wrftladj/module_diffusion_em_tl.F

   1
   2 ! ======================================================================================
   3 ! This file was generated by the version 5.3.6 of DFT on 08/10/2010. The differentiation
   4 ! transforming system(DFT) was jointly developed and sponsored by LASG of IAP(1998-2010)
   5 ! and LSEC of ICMSEC, AMSS(2001-2003)
   6 ! The copyright of the DFT system was declared by Walls at LASG, 1998-2010
   7 ! ======================================================================================
   8
   9  MODULE g_module_diffusion_em
  10
  11  USE g_module_bc, only: g_set_physical_bc3d
  12  USE module_state_description, only: p_m23, p_m13, p_m22, p_m33, p_r23, p_r13, p_r12, p_m12, p_m11
  13  USE g_module_big_step_utilities_em, only: grid_config_rec_type, param_first_scalar, p_qv, p_qi, p_qc
  14
  15  USE module_model_constants
  16
  17  CONTAINS
  18
  19  SUBROUTINE g_cal_deform_and_div(config_flags,u,g_u,v,g_v,w,g_w,div, &
  20  g_div,defor11,g_defor11,defor22,g_defor22,defor33,g_defor33,defor12, &
  21  g_defor12,defor13,g_defor13,defor23,g_defor23,nba_rij,g_nba_rij, &
  22  n_nba_rij,u_base,v_base,msfux,msfuy,msfvx,msfvy,msftx,msfty,rdx,rdy,dn,dnw,rdz, &
  23  g_rdz,rdzw,g_rdzw,fnm,fnp,cf1,cf2,cf3,zx,g_zx,zy,g_zy,ids,ide,jds,jde, &
  24  kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
  25
  26  IMPLICIT NONE
  27
  28  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
  29  g_Tmpv5,Tmpv6,g_Tmpv6
  30  TYPE(grid_config_rec_type) :: config_flags
  31  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
  32  REAL :: rdx,rdy,cf1,cf2,cf3
  33  REAL,DIMENSION(kms:kme) :: fnm,fnp,dn,dnw,u_base,v_base
  34  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
  35  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v,w,g_w,zx,g_zx,zy, &
  36  g_zy,rdz,g_rdz,rdzw,g_rdzw
  37  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
  38  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
  39  div,g_div
  40
  41  INTEGER :: n_nba_rij
  42
  43  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_rij) :: nba_rij,g_nba_rij
  44  INTEGER :: i,j,k,ktf,ktes1,ktes2,i_start,i_end,j_start,j_end
  45  REAL :: tmp,g_tmp,tmpzx,g_tmpzx,tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z,cft1, &
  46  g_cft1,cft2,g_cft2
  47  REAL,DIMENSION(its:ite,jts:jte) :: mm,g_mm,zzavg,g_zzavg,zeta_zd12,g_zeta_zd12
  48  REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: tmp1,g_tmp1,hat,g_hat, &
  49  hatavg,g_hatavg
  50
  51  ktes1 =kte-1
  52
  53  ktes2 =kte-2
  54
  55  g_cft2 =0.0
  56  cft2 =-0.5 *dnw(ktes1)/dn(ktes1)
  57
  58  g_cft1 =-g_cft2
  59  cft1 =1.0 -cft2
  60
  61  ktf =min(kte,kde-1)
  62
  63  i_start =its
  64
  65  i_end =min(ite,ide-1)
  66
  67  j_start =jts
  68
  69  j_end =min(jte,jde-1)
  70
  71  DO j =j_start,j_end
  72  DO i =i_start,i_end
  73
  74  g_mm(i,j) =0.0
  75  mm(i,j) =msftx(i,j) *msfty(i,j)
  76
  77  ENDDO
  78  ENDDO
  79
  80  DO j =j_start,j_end
  81  DO k =kts,ktf
  82  DO i =i_start,i_end+1
  83
  84  g_hat(i,k,j) =g_u(i,k,j)/msfuy(i,j)
  85  hat(i,k,j) =u(i,k,j)/msfuy(i,j)
  86
  87  ENDDO
  88  ENDDO
  89  ENDDO
  90
  91  DO j =j_start,j_end
  92  DO k =kts+1,ktf
  93  DO i =i_start,i_end
  94
  95  g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i,k,j) +g_hat(i+1,k,j)) +fnp(k) &
  96 *(g_hat(i,k-1,j) +g_hat(i+1,k-1,j)))
  97  hatavg(i,k,j) =0.5*(fnm(k)*(hat(i,k,j) +hat(i+1,k,j)) +fnp(k)*(hat(i,k-1,j) &
  98  +hat(i+1,k-1,j)))
  99
 100  ENDDO
 101  ENDDO
 102  ENDDO
 103
 104  DO j =j_start,j_end
 105  DO i =i_start,i_end
 106
 107  g_hatavg(i,1,j) =0.5*(cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3, &
 108  j) +cf1*g_hat(i+1,1,j) +cf2*g_hat(i+1,2,j) +cf3*g_hat(i+1,3,j))
 109  hatavg(i,1,j) =0.5*(cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j) +cf1*hat(i+1,1,j) &
 110  +cf2*hat(i+1,2,j) +cf3*hat(i+1,3,j))
 111
 112  g_Tmpv1 =cft1*(g_hat(i,ktes1,j) +g_hat(i+1,ktes1,j)) +g_cft1*(hat(i, &
 113  ktes1,j) +hat(i+1,ktes1,j))
 114  Tmpv1 =cft1*(hat(i,ktes1,j) +hat(i+1,ktes1,j))
 115
 116  g_Tmpv2 =cft2*(g_hat(i,ktes2,j) +g_hat(i+1,ktes2,j)) +g_cft2*(hat(i, &
 117  ktes2,j) +hat(i+1,ktes2,j))
 118  Tmpv2 =cft2*(hat(i,ktes2,j) +hat(i+1,ktes2,j))
 119
 120  g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
 121  hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
 122
 123  ENDDO
 124  ENDDO
 125
 126 !LPB[5]
 127
 128  DO j =j_start,j_end
 129  DO k =kts,ktf
 130  DO i =i_start,i_end
 131
 132  g_tmpzx =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k+1,j) +g_zx(i+1,k+1,j))
 133  tmpzx =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k+1,j) +zx(i+1,k+1,j))
 134
 135  g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*g_tmpzx +(g_hatavg(i,k+1,j) &
 136  -g_hatavg(i,k,j))*tmpzx
 137  Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*tmpzx
 138
 139  g_Tmpv2 =Tmpv1*g_rdzw(i,k,j) +g_Tmpv1*rdzw(i,k,j)
 140  Tmpv2 =Tmpv1*rdzw(i,k,j)
 141
 142  g_tmp1(i,k,j) =g_Tmpv2
 143  tmp1(i,k,j) =Tmpv2
 144
 145  ENDDO
 146  ENDDO
 147  ENDDO
 148
 149 !LPB[6]
 150
 151  DO j =j_start,j_end
 152  DO k =kts,ktf
 153  DO i =i_start,i_end
 154
 155  g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i+1,k,j) -g_hat(i,k,j)) -g_tmp1(i,k,j)) &
 156  +g_mm(i,j)*(rdx*(hat(i+1,k,j) -hat(i,k,j)) -tmp1(i,k,j))
 157  Tmpv1 =mm(i,j)*(rdx*(hat(i+1,k,j) -hat(i,k,j)) -tmp1(i,k,j))
 158
 159  g_tmp1(i,k,j) =g_Tmpv1
 160  tmp1(i,k,j) =Tmpv1
 161
 162  ENDDO
 163  ENDDO
 164  ENDDO
 165
 166  DO j =j_start,j_end
 167  DO k =kts,ktf
 168  DO i =i_start,i_end
 169
 170  g_defor11(i,k,j) =2.0*g_tmp1(i,k,j)
 171  defor11(i,k,j) =2.0*tmp1(i,k,j)
 172
 173  ENDDO
 174  ENDDO
 175  ENDDO
 176
 177  DO j =j_start,j_end
 178  DO k =kts,ktf
 179  DO i =i_start,i_end
 180
 181  g_div(i,k,j) =g_tmp1(i,k,j)
 182  div(i,k,j) =tmp1(i,k,j)
 183
 184  ENDDO
 185  ENDDO
 186  ENDDO
 187
 188 !LPB[9]
 189
 190  DO j =j_start,j_end+1
 191  DO k =kts,ktf
 192  DO i =i_start,i_end
 193
 194  IF((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
 195
 196  g_hat(i,k,j) =0.0
 197  hat(i,k,j) =0.
 198
 199  ELSE
 200
 201  g_hat(i,k,j) =g_v(i,k,j)/msfvx(i,j)
 202  hat(i,k,j) =v(i,k,j)/msfvx(i,j)
 203
 204  ENDIF
 205  ENDDO
 206  ENDDO
 207  ENDDO
 208
 209 !LPB[10]
 210
 211  DO j =j_start,j_end
 212  DO k =kts+1,ktf
 213  DO i =i_start,i_end
 214
 215  g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i,k,j) +g_hat(i,k,j+1)) +fnp(k) &
 216 *(g_hat(i,k-1,j) +g_hat(i,k-1,j+1)))
 217  hatavg(i,k,j) =0.5*(fnm(k)*(hat(i,k,j) +hat(i,k,j+1)) +fnp(k)*(hat(i,k-1,j) &
 218  +hat(i,k-1,j+1)))
 219
 220  ENDDO
 221  ENDDO
 222  ENDDO
 223
 224 !LPB[11]
 225
 226  DO j =j_start,j_end
 227  DO i =i_start,i_end
 228
 229  g_hatavg(i,1,j) =0.5*(cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3, &
 230  j) +cf1*g_hat(i,1,j+1) +cf2*g_hat(i,2,j+1) +cf3*g_hat(i,3,j+1))
 231  hatavg(i,1,j) =0.5*(cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j) +cf1*hat(i,1,j+1) &
 232  +cf2*hat(i,2,j+1) +cf3*hat(i,3,j+1))
 233
 234  g_Tmpv1 =cft1*(g_hat(i,ktes1,j) +g_hat(i,ktes1,j+1)) +g_cft1*(hat(i, &
 235  ktes1,j) +hat(i,ktes1,j+1))
 236  Tmpv1 =cft1*(hat(i,ktes1,j) +hat(i,ktes1,j+1))
 237
 238  g_Tmpv2 =cft2*(g_hat(i,ktes2,j) +g_hat(i,ktes2,j+1)) +g_cft2*(hat(i, &
 239  ktes2,j) +hat(i,ktes2,j+1))
 240  Tmpv2 =cft2*(hat(i,ktes2,j) +hat(i,ktes2,j+1))
 241
 242  g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
 243  hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
 244
 245  ENDDO
 246  ENDDO
 247
 248 !LPB[12]
 249
 250  DO j =j_start,j_end
 251  DO k =kts,ktf
 252  DO i =i_start,i_end
 253
 254  g_tmpzy =0.25*(g_zy(i,k,j) +g_zy(i,k,j+1) +g_zy(i,k+1,j) +g_zy(i,k+1,j+1))
 255  tmpzy =0.25*(zy(i,k,j) +zy(i,k,j+1) +zy(i,k+1,j) +zy(i,k+1,j+1))
 256
 257  g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*g_tmpzy +(g_hatavg(i,k+1,j) &
 258  -g_hatavg(i,k,j))*tmpzy
 259  Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*tmpzy
 260
 261  g_Tmpv2 =Tmpv1*g_rdzw(i,k,j) +g_Tmpv1*rdzw(i,k,j)
 262  Tmpv2 =Tmpv1*rdzw(i,k,j)
 263
 264  g_tmp1(i,k,j) =g_Tmpv2
 265  tmp1(i,k,j) =Tmpv2
 266
 267  ENDDO
 268  ENDDO
 269  ENDDO
 270
 271  DO j =j_start,j_end
 272  DO k =kts,ktf
 273  DO i =i_start,i_end
 274
 275  g_Tmpv1 =mm(i,j)*(rdy*(g_hat(i,k,j+1) -g_hat(i,k,j)) -g_tmp1(i,k,j)) &
 276  +g_mm(i,j)*(rdy*(hat(i,k,j+1) -hat(i,k,j)) -tmp1(i,k,j))
 277  Tmpv1 =mm(i,j)*(rdy*(hat(i,k,j+1) -hat(i,k,j)) -tmp1(i,k,j))
 278
 279  g_tmp1(i,k,j) =g_Tmpv1
 280  tmp1(i,k,j) =Tmpv1
 281
 282  ENDDO
 283  ENDDO
 284  ENDDO
 285
 286  DO j =j_start,j_end
 287  DO k =kts,ktf
 288  DO i =i_start,i_end
 289
 290  g_defor22(i,k,j) =2.0*g_tmp1(i,k,j)
 291  defor22(i,k,j) =2.0*tmp1(i,k,j)
 292
 293  ENDDO
 294  ENDDO
 295  ENDDO
 296
 297 !LPB[15]
 298  DO j =j_start,j_end
 299  DO k =kts,ktf
 300  DO i =i_start,i_end
 301
 302  g_div(i,k,j) =g_div(i,k,j) +g_tmp1(i,k,j)
 303  div(i,k,j) =div(i,k,j) +tmp1(i,k,j)
 304
 305  ENDDO
 306  ENDDO
 307  ENDDO
 308
 309  DO j =j_start,j_end
 310  DO k =kts,ktf
 311  DO i =i_start,i_end
 312
 313  g_Tmpv1 =(w(i,k+1,j) -w(i,k,j))*g_rdzw(i,k,j) +(g_w(i,k+1,j) -g_w(i,k, &
 314  j))*rdzw(i,k,j)
 315  Tmpv1 =(w(i,k+1,j) -w(i,k,j))*rdzw(i,k,j)
 316
 317  g_tmp1(i,k,j) =g_Tmpv1
 318  tmp1(i,k,j) =Tmpv1
 319
 320  ENDDO
 321  ENDDO
 322  ENDDO
 323
 324  DO j =j_start,j_end
 325  DO k =kts,ktf
 326  DO i =i_start,i_end
 327
 328  g_defor33(i,k,j) =2.0*g_tmp1(i,k,j)
 329  defor33(i,k,j) =2.0*tmp1(i,k,j)
 330
 331  ENDDO
 332  ENDDO
 333  ENDDO
 334
 335 !LPB[18]
 336  DO j =j_start,j_end
 337  DO k =kts,ktf
 338  DO i =i_start,i_end
 339
 340  g_div(i,k,j) =g_div(i,k,j) +g_tmp1(i,k,j)
 341  div(i,k,j) =div(i,k,j) +tmp1(i,k,j)
 342
 343  ENDDO
 344  ENDDO
 345  ENDDO
 346
 347 !LPB[19]
 348  i_start =its
 349
 350  i_end =ite
 351
 352  j_start =jts
 353
 354  j_end =jte
 355
 356  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
 357          config_flags%nested) i_start =max(ids+1,its)
 358
 359  IF( config_flags%open_xe .OR. config_flags%specified .OR.    &
 360          config_flags%nested) i_end =min(ide-1,ite)
 361
 362  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
 363          config_flags%nested) j_start =max(jds+1,jts)
 364
 365  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
 366          config_flags%nested) j_end =min(jde-1,jte)
 367
 368  IF( config_flags%periodic_x ) i_start =its
 369
 370  IF( config_flags%periodic_x ) i_end =ite
 371
 372  DO j =j_start,j_end
 373  DO i =i_start,i_end
 374
 375  g_mm(i,j) =0.0
 376  mm(i,j) =0.25 *(msfux(i,j-1)+msfux(i,j)) *(msfvy(i-1,j)+msfvy(i,j))
 377
 378  ENDDO
 379  ENDDO
 380
 381  DO j =j_start-1,j_end
 382  DO k =kts,ktf
 383  DO i =i_start,i_end
 384
 385  g_hat(i,k,j) =g_u(i,k,j)/msfux(i,j)
 386  hat(i,k,j) =u(i,k,j)/msfux(i,j)
 387
 388  ENDDO
 389  ENDDO
 390  ENDDO
 391
 392  DO j =j_start,j_end
 393  DO k =kts+1,ktf
 394  DO i =i_start,i_end
 395
 396  g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i,k,j-1) +g_hat(i,k,j)) +fnp(k) &
 397 *(g_hat(i,k-1,j-1) +g_hat(i,k-1,j)))
 398  hatavg(i,k,j) =0.5*(fnm(k)*(hat(i,k,j-1) +hat(i,k,j)) +fnp(k)*(hat(i,k-1,j-1) &
 399  +hat(i,k-1,j)))
 400
 401  ENDDO
 402  ENDDO
 403  ENDDO
 404
 405  DO j =j_start,j_end
 406  DO i =i_start,i_end
 407
 408  g_hatavg(i,1,j) =0.5*(cf1*g_hat(i,1,j-1) +cf2*g_hat(i,2,j-1) +cf3*g_hat( &
 409  i,3,j-1) +cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3,j))
 410  hatavg(i,1,j) =0.5*(cf1*hat(i,1,j-1) +cf2*hat(i,2,j-1) +cf3*hat(i,3,j-1) &
 411  +cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j))
 412
 413  g_Tmpv1 =cft1*(g_hat(i,ktes1,j-1) +g_hat(i,ktes1,j)) +g_cft1*(hat(i, &
 414  ktes1,j-1) +hat(i,ktes1,j))
 415  Tmpv1 =cft1*(hat(i,ktes1,j-1) +hat(i,ktes1,j))
 416
 417  g_Tmpv2 =cft2*(g_hat(i,ktes2,j-1) +g_hat(i,ktes2,j)) +g_cft2*(hat(i, &
 418  ktes2,j-1) +hat(i,ktes2,j))
 419  Tmpv2 =cft2*(hat(i,ktes2,j-1) +hat(i,ktes2,j))
 420
 421  g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
 422  hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
 423
 424  ENDDO
 425  ENDDO
 426
 427 !LPB[35]
 428
 429  DO j =j_start,j_end
 430  DO k =kts,ktf
 431  DO i =i_start,i_end
 432
 433  g_tmpzy =0.25*(g_zy(i-1,k,j) +g_zy(i,k,j) +g_zy(i-1,k+1,j) +g_zy(i,k+1,j))
 434  tmpzy =0.25*(zy(i-1,k,j) +zy(i,k,j) +zy(i-1,k+1,j) +zy(i,k+1,j))
 435
 436  g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*g_tmpzy +(g_hatavg(i,k+1,j) &
 437  -g_hatavg(i,k,j))*0.25*tmpzy
 438  Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*tmpzy
 439
 440  g_Tmpv2 =Tmpv1*(g_rdzw(i,k,j) +g_rdzw(i-1,k,j) +g_rdzw(i-1,k,j-1) &
 441  +g_rdzw(i,k,j-1)) +g_Tmpv1*(rdzw(i,k,j) +rdzw(i-1,k,j) +rdzw(i-1,k,j-1) +rdzw(i,k,j-1))
 442  Tmpv2 =Tmpv1*(rdzw(i,k,j) +rdzw(i-1,k,j) +rdzw(i-1,k,j-1) +rdzw(i,k,j-1))
 443
 444  g_tmp1(i,k,j) =g_Tmpv2
 445  tmp1(i,k,j) =Tmpv2
 446
 447  ENDDO
 448  ENDDO
 449  ENDDO
 450
 451  DO j =j_start,j_end
 452  DO k =kts,ktf
 453  DO i =i_start,i_end
 454
 455  g_Tmpv1 =mm(i,j)*(rdy*(g_hat(i,k,j) -g_hat(i,k,j-1)) -g_tmp1(i,k,j)) &
 456  +g_mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
 457  Tmpv1 =mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
 458
 459  g_defor12(i,k,j) =g_Tmpv1
 460  defor12(i,k,j) =Tmpv1
 461
 462  ENDDO
 463  ENDDO
 464  ENDDO
 465
 466 !LPB[37]
 467  DO j =j_start,j_end
 468  DO k =kts,ktf
 469  DO i =i_start-1,i_end
 470
 471  g_hat(i,k,j) =g_v(i,k,j)/msfvy(i,j)
 472  hat(i,k,j) =v(i,k,j)/msfvy(i,j)
 473
 474  ENDDO
 475  ENDDO
 476  ENDDO
 477
 478  DO j =j_start,j_end
 479  DO k =kts+1,ktf
 480  DO i =i_start,i_end
 481
 482  g_hatavg(i,k,j) =0.5*(fnm(k)*(g_hat(i-1,k,j) +g_hat(i,k,j)) +fnp(k) &
 483 *(g_hat(i-1,k-1,j) +g_hat(i,k-1,j)))
 484  hatavg(i,k,j) =0.5*(fnm(k)*(hat(i-1,k,j) +hat(i,k,j)) +fnp(k)*(hat(i-1,k-1,j) &
 485  +hat(i,k-1,j)))
 486
 487  ENDDO
 488  ENDDO
 489  ENDDO
 490
 491  DO j =j_start,j_end
 492  DO i =i_start,i_end
 493
 494  g_hatavg(i,1,j) =0.5*(cf1*g_hat(i-1,1,j) +cf2*g_hat(i-1,2,j) +cf3*g_hat( &
 495  i-1,3,j) +cf1*g_hat(i,1,j) +cf2*g_hat(i,2,j) +cf3*g_hat(i,3,j))
 496  hatavg(i,1,j) =0.5*(cf1*hat(i-1,1,j) +cf2*hat(i-1,2,j) +cf3*hat(i-1,3,j) &
 497  +cf1*hat(i,1,j) +cf2*hat(i,2,j) +cf3*hat(i,3,j))
 498
 499  g_Tmpv1 =cft1*(g_hat(i,ktes1,j) +g_hat(i-1,ktes1,j)) +g_cft1*(hat(i, &
 500  ktes1,j) +hat(i-1,ktes1,j))
 501  Tmpv1 =cft1*(hat(i,ktes1,j) +hat(i-1,ktes1,j))
 502
 503  g_Tmpv2 =cft2*(g_hat(i,ktes2,j) +g_hat(i-1,ktes2,j)) +g_cft2*(hat(i, &
 504  ktes2,j) +hat(i-1,ktes2,j))
 505  Tmpv2 =cft2*(hat(i,ktes2,j) +hat(i-1,ktes2,j))
 506
 507  g_hatavg(i,kte,j) =0.5*(g_Tmpv1 +g_Tmpv2)
 508  hatavg(i,kte,j) =0.5*(Tmpv1 +Tmpv2)
 509
 510  ENDDO
 511  ENDDO
 512
 513 !LPB[40]
 514  DO j =j_start,j_end
 515  DO k =kts,ktf
 516  DO i =i_start,i_end
 517
 518  g_tmpzx =0.25*(g_zx(i,k,j-1) +g_zx(i,k,j) +g_zx(i,k+1,j-1) +g_zx(i,k+1,j))
 519  tmpzx =0.25*(zx(i,k,j-1) +zx(i,k,j) +zx(i,k+1,j-1) +zx(i,k+1,j))
 520
 521  g_Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*g_tmpzx +(g_hatavg(i,k+1,j) &
 522  -g_hatavg(i,k,j))*0.25*tmpzx
 523  Tmpv1 =(hatavg(i,k+1,j) -hatavg(i,k,j))*0.25*tmpzx
 524
 525  g_Tmpv2 =Tmpv1*(g_rdzw(i,k,j) +g_rdzw(i,k,j-1) +g_rdzw(i-1,k,j-1) &
 526  +g_rdzw(i-1,k,j)) +g_Tmpv1*(rdzw(i,k,j) +rdzw(i,k,j-1) +rdzw(i-1,k,j-1) +rdzw(i-1,k,j))
 527  Tmpv2 =Tmpv1*(rdzw(i,k,j) +rdzw(i,k,j-1) +rdzw(i-1,k,j-1) +rdzw(i-1,k,j))
 528
 529  g_tmp1(i,k,j) =g_Tmpv2
 530  tmp1(i,k,j) =Tmpv2
 531
 532  ENDDO
 533  ENDDO
 534  ENDDO
 535
 536 !LPB[42]
 537  IF( config_flags%sfs_opt .GT. 0 ) THEN
 538
 539  DO j =j_start,j_end
 540  DO k =kts,ktf
 541  DO i =i_start,i_end
 542
 543  g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
 544  +g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 545  Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 546
 547  g_nba_rij(i,k,j,P_r12) =g_defor12(i,k,j) -g_Tmpv1
 548  nba_rij(i,k,j,P_r12) =defor12(i,k,j) -Tmpv1
 549
 550  g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
 551  +g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 552  Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 553
 554  g_defor12(i,k,j) =g_defor12(i,k,j) +g_Tmpv1
 555  defor12(i,k,j) =defor12(i,k,j) +Tmpv1
 556
 557  ENDDO
 558  ENDDO
 559  ENDDO
 560
 561  IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
 562
 563  DO j =jts,jte
 564  DO k =kts,kte
 565
 566  g_defor12(ids,k,j) =g_defor12(ids+1,k,j)
 567  defor12(ids,k,j) =defor12(ids+1,k,j)
 568
 569  g_nba_rij(ids,k,j,P_r12) =g_nba_rij(ids+1,k,j,P_r12)
 570  nba_rij(ids,k,j,P_r12) =nba_rij(ids+1,k,j,P_r12)
 571
 572  ENDDO
 573  ENDDO
 574  END IF
 575
 576  IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
 577
 578  DO k =kts,kte
 579  DO i =its,ite
 580
 581  g_defor12(i,k,jds) =g_defor12(i,k,jds+1)
 582  defor12(i,k,jds) =defor12(i,k,jds+1)
 583
 584  g_nba_rij(i,k,jds,P_r12) =g_nba_rij(i,k,jds+1,P_r12)
 585  nba_rij(i,k,jds,P_r12) =nba_rij(i,k,jds+1,P_r12)
 586
 587  ENDDO
 588  ENDDO
 589  END IF
 590
 591  IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
 592
 593  DO j =jts,jte
 594  DO k =kts,kte
 595
 596  g_defor12(ide,k,j) =g_defor12(ide-1,k,j)
 597  defor12(ide,k,j) =defor12(ide-1,k,j)
 598
 599  g_nba_rij(ide,k,j,P_r12) =g_nba_rij(ide-1,k,j,P_r12)
 600  nba_rij(ide,k,j,P_r12) =nba_rij(ide-1,k,j,P_r12)
 601
 602  ENDDO
 603  ENDDO
 604  END IF
 605
 606  IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
 607
 608  DO k =kts,kte
 609  DO i =its,ite
 610
 611  g_defor12(i,k,jde) =g_defor12(i,k,jde-1)
 612  defor12(i,k,jde) =defor12(i,k,jde-1)
 613
 614  g_nba_rij(i,k,jde,P_r12) =g_nba_rij(i,k,jde-1,P_r12)
 615  nba_rij(i,k,jde,P_r12) =nba_rij(i,k,jde-1,P_r12)
 616
 617  ENDDO
 618  ENDDO
 619  END IF
 620
 621  ELSE
 622
 623  DO j =j_start,j_end
 624  DO k =kts,ktf
 625  DO i =i_start,i_end
 626
 627  g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
 628  +g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 629  Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 630
 631  g_defor12(i,k,j) =g_defor12(i,k,j) +g_Tmpv1
 632  defor12(i,k,j) =defor12(i,k,j) +Tmpv1
 633
 634  ENDDO
 635  ENDDO
 636  ENDDO
 637
 638  IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
 639
 640  DO j =jts,jte
 641  DO k =kts,kte
 642
 643  g_defor12(ids,k,j) =g_defor12(ids+1,k,j)
 644  defor12(ids,k,j) =defor12(ids+1,k,j)
 645
 646  ENDDO
 647  ENDDO
 648  END IF
 649
 650  IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
 651
 652  DO k =kts,kte
 653  DO i =its,ite
 654
 655  g_defor12(i,k,jds) =g_defor12(i,k,jds+1)
 656  defor12(i,k,jds) =defor12(i,k,jds+1)
 657
 658  ENDDO
 659  ENDDO
 660  END IF
 661
 662  IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
 663
 664  DO j =jts,jte
 665  DO k =kts,kte
 666
 667  g_defor12(ide,k,j) =g_defor12(ide-1,k,j)
 668  defor12(ide,k,j) =defor12(ide-1,k,j)
 669
 670  ENDDO
 671  ENDDO
 672  END IF
 673
 674  IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
 675
 676  DO k =kts,kte
 677  DO i =its,ite
 678
 679  g_defor12(i,k,jde) =g_defor12(i,k,jde-1)
 680  defor12(i,k,jde) =defor12(i,k,jde-1)
 681
 682  ENDDO
 683  ENDDO
 684  END IF
 685
 686  ENDIF
 687
 688  i_start =its
 689
 690  i_end =min(ite,ide-1)
 691
 692  j_start =jts
 693
 694  j_end =min(jte,jde-1)
 695
 696  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
 697          config_flags%nested) i_start =max(ids+1,its)
 698
 699  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
 700          config_flags%nested) j_start =max(jds+1,jts)
 701
 702  IF( config_flags%periodic_x ) i_start =its
 703
 704  IF( config_flags%periodic_x ) i_end =min(ite,ide)
 705
 706  IF( config_flags%periodic_y ) j_end =min(jte,jde)
 707
 708  DO j =jts,jte
 709  DO i =its,ite
 710
 711  g_mm(i,j) =0.0
 712  mm(i,j) =msfux(i,j) *msfuy(i,j)
 713
 714  ENDDO
 715  ENDDO
 716
 717  DO j =j_start,j_end
 718  DO k =kts,kte
 719  DO i =i_start,i_end
 720
 721  g_hat(i,k,j) =g_w(i,k,j)/msfty(i,j)
 722  hat(i,k,j) =w(i,k,j)/msfty(i,j)
 723
 724  ENDDO
 725  ENDDO
 726  ENDDO
 727
 728  i =i_start-1
 729
 730  DO j =j_start,min(jte,jde-1)
 731  DO k =kts,kte
 732
 733  g_hat(i,k,j) =g_w(i,k,j)/msfty(i,j)
 734  hat(i,k,j) =w(i,k,j)/msfty(i,j)
 735
 736  ENDDO
 737  ENDDO
 738
 739  j =j_start-1
 740
 741  DO k =kts,kte
 742  DO i =i_start,min(ite,ide-1)
 743
 744  g_hat(i,k,j) =g_w(i,k,j)/msfty(i,j)
 745  hat(i,k,j) =w(i,k,j)/msfty(i,j)
 746
 747  ENDDO
 748  ENDDO
 749
 750  DO j =j_start,j_end
 751  DO k =kts,ktf
 752  DO i =i_start,i_end
 753
 754  g_hatavg(i,k,j) =0.25*(g_hat(i,k,j) +g_hat(i,k+1,j) +g_hat(i-1,k,j) &
 755  +g_hat(i-1,k+1,j))
 756  hatavg(i,k,j) =0.25*(hat(i,k,j) +hat(i,k+1,j) +hat(i-1,k,j) +hat(i-1,k+1,j))
 757
 758  ENDDO
 759  ENDDO
 760  ENDDO
 761
 762  DO j =j_start,j_end
 763  DO k =kts+1,ktf
 764  DO i =i_start,i_end
 765
 766  g_Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*g_zx(i,k,j) +(g_hatavg(i,k,j) &
 767  -g_hatavg(i,k-1,j))*zx(i,k,j)
 768  Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*zx(i,k,j)
 769
 770  g_Tmpv2 =Tmpv1*0.5*(g_rdz(i,k,j) +g_rdz(i-1,k,j)) +g_Tmpv1*0.5*(rdz(i,k, &
 771  j) +rdz(i-1,k,j))
 772  Tmpv2 =Tmpv1*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
 773
 774  g_tmp1(i,k,j) =g_Tmpv2
 775  tmp1(i,k,j) =Tmpv2
 776
 777  ENDDO
 778  ENDDO
 779  ENDDO
 780
 781  DO j =j_start,j_end
 782  DO k =kts+1,ktf
 783  DO i =i_start,i_end
 784
 785  g_Tmpv1 =mm(i,j)*(rdx*(g_hat(i,k,j) -g_hat(i-1,k,j)) -g_tmp1(i,k,j)) &
 786  +g_mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 787  Tmpv1 =mm(i,j)*(rdx*(hat(i,k,j) -hat(i-1,k,j)) -tmp1(i,k,j))
 788
 789  g_defor13(i,k,j) =g_Tmpv1
 790  defor13(i,k,j) =Tmpv1
 791
 792  ENDDO
 793  ENDDO
 794  ENDDO
 795
 796  DO j =j_start,j_end
 797  DO i =i_start,i_end
 798
 799  g_defor13(i,kts,j) =0.0
 800  defor13(i,kts,j) =0.0
 801
 802  g_defor13(i,ktf+1,j) =0.0
 803  defor13(i,ktf+1,j) =0.0
 804
 805  ENDDO
 806  ENDDO
 807
 808  IF( config_flags%mix_full_fields ) THEN
 809
 810  DO j =j_start,j_end
 811  DO k =kts+1,ktf
 812  DO i =i_start,i_end
 813
 814  g_Tmpv1 =(u(i,k,j) -u(i,k-1,j))*0.5*(g_rdz(i,k,j) +g_rdz(i-1,k,j)) &
 815  +(g_u(i,k,j) -g_u(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
 816  Tmpv1 =(u(i,k,j) -u(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
 817
 818  g_tmp1(i,k,j) =g_Tmpv1
 819  tmp1(i,k,j) =Tmpv1
 820
 821  ENDDO
 822  ENDDO
 823  ENDDO
 824  ELSE
 825
 826  DO j =j_start,j_end
 827  DO k =kts+1,ktf
 828  DO i =i_start,i_end
 829
 830  g_Tmpv1 =(u(i,k,j) -u_base(k) -u(i,k-1,j) +u_base(k-1))*0.5*(g_rdz(i,k,j) &
 831  +g_rdz(i-1,k,j)) +(g_u(i,k,j) -g_u(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
 832  Tmpv1 =(u(i,k,j) -u_base(k) -u(i,k-1,j) +u_base(k-1))*0.5*(rdz(i,k,j) +rdz(i-1,k,j))
 833
 834  g_tmp1(i,k,j) =g_Tmpv1
 835  tmp1(i,k,j) =Tmpv1
 836
 837  ENDDO
 838  ENDDO
 839  ENDDO
 840  END IF
 841
 842 !LPB[66]
 843
 844  IF( config_flags%sfs_opt .GT. 0 ) THEN
 845
 846  DO j =j_start,j_end
 847  DO k =kts+1,ktf
 848  DO i =i_start,i_end
 849
 850  g_nba_rij(i,k,j,P_r13) =g_tmp1(i,k,j) -g_defor13(i,k,j)
 851  nba_rij(i,k,j,P_r13) =tmp1(i,k,j) -defor13(i,k,j)
 852
 853  g_defor13(i,k,j) =g_defor13(i,k,j) +g_tmp1(i,k,j)
 854  defor13(i,k,j) =defor13(i,k,j) +tmp1(i,k,j)
 855
 856  ENDDO
 857  ENDDO
 858  ENDDO
 859
 860  DO j =j_start,j_end
 861  DO i =i_start,i_end
 862
 863  g_nba_rij(i,kts,j,P_r13) =0.0
 864  nba_rij(i,kts,j,P_r13) =0.0
 865
 866  g_nba_rij(i,ktf+1,j,P_r13) =0.0
 867  nba_rij(i,ktf+1,j,P_r13) =0.0
 868
 869  ENDDO
 870  ENDDO
 871
 872  ELSE
 873
 874  DO j =j_start,j_end
 875  DO k =kts+1,ktf
 876  DO i =i_start,i_end
 877
 878  g_defor13(i,k,j) =g_defor13(i,k,j) +g_tmp1(i,k,j)
 879  defor13(i,k,j) =defor13(i,k,j) +tmp1(i,k,j)
 880
 881  ENDDO
 882  ENDDO
 883  ENDDO
 884
 885  ENDIF
 886
 887 !LPB[67]
 888
 889  i_start =its
 890
 891  i_end =min(ite,ide-1)
 892
 893  j_start =jts
 894
 895  j_end =min(jte,jde-1)
 896
 897  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
 898          config_flags%nested) i_start =max(ids+1,its)
 899
 900  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
 901          config_flags%nested) j_start =max(jds+1,jts)
 902
 903  IF( config_flags%periodic_y ) j_end =min(jte,jde)
 904
 905  IF( config_flags%periodic_x ) i_start =its
 906
 907  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
 908
 909  DO j =jts,jte
 910  DO i =its,ite
 911
 912  g_mm(i,j) =0.0
 913  mm(i,j) =msfvx(i,j) *msfvy(i,j)
 914
 915  ENDDO
 916  ENDDO
 917
 918  DO j =j_start,j_end
 919  DO k =kts,kte
 920  DO i =i_start,i_end
 921
 922  g_hat(i,k,j) =g_w(i,k,j)/msftx(i,j)
 923  hat(i,k,j) =w(i,k,j)/msftx(i,j)
 924
 925  ENDDO
 926  ENDDO
 927  ENDDO
 928
 929  i =i_start-1
 930
 931  DO j =j_start,min(jte,jde-1)
 932  DO k =kts,kte
 933
 934  g_hat(i,k,j) =g_w(i,k,j)/msftx(i,j)
 935  hat(i,k,j) =w(i,k,j)/msftx(i,j)
 936
 937  ENDDO
 938  ENDDO
 939
 940  j =j_start-1
 941
 942  DO k =kts,kte
 943  DO i =i_start,min(ite,ide-1)
 944
 945  g_hat(i,k,j) =g_w(i,k,j)/msftx(i,j)
 946  hat(i,k,j) =w(i,k,j)/msftx(i,j)
 947
 948  ENDDO
 949  ENDDO
 950
 951  DO j =j_start,j_end
 952  DO k =kts,ktf
 953  DO i =i_start,i_end
 954
 955  g_hatavg(i,k,j) =0.25*(g_hat(i,k,j) +g_hat(i,k+1,j) +g_hat(i,k,j-1) &
 956  +g_hat(i,k+1,j-1))
 957  hatavg(i,k,j) =0.25*(hat(i,k,j) +hat(i,k+1,j) +hat(i,k,j-1) +hat(i,k+1,j-1))
 958
 959  ENDDO
 960  ENDDO
 961  ENDDO
 962
 963  DO j =j_start,j_end
 964  DO k =kts+1,ktf
 965  DO i =i_start,i_end
 966
 967  g_Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*g_zy(i,k,j) +(g_hatavg(i,k,j) &
 968  -g_hatavg(i,k-1,j))*zy(i,k,j)
 969  Tmpv1 =(hatavg(i,k,j) -hatavg(i,k-1,j))*zy(i,k,j)
 970
 971  g_Tmpv2 =Tmpv1*0.5*(g_rdz(i,k,j) +g_rdz(i,k,j-1)) +g_Tmpv1*0.5*(rdz(i,k, &
 972  j) +rdz(i,k,j-1))
 973  Tmpv2 =Tmpv1*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
 974
 975  g_tmp1(i,k,j) =g_Tmpv2
 976  tmp1(i,k,j) =Tmpv2
 977
 978  ENDDO
 979  ENDDO
 980  ENDDO
 981
 982  DO j =j_start,j_end
 983  DO k =kts+1,ktf
 984  DO i =i_start,i_end
 985
 986  g_Tmpv1 =mm(i,j)*(rdy*(g_hat(i,k,j) -g_hat(i,k,j-1)) -g_tmp1(i,k,j)) &
 987  +g_mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
 988  Tmpv1 =mm(i,j)*(rdy*(hat(i,k,j) -hat(i,k,j-1)) -tmp1(i,k,j))
 989
 990  g_defor23(i,k,j) =g_Tmpv1
 991  defor23(i,k,j) =Tmpv1
 992
 993  ENDDO
 994  ENDDO
 995  ENDDO
 996
 997  DO j =j_start,j_end
 998  DO i =i_start,i_end
 999
1000  g_defor23(i,kts,j) =0.0
1001  defor23(i,kts,j) =0.0
1002
1003  g_defor23(i,ktf+1,j) =0.0
1004  defor23(i,ktf+1,j) =0.0
1005
1006  ENDDO
1007  ENDDO
1008
1009  IF( config_flags%mix_full_fields ) THEN
1010
1011  DO j =j_start,j_end
1012  DO k =kts+1,ktf
1013  DO i =i_start,i_end
1014
1015  g_Tmpv1 =(v(i,k,j) -v(i,k-1,j))*0.5*(g_rdz(i,k,j) +g_rdz(i,k,j-1)) &
1016  +(g_v(i,k,j) -g_v(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
1017  Tmpv1 =(v(i,k,j) -v(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
1018
1019  g_tmp1(i,k,j) =g_Tmpv1
1020  tmp1(i,k,j) =Tmpv1
1021
1022  ENDDO
1023  ENDDO
1024  ENDDO
1025  ELSE
1026
1027  DO j =j_start,j_end
1028  DO k =kts+1,ktf
1029  DO i =i_start,i_end
1030
1031  g_Tmpv1 =(v(i,k,j) -v_base(k) -v(i,k-1,j) +v_base(k-1))*0.5*(g_rdz(i,k,j) &
1032  +g_rdz(i,k,j-1)) +(g_v(i,k,j) -g_v(i,k-1,j))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
1033  Tmpv1 =(v(i,k,j) -v_base(k) -v(i,k-1,j) +v_base(k-1))*0.5*(rdz(i,k,j) +rdz(i,k,j-1))
1034
1035  g_tmp1(i,k,j) =g_Tmpv1
1036  tmp1(i,k,j) =Tmpv1
1037
1038  ENDDO
1039  ENDDO
1040  ENDDO
1041  END IF
1042
1043  IF( config_flags%sfs_opt .GT. 0 ) THEN
1044
1045  DO j =j_start,j_end
1046  DO k =kts+1,ktf
1047  DO i =i_start,i_end
1048
1049  g_nba_rij(i,k,j,P_r23) =g_tmp1(i,k,j) -g_defor23(i,k,j)
1050  nba_rij(i,k,j,P_r23) =tmp1(i,k,j) -defor23(i,k,j)
1051
1052  g_defor23(i,k,j) =g_defor23(i,k,j) +g_tmp1(i,k,j)
1053  defor23(i,k,j) =defor23(i,k,j) +tmp1(i,k,j)
1054
1055  ENDDO
1056  ENDDO
1057  ENDDO
1058
1059  DO j =j_start,j_end
1060  DO i =i_start,i_end
1061
1062  g_nba_rij(i,kts,j,P_r23) =0.0
1063  nba_rij(i,kts,j,P_r23) =0.0
1064
1065  g_nba_rij(i,ktf+1,j,P_r23) =0.0
1066  nba_rij(i,ktf+1,j,P_r23) =0.0
1067
1068  ENDDO
1069  ENDDO
1070
1071  IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
1072
1073  DO j =jts,jte
1074  DO k =kts,kte
1075
1076  g_defor13(ids,k,j) =g_defor13(ids+1,k,j)
1077  defor13(ids,k,j) =defor13(ids+1,k,j)
1078
1079  g_defor23(ids,k,j) =g_defor23(ids+1,k,j)
1080  defor23(ids,k,j) =defor23(ids+1,k,j)
1081
1082  g_nba_rij(ids,k,j,P_r13) =g_nba_rij(ids+1,k,j,P_r13)
1083  nba_rij(ids,k,j,P_r13) =nba_rij(ids+1,k,j,P_r13)
1084
1085  g_nba_rij(ids,k,j,P_r23) =g_nba_rij(ids+1,k,j,P_r23)
1086  nba_rij(ids,k,j,P_r23) =nba_rij(ids+1,k,j,P_r23)
1087
1088  ENDDO
1089  ENDDO
1090  END IF
1091
1092  IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
1093
1094  DO k =kts,kte
1095  DO i =its,ite
1096
1097  g_defor13(i,k,jds) =g_defor13(i,k,jds+1)
1098  defor13(i,k,jds) =defor13(i,k,jds+1)
1099
1100  g_defor23(i,k,jds) =g_defor23(i,k,jds+1)
1101  defor23(i,k,jds) =defor23(i,k,jds+1)
1102
1103  g_nba_rij(i,k,jds,P_r13) =g_nba_rij(i,k,jds+1,P_r13)
1104  nba_rij(i,k,jds,P_r13) =nba_rij(i,k,jds+1,P_r13)
1105
1106  g_nba_rij(i,k,jds,P_r23) =g_nba_rij(i,k,jds+1,P_r23)
1107  nba_rij(i,k,jds,P_r23) =nba_rij(i,k,jds+1,P_r23)
1108
1109  ENDDO
1110  ENDDO
1111  END IF
1112
1113  IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
1114
1115  DO j =jts,jte
1116  DO k =kts,kte
1117
1118  g_defor13(ide,k,j) =g_defor13(ide-1,k,j)
1119  defor13(ide,k,j) =defor13(ide-1,k,j)
1120
1121  g_defor23(ide,k,j) =g_defor23(ide-1,k,j)
1122  defor23(ide,k,j) =defor23(ide-1,k,j)
1123
1124  g_nba_rij(ide,k,j,P_r13) =g_nba_rij(ide-1,k,j,P_r13)
1125  nba_rij(ide,k,j,P_r13) =nba_rij(ide-1,k,j,P_r13)
1126
1127  g_nba_rij(ide,k,j,P_r23) =g_nba_rij(ide-1,k,j,P_r23)
1128  nba_rij(ide,k,j,P_r23) =nba_rij(ide-1,k,j,P_r23)
1129
1130  ENDDO
1131  ENDDO
1132  END IF
1133
1134  IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
1135
1136  DO k =kts,kte
1137  DO i =its,ite
1138
1139  g_defor13(i,k,jde) =g_defor13(i,k,jde-1)
1140  defor13(i,k,jde) =defor13(i,k,jde-1)
1141
1142  g_defor23(i,k,jde) =g_defor23(i,k,jde-1)
1143  defor23(i,k,jde) =defor23(i,k,jde-1)
1144
1145  g_nba_rij(i,k,jde,P_r13) =g_nba_rij(i,k,jde-1,P_r13)
1146  nba_rij(i,k,jde,P_r13) =nba_rij(i,k,jde-1,P_r13)
1147
1148  g_nba_rij(i,k,jde,P_r23) =g_nba_rij(i,k,jde-1,P_r23)
1149  nba_rij(i,k,jde,P_r23) =nba_rij(i,k,jde-1,P_r23)
1150
1151  ENDDO
1152  ENDDO
1153  END IF
1154
1155  ELSE
1156
1157  DO j =j_start,j_end
1158  DO k =kts+1,ktf
1159  DO i =i_start,i_end
1160
1161  g_defor23(i,k,j) =g_defor23(i,k,j) +g_tmp1(i,k,j)
1162  defor23(i,k,j) =defor23(i,k,j) +tmp1(i,k,j)
1163
1164  ENDDO
1165  ENDDO
1166  ENDDO
1167
1168  IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
1169
1170  DO j =jts,jte
1171  DO k =kts,kte
1172
1173  g_defor13(ids,k,j) =g_defor13(ids+1,k,j)
1174  defor13(ids,k,j) =defor13(ids+1,k,j)
1175
1176  g_defor23(ids,k,j) =g_defor23(ids+1,k,j)
1177  defor23(ids,k,j) =defor23(ids+1,k,j)
1178
1179  ENDDO
1180  ENDDO
1181  END IF
1182
1183  IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
1184
1185  DO k =kts,kte
1186  DO i =its,ite
1187
1188  g_defor13(i,k,jds) =g_defor13(i,k,jds+1)
1189  defor13(i,k,jds) =defor13(i,k,jds+1)
1190
1191  g_defor23(i,k,jds) =g_defor23(i,k,jds+1)
1192  defor23(i,k,jds) =defor23(i,k,jds+1)
1193
1194  ENDDO
1195  ENDDO
1196  END IF
1197
1198  IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
1199
1200  DO j =jts,jte
1201  DO k =kts,kte
1202
1203  g_defor13(ide,k,j) =g_defor13(ide-1,k,j)
1204  defor13(ide,k,j) =defor13(ide-1,k,j)
1205
1206  g_defor23(ide,k,j) =g_defor23(ide-1,k,j)
1207  defor23(ide,k,j) =defor23(ide-1,k,j)
1208
1209  ENDDO
1210  ENDDO
1211  END IF
1212
1213  IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
1214
1215  DO k =kts,kte
1216  DO i =its,ite
1217
1218  g_defor13(i,k,jde) =g_defor13(i,k,jde-1)
1219  defor13(i,k,jde) =defor13(i,k,jde-1)
1220
1221  g_defor23(i,k,jde) =g_defor23(i,k,jde-1)
1222  defor23(i,k,jde) =defor23(i,k,jde-1)
1223
1224  ENDDO
1225  ENDDO
1226  END IF
1227
1228  ENDIF
1229
1230  END SUBROUTINE g_cal_deform_and_div
1231
1232  SUBROUTINE g_calculate_km_kh(config_flags,dt,dampcoef,zdamp,damp_opt,xkmh, &
1233  g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv,g_xkhv,BN2,g_BN2,khdif,kvdif,div, &
1234  g_div,defor11,g_defor11,defor22,g_defor22,defor33,g_defor33,defor12, &
1235  g_defor12,defor13,g_defor13,defor23,g_defor23,tke,g_tke,p8w,g_p8w,t8w, &
1236  g_t8w,theta,g_theta,t,g_t,p,g_p,moist,g_moist,dn,dnw,dx,dy,rdz, &
1237  g_rdz,rdzw,g_rdzw,isotropic,n_moist,cf1,cf2,cf3,warm_rain,mix_upper_bound, &
1238  msftx,msfty,zx,g_zx,zy,g_zy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1239
1240  IMPLICIT NONE
1241
1242  REAL :: Tmpv1,g_Tmpv1
1243  TYPE(grid_config_rec_type) :: config_flags
1244  INTEGER :: n_moist,damp_opt,isotropic,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
1245  kme,its,ite,jts,jte,kts,kte
1246  LOGICAL :: warm_rain
1247  REAL :: dx,dy,zdamp,dt,dampcoef,cf1,cf2,cf3,khdif,kvdif
1248  REAL,DIMENSION(kms:kme) :: dnw,dn
1249  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,g_moist
1250  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmv,g_xkmv,xkmh,g_xkmh,xkhv, &
1251  g_xkhv,xkhh,g_xkhh,BN2,g_BN2
1252  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
1253  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
1254  div,g_div,rdz,g_rdz,rdzw,g_rdzw,p8w,g_p8w,t8w,g_t8w,theta,g_theta, &
1255  t,g_t,p,g_p,zx,g_zx,zy,g_zy
1256  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,g_tke
1257  REAL :: mix_upper_bound
1258  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
1259  INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k!,km_opt
1260
1261  ktf =min(kte,kde-1)
1262
1263  i_start =its
1264
1265  i_end =min(ite,ide-1)
1266
1267  j_start =jts
1268
1269  j_end =min(jte,jde-1)
1270
1271  CALL g_calculate_N2(config_flags,BN2,g_BN2,moist,g_moist,theta,g_theta,t, &
1272  g_t,p,g_p,p8w,g_p8w,t8w,g_t8w,dnw,dn,rdz,g_rdz,rdzw,g_rdzw,n_moist, &
1273  cf1,cf2,cf3,warm_rain,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
1274  jte,kts,kte)
1275
1276 !ALL THE FOLLOWING STRUNCTURE ARE REVISED BY WALLS
1277 !ALL THE FOLLOWING STRUNCTURE ARE REVISED BY WALLS
1278
1279 !km_opt =config_flags%km_opt
1280 !km_opt =3
1281 !PRINT*, 'km_opt =', km_opt
1282
1283 !Select a scheme for calculating diffusion coefficients.
1284  km_coef: SELECT CASE( config_flags%km_opt )
1285 !km_coef: SELECT CASE( km_opt )
1286
1287  CASE (1)
1288
1289  CALL g_isotropic_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh, &
1290  xkhv,g_xkhv,khdif,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
1291  jts,jte,kts,kte)
1292
1293  CASE (2)
1294
1295  CALL g_tke_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv, &
1296  g_xkhv,BN2,g_BN2,tke,g_tke,p8w,g_p8w,t8w,g_t8w,theta,g_theta,rdz, &
1297  g_rdz,rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds, &
1298  jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1299
1300  CASE (3)
1301
1302  CALL g_smag_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv, &
1303  g_xkhv,BN2,g_BN2,div,g_div,defor11,g_defor11,defor22,g_defor22, &
1304  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
1305  rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds, &
1306  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1307
1308  CASE (4)
1309
1310  CALL g_smag2d_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv, &
1311  g_xkhv,defor11,g_defor11,defor22,g_defor22,defor12,g_defor12,rdzw, &
1312  g_rdzw,dx,dy,msftx,msfty,zx,g_zx,zy,g_zy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
1313  jts,jte,kts,kte)
1314
1315  CASE DEFAULT
1316
1317 !REVISED BY WALLS
1318 !CALL g_wrf_error_fatal('Please choose diffusion coefficient scheme')
1319  CALL wrf_error_fatal( 'Please choose diffusion coefficient scheme' )
1320
1321  END SELECT km_coef
1322
1323  IF( damp_opt .eq. 1 ) THEN
1324
1325  CALL g_cal_dampkm(config_flags,xkmh,g_xkmh,xkhh,g_xkhh,xkmv,g_xkmv,xkhv, &
1326  g_xkhv,dx,dy,dt,dampcoef,rdz,g_rdz,rdzw,g_rdzw,zdamp,msftx,msfty,ids,ide, &
1327  jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1328
1329  END IF
1330
1331  END SUBROUTINE g_calculate_km_kh
1332
1333  SUBROUTINE g_cal_dampkm(config_flags,xkmh,g_xkmh,xkhh,g_xkhh,xkmv,g_xkmv, &
1334  xkhv,g_xkhv,dx,dy,dt,dampcoef,rdz,g_rdz,rdzw,g_rdzw,zdamp,msftx,msfty,ids, &
1335  ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1336
1337  IMPLICIT NONE
1338
1339  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5,g_Tmpv5
1340  TYPE(grid_config_rec_type) :: config_flags
1341  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1342  REAL :: zdamp,dx,dy,dt,dampcoef
1343  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkhh,g_xkhh,xkmv, &
1344  g_xkmv,xkhv,g_xkhv
1345  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rdz,g_rdz,rdzw,g_rdzw
1346  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
1347  INTEGER :: i_start,i_end,j_start,j_end,ktf,ktfm1,i,j,k
1348  REAL :: kmmax,kmmvmax,g_kmmvmax,degrad90,dz,g_dz,tmp,g_tmp
1349  REAL :: ds
1350  REAL,DIMENSION(its:ite) :: deltaz,g_deltaz
1351  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dampk,g_dampk,dampkv,g_dampkv
1352
1353  ktf =min(kte,kde-1)
1354
1355  ktfm1 =ktf-1
1356
1357  i_start =its
1358
1359  i_end =min(ite,ide-1)
1360
1361  j_start =jts
1362
1363  j_end =min(jte,jde-1)
1364
1365  IF(config_flags%specified .OR. config_flags%nested) THEN
1366
1367  i_start =max(i_start,ids +config_flags%spec_bdy_width -1)
1368
1369  i_end =min(i_end,ide -config_flags%spec_bdy_width)
1370
1371  j_start =max(j_start,jds +config_flags%spec_bdy_width -1)
1372
1373  j_end =min(j_end,jde -config_flags%spec_bdy_width)
1374  ENDIF
1375
1376  kmmax =dx *dx/dt
1377
1378  degrad90 =DEGRAD *90.
1379
1380  DO j =j_start,j_end
1381
1382  k =ktf
1383
1384  DO i =i_start,i_end
1385
1386  ds =min(dx/msftx(i,j),dy/msfty(i,j))
1387
1388  kmmax =ds *ds/dt
1389
1390  g_dz =-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
1391  dz =1./rdzw(i,k,j)
1392
1393  g_deltaz(i) =0.5*g_dz
1394  deltaz(i) =0.5*dz
1395
1396  g_Tmpv1 =2.0*dz*g_dz
1397  Tmpv1 =dz*dz
1398
1399  g_kmmvmax =g_Tmpv1/dt
1400  kmmvmax =Tmpv1/dt
1401
1402  g_tmp =(g_deltaz(i)/zdamp +0.0 -(g_deltaz(i)/zdamp -0.0)*sign(1.0, deltaz(i) &
1403 /zdamp -(1.)))*0.5
1404  tmp =min(deltaz(i)/zdamp,1.)
1405
1406  g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
1407  Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
1408
1409  g_dampk(i,k,j) =g_Tmpv1*kmmax*dampcoef
1410  dampk(i,k,j) =Tmpv1*kmmax*dampcoef
1411
1412  g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
1413  Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
1414
1415  g_Tmpv2 =Tmpv1*g_kmmvmax +g_Tmpv1*kmmvmax
1416  Tmpv2 =Tmpv1*kmmvmax
1417
1418  g_dampkv(i,k,j) =g_Tmpv2*dampcoef
1419  dampkv(i,k,j) =Tmpv2*dampcoef
1420
1421  g_dampkv(i,k,j) =(g_dampkv(i,k,j) +g_dampk(i,k,j) -(g_dampkv(i,k,j) &
1422  -g_dampk(i,k,j))*sign(1.0, dampkv(i,k,j) -(dampk(i,k,j))))*0.5
1423  dampkv(i,k,j) =min(dampkv(i,k,j),dampk(i,k,j))
1424
1425  ENDDO
1426
1427  DO k =ktfm1,kts,-1
1428  DO i =i_start,i_end
1429
1430  ds =min(dx/msftx(i,j),dy/msfty(i,j))
1431
1432  kmmax =ds *ds/dt
1433
1434  g_dz =-1.*g_rdz(i,k,j)/(rdz(i,k,j)*rdz(i,k,j))
1435  dz =1./rdz(i,k,j)
1436
1437  g_deltaz(i) =g_deltaz(i) +g_dz
1438  deltaz(i) =deltaz(i) +dz
1439
1440  g_dz =-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
1441  dz =1./rdzw(i,k,j)
1442
1443  g_Tmpv1 =2.0*dz*g_dz
1444  Tmpv1 =dz*dz
1445
1446  g_kmmvmax =g_Tmpv1/dt
1447  kmmvmax =Tmpv1/dt
1448
1449  g_tmp =(g_deltaz(i)/zdamp +0.0 -(g_deltaz(i)/zdamp -0.0)*sign(1.0, deltaz(i) &
1450 /zdamp -(1.)))*0.5
1451  tmp =min(deltaz(i)/zdamp,1.)
1452
1453  g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
1454  Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
1455
1456  g_dampk(i,k,j) =g_Tmpv1*kmmax*dampcoef
1457  dampk(i,k,j) =Tmpv1*kmmax*dampcoef
1458
1459  g_Tmpv1 =2.0*cos(degrad90*tmp)*(-degrad90*g_tmp*sin(degrad90*tmp))
1460  Tmpv1 =cos(degrad90*tmp)*cos(degrad90*tmp)
1461
1462  g_Tmpv2 =Tmpv1*g_kmmvmax +g_Tmpv1*kmmvmax
1463  Tmpv2 =Tmpv1*kmmvmax
1464
1465  g_dampkv(i,k,j) =g_Tmpv2*dampcoef
1466  dampkv(i,k,j) =Tmpv2*dampcoef
1467
1468  g_dampkv(i,k,j) =(g_dampkv(i,k,j) +g_dampk(i,k,j) -(g_dampkv(i,k,j) &
1469  -g_dampk(i,k,j))*sign(1.0, dampkv(i,k,j) -(dampk(i,k,j))))*0.5
1470  dampkv(i,k,j) =min(dampkv(i,k,j),dampk(i,k,j))
1471
1472  ENDDO
1473  ENDDO
1474  ENDDO
1475
1476  DO j =j_start,j_end
1477  DO k =kts,ktf
1478  DO i =i_start,i_end
1479
1480  g_xkmh(i,k,j) =(g_xkmh(i,k,j) +g_dampk(i,k,j) +(g_xkmh(i,k,j) &
1481  -g_dampk(i,k,j))*sign(1.0, xkmh(i,k,j) -(dampk(i,k,j))))*0.5
1482  xkmh(i,k,j) =max(xkmh(i,k,j),dampk(i,k,j))
1483
1484  g_xkhh(i,k,j) =(g_xkhh(i,k,j) +g_dampk(i,k,j) +(g_xkhh(i,k,j) &
1485  -g_dampk(i,k,j))*sign(1.0, xkhh(i,k,j) -(dampk(i,k,j))))*0.5
1486  xkhh(i,k,j) =max(xkhh(i,k,j),dampk(i,k,j))
1487
1488  g_xkmv(i,k,j) =(g_xkmv(i,k,j) +g_dampkv(i,k,j) +(g_xkmv(i,k,j) &
1489  -g_dampkv(i,k,j))*sign(1.0, xkmv(i,k,j) -(dampkv(i,k,j))))*0.5
1490  xkmv(i,k,j) =max(xkmv(i,k,j),dampkv(i,k,j))
1491
1492  g_xkhv(i,k,j) =(g_xkhv(i,k,j) +g_dampkv(i,k,j) +(g_xkhv(i,k,j) &
1493  -g_dampkv(i,k,j))*sign(1.0, xkhv(i,k,j) -(dampkv(i,k,j))))*0.5
1494  xkhv(i,k,j) =max(xkhv(i,k,j),dampkv(i,k,j))
1495
1496  ENDDO
1497  ENDDO
1498  ENDDO
1499
1500  END SUBROUTINE g_cal_dampkm
1501
1502 !        Generated by TAPENADE     (INRIA, Tropics team)
1503 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
1504 !
1505 !  Differentiation of calculate_n2 in forward (tangent) mode:
1506 !   variations   of useful results: bn2
1507 !   with respect to varying inputs: p t t8w bn2 theta rdzw rdz
1508 !                moist p8w
1509 !   RW status of diff variables: p:in t:in t8w:in bn2:in-out theta:in
1510 !                rdzw:in rdz:in moist:in p8w:in
1511 SUBROUTINE G_CALCULATE_N2(config_flags, bn2, bn2d, moist, moistd, theta&
1512 &  , thetad, t, td, p, pd, p8w, p8wd, t8w, t8wd, dnw, dn, rdz, rdzd, rdzw&
1513 &  , rdzwd, n_moist, cf1, cf2, cf3, warm_rain, ids, ide, jds, jde, kds, &
1514 &  kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
1515   IMPLICIT NONE
1516 ! end of MARTA/WCS change
1517   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
1518   INTEGER, INTENT(IN) :: n_moist, ids, ide, jds, jde, kds, kde, ims, ime&
1519 &  , jms, jme, kms, kme, its, ite, jts, jte, kts, kte
1520   LOGICAL, INTENT(IN) :: warm_rain
1521   REAL, INTENT(IN) :: cf1, cf2, cf3
1522   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: bn2
1523   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: bn2d
1524   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdz, rdzw, &
1525 &  theta, t, p, p8w, t8w
1526   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzd, rdzwd&
1527 &  , thetad, td, pd, p8wd, t8wd
1528   REAL, DIMENSION(kms:kme), INTENT(IN) :: dnw, dn
1529   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(INOUT) :: &
1530 &  moist
1531   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(INOUT) :: &
1532 &  moistd
1533 ! Local variables.
1534   INTEGER :: i, j, k, ktf, ispe, ktes1, ktes2, i_start, i_end, j_start, &
1535 &  j_end
1536   REAL :: coefa, thetaep1, thetaem1, qc_cr, es, tc, qlpqi, qsw, qsi, &
1537 &  tmpdz, xlvqv, thetaesfc, thetasfc, qvtop, qvsfc, thetatop, thetaetop
1538   REAL :: coefad, thetaep1d, thetaem1d, esd, tcd, tmpdzd, xlvqvd, &
1539 &  thetaesfcd, thetasfcd, qvsfcd
1540   REAL, DIMENSION(its:ite, jts:jte) :: tmp1sfc, tmp1top
1541   REAL, DIMENSION(its:ite, jts:jte) :: tmp1sfcd
1542   REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: tmp1, qvs, qctmp
1543   REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: tmp1d, qvsd
1544   REAL :: arg1
1545   REAL :: arg1d
1546   REAL :: pwx1
1547   REAL :: pwx1d
1548   REAL :: pwy1
1549   REAL :: pwr1
1550   REAL :: pwr1d
1551 ! End declarations.
1552 !-----------------------------------------------------------------------
1553 ! in Kg/Kg
1554   qc_cr = 0.00001
1555   IF (kte .GT. kde - 1) THEN
1556     ktf = kde - 1
1557   ELSE
1558     ktf = kte
1559   END IF
1560   ktes1 = kte - 1
1561   ktes2 = kte - 2
1562   i_start = its
1563   IF (ite .GT. ide - 1) THEN
1564     i_end = ide - 1
1565   ELSE
1566     i_end = ite
1567   END IF
1568   j_start = jts
1569   IF (jte .GT. jde - 1) THEN
1570     j_end = jde - 1
1571   ELSE
1572     j_end = jte
1573   END IF
1574   IF ((config_flags%open_xs .OR. config_flags%specified) .OR. &
1575 &      config_flags%nested) THEN
1576     IF (ids + 1 .LT. its) THEN
1577       i_start = its
1578     ELSE
1579       i_start = ids + 1
1580     END IF
1581   END IF
1582   IF ((config_flags%open_xe .OR. config_flags%specified) .OR. &
1583 &      config_flags%nested) THEN
1584     IF (ide - 2 .GT. ite) THEN
1585       i_end = ite
1586     ELSE
1587       i_end = ide - 2
1588     END IF
1589   END IF
1590   IF ((config_flags%open_ys .OR. config_flags%specified) .OR. &
1591 &      config_flags%nested) THEN
1592     IF (jds + 1 .LT. jts) THEN
1593       j_start = jts
1594     ELSE
1595       j_start = jds + 1
1596     END IF
1597   END IF
1598   IF ((config_flags%open_ye .OR. config_flags%specified) .OR. &
1599 &      config_flags%nested) THEN
1600     IF (jde - 2 .GT. jte) THEN
1601       j_end = jte
1602     ELSE
1603       j_end = jde - 2
1604     END IF
1605   END IF
1606   IF (config_flags%periodic_x) i_start = its
1607   IF (config_flags%periodic_x) THEN
1608     IF (ite .GT. ide - 1) THEN
1609       i_end = ide - 1
1610     ELSE
1611       i_end = ite
1612     END IF
1613   END IF
1614   IF (p_qc .GT. param_first_scalar) THEN
1615     DO j=j_start,j_end
1616       DO k=kts,ktf
1617         DO i=i_start,i_end
1618           qctmp(i, k, j) = moist(i, k, j, p_qc)
1619         END DO
1620       END DO
1621     END DO
1622   ELSE
1623     DO j=j_start,j_end
1624       DO k=kts,ktf
1625         DO i=i_start,i_end
1626           qctmp(i, k, j) = 0.0
1627         END DO
1628       END DO
1629     END DO
1630   END IF
1631   DO j=jts,jte
1632     DO k=kts,kte
1633       DO i=its,ite
1634         tmp1d(i, k, j) = 0.0
1635         tmp1(i, k, j) = 0.0
1636       END DO
1637     END DO
1638   END DO
1639   DO j=jts,jte
1640     DO i=its,ite
1641       tmp1sfcd(i, j) = 0.0
1642       tmp1sfc(i, j) = 0.0
1643       tmp1top(i, j) = 0.0
1644     END DO
1645   END DO
1646   tmp1d = 0.0
1647   tmp1sfcd = 0.0
1648   DO ispe=param_first_scalar,n_moist
1649     IF ((ispe .EQ. p_qv .OR. ispe .EQ. p_qc) .OR. ispe .EQ. p_qi) THEN
1650       DO j=j_start,j_end
1651         DO k=kts,ktf
1652           DO i=i_start,i_end
1653             tmp1d(i, k, j) = tmp1d(i, k, j) + moistd(i, k, j, ispe)
1654             tmp1(i, k, j) = tmp1(i, k, j) + moist(i, k, j, ispe)
1655           END DO
1656         END DO
1657       END DO
1658       DO j=j_start,j_end
1659         DO i=i_start,i_end
1660           tmp1sfcd(i, j) = tmp1sfcd(i, j) + cf1*moistd(i, 1, j, ispe) + &
1661 &            cf2*moistd(i, 2, j, ispe) + cf3*moistd(i, 3, j, ispe)
1662           tmp1sfc(i, j) = tmp1sfc(i, j) + cf1*moist(i, 1, j, ispe) + cf2&
1663 &            *moist(i, 2, j, ispe) + cf3*moist(i, 3, j, ispe)
1664           tmp1top(i, j) = tmp1top(i, j) + moist(i, ktes1, j, ispe) + (&
1665 &            moist(i, ktes1, j, ispe)-moist(i, ktes2, j, ispe))*0.5*dnw(&
1666 &            ktes1)/dn(ktes1)
1667         END DO
1668       END DO
1669     END IF
1670   END DO
1671   qvsd = 0.0
1672 ! Calculate saturation mixing ratio.
1673   DO j=j_start,j_end
1674     DO k=kts,ktf
1675       DO i=i_start,i_end
1676         tcd = td(i, k, j)
1677         tc = t(i, k, j) - svpt0
1678         arg1d = (svp2*tcd*(t(i, k, j)-svp3)-svp2*tc*td(i, k, j))/(t(i, k&
1679 &          , j)-svp3)**2
1680         arg1 = svp2*tc/(t(i, k, j)-svp3)
1681         esd = 1000.0*svp1*arg1d*EXP(arg1)
1682         es = 1000.0*svp1*EXP(arg1)
1683         qvsd(i, k, j) = (ep_2*esd*(p(i, k, j)-es)-ep_2*es*(pd(i, k, j)-&
1684 &          esd))/(p(i, k, j)-es)**2
1685         qvs(i, k, j) = ep_2*es/(p(i, k, j)-es)
1686       END DO
1687     END DO
1688   END DO
1689   DO j=j_start,j_end
1690     DO k=kts+1,ktf-1
1691       DO i=i_start,i_end
1692         tmpdzd = -(rdzd(i, k, j)/rdz(i, k, j)**2) - rdzd(i, k+1, j)/rdz(&
1693 &          i, k+1, j)**2
1694         tmpdz = 1.0/rdz(i, k, j) + 1.0/rdz(i, k+1, j)
1695         IF (moist(i, k, j, p_qv) .GE. qvs(i, k, j) .OR. qctmp(i, k, j) &
1696 &            .GE. qc_cr) THEN
1697           xlvqvd = xlv*moistd(i, k, j, p_qv)
1698           xlvqv = xlv*moist(i, k, j, p_qv)
1699           coefad = (((xlvqvd*t(i, k, j)/r_d-xlvqv*td(i, k, j)/r_d)*(1.0+&
1700 &            xlv*xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))/t(i, k, j)**2-(1.0+&
1701 &            xlvqv/r_d/t(i, k, j))*((xlv*xlvqvd*t(i, k, j)/(cp*r_v)-xlv*&
1702 &            xlvqv*td(i, k, j)/(cp*r_v))/t(i, k, j)-xlv*xlvqv*td(i, k, j)&
1703 &            /(cp*r_v*t(i, k, j)))/t(i, k, j)**2)*theta(i, k, j)/(1.0+xlv&
1704 &            *xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))**2-(1.0+xlvqv/r_d/t(i, &
1705 &            k, j))*thetad(i, k, j)/(1.0+xlv*xlvqv/cp/r_v/t(i, k, j)/t(i&
1706 &            , k, j)))/theta(i, k, j)**2
1707           coefa = (1.0+xlvqv/r_d/t(i, k, j))/(1.0+xlv*xlvqv/cp/r_v/t(i, &
1708 &            k, j)/t(i, k, j))/theta(i, k, j)
1709           thetaep1d = thetad(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, &
1710 &            k+1, j)) + theta(i, k+1, j)*(xlv*qvsd(i, k+1, j)*t(i, k+1, j&
1711 &            )/cp-xlv*qvs(i, k+1, j)*td(i, k+1, j)/cp)/t(i, k+1, j)**2
1712           thetaep1 = theta(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+&
1713 &            1, j))
1714           thetaem1d = thetad(i, k-1, j)*(1.0+xlv*qvs(i, k-1, j)/cp/t(i, &
1715 &            k-1, j)) + theta(i, k-1, j)*(xlv*qvsd(i, k-1, j)*t(i, k-1, j&
1716 &            )/cp-xlv*qvs(i, k-1, j)*td(i, k-1, j)/cp)/t(i, k-1, j)**2
1717           thetaem1 = theta(i, k-1, j)*(1.0+xlv*qvs(i, k-1, j)/cp/t(i, k-&
1718 &            1, j))
1719           bn2d(i, k, j) = g*(((coefad*(thetaep1-thetaem1)+coefa*(&
1720 &            thetaep1d-thetaem1d))*tmpdz-coefa*(thetaep1-thetaem1)*tmpdzd&
1721 &            )/tmpdz**2-((tmp1d(i, k+1, j)-tmp1d(i, k-1, j))*tmpdz-(tmp1(&
1722 &            i, k+1, j)-tmp1(i, k-1, j))*tmpdzd)/tmpdz**2)
1723           bn2(i, k, j) = g*(coefa*(thetaep1-thetaem1)/tmpdz-(tmp1(i, k+1&
1724 &            , j)-tmp1(i, k-1, j))/tmpdz)
1725         ELSE
1726           bn2d(i, k, j) = g*((((thetad(i, k+1, j)-thetad(i, k-1, j))*&
1727 &            theta(i, k, j)-(theta(i, k+1, j)-theta(i, k-1, j))*thetad(i&
1728 &            , k, j))*tmpdz/theta(i, k, j)**2-(theta(i, k+1, j)-theta(i, &
1729 &            k-1, j))*tmpdzd/theta(i, k, j))/tmpdz**2+(1.61*(moistd(i, k+&
1730 &            1, j, p_qv)-moistd(i, k-1, j, p_qv))*tmpdz-1.61*(moist(i, k+&
1731 &            1, j, p_qv)-moist(i, k-1, j, p_qv))*tmpdzd)/tmpdz**2-((tmp1d&
1732 &            (i, k+1, j)-tmp1d(i, k-1, j))*tmpdz-(tmp1(i, k+1, j)-tmp1(i&
1733 &            , k-1, j))*tmpdzd)/tmpdz**2)
1734           bn2(i, k, j) = g*((theta(i, k+1, j)-theta(i, k-1, j))/theta(i&
1735 &            , k, j)/tmpdz+1.61*(moist(i, k+1, j, p_qv)-moist(i, k-1, j, &
1736 &            p_qv))/tmpdz-(tmp1(i, k+1, j)-tmp1(i, k-1, j))/tmpdz)
1737         END IF
1738       END DO
1739     END DO
1740   END DO
1741   k = kts
1742   DO j=j_start,j_end
1743     DO i=i_start,i_end
1744       tmpdzd = -(rdzd(i, k+1, j)/rdz(i, k+1, j)**2) - 0.5*rdzwd(i, k, j)&
1745 &        /rdzw(i, k, j)**2
1746       tmpdz = 1.0/rdz(i, k+1, j) + 0.5/rdzw(i, k, j)
1747       pwx1d = p8wd(i, k, j)/p1000mb
1748       pwx1 = p8w(i, k, j)/p1000mb
1749       pwy1 = r_d/cp
1750       IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pwy1 .EQ. INT(pwy1))) &
1751 &      THEN
1752         pwr1d = pwy1*pwx1**(pwy1-1)*pwx1d
1753       ELSE IF (pwx1 .EQ. 0.0 .AND. pwy1 .EQ. 1.0) THEN
1754         pwr1d = pwx1d
1755       ELSE
1756         pwr1d = 0.0
1757       END IF
1758       pwr1 = pwx1**pwy1
1759       thetasfcd = (t8wd(i, kts, j)*pwr1-t8w(i, kts, j)*pwr1d)/pwr1**2
1760       thetasfc = t8w(i, kts, j)/pwr1
1761       IF (moist(i, k, j, p_qv) .GE. qvs(i, k, j) .OR. qctmp(i, k, j) &
1762 &          .GE. qc_cr) THEN
1763         qvsfcd = cf1*qvsd(i, 1, j) + cf2*qvsd(i, 2, j) + cf3*qvsd(i, 3, &
1764 &          j)
1765         qvsfc = cf1*qvs(i, 1, j) + cf2*qvs(i, 2, j) + cf3*qvs(i, 3, j)
1766         xlvqvd = xlv*moistd(i, k, j, p_qv)
1767         xlvqv = xlv*moist(i, k, j, p_qv)
1768         coefad = (((xlvqvd*t(i, k, j)/r_d-xlvqv*td(i, k, j)/r_d)*(1.0+&
1769 &          xlv*xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))/t(i, k, j)**2-(1.0+&
1770 &          xlvqv/r_d/t(i, k, j))*((xlv*xlvqvd*t(i, k, j)/(cp*r_v)-xlv*&
1771 &          xlvqv*td(i, k, j)/(cp*r_v))/t(i, k, j)-xlv*xlvqv*td(i, k, j)/(&
1772 &          cp*r_v*t(i, k, j)))/t(i, k, j)**2)*theta(i, k, j)/(1.0+xlv*&
1773 &          xlvqv/cp/r_v/t(i, k, j)/t(i, k, j))**2-(1.0+xlvqv/r_d/t(i, k, &
1774 &          j))*thetad(i, k, j)/(1.0+xlv*xlvqv/cp/r_v/t(i, k, j)/t(i, k, j&
1775 &          )))/theta(i, k, j)**2
1776         coefa = (1.0+xlvqv/r_d/t(i, k, j))/(1.0+xlv*xlvqv/cp/r_v/t(i, k&
1777 &          , j)/t(i, k, j))/theta(i, k, j)
1778         thetaep1d = thetad(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+&
1779 &          1, j)) + theta(i, k+1, j)*(xlv*qvsd(i, k+1, j)*t(i, k+1, j)/cp&
1780 &          -xlv*qvs(i, k+1, j)*td(i, k+1, j)/cp)/t(i, k+1, j)**2
1781         thetaep1 = theta(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+1&
1782 &          , j))
1783         thetaesfcd = thetasfcd*(1.0+xlv*qvsfc/cp/t8w(i, kts, j)) + &
1784 &          thetasfc*(xlv*qvsfcd*t8w(i, kts, j)/cp-xlv*qvsfc*t8wd(i, kts, &
1785 &          j)/cp)/t8w(i, kts, j)**2
1786         thetaesfc = thetasfc*(1.0+xlv*qvsfc/cp/t8w(i, kts, j))
1787         bn2d(i, k, j) = g*(((coefad*(thetaep1-thetaesfc)+coefa*(&
1788 &          thetaep1d-thetaesfcd))*tmpdz-coefa*(thetaep1-thetaesfc)*tmpdzd&
1789 &          )/tmpdz**2-((tmp1d(i, k+1, j)-tmp1sfcd(i, j))*tmpdz-(tmp1(i, k&
1790 &          +1, j)-tmp1sfc(i, j))*tmpdzd)/tmpdz**2)
1791         bn2(i, k, j) = g*(coefa*(thetaep1-thetaesfc)/tmpdz-(tmp1(i, k+1&
1792 &          , j)-tmp1sfc(i, j))/tmpdz)
1793       ELSE
1794         qvsfcd = cf1*moistd(i, 1, j, p_qv) + cf2*moistd(i, 2, j, p_qv) +&
1795 &          cf3*moistd(i, 3, j, p_qv)
1796         qvsfc = cf1*moist(i, 1, j, p_qv) + cf2*moist(i, 2, j, p_qv) + &
1797 &          cf3*moist(i, 3, j, p_qv)
1798 !        BN2(i,k,j) = g * ( ( theta(i,k+1,j) - thetasfc ) /  &
1799 !                     theta(i,k,j) / tmpdz +  &
1800 !                     1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) /  &
1801 !                     tmpdz -  &
1802 !                     ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz  )
1803 !...... MARTA: change in computation of BN2 at the surface, WCS 040331
1804 ! controlare come calcola rdzw
1805         tmpdzd = -(rdzwd(i, k, j)/rdzw(i, k, j)**2)
1806         tmpdz = 1./rdzw(i, k, j)
1807         bn2d(i, k, j) = g*((((thetad(i, k+1, j)-thetad(i, k, j))*theta(i&
1808 &          , k, j)-(theta(i, k+1, j)-theta(i, k, j))*thetad(i, k, j))*&
1809 &          tmpdz/theta(i, k, j)**2-(theta(i, k+1, j)-theta(i, k, j))*&
1810 &          tmpdzd/theta(i, k, j))/tmpdz**2+(1.61*(moistd(i, k+1, j, p_qv)&
1811 &          -qvsfcd)*tmpdz-1.61*(moist(i, k+1, j, p_qv)-qvsfc)*tmpdzd)/&
1812 &          tmpdz**2-((tmp1d(i, k+1, j)-tmp1sfcd(i, j))*tmpdz-(tmp1(i, k+1&
1813 &          , j)-tmp1sfc(i, j))*tmpdzd)/tmpdz**2)
1814         bn2(i, k, j) = g*((theta(i, k+1, j)-theta(i, k, j))/theta(i, k, &
1815 &          j)/tmpdz+1.61*(moist(i, k+1, j, p_qv)-qvsfc)/tmpdz-(tmp1(i, k+&
1816 &          1, j)-tmp1sfc(i, j))/tmpdz)
1817 ! end of MARTA/WCS change
1818       END IF
1819     END DO
1820   END DO
1821 !...... MARTA: change in computation of BN2 at the top, WCS 040331
1822   DO j=j_start,j_end
1823     DO i=i_start,i_end
1824       bn2d(i, ktf, j) = bn2d(i, ktf-1, j)
1825       bn2(i, ktf, j) = bn2(i, ktf-1, j)
1826     END DO
1827   END DO
1828 END SUBROUTINE G_CALCULATE_N2
1829
1830  SUBROUTINE g_isotropic_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
1831  g_xkhh,xkhv,g_xkhv,khdif,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
1832  its,ite,jts,jte,kts,kte)
1833
1834  IMPLICIT NONE
1835
1836  REAL :: Tmpv1,g_Tmpv1
1837  TYPE(grid_config_rec_type) :: config_flags
1838  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1839  REAL :: khdif,kvdif
1840  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
1841  g_xkhh,xkhv,g_xkhv
1842  INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
1843  REAL :: khdif3,kvdif3
1844
1845  ktf =kte
1846
1847  i_start =its
1848
1849  i_end =min(ite,ide-1)
1850
1851  j_start =jts
1852
1853  j_end =min(jte,jde-1)
1854
1855  khdif3 =khdif/prandtl
1856
1857  kvdif3 =kvdif/prandtl
1858
1859  DO j =j_start,j_end
1860  DO k =kts,ktf
1861  DO i =i_start,i_end
1862
1863  g_xkmh(i,k,j) =0.0
1864  xkmh(i,k,j) =khdif
1865
1866  g_xkmv(i,k,j) =0.0
1867  xkmv(i,k,j) =kvdif
1868
1869  g_xkhh(i,k,j) =0.0
1870  xkhh(i,k,j) =khdif3
1871
1872  g_xkhv(i,k,j) =0.0
1873  xkhv(i,k,j) =kvdif3
1874
1875  ENDDO
1876  ENDDO
1877  ENDDO
1878
1879  END SUBROUTINE g_isotropic_km
1880
1881  SUBROUTINE g_smag_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh, &
1882  xkhv,g_xkhv,BN2,g_BN2,div,g_div,defor11,g_defor11,defor22,g_defor22, &
1883  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
1884  rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds, &
1885  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1886
1887  IMPLICIT NONE
1888
1889  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5,g_Tmpv5
1890
1891    REAL :: g_Sqrt
1892  TYPE(grid_config_rec_type) :: config_flags
1893  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1894  INTEGER :: isotropic
1895  REAL :: dx,dy,dt,mix_upper_bound
1896  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: BN2,g_BN2,rdzw,g_rdzw
1897  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
1898  g_xkhh,xkhv,g_xkhv
1899  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
1900  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
1901  div,g_div
1902  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
1903  INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
1904  REAL :: deltas,g_deltas,tmp,g_tmp,pr,g_pr,mlen_h,g_mlen_h,mlen_v, &
1905  g_mlen_v,c_s,g_c_s
1906  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: def2,g_def2
1907
1908  ktf =min(kte,kde-1)
1909
1910  i_start =its
1911
1912  i_end =min(ite,ide-1)
1913
1914  j_start =jts
1915
1916  j_end =min(jte,jde-1)
1917
1918  IF( config_flags%open_xs .or. config_flags%specified .or.   &
1919         config_flags%nested) i_start =max(ids+1,its)
1920
1921  IF( config_flags%open_xe .or. config_flags%specified .or.   &
1922         config_flags%nested) i_end =min(ide-2,ite)
1923
1924  IF( config_flags%open_ys .or. config_flags%specified .or.   &
1925         config_flags%nested) j_start =max(jds+1,jts)
1926
1927  IF( config_flags%open_ye .or. config_flags%specified .or.   &
1928         config_flags%nested) j_end =min(jde-2,jte)
1929
1930  IF( config_flags%periodic_x ) i_start =its
1931
1932  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
1933
1934  g_pr =0.0
1935  pr =prandtl
1936
1937 !REVISED BY WALLS
1938 !g_c_s =g_config_flags%c_s
1939  g_c_s =0.0
1940  c_s =config_flags%c_s
1941
1942  DO j =j_start,j_end
1943  DO k =kts,ktf
1944  DO i =i_start,i_end
1945
1946  g_Tmpv1 =2.0*defor11(i,k,j)*g_defor11(i,k,j)
1947  Tmpv1 =defor11(i,k,j)*defor11(i,k,j)
1948
1949  g_Tmpv2 =2.0*defor22(i,k,j)*g_defor22(i,k,j)
1950  Tmpv2 =defor22(i,k,j)*defor22(i,k,j)
1951
1952  g_Tmpv3 =2.0*defor33(i,k,j)*g_defor33(i,k,j)
1953  Tmpv3 =defor33(i,k,j)*defor33(i,k,j)
1954
1955  g_def2(i,k,j) =0.5*(g_Tmpv1 +g_Tmpv2 +g_Tmpv3)
1956  def2(i,k,j) =0.5*(Tmpv1 +Tmpv2 +Tmpv3)
1957
1958  ENDDO
1959  ENDDO
1960  ENDDO
1961
1962  DO j =j_start,j_end
1963  DO k =kts,ktf
1964  DO i =i_start,i_end
1965
1966  g_tmp =0.25*(g_defor12(i,k,j) +g_defor12(i,k,j+1) +g_defor12(i+1,k,j) &
1967  +g_defor12(i+1,k,j+1))
1968  tmp =0.25*(defor12(i,k,j) +defor12(i,k,j+1) +defor12(i+1,k,j) +defor12(i+1,k,j+1))
1969
1970  g_Tmpv1 =2.0*tmp*g_tmp
1971  Tmpv1 =tmp*tmp
1972
1973  g_def2(i,k,j) =g_def2(i,k,j) +g_Tmpv1
1974  def2(i,k,j) =def2(i,k,j) +Tmpv1
1975
1976  ENDDO
1977  ENDDO
1978  ENDDO
1979
1980  DO j =j_start,j_end
1981  DO k =kts,ktf
1982  DO i =i_start,i_end
1983
1984  g_tmp =0.25*(g_defor13(i,k+1,j) +g_defor13(i,k,j) +g_defor13(i+1,k+1,j) &
1985  +g_defor13(i+1,k,j))
1986  tmp =0.25*(defor13(i,k+1,j) +defor13(i,k,j) +defor13(i+1,k+1,j) +defor13(i+1,k,j))
1987
1988  g_Tmpv1 =2.0*tmp*g_tmp
1989  Tmpv1 =tmp*tmp
1990
1991  g_def2(i,k,j) =g_def2(i,k,j) +g_Tmpv1
1992  def2(i,k,j) =def2(i,k,j) +Tmpv1
1993
1994  ENDDO
1995  ENDDO
1996  ENDDO
1997
1998  DO j =j_start,j_end
1999  DO k =kts,ktf
2000  DO i =i_start,i_end
2001
2002  g_tmp =0.25*(g_defor23(i,k+1,j) +g_defor23(i,k,j) +g_defor23(i,k+1,j+1) &
2003  +g_defor23(i,k,j+1))
2004  tmp =0.25*(defor23(i,k+1,j) +defor23(i,k,j) +defor23(i,k+1,j+1) +defor23(i,k,j+1))
2005
2006  g_Tmpv1 =2.0*tmp*g_tmp
2007  Tmpv1 =tmp*tmp
2008
2009  g_def2(i,k,j) =g_def2(i,k,j) +g_Tmpv1
2010  def2(i,k,j) =def2(i,k,j) +Tmpv1
2011
2012  ENDDO
2013  ENDDO
2014  ENDDO
2015
2016  IF(isotropic .EQ. 0) THEN
2017
2018  DO j =j_start,j_end
2019  DO k =kts,ktf
2020  DO i =i_start,i_end
2021
2022  g_mlen_h =0.0
2023  mlen_h =sqrt(dx/msftx(i,j) *dy/msfty(i,j))
2024
2025  g_mlen_v =-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
2026  mlen_v =1./rdzw(i,k,j)
2027
2028  g_Tmpv1 =(g_BN2(i,k,j)*pr -g_pr*BN2(i,k,j))/(pr*pr)
2029  Tmpv1 =BN2(i,k,j)/pr
2030
2031  g_tmp =(0.0 +(g_def2(i,k,j) -g_Tmpv1) +(0.0 -(g_def2(i,k,j) -g_Tmpv1)) &
2032 *sign(1.0, 0. -(def2(i,k,j) -Tmpv1)))*0.5
2033  tmp =max(0.,def2(i,k,j) -Tmpv1)
2034
2035 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2036 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2037 !REVISED AND ADDED BY WALLS
2038  IF(tmp.NE.0.0) THEN
2039    g_tmp =0.5*g_tmp*tmp**(0.5 -1.0)
2040  ELSE
2041 ! Reivsed by Ning Pan, 2010-08-18
2042    g_tmp =0.0
2043 !   g_tmp =0.5*g_tmp/(tmp**0.5+1.e-10)
2044  ENDIF
2045 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2046 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2047
2048  tmp =tmp**0.5
2049
2050  g_Tmpv1 =2.0*c_s*g_c_s
2051  Tmpv1 =c_s*c_s
2052
2053  g_Tmpv2 =Tmpv1*g_mlen_h +g_Tmpv1*mlen_h
2054  Tmpv2 =Tmpv1*mlen_h
2055
2056  g_Tmpv3 =Tmpv2*g_mlen_h +g_Tmpv2*mlen_h
2057  Tmpv3 =Tmpv2*mlen_h
2058
2059  g_Tmpv4 =Tmpv3*g_tmp +g_Tmpv3*tmp
2060  Tmpv4 =Tmpv3*tmp
2061
2062  g_Tmpv5 =1.0E-6*mlen_h*g_mlen_h +1.0E-6*g_mlen_h*mlen_h
2063  Tmpv5 =1.0E-6*mlen_h*mlen_h
2064
2065  g_xkmh(i,k,j) =(g_Tmpv4 +g_Tmpv5 +(g_Tmpv4 -g_Tmpv5)*sign(1.0, Tmpv4 - &
2066 (Tmpv5)))*0.5
2067  xkmh(i,k,j) =max(Tmpv4,Tmpv5)
2068
2069  g_Tmpv1 =mix_upper_bound*mlen_h*g_mlen_h +mix_upper_bound*g_mlen_h*mlen_h
2070  Tmpv1 =mix_upper_bound*mlen_h*mlen_h
2071
2072  g_xkmh(i,k,j) =(g_xkmh(i,k,j) +(g_Tmpv1/dt) -(g_xkmh(i,k,j) &
2073  -(g_Tmpv1/dt))*sign(1.0, xkmh(i,k,j) -(Tmpv1/dt)))*0.5
2074  xkmh(i,k,j) =min(xkmh(i,k,j),Tmpv1/dt)
2075
2076  g_Tmpv1 =2.0*c_s*g_c_s
2077  Tmpv1 =c_s*c_s
2078
2079  g_Tmpv2 =Tmpv1*g_mlen_v +g_Tmpv1*mlen_v
2080  Tmpv2 =Tmpv1*mlen_v
2081
2082  g_Tmpv3 =Tmpv2*g_mlen_v +g_Tmpv2*mlen_v
2083  Tmpv3 =Tmpv2*mlen_v
2084
2085  g_Tmpv4 =Tmpv3*g_tmp +g_Tmpv3*tmp
2086  Tmpv4 =Tmpv3*tmp
2087
2088  g_Tmpv5 =1.0E-6*mlen_v*g_mlen_v +1.0E-6*g_mlen_v*mlen_v
2089  Tmpv5 =1.0E-6*mlen_v*mlen_v
2090
2091  g_xkmv(i,k,j) =(g_Tmpv4 +g_Tmpv5 +(g_Tmpv4 -g_Tmpv5)*sign(1.0, Tmpv4 - &
2092 (Tmpv5)))*0.5
2093  xkmv(i,k,j) =max(Tmpv4,Tmpv5)
2094
2095  g_Tmpv1 =mix_upper_bound*mlen_v*g_mlen_v +mix_upper_bound*g_mlen_v*mlen_v
2096  Tmpv1 =mix_upper_bound*mlen_v*mlen_v
2097
2098  g_xkmv(i,k,j) =(g_xkmv(i,k,j) +(g_Tmpv1/dt) -(g_xkmv(i,k,j) &
2099  -(g_Tmpv1/dt))*sign(1.0, xkmv(i,k,j) -(Tmpv1/dt)))*0.5
2100  xkmv(i,k,j) =min(xkmv(i,k,j),Tmpv1/dt)
2101
2102  g_Tmpv1 =(g_xkmh(i,k,j)*pr -g_pr*xkmh(i,k,j))/(pr*pr)
2103  Tmpv1 =xkmh(i,k,j)/pr
2104
2105  g_xkhh(i,k,j) =g_Tmpv1
2106  xkhh(i,k,j) =Tmpv1
2107
2108  g_Tmpv1 =mix_upper_bound*mlen_h*g_mlen_h +mix_upper_bound*g_mlen_h*mlen_h
2109  Tmpv1 =mix_upper_bound*mlen_h*mlen_h
2110
2111  g_xkhh(i,k,j) =(g_xkhh(i,k,j) +(g_Tmpv1/dt) -(g_xkhh(i,k,j) &
2112  -(g_Tmpv1/dt))*sign(1.0, xkhh(i,k,j) -(Tmpv1/dt)))*0.5
2113  xkhh(i,k,j) =min(xkhh(i,k,j),Tmpv1/dt)
2114
2115  g_Tmpv1 =(g_xkmv(i,k,j)*pr -g_pr*xkmv(i,k,j))/(pr*pr)
2116  Tmpv1 =xkmv(i,k,j)/pr
2117
2118  g_xkhv(i,k,j) =g_Tmpv1
2119  xkhv(i,k,j) =Tmpv1
2120
2121  g_Tmpv1 =mix_upper_bound*mlen_v*g_mlen_v +mix_upper_bound*g_mlen_v*mlen_v
2122  Tmpv1 =mix_upper_bound*mlen_v*mlen_v
2123
2124  g_xkhv(i,k,j) =(g_xkhv(i,k,j) +(g_Tmpv1/dt) -(g_xkhv(i,k,j) &
2125  -(g_Tmpv1/dt))*sign(1.0, xkhv(i,k,j) -(Tmpv1/dt)))*0.5
2126  xkhv(i,k,j) =min(xkhv(i,k,j),Tmpv1/dt)
2127
2128  ENDDO
2129  ENDDO
2130  ENDDO
2131  ELSE
2132
2133  DO j =j_start,j_end
2134  DO k =kts,ktf
2135  DO i =i_start,i_end
2136
2137  g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
2138 *rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
2139  deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
2140
2141  g_Tmpv1 =(g_BN2(i,k,j)*pr -g_pr*BN2(i,k,j))/(pr*pr)
2142  Tmpv1 =BN2(i,k,j)/pr
2143
2144  g_tmp =(0.0 +(g_def2(i,k,j) -g_Tmpv1) +(0.0 -(g_def2(i,k,j) -g_Tmpv1)) &
2145 *sign(1.0, 0. -(def2(i,k,j) -Tmpv1)))*0.5
2146  tmp =max(0.,def2(i,k,j) -Tmpv1)
2147
2148 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2149 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2150 !REVISED AND ADDED BY WALLS
2151  IF(tmp.NE.0.0) THEN
2152    g_tmp =0.5*g_tmp*tmp**(0.5 -1.0)
2153  ELSE
2154 ! Revised by Ning Pan, 2010-08-18
2155    g_tmp =0.0
2156 !   g_tmp =0.5*g_tmp/(tmp**0.5+1.e-10)
2157  ENDIF
2158 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2159 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2160  tmp =tmp**0.5  ! Added by Ning Pan, 2010-08-18
2161
2162  g_Tmpv1 =2.0*c_s*g_c_s
2163  Tmpv1 =c_s*c_s
2164
2165  g_Tmpv2 =Tmpv1*g_deltas +g_Tmpv1*deltas
2166  Tmpv2 =Tmpv1*deltas
2167
2168  g_Tmpv3 =Tmpv2*g_deltas +g_Tmpv2*deltas
2169  Tmpv3 =Tmpv2*deltas
2170
2171  g_Tmpv4 =Tmpv3*g_tmp +g_Tmpv3*tmp
2172  Tmpv4 =Tmpv3*tmp
2173
2174  g_Tmpv5 =1.0E-6*deltas*g_deltas +1.0E-6*g_deltas*deltas
2175  Tmpv5 =1.0E-6*deltas*deltas
2176
2177  g_xkmh(i,k,j) =(g_Tmpv4 +g_Tmpv5 +(g_Tmpv4 -g_Tmpv5)*sign(1.0, Tmpv4 - &
2178 (Tmpv5)))*0.5
2179  xkmh(i,k,j) =max(Tmpv4,Tmpv5)
2180
2181  g_xkmh(i,k,j) =(g_xkmh(i,k,j) +0.0 -(g_xkmh(i,k,j) -0.0)*sign(1.0, xkmh(i,k, &
2182  j) -(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)))*0.5
2183  xkmh(i,k,j) =min(xkmh(i,k,j),mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)
2184
2185  g_xkmv(i,k,j) =g_xkmh(i,k,j)
2186  xkmv(i,k,j) =xkmh(i,k,j)
2187
2188  g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
2189 *rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
2190  Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
2191
2192  g_xkmv(i,k,j) =(g_xkmv(i,k,j) +(g_Tmpv1/dt) -(g_xkmv(i,k,j) &
2193  -(g_Tmpv1/dt))*sign(1.0, xkmv(i,k,j) -(Tmpv1/dt)))*0.5
2194  xkmv(i,k,j) =min(xkmv(i,k,j),Tmpv1/dt)
2195
2196  g_Tmpv1 =(g_xkmh(i,k,j)*pr -g_pr*xkmh(i,k,j))/(pr*pr)
2197  Tmpv1 =xkmh(i,k,j)/pr
2198
2199  g_xkhh(i,k,j) =g_Tmpv1
2200  xkhh(i,k,j) =Tmpv1
2201
2202  g_xkhh(i,k,j) =(g_xkhh(i,k,j) +0.0 -(g_xkhh(i,k,j) -0.0)*sign(1.0, xkhh(i,k, &
2203  j) -(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)))*0.5
2204  xkhh(i,k,j) =min(xkhh(i,k,j),mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt)
2205
2206  g_Tmpv1 =(g_xkmv(i,k,j)*pr -g_pr*xkmv(i,k,j))/(pr*pr)
2207  Tmpv1 =xkmv(i,k,j)/pr
2208
2209  g_xkhv(i,k,j) =g_Tmpv1
2210  xkhv(i,k,j) =Tmpv1
2211
2212  g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
2213 *rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
2214  Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
2215
2216  g_xkhv(i,k,j) =(g_xkhv(i,k,j) +(g_Tmpv1/dt) -(g_xkhv(i,k,j) &
2217  -(g_Tmpv1/dt))*sign(1.0, xkhv(i,k,j) -(Tmpv1/dt)))*0.5
2218  xkhv(i,k,j) =min(xkhv(i,k,j),Tmpv1/dt)
2219
2220  ENDDO
2221  ENDDO
2222  ENDDO
2223  ENDIF
2224
2225  END SUBROUTINE g_smag_km
2226
2227 !        Generated by TAPENADE     (INRIA, Tropics team)
2228 !  Tapenade 3.10 (r5363) -  9 Sep 2014 09:54
2229 !
2230 !  Differentiation of smag2d_km in forward (tangent) mode:
2231 !   variations   of useful results: xkmh xkmv xkhh xkhv
2232 !   with respect to varying inputs: defor11 defor12 zx zy xkmh
2233 !                defor22 xkmv rdzw xkhh xkhv
2234 !   RW status of diff variables: defor11:in defor12:in zx:in zy:in
2235 !                xkmh:in-out defor22:in xkmv:in-out rdzw:in xkhh:in-out
2236 !                xkhv:in-out
2237 SUBROUTINE G_SMAG2D_KM(config_flags, xkmh, xkmhd, xkmv, xkmvd, xkhh, &
2238 &  xkhhd, xkhv, xkhvd, defor11, defor11d, defor22, defor22d, defor12, &
2239 &  defor12d, rdzw, rdzwd, dx, dy, msftx, msfty, zx, zxd, zy, zyd, ids, &
2240 &  ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, &
2241 &  jte, kts, kte)
2242   IMPLICIT NONE
2243   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
2244   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
2245 &  jme, kms, kme, its, ite, jts, jte, kts, kte
2246   REAL, INTENT(IN) :: dx, dy
2247   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzw, zx, zy
2248   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzwd, zxd, &
2249 &  zyd
2250   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmh, &
2251 &  xkmv, xkhh, xkhv
2252   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmhd, &
2253 &  xkmvd, xkhhd, xkhvd
2254   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: defor11, &
2255 &  defor22, defor12
2256   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: defor11d, &
2257 &  defor22d, defor12d
2258   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msftx, msfty
2259 ! LOCAL VARS
2260   INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
2261   REAL :: deltas, tmp, pr, mlen_h, c_s
2262   REAL :: tmpd
2263   REAL :: dxm, dym, tmpzx, tmpzy, alpha, def_limit
2264   REAL :: tmpzxd, tmpzyd, alphad
2265   REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: def2
2266   REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: def2d
2267   REAL :: arg1
2268   REAL :: arg1d
2269   REAL :: abs1d
2270   REAL :: abs4d
2271   REAL :: abs7d
2272   REAL :: x1
2273   REAL :: abs0d
2274   REAL :: abs3d
2275   REAL :: abs6d
2276   REAL :: x1d
2277   REAL :: abs7
2278   REAL :: abs6
2279   REAL :: abs5
2280   REAL :: abs4
2281   REAL :: abs3
2282   REAL :: abs2
2283   REAL :: abs2d
2284   REAL :: abs1
2285   REAL :: abs0
2286   REAL :: abs5d
2287   IF (kte .GT. kde - 1) THEN
2288     ktf = kde - 1
2289   ELSE
2290     ktf = kte
2291   END IF
2292   i_start = its
2293   IF (ite .GT. ide - 1) THEN
2294     i_end = ide - 1
2295   ELSE
2296     i_end = ite
2297   END IF
2298   j_start = jts
2299   IF (jte .GT. jde - 1) THEN
2300     j_end = jde - 1
2301   ELSE
2302     j_end = jte
2303   END IF
2304   IF ((config_flags%open_xs .OR. config_flags%specified) .OR. &
2305 &      config_flags%nested) THEN
2306     IF (ids + 1 .LT. its) THEN
2307       i_start = its
2308     ELSE
2309       i_start = ids + 1
2310     END IF
2311   END IF
2312   IF ((config_flags%open_xe .OR. config_flags%specified) .OR. &
2313 &      config_flags%nested) THEN
2314     IF (ide - 2 .GT. ite) THEN
2315       i_end = ite
2316     ELSE
2317       i_end = ide - 2
2318     END IF
2319   END IF
2320   IF ((config_flags%open_ys .OR. config_flags%specified) .OR. &
2321 &      config_flags%nested) THEN
2322     IF (jds + 1 .LT. jts) THEN
2323       j_start = jts
2324     ELSE
2325       j_start = jds + 1
2326     END IF
2327   END IF
2328   IF ((config_flags%open_ye .OR. config_flags%specified) .OR. &
2329 &      config_flags%nested) THEN
2330     IF (jde - 2 .GT. jte) THEN
2331       j_end = jte
2332     ELSE
2333       j_end = jde - 2
2334     END IF
2335   END IF
2336   IF (config_flags%periodic_x) i_start = its
2337   IF (config_flags%periodic_x) THEN
2338     IF (ite .GT. ide - 1) THEN
2339       i_end = ide - 1
2340     ELSE
2341       i_end = ite
2342     END IF
2343   END IF
2344   pr = prandtl
2345   c_s = config_flags%c_s
2346   def2d = 0.0_8
2347   DO j=j_start,j_end
2348     DO k=kts,ktf
2349       DO i=i_start,i_end
2350         def2d(i, k, j) = 0.25*((defor11d(i, k, j)-defor22d(i, k, j))*(&
2351 &          defor11(i, k, j)-defor22(i, k, j))+(defor11(i, k, j)-defor22(i&
2352 &          , k, j))*(defor11d(i, k, j)-defor22d(i, k, j)))
2353         def2(i, k, j) = 0.25*((defor11(i, k, j)-defor22(i, k, j))*(&
2354 &          defor11(i, k, j)-defor22(i, k, j)))
2355         tmpd = 0.25*(defor12d(i, k, j)+defor12d(i, k, j+1)+defor12d(i+1&
2356 &          , k, j)+defor12d(i+1, k, j+1))
2357         tmp = 0.25*(defor12(i, k, j)+defor12(i, k, j+1)+defor12(i+1, k, &
2358 &          j)+defor12(i+1, k, j+1))
2359         def2d(i, k, j) = def2d(i, k, j) + tmpd*tmp + tmp*tmpd
2360         def2(i, k, j) = def2(i, k, j) + tmp*tmp
2361       END DO
2362     END DO
2363   END DO
2364 !
2365   DO j=j_start,j_end
2366     DO k=kts,ktf
2367       DO i=i_start,i_end
2368         arg1 = dx/msftx(i, j)*dy/msfty(i, j)
2369         mlen_h = SQRT(arg1)
2370         IF (def2(i, k, j) .EQ. 0.0_8) THEN
2371           tmpd = 0.0_8
2372         ELSE
2373           tmpd = def2d(i, k, j)/(2.0*SQRT(def2(i, k, j)))
2374         END IF
2375         tmp = SQRT(def2(i, k, j))
2376 !        xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h )
2377         xkmhd(i, k, j) = c_s**2*mlen_h**2*tmpd
2378         xkmh(i, k, j) = c_s*c_s*mlen_h*mlen_h*tmp
2379         IF (xkmh(i, k, j) .GT. 10.*mlen_h) THEN
2380           xkmhd(i, k, j) = 0.0_8
2381           xkmh(i, k, j) = 10.*mlen_h
2382         ELSE
2383           xkmh(i, k, j) = xkmh(i, k, j)
2384         END IF
2385         xkmvd(i, k, j) = 0.0_8
2386         xkmv(i, k, j) = 0.
2387         xkhhd(i, k, j) = xkmhd(i, k, j)/pr
2388         xkhh(i, k, j) = xkmh(i, k, j)/pr
2389         xkhvd(i, k, j) = 0.0_8
2390         xkhv(i, k, j) = 0.
2391         IF (config_flags%diff_opt .EQ. 2) THEN
2392 ! jd: reduce diffusion coefficient by slope factor (modified by JB August 2014)
2393           dxm = dx/msftx(i, j)
2394           dym = dy/msfty(i, j)
2395           IF (zx(i, k, j) .GE. 0.0_8) THEN
2396             abs0d = zxd(i, k, j)
2397             abs0 = zx(i, k, j)
2398           ELSE
2399             abs0d = -zxd(i, k, j)
2400             abs0 = -zx(i, k, j)
2401           END IF
2402           IF (zx(i+1, k, j) .GE. 0.0_8) THEN
2403             abs2d = zxd(i+1, k, j)
2404             abs2 = zx(i+1, k, j)
2405           ELSE
2406             abs2d = -zxd(i+1, k, j)
2407             abs2 = -zx(i+1, k, j)
2408           END IF
2409           IF (zx(i, k+1, j) .GE. 0.0_8) THEN
2410             abs4d = zxd(i, k+1, j)
2411             abs4 = zx(i, k+1, j)
2412           ELSE
2413             abs4d = -zxd(i, k+1, j)
2414             abs4 = -zx(i, k+1, j)
2415           END IF
2416           IF (zx(i+1, k+1, j) .GE. 0.0_8) THEN
2417             abs6d = zxd(i+1, k+1, j)
2418             abs6 = zx(i+1, k+1, j)
2419           ELSE
2420             abs6d = -zxd(i+1, k+1, j)
2421             abs6 = -zx(i+1, k+1, j)
2422           END IF
2423           tmpzxd = 0.25*dxm*((abs0d+abs2d+abs4d+abs6d)*rdzw(i, k, j)+(&
2424 &           abs0+abs2+abs4+abs6)*rdzwd(i, k, j))
2425           tmpzx = 0.25*(abs0+abs2+abs4+abs6)*rdzw(i, k, j)*dxm
2426           IF (zy(i, k, j) .GE. 0.0_8) THEN
2427             abs1d = zyd(i, k, j)
2428             abs1 = zy(i, k, j)
2429           ELSE
2430             abs1d = -zyd(i, k, j)
2431             abs1 = -zy(i, k, j)
2432           END IF
2433           IF (zy(i, k, j+1) .GE. 0.0_8) THEN
2434             abs3d = zyd(i, k, j+1)
2435             abs3 = zy(i, k, j+1)
2436           ELSE
2437             abs3d = -zyd(i, k, j+1)
2438             abs3 = -zy(i, k, j+1)
2439           END IF
2440           IF (zy(i, k+1, j) .GE. 0.0_8) THEN
2441             abs5d = zyd(i, k+1, j)
2442             abs5 = zy(i, k+1, j)
2443           ELSE
2444             abs5d = -zyd(i, k+1, j)
2445             abs5 = -zy(i, k+1, j)
2446           END IF
2447           IF (zy(i, k+1, j+1) .GE. 0.0_8) THEN
2448             abs7d = zyd(i, k+1, j+1)
2449             abs7 = zy(i, k+1, j+1)
2450           ELSE
2451             abs7d = -zyd(i, k+1, j+1)
2452             abs7 = -zy(i, k+1, j+1)
2453           END IF
2454           tmpzyd = 0.25*dym*((abs1d+abs3d+abs5d+abs7d)*rdzw(i, k, j)+(&
2455 &            abs1+abs3+abs5+abs7)*rdzwd(i, k, j))
2456           tmpzy = 0.25*(abs1+abs3+abs5+abs7)*rdzw(i, k, j)*dym
2457           arg1d = tmpzxd*tmpzx + tmpzx*tmpzxd + tmpzyd*tmpzy + tmpzy*&
2458 &            tmpzyd
2459           arg1 = tmpzx*tmpzx + tmpzy*tmpzy
2460           IF (arg1 .EQ. 0.0_8) THEN
2461             x1d = 0.0_8
2462           ELSE
2463             x1d = arg1d/(2.0*SQRT(arg1))
2464           END IF
2465           x1 = SQRT(arg1)
2466           IF (x1 .LT. 1.0) THEN
2467             alpha = 1.0
2468             alphad = 0.0_8
2469           ELSE
2470             alphad = x1d
2471             alpha = x1
2472           END IF
2473           IF (10.0/mlen_h .LT. 1.e-3) THEN
2474             def_limit = 1.e-3
2475           ELSE
2476             def_limit = 10.0/mlen_h
2477           END IF
2478           IF (tmp .GT. def_limit) THEN
2479             xkmhd(i, k, j) = (xkmhd(i, k, j)*alpha**2-xkmh(i, k, j)*(&
2480 &             alphad*alpha+alpha*alphad))/(alpha*alpha)**2
2481             xkmh(i, k, j) = xkmh(i, k, j)/(alpha*alpha)
2482           ELSE
2483             xkmhd(i, k, j) = (xkmhd(i, k, j)*alpha-xkmh(i, k, j)*alphad)&
2484 &             /alpha**2
2485             xkmh(i, k, j) = xkmh(i, k, j)/alpha
2486           END IF
2487           xkhhd(i, k, j) = xkmhd(i, k, j)/pr
2488           xkhh(i, k, j) = xkmh(i, k, j)/pr
2489         END IF
2490       END DO
2491     END DO
2492   END DO
2493 END SUBROUTINE G_SMAG2D_KM
2494
2495  SUBROUTINE g_phy_bc(config_flags,div,g_div,defor11,g_defor11,defor22, &
2496  g_defor22,defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23, &
2497  g_defor23,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh,xkhv,g_xkhv,tke, &
2498  g_tke,RUBLTEN,g_RUBLTEN,RVBLTEN,g_RVBLTEN,RUCUTEN,g_RUCUTEN,RVCUTEN,g_RVCUTEN,&
2499  RUSHTEN,g_RUSHTEN,RVSHTEN,g_RVSHTEN,ids,ide,jds,jde,kds,kde,ims,ime, &
2500  jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2501
2502  IMPLICIT NONE
2503
2504  REAL :: Tmpv1,g_Tmpv1
2505  TYPE(grid_config_rec_type) :: config_flags
2506  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe, &
2507  its,ite,jts,jte,kts,kte
2508  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: RUBLTEN,g_RUBLTEN,RVBLTEN,g_RVBLTEN, &
2509  RUCUTEN,g_RUCUTEN,RVCUTEN,g_RVCUTEN, RUSHTEN,g_RUSHTEN,RVSHTEN,g_RVSHTEN, &
2510  defor11,g_defor11,defor22,g_defor22,defor33,g_defor33,defor12,g_defor12, &
2511  defor13,g_defor13,defor23,g_defor23,xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
2512  g_xkhh,xkhv,g_xkhv,tke,g_tke,div,g_div
2513
2514  IF(config_flags%bl_pbl_physics .GT. 0) THEN
2515
2516  CALL g_set_physical_bc3d(RUBLTEN,g_RUBLTEN,'t',config_flags,ids,ide,jds,jde, &
2517  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2518
2519  CALL g_set_physical_bc3d(RVBLTEN,g_RVBLTEN,'t',config_flags,ids,ide,jds,jde, &
2520  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2521  ENDIF
2522
2523 !Tiedtke ZCX&YQW
2524  IF(config_flags%cu_physics .GT. 0) THEN
2525
2526  CALL g_set_physical_bc3d(RUCUTEN,g_RUCUTEN,'t',config_flags,ids,ide,jds,jde, &
2527  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2528
2529  CALL g_set_physical_bc3d(RVCUTEN,g_RVCUTEN,'t',config_flags,ids,ide,jds,jde, &
2530  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2531  ENDIF
2532
2533    IF(config_flags%shcu_physics .GT. 0) THEN
2534
2535         CALL g_set_physical_bc3d( RUSHTEN, g_RUSHTEN,'t', config_flags,              &
2536                                 ids, ide, jds, jde, kds, kde,             &
2537                                 ims, ime, jms, jme, kms, kme,             &
2538                                 ips, ipe, jps, jpe, kps, kpe,             &
2539                                 its, ite, jts, jte, kts, kte              )
2540
2541         CALL g_set_physical_bc3d( RVSHTEN, g_RVSHTEN,'t', config_flags,              &
2542                                 ids, ide, jds, jde, kds, kde,             &
2543                                 ims, ime, jms, jme, kms, kme,             &
2544                                 ips, ipe, jps, jpe, kps, kpe,             &
2545                                 its, ite, jts, jte, kts, kte              )
2546
2547    ENDIF
2548
2549  CALL g_set_physical_bc3d(xkmh,g_xkmh,'t',config_flags,ids,ide,jds,jde,kds,kde, &
2550  ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2551
2552  CALL g_set_physical_bc3d(xkhh,g_xkhh,'t',config_flags,ids,ide,jds,jde,kds,kde, &
2553  ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2554
2555  IF(config_flags%diff_opt .eq. 2) THEN
2556
2557  CALL g_set_physical_bc3d(xkmv,g_xkmv,'t',config_flags,ids,ide,jds,jde,kds,kde, &
2558  ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2559
2560  CALL g_set_physical_bc3d(xkhv,g_xkhv,'t',config_flags,ids,ide,jds,jde,kds,kde, &
2561  ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2562
2563  CALL g_set_physical_bc3d(div,g_div,'t',config_flags,ids,ide,jds,jde,kds,kde, &
2564  ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2565
2566  CALL g_set_physical_bc3d(defor11,g_defor11,'t',config_flags,ids,ide,jds,jde, &
2567  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2568
2569  CALL g_set_physical_bc3d(defor22,g_defor22,'t',config_flags,ids,ide,jds,jde, &
2570  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2571
2572  CALL g_set_physical_bc3d(defor33,g_defor33,'t',config_flags,ids,ide,jds,jde, &
2573  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2574
2575  CALL g_set_physical_bc3d(defor12,g_defor12,'d',config_flags,ids,ide,jds,jde, &
2576  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2577
2578  CALL g_set_physical_bc3d(defor13,g_defor13,'e',config_flags,ids,ide,jds,jde, &
2579  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2580
2581  CALL g_set_physical_bc3d(defor23,g_defor23,'f',config_flags,ids,ide,jds,jde, &
2582  kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
2583  ENDIF
2584
2585  END SUBROUTINE g_phy_bc
2586
2587  SUBROUTINE g_tke_km(config_flags,xkmh,g_xkmh,xkmv,g_xkmv,xkhh,g_xkhh, &
2588  xkhv,g_xkhv,bn2,g_bn2,tke,g_tke,p8w,g_p8w,t8w,g_t8w,theta,g_theta, &
2589  rdz,g_rdz,rdzw,g_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide, &
2590  jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2591
2592  IMPLICIT NONE
2593
2594  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
2595  g_Tmpv5,Tmpv6,g_Tmpv6
2596
2597  REAL :: g_Sqrt
2598  TYPE(grid_config_rec_type) :: config_flags
2599  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
2600  INTEGER :: isotropic
2601  REAL :: dx,dy,dt
2602  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,g_tke,p8w,g_p8w,t8w,g_t8w, &
2603  theta,g_theta,rdz,g_rdz,rdzw,g_rdzw,bn2,g_bn2
2604  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,g_xkmh,xkmv,g_xkmv,xkhh, &
2605  g_xkhh,xkhv,g_xkhv
2606  REAL :: mix_upper_bound
2607  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
2608  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,g_l_scale
2609  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dthrdn,g_dthrdn
2610  REAL :: deltas,g_deltas,tmp,g_tmp,mlen_s,g_mlen_s,mlen_h,g_mlen_h,mlen_v, &
2611  g_mlen_v,tmpdz,g_tmpdz,thetasfc,g_thetasfc,thetatop,g_thetatop,minkx, &
2612  g_minkx,pr_inv,g_pr_inv,pr_inv_h,g_pr_inv_h,pr_inv_v,g_pr_inv_v,c_k,g_c_k
2613  INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
2614  REAL,PARAMETER :: tke_seed_value =1.e-06
2615  REAL :: tke_seed
2616  REAL,PARAMETER :: epsilon =1.e-10
2617
2618  ktf =min(kte,kde-1)
2619
2620  i_start =its
2621
2622  i_end =min(ite,ide-1)
2623
2624  j_start =jts
2625
2626  j_end =min(jte,jde-1)
2627
2628  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
2629          config_flags%nested) i_start =max(ids+1,its)
2630
2631  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
2632          config_flags%nested) i_end =min(ide-2,ite)
2633
2634  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
2635          config_flags%nested) j_start =max(jds+1,jts)
2636
2637  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
2638          config_flags%nested) j_end =min(jde-2,jte)
2639
2640  IF( config_flags%periodic_x ) i_start =its
2641
2642  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
2643
2644 !REVISED BY WALLS
2645  g_c_k =0.0
2646  c_k =config_flags%c_k
2647
2648  tke_seed = 0.
2649
2650  IF (config_flags%isfflx .eq. 0) THEN
2651    IF ((config_flags%diff_opt .eq. 2) .and. (config_flags%bl_pbl_physics .eq. 0)) THEN
2652      IF( (config_flags%tke_drag_coefficient .lt. epsilon) .and.  &
2653          (config_flags%tke_heat_flux .lt. epsilon)  )  THEN
2654        tke_seed = tke_seed_value
2655      ENDIF
2656    ELSE
2657      !tke_drag_coefficient and tke_heat_flux are irrelevant here
2658      tke_seed = tke_seed_value
2659    ENDIF
2660  ENDIF
2661
2662  DO j =j_start,j_end
2663  DO k =kts+1,ktf-1
2664  DO i =i_start,i_end
2665
2666  g_tmpdz = -(g_rdz(i,k+1,j)/(rdz(i,k+1,j)*rdz(i,k+1,j))) - &
2667 &   g_rdz(i,k,j)/(rdz(i,k,j)*rdz(i,k,j))
2668  tmpdz = 1.0/rdz(i,k+1,j) + 1.0/rdz(i,k,j)
2669
2670  g_Tmpv1 = ((g_theta(i,k+1,j)-g_theta(i,k-1,j))*tmpdz- &
2671 &   g_tmpdz*(theta(i,k+1,j)-theta(i,k-1,j)))/(tmpdz*tmpdz)
2672  Tmpv1 = (theta(i,k+1,j)-theta(i,k-1,j))/tmpdz
2673
2674  g_dthrdn(i,k,j) =g_Tmpv1
2675  dthrdn(i,k,j) =Tmpv1
2676
2677  ENDDO
2678  ENDDO
2679  ENDDO
2680
2681  k =kts
2682
2683  DO j =j_start,j_end
2684  DO i =i_start,i_end
2685
2686   g_tmpdz = -(g_rdzw(i,k+1,j)/(rdzw(i,k+1,j)*rdzw(i,k+1,j))) - &
2687 &    g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
2688   tmpdz = 1.0/rdzw(i,k+1,j) + 1.0/rdzw(i,k,j)
2689
2690  g_Tmpv1 =(g_T8w(i,kts,j)*(p8w(i,k,j)/p1000mb)**(R_d/Cp) -(R_d/Cp) &
2691 *(g_p8w(i,k,j)/p1000mb)*(p8w(i,k,j)/p1000mb)**((R_d/Cp) -1.0)*T8w(i,kts,j)) &
2692 /((p8w(i,k,j)/p1000mb)**(R_d/Cp)*(p8w(i,k,j)/p1000mb)**(R_d/Cp))
2693  Tmpv1 =T8w(i,kts,j)/(p8w(i,k,j)/p1000mb)**(R_d/Cp)
2694
2695  g_thetasfc =g_Tmpv1
2696  thetasfc =Tmpv1
2697
2698  g_Tmpv1 =((g_theta(i,k+1,j) -g_thetasfc)*tmpdz -g_tmpdz*(theta(i,k+1,j) &
2699  -thetasfc))/(tmpdz*tmpdz)
2700  Tmpv1 =(theta(i,k+1,j) -thetasfc)/tmpdz
2701
2702  g_dthrdn(i,k,j) =g_Tmpv1
2703  dthrdn(i,k,j) =Tmpv1
2704
2705  ENDDO
2706  ENDDO
2707
2708  k =ktf
2709
2710  DO j =j_start,j_end
2711  DO i =i_start,i_end
2712
2713  g_tmpdz =-1.0*g_rdz(i,k,j)/(rdz(i,k,j)*rdz(i,k,j)) +(-0.5*g_rdzw(i,k,j) &
2714 /(rdzw(i,k,j)*rdzw(i,k,j)))
2715  tmpdz =1.0/rdz(i,k,j)+0.5/rdzw(i,k,j)
2716
2717  g_Tmpv1 =(g_T8w(i,kde,j)*(p8w(i,kde,j)/p1000mb)**(R_d/Cp) -(R_d/Cp) &
2718 *(g_p8w(i,kde,j)/p1000mb)*(p8w(i,kde,j)/p1000mb)**((R_d/Cp) -1.0)*T8w(i,kde,j)) &
2719 /((p8w(i,kde,j)/p1000mb)**(R_d/Cp)*(p8w(i,kde,j)/p1000mb)**(R_d/Cp))
2720  Tmpv1 =T8w(i,kde,j)/(p8w(i,kde,j)/p1000mb)**(R_d/Cp)
2721
2722  g_thetatop =g_Tmpv1
2723  thetatop =Tmpv1
2724
2725  g_Tmpv1 =((g_thetatop -g_theta(i,k-1,j))*tmpdz -g_tmpdz*(thetatop - &
2726  theta(i,k-1,j)))/(tmpdz*tmpdz)
2727  Tmpv1 =(thetatop -theta(i,k-1,j))/tmpdz
2728
2729  g_dthrdn(i,k,j) =g_Tmpv1
2730  dthrdn(i,k,j) =Tmpv1
2731
2732  ENDDO
2733  ENDDO
2734
2735 !ADDED BY WALLS
2736 !isotropic=1
2737
2738  IF( isotropic .EQ. 0 ) THEN
2739
2740  DO j =j_start,j_end
2741  DO k =kts,ktf
2742  DO i =i_start,i_end
2743
2744  g_mlen_h =0.0
2745  mlen_h =sqrt(dx/msftx(i,j) *dy/msfty(i,j))
2746
2747  g_tmp =g_Sqrt((g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k, &
2748  j) -(tke_seed)))*0.5, max(tke(i,k,j),tke_seed))
2749  tmp =sqrt(max(tke(i,k,j),tke_seed))
2750
2751  g_deltas =-1.0*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))
2752  deltas =1.0/rdzw(i,k,j)
2753
2754  g_mlen_v =g_deltas
2755  mlen_v =deltas
2756
2757  IF( dthrdn(i,k,j) .GT. 0.) THEN
2758
2759  g_Tmpv1 =g/theta(i,k,j)*g_dthrdn(i,k,j) +(-g*g_theta(i,k,j)/(theta(i,k,j) &
2760 *theta(i,k,j)))*dthrdn(i,k,j)
2761  Tmpv1 =g/theta(i,k,j)*dthrdn(i,k,j)
2762
2763  g_Tmpv2 =(0.76*g_tmp*(abs(Tmpv1))**0.5 -0.5*(sign(1.0, Tmpv1)*g_Tmpv1) &
2764 *(abs(Tmpv1))**(0.5 -1.0)*0.76*tmp)/((abs(Tmpv1))**0.5*(abs(Tmpv1))**0.5)
2765  Tmpv2 =0.76*tmp/(abs(Tmpv1))**0.5
2766
2767  g_mlen_s =g_Tmpv2
2768  mlen_s =Tmpv2
2769
2770  g_mlen_v =(g_mlen_v +g_mlen_s -(g_mlen_v -g_mlen_s)*sign(1.0, mlen_v - &
2771 (mlen_s)))*0.5
2772  mlen_v =min(mlen_v,mlen_s)
2773
2774  END IF
2775
2776  g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
2777  Tmpv1 =c_k*tmp
2778
2779  g_Tmpv2 =Tmpv1*g_mlen_h +g_Tmpv1*mlen_h
2780  Tmpv2 =Tmpv1*mlen_h
2781
2782  g_Tmpv3 =1.0E-6*mlen_h*g_mlen_h +1.0E-6*g_mlen_h*mlen_h
2783  Tmpv3 =1.0E-6*mlen_h*mlen_h
2784
2785  g_xkmh(i,k,j) =(g_Tmpv2 +g_Tmpv3 +(g_Tmpv2 -g_Tmpv3)*sign(1.0, Tmpv2 - &
2786 (Tmpv3)))*0.5
2787  xkmh(i,k,j) =max(Tmpv2,Tmpv3)
2788
2789  g_Tmpv1 =mix_upper_bound*mlen_h*g_mlen_h +mix_upper_bound*g_mlen_h*mlen_h
2790  Tmpv1 =mix_upper_bound*mlen_h*mlen_h
2791
2792  g_xkmh(i,k,j) =(g_xkmh(i,k,j) +(g_Tmpv1/dt) -(g_xkmh(i,k,j) &
2793  -(g_Tmpv1/dt))*sign(1.0, xkmh(i,k,j) -(Tmpv1/dt)))*0.5
2794  xkmh(i,k,j) =min(xkmh(i,k,j),Tmpv1/dt)
2795
2796  g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
2797  Tmpv1 =c_k*tmp
2798
2799  g_Tmpv2 =Tmpv1*g_mlen_v +g_Tmpv1*mlen_v
2800  Tmpv2 =Tmpv1*mlen_v
2801
2802  g_Tmpv3 =1.0E-6*deltas*g_deltas +1.0E-6*g_deltas*deltas
2803  Tmpv3 =1.0E-6*deltas*deltas
2804
2805  g_xkmv(i,k,j) =(g_Tmpv2 +g_Tmpv3 +(g_Tmpv2 -g_Tmpv3)*sign(1.0, Tmpv2 - &
2806 (Tmpv3)))*0.5
2807  xkmv(i,k,j) =max(Tmpv2,Tmpv3)
2808
2809  g_Tmpv1 =mix_upper_bound*deltas*g_deltas +mix_upper_bound*g_deltas*deltas
2810  Tmpv1 =mix_upper_bound*deltas*deltas
2811
2812  g_xkmv(i,k,j) =(g_xkmv(i,k,j) +(g_Tmpv1/dt) -(g_xkmv(i,k,j) &
2813  -(g_Tmpv1/dt))*sign(1.0, xkmv(i,k,j) -(Tmpv1/dt)))*0.5
2814  xkmv(i,k,j) =min(xkmv(i,k,j),Tmpv1/dt)
2815
2816  g_pr_inv_h =0.0
2817  pr_inv_h =1./prandtl
2818
2819  g_Tmpv1 =(2.0*g_mlen_v*deltas -g_deltas*2.0*mlen_v)/(deltas*deltas)
2820  Tmpv1 =2.0*mlen_v/deltas
2821
2822  g_pr_inv_v =g_Tmpv1
2823  pr_inv_v =1.0 +Tmpv1
2824
2825  g_Tmpv1 =xkmh(i,k,j)*g_pr_inv_h +g_xkmh(i,k,j)*pr_inv_h
2826  Tmpv1 =xkmh(i,k,j)*pr_inv_h
2827
2828  g_xkhh(i,k,j) =g_Tmpv1
2829  xkhh(i,k,j) =Tmpv1
2830
2831  g_Tmpv1 =xkmv(i,k,j)*g_pr_inv_v +g_xkmv(i,k,j)*pr_inv_v
2832  Tmpv1 =xkmv(i,k,j)*pr_inv_v
2833
2834  g_xkhv(i,k,j) =g_Tmpv1
2835  xkhv(i,k,j) =Tmpv1
2836
2837  ENDDO
2838  ENDDO
2839  ENDDO
2840  ELSE
2841
2842  CALL g_calc_l_scale(config_flags,tke,g_tke,BN2,g_BN2,l_scale,g_l_scale, &
2843  i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,g_rdzw,msftx,msfty,ids,ide,jds,jde,kds, &
2844  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2845
2846  DO j =j_start,j_end
2847  DO k =kts,ktf
2848  DO i =i_start,i_end
2849
2850  g_tmp =g_Sqrt((g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k, &
2851  j) -(tke_seed)))*0.5, max(tke(i,k,j),tke_seed))
2852  tmp =sqrt(max(tke(i,k,j),tke_seed))
2853
2854  g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
2855 *rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
2856  deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
2857
2858  g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
2859  Tmpv1 =c_k*tmp
2860
2861  g_Tmpv2 =Tmpv1*g_l_scale(i,k,j) +g_Tmpv1*l_scale(i,k,j)
2862  Tmpv2 =Tmpv1*l_scale(i,k,j)
2863
2864  g_xkmh(i,k,j) =g_Tmpv2
2865  xkmh(i,k,j) =Tmpv2
2866
2867  g_xkmh(i,k,j) =(0.0 +g_xkmh(i,k,j) -(0.0 -g_xkmh(i,k,j))*sign(1.0, &
2868  mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt -(xkmh(i,k,j))))*0.5
2869  xkmh(i,k,j) =min(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt,xkmh(i,k,j))
2870
2871  g_Tmpv1 =c_k*g_tmp +g_c_k*tmp
2872  Tmpv1 =c_k*tmp
2873
2874  g_Tmpv2 =Tmpv1*g_l_scale(i,k,j) +g_Tmpv1*l_scale(i,k,j)
2875  Tmpv2 =Tmpv1*l_scale(i,k,j)
2876
2877  g_xkmv(i,k,j) =g_Tmpv2
2878  xkmv(i,k,j) =Tmpv2
2879
2880  g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
2881 *rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
2882
2883 ! Added by Ning Pan, 2010-08-13
2884  Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
2885  g_xkmv(i,k,j) =(g_Tmpv1/dt +g_xkmv(i,k,j) -(g_Tmpv1/dt -g_xkmv(i,k,j)) &
2886 *sign(1.0, Tmpv1/dt -(xkmv(i,k,j))))*0.5
2887
2888  xkmv(i,k,j) =min(mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt,xkmv(i,k,j))
2889
2890  g_Tmpv1 =(2.0*g_l_scale(i,k,j)*deltas -g_deltas*2.0*l_scale(i,k,j))/(deltas*deltas)
2891  Tmpv1 =2.0*l_scale(i,k,j)/deltas
2892
2893  g_pr_inv =g_Tmpv1
2894  pr_inv =1.0 +Tmpv1
2895
2896  g_Tmpv1 =xkmh(i,k,j)*g_pr_inv +g_xkmh(i,k,j)*pr_inv
2897  Tmpv1 =xkmh(i,k,j)*pr_inv
2898
2899  g_xkhh(i,k,j) =(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, mix_upper_bound *dx/ &
2900  msftx(i,j) *dy/msfty(i,j)/dt -(Tmpv1)))*0.5
2901  xkhh(i,k,j) =min(mix_upper_bound *dx/msftx(i,j) *dy/msfty(i,j)/dt,Tmpv1)
2902
2903  g_Tmpv1 =((-mix_upper_bound*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j))) &
2904 *rdzw(i,k,j) -g_rdzw(i,k,j)*mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))
2905  Tmpv1 =mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)
2906
2907  g_Tmpv2 =xkmv(i,k,j)*g_pr_inv +g_xkmv(i,k,j)*pr_inv
2908  Tmpv2 =xkmv(i,k,j)*pr_inv
2909
2910  g_xkhv(i,k,j) =(g_Tmpv1/dt +g_Tmpv2 -(g_Tmpv1/dt -g_Tmpv2) &
2911 *sign(1.0, Tmpv1/dt -(Tmpv2)))*0.5
2912  xkhv(i,k,j) =min(Tmpv1/dt,Tmpv2)
2913
2914  ENDDO
2915  ENDDO
2916  ENDDO
2917  END IF
2918
2919  END SUBROUTINE g_tke_km
2920
2921  SUBROUTINE g_tke_rhs(tendency,g_tendency,BN2,g_BN2,config_flags,defor11, &
2922  g_defor11,defor22,g_defor22,defor33,g_defor33,defor12,g_defor12,defor13, &
2923  g_defor13,defor23,g_defor23,u,g_u,v,g_v,w,g_w,div,g_div,tke, &
2924  g_tke,mu,g_mu,theta,g_theta,p,g_p,p8w,g_p8w,t8w,g_t8w,z,g_z,fnm, &
2925  fnp,cf1,cf2,cf3,msftx,msfty,xkmh,g_xkmh,xkmv,g_xkmv,xkhv,g_xkhv,rdx,rdy,dx, &
2926  dy,dt,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dn,dnw,isotropic,hfx, &
2927  g_hfx,qfx,g_qfx,qv,g_qv,ust,g_ust,rho,g_rho,ids,ide,jds,jde,kds,kde, &
2928  ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2929
2930  IMPLICIT NONE
2931
2932  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
2933  TYPE(grid_config_rec_type) :: config_flags
2934  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
2935  INTEGER :: isotropic
2936  REAL :: cf1,cf2,cf3,dt,rdx,rdy,dx,dy
2937  REAL,DIMENSION(kms:kme) :: fnm,fnp,dnw,dn
2938  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
2939  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
2940  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
2941  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
2942  div,g_div,BN2,g_BN2,tke,g_tke,xkmh,g_xkmh,xkmv,g_xkmv,xkhv,g_xkhv, &
2943  zx,g_zx,zy,g_zy,u,g_u,v,g_v,w,g_w,theta,g_theta,p,g_p,p8w, &
2944  g_p8w,t8w,g_t8w,z,g_z,rdz,g_rdz,rdzw,g_rdzw
2945  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
2946  REAL,DIMENSION(ims:ime,jms:jme) :: hfx,g_hfx,ust,g_ust,qfx,g_qfx
2947  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: qv,g_qv,rho,g_rho
2948  INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
2949
2950  CALL g_tke_shear(tendency,g_tendency,config_flags,defor11,g_defor11,defor22, &
2951  g_defor22,defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23, &
2952  g_defor23,u,g_u,v,g_v,w,g_w,tke,g_tke,ust,g_ust,mu,g_mu,fnm,fnp, &
2953  cf1,cf2,cf3,msftx,msfty,xkmh,g_xkmh,xkmv,g_xkmv,rdx,rdy,zx,g_zx,zy,g_zy, &
2954  rdz,g_rdz,rdzw,g_rdzw,dnw,dn,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
2955  its,ite,jts,jte,kts,kte)
2956
2957  CALL g_tke_buoyancy(tendency,g_tendency,config_flags,mu,g_mu,tke,g_tke, &
2958  xkhv,g_xkhv,BN2,g_BN2,theta,g_theta,dt,hfx,g_hfx,qfx,g_qfx,qv,g_qv, &
2959  rho,g_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2960
2961  CALL g_tke_dissip(tendency,g_tendency,config_flags,mu,g_mu,tke,g_tke,bn2, &
2962  g_bn2,theta,g_theta,p8w,g_p8w,t8w,g_t8w,z,g_z,dx,dy,rdz,g_rdz,rdzw, &
2963  g_rdzw,isotropic,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
2964  ite,jts,jte,kts,kte)
2965
2966  ktf =min(kte,kde-1)
2967
2968  i_start =its
2969
2970  i_end =min(ite,ide-1)
2971
2972  j_start =jts
2973
2974  j_end =min(jte,jde-1)
2975
2976  IF( config_flags%open_xs .or. config_flags%specified .or.   &
2977          config_flags%nested) i_start =max(ids+1,its)
2978
2979  IF( config_flags%open_xe .or. config_flags%specified .or.   &
2980          config_flags%nested) i_end =min(ide-2,ite)
2981
2982  IF( config_flags%open_ys .or. config_flags%specified .or.   &
2983          config_flags%nested) j_start =max(jds+1,jts)
2984
2985  IF( config_flags%open_ye .or. config_flags%specified .or.   &
2986          config_flags%nested) j_end =min(jde-2,jte)
2987
2988  IF( config_flags%periodic_x ) i_start =its
2989
2990  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
2991
2992  DO j =j_start,j_end
2993  DO k =kts,ktf
2994  DO i =i_start,i_end
2995
2996  g_Tmpv1 =-mu(i,j)*(0.0 +g_tke(i,k,j) +(0.0 -g_tke(i,k,j))*sign(1.0, 0.0 -( &
2997  tke(i,k,j))))*0.5 -g_mu(i,j)*max(0.0,tke(i,k,j))
2998  Tmpv1 =-mu(i,j)*max(0.0,tke(i,k,j))
2999
3000  g_tendency(i,k,j) =(g_tendency(i,k,j) +(g_Tmpv1/dt) +(g_tendency(i,k,j) &
3001  -(g_Tmpv1/dt))*sign(1.0, tendency(i,k,j) -(Tmpv1/dt)))*0.5
3002  tendency(i,k,j) =max(tendency(i,k,j),Tmpv1/dt)
3003
3004  ENDDO
3005  ENDDO
3006  ENDDO
3007
3008  END SUBROUTINE g_tke_rhs
3009
3010  SUBROUTINE g_calc_l_scale(config_flags,tke,g_tke,BN2,g_BN2,l_scale, &
3011  g_l_scale,i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,g_rdzw,msftx,msfty,ids, &
3012  ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
3013
3014  IMPLICIT NONE
3015
3016  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
3017
3018    REAL :: g_Sqrt
3019  TYPE(grid_config_rec_type) :: config_flags
3020  INTEGER :: i_start,i_end,ktf,j_start,j_end,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
3021  kms,kme,its,ite,jts,jte,kts,kte
3022  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: BN2,g_BN2,tke,g_tke,rdzw,g_rdzw
3023  REAL :: dx,dy
3024  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,g_l_scale
3025  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
3026  INTEGER :: i,j,k
3027  REAL :: deltas,g_deltas,tmp,g_tmp
3028
3029  DO j =j_start,j_end
3030  DO k =kts,ktf
3031  DO i =i_start,i_end
3032
3033  g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
3034 *rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
3035  deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
3036
3037  g_l_scale(i,k,j) =g_deltas
3038  l_scale(i,k,j) =deltas
3039
3040  IF( BN2(i,k,j) .gt. 1.0e-6 ) THEN
3041
3042  g_tmp =g_Sqrt((g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k, &
3043  j) -(1.0e-6)))*0.5, max(tke(i,k,j),1.0e-6))
3044  tmp =sqrt(max(tke(i,k,j),1.0e-6))
3045
3046  g_Tmpv1 =(0.76*g_tmp*sqrt(BN2(i,k,j)) -g_Sqrt(g_BN2(i,k,j), BN2(i,k,j)) &
3047 *0.76*tmp)/(sqrt(BN2(i,k,j))*sqrt(BN2(i,k,j)))
3048  Tmpv1 =0.76*tmp/sqrt(BN2(i,k,j))
3049
3050  g_l_scale(i,k,j) =g_Tmpv1
3051  l_scale(i,k,j) =Tmpv1
3052
3053  g_l_scale(i,k,j) =(g_l_scale(i,k,j) +g_deltas -(g_l_scale(i,k,j) &
3054  -g_deltas)*sign(1.0, l_scale(i,k,j) -(deltas)))*0.5
3055  l_scale(i,k,j) =min(l_scale(i,k,j),deltas)
3056
3057  g_l_scale(i,k,j) =(g_l_scale(i,k,j) +0.001*g_deltas +(g_l_scale(i,k,j) &
3058  -0.001*g_deltas)*sign(1.0, l_scale(i,k,j) -(0.001*deltas)))*0.5
3059  l_scale(i,k,j) =max(l_scale(i,k,j),0.001*deltas)
3060
3061  END IF
3062  ENDDO
3063  ENDDO
3064  ENDDO
3065
3066  END SUBROUTINE g_calc_l_scale
3067
3068  SUBROUTINE g_tke_buoyancy(tendency,g_tendency,config_flags,mu,g_mu,tke, &
3069  g_tke,xkhv,g_xkhv,BN2,g_BN2,theta,g_theta,dt,hfx,g_hfx,qfx,g_qfx, &
3070  qv,g_qv,rho,g_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
3071  jte,kts,kte)
3072
3073  IMPLICIT NONE
3074
3075  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
3076  TYPE(grid_config_rec_type) :: config_flags
3077  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3078  REAL :: dt
3079  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3080  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhv,g_xkhv,tke,g_tke,BN2,g_BN2, &
3081  theta,g_theta
3082  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
3083  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: qv,g_qv,rho,g_rho
3084  REAL,DIMENSION(ims:ime,jms:jme) :: hfx,g_hfx,qfx,g_qfx
3085  INTEGER :: i,j,k,ktf
3086  INTEGER :: i_start,i_end,j_start,j_end
3087  REAL :: heat_flux,g_heat_flux,heat_flux0,g_heat_flux0
3088  REAL :: cpm,g_cpm
3089
3090  ktf =min(kte,kde-1)
3091
3092  i_start =its
3093
3094  i_end =min(ite,ide-1)
3095
3096  j_start =jts
3097
3098  j_end =min(jte,jde-1)
3099
3100  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
3101          config_flags%nested ) i_start =max(ids+1,its)
3102
3103  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
3104          config_flags%nested ) i_end =min(ide-2,ite)
3105
3106  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
3107          config_flags%nested ) j_start =max(jds+1,jts)
3108
3109  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
3110          config_flags%nested ) j_end =min(jde-2,jte)
3111
3112  IF( config_flags%periodic_x ) i_start =its
3113
3114  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
3115
3116  DO j =j_start,j_end
3117  DO k =kts+1,ktf
3118  DO i =i_start,i_end
3119
3120  g_Tmpv1 =mu(i,j)*g_xkhv(i,k,j) +g_mu(i,j)*xkhv(i,k,j)
3121  Tmpv1 =mu(i,j)*xkhv(i,k,j)
3122
3123  g_Tmpv2 =Tmpv1*g_BN2(i,k,j) +g_Tmpv1*BN2(i,k,j)
3124  Tmpv2 =Tmpv1*BN2(i,k,j)
3125
3126  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv2
3127  tendency(i,k,j) =tendency(i,k,j) -Tmpv2
3128
3129  ENDDO
3130  ENDDO
3131  ENDDO
3132
3133 ! Added by Ning Pan, 2010-08-12
3134  tl_hflux: SELECT CASE( config_flags%isfflx )
3135  CASE (0,2)
3136
3137 ! g_heat_flux0 =g_config_flags%tke_heat_flux  ! Remarked by Ning Pan, 2010-08-12
3138  heat_flux0 =config_flags%tke_heat_flux
3139
3140  K =KTS
3141
3142  DO j =j_start,j_end
3143  DO i =i_start,i_end
3144
3145 ! g_heat_flux =g_heat_flux0  ! Remarked by Ning Pan, 2010-08-12
3146  heat_flux =heat_flux0
3147
3148  g_Tmpv1 =xkhv(i,k,j)*g_BN2(i,k,j) +g_xkhv(i,k,j)*BN2(i,k,j)
3149  Tmpv1 =xkhv(i,k,j)*BN2(i,k,j)
3150
3151 ! Revised by Ning Pan, 2010-08-12
3152 ! g_Tmpv2 =(g/theta(i,k,j))*g_heat_flux +(-g*g_theta(i,k,j)/(theta(i,k,j) &
3153 !*theta(i,k,j)))*heat_flux
3154  g_Tmpv2 =(-g*g_theta(i,k,j)/(theta(i,k,j) &
3155 *theta(i,k,j)))*heat_flux
3156  Tmpv2 =(g/theta(i,k,j))*heat_flux
3157
3158  g_Tmpv3 =mu(i,j)*((g_Tmpv1) -g_Tmpv2) +g_mu(i,j)*((Tmpv1) -Tmpv2)
3159  Tmpv3 =mu(i,j)*((Tmpv1) -Tmpv2)
3160
3161  g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv3/2.)
3162  tendency(i,k,j) =tendency(i,k,j) -Tmpv3/2.
3163
3164  ENDDO
3165  ENDDO
3166
3167  CASE (1)  ! Added by Ning Pan, 2010-08-12
3168
3169  K =KTS
3170
3171  DO j =j_start,j_end
3172  DO i =i_start,i_end
3173
3174  g_cpm =cp*(0.8*g_qv(i,k,j))
3175  cpm =cp*(1. +0.8*qv(i,k,j))
3176
3177  g_Tmpv1 =(g_hfx(i,j)*cpm -g_cpm*hfx(i,j))/(cpm*cpm)
3178  Tmpv1 =hfx(i,j)/cpm
3179
3180  g_Tmpv2 =((g_Tmpv1)*rho(i,k,j) -g_rho(i,k,j)*(Tmpv1))/(rho(i,k,j)*rho(i,k,j))
3181  Tmpv2 =(Tmpv1)/rho(i,k,j)
3182
3183  g_heat_flux =g_Tmpv2
3184  heat_flux =Tmpv2
3185
3186  g_Tmpv1 =xkhv(i,k,j)*g_BN2(i,k,j) +g_xkhv(i,k,j)*BN2(i,k,j)
3187  Tmpv1 =xkhv(i,k,j)*BN2(i,k,j)
3188
3189  g_Tmpv2 =(g/theta(i,k,j))*g_heat_flux +(-g*g_theta(i,k,j)/(theta(i,k,j) &
3190 *theta(i,k,j)))*heat_flux
3191  Tmpv2 =(g/theta(i,k,j))*heat_flux
3192
3193  g_Tmpv3 =mu(i,j)*((g_Tmpv1) -g_Tmpv2) +g_mu(i,j)*((Tmpv1) -Tmpv2)
3194  Tmpv3 =mu(i,j)*((Tmpv1) -Tmpv2)
3195
3196  g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv3/2.)
3197  tendency(i,k,j) =tendency(i,k,j) -Tmpv3/2.
3198
3199  ENDDO
3200  ENDDO
3201
3202  CASE DEFAULT  ! Added by Ning Pan, 2010-08-12
3203 ! Revised by Ning Pan, 2010-08-12
3204 ! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
3205  CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
3206  END SELECT tl_hflux  ! Added by Ning Pan, 2010-08-12
3207
3208  END SUBROUTINE g_tke_buoyancy
3209
3210  SUBROUTINE g_tke_dissip(tendency,g_tendency,config_flags,mu,g_mu,tke, &
3211  g_tke,bn2,g_bn2,theta,g_theta,p8w,g_p8w,t8w,g_t8w,z,g_z,dx,dy,rdz, &
3212  g_rdz,rdzw,g_rdzw,isotropic,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
3213  jme,kms,kme,its,ite,jts,jte,kts,kte)
3214
3215  IMPLICIT NONE
3216
3217  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
3218  TYPE(grid_config_rec_type) :: config_flags
3219  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3220  INTEGER :: isotropic
3221  REAL :: dx,dy
3222  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3223  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,g_tke,bn2,g_bn2,theta, &
3224  g_theta,p8w,g_p8w,t8w,g_t8w,z,g_z,rdz,g_rdz,rdzw,g_rdzw
3225  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
3226  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
3227  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dthrdn,g_dthrdn
3228  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,g_l_scale
3229  REAL,DIMENSION(its:ite) :: sumtke,g_sumtke,sumtkez,g_sumtkez
3230  INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
3231  REAL :: disp_len,g_disp_len,deltas,g_deltas,coefc,g_coefc,tmpdz,g_tmpdz, &
3232  len_s,g_len_s,thetasfc,g_thetasfc,thetatop,g_thetatop,len_0,g_len_0, &
3233  tketmp,g_tketmp,tmp,g_tmp,ce1,g_ce1,ce2,g_ce2,c_k,g_c_k
3234
3235 ! g_c_k =g_config_flags%c_k  ! Remarked by Ning Pan, 2010-08-12
3236  c_k =config_flags%c_k
3237
3238 ! g_ce1 =(g_c_k/0.10)*0.19  ! Remarked by Ning Pan, 2010-08-12
3239  ce1 =(c_k/0.10)*0.19
3240
3241 ! g_ce2 =(0.0 +-g_ce1 +(0.0 --g_ce1)*sign(1.0, 0.0 -(0.93 -ce1)))*0.5  ! Remarked by Ning Pan, 2010-08-12
3242  ce2 =max(0.0,0.93 -ce1)
3243
3244  ktf =min(kte,kde-1)
3245
3246  i_start =its
3247
3248  i_end =min(ite,ide-1)
3249
3250  j_start =jts
3251
3252  j_end =min(jte,jde-1)
3253
3254  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
3255          config_flags%nested) i_start =max(ids+1,its)
3256
3257  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
3258          config_flags%nested) i_end =min(ide-2,ite)
3259
3260  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
3261          config_flags%nested) j_start =max(jds+1,jts)
3262
3263  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
3264          config_flags%nested) j_end =min(jde-2,jte)
3265
3266  IF( config_flags%periodic_x ) i_start =its
3267
3268  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
3269
3270  CALL g_calc_l_scale(config_flags,tke,g_tke,BN2,g_BN2,l_scale,g_l_scale, &
3271  i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,g_rdzw,msftx,msfty,ids,ide,jds,jde,kds, &
3272  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
3273
3274  DO j =j_start,j_end
3275  DO k =kts,ktf
3276  DO i =i_start,i_end
3277
3278  g_deltas =0.33333333*(-dx/msftx(i,j) *dy/msfty(i,j)*g_rdzw(i,k,j)/(rdzw(i,k,j) &
3279 *rdzw(i,k,j)))*(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1.0)
3280  deltas =(dx/msftx(i,j) *dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
3281
3282  g_tketmp =(g_tke(i,k,j) +0.0 +(g_tke(i,k,j) -0.0)*sign(1.0, tke(i,k,j) &
3283  -(1.0e-6)))*0.5
3284  tketmp =max(tke(i,k,j),1.0e-6)
3285
3286  IF( k .eq. kts .or. k .eq. ktf ) THEN
3287
3288  g_coefc =0.0
3289  coefc =3.9
3290
3291  ELSE
3292
3293 ! Revised by Ning Pan, 2010-08-12
3294 ! g_Tmpv1 =ce2*g_l_scale(i,k,j) +g_ce2*l_scale(i,k,j)
3295  g_Tmpv1 =ce2*g_l_scale(i,k,j)
3296  Tmpv1 =ce2*l_scale(i,k,j)
3297
3298  g_Tmpv2 =(g_Tmpv1*deltas -g_deltas*Tmpv1)/(deltas*deltas)
3299  Tmpv2 =Tmpv1/deltas
3300
3301 ! Revised by Ning Pan, 2010-08-12
3302 ! g_coefc =g_ce1 +g_Tmpv2
3303  g_coefc =g_Tmpv2
3304  coefc =ce1 +Tmpv2
3305
3306  END IF
3307
3308  g_Tmpv1 =mu(i,j)*g_coefc +g_mu(i,j)*coefc
3309  Tmpv1 =mu(i,j)*coefc
3310
3311  g_Tmpv2 =Tmpv1*1.5*g_tketmp*tketmp**(1.5 -1.0) +g_Tmpv1*tketmp**1.5
3312  Tmpv2 =Tmpv1*tketmp**1.5
3313
3314  g_Tmpv3 =(g_Tmpv2*l_scale(i,k,j) -g_l_scale(i,k,j)*Tmpv2)/(l_scale(i,k,j) &
3315 *l_scale(i,k,j))
3316  Tmpv3 =Tmpv2/l_scale(i,k,j)
3317
3318  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv3
3319  tendency(i,k,j) =tendency(i,k,j) -Tmpv3
3320
3321  ENDDO
3322  ENDDO
3323  ENDDO
3324
3325  END SUBROUTINE g_tke_dissip
3326
3327  SUBROUTINE g_tke_shear(tendency,g_tendency,config_flags,defor11,g_defor11, &
3328  defor22,g_defor22,defor33,g_defor33,defor12,g_defor12,defor13,g_defor13, &
3329  defor23,g_defor23,u,g_u,v,g_v,w,g_w,tke,g_tke,ust,g_ust,mu,g_mu, &
3330  fnm,fnp,cf1,cf2,cf3,msftx,msfty,xkmh,g_xkmh,xkmv,g_xkmv,rdx,rdy,zx,g_zx,zy, &
3331  g_zy,rdz,g_rdz,rdzw,g_rdzw,dn,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
3332  kms,kme,its,ite,jts,jte,kts,kte)
3333
3334  IMPLICIT NONE
3335
3336  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
3337
3338    REAL :: g_Sqrt
3339  TYPE(grid_config_rec_type) :: config_flags
3340  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3341  REAL :: cf1,cf2,cf3,rdx,rdy
3342  REAL,DIMENSION(kms:kme) :: fnm,fnp,dn,dnw
3343  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
3344  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3345  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
3346  defor33,g_defor33,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23, &
3347  tke,g_tke,xkmh,g_xkmh,xkmv,g_xkmv,zx,g_zx,zy,g_zy,u,g_u,v,g_v,w, &
3348  g_w,rdz,g_rdz,rdzw,g_rdzw
3349  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
3350  REAL,DIMENSION(ims:ime,jms:jme) :: ust,g_ust
3351  INTEGER :: i,j,k,ktf,ktes1,ktes2,i_start,i_end,j_start,j_end,is_ext,ie_ext,js_ext,je_ext
3352  REAL :: mtau,g_mtau
3353  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: avg,g_avg,titau,g_titau, &
3354  tmp2,g_tmp2
3355  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: titau12,g_titau12,tmp1,g_tmp1,zxavg, &
3356  g_zxavg,zyavg,g_zyavg
3357  REAL :: absU,g_absU,cd0,g_cd0,Cd,g_Cd
3358
3359  ktf =min(kte,kde-1)
3360
3361  ktes1 =kte-1
3362
3363  ktes2 =kte-2
3364
3365  i_start =its
3366
3367  i_end =min(ite,ide-1)
3368
3369  j_start =jts
3370
3371  j_end =min(jte,jde-1)
3372
3373  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
3374          config_flags%nested ) i_start =max(ids+1,its)
3375
3376  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
3377          config_flags%nested ) i_end =min(ide-2,ite)
3378
3379  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
3380          config_flags%nested ) j_start =max(jds+1,jts)
3381
3382  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
3383          config_flags%nested ) j_end =min(jde-2,jte)
3384
3385  IF( config_flags%periodic_x ) i_start =its
3386
3387  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
3388
3389  DO j =j_start,j_end
3390  DO k =kts,ktf
3391  DO i =i_start,i_end
3392
3393  g_zxavg(i,k,j) =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k+1,j) &
3394  +g_zx(i+1,k+1,j))
3395  zxavg(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))
3396
3397  g_zyavg(i,k,j) =0.25*(g_zy(i,k,j) +g_zy(i,k,j+1) +g_zy(i,k+1,j) &
3398  +g_zy(i,k+1,j+1))
3399  zyavg(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))
3400
3401  ENDDO
3402  ENDDO
3403  ENDDO
3404
3405  DO j =j_start,j_end
3406  DO k =kts,ktf
3407  DO i =i_start,i_end
3408
3409  g_Tmpv1 =0.5*mu(i,j)*g_xkmh(i,k,j) +0.5*g_mu(i,j)*xkmh(i,k,j)
3410  Tmpv1 =0.5*mu(i,j)*xkmh(i,k,j)
3411
3412  g_Tmpv2 =Tmpv1*(2.0*(g_defor11(i,k,j))*(defor11(i,k,j))) +g_Tmpv1*(( &
3413  defor11(i,k,j))**2)
3414  Tmpv2 =Tmpv1*((defor11(i,k,j))**2)
3415
3416  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3417  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3418
3419  ENDDO
3420  ENDDO
3421  ENDDO
3422
3423  DO j =j_start,j_end
3424  DO k =kts,ktf
3425  DO i =i_start,i_end
3426
3427  g_Tmpv1 =0.5*mu(i,j)*g_xkmh(i,k,j) +0.5*g_mu(i,j)*xkmh(i,k,j)
3428  Tmpv1 =0.5*mu(i,j)*xkmh(i,k,j)
3429
3430  g_Tmpv2 =Tmpv1*(2.0*(g_defor22(i,k,j))*(defor22(i,k,j))) +g_Tmpv1*(( &
3431  defor22(i,k,j))**2)
3432  Tmpv2 =Tmpv1*((defor22(i,k,j))**2)
3433
3434  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3435  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3436
3437  ENDDO
3438  ENDDO
3439  ENDDO
3440
3441  DO j =j_start,j_end
3442  DO k =kts,ktf
3443  DO i =i_start,i_end
3444
3445  g_Tmpv1 =0.5*mu(i,j)*g_xkmv(i,k,j) +0.5*g_mu(i,j)*xkmv(i,k,j)
3446  Tmpv1 =0.5*mu(i,j)*xkmv(i,k,j)
3447
3448  g_Tmpv2 =Tmpv1*(2.0*(g_defor33(i,k,j))*(defor33(i,k,j))) +g_Tmpv1*(( &
3449  defor33(i,k,j))**2)
3450  Tmpv2 =Tmpv1*((defor33(i,k,j))**2)
3451
3452  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3453  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3454
3455  ENDDO
3456  ENDDO
3457  ENDDO
3458
3459  DO j =j_start,j_end
3460  DO k =kts,ktf
3461  DO i =i_start,i_end
3462
3463  g_avg(i,k,j) =0.25*((2.0*g_defor12(i,k,j)*defor12(i,k,j)) +(2.0*g_defor12(i, &
3464  k,j+1)*defor12(i,k,j+1)) +(2.0*g_defor12(i+1,k,j)*defor12(i+1,k,j)) +(2.0* &
3465  g_defor12(i+1,k,j+1)*defor12(i+1,k,j+1)))
3466  avg(i,k,j) =0.25*((defor12(i,k,j)**2) +(defor12(i,k,j+1)**2) +(defor12(i+1,k,j)**2) &
3467  +(defor12(i+1,k,j+1)**2))
3468
3469  ENDDO
3470  ENDDO
3471  ENDDO
3472
3473  DO j =j_start,j_end
3474  DO k =kts,ktf
3475  DO i =i_start,i_end
3476
3477  g_Tmpv1 =mu(i,j)*g_xkmh(i,k,j) +g_mu(i,j)*xkmh(i,k,j)
3478  Tmpv1 =mu(i,j)*xkmh(i,k,j)
3479
3480  g_Tmpv2 =Tmpv1*g_avg(i,k,j) +g_Tmpv1*avg(i,k,j)
3481  Tmpv2 =Tmpv1*avg(i,k,j)
3482
3483  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3484  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3485
3486  ENDDO
3487  ENDDO
3488  ENDDO
3489
3490  DO j =j_start,j_end
3491  DO k =kts+1,ktf
3492  DO i =i_start,i_end+1
3493
3494  g_tmp2(i,k,j) =g_defor13(i,k,j)
3495  tmp2(i,k,j) =defor13(i,k,j)
3496
3497  ENDDO
3498  ENDDO
3499  ENDDO
3500
3501  DO j =j_start,j_end
3502  DO i =i_start,i_end+1
3503
3504  g_tmp2(i,kts,j) =0.0
3505  tmp2(i,kts,j) =0.0
3506
3507  g_tmp2(i,ktf+1,j) =0.0
3508  tmp2(i,ktf+1,j) =0.0
3509
3510  ENDDO
3511  ENDDO
3512
3513  DO j =j_start,j_end
3514  DO k =kts,ktf
3515  DO i =i_start,i_end
3516
3517  g_avg(i,k,j) =0.25*((2.0*g_tmp2(i,k+1,j)*tmp2(i,k+1,j)) +(2.0*g_tmp2(i,k,j) &
3518 *tmp2(i,k,j)) +(2.0*g_tmp2(i+1,k+1,j)*tmp2(i+1,k+1,j)) +(2.0*g_tmp2(i+1,k,j) &
3519 *tmp2(i+1,k,j)))
3520  avg(i,k,j) =0.25*((tmp2(i,k+1,j)**2) +(tmp2(i,k,j)**2) +(tmp2(i+1,k+1,j)**2) &
3521  +(tmp2(i+1,k,j)**2))
3522
3523  ENDDO
3524  ENDDO
3525  ENDDO
3526
3527  DO j =j_start,j_end
3528  DO k =kts,ktf
3529  DO i =i_start,i_end
3530
3531  g_Tmpv1 =mu(i,j)*g_xkmv(i,k,j) +g_mu(i,j)*xkmv(i,k,j)
3532  Tmpv1 =mu(i,j)*xkmv(i,k,j)
3533
3534  g_Tmpv2 =Tmpv1*g_avg(i,k,j) +g_Tmpv1*avg(i,k,j)
3535  Tmpv2 =Tmpv1*avg(i,k,j)
3536
3537  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3538  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3539
3540  ENDDO
3541  ENDDO
3542  ENDDO
3543
3544  K =KTS
3545
3546 ! Added by Ning Pan, 2010-08-12
3547  tl_uflux: SELECT CASE( config_flags%isfflx )
3548  CASE (0)
3549
3550 ! g_cd0 =g_config_flags%tke_drag_coefficient  ! Remarked by Ning Pan, 2010-08-12
3551  cd0 =config_flags%tke_drag_coefficient
3552
3553  DO j =j_start,j_end
3554  DO i =i_start,i_end
3555
3556  g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
3557  +2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
3558 **2 +(v(i,k,j) +v(i,k,j+1))**2)
3559  absU =0.5*sqrt((u(i,k,j) +u(i+1,k,j))**2 +(v(i,k,j) +v(i,k,j+1))**2)
3560
3561 ! Revised by Ning Pan, 2010-08-12
3562 ! g_Cd =g_cd0
3563  g_Cd =0.0
3564  Cd =cd0
3565
3566  g_Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*g_Cd +(g_u(i,k,j) +g_u(i+1,k,j))*0.5*Cd
3567  Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*Cd
3568
3569  g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
3570  Tmpv2 =Tmpv1*absU
3571
3572  g_Tmpv3 =Tmpv2*(g_defor13(i,kts+1,j) +g_defor13(i+1,kts+1,j)) &
3573  +g_Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
3574  Tmpv3 =Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
3575
3576  g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
3577  Tmpv4 =mu(i,j)*(Tmpv3*0.5)
3578
3579  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
3580  tendency(i,k,j) =tendency(i,k,j) +Tmpv4
3581
3582  ENDDO
3583  ENDDO
3584
3585  CASE (1,2)  ! Added by Ning Pan, 2010-08-12
3586
3587  DO j =j_start,j_end
3588  DO i =i_start,i_end
3589
3590  g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
3591  +2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
3592 **2 +(v(i,k,j) +v(i,k,j+1))**2)
3593  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
3594
3595  g_Tmpv1 =((2.0*g_ust(i,j)*ust(i,j))*(absU**2) -(2.0*g_absU*absU)*(ust(i,j) &
3596 **2))/((absU**2)*(absU**2))
3597  Tmpv1 =(ust(i,j)**2)/(absU**2)
3598
3599  g_Cd =g_Tmpv1
3600  Cd =Tmpv1
3601
3602  g_Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*g_Cd +(g_u(i,k,j) +g_u(i+1,k,j))*0.5*Cd
3603  Tmpv1 =(u(i,k,j) +u(i+1,k,j))*0.5*Cd
3604
3605  g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
3606  Tmpv2 =Tmpv1*absU
3607
3608  g_Tmpv3 =Tmpv2*(g_defor13(i,kts+1,j) +g_defor13(i+1,kts+1,j)) &
3609  +g_Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
3610  Tmpv3 =Tmpv2*(defor13(i,kts+1,j) +defor13(i+1,kts+1,j))
3611
3612  g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
3613  Tmpv4 =mu(i,j)*(Tmpv3*0.5)
3614
3615  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
3616  tendency(i,k,j) =tendency(i,k,j) +Tmpv4
3617
3618  ENDDO
3619  ENDDO
3620
3621  CASE DEFAULT  ! Added by Ning Pan, 2010-08-12
3622 ! Revised by Ning Pan, 2010-08-12
3623 ! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
3624  CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
3625  END SELECT tl_uflux  ! Added by Ning Pan, 2010-08-12
3626
3627  DO j =j_start,j_end+1
3628  DO k =kts+1,ktf
3629  DO i =i_start,i_end
3630
3631  g_tmp2(i,k,j) =g_defor23(i,k,j)
3632  tmp2(i,k,j) =defor23(i,k,j)
3633
3634  ENDDO
3635  ENDDO
3636  ENDDO
3637
3638  DO j =j_start,j_end+1
3639  DO i =i_start,i_end
3640
3641  g_tmp2(i,kts,j) =0.0
3642  tmp2(i,kts,j) =0.0
3643
3644  g_tmp2(i,ktf+1,j) =0.0
3645  tmp2(i,ktf+1,j) =0.0
3646
3647  ENDDO
3648  ENDDO
3649
3650  DO j =j_start,j_end
3651  DO k =kts,ktf
3652  DO i =i_start,i_end
3653
3654  g_avg(i,k,j) =0.25*((2.0*g_tmp2(i,k+1,j)*tmp2(i,k+1,j)) +(2.0*g_tmp2(i,k,j) &
3655 *tmp2(i,k,j)) +(2.0*g_tmp2(i,k+1,j+1)*tmp2(i,k+1,j+1)) +(2.0*g_tmp2(i,k,j+1) &
3656 *tmp2(i,k,j+1)))
3657  avg(i,k,j) =0.25*((tmp2(i,k+1,j)**2) +(tmp2(i,k,j)**2) +(tmp2(i,k+1,j+1)**2) &
3658  +(tmp2(i,k,j+1)**2))
3659
3660  ENDDO
3661  ENDDO
3662  ENDDO
3663
3664  DO j =j_start,j_end
3665  DO k =kts,ktf
3666  DO i =i_start,i_end
3667
3668  g_Tmpv1 =mu(i,j)*g_xkmv(i,k,j) +g_mu(i,j)*xkmv(i,k,j)
3669  Tmpv1 =mu(i,j)*xkmv(i,k,j)
3670
3671  g_Tmpv2 =Tmpv1*g_avg(i,k,j) +g_Tmpv1*avg(i,k,j)
3672  Tmpv2 =Tmpv1*avg(i,k,j)
3673
3674  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3675  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3676
3677  ENDDO
3678  ENDDO
3679  ENDDO
3680
3681  K =KTS
3682
3683 ! Added by Ning Pan, 2010-08-12
3684  tl_vflux: SELECT CASE( config_flags%isfflx )
3685  CASE (0)
3686
3687 ! g_cd0 =g_config_flags%tke_drag_coefficient  ! Remarked by Ning Pan, 2010-08-12
3688  cd0 =config_flags%tke_drag_coefficient
3689
3690  DO j =j_start,j_end
3691  DO i =i_start,i_end
3692
3693  g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
3694  +2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
3695 **2 +(v(i,k,j) +v(i,k,j+1))**2)
3696  absU =0.5*sqrt((u(i,k,j) +u(i+1,k,j))**2 +(v(i,k,j) +v(i,k,j+1))**2)
3697
3698 ! Revised by Ning Pan, 2010-08-12
3699 ! g_Cd =g_cd0
3700  g_Cd =0.0
3701  Cd =cd0
3702
3703  g_Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*g_Cd +(g_v(i,k,j) +g_v(i,k,j+1))*0.5*Cd
3704  Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*Cd
3705
3706  g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
3707  Tmpv2 =Tmpv1*absU
3708
3709  g_Tmpv3 =Tmpv2*(g_defor23(i,kts+1,j) +g_defor23(i,kts+1,j+1)) &
3710  +g_Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
3711  Tmpv3 =Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
3712
3713  g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
3714  Tmpv4 =mu(i,j)*(Tmpv3*0.5)
3715
3716  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
3717  tendency(i,k,j) =tendency(i,k,j) +Tmpv4
3718
3719  ENDDO
3720  ENDDO
3721
3722  CASE (1,2)  ! Added by Ning Pan, 2010-08-12
3723
3724  DO j =j_start,j_end
3725  DO i =i_start,i_end
3726
3727  g_absU =0.5*g_Sqrt(2.0*(g_u(i,k,j) +g_u(i+1,k,j))*(u(i,k,j) +u(i+1,k,j)) &
3728  +2.0*(g_v(i,k,j) +g_v(i,k,j+1))*(v(i,k,j) +v(i,k,j+1)), (u(i,k,j) +u(i+1,k,j)) &
3729 **2 +(v(i,k,j) +v(i,k,j+1))**2)
3730  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
3731
3732  g_Tmpv1 =((2.0*g_ust(i,j)*ust(i,j))*(absU**2) -(2.0*g_absU*absU)*(ust(i,j) &
3733 **2))/((absU**2)*(absU**2))
3734  Tmpv1 =(ust(i,j)**2)/(absU**2)
3735
3736  g_Cd =g_Tmpv1
3737  Cd =Tmpv1
3738
3739  g_Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*g_Cd +(g_v(i,k,j) +g_v(i,k,j+1))*0.5*Cd
3740  Tmpv1 =(v(i,k,j) +v(i,k,j+1))*0.5*Cd
3741
3742  g_Tmpv2 =Tmpv1*g_absU +g_Tmpv1*absU
3743  Tmpv2 =Tmpv1*absU
3744
3745  g_Tmpv3 =Tmpv2*(g_defor23(i,kts+1,j) +g_defor23(i,kts+1,j+1)) &
3746  +g_Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
3747  Tmpv3 =Tmpv2*(defor23(i,kts+1,j) +defor23(i,kts+1,j+1))
3748
3749  g_Tmpv4 =mu(i,j)*(g_Tmpv3*0.5) +g_mu(i,j)*(Tmpv3*0.5)
3750  Tmpv4 =mu(i,j)*(Tmpv3*0.5)
3751
3752  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv4
3753  tendency(i,k,j) =tendency(i,k,j) +Tmpv4
3754
3755  ENDDO
3756  ENDDO
3757
3758  CASE DEFAULT  ! Added by Ning Pan, 2010-08-12
3759 ! Revised by Ning Pan, 2010-08-12
3760 ! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
3761     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
3762  END SELECT tl_vflux  ! Added by Ning Pan, 2010-08-12
3763
3764  END SUBROUTINE g_tke_shear
3765
3766 !        Generated by TAPENADE     (INRIA, Tropics team)
3767 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
3768 !
3769 !  Differentiation of compute_diff_metrics in forward (tangent) mode:
3770 !   variations   of useful results: zx zy z rdzw rdz
3771 !   with respect to varying inputs: zx zy z rdzw rdz ph
3772 !   RW status of diff variables: zx:in-out zy:in-out z:in-out rdzw:in-out
3773 !                rdz:in-out ph:in
3774 SUBROUTINE G_COMPUTE_DIFF_METRICS(config_flags, ph, phd, phb, z, zd, rdz&
3775 &  , rdzd, rdzw, rdzwd, zx, zxd, zy, zyd, rdx, rdy, ids, ide, jds, jde, &
3776 &  kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
3777   IMPLICIT NONE
3778   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
3779   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3780 &  jme, kms, kme, its, ite, jts, jte, kts, kte
3781   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ph, phb
3782   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: phd
3783   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rdz, rdzw, &
3784 &  zx, zy, z
3785   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rdzd, rdzwd&
3786 &  , zxd, zyd, zd
3787   REAL, INTENT(IN) :: rdx, rdy
3788 ! Local variables.
3789   REAL, DIMENSION(its - 1:ite, kts:kte, jts - 1:jte) :: z_at_w
3790   REAL, DIMENSION(its-1:ite, kts:kte, jts-1:jte) :: z_at_wd
3791   INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
3792   INTEGER :: min1
3793   INTEGER :: max4
3794   INTEGER :: max3
3795   INTEGER :: max2
3796   INTEGER :: max1
3797
3798   IF (kte .GT. kde - 1) THEN
3799     ktf = kde - 1
3800   ELSE
3801     ktf = kte
3802   END IF
3803 ! Bug fix, WCS, 22 april 2002.
3804 ! We need rdzw in halo for average to u and v points.
3805   j_start = jts - 1
3806   j_end = jte
3807   z_at_wd = 0.0
3808 ! Begin with dz computations.
3809   DO j=j_start,j_end
3810     IF (jte .GT. jde - 1) THEN
3811       min1 = jde - 1
3812     ELSE
3813       min1 = jte
3814     END IF
3815     IF (j_start .GE. jts .AND. j_end .LE. min1) THEN
3816       i_start = its - 1
3817       i_end = ite
3818     ELSE
3819       i_start = its
3820       IF (ite .GT. ide - 1) THEN
3821         i_end = ide - 1
3822       ELSE
3823         i_end = ite
3824       END IF
3825     END IF
3826 ! Compute z at w points for rdz and rdzw computations.  We'll switch z
3827 ! to z at p points before returning
3828     DO k=1,kte
3829 ! Bug fix, WCS, 22 april 2002
3830       DO i=i_start,i_end
3831         z_at_wd(i, k, j) = phd(i, k, j)/g
3832         z_at_w(i, k, j) = (ph(i, k, j)+phb(i, k, j))/g
3833       END DO
3834     END DO
3835     DO k=1,ktf
3836       DO i=i_start,i_end
3837         rdzwd(i, k, j) = -((z_at_wd(i, k+1, j)-z_at_wd(i, k, j))/(z_at_w&
3838 &          (i, k+1, j)-z_at_w(i, k, j))**2)
3839         rdzw(i, k, j) = 1.0/(z_at_w(i, k+1, j)-z_at_w(i, k, j))
3840       END DO
3841     END DO
3842     DO k=2,ktf
3843       DO i=i_start,i_end
3844         rdzd(i, k, j) = -(2.0*(z_at_wd(i, k+1, j)-z_at_wd(i, k-1, j))/(&
3845 &          z_at_w(i, k+1, j)-z_at_w(i, k-1, j))**2)
3846         rdz(i, k, j) = 2.0/(z_at_w(i, k+1, j)-z_at_w(i, k-1, j))
3847       END DO
3848     END DO
3849 ! Bug fix, WCS, 22 april 2002; added the following code
3850     DO i=i_start,i_end
3851       rdzd(i, 1, j) = -(2.*(z_at_wd(i, 2, j)-z_at_wd(i, 1, j))/(z_at_w(i&
3852 &        , 2, j)-z_at_w(i, 1, j))**2)
3853       rdz(i, 1, j) = 2./(z_at_w(i, 2, j)-z_at_w(i, 1, j))
3854     END DO
3855   END DO
3856 ! End bug fix.
3857 ! Now compute zx and zy; we'll assume that the halo for ph and phb is
3858 ! properly filled.
3859   i_start = its
3860   IF (ite .GT. ide - 1) THEN
3861     i_end = ide - 1
3862   ELSE
3863     i_end = ite
3864   END IF
3865   j_start = jts
3866   IF (jte .GT. jde - 1) THEN
3867     j_end = jde - 1
3868   ELSE
3869     j_end = jte
3870   END IF
3871   DO j=j_start,j_end
3872     DO k=1,kte
3873       IF (ids + 1 .LT. its) THEN
3874         max1 = its
3875       ELSE
3876         max1 = ids + 1
3877       END IF
3878       DO i=max1,i_end
3879         zxd(i, k, j) = 0.0
3880         zx(i, k, j) = rdx*(phb(i, k, j)-phb(i-1, k, j))/g
3881       END DO
3882     END DO
3883   END DO
3884   DO j=j_start,j_end
3885     DO k=1,kte
3886       IF (ids + 1 .LT. its) THEN
3887         max2 = its
3888       ELSE
3889         max2 = ids + 1
3890       END IF
3891       DO i=max2,i_end
3892         zxd(i, k, j) = zxd(i, k, j) + rdx*(phd(i, k, j)-phd(i-1, k, j))/&
3893 &          g
3894         zx(i, k, j) = zx(i, k, j) + rdx*(ph(i, k, j)-ph(i-1, k, j))/g
3895       END DO
3896     END DO
3897   END DO
3898   IF (jds + 1 .LT. jts) THEN
3899     max3 = jts
3900   ELSE
3901     max3 = jds + 1
3902   END IF
3903   DO j=max3,j_end
3904     DO k=1,kte
3905       DO i=i_start,i_end
3906         zyd(i, k, j) = 0.0
3907         zy(i, k, j) = rdy*(phb(i, k, j)-phb(i, k, j-1))/g
3908       END DO
3909     END DO
3910   END DO
3911   IF (jds + 1 .LT. jts) THEN
3912     max4 = jts
3913   ELSE
3914     max4 = jds + 1
3915   END IF
3916   DO j=max4,j_end
3917     DO k=1,kte
3918       DO i=i_start,i_end
3919         zyd(i, k, j) = zyd(i, k, j) + rdy*(phd(i, k, j)-phd(i, k, j-1))/&
3920 &          g
3921         zy(i, k, j) = zy(i, k, j) + rdy*(ph(i, k, j)-ph(i, k, j-1))/g
3922       END DO
3923     END DO
3924   END DO
3925 ! Some b.c. on zx and zy.
3926   IF (.NOT.config_flags%periodic_x) THEN
3927     IF (ite .EQ. ide) THEN
3928       DO j=j_start,j_end
3929         DO k=1,ktf
3930           zxd(ide, k, j) = 0.0
3931           zx(ide, k, j) = 0.0
3932         END DO
3933       END DO
3934     END IF
3935     IF (its .EQ. ids) THEN
3936       DO j=j_start,j_end
3937         DO k=1,ktf
3938           zxd(ids, k, j) = 0.0
3939           zx(ids, k, j) = 0.0
3940         END DO
3941       END DO
3942     END IF
3943   ELSE
3944     IF (ite .EQ. ide) THEN
3945       DO j=j_start,j_end
3946         DO k=1,ktf
3947           zxd(ide, k, j) = 0.0
3948           zx(ide, k, j) = rdx*(phb(ide, k, j)-phb(ide-1, k, j))/g
3949         END DO
3950       END DO
3951       DO j=j_start,j_end
3952         DO k=1,ktf
3953           zxd(ide, k, j) = zxd(ide, k, j) + rdx*(phd(ide, k, j)-phd(ide-&
3954 &            1, k, j))/g
3955           zx(ide, k, j) = zx(ide, k, j) + rdx*(ph(ide, k, j)-ph(ide-1, k&
3956 &            , j))/g
3957         END DO
3958       END DO
3959     END IF
3960     IF (its .EQ. ids) THEN
3961       DO j=j_start,j_end
3962         DO k=1,ktf
3963           zxd(ids, k, j) = 0.0
3964           zx(ids, k, j) = rdx*(phb(ids, k, j)-phb(ids-1, k, j))/g
3965         END DO
3966       END DO
3967       DO j=j_start,j_end
3968         DO k=1,ktf
3969           zxd(ids, k, j) = zxd(ids, k, j) + rdx*(phd(ids, k, j)-phd(ids-&
3970 &            1, k, j))/g
3971           zx(ids, k, j) = zx(ids, k, j) + rdx*(ph(ids, k, j)-ph(ids-1, k&
3972 &            , j))/g
3973         END DO
3974       END DO
3975     END IF
3976   END IF
3977   IF (.NOT.config_flags%periodic_y) THEN
3978     IF (jte .EQ. jde) THEN
3979       DO k=1,ktf
3980         DO i=i_start,i_end
3981           zyd(i, k, jde) = 0.0
3982           zy(i, k, jde) = 0.0
3983         END DO
3984       END DO
3985     END IF
3986     IF (jts .EQ. jds) THEN
3987       DO k=1,ktf
3988         DO i=i_start,i_end
3989           zyd(i, k, jds) = 0.0
3990           zy(i, k, jds) = 0.0
3991         END DO
3992       END DO
3993     END IF
3994   ELSE
3995     IF (jte .EQ. jde) THEN
3996      DO k=1,ktf
3997         DO i =i_start, i_end
3998           zyd(i, k, jde) = 0.0
3999           zy(i, k, jde) = rdy*(phb(i, k, jde)-phb(i, k, jde-1))/g
4000         END DO
4001       END DO
4002      DO k=1,ktf
4003         DO i =i_start, i_end
4004           zyd(i, k, jde) = zyd(i, k, jde) + rdy*(phd(i, k, jde)-phd(i, k&
4005 &            , jde-1))/g
4006           zy(i, k, jde) = zy(i, k, jde) + rdy*(ph(i, k, jde)-ph(i, k, &
4007 &            jde-1))/g
4008         END DO
4009       END DO
4010     END IF
4011     IF (jts .EQ. jds) THEN
4012       DO k=1,ktf
4013         DO i =i_start, i_end
4014           zyd(i, k, jds) = 0.0
4015           zy(i, k, jds) = rdy*(phb(i, k, jds)-phb(i, k, jds-1))/g
4016         END DO
4017       END DO
4018       DO k=1,ktf
4019          DO i =i_start, i_end
4020           zyd(i, k, jds) = zyd(i, k, jds) + rdy*(phd(i, k, jds)-phd(i, k&
4021 &            , jds-1))/g
4022           zy(i, k, jds) = zy(i, k, jds) + rdy*(ph(i, k, jds)-ph(i, k, &
4023 &            jds-1))/g
4024         END DO
4025       END DO
4026     END IF
4027   END IF
4028 ! Calculate z at p points.
4029   DO j=j_start,j_end
4030     DO k=1,ktf
4031       DO i=i_start,i_end
4032         zd(i, k, j) = 0.5*(phd(i, k, j)+phd(i, k+1, j))/g
4033         z(i, k, j) = 0.5*(ph(i, k, j)+phb(i, k, j)+ph(i, k+1, j)+phb(i, &
4034 &          k+1, j))/g
4035       END DO
4036     END DO
4037   END DO
4038 END SUBROUTINE G_COMPUTE_DIFF_METRICS
4039
4040  SUBROUTINE g_horizontal_diffusion_2(rt_tendf,g_rt_tendf,ru_tendf,g_ru_tendf, &
4041  rv_tendf,g_rv_tendf,rw_tendf,g_rw_tendf,tke_tendf,g_tke_tendf,moist_tendf, &
4042  g_moist_tendf,n_moist,chem_tendf,g_chem_tendf,n_chem,scalar_tendf, &
4043  g_scalar_tendf,n_scalar,tracer_tendf,g_tracer_tendf,n_tracer,thp,g_thp, &
4044  theta,g_theta,mu,g_mu,tke,g_tke,config_flags,defor11,g_defor11,defor22, &
4045  g_defor22,defor12,g_defor12,defor13,g_defor13,defor23,g_defor23,nba_mij, &
4046  g_nba_mij,n_nba_mij,div,g_div,moist,g_moist,chem,g_chem,scalar, &
4047  g_scalar,tracer,g_tracer,msfux,msfuy,msfvx,msfvy,msftx,msfty,xkmh,g_xkmh, &
4048  xkhh,g_xkhh,km_opt,rdx,rdy,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,cf1,cf2,cf3,zx, &
4049  g_zx,zy,g_zy,dn,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
4050  jts,jte,kts,kte)
4051
4052  IMPLICIT NONE
4053
4054  REAL :: Tmpv1,g_Tmpv1
4055  TYPE(grid_config_rec_type) :: config_flags
4056  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4057  INTEGER :: n_moist,n_chem,n_scalar,n_tracer,km_opt
4058  REAL :: cf1,cf2,cf3
4059  REAL,DIMENSION(kms:kme) :: fnm
4060  REAL,DIMENSION(kms:kme) :: fnp
4061  REAL,DIMENSION(kms:kme) :: dnw
4062  REAL,DIMENSION(kms:kme) :: dn
4063  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty,mu,g_mu
4064  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rt_tendf,g_rt_tendf,ru_tendf, &
4065  g_ru_tendf,rv_tendf,g_rv_tendf,rw_tendf,g_rw_tendf,tke_tendf,g_tke_tendf
4066  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist_tendf,g_moist_tendf
4067  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem_tendf,g_chem_tendf
4068  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar_tendf,g_scalar_tendf
4069  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer_tendf,g_tracer_tendf
4070  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,g_moist
4071  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem,g_chem
4072  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar,g_scalar
4073  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer,g_tracer
4074  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor22,g_defor22, &
4075  defor12,g_defor12,defor13,g_defor13,defor23,g_defor23,div,g_div,xkmh, &
4076  g_xkmh,xkhh,g_xkhh,zx,g_zx,zy,g_zy,theta,g_theta,thp,g_thp,tke, &
4077  g_tke,rdz,g_rdz,rdzw,g_rdzw
4078  REAL :: rdx,rdy
4079
4080  INTEGER :: n_nba_mij
4081
4082  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
4083  INTEGER :: im,ic,is
4084
4085  CALL g_horizontal_diffusion_u_2(ru_tendf,g_ru_tendf,mu,g_mu,config_flags, &
4086  defor11,g_defor11,defor12,g_defor12,div,g_div,nba_mij,g_nba_mij, &
4087  n_nba_mij,tke(ims,kms,jms),g_tke(ims,kms,jms),msfux,msfuy,xkmh,g_xkmh,rdx,rdy, &
4088  fnm,fnp,zx,g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
4089  kms,kme,its,ite,jts,jte,kts,kte)
4090
4091  CALL g_horizontal_diffusion_v_2(rv_tendf,g_rv_tendf,mu,g_mu,config_flags, &
4092  defor12,g_defor12,defor22,g_defor22,div,g_div,nba_mij,g_nba_mij, &
4093  n_nba_mij,tke(ims,kms,jms),g_tke(ims,kms,jms),msfvx,msfvy,xkmh,g_xkmh,rdx,rdy, &
4094  fnm,fnp,zx,g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
4095  kms,kme,its,ite,jts,jte,kts,kte)
4096
4097  CALL g_horizontal_diffusion_w_2(rw_tendf,g_rw_tendf,mu,g_mu,config_flags, &
4098  defor13,g_defor13,defor23,g_defor23,div,g_div,nba_mij,g_nba_mij, &
4099  n_nba_mij,tke(ims,kms,jms),g_tke(ims,kms,jms),msftx,msfty,xkmh,g_xkmh,rdx,rdy, &
4100  fnm,fnp,zx,g_zx,zy,g_zy,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
4101  kms,kme,its,ite,jts,jte,kts,kte)
4102
4103  CALL g_horizontal_diffusion_s(rt_tendf,g_rt_tendf,mu,g_mu,config_flags,thp, &
4104  g_thp,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2, &
4105  cf3,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde, &
4106  kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4107
4108  IF(km_opt .eq. 2) CALL g_horizontal_diffusion_s(tke_tendf(ims,kms,jms) &
4109 ,g_tke_tendf(ims,kms,jms),mu,g_mu,config_flags,tke(ims,kms,jms),g_tke(ims, &
4110  kms,jms),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2, &
4111  cf3,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.true.,ids,ide,jds,jde, &
4112  kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4113
4114  IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
4115
4116  DO im =PARAM_FIRST_SCALAR,n_moist
4117
4118  CALL g_horizontal_diffusion_s(moist_tendf(ims,kms,jms,im),g_moist_tendf(ims, &
4119  kms,jms,im),mu,g_mu,config_flags,moist(ims,kms,jms,im),g_moist(ims,kms,jms,im) &
4120 ,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
4121  g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
4122  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4123  ENDDO
4124  ENDIF
4125
4126  IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
4127
4128  DO ic =PARAM_FIRST_SCALAR,n_chem
4129
4130  CALL g_horizontal_diffusion_s(chem_tendf(ims,kms,jms,ic),g_chem_tendf(ims,kms, &
4131  jms,ic),mu,g_mu,config_flags,chem(ims,kms,jms,ic),g_chem(ims,kms,jms,ic) &
4132 ,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
4133  g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
4134  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4135  ENDDO
4136  ENDIF
4137
4138  IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
4139
4140  DO ic =PARAM_FIRST_SCALAR,n_tracer
4141
4142  CALL g_horizontal_diffusion_s(tracer_tendf(ims,kms,jms,ic),g_tracer_tendf(ims, &
4143  kms,jms,ic),mu,g_mu,config_flags,tracer(ims,kms,jms,ic),g_tracer(ims,kms,jms, &
4144  ic),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3, &
4145  zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
4146  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4147  ENDDO
4148  ENDIF
4149
4150  IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
4151
4152  DO is =PARAM_FIRST_SCALAR,n_scalar
4153
4154  CALL g_horizontal_diffusion_s(scalar_tendf(ims,kms,jms,is),g_scalar_tendf(ims, &
4155  kms,jms,is),mu,g_mu,config_flags,scalar(ims,kms,jms,is),g_scalar(ims,kms,jms, &
4156  is),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3, &
4157  zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds, &
4158  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4159  ENDDO
4160  ENDIF
4161
4162  END SUBROUTINE g_horizontal_diffusion_2
4163
4164  SUBROUTINE g_horizontal_diffusion_u_2(tendency,g_tendency,mu,g_mu, &
4165  config_flags,defor11,g_defor11,defor12,g_defor12,div,g_div,nba_mij, &
4166  g_nba_mij,n_nba_mij,tke,g_tke,msfux,msfuy,xkmh,g_xkmh,rdx,rdy,fnm,fnp,zx, &
4167  g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
4168  its,ite,jts,jte,kts,kte)
4169
4170  IMPLICIT NONE
4171
4172  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
4173  TYPE(grid_config_rec_type) :: config_flags
4174  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4175  REAL,DIMENSION(kms:kme) :: fnm
4176  REAL,DIMENSION(kms:kme) :: fnp
4177  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,mu,g_mu
4178  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
4179  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rdzw,g_rdzw
4180  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,g_defor11,defor12,g_defor12, &
4181  div,g_div,tke,g_tke,xkmh,g_xkmh,zx,g_zx,zy,g_zy
4182
4183  INTEGER :: n_nba_mij
4184
4185  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
4186  REAL :: rdx,rdy
4187  INTEGER :: i,j,k,ktf
4188  INTEGER :: i_start,i_end,j_start,j_end
4189  INTEGER :: is_ext,ie_ext,js_ext,je_ext
4190  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,g_titau1avg, &
4191  titau2avg,g_titau2avg,titau1,g_titau1,titau2,g_titau2,xkxavg,g_xkxavg, &
4192  rravg,g_rravg
4193  REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
4194  REAL :: tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z
4195  REAL :: term1,g_term1,term2,g_term2,term3,g_term3
4196
4197  ktf =min(kte,kde-1)
4198
4199  i_start =its
4200
4201  i_end =ite
4202
4203  j_start =jts
4204
4205  j_end =min(jte,jde-1)
4206
4207  IF( config_flags%open_xs .or. config_flags%specified .or.   &
4208         config_flags%nested) i_start =max(ids+1,its)
4209
4210  IF( config_flags%open_xe .or. config_flags%specified .or.   &
4211         config_flags%nested) i_end =min(ide-1,ite)
4212
4213  IF( config_flags%open_ys .or. config_flags%specified .or.   &
4214         config_flags%nested) j_start =max(jds+1,jts)
4215
4216  IF( config_flags%open_ye .or. config_flags%specified .or.   &
4217         config_flags%nested) j_end =min(jde-2,jte)
4218
4219  IF( config_flags%periodic_x ) i_start =its
4220
4221  IF( config_flags%periodic_x ) i_end =ite
4222
4223  is_ext =1
4224
4225  ie_ext =0
4226
4227  js_ext =0
4228
4229  je_ext =0
4230
4231  CALL g_cal_titau_11_22_33(config_flags,titau1,g_titau1,mu,g_mu,tke,g_tke, &
4232  xkmh,g_xkmh,defor11,g_defor11,nba_mij(ims,kms,jms,P_m11),g_nba_mij(ims,kms, &
4233  jms,P_m11),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
4234  kme,its,ite,jts,jte,kts,kte)
4235
4236  is_ext =0
4237
4238  ie_ext =0
4239
4240  js_ext =0
4241
4242  je_ext =1
4243
4244  CALL g_cal_titau_12_21(config_flags,titau2,g_titau2,mu,g_mu,xkmh,g_xkmh, &
4245  defor12,g_defor12,nba_mij(ims,kms,jms,P_m12),g_nba_mij(ims,kms,jms,P_m12) &
4246 ,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
4247  jts,jte,kts,kte)
4248
4249  DO j =j_start,j_end
4250  DO k =kts+1,ktf
4251  DO i =i_start,i_end
4252
4253  g_titau1avg(i,k,j) =0.5*(fnm(k)*(g_titau1(i-1,k,j) +g_titau1(i,k,j)) +fnp(k) &
4254 *(g_titau1(i-1,k-1,j) +g_titau1(i,k-1,j)))
4255  titau1avg(i,k,j) =0.5*(fnm(k)*(titau1(i-1,k,j) +titau1(i,k,j)) +fnp(k)*(titau1(i-1,k- &
4256  1,j) +titau1(i,k-1,j)))
4257
4258  g_titau2avg(i,k,j) =0.5*(fnm(k)*(g_titau2(i,k,j+1) +g_titau2(i,k,j)) +fnp(k) &
4259 *(g_titau2(i,k-1,j+1) +g_titau2(i,k-1,j)))
4260  titau2avg(i,k,j) =0.5*(fnm(k)*(titau2(i,k,j+1) +titau2(i,k,j)) +fnp(k)*(titau2(i,k-1, &
4261  j+1) +titau2(i,k-1,j)))
4262
4263  g_tmpzy =0.25*(g_zy(i-1,k,j) +g_zy(i,k,j) +g_zy(i-1,k,j+1) +g_zy(i,k,j+1))
4264  tmpzy =0.25*(zy(i-1,k,j) +zy(i,k,j) +zy(i-1,k,j+1) +zy(i,k,j+1))
4265
4266  g_Tmpv1 =titau1avg(i,k,j)*g_zx(i,k,j) +g_titau1avg(i,k,j)*zx(i,k,j)
4267  Tmpv1 =titau1avg(i,k,j)*zx(i,k,j)
4268
4269  g_titau1avg(i,k,j) =g_Tmpv1
4270  titau1avg(i,k,j) =Tmpv1
4271
4272  g_Tmpv1 =titau2avg(i,k,j)*g_tmpzy +g_titau2avg(i,k,j)*tmpzy
4273  Tmpv1 =titau2avg(i,k,j)*tmpzy
4274
4275  g_titau2avg(i,k,j) =g_Tmpv1
4276  titau2avg(i,k,j) =Tmpv1
4277
4278  ENDDO
4279  ENDDO
4280  ENDDO
4281
4282  DO j =j_start,j_end
4283  DO i =i_start,i_end
4284
4285  g_titau1avg(i,kts,j) =0.0
4286  titau1avg(i,kts,j) =0.
4287
4288  g_titau1avg(i,ktf+1,j) =0.0
4289  titau1avg(i,ktf+1,j) =0.
4290
4291  g_titau2avg(i,kts,j) =0.0
4292  titau2avg(i,kts,j) =0.
4293
4294  g_titau2avg(i,ktf+1,j) =0.0
4295  titau2avg(i,ktf+1,j) =0.
4296
4297  ENDDO
4298  ENDDO
4299
4300  DO j =j_start,j_end
4301  DO k =kts,ktf
4302  DO i =i_start,i_end
4303
4304 ! g_mrdx =0.0  ! Remarked by Ning Pan, 2010-08-10
4305  mrdx =msfux(i,j) *rdx
4306
4307 ! g_mrdy =0.0  ! Remarked by Ning Pan, 2010-08-10
4308  mrdy =msfuy(i,j) *rdy
4309
4310 ! Revised by Ning Pan, 2010-08-10
4311 ! g_Tmpv1 =mrdx*(g_titau1(i,k,j) -g_titau1(i-1,k,j)) +g_mrdx*(titau1(i,k, &
4312 ! j) -titau1(i-1,k,j))
4313  g_Tmpv1 =mrdx*(g_titau1(i,k,j) -g_titau1(i-1,k,j))
4314  Tmpv1 =mrdx*(titau1(i,k,j) -titau1(i-1,k,j))
4315
4316 ! Revised by Ning Pan, 2010-08-10
4317 ! g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j)) +g_mrdy*(titau2(i,k, &
4318 ! j+1) -titau2(i,k,j))
4319  g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j))
4320  Tmpv2 =mrdy*(titau2(i,k,j+1) -titau2(i,k,j))
4321
4322  g_Tmpv3 =msfuy(i,j)*rdzw(i,k,j)*((g_titau1avg(i,k+1,j) -g_titau1avg(i,k,j)) &
4323  +(g_titau2avg(i,k+1,j) -g_titau2avg(i,k,j))) +msfuy(i,j)*g_rdzw(i,k,j) &
4324 *((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i,k+1,j) -titau2avg(i,k,j)))
4325  Tmpv3 =msfuy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i, &
4326  k+1,j) -titau2avg(i,k,j)))
4327
4328  g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv1 +g_Tmpv2 -g_Tmpv3)
4329  tendency(i,k,j) =tendency(i,k,j) -(Tmpv1 +Tmpv2 -Tmpv3)
4330
4331  ENDDO
4332  ENDDO
4333  ENDDO
4334
4335  END SUBROUTINE g_horizontal_diffusion_u_2
4336
4337  SUBROUTINE g_horizontal_diffusion_v_2(tendency,g_tendency,mu,g_mu, &
4338  config_flags,defor12,g_defor12,defor22,g_defor22,div,g_div,nba_mij, &
4339  g_nba_mij,n_nba_mij,tke,g_tke,msfvx,msfvy,xkmh,g_xkmh,rdx,rdy,fnm,fnp,zx, &
4340  g_zx,zy,g_zy,rdzw,g_rdzw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
4341  its,ite,jts,jte,kts,kte)
4342
4343  IMPLICIT NONE
4344
4345  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
4346  TYPE(grid_config_rec_type) :: config_flags
4347  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4348  REAL,DIMENSION(kms:kme) :: fnm
4349  REAL,DIMENSION(kms:kme) :: fnp
4350  REAL,DIMENSION(ims:ime,jms:jme) :: msfvx,msfvy,mu,g_mu
4351  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
4352  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor12,g_defor12,defor22,g_defor22, &
4353  div,g_div,tke,g_tke,xkmh,g_xkmh,zx,g_zx,zy,g_zy,rdzw,g_rdzw
4354
4355  INTEGER :: n_nba_mij
4356
4357  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
4358  REAL :: rdx,rdy
4359  INTEGER :: i,j,k,ktf
4360  INTEGER :: i_start,i_end,j_start,j_end
4361  INTEGER :: is_ext,ie_ext,js_ext,je_ext
4362  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,g_titau1avg, &
4363  titau2avg,g_titau2avg,titau1,g_titau1,titau2,g_titau2,xkxavg,g_xkxavg, &
4364  rravg,g_rravg
4365  REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
4366  REAL :: tmpzx,g_tmpzx,tmpzeta_z,g_tmpzeta_z
4367
4368  ktf =min(kte,kde-1)
4369
4370  i_start =its
4371
4372  i_end =min(ite,ide-1)
4373
4374  j_start =jts
4375
4376  j_end =jte
4377
4378  IF( config_flags%open_xs .or. config_flags%specified .or.   &
4379         config_flags%nested) i_start =max(ids+1,its)
4380
4381  IF( config_flags%open_xe .or. config_flags%specified .or.   &
4382         config_flags%nested) i_end =min(ide-2,ite)
4383
4384  IF( config_flags%open_ys .or. config_flags%specified .or.   &
4385         config_flags%nested) j_start =max(jds+1,jts)
4386
4387  IF( config_flags%open_ye .or. config_flags%specified .or.   &
4388         config_flags%nested) j_end =min(jde-1,jte)
4389
4390  IF( config_flags%periodic_x ) i_start =its
4391
4392  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
4393
4394  is_ext =0
4395
4396  ie_ext =1
4397
4398  js_ext =0
4399
4400  je_ext =0
4401
4402  CALL g_cal_titau_12_21(config_flags,titau1,g_titau1,mu,g_mu,xkmh,g_xkmh, &
4403  defor12,g_defor12,nba_mij(ims,kms,jms,P_m12),g_nba_mij(ims,kms,jms,P_m12) &
4404 ,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
4405  jts,jte,kts,kte)
4406
4407  is_ext =0
4408
4409  ie_ext =0
4410
4411  js_ext =1
4412
4413  je_ext =0
4414
4415  CALL g_cal_titau_11_22_33(config_flags,titau2,g_titau2,mu,g_mu,tke,g_tke, &
4416  xkmh,g_xkmh,defor22,g_defor22,nba_mij(ims,kms,jms,P_m22),g_nba_mij(ims,kms, &
4417  jms,P_m22),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
4418  kme,its,ite,jts,jte,kts,kte)
4419
4420  DO j =j_start,j_end
4421  DO k =kts+1,ktf
4422  DO i =i_start,i_end
4423
4424  g_titau1avg(i,k,j) =0.5*(fnm(k)*(g_titau1(i+1,k,j) +g_titau1(i,k,j)) +fnp(k) &
4425 *(g_titau1(i+1,k-1,j) +g_titau1(i,k-1,j)))
4426  titau1avg(i,k,j) =0.5*(fnm(k)*(titau1(i+1,k,j) +titau1(i,k,j)) +fnp(k)*(titau1(i+1,k- &
4427  1,j) +titau1(i,k-1,j)))
4428
4429  g_titau2avg(i,k,j) =0.5*(fnm(k)*(g_titau2(i,k,j-1) +g_titau2(i,k,j)) +fnp(k) &
4430 *(g_titau2(i,k-1,j-1) +g_titau2(i,k-1,j)))
4431  titau2avg(i,k,j) =0.5*(fnm(k)*(titau2(i,k,j-1) +titau2(i,k,j)) +fnp(k)*(titau2(i,k-1, &
4432  j-1) +titau2(i,k-1,j)))
4433
4434  g_tmpzx =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k,j-1) +g_zx(i+1,k,j-1))
4435  tmpzx =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k,j-1) +zx(i+1,k,j-1))
4436
4437  g_Tmpv1 =titau1avg(i,k,j)*g_tmpzx +g_titau1avg(i,k,j)*tmpzx
4438  Tmpv1 =titau1avg(i,k,j)*tmpzx
4439
4440  g_titau1avg(i,k,j) =g_Tmpv1
4441  titau1avg(i,k,j) =Tmpv1
4442
4443  g_Tmpv1 =titau2avg(i,k,j)*g_zy(i,k,j) +g_titau2avg(i,k,j)*zy(i,k,j)
4444  Tmpv1 =titau2avg(i,k,j)*zy(i,k,j)
4445
4446  g_titau2avg(i,k,j) =g_Tmpv1
4447  titau2avg(i,k,j) =Tmpv1
4448
4449  ENDDO
4450  ENDDO
4451  ENDDO
4452
4453  DO j =j_start,j_end
4454  DO i =i_start,i_end
4455
4456  g_titau1avg(i,kts,j) =0.0
4457  titau1avg(i,kts,j) =0.
4458
4459  g_titau1avg(i,ktf+1,j) =0.0
4460  titau1avg(i,ktf+1,j) =0.
4461
4462  g_titau2avg(i,kts,j) =0.0
4463  titau2avg(i,kts,j) =0.
4464
4465  g_titau2avg(i,ktf+1,j) =0.0
4466  titau2avg(i,ktf+1,j) =0.
4467
4468  ENDDO
4469  ENDDO
4470
4471  DO j =j_start,j_end
4472  DO k =kts,ktf
4473  DO i =i_start,i_end
4474
4475 ! g_mrdx =0.0  ! Remarked by Ning Pan, 2010-08-10
4476  mrdx =msfvx(i,j) *rdx
4477
4478 ! g_mrdy =0.0  ! Remarked by Ning Pan, 2010-08-10
4479  mrdy =msfvy(i,j) *rdy
4480
4481 ! Revised by Ning Pan, 2010-08-10
4482 ! g_Tmpv1 =mrdy*(g_titau2(i,k,j) -g_titau2(i,k,j-1)) +g_mrdy*(titau2(i,k, &
4483 ! j) -titau2(i,k,j-1))
4484  g_Tmpv1 =mrdy*(g_titau2(i,k,j) -g_titau2(i,k,j-1))
4485  Tmpv1 =mrdy*(titau2(i,k,j) -titau2(i,k,j-1))
4486
4487 ! Revised by Ning Pan, 2010-08-10
4488 ! g_Tmpv2 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j)) +g_mrdx*(titau1(i+1, &
4489 ! k,j) -titau1(i,k,j))
4490  g_Tmpv2 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j))
4491  Tmpv2 =mrdx*(titau1(i+1,k,j) -titau1(i,k,j))
4492
4493  g_Tmpv3 =msfvy(i,j)*rdzw(i,k,j)*((g_titau1avg(i,k+1,j) -g_titau1avg(i,k,j)) &
4494  +(g_titau2avg(i,k+1,j) -g_titau2avg(i,k,j))) +msfvy(i,j)*g_rdzw(i,k,j) &
4495 *((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i,k+1,j) -titau2avg(i,k,j)))
4496  Tmpv3 =msfvy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j) -titau1avg(i,k,j)) +(titau2avg(i, &
4497  k+1,j) -titau2avg(i,k,j)))
4498
4499  g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv1 +g_Tmpv2 -g_Tmpv3)
4500  tendency(i,k,j) =tendency(i,k,j) -(Tmpv1 +Tmpv2 -Tmpv3)
4501
4502  ENDDO
4503  ENDDO
4504  ENDDO
4505
4506  END SUBROUTINE g_horizontal_diffusion_v_2
4507
4508  SUBROUTINE g_horizontal_diffusion_w_2(tendency,g_tendency,mu,g_mu, &
4509  config_flags,defor13,g_defor13,defor23,g_defor23,div,g_div,nba_mij, &
4510  g_nba_mij,n_nba_mij,tke,g_tke,msftx,msfty,xkmh,g_xkmh,rdx,rdy,fnm,fnp,zx, &
4511  g_zx,zy,g_zy,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
4512  ite,jts,jte,kts,kte)
4513
4514  IMPLICIT NONE
4515
4516  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4
4517  TYPE(grid_config_rec_type) :: config_flags
4518  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4519  REAL,DIMENSION(kms:kme) :: fnm
4520  REAL,DIMENSION(kms:kme) :: fnp
4521  REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty,mu,g_mu
4522  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
4523  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,g_defor13,defor23,g_defor23, &
4524  div,g_div,tke,g_tke,xkmh,g_xkmh,zx,g_zx,zy,g_zy,rdz,g_rdz
4525
4526  INTEGER :: n_nba_mij
4527
4528  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
4529  REAL :: rdx,rdy
4530  INTEGER :: i,j,k,ktf
4531  INTEGER :: i_start,i_end,j_start,j_end
4532  INTEGER :: is_ext,ie_ext,js_ext,je_ext
4533  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,g_titau1avg, &
4534  titau2avg,g_titau2avg,titau1,g_titau1,titau2,g_titau2,xkxavg,g_xkxavg, &
4535  rravg,g_rravg
4536  REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
4537  REAL :: tmpzx,g_tmpzx,tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z
4538
4539  ktf =min(kte,kde-1)
4540
4541  i_start =its
4542
4543  i_end =min(ite,ide-1)
4544
4545  j_start =jts
4546
4547  j_end =min(jte,jde-1)
4548
4549  IF( config_flags%open_xs .or. config_flags%specified .or.   &
4550         config_flags%nested) i_start =max(ids+1,its)
4551
4552  IF( config_flags%open_xe .or. config_flags%specified .or.   &
4553         config_flags%nested) i_end =min(ide-2,ite)
4554
4555  IF( config_flags%open_ys .or. config_flags%specified .or.   &
4556         config_flags%nested) j_start =max(jds+1,jts)
4557
4558  IF( config_flags%open_ye .or. config_flags%specified .or.   &
4559         config_flags%nested) j_end =min(jde-2,jte)
4560
4561  IF( config_flags%periodic_x ) i_start =its
4562
4563  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
4564
4565  is_ext =0
4566
4567  ie_ext =1
4568
4569  js_ext =0
4570
4571  je_ext =0
4572
4573  CALL g_cal_titau_13_31(config_flags,titau1,g_titau1,defor13,g_defor13, &
4574  nba_mij(ims,kms,jms,P_m13),g_nba_mij(ims,kms,jms,P_m13),mu,g_mu,xkmh,g_xkmh, &
4575  fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
4576  its,ite,jts,jte,kts,kte)
4577
4578  is_ext =0
4579
4580  ie_ext =0
4581
4582  js_ext =0
4583
4584  je_ext =1
4585
4586  CALL g_cal_titau_23_32(config_flags,titau2,g_titau2,defor23,g_defor23, &
4587  nba_mij(ims,kms,jms,P_m23),g_nba_mij(ims,kms,jms,P_m23),mu,g_mu,xkmh,g_xkmh, &
4588  fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
4589  its,ite,jts,jte,kts,kte)
4590
4591  DO j =j_start,j_end
4592  DO k =kts,ktf
4593  DO i =i_start,i_end
4594
4595  g_titau1avg(i,k,j) =0.25*(g_titau1(i+1,k+1,j) +g_titau1(i,k+1,j) &
4596  +g_titau1(i+1,k,j) +g_titau1(i,k,j))
4597  titau1avg(i,k,j) =0.25*(titau1(i+1,k+1,j) +titau1(i,k+1,j) +titau1(i+1,k,j) +titau1(i,k,j))
4598
4599  g_titau2avg(i,k,j) =0.25*(g_titau2(i,k+1,j+1) +g_titau2(i,k+1,j) &
4600  +g_titau2(i,k,j+1) +g_titau2(i,k,j))
4601  titau2avg(i,k,j) =0.25*(titau2(i,k+1,j+1) +titau2(i,k+1,j) +titau2(i,k,j+1) +titau2(i,k,j))
4602
4603  g_tmpzx =0.25*(g_zx(i,k,j) +g_zx(i+1,k,j) +g_zx(i,k+1,j) +g_zx(i+1,k+1,j))
4604  tmpzx =0.25*(zx(i,k,j) +zx(i+1,k,j) +zx(i,k+1,j) +zx(i+1,k+1,j))
4605
4606  g_tmpzy =0.25*(g_zy(i,k,j) +g_zy(i,k,j+1) +g_zy(i,k+1,j) +g_zy(i,k+1,j+1))
4607  tmpzy =0.25*(zy(i,k,j) +zy(i,k,j+1) +zy(i,k+1,j) +zy(i,k+1,j+1))
4608
4609  g_Tmpv1 =titau1avg(i,k,j)*g_tmpzx +g_titau1avg(i,k,j)*tmpzx
4610  Tmpv1 =titau1avg(i,k,j)*tmpzx
4611
4612  g_titau1avg(i,k,j) =g_Tmpv1
4613  titau1avg(i,k,j) =Tmpv1
4614
4615  g_Tmpv1 =titau2avg(i,k,j)*g_tmpzy +g_titau2avg(i,k,j)*tmpzy
4616  Tmpv1 =titau2avg(i,k,j)*tmpzy
4617
4618  g_titau2avg(i,k,j) =g_Tmpv1
4619  titau2avg(i,k,j) =Tmpv1
4620
4621  ENDDO
4622  ENDDO
4623  ENDDO
4624
4625  DO j =j_start,j_end
4626  DO i =i_start,i_end
4627
4628  g_titau1avg(i,ktf+1,j) =0.0
4629  titau1avg(i,ktf+1,j) =0.
4630
4631  g_titau2avg(i,ktf+1,j) =0.0
4632  titau2avg(i,ktf+1,j) =0.
4633
4634  ENDDO
4635  ENDDO
4636
4637  DO j =j_start,j_end
4638  DO k =kts+1,ktf
4639  DO i =i_start,i_end
4640
4641 ! g_mrdx =0.0  ! Remarked by Ning Pan, 2010-08-10
4642  mrdx =msftx(i,j) *rdx
4643
4644 ! g_mrdy =0.0  ! Remarked by Ning Pan, 2010-08-10
4645  mrdy =msfty(i,j) *rdy
4646
4647 ! Revised by Ning Pan, 2010-08-10
4648 ! g_Tmpv1 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j)) +g_mrdx*(titau1(i+1, &
4649 ! k,j) -titau1(i,k,j))
4650  g_Tmpv1 =mrdx*(g_titau1(i+1,k,j) -g_titau1(i,k,j))
4651  Tmpv1 =mrdx*(titau1(i+1,k,j) -titau1(i,k,j))
4652
4653 ! Revised by Ning Pan, 2010-08-10
4654 ! g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j)) +g_mrdy*(titau2(i,k, &
4655 ! j+1) -titau2(i,k,j))
4656  g_Tmpv2 =mrdy*(g_titau2(i,k,j+1) -g_titau2(i,k,j))
4657  Tmpv2 =mrdy*(titau2(i,k,j+1) -titau2(i,k,j))
4658
4659  g_Tmpv3 =msfty(i,j)*rdz(i,k,j)*(g_titau1avg(i,k,j) -g_titau1avg(i,k-1,j) &
4660  +g_titau2avg(i,k,j) -g_titau2avg(i,k-1,j)) +msfty(i,j)*g_rdz(i,k,j) &
4661 *(titau1avg(i,k,j) -titau1avg(i,k-1,j) +titau2avg(i,k,j) -titau2avg(i,k-1,j))
4662  Tmpv3 =msfty(i,j)*rdz(i,k,j)*(titau1avg(i,k,j) -titau1avg(i,k-1,j) +titau2avg(i,k,j) &
4663  -titau2avg(i,k-1,j))
4664
4665  g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv1 +g_Tmpv2 -g_Tmpv3)
4666  tendency(i,k,j) =tendency(i,k,j) -(Tmpv1 +Tmpv2 -Tmpv3)
4667
4668  ENDDO
4669  ENDDO
4670  ENDDO
4671
4672  END SUBROUTINE g_horizontal_diffusion_w_2
4673
4674  SUBROUTINE g_horizontal_diffusion_s(tendency,g_tendency,mu,g_mu, &
4675  config_flags,var,g_var,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,g_xkhh,rdx,rdy, &
4676  fnm,fnp,cf1,cf2,cf3,zx,g_zx,zy,g_zy,rdz,g_rdz,rdzw,g_rdzw,dnw,dn, &
4677  doing_tke,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4678
4679  IMPLICIT NONE
4680
4681  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
4682  g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8,Tmpv9,g_Tmpv9
4683  TYPE(grid_config_rec_type) :: config_flags
4684  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4685  LOGICAL :: doing_tke
4686  REAL :: cf1,cf2,cf3
4687  REAL,DIMENSION(kms:kme) :: fnm
4688  REAL,DIMENSION(kms:kme) :: fnp
4689  REAL,DIMENSION(kms:kme) :: dn
4690  REAL,DIMENSION(kms:kme) :: dnw
4691  REAL,DIMENSION(ims:ime,jms:jme) :: msfux
4692  REAL,DIMENSION(ims:ime,jms:jme) :: msfuy
4693  REAL,DIMENSION(ims:ime,jms:jme) :: msfvx
4694  REAL,DIMENSION(ims:ime,jms:jme) :: msfvy
4695  REAL,DIMENSION(ims:ime,jms:jme) :: msftx
4696  REAL,DIMENSION(ims:ime,jms:jme) :: msfty
4697  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
4698  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
4699  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhh,g_xkhh,rdz,g_rdz,rdzw,g_rdzw
4700  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var,g_var,zx,g_zx,zy,g_zy
4701  REAL :: rdx,rdy
4702  INTEGER :: i,j,k,ktf
4703  INTEGER :: i_start,i_end,j_start,j_end
4704  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: H1avg,g_H1avg,H2avg,g_H2avg, &
4705  H1,g_H1,H2,g_H2,xkxavg,g_xkxavg
4706  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tmptendf,g_tmptendf
4707  REAL :: mrdx,g_mrdx,mrdy,g_mrdy,rcoup,g_rcoup
4708  REAL :: tmpzx,g_tmpzx,tmpzy,g_tmpzy,tmpzeta_z,g_tmpzeta_z,rdzu,g_rdzu, &
4709  rdzv,g_rdzv
4710  INTEGER :: ktes1,ktes2
4711
4712  ktf =min(kte,kde-1)
4713
4714  ktes1 =kte-1
4715
4716  ktes2 =kte-2
4717
4718  i_start =its
4719
4720  i_end =min(ite,ide-1)
4721
4722  j_start =jts
4723
4724  j_end =min(jte,jde-1)
4725
4726  IF( config_flags%open_xs .or. config_flags%specified .or.   &
4727         config_flags%nested) i_start =max(ids+1,its)
4728
4729  IF( config_flags%open_xe .or. config_flags%specified .or.   &
4730         config_flags%nested) i_end =min(ide-2,ite)
4731
4732  IF( config_flags%open_ys .or. config_flags%specified .or.   &
4733         config_flags%nested) j_start =max(jds+1,jts)
4734
4735  IF( config_flags%open_ye .or. config_flags%specified .or.   &
4736         config_flags%nested) j_end =min(jde-2,jte)
4737
4738  IF( config_flags%periodic_x ) i_start =its
4739
4740  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
4741
4742  IF( doing_tke ) THEN
4743
4744  DO j =j_start,j_end
4745  DO k =kts,ktf
4746  DO i =i_start,i_end
4747
4748  g_tmptendf(i,k,j) =g_tendency(i,k,j)
4749  tmptendf(i,k,j) =tendency(i,k,j)
4750
4751  ENDDO
4752  ENDDO
4753  ENDDO
4754  ENDIF
4755
4756  DO j =j_start,j_end
4757  DO k =kts,ktf
4758  DO i =i_start,i_end+1
4759
4760  g_xkxavg(i,k,j) =0.5*(g_xkhh(i-1,k,j) +g_xkhh(i,k,j))
4761  xkxavg(i,k,j) =0.5*(xkhh(i-1,k,j) +xkhh(i,k,j))
4762
4763  ENDDO
4764  ENDDO
4765  ENDDO
4766
4767  DO j =j_start,j_end
4768  DO k =kts+1,ktf
4769  DO i =i_start,i_end+1
4770
4771  g_H1avg(i,k,j) =0.5*(fnm(k)*(g_var(i-1,k,j) +g_var(i,k,j)) +fnp(k) &
4772 *(g_var(i-1,k-1,j) +g_var(i,k-1,j)))
4773  H1avg(i,k,j) =0.5*(fnm(k)*(var(i-1,k,j) +var(i,k,j)) +fnp(k)*(var(i-1,k-1,j) +var(i,k-1,j)))
4774
4775  ENDDO
4776  ENDDO
4777  ENDDO
4778
4779  DO j =j_start,j_end
4780  DO i =i_start,i_end+1
4781
4782  g_H1avg(i,kts,j) =0.5*(cf1*g_var(i,1,j) +cf2*g_var(i,2,j) +cf3*g_var(i,3, &
4783  j) +cf1*g_var(i-1,1,j) +cf2*g_var(i-1,2,j) +cf3*g_var(i-1,3,j))
4784  H1avg(i,kts,j) =0.5*(cf1*var(i,1,j) +cf2*var(i,2,j) +cf3*var(i,3,j) +cf1*var(i-1,1,j) &
4785  +cf2*var(i-1,2,j) +cf3*var(i-1,3,j))
4786
4787  g_H1avg(i,ktf+1,j) =0.5*(g_var(i,ktes1,j) +((g_var(i,ktes1,j) -g_var(i, &
4788  ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)) +g_var(i-1,ktes1,j) +((g_var(i-1,ktes1,j) &
4789  -g_var(i-1,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)))
4790  H1avg(i,ktf+1,j) =0.5*(var(i,ktes1,j) +(var(i,ktes1,j) -var(i,ktes2,j)) &
4791 *0.5*dnw(ktes1)/dn(ktes1) +var(i-1,ktes1,j) +(var(i-1,ktes1,j) -var(i-1,ktes2,j)) &
4792 *0.5*dnw(ktes1)/dn(ktes1))
4793
4794  ENDDO
4795  ENDDO
4796
4797  DO j =j_start,j_end
4798  DO k =kts,ktf
4799  DO i =i_start,i_end+1
4800
4801  g_tmpzx =0.5*(g_zx(i,k,j) +g_zx(i,k+1,j))
4802  tmpzx =0.5*(zx(i,k,j) +zx(i,k+1,j))
4803
4804  g_rdzu =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i-1,k, &
4805  j)/(rdzw(i-1,k,j)*rdzw(i-1,k,j))))/((1./rdzw(i,k,j) +1./rdzw(i-1,k,j))*(1./rdzw(i,k, &
4806  j) +1./rdzw(i-1,k,j)))
4807  rdzu =2./(1./rdzw(i,k,j) +1./rdzw(i-1,k,j))
4808
4809  g_Tmpv1 =tmpzx*(g_H1avg(i,k+1,j) -g_H1avg(i,k,j)) +g_tmpzx*(H1avg(i,k+1, &
4810  j) -H1avg(i,k,j))
4811  Tmpv1 =tmpzx*(H1avg(i,k+1,j) -H1avg(i,k,j))
4812
4813  g_Tmpv2 =Tmpv1*g_rdzu +g_Tmpv1*rdzu
4814  Tmpv2 =Tmpv1*rdzu
4815
4816  g_Tmpv3 =-msfuy(i,j)*xkxavg(i,k,j)*(rdx*(g_var(i,k,j) -g_var(i-1,k,j)) &
4817  -g_Tmpv2) -msfuy(i,j)*g_xkxavg(i,k,j)*(rdx*(var(i,k,j) -var(i-1,k,j)) -Tmpv2)
4818  Tmpv3 =-msfuy(i,j)*xkxavg(i,k,j)*(rdx*(var(i,k,j) -var(i-1,k,j)) -Tmpv2)
4819
4820  g_H1(i,k,j) =g_Tmpv3
4821  H1(i,k,j) =Tmpv3
4822
4823  ENDDO
4824  ENDDO
4825  ENDDO
4826
4827  DO j =j_start,j_end+1
4828  DO k =kts,ktf
4829  DO i =i_start,i_end
4830
4831  g_xkxavg(i,k,j) =0.5*(g_xkhh(i,k,j-1) +g_xkhh(i,k,j))
4832  xkxavg(i,k,j) =0.5*(xkhh(i,k,j-1) +xkhh(i,k,j))
4833
4834  ENDDO
4835  ENDDO
4836  ENDDO
4837
4838  DO j =j_start,j_end+1
4839  DO k =kts+1,ktf
4840  DO i =i_start,i_end
4841
4842  g_H2avg(i,k,j) =0.5*(fnm(k)*(g_var(i,k,j-1) +g_var(i,k,j)) +fnp(k) &
4843 *(g_var(i,k-1,j-1) +g_var(i,k-1,j)))
4844  H2avg(i,k,j) =0.5*(fnm(k)*(var(i,k,j-1) +var(i,k,j)) +fnp(k)*(var(i,k-1,j-1) +var(i,k-1,j)))
4845
4846  ENDDO
4847  ENDDO
4848  ENDDO
4849
4850  DO j =j_start,j_end+1
4851  DO i =i_start,i_end
4852
4853  g_H2avg(i,kts,j) =0.5*(cf1*g_var(i,1,j) +cf2*g_var(i,2,j) +cf3*g_var(i,3, &
4854  j) +cf1*g_var(i,1,j-1) +cf2*g_var(i,2,j-1) +cf3*g_var(i,3,j-1))
4855  H2avg(i,kts,j) =0.5*(cf1*var(i,1,j) +cf2*var(i,2,j) +cf3*var(i,3,j) +cf1*var(i,1,j-1) &
4856  +cf2*var(i,2,j-1) +cf3*var(i,3,j-1))
4857
4858  g_H2avg(i,ktf+1,j) =0.5*(g_var(i,ktes1,j) +((g_var(i,ktes1,j) -g_var(i, &
4859  ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)) +g_var(i,ktes1,j-1) +((g_var(i,ktes1,j-1) &
4860  -g_var(i,ktes2,j-1))*0.5*dnw(ktes1)/dn(ktes1)))
4861  H2avg(i,ktf+1,j) =0.5*(var(i,ktes1,j) +(var(i,ktes1,j) -var(i,ktes2,j)) &
4862 *0.5*dnw(ktes1)/dn(ktes1) +var(i,ktes1,j-1) +(var(i,ktes1,j-1) -var(i,ktes2,j-1)) &
4863 *0.5*dnw(ktes1)/dn(ktes1))
4864
4865  ENDDO
4866  ENDDO
4867
4868  DO j =j_start,j_end+1
4869  DO k =kts,ktf
4870  DO i =i_start,i_end
4871
4872  g_tmpzy =0.5*(g_zy(i,k,j) +g_zy(i,k+1,j))
4873  tmpzy =0.5*(zy(i,k,j) +zy(i,k+1,j))
4874
4875  g_rdzv =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i,k,j- &
4876  1)/(rdzw(i,k,j-1)*rdzw(i,k,j-1))))/((1./rdzw(i,k,j) +1./rdzw(i,k,j-1))*(1./rdzw(i,k, &
4877  j) +1./rdzw(i,k,j-1)))
4878  rdzv =2./(1./rdzw(i,k,j) +1./rdzw(i,k,j-1))
4879
4880  g_Tmpv1 =tmpzy*(g_H2avg(i,k+1,j) -g_H2avg(i,k,j)) +g_tmpzy*(H2avg(i,k+1, &
4881  j) -H2avg(i,k,j))
4882  Tmpv1 =tmpzy*(H2avg(i,k+1,j) -H2avg(i,k,j))
4883
4884  g_Tmpv2 =Tmpv1*g_rdzv +g_Tmpv1*rdzv
4885  Tmpv2 =Tmpv1*rdzv
4886
4887  g_Tmpv3 =-msfvy(i,j)*xkxavg(i,k,j)*(rdy*(g_var(i,k,j) -g_var(i,k,j-1)) &
4888  -g_Tmpv2) -msfvy(i,j)*g_xkxavg(i,k,j)*(rdy*(var(i,k,j) -var(i,k,j-1)) -Tmpv2)
4889  Tmpv3 =-msfvy(i,j)*xkxavg(i,k,j)*(rdy*(var(i,k,j) -var(i,k,j-1)) -Tmpv2)
4890
4891  g_H2(i,k,j) =g_Tmpv3
4892  H2(i,k,j) =Tmpv3
4893
4894  ENDDO
4895  ENDDO
4896  ENDDO
4897
4898  DO j =j_start,j_end
4899  DO k =kts+1,ktf
4900  DO i =i_start,i_end
4901
4902  g_H1avg(i,k,j) =0.5*(fnm(k)*(g_H1(i+1,k,j) +g_H1(i,k,j)) +fnp(k) &
4903 *(g_H1(i+1,k-1,j) +g_H1(i,k-1,j)))
4904  H1avg(i,k,j) =0.5*(fnm(k)*(H1(i+1,k,j) +H1(i,k,j)) +fnp(k)*(H1(i+1,k-1,j) +H1(i,k-1,j)))
4905
4906  g_H2avg(i,k,j) =0.5*(fnm(k)*(g_H2(i,k,j+1) +g_H2(i,k,j)) +fnp(k) &
4907 *(g_H2(i,k-1,j+1) +g_H2(i,k-1,j)))
4908  H2avg(i,k,j) =0.5*(fnm(k)*(H2(i,k,j+1) +H2(i,k,j)) +fnp(k)*(H2(i,k-1,j+1) +H2(i,k-1,j)))
4909
4910  g_tmpzx =0.5*(g_zx(i,k,j) +g_zx(i+1,k,j))
4911  tmpzx =0.5*(zx(i,k,j) +zx(i+1,k,j))
4912
4913  g_tmpzy =0.5*(g_zy(i,k,j) +g_zy(i,k,j+1))
4914  tmpzy =0.5*(zy(i,k,j) +zy(i,k,j+1))
4915
4916  g_Tmpv1 =H1avg(i,k,j)*g_tmpzx +g_H1avg(i,k,j)*tmpzx
4917  Tmpv1 =H1avg(i,k,j)*tmpzx
4918
4919  g_H1avg(i,k,j) =g_Tmpv1
4920  H1avg(i,k,j) =Tmpv1
4921
4922  g_Tmpv1 =H2avg(i,k,j)*g_tmpzy +g_H2avg(i,k,j)*tmpzy
4923  Tmpv1 =H2avg(i,k,j)*tmpzy
4924
4925  g_H2avg(i,k,j) =g_Tmpv1
4926  H2avg(i,k,j) =Tmpv1
4927
4928  ENDDO
4929  ENDDO
4930  ENDDO
4931
4932  DO j =j_start,j_end
4933  DO i =i_start,i_end
4934
4935  g_H1avg(i,kts,j) =0.0
4936  H1avg(i,kts,j) =0.
4937
4938  g_H1avg(i,ktf+1,j) =0.0
4939  H1avg(i,ktf+1,j) =0.
4940
4941  g_H2avg(i,kts,j) =0.0
4942  H2avg(i,kts,j) =0.
4943
4944  g_H2avg(i,ktf+1,j) =0.0
4945  H2avg(i,ktf+1,j) =0.
4946
4947  ENDDO
4948  ENDDO
4949
4950  DO j =j_start,j_end
4951  DO k =kts,ktf
4952  DO i =i_start,i_end
4953
4954 ! g_mrdx =0.0  ! Remarked by Ning Pan, 2010-08-10
4955  mrdx =msftx(i,j) *rdx
4956
4957 ! g_mrdy =0.0  ! Remarked by Ning Pan, 2010-08-10
4958  mrdy =msfty(i,j) *rdy
4959
4960  g_Tmpv1 =(mu(i+1,j) +mu(i,j))*g_H1(i+1,k,j) +(g_mu(i+1,j) +g_mu(i,j))*H1(i+1,k,j)
4961  Tmpv1 =(mu(i+1,j) +mu(i,j))*H1(i+1,k,j)
4962
4963  g_Tmpv2 =(mu(i-1,j) +mu(i,j))*g_H1(i,k,j) +(g_mu(i-1,j) +g_mu(i,j))*H1(i,k,j)
4964  Tmpv2 =(mu(i-1,j) +mu(i,j))*H1(i,k,j)
4965
4966 ! Revised by Ning Pan, 2010-08-10
4967 ! g_Tmpv3 =mrdx*0.5*(g_Tmpv1 -g_Tmpv2) +g_mrdx*0.5*(Tmpv1 -Tmpv2)
4968  g_Tmpv3 =mrdx*0.5*(g_Tmpv1 -g_Tmpv2)
4969  Tmpv3 =mrdx*0.5*(Tmpv1 -Tmpv2)
4970
4971  g_Tmpv4 =(mu(i,j+1) +mu(i,j))*g_H2(i,k,j+1) +(g_mu(i,j+1) +g_mu(i,j))*H2(i,k,j+1)
4972  Tmpv4 =(mu(i,j+1) +mu(i,j))*H2(i,k,j+1)
4973
4974  g_Tmpv5 =(mu(i,j-1) +mu(i,j))*g_H2(i,k,j) +(g_mu(i,j-1) +g_mu(i,j))*H2(i,k,j)
4975  Tmpv5 =(mu(i,j-1) +mu(i,j))*H2(i,k,j)
4976
4977 ! Revised by Ning Pan, 2010-08-10
4978 ! g_Tmpv6 =mrdy*0.5*(g_Tmpv4 -g_Tmpv5) +g_mrdy*0.5*(Tmpv4 -Tmpv5)
4979  g_Tmpv6 =mrdy*0.5*(g_Tmpv4 -g_Tmpv5)
4980  Tmpv6 =mrdy*0.5*(Tmpv4 -Tmpv5)
4981
4982  g_Tmpv7 =msfty(i,j)*mu(i,j)*(g_H1avg(i,k+1,j) -g_H1avg(i,k,j) &
4983  +g_H2avg(i,k+1,j) -g_H2avg(i,k,j)) +msfty(i,j)*g_mu(i,j)*(H1avg(i,k+1,j) &
4984  -H1avg(i,k,j) +H2avg(i,k+1,j) -H2avg(i,k,j))
4985  Tmpv7 =msfty(i,j)*mu(i,j)*(H1avg(i,k+1,j) -H1avg(i,k,j) +H2avg(i,k+1,j) -H2avg(i,k,j))
4986
4987  g_Tmpv8 =Tmpv7*g_rdzw(i,k,j) +g_Tmpv7*rdzw(i,k,j)
4988  Tmpv8 =Tmpv7*rdzw(i,k,j)
4989
4990  g_tendency(i,k,j) =g_tendency(i,k,j) -(g_Tmpv3 +g_Tmpv6 -g_Tmpv8)
4991  tendency(i,k,j) =tendency(i,k,j) -(Tmpv3 +Tmpv6 -Tmpv8)
4992
4993  ENDDO
4994  ENDDO
4995  ENDDO
4996
4997  IF( doing_tke ) THEN
4998
4999  DO j =j_start,j_end
5000  DO k =kts,ktf
5001  DO i =i_start,i_end
5002
5003  g_tendency(i,k,j) =g_tmptendf(i,k,j) +2.*(g_tendency(i,k,j) -g_tmptendf(i,k,j))
5004  tendency(i,k,j) =tmptendf(i,k,j) +2.*(tendency(i,k,j) -tmptendf(i,k,j))
5005
5006  ENDDO
5007  ENDDO
5008  ENDDO
5009  ENDIF
5010
5011  END SUBROUTINE g_horizontal_diffusion_s
5012
5013  SUBROUTINE g_vertical_diffusion_2(ru_tendf,g_ru_tendf,rv_tendf,g_rv_tendf, &
5014  rw_tendf,g_rw_tendf,rt_tendf,g_rt_tendf,tke_tendf,g_tke_tendf,moist_tendf, &
5015  g_moist_tendf,n_moist,chem_tendf,g_chem_tendf,n_chem,scalar_tendf, &
5016  g_scalar_tendf,n_scalar,tracer_tendf,g_tracer_tendf,n_tracer,u_2,g_u_2,v_2, &
5017  g_v_2,thp,g_thp,u_base,v_base,t_base,qv_base,mu,g_mu,tke,g_tke, &
5018  config_flags,defor13,g_defor13,defor23,g_defor23,defor33,g_defor33,nba_mij, &
5019  g_nba_mij,n_nba_mij,div,g_div,moist,g_moist,chem,g_chem,scalar, &
5020  g_scalar,tracer,g_tracer,xkmv,g_xkmv,xkhv,g_xkhv,km_opt,fnm,fnp,dn,dnw, &
5021  rdz,g_rdz,rdzw,g_rdzw,hfx,g_hfx,qfx,g_qfx,ust,g_ust,rho,g_rho,ids, &
5022  ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5023
5024  IMPLICIT NONE
5025
5026  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
5027
5028    REAL :: g_Sqrt
5029  TYPE(grid_config_rec_type) :: config_flags
5030  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5031  INTEGER :: n_moist,n_chem,n_scalar,n_tracer,km_opt
5032  REAL,DIMENSION(kms:kme) :: fnm
5033  REAL,DIMENSION(kms:kme) :: fnp
5034  REAL,DIMENSION(kms:kme) :: dnw
5035  REAL,DIMENSION(kms:kme) :: dn
5036  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
5037  REAL,DIMENSION(kms:kme) :: qv_base
5038  REAL,DIMENSION(kms:kme) :: u_base
5039  REAL,DIMENSION(kms:kme) :: v_base
5040  REAL,DIMENSION(kms:kme) :: t_base
5041  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tendf,g_ru_tendf,rv_tendf, &
5042  g_rv_tendf,rw_tendf,g_rw_tendf,tke_tendf,g_tke_tendf,rt_tendf,g_rt_tendf
5043  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist_tendf,g_moist_tendf
5044  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem_tendf,g_chem_tendf
5045  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar_tendf,g_scalar_tendf
5046  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer_tendf,g_tracer_tendf
5047  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,g_moist
5048  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem,g_chem
5049  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar,g_scalar
5050  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer,g_tracer
5051  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,g_defor13,defor23,g_defor23, &
5052  defor33,g_defor33,div,g_div,xkmv,g_xkmv,xkhv,g_xkhv,tke,g_tke,rdz, &
5053  g_rdz,u_2,g_u_2,v_2,g_v_2,rdzw,g_rdzw
5054
5055  INTEGER :: n_nba_mij
5056
5057  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
5058  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho,g_rho
5059  REAL,DIMENSION(ims:ime,jms:jme) :: hfx,g_hfx,qfx,g_qfx
5060  REAL,DIMENSION(ims:ime,jms:jme) :: ust,g_ust
5061  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: thp,g_thp
5062  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var_mix,g_var_mix
5063  INTEGER :: im,i,j,k
5064  INTEGER :: i_start,i_end,j_start,j_end
5065  REAL :: V0_u,g_V0_u,V0_v,g_V0_v,tao_xz,g_tao_xz,tao_yz,g_tao_yz,ustar, &
5066  g_ustar,cd0,g_cd0
5067  REAL :: xsfc,g_xsfc,psi1,g_psi1,vk2,g_vk2,zrough,g_zrough,lnz,g_lnz
5068  REAL :: heat_flux,g_heat_flux,moist_flux,g_moist_flux,heat_flux0,g_heat_flux0
5069  REAL :: cpm,g_cpm
5070
5071  i_start =its
5072
5073  i_end =min(ite,ide-1)
5074
5075  j_start =jts
5076
5077  j_end =min(jte,jde-1)
5078
5079  CALL g_vertical_diffusion_u_2(ru_tendf,g_ru_tendf,config_flags,mu,g_mu, &
5080  defor13,g_defor13,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
5081  g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5082
5083  CALL g_vertical_diffusion_v_2(rv_tendf,g_rv_tendf,config_flags,mu,g_mu, &
5084  defor23,g_defor23,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
5085  g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5086
5087  CALL g_vertical_diffusion_w_2(rw_tendf,g_rw_tendf,config_flags,mu,g_mu, &
5088  defor33,g_defor33,tke(ims,kms,jms),g_tke(ims,kms,jms),nba_mij,g_nba_mij, &
5089  n_nba_mij,div,g_div,xkmv,g_xkmv,dn,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims, &
5090  ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5091
5092 ! Added by Ning Pan, 2010-08-11
5093  tl_vflux: SELECT CASE( config_flags%isfflx )
5094  CASE (0)
5095
5096 ! Remarked by Ning Pan, 2010-08-09
5097 ! g_cd0 =g_config_flags%tke_drag_coefficient
5098  cd0 =config_flags%tke_drag_coefficient
5099
5100  DO j =j_start,j_end
5101  DO i =i_start,ite
5102
5103  g_V0_u =0.0
5104  V0_u =0.
5105
5106  g_tao_xz =0.0
5107  tao_xz =0.
5108
5109  g_V0_u =g_Sqrt((2.0*g_u_2(i,kts,j)*u_2(i,kts,j)) +(2.0*((g_v_2(i,kts,j) &
5110  +g_v_2(i,kts,j+1) +g_v_2(i-1,kts,j) +g_v_2(i-1,kts,j+1))/4)*((v_2(i,kts,j) &
5111  +v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)), (u_2(i,kts,j)**2) &
5112  +(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)**2))
5113  V0_u =sqrt((u_2(i,kts,j)**2) +(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) &
5114  +v_2(i-1,kts,j+1))/4)**2)) +epsilon
5115
5116 ! Revised by Ning Pan, 2010-08-11
5117 ! g_Tmpv1 =cd0*g_V0_u +g_cd0*V0_u
5118  g_Tmpv1 =cd0*g_V0_u
5119  Tmpv1 =cd0*V0_u
5120
5121  g_Tmpv2 =Tmpv1*g_u_2(i,kts,j) +g_Tmpv1*u_2(i,kts,j)
5122  Tmpv2 =Tmpv1*u_2(i,kts,j)
5123
5124  g_tao_xz =g_Tmpv2
5125  tao_xz =Tmpv2
5126
5127  g_Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*g_tao_xz +0.25*(g_mu(i,j) +g_mu(i-1,j))*tao_xz
5128  Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*tao_xz
5129
5130  g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i-1,kts,j)) +g_Tmpv1*(rdzw(i, &
5131  kts,j) +rdzw(i-1,kts,j))
5132  Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i-1,kts,j))
5133
5134  g_ru_tendf(i,kts,j) =g_ru_tendf(i,kts,j) -g_Tmpv2
5135  ru_tendf(i,kts,j) =ru_tendf(i,kts,j) -Tmpv2
5136
5137  IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
5138     g_nba_mij(i,kts,j,P_m13) = -g_tao_xz
5139     nba_mij(i,kts,j,P_m13) = -tao_xz
5140  ENDIF
5141
5142  ENDDO
5143  ENDDO
5144
5145  DO j =j_start,jte
5146  DO i =i_start,i_end
5147
5148  g_V0_v =0.0
5149  V0_v =0.
5150
5151  g_tao_yz =0.0
5152  tao_yz =0.
5153
5154  g_V0_v =g_Sqrt((2.0*g_v_2(i,kts,j)*v_2(i,kts,j)) +(2.0*((g_u_2(i,kts,j) &
5155  +g_u_2(i,kts,j-1) +g_u_2(i+1,kts,j) +g_u_2(i+1,kts,j-1))/4)*((u_2(i,kts,j) &
5156  +u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)), (v_2(i,kts,j)**2) &
5157  +(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)**2))
5158  V0_v =sqrt((v_2(i,kts,j)**2) +(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) &
5159  +u_2(i+1,kts,j-1))/4)**2)) +epsilon
5160
5161 ! Revised by Ning Pan, 2010-08-11
5162 ! g_Tmpv1 =cd0*g_V0_v +g_cd0*V0_v
5163  g_Tmpv1 =cd0*g_V0_v
5164  Tmpv1 =cd0*V0_v
5165
5166  g_Tmpv2 =Tmpv1*g_v_2(i,kts,j) +g_Tmpv1*v_2(i,kts,j)
5167  Tmpv2 =Tmpv1*v_2(i,kts,j)
5168
5169  g_tao_yz =g_Tmpv2
5170  tao_yz =Tmpv2
5171
5172  g_Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*g_tao_yz +0.25*(g_mu(i,j) +g_mu(i,j-1))*tao_yz
5173  Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*tao_yz
5174
5175  g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i,kts,j-1)) +g_Tmpv1*(rdzw(i, &
5176  kts,j) +rdzw(i,kts,j-1))
5177  Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i,kts,j-1))
5178
5179  g_rv_tendf(i,kts,j) =g_rv_tendf(i,kts,j) -g_Tmpv2
5180  rv_tendf(i,kts,j) =rv_tendf(i,kts,j) -Tmpv2
5181
5182  IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
5183     g_nba_mij(i,kts,j,P_m23) = -g_tao_yz
5184     nba_mij(i,kts,j,P_m23) = -tao_yz
5185  ENDIF
5186
5187  ENDDO
5188  ENDDO
5189
5190  CASE (1,2)  ! Added by Ning Pan, 2010-08-11
5191
5192  DO j =j_start,j_end
5193  DO i =i_start,ite
5194
5195  g_V0_u =0.0
5196  V0_u =0.
5197
5198  g_tao_xz =0.0
5199  tao_xz =0.
5200
5201  g_V0_u =g_Sqrt((2.0*g_u_2(i,kts,j)*u_2(i,kts,j)) +(2.0*((g_v_2(i,kts,j) &
5202  +g_v_2(i,kts,j+1) +g_v_2(i-1,kts,j) +g_v_2(i-1,kts,j+1))/4)*((v_2(i,kts,j) &
5203  +v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)), (u_2(i,kts,j)**2) &
5204  +(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) +v_2(i-1,kts,j+1))/4)**2))
5205  V0_u =sqrt((u_2(i,kts,j)**2) +(((v_2(i,kts,j) +v_2(i,kts,j+1) +v_2(i-1,kts,j) &
5206  +v_2(i-1,kts,j+1))/4)**2)) +epsilon
5207
5208  g_ustar =0.5*(g_ust(i,j) +g_ust(i-1,j))
5209  ustar =0.5*(ust(i,j) +ust(i-1,j))
5210
5211  g_Tmpv1 =2.0*ustar*g_ustar
5212  Tmpv1 =ustar*ustar
5213
5214  g_Tmpv2 =Tmpv1*g_u_2(i,kts,j) +g_Tmpv1*u_2(i,kts,j)
5215  Tmpv2 =Tmpv1*u_2(i,kts,j)
5216
5217  g_Tmpv3 =(g_Tmpv2*V0_u -g_V0_u*Tmpv2)/(V0_u*V0_u)
5218  Tmpv3 =Tmpv2/V0_u
5219
5220  g_tao_xz =g_Tmpv3
5221  tao_xz =Tmpv3
5222
5223  g_Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*g_tao_xz +0.25*(g_mu(i,j) +g_mu(i-1,j))*tao_xz
5224  Tmpv1 =0.25*(mu(i,j) +mu(i-1,j))*tao_xz
5225
5226  g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i-1,kts,j)) +g_Tmpv1*(rdzw(i, &
5227  kts,j) +rdzw(i-1,kts,j))
5228  Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i-1,kts,j))
5229
5230  g_ru_tendf(i,kts,j) =g_ru_tendf(i,kts,j) -g_Tmpv2
5231  ru_tendf(i,kts,j) =ru_tendf(i,kts,j) -Tmpv2
5232
5233  IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
5234     g_nba_mij(i,kts,j,P_m13) = -g_tao_xz
5235     nba_mij(i,kts,j,P_m13) = -tao_xz
5236  ENDIF
5237
5238  ENDDO
5239  ENDDO
5240
5241  DO j =j_start,jte
5242  DO i =i_start,i_end
5243
5244  g_V0_v =0.0
5245  V0_v =0.
5246
5247  g_tao_yz =0.0
5248  tao_yz =0.
5249
5250  g_V0_v =g_Sqrt((2.0*g_v_2(i,kts,j)*v_2(i,kts,j)) +(2.0*((g_u_2(i,kts,j) &
5251  +g_u_2(i,kts,j-1) +g_u_2(i+1,kts,j) +g_u_2(i+1,kts,j-1))/4)*((u_2(i,kts,j) &
5252  +u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)), (v_2(i,kts,j)**2) &
5253  +(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) +u_2(i+1,kts,j-1))/4)**2))
5254  V0_v =sqrt((v_2(i,kts,j)**2) +(((u_2(i,kts,j) +u_2(i,kts,j-1) +u_2(i+1,kts,j) &
5255  +u_2(i+1,kts,j-1))/4)**2)) +epsilon
5256
5257  g_ustar =0.5*(g_ust(i,j) +g_ust(i,j-1))
5258  ustar =0.5*(ust(i,j) +ust(i,j-1))
5259
5260  g_Tmpv1 =2.0*ustar*g_ustar
5261  Tmpv1 =ustar*ustar
5262
5263  g_Tmpv2 =Tmpv1*g_v_2(i,kts,j) +g_Tmpv1*v_2(i,kts,j)
5264  Tmpv2 =Tmpv1*v_2(i,kts,j)
5265
5266  g_Tmpv3 =(g_Tmpv2*V0_v -g_V0_v*Tmpv2)/(V0_v*V0_v)
5267  Tmpv3 =Tmpv2/V0_v
5268
5269  g_tao_yz =g_Tmpv3
5270  tao_yz =Tmpv3
5271
5272  g_Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*g_tao_yz +0.25*(g_mu(i,j) +g_mu(i,j-1))*tao_yz
5273  Tmpv1 =0.25*(mu(i,j) +mu(i,j-1))*tao_yz
5274
5275  g_Tmpv2 =Tmpv1*(g_rdzw(i,kts,j) +g_rdzw(i,kts,j-1)) +g_Tmpv1*(rdzw(i, &
5276  kts,j) +rdzw(i,kts,j-1))
5277  Tmpv2 =Tmpv1*(rdzw(i,kts,j) +rdzw(i,kts,j-1))
5278
5279  g_rv_tendf(i,kts,j) =g_rv_tendf(i,kts,j) -g_Tmpv2
5280  rv_tendf(i,kts,j) =rv_tendf(i,kts,j) -Tmpv2
5281
5282  IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
5283     g_nba_mij(i,kts,j,P_m23) = -g_tao_yz
5284     nba_mij(i,kts,j,P_m23) = -tao_yz
5285  ENDIF
5286
5287  ENDDO
5288  ENDDO
5289
5290  CASE DEFAULT  ! Added by Ning Pan, 2010-08-11
5291
5292 ! Revised by Ning Pan, 2010-08-10
5293 ! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
5294  CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
5295
5296  END SELECT tl_vflux  ! Added by Ning Pan, 2010-08-11
5297
5298  IF( config_flags%mix_full_fields ) THEN
5299
5300  DO j =jts,min(jte,jde-1)
5301  DO k =kts,kte-1
5302  DO i =its,min(ite,ide-1)
5303
5304  g_var_mix(i,k,j) =g_thp(i,k,j)
5305  var_mix(i,k,j) =thp(i,k,j)
5306
5307  ENDDO
5308  ENDDO
5309  ENDDO
5310  ELSE
5311
5312  DO j =jts,min(jte,jde-1)
5313  DO k =kts,kte-1
5314  DO i =its,min(ite,ide-1)
5315
5316  g_var_mix(i,k,j) =g_thp(i,k,j)
5317  var_mix(i,k,j) =thp(i,k,j) -t_base(k)
5318
5319  ENDDO
5320  ENDDO
5321  ENDDO
5322  END IF
5323
5324  CALL g_vertical_diffusion_s(rt_tendf,g_rt_tendf,config_flags,var_mix, &
5325  g_var_mix,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp, &
5326 .false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5327
5328 ! Added by Ning Pan, 2010-08-11
5329  tl_hflux: SELECT CASE( config_flags%isfflx )
5330  CASE (0,2)
5331
5332 ! Remarked by Ning Pan, 2010-08-09
5333 ! g_heat_flux =g_config_flags%tke_heat_flux
5334  heat_flux =config_flags%tke_heat_flux
5335
5336  DO j =j_start,j_end
5337  DO i =i_start,i_end
5338
5339  g_cpm =cp*(0.8*g_moist(i,kts,j,P_QV))
5340  cpm =cp*(1. +0.8*moist(i,kts,j,P_QV))
5341
5342  g_hfx(i,j)= heat_flux*cpm*g_rho(i,1,j) + heat_flux*g_cpm*rho(i,1,j)
5343
5344 ! Revised by Ning Pan, 2010-08-11
5345 ! g_Tmpv1 =mu(i,j)*g_heat_flux +g_mu(i,j)*heat_flux
5346  g_Tmpv1 =g_mu(i,j)*heat_flux
5347  Tmpv1 =mu(i,j)*heat_flux
5348
5349  g_Tmpv2 =Tmpv1*g_rdzw(i,kts,j) +g_Tmpv1*rdzw(i,kts,j)
5350  Tmpv2 =Tmpv1*rdzw(i,kts,j)
5351
5352  g_rt_tendf(i,kts,j) =g_rt_tendf(i,kts,j) +g_Tmpv2
5353  rt_tendf(i,kts,j) =rt_tendf(i,kts,j) +Tmpv2
5354
5355  ENDDO
5356  ENDDO
5357
5358  CASE (1)  ! Added by Ning Pan, 2010-08-11
5359
5360  DO j =j_start,j_end
5361  DO i =i_start,i_end
5362
5363  g_cpm =cp*(0.8*g_moist(i,kts,j,P_QV))
5364  cpm =cp*(1. +0.8*moist(i,kts,j,P_QV))
5365
5366  g_Tmpv1 =(g_hfx(i,j)*cpm -g_cpm*hfx(i,j))/(cpm*cpm)
5367  Tmpv1 =hfx(i,j)/cpm
5368
5369  g_Tmpv2 =(g_Tmpv1*rho(i,1,j) -g_rho(i,1,j)*Tmpv1)/(rho(i,1,j)*rho(i,1,j))
5370  Tmpv2 =Tmpv1/rho(i,1,j)
5371
5372  g_heat_flux =g_Tmpv2
5373  heat_flux =Tmpv2
5374
5375  g_Tmpv1 =mu(i,j)*g_heat_flux +g_mu(i,j)*heat_flux
5376  Tmpv1 =mu(i,j)*heat_flux
5377
5378  g_Tmpv2 =Tmpv1*g_rdzw(i,kts,j) +g_Tmpv1*rdzw(i,kts,j)
5379  Tmpv2 =Tmpv1*rdzw(i,kts,j)
5380
5381  g_rt_tendf(i,kts,j) =g_rt_tendf(i,kts,j) +g_Tmpv2
5382  rt_tendf(i,kts,j) =rt_tendf(i,kts,j) +Tmpv2
5383
5384  ENDDO
5385  ENDDO
5386
5387  CASE DEFAULT  ! Added by Ning Pan, 2010-08-11
5388
5389 ! Revised by Ning Pan, 2010-08-10
5390 ! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
5391  CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
5392
5393  END SELECT tl_hflux  ! Added by Ning Pan, 2010-08-11
5394
5395  IF(km_opt .eq. 2) THEN
5396
5397  CALL g_vertical_diffusion_s(tke_tendf(ims,kms,jms),g_tke_tendf(ims,kms,jms) &
5398 ,config_flags,tke(ims,kms,jms),g_tke(ims,kms,jms),mu,g_mu,xkhv,g_xkhv,dn, &
5399  dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.true.,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
5400  jme,kms,kme,its,ite,jts,jte,kts,kte)
5401  endif
5402
5403  IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
5404
5405  DO im =PARAM_FIRST_SCALAR,n_moist
5406
5407  IF( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
5408
5409  DO j =jts,min(jte,jde-1)
5410  DO k =kts,kte-1
5411  DO i =its,min(ite,ide-1)
5412
5413  g_var_mix(i,k,j) =g_moist(i,k,j,im)
5414  var_mix(i,k,j) =moist(i,k,j,im) -qv_base(k)
5415
5416  ENDDO
5417  ENDDO
5418  ENDDO
5419  ELSE
5420
5421  DO j =jts,min(jte,jde-1)
5422  DO k =kts,kte-1
5423  DO i =its,min(ite,ide-1)
5424
5425  g_var_mix(i,k,j) =g_moist(i,k,j,im)
5426  var_mix(i,k,j) =moist(i,k,j,im)
5427
5428  ENDDO
5429  ENDDO
5430  ENDDO
5431  END IF
5432
5433  CALL g_vertical_diffusion_s(moist_tendf(ims,kms,jms,im),g_moist_tendf(ims,kms, &
5434  jms,im),config_flags,var_mix,g_var_mix,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz, &
5435  g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
5436  kme,its,ite,jts,jte,kts,kte)
5437
5438 ! Added by Ning Pan, 2010-08-11
5439  tl_qflux: SELECT CASE( config_flags%isfflx )
5440  CASE (0)
5441  CASE (1,2)
5442
5443  IF( im == P_QV ) THEN
5444
5445  DO j =j_start,j_end
5446  DO i =i_start,i_end
5447
5448  g_Tmpv1 =(g_qfx(i,j)*rho(i,1,j) -g_rho(i,1,j)*qfx(i,j))/(rho(i,1,j)*rho(i,1,j))
5449  Tmpv1 =qfx(i,j)/rho(i,1,j)
5450
5451  g_Tmpv2 =(g_Tmpv1*(1. +moist(i,kts,j,P_QV)) -(g_moist(i,kts,j,P_QV))*Tmpv1) &
5452 /((1. +moist(i,kts,j,P_QV))*(1. +moist(i,kts,j,P_QV)))
5453  Tmpv2 =Tmpv1/(1. +moist(i,kts,j,P_QV))
5454
5455  g_moist_flux =g_Tmpv2
5456  moist_flux =Tmpv2
5457
5458  g_Tmpv1 =mu(i,j)*g_moist_flux +g_mu(i,j)*moist_flux
5459  Tmpv1 =mu(i,j)*moist_flux
5460
5461  g_Tmpv2 =Tmpv1*g_rdzw(i,kts,j) +g_Tmpv1*rdzw(i,kts,j)
5462  Tmpv2 =Tmpv1*rdzw(i,kts,j)
5463
5464  g_moist_tendf(i,kts,j,im) =g_moist_tendf(i,kts,j,im) +g_Tmpv2
5465  moist_tendf(i,kts,j,im) =moist_tendf(i,kts,j,im) +Tmpv2
5466
5467  ENDDO
5468  ENDDO
5469  ENDIF
5470
5471  CASE DEFAULT  ! Added by Ning Pan, 2010-08-11
5472
5473 ! Revised by Ning Pan, 2010-08-10
5474 ! CALL g_wrf_error_fatal('isfflx value invalid for diff_opt=2')
5475  CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
5476
5477  END SELECT tl_qflux  ! Added by Ning Pan, 2010-08-11
5478
5479  ENDDO
5480  ENDIF
5481
5482  IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
5483
5484  DO im =PARAM_FIRST_SCALAR,n_chem
5485  CALL g_vertical_diffusion_s(chem_tendf(ims,kms,jms,im),g_chem_tendf(ims,kms, &
5486  jms,im),config_flags,chem(ims,kms,jms,im),g_chem(ims,kms,jms,im),mu,g_mu,xkhv, &
5487  g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde, &
5488  ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5489  ENDDO
5490  ENDIF
5491
5492  IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
5493
5494  DO im =PARAM_FIRST_SCALAR,n_tracer
5495
5496  CALL g_vertical_diffusion_s(tracer_tendf(ims,kms,jms,im),g_tracer_tendf(ims, &
5497  kms,jms,im),config_flags,tracer(ims,kms,jms,im),g_tracer(ims,kms,jms,im) &
5498 ,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids, &
5499  ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5500  ENDDO
5501  ENDIF
5502
5503  IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
5504
5505  DO im =PARAM_FIRST_SCALAR,n_scalar
5506
5507  CALL g_vertical_diffusion_s(scalar_tendf(ims,kms,jms,im),g_scalar_tendf(ims, &
5508  kms,jms,im),config_flags,scalar(ims,kms,jms,im),g_scalar(ims,kms,jms,im) &
5509 ,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp,.false.,ids, &
5510  ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5511  ENDDO
5512  ENDIF
5513
5514  END SUBROUTINE g_vertical_diffusion_2
5515
5516  SUBROUTINE g_vertical_diffusion_u_2(tendency,g_tendency,config_flags,mu, &
5517  g_mu,defor13,g_defor13,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
5518  g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5519
5520  IMPLICIT NONE
5521
5522  REAL :: Tmpv1,g_Tmpv1
5523  TYPE(grid_config_rec_type) :: config_flags
5524  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5525  REAL,DIMENSION(kms:kme) :: fnm
5526  REAL,DIMENSION(kms:kme) :: fnp
5527  REAL,DIMENSION(kms:kme) :: dnw
5528  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
5529  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,g_defor13,xkmv,g_xkmv,rdzw,g_rdzw
5530
5531  INTEGER :: n_nba_mij
5532
5533  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
5534  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
5535  INTEGER :: i,j,k,ktf
5536  INTEGER :: i_start,i_end,j_start,j_end
5537  INTEGER :: is_ext,ie_ext,js_ext,je_ext
5538  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,g_titau3
5539  REAL,DIMENSION(its:ite,jts:jte) :: zzavg,g_zzavg
5540  REAL :: rdzu,g_rdzu
5541
5542  ktf =min(kte,kde-1)
5543
5544  i_start =its
5545
5546  i_end =ite
5547
5548  j_start =jts
5549
5550  j_end =min(jte,jde-1)
5551
5552  IF( config_flags%open_xs .or. config_flags%specified .or.   &
5553         config_flags%nested) i_start =max(ids+1,its)
5554
5555  IF( config_flags%open_xe .or. config_flags%specified .or.   &
5556         config_flags%nested) i_end =min(ide-1,ite)
5557
5558  IF( config_flags%open_ys .or. config_flags%specified .or.   &
5559         config_flags%nested) j_start =max(jds+1,jts)
5560
5561  IF( config_flags%open_ye .or. config_flags%specified .or.   &
5562         config_flags%nested) j_end =min(jde-2,jte)
5563
5564  IF( config_flags%periodic_x ) i_start =its
5565
5566  IF( config_flags%periodic_x ) i_end =ite
5567
5568  is_ext =0
5569
5570  ie_ext =0
5571
5572  js_ext =0
5573
5574  je_ext =0
5575
5576  CALL g_cal_titau_13_31(config_flags,titau3,g_titau3,defor13,g_defor13, &
5577  nba_mij(ims,kms,jms,P_m13),g_nba_mij(ims,kms,jms,P_m13),mu,g_mu,xkmv,g_xkmv, &
5578  fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
5579  its,ite,jts,jte,kts,kte)
5580
5581  DO j =j_start,j_end
5582  DO k =kts+1,ktf
5583  DO i =i_start,i_end
5584
5585  g_rdzu =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i-1,k, &
5586  j)/(rdzw(i-1,k,j)*rdzw(i-1,k,j))))/((1./rdzw(i,k,j) +1./rdzw(i-1,k,j))*(1./rdzw(i,k, &
5587  j) +1./rdzw(i-1,k,j)))
5588  rdzu =2./(1./rdzw(i,k,j) +1./rdzw(i-1,k,j))
5589
5590  g_Tmpv1 =rdzu*(g_titau3(i,k+1,j) -g_titau3(i,k,j)) +g_rdzu*(titau3(i,k+ &
5591  1,j) -titau3(i,k,j))
5592  Tmpv1 =rdzu*(titau3(i,k+1,j) -titau3(i,k,j))
5593
5594  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
5595  tendency(i,k,j) =tendency(i,k,j) -Tmpv1
5596
5597  ENDDO
5598  ENDDO
5599  ENDDO
5600
5601  DO j =j_start,j_end
5602
5603  k =kts
5604
5605  DO i =i_start,i_end
5606
5607  g_rdzu =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i-1,k, &
5608  j)/(rdzw(i-1,k,j)*rdzw(i-1,k,j))))/((1./rdzw(i,k,j) +1./rdzw(i-1,k,j))*(1./rdzw(i,k, &
5609  j) +1./rdzw(i-1,k,j)))
5610  rdzu =2./(1./rdzw(i,k,j) +1./rdzw(i-1,k,j))
5611
5612  g_Tmpv1 =rdzu*(g_titau3(i,k+1,j)) +g_rdzu*(titau3(i,k+1,j))
5613  Tmpv1 =rdzu*(titau3(i,k+1,j))
5614
5615  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
5616  tendency(i,k,j) =tendency(i,k,j) -Tmpv1
5617
5618  ENDDO
5619  ENDDO
5620
5621  END SUBROUTINE g_vertical_diffusion_u_2
5622
5623  SUBROUTINE g_vertical_diffusion_v_2(tendency,g_tendency,config_flags,mu, &
5624  g_mu,defor23,g_defor23,xkmv,g_xkmv,nba_mij,g_nba_mij,n_nba_mij,dnw,rdzw, &
5625  g_rdzw,fnm,fnp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5626
5627  IMPLICIT NONE
5628
5629  REAL :: Tmpv1,g_Tmpv1
5630  TYPE(grid_config_rec_type) :: config_flags
5631  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5632  REAL,DIMENSION(kms:kme) :: fnm
5633  REAL,DIMENSION(kms:kme) :: fnp
5634  REAL,DIMENSION(kms:kme) :: dnw
5635  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
5636  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor23,g_defor23,xkmv,g_xkmv,rdzw,g_rdzw
5637
5638  INTEGER :: n_nba_mij
5639
5640  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
5641  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
5642  INTEGER :: i,j,k,ktf
5643  INTEGER :: i_start,i_end,j_start,j_end
5644  INTEGER :: is_ext,ie_ext,js_ext,je_ext
5645  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,g_titau3
5646  REAL,DIMENSION(its:ite,jts:jte) :: zzavg,g_zzavg
5647  REAL :: rdzv,g_rdzv
5648
5649  ktf =min(kte,kde-1)
5650
5651  i_start =its
5652
5653  i_end =min(ite,ide-1)
5654
5655  j_start =jts
5656
5657  j_end =jte
5658
5659  IF( config_flags%open_xs .or. config_flags%specified .or.   &
5660         config_flags%nested) i_start =max(ids+1,its)
5661
5662  IF( config_flags%open_xe .or. config_flags%specified .or.   &
5663         config_flags%nested) i_end =min(ide-2,ite)
5664
5665  IF( config_flags%open_ys .or. config_flags%specified .or.   &
5666         config_flags%nested) j_start =max(jds+1,jts)
5667
5668  IF( config_flags%open_ye .or. config_flags%specified .or.   &
5669         config_flags%nested) j_end =min(jde-1,jte)
5670
5671  IF( config_flags%periodic_x ) i_start =its
5672
5673  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
5674
5675  is_ext =0
5676
5677  ie_ext =0
5678
5679  js_ext =0
5680
5681  je_ext =0
5682
5683  CALL g_cal_titau_23_32(config_flags,titau3,g_titau3,defor23,g_defor23, &
5684  nba_mij(ims,kms,jms,P_m23),g_nba_mij(ims,kms,jms,P_m23),mu,g_mu,xkmv,g_xkmv, &
5685  fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
5686  its,ite,jts,jte,kts,kte)
5687
5688  DO j =j_start,j_end
5689  DO k =kts+1,ktf
5690  DO i =i_start,i_end
5691
5692  g_rdzv =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i,k,j- &
5693  1)/(rdzw(i,k,j-1)*rdzw(i,k,j-1))))/((1./rdzw(i,k,j) +1./rdzw(i,k,j-1))*(1./rdzw(i,k, &
5694  j) +1./rdzw(i,k,j-1)))
5695  rdzv =2./(1./rdzw(i,k,j) +1./rdzw(i,k,j-1))
5696
5697  g_Tmpv1 =rdzv*(g_titau3(i,k+1,j) -g_titau3(i,k,j)) +g_rdzv*(titau3(i,k+ &
5698  1,j) -titau3(i,k,j))
5699  Tmpv1 =rdzv*(titau3(i,k+1,j) -titau3(i,k,j))
5700
5701  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
5702  tendency(i,k,j) =tendency(i,k,j) -Tmpv1
5703
5704  ENDDO
5705  ENDDO
5706  ENDDO
5707
5708  DO j =j_start,j_end
5709
5710  k =kts
5711
5712  DO i =i_start,i_end
5713
5714  g_rdzv =-2.*(-1.*g_rdzw(i,k,j)/(rdzw(i,k,j)*rdzw(i,k,j)) +(-1.*g_rdzw(i,k,j- &
5715  1)/(rdzw(i,k,j-1)*rdzw(i,k,j-1))))/((1./rdzw(i,k,j) +1./rdzw(i,k,j-1))*(1./rdzw(i,k, &
5716  j) +1./rdzw(i,k,j-1)))
5717  rdzv =2./(1./rdzw(i,k,j) +1./rdzw(i,k,j-1))
5718
5719  g_Tmpv1 =rdzv*(g_titau3(i,k+1,j)) +g_rdzv*(titau3(i,k+1,j))
5720  Tmpv1 =rdzv*(titau3(i,k+1,j))
5721
5722  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
5723  tendency(i,k,j) =tendency(i,k,j) -Tmpv1
5724
5725  ENDDO
5726  ENDDO
5727
5728  END SUBROUTINE g_vertical_diffusion_v_2
5729
5730  SUBROUTINE g_vertical_diffusion_w_2(tendency,g_tendency,config_flags,mu, &
5731  g_mu,defor33,g_defor33,tke,g_tke,nba_mij,g_nba_mij,n_nba_mij,div, &
5732  g_div,xkmv,g_xkmv,dn,rdz,g_rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
5733  kme,its,ite,jts,jte,kts,kte)
5734
5735  IMPLICIT NONE
5736
5737  REAL :: Tmpv1,g_Tmpv1
5738  TYPE(grid_config_rec_type) :: config_flags
5739  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5740  REAL,DIMENSION(kms:kme) :: dn
5741  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
5742  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor33,g_defor33,tke,g_tke,div, &
5743  g_div,xkmv,g_xkmv,rdz,g_rdz
5744
5745  INTEGER :: n_nba_mij
5746
5747  REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,g_nba_mij
5748  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
5749  INTEGER :: i,j,k,ktf
5750  INTEGER :: i_start,i_end,j_start,j_end
5751  INTEGER :: is_ext,ie_ext,js_ext,je_ext
5752  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,g_titau3
5753
5754  ktf =min(kte,kde-1)
5755
5756  i_start =its
5757
5758  i_end =min(ite,ide-1)
5759
5760  j_start =jts
5761
5762  j_end =min(jte,jde-1)
5763
5764  IF( config_flags%open_xs .or. config_flags%specified .or.   &
5765         config_flags%nested) i_start =max(ids+1,its)
5766
5767  IF( config_flags%open_xe .or. config_flags%specified .or.   &
5768         config_flags%nested) i_end =min(ide-2,ite)
5769
5770  IF( config_flags%open_ys .or. config_flags%specified .or.   &
5771         config_flags%nested) j_start =max(jds+1,jts)
5772
5773  IF( config_flags%open_ye .or. config_flags%specified .or.   &
5774         config_flags%nested) j_end =min(jde-2,jte)
5775
5776  IF( config_flags%periodic_x ) i_start =its
5777
5778  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
5779
5780  is_ext =0
5781
5782  ie_ext =0
5783
5784  js_ext =0
5785
5786  je_ext =0
5787
5788  CALL g_cal_titau_11_22_33(config_flags,titau3,g_titau3,mu,g_mu,tke,g_tke, &
5789  xkmv,g_xkmv,defor33,g_defor33,nba_mij(ims,kms,jms,P_m33),g_nba_mij(ims,kms, &
5790  jms,P_m33),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
5791  kme,its,ite,jts,jte,kts,kte)
5792
5793  DO j =j_start,j_end
5794  DO k =kts+1,ktf
5795  DO i =i_start,i_end
5796
5797  g_Tmpv1 =rdz(i,k,j)*(g_titau3(i,k,j) -g_titau3(i,k-1,j)) +g_rdz(i,k,j) &
5798 *(titau3(i,k,j) -titau3(i,k-1,j))
5799  Tmpv1 =rdz(i,k,j)*(titau3(i,k,j) -titau3(i,k-1,j))
5800
5801  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv1
5802  tendency(i,k,j) =tendency(i,k,j) -Tmpv1
5803
5804  ENDDO
5805  ENDDO
5806  ENDDO
5807
5808  END SUBROUTINE g_vertical_diffusion_w_2
5809
5810  SUBROUTINE g_vertical_diffusion_s(tendency,g_tendency,config_flags,var, &
5811  g_var,mu,g_mu,xkhv,g_xkhv,dn,dnw,rdz,g_rdz,rdzw,g_rdzw,fnm,fnp, &
5812  doing_tke,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5813
5814  IMPLICIT NONE
5815
5816  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
5817  TYPE(grid_config_rec_type) :: config_flags
5818  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5819  LOGICAL :: doing_tke
5820  REAL,DIMENSION(kms:kme) :: fnm
5821  REAL,DIMENSION(kms:kme) :: fnp
5822  REAL,DIMENSION(kms:kme) :: dn
5823  REAL,DIMENSION(kms:kme) :: dnw
5824  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
5825  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhv,g_xkhv
5826  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
5827  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var,g_var,rdz,g_rdz,rdzw,g_rdzw
5828  INTEGER :: i,j,k,ktf
5829  INTEGER :: i_start,i_end,j_start,j_end
5830  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: H3,g_H3,xkxavg,g_xkxavg,rravg,g_rravg
5831  REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tmptendf,g_tmptendf
5832
5833  ktf =min(kte,kde-1)
5834
5835  i_start =its
5836
5837  i_end =min(ite,ide-1)
5838
5839  j_start =jts
5840
5841  j_end =min(jte,jde-1)
5842
5843  IF( config_flags%open_xs .or. config_flags%specified .or.   &
5844         config_flags%nested) i_start =max(ids+1,its)
5845
5846  IF( config_flags%open_xe .or. config_flags%specified .or.   &
5847         config_flags%nested) i_end =min(ide-2,ite)
5848
5849  IF( config_flags%open_ys .or. config_flags%specified .or.   &
5850         config_flags%nested) j_start =max(jds+1,jts)
5851
5852  IF( config_flags%open_ye .or. config_flags%specified .or.   &
5853         config_flags%nested) j_end =min(jde-2,jte)
5854
5855  IF( config_flags%periodic_x ) i_start =its
5856
5857  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
5858
5859  IF(doing_tke) THEN
5860
5861  DO j =j_start,j_end
5862  DO k =kts,ktf
5863  DO i =i_start,i_end
5864
5865  g_tmptendf(i,k,j) =g_tendency(i,k,j)
5866  tmptendf(i,k,j) =tendency(i,k,j)
5867
5868  ENDDO
5869  ENDDO
5870  ENDDO
5871  ENDIF
5872
5873  g_xkxavg =0.0
5874  xkxavg =0.
5875
5876  DO j =j_start,j_end
5877  DO k =kts+1,ktf
5878  DO i =i_start,i_end
5879
5880  g_xkxavg(i,k,j) =fnm(k)*g_xkhv(i,k,j) +fnp(k)*g_xkhv(i,k-1,j)
5881  xkxavg(i,k,j) =fnm(k)*xkhv(i,k,j) +fnp(k)*xkhv(i,k-1,j)
5882
5883  g_Tmpv1 =-xkxavg(i,k,j)*(g_var(i,k,j) -g_var(i,k-1,j)) -g_xkxavg(i,k,j) &
5884 *(var(i,k,j) -var(i,k-1,j))
5885  Tmpv1 =-xkxavg(i,k,j)*(var(i,k,j) -var(i,k-1,j))
5886
5887  g_Tmpv2 =Tmpv1*g_rdz(i,k,j) +g_Tmpv1*rdz(i,k,j)
5888  Tmpv2 =Tmpv1*rdz(i,k,j)
5889
5890  g_H3(i,k,j) =g_Tmpv2
5891  H3(i,k,j) =Tmpv2
5892
5893  ENDDO
5894  ENDDO
5895  ENDDO
5896
5897  DO j =j_start,j_end
5898  DO i =i_start,i_end
5899
5900  g_H3(i,kts,j) =0.0
5901  H3(i,kts,j) =0.
5902
5903  g_H3(i,ktf+1,j) =0.0
5904  H3(i,ktf+1,j) =0.
5905
5906  ENDDO
5907  ENDDO
5908
5909  DO j =j_start,j_end
5910  DO k =kts,ktf
5911  DO i =i_start,i_end
5912
5913  g_Tmpv1 =mu(i,j)*(g_H3(i,k+1,j) -g_H3(i,k,j)) +g_mu(i,j)*(H3(i,k+1,j) -H3(i,k,j))
5914  Tmpv1 =mu(i,j)*(H3(i,k+1,j) -H3(i,k,j))
5915
5916  g_Tmpv2 =Tmpv1*g_rdzw(i,k,j) +g_Tmpv1*rdzw(i,k,j)
5917  Tmpv2 =Tmpv1*rdzw(i,k,j)
5918
5919  g_tendency(i,k,j) =g_tendency(i,k,j) -g_Tmpv2
5920  tendency(i,k,j) =tendency(i,k,j) -Tmpv2
5921
5922  ENDDO
5923  ENDDO
5924  ENDDO
5925
5926  IF(doing_tke) THEN
5927
5928  DO j =j_start,j_end
5929  DO k =kts,ktf
5930  DO i =i_start,i_end
5931
5932  g_tendency(i,k,j) =g_tmptendf(i,k,j) +2.*(g_tendency(i,k,j) -g_tmptendf(i,k,j))
5933  tendency(i,k,j) =tmptendf(i,k,j) +2.*(tendency(i,k,j) -tmptendf(i,k,j))
5934
5935  ENDDO
5936  ENDDO
5937  ENDDO
5938  ENDIF
5939
5940  END SUBROUTINE g_vertical_diffusion_s
5941
5942  SUBROUTINE g_cal_titau_11_22_33(config_flags,titau,g_titau,mu,g_mu,tke, &
5943  g_tke,xkx,g_xkx,defor,g_defor,mtau,g_mtau,is_ext,ie_ext,js_ext,je_ext, &
5944  ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
5945
5946  IMPLICIT NONE
5947
5948  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
5949  TYPE(grid_config_rec_type) :: config_flags
5950  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5951  INTEGER :: is_ext,ie_ext,js_ext,je_ext
5952  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
5953  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx,tke,g_tke
5954
5955  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
5956  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
5957  INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
5958
5959  ktf =min(kte,kde-1)
5960
5961  i_start =its
5962
5963  i_end =ite
5964
5965  j_start =jts
5966
5967  j_end =jte
5968
5969  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
5970          config_flags%nested) i_start =max(ids+1,its)
5971
5972  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
5973          config_flags%nested) i_end =min(ide-1,ite)
5974
5975  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
5976          config_flags%nested) j_start =max(jds+1,jts)
5977
5978  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
5979          config_flags%nested) j_end =min(jde-1,jte)
5980
5981  IF( config_flags%periodic_x ) i_start =its
5982
5983  IF( config_flags%periodic_x ) i_end =ite
5984
5985  i_start =i_start-is_ext
5986
5987  i_end =i_end+ie_ext
5988
5989  j_start =j_start-js_ext
5990
5991  j_end =j_end+je_ext
5992
5993  IF( config_flags%sfs_opt .GT. 0 ) THEN
5994
5995  DO j =j_start,j_end
5996  DO k =kts,ktf
5997  DO i =i_start,i_end
5998
5999  g_Tmpv1 =mu(i,j)*g_mtau(i,k,j) +g_mu(i,j)*mtau(i,k,j)
6000  Tmpv1 =mu(i,j)*mtau(i,k,j)
6001
6002  g_titau(i,k,j) =g_Tmpv1
6003  titau(i,k,j) =Tmpv1
6004
6005  ENDDO
6006  ENDDO
6007  ENDDO
6008
6009  ELSE
6010
6011  IF( config_flags%m_opt .EQ. 1 ) THEN
6012
6013  DO j =j_start,j_end
6014  DO k =kts,ktf
6015  DO i =i_start,i_end
6016
6017  g_Tmpv1 =-mu(i,j)*g_xkx(i,k,j) -g_mu(i,j)*xkx(i,k,j)
6018  Tmpv1 =-mu(i,j)*xkx(i,k,j)
6019
6020  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6021  Tmpv2 =Tmpv1*defor(i,k,j)
6022
6023  g_titau(i,k,j) =g_Tmpv2
6024  titau(i,k,j) =Tmpv2
6025
6026  g_Tmpv1 =-xkx(i,k,j)*g_defor(i,k,j) -g_xkx(i,k,j)*defor(i,k,j)
6027  Tmpv1 =-xkx(i,k,j)*defor(i,k,j)
6028
6029  g_mtau(i,k,j) =g_Tmpv1
6030  mtau(i,k,j) =Tmpv1
6031
6032  ENDDO
6033  ENDDO
6034  ENDDO
6035
6036  ELSE
6037
6038  DO j =j_start,j_end
6039  DO k =kts,ktf
6040  DO i =i_start,i_end
6041
6042  g_Tmpv1 =-mu(i,j)*g_xkx(i,k,j) -g_mu(i,j)*xkx(i,k,j)
6043  Tmpv1 =-mu(i,j)*xkx(i,k,j)
6044
6045  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6046  Tmpv2 =Tmpv1*defor(i,k,j)
6047
6048  g_titau(i,k,j) =g_Tmpv2
6049  titau(i,k,j) =Tmpv2
6050
6051  ENDDO
6052  ENDDO
6053  ENDDO
6054  ENDIF
6055  ENDIF
6056
6057  END SUBROUTINE g_cal_titau_11_22_33
6058
6059  SUBROUTINE g_cal_titau_12_21(config_flags,titau,g_titau,mu,g_mu,xkx, &
6060  g_xkx,defor,g_defor,mtau,g_mtau,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde, &
6061  kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6062
6063  IMPLICIT NONE
6064
6065  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
6066  TYPE(grid_config_rec_type) :: config_flags
6067  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6068  INTEGER :: is_ext,ie_ext,js_ext,je_ext
6069  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
6070  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx
6071
6072  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
6073  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
6074  INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
6075  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,g_xkxavg
6076  REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,g_muavg
6077
6078  ktf =min(kte,kde-1)
6079
6080  i_start =its
6081
6082  i_end =ite
6083
6084  j_start =jts
6085
6086  j_end =jte
6087
6088  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
6089          config_flags%nested ) i_start =max(ids+1,its)
6090
6091  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
6092          config_flags%nested ) i_end =min(ide-1,ite)
6093
6094  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
6095          config_flags%nested ) j_start =max(jds+1,jts)
6096
6097  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
6098          config_flags%nested ) j_end =min(jde-1,jte)
6099
6100  IF( config_flags%periodic_x ) i_start =its
6101
6102  IF( config_flags%periodic_x ) i_end =ite
6103
6104  i_start =i_start-is_ext
6105
6106  i_end =i_end+ie_ext
6107
6108  j_start =j_start-js_ext
6109
6110  j_end =j_end+je_ext
6111
6112  DO j =j_start,j_end
6113  DO k =kts,ktf
6114  DO i =i_start,i_end
6115
6116  g_xkxavg(i,k,j) =0.25*(g_xkx(i-1,k,j) +g_xkx(i,k,j) +g_xkx(i-1,k,j-1) &
6117  +g_xkx(i,k,j-1))
6118  xkxavg(i,k,j) =0.25*(xkx(i-1,k,j) +xkx(i,k,j) +xkx(i-1,k,j-1) +xkx(i,k,j-1))
6119
6120  ENDDO
6121  ENDDO
6122  ENDDO
6123
6124  DO j =j_start,j_end
6125  DO i =i_start,i_end
6126
6127  g_muavg(i,j) =0.25*(g_mu(i-1,j) +g_mu(i,j) +g_mu(i-1,j-1) +g_mu(i,j-1))
6128  muavg(i,j) =0.25*(mu(i-1,j) +mu(i,j) +mu(i-1,j-1) +mu(i,j-1))
6129
6130  ENDDO
6131  ENDDO
6132
6133  IF( config_flags%sfs_opt .GT. 0 ) THEN
6134
6135  DO j =j_start,j_end
6136  DO k =kts,ktf
6137  DO i =i_start,i_end
6138
6139  g_Tmpv1 =muavg(i,j)*g_mtau(i,k,j) +g_muavg(i,j)*mtau(i,k,j)
6140  Tmpv1 =muavg(i,j)*mtau(i,k,j)
6141
6142  g_titau(i,k,j) =g_Tmpv1
6143  titau(i,k,j) =Tmpv1
6144
6145  ENDDO
6146  ENDDO
6147  ENDDO
6148
6149  ELSE
6150
6151  IF( config_flags%m_opt .EQ. 1 ) THEN
6152
6153  DO j =j_start,j_end
6154  DO k =kts,ktf
6155  DO i =i_start,i_end
6156
6157  g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
6158  Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
6159
6160  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6161  Tmpv2 =Tmpv1*defor(i,k,j)
6162
6163  g_titau(i,k,j) =g_Tmpv2
6164  titau(i,k,j) =Tmpv2
6165
6166  g_Tmpv1 =-xkxavg(i,k,j)*g_defor(i,k,j) -g_xkxavg(i,k,j)*defor(i,k,j)
6167  Tmpv1 =-xkxavg(i,k,j)*defor(i,k,j)
6168
6169  g_mtau(i,k,j) =g_Tmpv1
6170  mtau(i,k,j) =Tmpv1
6171
6172  ENDDO
6173  ENDDO
6174  ENDDO
6175
6176  ELSE
6177
6178  DO j =j_start,j_end
6179  DO k =kts,ktf
6180  DO i =i_start,i_end
6181
6182  g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
6183  Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
6184
6185  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6186  Tmpv2 =Tmpv1*defor(i,k,j)
6187
6188  g_titau(i,k,j) =g_Tmpv2
6189  titau(i,k,j) =Tmpv2
6190
6191  ENDDO
6192  ENDDO
6193  ENDDO
6194  ENDIF
6195  ENDIF
6196
6197  END SUBROUTINE g_cal_titau_12_21
6198
6199  SUBROUTINE g_cal_titau_13_31(config_flags,titau,g_titau,defor,g_defor,mtau, &
6200  g_mtau,mu,g_mu,xkx,g_xkx,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds, &
6201  jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6202
6203  IMPLICIT NONE
6204
6205  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
6206  TYPE(grid_config_rec_type) :: config_flags
6207  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6208  INTEGER :: is_ext,ie_ext,js_ext,je_ext
6209  REAL,DIMENSION(kms:kme) :: fnm,fnp
6210  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
6211  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx
6212
6213  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
6214  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
6215  INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
6216  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,g_xkxavg
6217  REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,g_muavg
6218
6219  ktf =min(kte,kde-1)
6220
6221  i_start =its
6222
6223  i_end =ite
6224
6225  j_start =jts
6226
6227  j_end =min(jte,jde-1)
6228
6229  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
6230          config_flags%nested) i_start =max(ids+1,its)
6231
6232  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
6233          config_flags%nested) i_end =min(ide-1,ite)
6234
6235  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
6236          config_flags%nested) j_start =max(jds+1,jts)
6237
6238  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
6239          config_flags%nested) j_end =min(jde-2,jte)
6240
6241  IF( config_flags%periodic_x ) i_start =its
6242
6243  IF( config_flags%periodic_x ) i_end =ite
6244
6245  i_start =i_start-is_ext
6246
6247  i_end =i_end+ie_ext
6248
6249  j_start =j_start-js_ext
6250
6251  j_end =j_end+je_ext
6252
6253  DO j =j_start,j_end
6254  DO k =kts+1,ktf
6255  DO i =i_start,i_end
6256
6257  g_xkxavg(i,k,j) =0.5*(fnm(k)*(g_xkx(i,k,j) +g_xkx(i-1,k,j)) +fnp(k) &
6258 *(g_xkx(i,k-1,j) +g_xkx(i-1,k-1,j)))
6259  xkxavg(i,k,j) =0.5*(fnm(k)*(xkx(i,k,j) +xkx(i-1,k,j)) +fnp(k)*(xkx(i,k-1,j) &
6260  +xkx(i-1,k-1,j)))
6261
6262  ENDDO
6263  ENDDO
6264  ENDDO
6265
6266  DO j =j_start,j_end
6267  DO i =i_start,i_end
6268
6269  g_muavg(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
6270  muavg(i,j) =0.5*(mu(i,j) +mu(i-1,j))
6271
6272  ENDDO
6273  ENDDO
6274
6275  IF( config_flags%sfs_opt .GT. 0 ) THEN
6276
6277  DO j =j_start,j_end
6278  DO k =kts+1,ktf
6279  DO i =i_start,i_end
6280
6281  g_Tmpv1 =muavg(i,j)*g_mtau(i,k,j) +g_muavg(i,j)*mtau(i,k,j)
6282  Tmpv1 =muavg(i,j)*mtau(i,k,j)
6283
6284  g_titau(i,k,j) =g_Tmpv1
6285  titau(i,k,j) =Tmpv1
6286
6287  ENDDO
6288  ENDDO
6289  ENDDO
6290
6291  ELSE
6292
6293  IF( config_flags%m_opt .EQ. 1 ) THEN
6294
6295  DO j =j_start,j_end
6296  DO k =kts+1,ktf
6297  DO i =i_start,i_end
6298
6299  g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
6300  Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
6301
6302  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6303  Tmpv2 =Tmpv1*defor(i,k,j)
6304
6305  g_titau(i,k,j) =g_Tmpv2
6306  titau(i,k,j) =Tmpv2
6307
6308  g_Tmpv1 =-xkxavg(i,k,j)*g_defor(i,k,j) -g_xkxavg(i,k,j)*defor(i,k,j)
6309  Tmpv1 =-xkxavg(i,k,j)*defor(i,k,j)
6310
6311  g_mtau(i,k,j) =g_Tmpv1
6312  mtau(i,k,j) =Tmpv1
6313
6314  ENDDO
6315  ENDDO
6316  ENDDO
6317
6318  ELSE
6319
6320  DO j =j_start,j_end
6321  DO k =kts+1,ktf
6322  DO i =i_start,i_end
6323
6324  g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
6325  Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
6326
6327  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6328  Tmpv2 =Tmpv1*defor(i,k,j)
6329
6330  g_titau(i,k,j) =g_Tmpv2
6331  titau(i,k,j) =Tmpv2
6332
6333  ENDDO
6334  ENDDO
6335  ENDDO
6336  ENDIF
6337  ENDIF
6338
6339  DO j =j_start,j_end
6340  DO i =i_start,i_end
6341
6342  g_titau(i,kts,j) =0.0
6343  titau(i,kts,j) =0.0
6344
6345  g_titau(i,ktf+1,j) =0.0
6346  titau(i,ktf+1,j) =0.0
6347
6348  ENDDO
6349  ENDDO
6350
6351  END SUBROUTINE g_cal_titau_13_31
6352
6353  SUBROUTINE g_cal_titau_23_32(config_flags,titau,g_titau,defor,g_defor,mtau, &
6354  g_mtau,mu,g_mu,xkx,g_xkx,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds, &
6355  jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6356
6357  IMPLICIT NONE
6358
6359  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2
6360  TYPE(grid_config_rec_type) :: config_flags
6361  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6362  INTEGER :: is_ext,ie_ext,js_ext,je_ext
6363  REAL,DIMENSION(kms:kme) :: fnm,fnp
6364  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,g_titau
6365  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,g_defor,xkx,g_xkx
6366
6367  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,g_mtau
6368  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
6369  INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
6370  REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,g_xkxavg
6371  REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,g_muavg
6372
6373  ktf =min(kte,kde-1)
6374
6375  i_start =its
6376
6377  i_end =min(ite,ide-1)
6378
6379  j_start =jts
6380
6381  j_end =jte
6382
6383  IF( config_flags%open_xs .OR. config_flags%specified .OR.   &
6384          config_flags%nested) i_start =max(ids+1,its)
6385
6386  IF( config_flags%open_xe .OR. config_flags%specified .OR.   &
6387          config_flags%nested) i_end =min(ide-2,ite)
6388
6389  IF( config_flags%open_ys .OR. config_flags%specified .OR.   &
6390          config_flags%nested) j_start =max(jds+1,jts)
6391
6392  IF( config_flags%open_ye .OR. config_flags%specified .OR.   &
6393          config_flags%nested) j_end =min(jde-1,jte)
6394
6395  IF( config_flags%periodic_x ) i_start =its
6396
6397  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
6398
6399  i_start =i_start-is_ext
6400
6401  i_end =i_end+ie_ext
6402
6403  j_start =j_start-js_ext
6404
6405  j_end =j_end+je_ext
6406
6407  DO j =j_start,j_end
6408  DO k =kts+1,ktf
6409  DO i =i_start,i_end
6410
6411  g_xkxavg(i,k,j) =0.5*(fnm(k)*(g_xkx(i,k,j) +g_xkx(i,k,j-1)) +fnp(k) &
6412 *(g_xkx(i,k-1,j) +g_xkx(i,k-1,j-1)))
6413  xkxavg(i,k,j) =0.5*(fnm(k)*(xkx(i,k,j) +xkx(i,k,j-1)) +fnp(k)*(xkx(i,k-1,j) &
6414  +xkx(i,k-1,j-1)))
6415
6416  ENDDO
6417  ENDDO
6418  ENDDO
6419
6420  DO j =j_start,j_end
6421  DO i =i_start,i_end
6422
6423  g_muavg(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
6424  muavg(i,j) =0.5*(mu(i,j) +mu(i,j-1))
6425
6426  ENDDO
6427  ENDDO
6428
6429  IF( config_flags%sfs_opt .EQ. 1 ) THEN
6430
6431  DO j =j_start,j_end
6432  DO k =kts+1,ktf
6433  DO i =i_start,i_end
6434
6435  g_Tmpv1 =muavg(i,j)*g_mtau(i,k,j) +g_muavg(i,j)*mtau(i,k,j)
6436  Tmpv1 =muavg(i,j)*mtau(i,k,j)
6437
6438  g_titau(i,k,j) =g_Tmpv1
6439  titau(i,k,j) =Tmpv1
6440
6441  ENDDO
6442  ENDDO
6443  ENDDO
6444
6445  ELSE
6446
6447  IF( config_flags%m_opt .EQ. 1 ) THEN
6448
6449  DO j =j_start,j_end
6450  DO k =kts+1,ktf
6451  DO i =i_start,i_end
6452
6453  g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
6454  Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
6455
6456  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6457  Tmpv2 =Tmpv1*defor(i,k,j)
6458
6459  g_titau(i,k,j) =g_Tmpv2
6460  titau(i,k,j) =Tmpv2
6461
6462  g_Tmpv1 =-xkxavg(i,k,j)*g_defor(i,k,j) -g_xkxavg(i,k,j)*defor(i,k,j)
6463  Tmpv1 =-xkxavg(i,k,j)*defor(i,k,j)
6464
6465  g_mtau(i,k,j) =g_Tmpv1
6466  mtau(i,k,j) =Tmpv1
6467
6468  ENDDO
6469  ENDDO
6470  ENDDO
6471
6472  ELSE
6473
6474  DO j =j_start,j_end
6475  DO k =kts+1,ktf
6476  DO i =i_start,i_end
6477
6478  g_Tmpv1 =-muavg(i,j)*g_xkxavg(i,k,j) -g_muavg(i,j)*xkxavg(i,k,j)
6479  Tmpv1 =-muavg(i,j)*xkxavg(i,k,j)
6480
6481  g_Tmpv2 =Tmpv1*g_defor(i,k,j) +g_Tmpv1*defor(i,k,j)
6482  Tmpv2 =Tmpv1*defor(i,k,j)
6483
6484  g_titau(i,k,j) =g_Tmpv2
6485  titau(i,k,j) =Tmpv2
6486
6487  ENDDO
6488  ENDDO
6489  ENDDO
6490  ENDIF
6491  ENDIF
6492
6493  DO j =j_start,j_end
6494  DO i =i_start,i_end
6495
6496  g_titau(i,kts,j) =0.0
6497  titau(i,kts,j) =0.0
6498
6499  g_titau(i,ktf+1,j) =0.0
6500  titau(i,ktf+1,j) =0.0
6501
6502  ENDDO
6503  ENDDO
6504
6505  END SUBROUTINE g_cal_titau_23_32
6506
6507  END MODULE g_module_diffusion_em
6508
6509  REAL Function g_Sqrt(g_x,x)
6510
6511  REAL g_x,x
6512
6513  IF(x.GT.0.0) THEN
6514    g_Sqrt =0.5*g_x/sqrt(x)
6515  ELSE
6516 ! Revised by Ning Pan, 2010-08-10
6517 !   Print*,''
6518 !   Print*,'g_Sqrt is incorrectly evaluated by 0!'
6519 !   Print*,'Aborted from compute_diff_metrics'
6520 !   g_Sqrt =0.0
6521    g_Sqrt =0.5*g_x/(sqrt(x)+1.e-6)
6522  END IF
6523
6524  RETURN
6525  END
6526