wrftladj/module_big_step_utilities_em_ad.F

   1 ! ======================================================================================
   2 ! This file was generated by the version 4.3.6 of ADG on 07/13/2010. The Adjoint Code
   3 ! Generator (ADG) was developed and sponsored by LASG of IAP (1999-2010)
   4 ! The Copyright of the ADG system was declared by Walls at LASG, 1999-2010
   5 ! ======================================================================================
   6
   7 MODULE a_module_big_step_utilities_em
   8
   9    USE module_model_constants
  10    USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, ntiedtkescheme, &
  11    kfetascheme, mskfscheme, g3scheme, p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD
  12    USE module_configure, ONLY : grid_config_rec_type
  13    USE module_wrf_error
  14 #if (RWORDSIZE == 4)
  15 #   define VPOWX vspowx
  16 #   define VPOW  vspow
  17 #else
  18 #   define VPOWX vpowx
  19 #   define VPOW  vpow
  20 #endif
  21
  22 CONTAINS
  23
  24 !        Generated by TAPENADE     (INRIA, Tropics team)
  25 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
  26 !
  27 !  Differentiation of calc_mu_uv in reverse (adjoint) mode:
  28 !   gradient     of useful results: muu muv mu
  29 !   with respect to varying inputs: muu muv mu
  30 !   RW status of diff variables: muu:in-out muv:in-out mu:incr
  31 SUBROUTINE A_CALC_MU_UV(config_flags, mub0, muub, &
  32 &  muvb, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its&
  33 &  , ite, jts, jte, kts, kte)
  34   IMPLICIT NONE
  35 ! Input data
  36   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
  37   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  38 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  39   REAL, DIMENSION(ims:ime, jms:jme) :: muub, muvb
  40   REAL, DIMENSION(ims:ime, jms:jme) :: mub0
  41 !  local stuff
  42   INTEGER :: i, j, itf, jtf, im, jm
  43   INTEGER :: ad_to
  44   INTEGER :: ad_to0
  45   INTEGER :: ad_to1
  46   INTEGER :: ad_to2
  47   INTEGER :: ad_to3
  48   INTEGER :: ad_to4
  49   INTEGER :: ad_to5
  50   INTEGER :: ad_to6
  51   INTEGER :: ad_to7
  52   INTEGER :: ad_to8
  53   INTEGER :: ad_to9
  54   INTEGER :: ad_to10
  55   INTEGER :: branch
  56 !<DESCRIPTION>
  57 !
  58 !  calc_mu_uv calculates the full column dry-air mass at the staggered
  59 !  horizontal velocity points (u,v) and places the results in muu and muv.
  60 !  This routine uses the reference state (mub) and perturbation state (mu)
  61 !
  62 !</DESCRIPTION>
  63   itf = ite
  64   IF (jte .GT. jde - 1) THEN
  65     jtf = jde - 1
  66   ELSE
  67     jtf = jte
  68   END IF
  69   IF (its .NE. ids .AND. ite .NE. ide) THEN
  70     DO j=jts,jtf
  71       i = itf + 1
  72       CALL PUSHINTEGER4(i - 1)
  73     END DO
  74     CALL PUSHINTEGER4(j - 1)
  75     CALL PUSHCONTROL3B(4)
  76   ELSE IF (its .EQ. ids .AND. ite .NE. ide) THEN
  77     DO j=jts,jtf
  78       i = itf + 1
  79       CALL PUSHINTEGER4(i - 1)
  80     END DO
  81     CALL PUSHINTEGER4(j - 1)
  82     i = its
  83     im = its
  84     IF (config_flags%periodic_x) im = its - 1
  85     j = jtf + 1
  86     CALL PUSHINTEGER4(j - 1)
  87     CALL PUSHCONTROL3B(3)
  88   ELSE IF (its .NE. ids .AND. ite .EQ. ide) THEN
  89     DO j=jts,jtf
  90       i = itf
  91       CALL PUSHINTEGER4(i - 1)
  92     END DO
  93     CALL PUSHINTEGER4(j - 1)
  94     i = ite
  95     im = ite - 1
  96     IF (config_flags%periodic_x) im = ite
  97     j = jtf + 1
  98     CALL PUSHINTEGER4(j - 1)
  99     CALL PUSHCONTROL3B(2)
 100   ELSE IF (its .EQ. ids .AND. ite .EQ. ide) THEN
 101     DO j=jts,jtf
 102       i = itf
 103       CALL PUSHINTEGER4(i - 1)
 104     END DO
 105     CALL PUSHINTEGER4(j - 1)
 106     im = its
 107     IF (config_flags%periodic_x) im = its - 1
 108     j = jtf + 1
 109     CALL PUSHINTEGER4(j - 1)
 110     i = ite
 111     CALL PUSHINTEGER4(im)
 112     im = ite - 1
 113     IF (config_flags%periodic_x) im = ite
 114     j = jtf + 1
 115     CALL PUSHINTEGER4(j - 1)
 116     CALL PUSHCONTROL3B(1)
 117   ELSE
 118     CALL PUSHCONTROL3B(0)
 119   END IF
 120   IF (ite .GT. ide - 1) THEN
 121     itf = ide - 1
 122   ELSE
 123     itf = ite
 124   END IF
 125   jtf = jte
 126   IF (jts .NE. jds .AND. jte .NE. jde) THEN
 127     DO j=jts,jtf
 128       CALL PUSHINTEGER4(i)
 129     END DO
 130     DO j=jtf,jts,-1
 131       DO i=itf,its,-1
 132         mub0(i, j) = mub0(i, j) + 0.5*muvb(i, j)
 133         mub0(i, j-1) = mub0(i, j-1) + 0.5*muvb(i, j)
 134         muvb(i, j) = 0.0
 135       END DO
 136       CALL POPINTEGER4(i)
 137     END DO
 138   ELSE IF (jts .EQ. jds .AND. jte .NE. jde) THEN
 139     DO j=jts+1,jtf
 140       CALL PUSHINTEGER4(i)
 141     END DO
 142     j = jts
 143     jm = jts
 144     IF (config_flags%periodic_y) jm = jts - 1
 145     CALL PUSHINTEGER4(i)
 146     DO i=itf,its,-1
 147       mub0(i, j) = mub0(i, j) + 0.5*muvb(i, j)
 148       mub0(i, jm) = mub0(i, jm) + 0.5*muvb(i, j)
 149       muvb(i, j) = 0.0
 150     END DO
 151     CALL POPINTEGER4(i)
 152     DO j=jtf,jts+1,-1
 153       DO i=itf,its,-1
 154         mub0(i, j) = mub0(i, j) + 0.5*muvb(i, j)
 155         mub0(i, j-1) = mub0(i, j-1) + 0.5*muvb(i, j)
 156         muvb(i, j) = 0.0
 157       END DO
 158       CALL POPINTEGER4(i)
 159     END DO
 160   ELSE IF (jts .NE. jds .AND. jte .EQ. jde) THEN
 161     DO j=jts,jtf-1
 162       CALL PUSHINTEGER4(i)
 163     END DO
 164     j = jte
 165     jm = jte - 1
 166     IF (config_flags%periodic_y) jm = jte
 167     CALL PUSHINTEGER4(i)
 168     DO i=itf,its,-1
 169       mub0(i, j-1) = mub0(i, j-1) + 0.5*muvb(i, j)
 170       mub0(i, jm) = mub0(i, jm) + 0.5*muvb(i, j)
 171       muvb(i, j) = 0.0
 172     END DO
 173     CALL POPINTEGER4(i)
 174     DO j=jtf-1,jts,-1
 175       DO i=itf,its,-1
 176         mub0(i, j) = mub0(i, j) + 0.5*muvb(i, j)
 177         mub0(i, j-1) = mub0(i, j-1) + 0.5*muvb(i, j)
 178         muvb(i, j) = 0.0
 179       END DO
 180       CALL POPINTEGER4(i)
 181     END DO
 182   ELSE IF (jts .EQ. jds .AND. jte .EQ. jde) THEN
 183     DO j=jts+1,jtf-1
 184       CALL PUSHINTEGER4(i)
 185     END DO
 186     jm = jts
 187     IF (config_flags%periodic_y) jm = jts - 1
 188     CALL PUSHINTEGER4(i)
 189     j = jte
 190     CALL PUSHINTEGER4(jm)
 191     jm = jte - 1
 192     IF (config_flags%periodic_y) jm = jte
 193     DO i=itf,its,-1
 194       mub0(i, j-1) = mub0(i, j-1) + 0.5*muvb(i, j)
 195       mub0(i, jm) = mub0(i, jm) + 0.5*muvb(i, j)
 196       muvb(i, j) = 0.0
 197     END DO
 198     CALL POPINTEGER4(jm)
 199     j = jts
 200     DO i=itf,its,-1
 201       mub0(i, j) = mub0(i, j) + 0.5*muvb(i, j)
 202       mub0(i, jm) = mub0(i, jm) + 0.5*muvb(i, j)
 203       muvb(i, j) = 0.0
 204     END DO
 205     CALL POPINTEGER4(i)
 206     DO j=jtf-1,jts+1,-1
 207       DO i=itf,its,-1
 208         mub0(i, j) = mub0(i, j) + 0.5*muvb(i, j)
 209         mub0(i, j-1) = mub0(i, j-1) + 0.5*muvb(i, j)
 210         muvb(i, j) = 0.0
 211       END DO
 212       CALL POPINTEGER4(i)
 213     END DO
 214   END IF
 215   CALL POPCONTROL3B(branch)
 216   IF (branch .LT. 2) THEN
 217     IF (branch .NE. 0) THEN
 218       CALL POPINTEGER4(ad_to8)
 219       DO j=ad_to8,jts,-1
 220         mub0(i-1, j) = mub0(i-1, j) + 0.5*muub(i, j)
 221         mub0(im, j) = mub0(im, j) + 0.5*muub(i, j)
 222         muub(i, j) = 0.0
 223       END DO
 224       CALL POPINTEGER4(im)
 225       i = its
 226       CALL POPINTEGER4(ad_to7)
 227       DO j=ad_to7,jts,-1
 228         mub0(i, j) = mub0(i, j) + 0.5*muub(i, j)
 229         mub0(im, j) = mub0(im, j) + 0.5*muub(i, j)
 230         muub(i, j) = 0.0
 231       END DO
 232       CALL POPINTEGER4(ad_to6)
 233       DO j=ad_to6,jts,-1
 234         CALL POPINTEGER4(ad_to5)
 235         DO i=ad_to5,its+1,-1
 236           mub0(i, j) = mub0(i, j) + 0.5*muub(i, j)
 237           mub0(i-1, j) = mub0(i-1, j) + 0.5*muub(i, j)
 238           muub(i, j) = 0.0
 239         END DO
 240       END DO
 241     END IF
 242   ELSE IF (branch .EQ. 2) THEN
 243     CALL POPINTEGER4(ad_to4)
 244     DO j=ad_to4,jts,-1
 245       mub0(i-1, j) = mub0(i-1, j) + 0.5*muub(i, j)
 246       mub0(im, j) = mub0(im, j) + 0.5*muub(i, j)
 247       muub(i, j) = 0.0
 248     END DO
 249     CALL POPINTEGER4(ad_to3)
 250     DO j=ad_to3,jts,-1
 251       CALL POPINTEGER4(ad_to2)
 252       DO i=ad_to2,its,-1
 253         mub0(i, j) = mub0(i, j) + 0.5*muub(i, j)
 254         mub0(i-1, j) = mub0(i-1, j) + 0.5*muub(i, j)
 255         muub(i, j) = 0.0
 256       END DO
 257     END DO
 258   ELSE IF (branch .EQ. 3) THEN
 259     CALL POPINTEGER4(ad_to1)
 260     DO j=ad_to1,jts,-1
 261       mub0(i, j) = mub0(i, j) + 0.5*muub(i, j)
 262       mub0(im, j) = mub0(im, j) + 0.5*muub(i, j)
 263       muub(i, j) = 0.0
 264     END DO
 265     CALL POPINTEGER4(ad_to0)
 266     DO j=ad_to0,jts,-1
 267       CALL POPINTEGER4(ad_to)
 268       DO i=ad_to,its+1,-1
 269         mub0(i, j) = mub0(i, j) + 0.5*muub(i, j)
 270         mub0(i-1, j) = mub0(i-1, j) + 0.5*muub(i, j)
 271         muub(i, j) = 0.0
 272       END DO
 273     END DO
 274   ELSE
 275     CALL POPINTEGER4(ad_to10)
 276     DO j=ad_to10,jts,-1
 277       CALL POPINTEGER4(ad_to9)
 278       DO i=ad_to9,its,-1
 279         mub0(i, j) = mub0(i, j) + 0.5*muub(i, j)
 280         mub0(i-1, j) = mub0(i-1, j) + 0.5*muub(i, j)
 281         muub(i, j) = 0.0
 282       END DO
 283     END DO
 284   END IF
 285 END SUBROUTINE A_CALC_MU_UV
 286
 287    SUBROUTINE a_calc_mu_uv_1(config_flags,mu,a_mu,muu,a_muu,muv,a_muv,ids,ide, &
 288    jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
 289
 290 !PART I: DECLARATION OF VARIABLES
 291
 292    IMPLICIT NONE
 293
 294    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
 295    TYPE(grid_config_rec_type) :: config_flags
 296    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 297    REAL,DIMENSION(ims:ime,jms:jme) :: muu,a_muu,muv,a_muv
 298    REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
 299    INTEGER :: i,j,itf,jtf,im,jm
 300
 301    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002
 302
 303 !PART II: CALCULATIONS OF B. S. TRAJECTORY
 304
 305 !      IF      ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
 306
 307 !         if(config_flags%periodic_x) im = its-1
 308
 309 !         if(config_flags%periodic_x) im = ite
 310
 311 !         if(config_flags%periodic_x) im = its-1
 312
 313 !         if(config_flags%periodic_x) im = ite
 314
 315 !      IF      ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 316
 317 !         if(config_flags%periodic_y) jm = jts-1
 318
 319 !         if(config_flags%periodic_y) jm = jte
 320
 321 !         if(config_flags%periodic_y) jm = jts-1
 322
 323 !         if(config_flags%periodic_y) jm = jte
 324
 325 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
 326
 327 !LPB[3]
 328
 329 !  IF( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 330 !  DO j =jts, jtf
 331 !  DO i =its, itf
 332 !  Tmpv001 =mu(i,j) +mu(i,j-1)
 333 !  Tmpv002 =0.5*Tmpv001
 334 !  muv(i,j) =Tmpv002
 335
 336 !  ENDDO
 337 !  ENDDO
 338 !  ELSE IF( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN
 339 !  DO j =jts+1, jtf
 340 !  DO i =its, itf
 341 !  Tmpv001 =mu(i,j) +mu(i,j-1)
 342 !  Tmpv002 =0.5*Tmpv001
 343 !  muv(i,j) =Tmpv002
 344
 345 !  ENDDO
 346 !  ENDDO
 347 !  j =jts
 348 !  jm =jts
 349 !  IF(config_flags%periodic_y) THEN
 350 !  jm =jts-1
 351 !  END IF
 352 !  DO i =its, itf
 353 !  Tmpv001 =mu(i,j) +mu(i,jm)
 354 !  Tmpv002 =0.5*Tmpv001
 355 !  muv(i,j) =Tmpv002
 356
 357 !  ENDDO
 358
 359 !  ELSE IF( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN
 360 !  DO j =jts, jtf-1
 361 !  DO i =its, itf
 362 !  Tmpv001 =mu(i,j) +mu(i,j-1)
 363 !  Tmpv002 =0.5*Tmpv001
 364 !  muv(i,j) =Tmpv002
 365
 366 !  ENDDO
 367 !  ENDDO
 368 !  j =jte
 369 !  jm =jte-1
 370 !  IF(config_flags%periodic_y) THEN
 371 !  jm =jte
 372 !  END IF
 373 !  DO i =its, itf
 374 !  Tmpv001 =mu(i,j-1) +mu(i,jm)
 375 !  Tmpv002 =0.5*Tmpv001
 376 !  muv(i,j) =Tmpv002
 377
 378 !  ENDDO
 379
 380 !  ELSE IF( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN
 381 !  DO j =jts+1, jtf-1
 382 !  DO i =its, itf
 383 !  Tmpv001 =mu(i,j) +mu(i,j-1)
 384 !  Tmpv002 =0.5*Tmpv001
 385 !  muv(i,j) =Tmpv002
 386
 387 !  ENDDO
 388 !  ENDDO
 389 !  j =jts
 390 !  jm =jts
 391 !  IF(config_flags%periodic_y) THEN
 392 !  jm =jts-1
 393 !  END IF
 394 !  DO i =its, itf
 395 !  Tmpv001 =mu(i,j) +mu(i,jm)
 396 !  Tmpv002 =0.5*Tmpv001
 397 !  muv(i,j) =Tmpv002
 398
 399 !  ENDDO
 400
 401 !  j =jte
 402 !  jm =jte-1
 403 !  IF(config_flags%periodic_y) THEN
 404 !  jm =jte
 405 !  END IF
 406 !  DO i =its, itf
 407 !  Tmpv001 =mu(i,j-1) +mu(i,jm)
 408 !  Tmpv002 =0.5*Tmpv001
 409 !  muv(i,j) =Tmpv002
 410
 411 !  ENDDO
 412
 413 !  END IF
 414
 415 !  Added by Ning Pan, 2010-07-17
 416    itf =min(ite,ide-1)
 417    jtf =jte
 418
 419    IF( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 420
 421    DO j =jtf, jts, -1
 422    DO i =itf, its, -1
 423    a_Tmpv2 =a_muv(i,j)
 424    a_muv(i,j) =0.0
 425    a_Tmpv1 =0.5*a_Tmpv2
 426    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 427    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
 428    ENDDO
 429    ENDDO
 430
 431    ELSE IF( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN
 432
 433 !  Added by Ning Pan, 2010-07-17
 434    j =jts
 435    jm =jts
 436    IF(config_flags%periodic_y) jm =jts-1
 437
 438    DO i =itf, its, -1
 439    a_Tmpv2 =a_muv(i,j)
 440    a_muv(i,j) =0.0
 441    a_Tmpv1 =0.5*a_Tmpv2
 442    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 443    a_mu(i,jm) =a_mu(i,jm) +a_Tmpv1
 444    ENDDO
 445
 446 !  Remarked by Ning Pan, 2010-07-17
 447 !   IF(config_flags%periodic_y) THEN
 448
 449 !   END IF
 450
 451    DO j =jtf, jts+1, -1
 452    DO i =itf, its, -1
 453    a_Tmpv2 =a_muv(i,j)
 454    a_muv(i,j) =0.0
 455    a_Tmpv1 =0.5*a_Tmpv2
 456    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 457    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
 458    ENDDO
 459    ENDDO
 460
 461    ELSE IF( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN
 462
 463 !  Added by Ning Pan, 2010-07-17
 464    j =jte
 465    jm =jte-1
 466    IF(config_flags%periodic_y) jm =jte
 467
 468    DO i =itf, its, -1
 469    a_Tmpv2 =a_muv(i,j)
 470    a_muv(i,j) =0.0
 471    a_Tmpv1 =0.5*a_Tmpv2
 472    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
 473    a_mu(i,jm) =a_mu(i,jm) +a_Tmpv1
 474    ENDDO
 475
 476 !  Remarked by Ning Pan, 2010-07-17
 477 !   IF(config_flags%periodic_y) THEN
 478
 479 !   END IF
 480
 481    DO j =jtf-1, jts, -1
 482    DO i =itf, its, -1
 483    a_Tmpv2 =a_muv(i,j)
 484    a_muv(i,j) =0.0
 485    a_Tmpv1 =0.5*a_Tmpv2
 486    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 487    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
 488    ENDDO
 489    ENDDO
 490
 491    ELSE IF( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN
 492
 493 !  Added by Ning Pan, 2010-07-17
 494    j =jte
 495    jm =jte-1
 496    IF(config_flags%periodic_y) jm =jte
 497
 498    DO i =itf, its, -1
 499    a_Tmpv2 =a_muv(i,j)
 500    a_muv(i,j) =0.0
 501    a_Tmpv1 =0.5*a_Tmpv2
 502    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
 503    a_mu(i,jm) =a_mu(i,jm) +a_Tmpv1
 504    ENDDO
 505
 506 !  Remarked by Ning Pan, 2010-07-17
 507 !   IF(config_flags%periodic_y) THEN
 508
 509 !   END IF
 510
 511    j =jts
 512    jm =jts
 513    IF(config_flags%periodic_y) jm =jts-1
 514
 515    DO i =itf, its, -1
 516    a_Tmpv2 =a_muv(i,j)
 517    a_muv(i,j) =0.0
 518    a_Tmpv1 =0.5*a_Tmpv2
 519    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 520    a_mu(i,jm) =a_mu(i,jm) +a_Tmpv1
 521    ENDDO
 522
 523 !  Remarked by Ning Pan, 2010-07-17
 524 !   IF(config_flags%periodic_y) THEN
 525
 526 !   END IF
 527
 528    DO j =jtf-1, jts+1, -1
 529    DO i =itf, its, -1
 530    a_Tmpv2 =a_muv(i,j)
 531    a_muv(i,j) =0.0
 532    a_Tmpv1 =0.5*a_Tmpv2
 533    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 534    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
 535    ENDDO
 536    ENDDO
 537
 538    END IF
 539
 540 !LPB[2]
 541 !  itf =min(ite, ide-1)
 542 !  jtf =jte
 543
 544 !LPB[1]
 545
 546 !  IF( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
 547 !  DO j =jts, jtf
 548 !  DO i =its, itf
 549 !  Tmpv001 =mu(i,j) +mu(i-1,j)
 550 !  Tmpv002 =0.5*Tmpv001
 551 !  muu(i,j) =Tmpv002
 552
 553 !  ENDDO
 554 !  ENDDO
 555 !  ELSE IF( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN
 556 !  DO j =jts, jtf
 557 !  DO i =its+1, itf
 558 !  Tmpv001 =mu(i,j) +mu(i-1,j)
 559 !  Tmpv002 =0.5*Tmpv001
 560 !  muu(i,j) =Tmpv002
 561
 562 !  ENDDO
 563 !  ENDDO
 564 !  i =its
 565 !  im =its
 566 !  IF(config_flags%periodic_x) THEN
 567 !  im =its-1
 568 !  END IF
 569 !  DO j =jts, jtf
 570 !  Tmpv001 =mu(i,j) +mu(im,j)
 571 !  Tmpv002 =0.5*Tmpv001
 572 !  muu(i,j) =Tmpv002
 573
 574 !  ENDDO
 575
 576 !  ELSE IF( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN
 577 !  DO j =jts, jtf
 578 !  DO i =its, itf-1
 579 !  Tmpv001 =mu(i,j) +mu(i-1,j)
 580 !  Tmpv002 =0.5*Tmpv001
 581 !  muu(i,j) =Tmpv002
 582
 583 !  ENDDO
 584 !  ENDDO
 585 !  i =ite
 586 !  im =ite-1
 587 !  IF(config_flags%periodic_x) THEN
 588 !  im =ite
 589 !  END IF
 590 !  DO j =jts, jtf
 591 !  Tmpv001 =mu(i-1,j) +mu(im,j)
 592 !  Tmpv002 =0.5*Tmpv001
 593 !  muu(i,j) =Tmpv002
 594
 595 !  ENDDO
 596
 597 !  ELSE IF( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN
 598 !  DO j =jts, jtf
 599 !  DO i =its+1, itf-1
 600 !  Tmpv001 =mu(i,j) +mu(i-1,j)
 601 !  Tmpv002 =0.5*Tmpv001
 602 !  muu(i,j) =Tmpv002
 603
 604 !  ENDDO
 605 !  ENDDO
 606 !  i =its
 607 !  im =its
 608 !  IF(config_flags%periodic_x) THEN
 609 !  im =its-1
 610 !  END IF
 611 !  DO j =jts, jtf
 612 !  Tmpv001 =mu(i,j) +mu(im,j)
 613 !  Tmpv002 =0.5*Tmpv001
 614 !  muu(i,j) =Tmpv002
 615
 616 !  ENDDO
 617
 618 !  i =ite
 619 !  im =ite-1
 620 !  IF(config_flags%periodic_x) THEN
 621 !  im =ite
 622 !  END IF
 623 !  DO j =jts, jtf
 624 !  Tmpv001 =mu(i-1,j) +mu(im,j)
 625 !  Tmpv002 =0.5*Tmpv001
 626 !  muu(i,j) =Tmpv002
 627
 628 !  ENDDO
 629
 630 !  END IF
 631
 632 !  Added by Ning Pan, 2010-07-17
 633    itf =ite
 634    jtf =min(jte,jde-1)
 635
 636    IF( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
 637
 638    DO j =jtf, jts, -1
 639    DO i =itf, its, -1
 640    a_Tmpv2 =a_muu(i,j)
 641    a_muu(i,j) =0.0
 642    a_Tmpv1 =0.5*a_Tmpv2
 643    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 644    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
 645    ENDDO
 646    ENDDO
 647
 648    ELSE IF( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN
 649
 650 !  Added by Ning Pan, 2010-07-17
 651    i =its
 652    im =its
 653    IF(config_flags%periodic_x) im =its-1
 654
 655    DO j =jtf, jts, -1
 656    a_Tmpv2 =a_muu(i,j)
 657    a_muu(i,j) =0.0
 658    a_Tmpv1 =0.5*a_Tmpv2
 659    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 660    a_mu(im,j) =a_mu(im,j) +a_Tmpv1
 661    ENDDO
 662
 663 !  Remarked by Ning Pan, 2010-07-17
 664 !   IF(config_flags%periodic_x) THEN
 665
 666 !   END IF
 667
 668    DO j =jtf, jts, -1
 669    DO i =itf, its+1, -1
 670    a_Tmpv2 =a_muu(i,j)
 671    a_muu(i,j) =0.0
 672    a_Tmpv1 =0.5*a_Tmpv2
 673    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 674    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
 675    ENDDO
 676    ENDDO
 677
 678    ELSE IF( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN
 679
 680 !  Added by Ning Pan, 2010-07-17
 681    i =ite
 682    im =ite-1
 683    IF(config_flags%periodic_x) im =ite
 684
 685    DO j =jtf, jts, -1
 686    a_Tmpv2 =a_muu(i,j)
 687    a_muu(i,j) =0.0
 688    a_Tmpv1 =0.5*a_Tmpv2
 689    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
 690    a_mu(im,j) =a_mu(im,j) +a_Tmpv1
 691    ENDDO
 692
 693 !  Remarked by Ning Pan, 2010-07-17
 694 !   IF(config_flags%periodic_x) THEN
 695
 696 !   END IF
 697
 698    DO j =jtf, jts, -1
 699    DO i =itf-1, its, -1
 700    a_Tmpv2 =a_muu(i,j)
 701    a_muu(i,j) =0.0
 702    a_Tmpv1 =0.5*a_Tmpv2
 703    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 704    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
 705    ENDDO
 706    ENDDO
 707
 708    ELSE IF( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN
 709
 710 !  Added by Ning Pan, 2010-07-17
 711    i =ite
 712    im =ite-1
 713    IF(config_flags%periodic_x) im =ite
 714
 715    DO j =jtf, jts, -1
 716    a_Tmpv2 =a_muu(i,j)
 717    a_muu(i,j) =0.0
 718    a_Tmpv1 =0.5*a_Tmpv2
 719    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
 720    a_mu(im,j) =a_mu(im,j) +a_Tmpv1
 721    ENDDO
 722
 723 !  Remarked by Ning Pan, 2010-07-17
 724 !   IF(config_flags%periodic_x) THEN
 725
 726 !   END IF
 727
 728 !  Added by Ning Pan, 2010-07-17
 729    i =its
 730    im =its
 731    IF(config_flags%periodic_x) im =its-1
 732
 733    DO j =jtf, jts, -1
 734    a_Tmpv2 =a_muu(i,j)
 735    a_muu(i,j) =0.0
 736    a_Tmpv1 =0.5*a_Tmpv2
 737    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 738    a_mu(im,j) =a_mu(im,j) +a_Tmpv1
 739    ENDDO
 740
 741 !  Remarked by Ning Pan, 2010-07-17
 742 !   IF(config_flags%periodic_x) THEN
 743
 744 !   END IF
 745
 746    DO j =jtf, jts, -1
 747    DO i =itf-1, its+1, -1
 748    a_Tmpv2 =a_muu(i,j)
 749    a_muu(i,j) =0.0
 750    a_Tmpv1 =0.5*a_Tmpv2
 751    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
 752    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
 753    ENDDO
 754    ENDDO
 755
 756    END IF
 757
 758 !LPB[0]
 759 !  itf =ite
 760 !  jtf =min(jte, jde-1)
 761
 762    END SUBROUTINE a_calc_mu_uv_1
 763
 764 !        Generated by TAPENADE     (INRIA, Tropics team)
 765 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 766 !
 767 !  Differentiation of couple_momentum in reverse (adjoint) mode:
 768 !   gradient     of useful results: u v w ru rv rw mut muu muv
 769 !   with respect to varying inputs: u v w ru rv rw mut muu muv
 770 !   RW status of diff variables: u:incr v:incr w:incr ru:in-out
 771 !                rv:in-out rw:in-out mut:incr muu:incr muv:incr
 772 ! Map scale factor comments for this routine:
 773 ! Locally not changed, but sent the correct map scale factors
 774 ! from module_em (msfuy, msfvx, msfty)
 775 SUBROUTINE A_COUPLE_MOMENTUM(muu, muub, rub, u, ub, msfu, muv, muvb&
 776 &  , rvb, v, vb, msfv, msfv_inv, mut, mutb, rwb, w, wb, msft, ids&
 777 &  , ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts&
 778 &  , jte, kts, kte)
 779   IMPLICIT NONE
 780 ! Input data
 781   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 782 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 783   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rub, rvb, rwb
 784   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muu, muv, mut
 785   REAL, DIMENSION(ims:ime, jms:jme) :: muub, muvb, mutb
 786   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfu, msfv, msft, &
 787 &  msfv_inv
 788   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, v, w
 789   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ub, vb, wb
 790 ! Local data
 791   INTEGER :: i, j, k, itf, jtf, ktf
 792   INTEGER :: ad_to
 793   INTEGER :: ad_to0
 794   INTEGER :: ad_to1
 795   INTEGER :: ad_to2
 796   REAL :: tempb
 797   IF (kte .GT. kde - 1) THEN
 798     ktf = kde - 1
 799   ELSE
 800     ktf = kte
 801   END IF
 802   itf = ite
 803   IF (jte .GT. jde - 1) THEN
 804     jtf = jde - 1
 805   ELSE
 806     jtf = jte
 807   END IF
 808   DO j=jts,jtf
 809     DO k=kts,ktf
 810       i = itf + 1
 811       CALL PUSHINTEGER4(i - 1)
 812     END DO
 813   END DO
 814   CALL PUSHINTEGER4(j - 1)
 815   IF (ite .GT. ide - 1) THEN
 816     itf = ide - 1
 817   ELSE
 818     itf = ite
 819   END IF
 820   jtf = jte
 821   DO j=jts,jtf
 822     DO k=kts,ktf
 823       i = itf + 1
 824       CALL PUSHINTEGER4(i - 1)
 825     END DO
 826   END DO
 827   CALL PUSHINTEGER4(j - 1)
 828   IF (ite .GT. ide - 1) THEN
 829     itf = ide - 1
 830   ELSE
 831     itf = ite
 832   END IF
 833   IF (jte .GT. jde - 1) THEN
 834     jtf = jde - 1
 835   ELSE
 836     jtf = jte
 837   END IF
 838   DO j=jtf,jts,-1
 839     DO k=kte,kts,-1
 840       DO i=itf,its,-1
 841         wb(i, k, j) = wb(i, k, j) + mut(i, j)*rwb(i, k, j)/msft(i, j)
 842         mutb(i, j) = mutb(i, j) + w(i, k, j)*rwb(i, k, j)/msft(i, j)
 843         rwb(i, k, j) = 0.0
 844       END DO
 845     END DO
 846   END DO
 847   CALL POPINTEGER4(ad_to2)
 848   DO j=ad_to2,jts,-1
 849     DO k=ktf,kts,-1
 850       CALL POPINTEGER4(ad_to1)
 851       DO i=ad_to1,its,-1
 852         tempb = msfv_inv(i, j)*rvb(i, k, j)
 853         vb(i, k, j) = vb(i, k, j) + muv(i, j)*tempb
 854         muvb(i, j) = muvb(i, j) + v(i, k, j)*tempb
 855         rvb(i, k, j) = 0.0
 856       END DO
 857     END DO
 858   END DO
 859   CALL POPINTEGER4(ad_to0)
 860   DO j=ad_to0,jts,-1
 861     DO k=ktf,kts,-1
 862       CALL POPINTEGER4(ad_to)
 863       DO i=ad_to,its,-1
 864         ub(i, k, j) = ub(i, k, j) + muu(i, j)*rub(i, k, j)/msfu(i, j)
 865         muub(i, j) = muub(i, j) + u(i, k, j)*rub(i, k, j)/msfu(i, j)
 866         rub(i, k, j) = 0.0
 867       END DO
 868     END DO
 869   END DO
 870 END SUBROUTINE A_COUPLE_MOMENTUM
 871
 872    SUBROUTINE a_calc_ww_cp(u,a_u,v,a_v,mup,a_mup,mub,ww,a_ww,rdx,rdy,msftx, &
 873    msfty,msfux,msfuy,msfvx,msfvx_inv,msfvy,dnw,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
 874    kms,kme,its,ite,jts,jte,kts,kte)
 875
 876 !PART I: DECLARATION OF VARIABLES
 877
 878    IMPLICIT NONE
 879
 880    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
 881    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 882    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,a_u,v,a_v
 883    REAL,DIMENSION(ims:ime,jms:jme) :: mup,a_mup,mub,msftx,msfty,msfux,msfuy,msfvx, &
 884    msfvy,msfvx_inv
 885    REAL,DIMENSION(kms:kme) :: dnw
 886    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ww,a_ww
 887    REAL :: rdx,rdy
 888    INTEGER :: i,j,k,itf,jtf,ktf
 889    REAL,DIMENSION(its:ite) :: dmdt,a_dmdt
 890    REAL,DIMENSION(its:ite,kts:kte) :: divv,a_divv
 891    REAL,DIMENSION(its:ite+1,jts:jte+1) :: muu,a_muu,muv,a_muv
 892
 893    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
 894    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, &
 895    Tmpv009,a_Tmpv10,Tmpv010
 896
 897 !PART II: CALCULATIONS OF B. S. TRAJECTORY
 898
 899 !LPB[0]
 900
 901        jtf=MIN(jte,jde-1)
 902        ktf=MIN(kte,kde-1)
 903        itf=MIN(ite,ide-1)
 904
 905 !LPB[1]
 906          DO j=jts,jtf
 907
 908          DO i=its,min(ite+1,ide)
 909            muu(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i-1,j)+mub(i-1,j))/msfuy(i,j)
 910          ENDDO
 911
 912          ENDDO
 913
 914 !LPB[2]
 915          DO j=jts,min(jte+1,jde)
 916
 917          DO i=its,itf
 918            muv(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i,j-1)+mub(i,j-1))*msfvx_inv(i,j)
 919          ENDDO
 920
 921          ENDDO
 922
 923 !!LPB[3]
 924 !         DO j=jts,jtf
 925
 926 !           DO i=its,ite
 927 !             dmdt(i) = 0.
 928 !             ww(i,1,j) = 0.
 929 !             ww(i,kte,j) = 0.
 930 !           ENDDO
 931
 932 !           DO k=kts,ktf
 933 !           DO i=its,itf
 934 !             divv(i,k) = msftx(i,j)*dnw(k)*( rdx*(muu(i+1,j)*u(i+1,k,j)-muu(i,j) &
 935 !   *u(i,k,j))    &
 936 !                                           +rdy*(muv(i,j+1)*v(i,k,j+1)-muv(i,j)*v(i,k,j))   )
 937 !             dmdt(i) = dmdt(i) + divv(i,k)
 938 !           ENDDO
 939 !           ENDDO
 940
 941 !           DO k=2,ktf
 942 !           DO i=its,itf
 943 !              ww(i,k,j)=ww(i,k-1,j) - dnw(k-1)*dmdt(i) - divv(i,k-1)
 944 !           ENDDO
 945 !           ENDDO
 946
 947 !        ENDDO
 948
 949 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
 950
 951    Do K0_ADJ =its, ite
 952    a_dmdt(K0_ADJ) =0.0
 953    End Do
 954
 955    Do K1_ADJ =kts, kte
 956    Do K0_ADJ =its, ite
 957    a_divv(K0_ADJ,K1_ADJ) =0.0
 958    End Do
 959    End Do
 960
 961    Do K1_ADJ =jts, jte+1
 962    Do K0_ADJ =its, ite+1
 963    a_muu(K0_ADJ,K1_ADJ) =0.0
 964    End Do
 965    End Do
 966
 967    Do K1_ADJ =jts, jte+1
 968    Do K0_ADJ =its, ite+1
 969    a_muv(K0_ADJ,K1_ADJ) =0.0
 970    End Do
 971    End Do
 972
 973 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
 974
 975
 976 !LPB[3]
 977    DO j =jtf, jts, -1
 978
 979 ! Remarked by Ning Pan, 2010-08-31 : not need to recalculate
 980 !   DO i =its, ite
 981 !   dmdt(i) =0.
 982
 983 !   ww(i,1,j) =0.
 984
 985 !   ww(i,kte,j) =0.
 986
 987 !   ENDDO
 988
 989 !   DO k =kts, ktf
 990 !   DO i =its, itf
 991 !   Tmpv001 =muu(i+1,j)*u(i+1,k,j)
 992 !   Tmpv002 =muu(i,j)*u(i,k,j)
 993 !   Tmpv003 =Tmpv001 -Tmpv002
 994 !   Tmpv004 =rdx*Tmpv003
 995 !   Tmpv005 =muv(i,j+1)*v(i,k,j+1)
 996 !   Tmpv006 =muv(i,j)*v(i,k,j)
 997 !   Tmpv007 =Tmpv005 -Tmpv006
 998 !   Tmpv008 =rdy*Tmpv007
 999 !   Tmpv009 =Tmpv004 +Tmpv008
1000 !   Tmpv010 =msftx(i,j)*dnw(k)*Tmpv009
1001 !!  divv(i,k) =Tmpv010
1002
1003 !   Tmpv001 =dmdt(i) +divv(i,k)
1004 !!  dmdt(i) =Tmpv001
1005
1006 !   ENDDO
1007 !   ENDDO
1008 !   DO k =2, ktf
1009 !   DO i =its, itf
1010 !   Tmpv001 =ww(i,k-1,j) -dnw(k-1)*dmdt(i)
1011 !   Tmpv002 =Tmpv001 -divv(i,k-1)
1012 !!  ww(i,k,j) =Tmpv002
1013
1014 !   ENDDO
1015 !   ENDDO
1016
1017    DO k =ktf, 2, -1
1018    DO i =itf, its, -1
1019    a_Tmpv2 =a_ww(i,k,j)
1020    a_ww(i,k,j) =0.0
1021    a_Tmpv1 =a_Tmpv2
1022    a_divv(i,k-1) =a_divv(i,k-1) -a_Tmpv2
1023    a_ww(i,k-1,j) =a_ww(i,k-1,j) +a_Tmpv1
1024    a_dmdt(i) =a_dmdt(i) -dnw(k-1)*a_Tmpv1
1025    ENDDO
1026    ENDDO
1027
1028    DO k =ktf, kts, -1
1029    DO i =itf, its, -1
1030    a_Tmpv1 =a_dmdt(i)
1031    a_dmdt(i) =0.0
1032    a_dmdt(i) =a_dmdt(i) +a_Tmpv1
1033    a_divv(i,k) =a_divv(i,k) +a_Tmpv1
1034    a_Tmpv10 =a_divv(i,k)
1035    a_divv(i,k) =0.0
1036    a_Tmpv9 =msftx(i,j)*dnw(k)*a_Tmpv10
1037    a_Tmpv4 =a_Tmpv9
1038    a_Tmpv8 =a_Tmpv9
1039    a_Tmpv7 =rdy*a_Tmpv8
1040    a_Tmpv5 =a_Tmpv7
1041    a_Tmpv6 =-a_Tmpv7
1042    a_muv(i,j) =a_muv(i,j) +v(i,k,j)*a_Tmpv6
1043    a_v(i,k,j) =a_v(i,k,j) +muv(i,j)*a_Tmpv6
1044    a_muv(i,j+1) =a_muv(i,j+1) +v(i,k,j+1)*a_Tmpv5
1045    a_v(i,k,j+1) =a_v(i,k,j+1) +muv(i,j+1)*a_Tmpv5
1046    a_Tmpv3 =rdx*a_Tmpv4
1047    a_Tmpv1 =a_Tmpv3
1048    a_Tmpv2 =-a_Tmpv3
1049    a_muu(i,j) =a_muu(i,j) +u(i,k,j)*a_Tmpv2
1050    a_u(i,k,j) =a_u(i,k,j) +muu(i,j)*a_Tmpv2
1051    a_muu(i+1,j) =a_muu(i+1,j) +u(i+1,k,j)*a_Tmpv1
1052    a_u(i+1,k,j) =a_u(i+1,k,j) +muu(i+1,j)*a_Tmpv1
1053    ENDDO
1054    ENDDO
1055
1056    DO i =ite, its, -1
1057    a_ww(i,kte,j) =0.0
1058    a_ww(i,1,j) =0.0
1059    a_dmdt(i) =0.0
1060    ENDDO
1061
1062    ENDDO
1063
1064 !LPB[2]
1065    DO j =min(jte+1, jde), jts, -1
1066
1067 !  DO i =its, itf
1068 !  Tmpv001 =mup(i,j) +mub(i,j) +mup(i,j-1)
1069 !  Tmpv002 =Tmpv001 +mub(i,j-1)
1070 !  Tmpv003 =0.5*Tmpv002
1071 !  Tmpv004 =Tmpv003*msfvx_inv(i,j)
1072 !  muv(i,j) =Tmpv004
1073
1074 !  ENDDO
1075
1076    DO i =itf, its, -1
1077    a_Tmpv4 =a_muv(i,j)
1078    a_muv(i,j) =0.0
1079    a_Tmpv3 =msfvx_inv(i,j)*a_Tmpv4
1080    a_Tmpv2 =0.5*a_Tmpv3
1081    a_Tmpv1 =a_Tmpv2
1082    a_mup(i,j) =a_mup(i,j) +a_Tmpv1
1083    a_mup(i,j-1) =a_mup(i,j-1) +a_Tmpv1
1084    ENDDO
1085
1086    ENDDO
1087
1088 !LPB[1]
1089    DO j =jtf, jts, -1
1090
1091 !  DO i =its, min(ite+1, ide)
1092 !  Tmpv001 =mup(i,j) +mub(i,j) +mup(i-1,j)
1093 !  Tmpv002 =Tmpv001 +mub(i-1,j)
1094 !  Tmpv003 =0.5*Tmpv002
1095 !  Tmpv004 =Tmpv003/msfuy(i,j)
1096 !  muu(i,j) =Tmpv004
1097
1098 !  ENDDO
1099
1100    DO i =min(ite+1, ide), its, -1
1101    a_Tmpv4 =a_muu(i,j)
1102    a_muu(i,j) =0.0
1103    a_Tmpv3 =a_Tmpv4/msfuy(i,j)
1104    a_Tmpv2 =0.5*a_Tmpv3
1105    a_Tmpv1 =a_Tmpv2
1106    a_mup(i,j) =a_mup(i,j) +a_Tmpv1
1107    a_mup(i-1,j) =a_mup(i-1,j) +a_Tmpv1
1108    ENDDO
1109
1110    ENDDO
1111
1112 !LPB[0]
1113 !  jtf =min(jte, jde-1)
1114 !  ktf =min(kte, kde-1)
1115 !  itf =min(ite, ide-1)
1116
1117    END SUBROUTINE a_calc_ww_cp
1118
1119 !        Generated by TAPENADE     (INRIA, Tropics team)
1120 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
1121 !
1122 !  Differentiation of calc_cq in reverse (adjoint) mode:
1123 !   gradient     of useful results: cqu cqv cqw moist
1124 !   with respect to varying inputs: cqu cqv cqw moist
1125 !   RW status of diff variables: cqu:in-out cqv:in-out cqw:in-out
1126 !                moist:incr
1127 SUBROUTINE A_CALC_CQ(moist, moistb, cqu, cqub, cqv, cqvb, cqw, cqwb, &
1128 &  n_moist, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, &
1129 &  its, ite, jts, jte, kts, kte)
1130   IMPLICIT NONE
1131 ! Input data
1132   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
1133 &  jme, kms, kme, its, ite, jts, jte, kts, kte
1134   INTEGER, INTENT(IN) :: n_moist
1135   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
1136 &  moist
1137   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist) :: moistb
1138   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: cqu, cqv, cqw
1139   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: cqub, cqvb, cqwb
1140 ! Local stuff
1141 ! Changes from Larry Meadows, Intel Corp.  Improve vectorization of this routine
1142   REAL :: qtot(its:ite)
1143   REAL :: qtotb(its:ite)
1144   INTEGER :: i, j, k, itf, jtf, ktf, ispe
1145   INTEGER :: ad_to
1146   INTEGER :: ad_to0
1147   INTEGER :: ad_to1
1148   INTEGER :: ad_to2
1149   INTEGER :: ad_to3
1150   INTEGER :: ad_to4
1151   INTEGER :: ad_to5
1152   INTEGER :: ad_to6
1153   INTEGER :: ad_to7
1154   INTEGER :: ad_to8
1155   IF (kte .GT. kde - 1) THEN
1156     ktf = kde - 1
1157   ELSE
1158     ktf = kte
1159   END IF
1160   IF (n_moist .GE. param_first_scalar) THEN
1161     itf = ite
1162     IF (jte .GT. jde - 1) THEN
1163       jtf = jde - 1
1164     ELSE
1165       jtf = jte
1166     END IF
1167     DO j=jts,jtf
1168       DO k=kts,ktf
1169         CALL PUSHREAL8ARRAY(qtot, ite - its + 1)
1170         qtot = 0.
1171         DO ispe=param_first_scalar,n_moist
1172           DO i=its,itf
1173             qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i-1, k, j, &
1174 &              ispe)
1175           END DO
1176           CALL PUSHINTEGER4(i - 1)
1177         END DO
1178         i = itf + 1
1179         CALL PUSHINTEGER4(i - 1)
1180       END DO
1181     END DO
1182     CALL PUSHINTEGER4(j - 1)
1183     IF (ite .GT. ide - 1) THEN
1184       itf = ide - 1
1185     ELSE
1186       itf = ite
1187     END IF
1188     jtf = jte
1189     DO j=jts,jtf
1190       DO k=kts,ktf
1191         CALL PUSHREAL8ARRAY(qtot, ite - its + 1)
1192         qtot = 0.
1193         DO ispe=param_first_scalar,n_moist
1194           DO i=its,itf
1195             qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i, k, j-1, &
1196 &              ispe)
1197           END DO
1198           CALL PUSHINTEGER4(i - 1)
1199         END DO
1200         i = itf + 1
1201         CALL PUSHINTEGER4(i - 1)
1202       END DO
1203     END DO
1204     CALL PUSHINTEGER4(j - 1)
1205     IF (ite .GT. ide - 1) THEN
1206       itf = ide - 1
1207     ELSE
1208       itf = ite
1209     END IF
1210     IF (jte .GT. jde - 1) THEN
1211       jtf = jde - 1
1212     ELSE
1213       jtf = jte
1214     END IF
1215     DO j=jtf,jts,-1
1216       DO k=ktf,kts+1,-1
1217         qtotb = 0.0
1218         DO i=itf,its,-1
1219           qtotb(i) = qtotb(i) + 0.5*cqwb(i, k, j)
1220           cqwb(i, k, j) = 0.0
1221         END DO
1222         DO ispe=n_moist,param_first_scalar,-1
1223           DO i=itf,its,-1
1224             moistb(i, k, j, ispe) = moistb(i, k, j, ispe) + qtotb(i)
1225             moistb(i, k-1, j, ispe) = moistb(i, k-1, j, ispe) + qtotb(i)
1226           END DO
1227         END DO
1228       END DO
1229     END DO
1230     CALL POPINTEGER4(ad_to8)
1231     DO j=ad_to8,jts,-1
1232       DO k=ktf,kts,-1
1233         qtotb = 0.0
1234         CALL POPINTEGER4(ad_to7)
1235         DO i=ad_to7,its,-1
1236           qtotb(i) = qtotb(i) - 0.5*cqvb(i, k, j)/(0.5*qtot(i)+1.)**2
1237           cqvb(i, k, j) = 0.0
1238         END DO
1239         DO ispe=n_moist,param_first_scalar,-1
1240           CALL POPINTEGER4(ad_to6)
1241           DO i=ad_to6,its,-1
1242             moistb(i, k, j, ispe) = moistb(i, k, j, ispe) + qtotb(i)
1243             moistb(i, k, j-1, ispe) = moistb(i, k, j-1, ispe) + qtotb(i)
1244           END DO
1245         END DO
1246         CALL POPREAL8ARRAY(qtot, ite - its + 1)
1247       END DO
1248     END DO
1249     CALL POPINTEGER4(ad_to5)
1250     DO j=ad_to5,jts,-1
1251       DO k=ktf,kts,-1
1252         qtotb = 0.0
1253         CALL POPINTEGER4(ad_to4)
1254         DO i=ad_to4,its,-1
1255           qtotb(i) = qtotb(i) - 0.5*cqub(i, k, j)/(0.5*qtot(i)+1.)**2
1256           cqub(i, k, j) = 0.0
1257         END DO
1258         DO ispe=n_moist,param_first_scalar,-1
1259           CALL POPINTEGER4(ad_to3)
1260           DO i=ad_to3,its,-1
1261             moistb(i, k, j, ispe) = moistb(i, k, j, ispe) + qtotb(i)
1262             moistb(i-1, k, j, ispe) = moistb(i-1, k, j, ispe) + qtotb(i)
1263           END DO
1264         END DO
1265         CALL POPREAL8ARRAY(qtot, ite - its + 1)
1266       END DO
1267     END DO
1268   ELSE
1269     itf = ite
1270     IF (jte .GT. jde - 1) THEN
1271       jtf = jde - 1
1272     ELSE
1273       jtf = jte
1274     END IF
1275     DO j=jts,jtf
1276       DO k=kts,ktf
1277         i = itf + 1
1278         CALL PUSHINTEGER4(i - 1)
1279       END DO
1280     END DO
1281     CALL PUSHINTEGER4(j - 1)
1282     IF (ite .GT. ide - 1) THEN
1283       itf = ide - 1
1284     ELSE
1285       itf = ite
1286     END IF
1287     jtf = jte
1288     DO j=jts,jtf
1289       DO k=kts,ktf
1290         i = itf + 1
1291         CALL PUSHINTEGER4(i - 1)
1292       END DO
1293     END DO
1294     CALL PUSHINTEGER4(j - 1)
1295     IF (ite .GT. ide - 1) THEN
1296       itf = ide - 1
1297     ELSE
1298       itf = ite
1299     END IF
1300     IF (jte .GT. jde - 1) THEN
1301       jtf = jde - 1
1302     ELSE
1303       jtf = jte
1304     END IF
1305     DO j=jtf,jts,-1
1306       DO k=ktf,kts+1,-1
1307         DO i=itf,its,-1
1308           cqwb(i, k, j) = 0.0
1309         END DO
1310       END DO
1311     END DO
1312     CALL POPINTEGER4(ad_to2)
1313     DO j=ad_to2,jts,-1
1314       DO k=ktf,kts,-1
1315         CALL POPINTEGER4(ad_to1)
1316         DO i=ad_to1,its,-1
1317           cqvb(i, k, j) = 0.0
1318         END DO
1319       END DO
1320     END DO
1321     CALL POPINTEGER4(ad_to0)
1322     DO j=ad_to0,jts,-1
1323       DO k=ktf,kts,-1
1324         CALL POPINTEGER4(ad_to)
1325         DO i=ad_to,its,-1
1326           cqub(i, k, j) = 0.0
1327         END DO
1328       END DO
1329     END DO
1330   END IF
1331 END SUBROUTINE A_CALC_CQ
1332
1333    SUBROUTINE a_calc_alt(alt,a_alt,al,a_al,alb,ids,ide,jds,jde,kds,kde,ims,ime, &
1334    jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1335
1336 !PART I: DECLARATION OF VARIABLES
1337
1338    IMPLICIT NONE
1339
1340    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
1341    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1342    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: alb,al,a_al
1343    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: alt,a_alt
1344    INTEGER :: i,j,k,itf,jtf,ktf
1345
1346 !PART II: CALCULATIONS OF B. S. TRAJECTORY
1347
1348 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
1349
1350    ! Added by Ning Pan, 2010-07-13
1351    itf =min(ite,ide-1)
1352    jtf =min(jte,jde-1)
1353    ktf =min(kte,kde-1)
1354
1355 !LPB[1]
1356    DO j =jtf, jts, -1
1357
1358 !  DO k =kts, ktf
1359 !  DO i =its, itf
1360 !  alt(i,k,j) =al(i,k,j) +alb(i,k,j)
1361
1362 !  ENDDO
1363 !  ENDDO
1364
1365    DO k =ktf, kts, -1
1366    DO i =itf, its, -1
1367    a_al(i,k,j) =a_al(i,k,j) +a_alt(i,k,j)
1368    a_alt(i,k,j) =0.0
1369    ENDDO
1370    ENDDO
1371
1372    ENDDO
1373
1374 !LPB[0]
1375 !  itf =min(ite, ide-1)
1376 !  jtf =min(jte, jde-1)
1377 !  ktf =min(kte, kde-1)
1378
1379    END SUBROUTINE a_calc_alt
1380
1381 !        Generated by TAPENADE     (INRIA, Tropics team)
1382 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
1383 !
1384 !  Differentiation of calc_p_rho_phi in reverse (adjoint) mode:
1385 !   gradient     of useful results: p al t muts ph moist mu
1386 !   with respect to varying inputs: p al t muts ph moist mu
1387 !   RW status of diff variables: p:in-out al:in-out t:incr muts:incr
1388 !                ph:in-out moist:incr mu:incr
1389 SUBROUTINE A_CALC_P_RHO_PHI(moist, moistb, n_moist, hypsometric_opt, al&
1390 &  , alb0, alb, mu, mub, muts, mutsb, ph, phb0, phb, p, pb0, pb, t, tb, &
1391 &  p0, t0, ptop, znu, znw, dnw, rdnw, rdn, non_hydrostatic, ids, ide, jds&
1392 &  , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
1393 &  , kte)
1394   IMPLICIT NONE
1395 ! Input data
1396   LOGICAL, INTENT(IN) :: non_hydrostatic
1397   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
1398 &  jme, kms, kme, its, ite, jts, jte, kts, kte
1399   INTEGER, INTENT(IN) :: n_moist
1400   INTEGER, INTENT(IN) :: hypsometric_opt
1401   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: alb, pb, t
1402   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tb
1403   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
1404 &  moist
1405   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist) :: moistb
1406   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: al, p
1407   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: alb0, pb0
1408   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ph, phb
1409   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: phb0
1410   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muts
1411   REAL, DIMENSION(ims:ime, jms:jme) :: mub, mutsb
1412   REAL, DIMENSION(kms:kme), INTENT(IN) :: znu, znw, dnw, rdnw, rdn
1413   REAL, INTENT(IN) :: t0, p0, ptop
1414 ! Local stuff
1415   INTEGER :: i, j, k, itf, jtf, ktf, ispe
1416   REAL :: qvf, qtot, qf1, qf2
1417   REAL :: qvfb, qtotb, qf1b
1418   REAL, DIMENSION(its:ite) :: temp, cpovcv_v
1419   REAL, DIMENSION(its:ite) :: tempb
1420   REAL :: pfu, phm, pfd
1421   REAL :: pfub, phmb, pfdb
1422   INTEGER :: arg1
1423   INTEGER :: branch
1424   REAL :: temp3
1425   REAL :: temp2
1426   REAL :: temp1
1427   REAL :: temp0
1428   REAL :: temp16b
1429   REAL :: temp0b
1430   REAL :: temp3b
1431   REAL :: temp18
1432   REAL :: temp17
1433   REAL :: temp12b
1434   REAL :: temp16
1435   REAL :: temp6b
1436   REAL :: temp15
1437   REAL :: temp14
1438   REAL :: temp13
1439   REAL :: temp12
1440   REAL :: temp11
1441   REAL :: temp10
1442   REAL :: temp0b0
1443   REAL :: temp8b0
1444   REAL :: temp14b
1445   REAL :: temp8b
1446   REAL :: temp3b0
1447   REAL :: temp12b2
1448   REAL :: temp12b1
1449   REAL :: temp12b0
1450   REAL :: temp6b0
1451   REAL :: temp9
1452   REAL :: temp8
1453   REAL :: temp7
1454   REAL :: temp10b
1455   REAL :: temp6
1456   REAL :: temp10b1
1457   REAL :: temp5
1458   REAL :: temp10b0
1459   REAL :: temp4
1460   IF (ite .GT. ide - 1) THEN
1461     itf = ide - 1
1462   ELSE
1463     itf = ite
1464   END IF
1465   IF (jte .GT. jde - 1) THEN
1466     jtf = jde - 1
1467   ELSE
1468     jtf = jte
1469   END IF
1470   IF (kte .GT. kde - 1) THEN
1471     ktf = kde - 1
1472   ELSE
1473     ktf = kte
1474   END IF
1475 !#ifndef INTELMKL
1476   cpovcv_v = cpovcv
1477 !#endif
1478   IF (non_hydrostatic) THEN
1479     IF (hypsometric_opt .EQ. 1) THEN
1480       DO j=jts,jtf
1481         DO k=kts,ktf
1482           DO i=its,itf
1483             al(i, k, j) = -(1./muts(i, j)*(alb(i, k, j)*mu(i, j)+rdnw(k)&
1484 &              *(ph(i, k+1, j)-ph(i, k, j))))
1485           END DO
1486         END DO
1487       END DO
1488       CALL PUSHCONTROL2B(0)
1489     ELSE IF (hypsometric_opt .EQ. 2) THEN
1490 ! The relation used to get specific volume, al, is: al = -dZ/dp,
1491 ! where dp = mut * d(eta). The pressure depth, dp, is replaced with
1492 ! p*(dp/p) ~ p*LOG((p+0.5dp)/(p-0.5dp)). Difference between dp and p*dLOG(p)
1493 ! is as follows: p*dLOG(p) - dp = 1/12*(dp/p)**3 + 1/90*(dp/p)**5 + ...
1494 ! Therefore, p*dLOG(p) is always larger than dp and the difference is
1495 ! in proportion to dp/p. TKW, 02/16/2010
1496       DO j=jts,jtf
1497         DO k=kts,ktf
1498           DO i=its,itf
1499             pfu = muts(i, j)*znw(k+1) + ptop
1500             pfd = muts(i, j)*znw(k) + ptop
1501             phm = muts(i, j)*znu(k) + ptop
1502             al(i, k, j) = (ph(i, k+1, j)-ph(i, k, j)+phb(i, k+1, j)-phb(&
1503 &              i, k, j))/phm/LOG(pfd/pfu) - alb(i, k, j)
1504           END DO
1505         END DO
1506       END DO
1507       CALL PUSHCONTROL2B(1)
1508     ELSE
1509       CALL PUSHCONTROL2B(2)
1510     END IF
1511     IF (n_moist .GE. param_first_scalar) THEN
1512       DO j=jts,jtf
1513         DO k=kts,ktf
1514           DO i=its,itf
1515             qvf = 1. + rvovrd*moist(i, k, j, p_qv)
1516             CALL PUSHREAL8(temp(i))
1517             temp(i) = r_d*(t0+t(i, k, j))*qvf/(p0*(al(i, k, j)+alb(i, k&
1518 &              , j)))
1519           END DO
1520         END DO
1521       END DO
1522       tempb = 0.0
1523       DO j=jtf,jts,-1
1524         DO k=ktf,kts,-1
1525           DO i=itf,its,-1
1526             pb0(i, k, j) = p0*pb0(i, k, j)
1527           END DO
1528           arg1 = itf - its + 1
1529           CALL A_VPOW(p(its, k, j), pb0(its, k, j), temp(its), tempb(its&
1530 &                ), cpovcv_v(its), arg1)
1531           DO i=itf,its,-1
1532             qvf = 1. + rvovrd*moist(i, k, j, p_qv)
1533             CALL POPREAL8(temp(i))
1534             temp15 = p0*(alb(i, k, j)+al(i, k, j))
1535             temp14 = t0 + t(i, k, j)
1536             temp14b = r_d*tempb(i)/temp15
1537             tb(i, k, j) = tb(i, k, j) + qvf*temp14b
1538             qvfb = temp14*temp14b
1539             alb0(i, k, j) = alb0(i, k, j) - temp14*qvf*p0*temp14b/temp15
1540             tempb(i) = 0.0
1541             moistb(i, k, j, p_qv) = moistb(i, k, j, p_qv) + rvovrd*qvfb
1542           END DO
1543         END DO
1544       END DO
1545     ELSE
1546       DO j=jtf,jts,-1
1547         DO k=ktf,kts,-1
1548           DO i=itf,its,-1
1549             temp18 = p0*(alb(i, k, j)+al(i, k, j))
1550             temp17 = t0 + t(i, k, j)
1551             temp16 = temp17/temp18
1552             IF (r_d*temp16 .LE. 0.0 .AND. (cpovcv .EQ. 0.0 .OR. cpovcv &
1553 &                .NE. INT(cpovcv))) THEN
1554               temp16b = 0.0
1555             ELSE
1556               temp16b = r_d*cpovcv*(r_d*temp16)**(cpovcv-1)*p0*pb0(i, k&
1557 &                , j)/temp18
1558             END IF
1559             tb(i, k, j) = tb(i, k, j) + temp16b
1560             alb0(i, k, j) = alb0(i, k, j) - temp16*p0*temp16b
1561             pb0(i, k, j) = 0.0
1562           END DO
1563         END DO
1564       END DO
1565     END IF
1566     CALL POPCONTROL2B(branch)
1567     IF (branch .EQ. 0) THEN
1568       DO j=jtf,jts,-1
1569         DO k=ktf,kts,-1
1570           DO i=itf,its,-1
1571             temp12b = -(alb0(i, k, j)/muts(i, j))
1572             mub(i, j) = mub(i, j) + alb(i, k, j)*temp12b
1573             phb0(i, k+1, j) = phb0(i, k+1, j) + rdnw(k)*temp12b
1574             phb0(i, k, j) = phb0(i, k, j) - rdnw(k)*temp12b
1575             mutsb(i, j) = mutsb(i, j) - (alb(i, k, j)*mu(i, j)+rdnw(k)*(&
1576 &              ph(i, k+1, j)-ph(i, k, j)))*temp12b/muts(i, j)
1577             alb0(i, k, j) = 0.0
1578           END DO
1579         END DO
1580       END DO
1581     ELSE IF (branch .EQ. 1) THEN
1582       DO j=jtf,jts,-1
1583         DO k=ktf,kts,-1
1584           DO i=itf,its,-1
1585             pfu = muts(i, j)*znw(k+1) + ptop
1586             phm = muts(i, j)*znu(k) + ptop
1587             pfd = muts(i, j)*znw(k) + ptop
1588             temp12 = pfd/pfu
1589             temp13 = LOG(temp12)
1590             temp12b0 = alb0(i, k, j)/(phm*temp13)
1591             temp12b1 = -((phb(i, k+1, j)-phb(i, k, j)+ph(i, k+1, j)-ph(i&
1592 &              , k, j))*temp12b0/(phm*temp13))
1593             temp12b2 = phm*temp12b1/(temp12*pfu)
1594             phb0(i, k+1, j) = phb0(i, k+1, j) + temp12b0
1595             phb0(i, k, j) = phb0(i, k, j) - temp12b0
1596             phmb = temp13*temp12b1
1597             pfdb = temp12b2
1598             pfub = -(temp12*temp12b2)
1599             alb0(i, k, j) = 0.0
1600             mutsb(i, j) = mutsb(i, j) + znw(k)*pfdb + znw(k+1)*pfub + &
1601 &              znu(k)*phmb
1602           END DO
1603         END DO
1604       END DO
1605     END IF
1606   ELSE
1607 !  hydrostatic pressure, al, and ph1 calc; WCS, 5 sept 2001
1608     IF (n_moist .GE. param_first_scalar) THEN
1609       DO j=jts,jtf
1610 ! top layer
1611         k = ktf
1612         DO i=its,itf
1613           qtot = 0.
1614           DO ispe=param_first_scalar,n_moist
1615             qtot = qtot + moist(i, k, j, ispe)
1616           END DO
1617           qf2 = 1.
1618           CALL PUSHREAL8(qf1)
1619           qf1 = qtot*qf2
1620           p(i, k, j) = -(0.5*(mu(i, j)+qf1*muts(i, j))/rdnw(k)/qf2)
1621           qvf = 1. + rvovrd*moist(i, k, j, p_qv)
1622           al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*((p(i, k, j)+pb(&
1623 &            i, k, j))/p1000mb)**cvpm - alb(i, k, j)
1624         END DO
1625         CALL PUSHINTEGER4(k)
1626 ! remaining layers, integrate down
1627         DO k=ktf-1,kts,-1
1628           DO i=its,itf
1629             qtot = 0.
1630             DO ispe=param_first_scalar,n_moist
1631               qtot = qtot + 0.5*(moist(i, k, j, ispe)+moist(i, k+1, j, &
1632 &                ispe))
1633             END DO
1634             qf2 = 1.
1635             CALL PUSHREAL8(qf1)
1636             qf1 = qtot*qf2
1637             CALL PUSHREAL8(p(i, k, j))
1638             p(i, k, j) = p(i, k+1, j) - (mu(i, j)+qf1*muts(i, j))/qf2/&
1639 &              rdn(k+1)
1640             qvf = 1. + rvovrd*moist(i, k, j, p_qv)
1641             al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*((p(i, k, j)+&
1642 &              pb(i, k, j))/p1000mb)**cvpm - alb(i, k, j)
1643           END DO
1644         END DO
1645       END DO
1646       CALL PUSHCONTROL1B(0)
1647     ELSE
1648       DO j=jts,jtf
1649 ! top layer
1650         k = ktf
1651         DO i=its,itf
1652           qtot = 0.
1653           qf2 = 1.
1654           qf1 = qtot*qf2
1655           p(i, k, j) = -(0.5*(mu(i, j)+qf1*muts(i, j))/rdnw(k)/qf2)
1656           qvf = 1.
1657           al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*((p(i, k, j)+pb(&
1658 &            i, k, j))/p1000mb)**cvpm - alb(i, k, j)
1659         END DO
1660         CALL PUSHINTEGER4(k)
1661 ! remaining layers, integrate down
1662         DO k=ktf-1,kts,-1
1663           DO i=its,itf
1664             qtot = 0.
1665             qf2 = 1.
1666             qf1 = qtot*qf2
1667             CALL PUSHREAL8(p(i, k, j))
1668             p(i, k, j) = p(i, k+1, j) - (mu(i, j)+qf1*muts(i, j))/qf2/&
1669 &              rdn(k+1)
1670             qvf = 1.
1671             al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*((p(i, k, j)+&
1672 &              pb(i, k, j))/p1000mb)**cvpm - alb(i, k, j)
1673           END DO
1674         END DO
1675       END DO
1676       CALL PUSHCONTROL1B(1)
1677     END IF
1678     IF (hypsometric_opt .EQ. 1) THEN
1679       DO j=jtf,jts,-1
1680         DO k=ktf+1,2,-1
1681           DO i=itf,its,-1
1682             temp10b = -(dnw(k-1)*phb0(i, k, j))
1683             phb0(i, k-1, j) = phb0(i, k-1, j) + phb0(i, k, j)
1684             mutsb(i, j) = mutsb(i, j) + al(i, k-1, j)*temp10b
1685             alb0(i, k-1, j) = alb0(i, k-1, j) + muts(i, j)*temp10b
1686             mub(i, j) = mub(i, j) + alb(i, k-1, j)*temp10b
1687             phb0(i, k, j) = 0.0
1688           END DO
1689         END DO
1690       END DO
1691     ELSE
1692       DO j=jtf,jts,-1
1693         DO k=ktf+1,kts+1,-1
1694           DO i=itf,its,-1
1695             pfu = muts(i, j)*znw(k) + ptop
1696             phm = muts(i, j)*znu(k-1) + ptop
1697             pfd = muts(i, j)*znw(k-1) + ptop
1698             temp10 = pfd/pfu
1699             temp10b0 = LOG(temp10)*phb0(i, k, j)
1700             temp11 = alb(i, k-1, j) + al(i, k-1, j)
1701             temp10b1 = temp11*phm*phb0(i, k, j)/(temp10*pfu)
1702             phb0(i, k-1, j) = phb0(i, k-1, j) + phb0(i, k, j)
1703             alb0(i, k-1, j) = alb0(i, k-1, j) + phm*temp10b0
1704             phmb = temp11*temp10b0
1705             pfdb = temp10b1
1706             pfub = -(temp10*temp10b1)
1707             phb0(i, k, j) = 0.0
1708             mutsb(i, j) = mutsb(i, j) + znw(k-1)*pfdb + znw(k)*pfub + &
1709 &              znu(k-1)*phmb
1710           END DO
1711         END DO
1712         DO i=itf,its,-1
1713           phb0(i, kts, j) = 0.0
1714         END DO
1715       END DO
1716     END IF
1717     CALL POPCONTROL1B(branch)
1718     IF (branch .EQ. 0) THEN
1719       DO j=jtf,jts,-1
1720         DO k=kts,ktf-1,1
1721           DO i=itf,its,-1
1722             qvf = 1. + rvovrd*moist(i, k, j, p_qv)
1723             temp5 = pb(i, k, j) + p(i, k, j)
1724             temp4 = temp5/p1000mb
1725             temp3 = t0 + t(i, k, j)
1726             temp3b = r_d*temp4**cvpm*alb0(i, k, j)
1727             tb(i, k, j) = tb(i, k, j) + qvf*temp3b/p1000mb
1728             qvfb = temp3*temp3b/p1000mb
1729             IF (.NOT.(temp4 .LE. 0.0 .AND. (cvpm .EQ. 0.0 .OR. cvpm .NE.&
1730 &                INT(cvpm)))) pb0(i, k, j) = pb0(i, k, j) + cvpm*temp4**(&
1731 &                cvpm-1)*temp3*qvf*r_d*alb0(i, k, j)/p1000mb**2
1732             alb0(i, k, j) = 0.0
1733             moistb(i, k, j, p_qv) = moistb(i, k, j, p_qv) + rvovrd*qvfb
1734             qf2 = 1.
1735             CALL POPREAL8(p(i, k, j))
1736             temp3b0 = -(pb0(i, k, j)/(qf2*rdn(k+1)))
1737             pb0(i, k+1, j) = pb0(i, k+1, j) + pb0(i, k, j)
1738             mub(i, j) = mub(i, j) + temp3b0
1739             qf1b = muts(i, j)*temp3b0
1740             mutsb(i, j) = mutsb(i, j) + qf1*temp3b0
1741             pb0(i, k, j) = 0.0
1742             CALL POPREAL8(qf1)
1743             qtotb = qf2*qf1b
1744             DO ispe=n_moist,param_first_scalar,-1
1745               moistb(i, k, j, ispe) = moistb(i, k, j, ispe) + 0.5*qtotb
1746               moistb(i, k+1, j, ispe) = moistb(i, k+1, j, ispe) + 0.5*&
1747 &                qtotb
1748             END DO
1749           END DO
1750         END DO
1751         CALL POPINTEGER4(k)
1752         DO i=itf,its,-1
1753           qvf = 1. + rvovrd*moist(i, k, j, p_qv)
1754           temp2 = pb(i, k, j) + p(i, k, j)
1755           temp1 = temp2/p1000mb
1756           temp0 = t0 + t(i, k, j)
1757           temp0b = r_d*temp1**cvpm*alb0(i, k, j)
1758           tb(i, k, j) = tb(i, k, j) + qvf*temp0b/p1000mb
1759           qvfb = temp0*temp0b/p1000mb
1760           IF (.NOT.(temp1 .LE. 0.0 .AND. (cvpm .EQ. 0.0 .OR. cvpm .NE. &
1761 &              INT(cvpm)))) pb0(i, k, j) = pb0(i, k, j) + cvpm*temp1**(&
1762 &              cvpm-1)*temp0*qvf*r_d*alb0(i, k, j)/p1000mb**2
1763           alb0(i, k, j) = 0.0
1764           moistb(i, k, j, p_qv) = moistb(i, k, j, p_qv) + rvovrd*qvfb
1765           qf2 = 1.
1766           temp0b0 = -(0.5*pb0(i, k, j)/(rdnw(k)*qf2))
1767           mub(i, j) = mub(i, j) + temp0b0
1768           qf1b = muts(i, j)*temp0b0
1769           mutsb(i, j) = mutsb(i, j) + qf1*temp0b0
1770           pb0(i, k, j) = 0.0
1771           CALL POPREAL8(qf1)
1772           qtotb = qf2*qf1b
1773           DO ispe=n_moist,param_first_scalar,-1
1774             moistb(i, k, j, ispe) = moistb(i, k, j, ispe) + qtotb
1775           END DO
1776         END DO
1777       END DO
1778     ELSE
1779       DO j=jtf,jts,-1
1780         DO k=kts,ktf-1,1
1781           DO i=itf,its,-1
1782             qvf = 1.
1783             temp9 = pb(i, k, j) + p(i, k, j)
1784             temp8 = temp9/p1000mb
1785             temp8b = r_d*qvf*alb0(i, k, j)
1786             tb(i, k, j) = tb(i, k, j) + temp8**cvpm*temp8b/p1000mb
1787             IF (.NOT.(temp8 .LE. 0.0 .AND. (cvpm .EQ. 0.0 .OR. cvpm .NE.&
1788 &                INT(cvpm)))) pb0(i, k, j) = pb0(i, k, j) + cvpm*temp8**(&
1789 &                cvpm-1)*(t0+t(i, k, j))*temp8b/p1000mb**2
1790             alb0(i, k, j) = 0.0
1791             qf2 = 1.
1792             qtot = 0.
1793             qf1 = qtot*qf2
1794             CALL POPREAL8(p(i, k, j))
1795             temp8b0 = -(pb0(i, k, j)/(qf2*rdn(k+1)))
1796             pb0(i, k+1, j) = pb0(i, k+1, j) + pb0(i, k, j)
1797             mub(i, j) = mub(i, j) + temp8b0
1798             mutsb(i, j) = mutsb(i, j) + qf1*temp8b0
1799             pb0(i, k, j) = 0.0
1800           END DO
1801         END DO
1802         CALL POPINTEGER4(k)
1803         DO i=itf,its,-1
1804           qvf = 1.
1805           temp7 = pb(i, k, j) + p(i, k, j)
1806           temp6 = temp7/p1000mb
1807           temp6b = r_d*qvf*alb0(i, k, j)
1808           tb(i, k, j) = tb(i, k, j) + temp6**cvpm*temp6b/p1000mb
1809           IF (.NOT.(temp6 .LE. 0.0 .AND. (cvpm .EQ. 0.0 .OR. cvpm .NE. &
1810 &              INT(cvpm)))) pb0(i, k, j) = pb0(i, k, j) + cvpm*temp6**(&
1811 &              cvpm-1)*(t0+t(i, k, j))*temp6b/p1000mb**2
1812           alb0(i, k, j) = 0.0
1813           qf2 = 1.
1814           qtot = 0.
1815           qf1 = qtot*qf2
1816           temp6b0 = -(0.5*pb0(i, k, j)/(rdnw(k)*qf2))
1817           mub(i, j) = mub(i, j) + temp6b0
1818           mutsb(i, j) = mutsb(i, j) + qf1*temp6b0
1819           pb0(i, k, j) = 0.0
1820         END DO
1821       END DO
1822     END IF
1823   END IF
1824 END SUBROUTINE A_CALC_P_RHO_PHI
1825
1826 !        Generated by TAPENADE     (INRIA, Tropics team)
1827 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
1828 !
1829 !  Differentiation of vpow in reverse (adjoint) mode:
1830 !   gradient     of useful results: y z
1831 !   with respect to varying inputs: y z
1832 SUBROUTINE A_VPOW(z, zb, y, yb, x, n)
1833   IMPLICIT NONE
1834   REAL :: x(*), y(*), z(*)
1835   REAL :: yb(*), zb(*)
1836   INTEGER :: j
1837   INTEGER :: n
1838   DO j=n,1,-1
1839     IF (.NOT.(y(j) .LE. 0.0 .AND. (x(j) .EQ. 0.0 .OR. x(j) .NE. INT(x(j)&
1840 &        )))) yb(j) = yb(j) + x(j)*y(j)**(x(j)-1)*zb(j)
1841     zb(j) = 0.0_8
1842   END DO
1843 END SUBROUTINE A_VPOW
1844
1845    SUBROUTINE a_calc_php(php,a_php,ph,a_ph,phb,ids,ide,jds,jde,kds,kde,ims,ime, &
1846    jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1847
1848 !PART I: DECLARATION OF VARIABLES
1849
1850    IMPLICIT NONE
1851
1852    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
1853    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1854    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: phb,ph,a_ph
1855    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: php,a_php
1856    INTEGER :: i,j,k,itf,jtf,ktf
1857
1858    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002
1859
1860 !PART II: CALCULATIONS OF B. S. TRAJECTORY
1861
1862 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
1863
1864    ! Added by Ning Pan, 2010-07-13
1865    itf =min(ite,ide-1)
1866    jtf =min(jte,jde-1)
1867    ktf =min(kte,kde-1)
1868
1869 !LPB[1]
1870    DO j =jtf, jts, -1
1871
1872 !  DO k =kts, ktf
1873 !  DO i =its, itf
1874 !  Tmpv001 =phb(i,k,j)+phb(i,k+1,j) +ph(i,k,j) +ph(i,k+1,j)
1875 !  Tmpv002 =0.5*Tmpv001
1876 !  php(i,k,j) =Tmpv002
1877
1878 !  ENDDO
1879 !  ENDDO
1880
1881    DO k =ktf, kts, -1
1882    DO i =itf, its, -1
1883    a_Tmpv2 =a_php(i,k,j)
1884    a_php(i,k,j) =0.0
1885    a_Tmpv1 =0.5*a_Tmpv2
1886    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
1887    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
1888    ENDDO
1889    ENDDO
1890
1891    ENDDO
1892
1893 !LPB[0]
1894 !  itf =min(ite, ide-1)
1895 !  jtf =min(jte, jde-1)
1896 !  ktf =min(kte, kde-1)
1897
1898    END SUBROUTINE a_calc_php
1899
1900    SUBROUTINE a_diagnose_w(ph_tend,a_ph_tend,ph_new,a_ph_new,ph_old,a_ph_old,w, &
1901    a_w,mu,a_mu,dt,u,a_u,v,a_v,ht,cf1,cf2,cf3,rdx,rdy,msftx,msfty,ids,ide,jds, &
1902    jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1903
1904 !PART I: DECLARATION OF VARIABLES
1905
1906    IMPLICIT NONE
1907
1908    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
1909    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1910    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ph_tend,a_ph_tend,ph_new,a_ph_new, &
1911    ph_old,a_ph_old,u,a_u,v,a_v
1912    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: w,a_w
1913    REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu,ht,msftx,msfty
1914    REAL :: dt,cf1,cf2,cf3,rdx,rdy
1915    INTEGER :: i,j,k,itf,jtf
1916
1917    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
1918    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, &
1919    Tmpv009,a_Tmpv10,Tmpv010,a_Tmpv11,Tmpv011,a_Tmpv12,Tmpv012,a_Tmpv13,Tmpv013, &
1920    a_Tmpv14,Tmpv014,a_Tmpv15,Tmpv015,a_Tmpv16,Tmpv016,a_Tmpv17,Tmpv017
1921
1922 !PART II: CALCULATIONS OF B. S. TRAJECTORY
1923
1924 !LPB[0]
1925       itf=MIN(ite,ide-1)
1926       jtf=MIN(jte,jde-1)
1927
1928 !!LPB[1]
1929 !      DO j = jts, jtf
1930
1931 !        DO i = its, itf
1932 !            w(i,1,j)=  msfty(i,j)*.5*rdy*(                        &
1933 !                              (ht(i,j+1)-ht(i,j  ))               &
1934 !             *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1))      &
1935 !                             +(ht(i,j  )-ht(i,j-1))               &
1936 !             *(cf1*v(i,1,j  )+cf2*v(i,2,j  )+cf3*v(i,3,j  ))  )   &
1937 !                    +msftx(i,j)*.5*rdx*(                          &
1938 !                              (ht(i+1,j)-ht(i,j  ))               &
1939 !             *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j))      &
1940 !                             +(ht(i,j  )-ht(i-1,j))               &
1941 !             *(cf1*u(i  ,1,j)+cf2*u(i  ,2,j)+cf3*u(i  ,3,j))  )
1942 !        ENDDO
1943
1944 !        DO k = 2, kte
1945 !        DO i = its, itf
1946 !          w(i,k,j) =  msfty(i,j)*(  (ph_new(i,k,j)-ph_old(i,k,j))/dt         &
1947 !                                  - ph_tend(i,k,j)/mu(i,j)        )/g
1948 !        ENDDO
1949 !        ENDDO
1950
1951 !      ENDDO
1952
1953 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
1954
1955 !LPB[1]
1956    DO j =jtf, jts, -1
1957
1958    DO i =its, itf
1959    Tmpv001 =cf1*v(i,1,j+1) +cf2*v(i,2,j+1)
1960    Tmpv002 =Tmpv001 +cf3*v(i,3,j+1)
1961    Tmpv003 =(ht(i,j+1)-ht(i,j))*Tmpv002
1962    Tmpv004 =cf1*v(i,1,j) +cf2*v(i,2,j)
1963    Tmpv005 =Tmpv004 +cf3*v(i,3,j)
1964    Tmpv006 =(ht(i,j)-ht(i,j-1))*Tmpv005
1965    Tmpv007 =Tmpv003 +Tmpv006
1966    Tmpv008 =msfty(i,j)*.5*rdy*Tmpv007
1967    Tmpv009 =cf1*u(i+1,1,j) +cf2*u(i+1,2,j)
1968    Tmpv010 =Tmpv009 +cf3*u(i+1,3,j)
1969    Tmpv011 =(ht(i+1,j)-ht(i,j))*Tmpv010
1970    Tmpv012 =cf1*u(i,1,j) +cf2*u(i,2,j)
1971    Tmpv013 =Tmpv012 +cf3*u(i,3,j)
1972    Tmpv014 =(ht(i,j)-ht(i-1,j))*Tmpv013
1973    Tmpv015 =Tmpv011 +Tmpv014
1974    Tmpv016 =msftx(i,j)*.5*rdx*Tmpv015
1975    Tmpv017 =Tmpv008 +Tmpv016
1976 !  w(i,1,j) =Tmpv017
1977
1978    ENDDO
1979
1980    DO k =2, kte
1981    DO i =its, itf
1982    Tmpv001 =ph_new(i,k,j) -ph_old(i,k,j)
1983    Tmpv002 =Tmpv001/dt
1984    Tmpv003 =ph_tend(i,k,j)/mu(i,j)
1985    Tmpv004 =Tmpv002 -Tmpv003
1986    Tmpv005 =msfty(i,j)*Tmpv004
1987    Tmpv006 =Tmpv005/g
1988 !  w(i,k,j) =Tmpv006
1989
1990    ENDDO
1991    ENDDO
1992
1993    DO k =kte, 2, -1
1994    DO i =itf, its, -1
1995    a_Tmpv6 =a_w(i,k,j)
1996    a_w(i,k,j) =0.0
1997    a_Tmpv5 =a_Tmpv6/g
1998    a_Tmpv4 =msfty(i,j)*a_Tmpv5
1999    a_Tmpv2 =a_Tmpv4
2000    a_Tmpv3 =-a_Tmpv4
2001    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv3/mu(i,j)
2002    a_mu(i,j) =a_mu(i,j) -ph_tend(i,k,j)/(mu(i,j)*mu(i,j))*a_Tmpv3
2003    a_Tmpv1 =a_Tmpv2/dt
2004    a_ph_new(i,k,j) =a_ph_new(i,k,j) +a_Tmpv1
2005    a_ph_old(i,k,j) =a_ph_old(i,k,j) -a_Tmpv1
2006    ENDDO
2007    ENDDO
2008
2009    DO i =itf, its, -1
2010    a_Tmpv17 =a_w(i,1,j)
2011    a_w(i,1,j) =0.0
2012    a_Tmpv8 =a_Tmpv17
2013    a_Tmpv16 =a_Tmpv17
2014    a_Tmpv15 =msftx(i,j)*.5*rdx*a_Tmpv16
2015    a_Tmpv11 =a_Tmpv15
2016    a_Tmpv14 =a_Tmpv15
2017    a_Tmpv13 =(ht(i,j)-ht(i-1,j))*a_Tmpv14
2018    a_Tmpv12 =a_Tmpv13
2019    a_u(i,3,j) =a_u(i,3,j) +cf3*a_Tmpv13
2020    a_u(i,1,j) =a_u(i,1,j) +cf1*a_Tmpv12
2021    a_u(i,2,j) =a_u(i,2,j) +cf2*a_Tmpv12
2022    a_Tmpv10 =(ht(i+1,j)-ht(i,j))*a_Tmpv11
2023    a_Tmpv9 =a_Tmpv10
2024    a_u(i+1,3,j) =a_u(i+1,3,j) +cf3*a_Tmpv10
2025    a_u(i+1,1,j) =a_u(i+1,1,j) +cf1*a_Tmpv9
2026    a_u(i+1,2,j) =a_u(i+1,2,j) +cf2*a_Tmpv9
2027    a_Tmpv7 =msfty(i,j)*.5*rdy*a_Tmpv8
2028    a_Tmpv3 =a_Tmpv7
2029    a_Tmpv6 =a_Tmpv7
2030    a_Tmpv5 =(ht(i,j)-ht(i,j-1))*a_Tmpv6
2031    a_Tmpv4 =a_Tmpv5
2032    a_v(i,3,j) =a_v(i,3,j) +cf3*a_Tmpv5
2033    a_v(i,1,j) =a_v(i,1,j) +cf1*a_Tmpv4
2034    a_v(i,2,j) =a_v(i,2,j) +cf2*a_Tmpv4
2035    a_Tmpv2 =(ht(i,j+1)-ht(i,j))*a_Tmpv3
2036    a_Tmpv1 =a_Tmpv2
2037    a_v(i,3,j+1) =a_v(i,3,j+1) +cf3*a_Tmpv2
2038    a_v(i,1,j+1) =a_v(i,1,j+1) +cf1*a_Tmpv1
2039    a_v(i,2,j+1) =a_v(i,2,j+1) +cf2*a_Tmpv1
2040    ENDDO
2041
2042    ENDDO
2043
2044 !LPB[0]
2045 !  itf =min(ite, ide-1)
2046 !  jtf =min(jte, jde-1)
2047
2048    END SUBROUTINE a_diagnose_w
2049
2050    SUBROUTINE a_rhs_ph(ph_tend,a_ph_tend,u,a_u,v,a_v,ww,a_ww,ph,a_ph,ph_old, &
2051    a_ph_old,phb,w,a_w,mut,a_mut,muu,a_muu,muv,a_muv,fnm,fnp,rdnw,cfn,cfn1,rdx, &
2052    rdy,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,non_hydrostatic,config_flags,ids, &
2053    ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2054
2055 !PART I: DECLARATION OF VARIABLES
2056
2057    IMPLICIT NONE
2058
2059    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
2060    TYPE(grid_config_rec_type) :: config_flags
2061    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
2062    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,a_u,v,a_v,ww,a_ww,ph,a_ph, &
2063    ph_old,a_ph_old,phb,w,a_w
2064    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ph_tend,a_ph_tend
2065    REAL,DIMENSION(ims:ime,jms:jme) :: muu,a_muu,muv,a_muv,mut,a_mut,msfux,msfuy, &
2066    msfvx,msfvy,msftx,msfty,msfvx_inv
2067    REAL,DIMENSION(kms:kme) :: rdnw,fnm,fnp
2068    REAL :: cfn,cfn1,rdx,rdy
2069    LOGICAL :: non_hydrostatic
2070    INTEGER :: i,j,k,itf,jtf,ktf,kz,i_start,j_start
2071    REAL :: ur,a_ur,ul,a_ul,ub,a_ub,vr,a_vr,vl,a_vl,vb,a_vb
2072    REAL,DIMENSION(its:ite,kts:kte) :: wdwn,a_wdwn
2073    INTEGER :: advective_order
2074    LOGICAL :: specified
2075
2076    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
2077    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, &
2078    Tmpv009,a_Tmpv10,Tmpv010,a_Tmpv11,Tmpv011,a_Tmpv12,Tmpv012,a_Tmpv13,Tmpv013, &
2079    a_Tmpv14,Tmpv014,a_Tmpv15,Tmpv015,a_Tmpv16,Tmpv016,a_Tmpv17,Tmpv017, &
2080    a_Tmpv18,Tmpv018,a_Tmpv19,Tmpv019,a_Tmpv20,Tmpv020,a_Tmpv21,Tmpv021
2081 !REVISED BY WALLS
2082    REAL,DIMENSION(min0(its,jts):max0(MAX(ite,ide-1),MAX(jte,jde-1))) :: Tmpv200
2083    REAL,DIMENSION(min0(its,jts):max0(MAX(ite,ide-1),MAX(jte,jde-1))) :: Tmpv201
2084    REAL,DIMENSION(min0(its,jts):max0(MAX(ite,ide-1),MAX(jte,jde-1))) :: Tmpv202
2085    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv203
2086    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv204
2087    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv205
2088    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv206
2089    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv207
2090    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv208
2091    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv209
2092    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2010
2093    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2011
2094    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2012
2095    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2013
2096    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2014
2097    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2015
2098    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2016
2099    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2017
2100    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2018
2101    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2019
2102    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2020
2103    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2021
2104    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2022
2105    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2023
2106    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2024
2107    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2025
2108    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2026
2109    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2027
2110    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2028
2111    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2029
2112    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2030
2113    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2031
2114    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2032
2115    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2033
2116    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2034
2117    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2035
2118    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2036
2119    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2037
2120    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2038
2121    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2039
2122    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2040
2123    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2041
2124    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2042
2125    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv2043
2126    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2044
2127    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2045
2128    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2046
2129    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2047
2130    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2048
2131    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2049
2132    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2050
2133    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2051
2134    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2052
2135    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2053
2136    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2054
2137    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2055
2138    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2056
2139    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2057
2140    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2058
2141    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2059
2142    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2060
2143    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2061
2144    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2062
2145    REAL,DIMENSION(jts:MAX(jte,jde-1)) :: Tmpv2063
2146    REAL,DIMENSION(min0(its,2):max0(MAX(ite,ide-1),kde-1),min0(2,jts+1,jts) &
2147    :max0(kte,MAX(jte,jde-1)-2,kde,MAX(jte,jde-1))) :: Tmpv300
2148    REAL,DIMENSION(min0(its,2):max0(MAX(ite,ide-1),kde-1),min0(2,jts+1,jts) &
2149    :max0(kte,MAX(jte,jde-1)-2,kde,MAX(jte,jde-1))) :: Tmpv301
2150    REAL,DIMENSION(min0(its,2):max0(MAX(ite,ide-1),kde-1),min0(jts+1,2,jts) &
2151    :max0(MAX(jte,jde-1)-2,kde,MAX(jte,jde-1))) :: Tmpv302
2152    REAL,DIMENSION(its:MAX(ite,ide-1),jts+1:MAX(jte,jde-1)) :: Tmpv303
2153    REAL,DIMENSION(its:MAX(ite,ide-1),jts+1:MAX(jte,jde-1)) :: Tmpv304
2154    REAL,DIMENSION(its:MAX(ite,ide-1),jts+1:MAX(jte,jde-1)) :: Tmpv305
2155    REAL,DIMENSION(its+1:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv306
2156    REAL,DIMENSION(its+1:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv307
2157    REAL,DIMENSION(its+1:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv308
2158    REAL,DIMENSION(its+1:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv309
2159    REAL,DIMENSION(its+1:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3010
2160    REAL,DIMENSION(its+1:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3011
2161    REAL,DIMENSION(its:MAX(ite,ide-1),jts+2:MAX(jte,jde-1)) :: Tmpv3012
2162    REAL,DIMENSION(its:MAX(ite,ide-1),jts+2:MAX(jte,jde-1)) :: Tmpv3013
2163    REAL,DIMENSION(its:MAX(ite,ide-1),jts+2:MAX(jte,jde-1)) :: Tmpv3014
2164    REAL,DIMENSION(its:MAX(ite,ide-1),jts+2:MAX(jte,jde-1)) :: Tmpv3015
2165    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3016
2166    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3017
2167    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3018
2168    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3019
2169    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3020
2170    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3021
2171    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3022
2172    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3023
2173    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3024
2174    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3025
2175    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3026
2176    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3027
2177    REAL,DIMENSION(its+2:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3028
2178    REAL,DIMENSION(its+2:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3029
2179    REAL,DIMENSION(its+2:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3030
2180    REAL,DIMENSION(its+2:MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3031
2181    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3032
2182    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3033
2183    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3034
2184    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3035
2185    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3036
2186    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3037
2187    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3038
2188    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3039
2189    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3040
2190    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3041
2191    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3042
2192    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3043
2193    REAL,DIMENSION(its:MAX(ite,ide-1),MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv3044
2194    REAL,DIMENSION(its:MAX(ite,ide-1),MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv3045
2195    REAL,DIMENSION(its:MAX(ite,ide-1),MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv3046
2196    REAL,DIMENSION(its:MAX(ite,ide-1),MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv3047
2197    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3048
2198    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3049
2199    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3050
2200    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3051
2201    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3052
2202    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3053
2203    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3054
2204    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3055
2205    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3056
2206    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3057
2207    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3058
2208    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3059
2209    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3060
2210    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3061
2211    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3062
2212    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3063
2213    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3064
2214    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3065
2215    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3066
2216    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1) :: Tmpv3067
2217    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3068
2218    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3069
2219    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3070
2220    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),jts:MAX(jte,jde-1)) :: Tmpv3071
2221    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3072
2222    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3073
2223    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3074
2224    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3075
2225    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3076
2226    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3077
2227    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3078
2228    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3079
2229    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3080
2230    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3081
2231    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3082
2232    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3083
2233    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3084
2234    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3085
2235    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3086
2236    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3087
2237    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3088
2238    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3089
2239    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3090
2240    REAL,DIMENSION(2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv3091
2241    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+1:MAX(jte,jde-1)) :: Tmpv400
2242    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+1:MAX(jte,jde-1)) :: Tmpv401
2243    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+1:MAX(jte,jde-1)) :: Tmpv402
2244    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+1:MAX(jte,jde-1)) :: Tmpv403
2245    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+1:MAX(jte,jde-1)) :: Tmpv404
2246    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+1:MAX(jte,jde-1)) :: Tmpv405
2247    REAL,DIMENSION(its+1:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv406
2248    REAL,DIMENSION(its+1:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv407
2249    REAL,DIMENSION(its+1:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv408
2250    REAL,DIMENSION(its+1:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv409
2251    REAL,DIMENSION(its+1:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4010
2252    REAL,DIMENSION(its+1:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4011
2253    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+2:MAX(jte,jde-1)) :: Tmpv4012
2254    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+2:MAX(jte,jde-1)) :: Tmpv4013
2255    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+2:MAX(jte,jde-1)) :: Tmpv4014
2256    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,jts+2:MAX(jte,jde-1)) :: Tmpv4015
2257    REAL,DIMENSION(its+2:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4016
2258    REAL,DIMENSION(its+2:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4017
2259    REAL,DIMENSION(its+2:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4018
2260    REAL,DIMENSION(its+2:MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4019
2261    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv4020
2262    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv4021
2263    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv4022
2264    REAL,DIMENSION(its:MAX(ite,ide-1),2:kte-1,MIN(jts,jds+3):MAX(jte,jde-1)) :: Tmpv4023
2265    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4024
2266    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4025
2267    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4026
2268    REAL,DIMENSION(MIN(its,ids+3):MAX(ite,ide-1),2:kte-1,jts:MAX(jte,jde-1)) :: Tmpv4027
2269
2270 !PART II: CALCULATIONS OF B. S. TRAJECTORY
2271
2272 !LPB[0]
2273       specified = .false.
2274
2275 !LPB[1]
2276    if(config_flags%specified .or. config_flags%nested) specified = .true.
2277
2278 !LPB[2]
2279       advective_order = config_flags%h_sca_adv_order
2280       itf=MIN(ite,ide-1)
2281       jtf=MIN(jte,jde-1)
2282       ktf=MIN(kte,kde-1)
2283
2284 ! Remarked by Ning Pan, 2010-07-20: LPB[3]-LPB[14] are useless
2285 !!LPB[3]
2286 !      DO j = jts, jtf
2287
2288 !        DO k = 2, kte
2289 !        DO i = its, itf
2290 !             wdwn(i,k) = .5*(ww(i,k,j)+ww(i,k-1,j))*rdnw(k-1)                 &
2291 !                           *(ph(i,k,j)-ph(i,k-1,j)+phb(i,k,j)-phb(i,k-1,j))
2292 !        ENDDO
2293 !        ENDDO
2294
2295 !        DO k = 2, kte-1
2296 !        DO i = its, itf
2297 !              ph_tend(i,k,j) = ph_tend(i,k,j)                             &
2298 !                                - (fnm(k)*wdwn(i,k+1)+fnp(k)*wdwn(i,k))
2299 !        ENDDO
2300 !        ENDDO
2301
2302 !      ENDDO
2303
2304 !LPB[4]
2305
2306 !LPB[5]
2307 !   IF (non_hydrostatic) THEN
2308
2309 !      DO j = jts, jtf
2310 !        DO i = its, itf
2311 !           ph_tend(i,kde,j) = 0.
2312 !        ENDDO
2313
2314 !        DO k = 2, kte
2315 !        DO i = its, itf
2316 !           ph_tend(i,k,j) = ph_tend(i,k,j) + mut(i,j)*g*w(i,k,j)/msfty(i,j)
2317 !        ENDDO
2318 !        ENDDO
2319 !      ENDDO
2320
2321 !   END IF
2322
2323 !LPB[6]
2324
2325 !LPB[7]
2326
2327 !   IF (advective_order <= 2) THEN
2328
2329 !      i_start = its
2330 !      j_start = jts
2331 !      itf=MIN(ite,ide-1)
2332 !      jtf=MIN(jte,jde-1)
2333 !   IF ( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start = jts+1
2334
2335 !   IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jtf-2
2336
2337 !      DO j = j_start, jtf
2338 !        DO k = 2, kte-1
2339 !        DO i = i_start, itf
2340 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*            &
2341 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*     &
2342 !                     (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))     &
2343 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*     &
2344 !                     (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
2345 !        ENDDO
2346 !        ENDDO
2347 !        k = kte
2348
2349 !        DO i = i_start, itf
2350 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                         &
2351 !!     &
2352 !                     ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2353 !   *      &
2354 !                      (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))                &
2355 !!     &
2356 !                      +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) &
2357 !   *      &
2358 !                      (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
2359 !        ENDDO
2360 !      ENDDO
2361 !      i_start = its
2362 !      j_start = jts
2363 !      itf=MIN(ite,ide-1)
2364 !      jtf=MIN(jte,jde-1)
2365 !   IF ( (config_flags%open_xs .or. specified) .and. its == ids ) i_start = its+1
2366
2367 !   IF ( (config_flags%open_xe .or. specified) .and. ite == ide ) itf = itf-2
2368
2369 !      DO j = j_start, jtf
2370 !        DO k = 2, kte-1
2371 !        DO i = i_start, itf
2372 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*           &
2373 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*    &
2374 !                     (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))    &
2375 !                     +muu(i  ,j)*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*    &
2376 !                     (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2377 !        ENDDO
2378 !        ENDDO
2379 !        k = kte
2380
2381 !        DO i = i_start, itf
2382 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                         &
2383 !!     &
2384 !                     ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2385 !   *      &
2386 !                      (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))                &
2387 !!     &
2388 !                      +muu(i  ,j)*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j) &
2389 !   *      &
2390 !                      (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2391 !        ENDDO
2392 !      ENDDO
2393 !      ELSE IF (advective_order <= 4) THEN
2394 !      i_start = its
2395 !      j_start = jts
2396 !      itf=MIN(ite,ide-1)
2397 !      jtf=MIN(jte,jde-1)
2398 !   IF ( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start = jts+2
2399
2400 !   IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jtf-3
2401
2402 !      DO j = j_start, jtf
2403 !        DO k = 2, kte-1
2404 !        DO i = i_start, itf
2405 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*(                       &
2406 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                  &
2407 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  ))* (1./12.) &
2408 !   *(     &
2409 !                       8.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2410 !                         -(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2411 !                      +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2412 !                         -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
2413 !        ENDDO
2414 !        ENDDO
2415 !        k = kte
2416
2417 !        DO i = i_start, itf
2418 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*(                        &
2419 !!               &
2420 !                    ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2421 !!                     &
2422 !                     +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  )) &
2423 !   * (1./12.)*(     &
2424 !                       8.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2425 !!               &
2426 !                         -(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2427 !!               &
2428 !                      +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2429 !!               &
2430 !                         -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
2431 !        ENDDO
2432 !      ENDDO
2433 !   IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+1 )  THEN
2434
2435 !        j = jds+1
2436
2437 !        DO k = 2, kte-1
2438 !        DO i = i_start, itf
2439 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*            &
2440 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*     &
2441 !                     (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))     &
2442 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*     &
2443 !                     (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
2444 !        ENDDO
2445 !        ENDDO
2446 !        k = kte
2447
2448 !        DO i = i_start, itf
2449 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                         &
2450 !!     &
2451 !                     ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2452 !   *      &
2453 !                      (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))                &
2454 !!     &
2455 !                      +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) &
2456 !   *      &
2457 !                      (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
2458 !        ENDDO
2459 !      END IF
2460 !   IF ( (config_flags%open_ye .or. specified) .and. jte >= jde-2 )  THEN
2461
2462 !        j = jde-2
2463
2464 !        DO k = 2, kte-1
2465 !        DO i = i_start, itf
2466 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*            &
2467 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*     &
2468 !                     (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))     &
2469 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*     &
2470 !                     (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
2471 !        ENDDO
2472 !        ENDDO
2473 !        k = kte
2474
2475 !        DO i = i_start, itf
2476 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                         &
2477 !!     &
2478 !                     ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2479 !   *      &
2480 !                      (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))                &
2481 !!     &
2482 !                      +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) &
2483 !   *      &
2484 !                      (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
2485 !        ENDDO
2486 !      END IF
2487 !      i_start = its
2488 !      j_start = jts
2489 !      itf=MIN(ite,ide-1)
2490 !      jtf=MIN(jte,jde-1)
2491 !   IF ( (config_flags%open_xs) .and. its == ids ) i_start = its+2
2492
2493 !   IF ( (config_flags%open_xe) .and. ite == ide ) itf = itf-3
2494
2495 !      DO j = j_start, jtf
2496 !        DO k = 2, kte-1
2497 !        DO i = i_start, itf
2498 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                      &
2499 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)                 &
2500 !                     +muu(i,j  )*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j) )* (1./12.)*(   &
2501 !                       8.*(ph(i+1,k,j)-ph(i-1,k,j))                                     &
2502 !                         -(ph(i+2,k,j)-ph(i-2,k,j))                                     &
2503 !                      +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                   &
2504 !                         -(phb(i+2,k,j)-phb(i-2,k,j))  )   )
2505 !        ENDDO
2506 !        ENDDO
2507 !        k = kte
2508
2509 !        DO i = i_start, itf
2510 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                        &
2511 !!               &
2512 !                    ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2513 !!                     &
2514 !                     +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(i  ,j) ) &
2515 !   * (1./12.)*(    &
2516 !                       8.*(ph(i+1,k,j)-ph(i-1,k,j))                                      &
2517 !!               &
2518 !                         -(ph(i+2,k,j)-ph(i-2,k,j))                                      &
2519 !!               &
2520 !                      +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                    &
2521 !!               &
2522 !                         -(phb(i+2,k,j)-phb(i-2,k,j))  )     )
2523 !        ENDDO
2524 !      ENDDO
2525 !   IF ( (config_flags%open_xs .or. specified) .and. its <= ids+1 ) THEN
2526
2527 !        i = ids + 1
2528
2529 !        DO j = j_start, jtf
2530 !        DO k = 2, kte-1
2531 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*           &
2532 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*    &
2533 !                     (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))    &
2534 !                     +muu(i  ,j)*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*    &
2535 !                     (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2536 !        ENDDO
2537 !        ENDDO
2538 !        k = kte
2539
2540 !        DO j = j_start, jtf
2541 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                         &
2542 !!     &
2543 !                     ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2544 !   *      &
2545 !                      (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))                &
2546 !!     &
2547 !                      +muu(i  ,j)*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j) &
2548 !   *      &
2549 !                      (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2550 !        ENDDO
2551 !      END IF
2552 !   IF ( (config_flags%open_xe .or. specified) .and. ite >= ide-2 ) THEN
2553
2554 !        i = ide-2
2555
2556 !        DO j = j_start, jtf
2557 !        DO k = 2, kte-1
2558 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*           &
2559 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*    &
2560 !                     (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))    &
2561 !                     +muu(i  ,j)*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*    &
2562 !                     (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2563 !        ENDDO
2564 !        ENDDO
2565 !        k = kte
2566
2567 !        DO j = j_start, jtf
2568 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                         &
2569 !!     &
2570 !                     ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2571 !   *      &
2572 !                      (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))                &
2573 !!     &
2574 !                      +muu(i  ,j)*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j) &
2575 !   *      &
2576 !                      (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2577 !        ENDDO
2578 !      END IF
2579 !      ELSE IF (advective_order <= 6) THEN
2580 !      i_start = its
2581 !      j_start = jts
2582 !      itf=MIN(ite,ide-1)
2583 !      jtf=MIN(jte,jde-1)
2584 !   IF (config_flags%open_ys .or. specified ) j_start = max(jts,jds+3)
2585
2586 !   IF (config_flags%open_ye .or. specified ) jtf     = min(jtf,jde-4)
2587
2588 !      DO j = j_start, jtf
2589 !        DO k = 2, kte-1
2590 !        DO i = i_start, itf
2591 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                      &
2592 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                  &
2593 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  ) )* (1./60.) &
2594 !   *(    &
2595 !                      45.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2596 !                      -9.*(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2597 !                         +(ph(i,k,j+3)-ph(i,k,j-3))                                      &
2598 !                     +45.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2599 !                      -9.*(phb(i,k,j+2)-phb(i,k,j-2))                                    &
2600 !                         +(phb(i,k,j+3)-phb(i,k,j-3))  )   )
2601 !        ENDDO
2602 !        ENDDO
2603 !        k = kte
2604
2605 !        DO i = i_start, itf
2606 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* (                       &
2607 !!               &
2608 !                    ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2609 !!                     &
2610 !                     +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) ) &
2611 !   * (1./60.)*(    &
2612 !                      45.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2613 !!               &
2614 !                      -9.*(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2615 !!               &
2616 !                         +(ph(i,k,j+3)-ph(i,k,j-3))                                      &
2617 !!               &
2618 !                     +45.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2619 !!               &
2620 !                      -9.*(phb(i,k,j+2)-phb(i,k,j-2))                                    &
2621 !!               &
2622 !                         +(phb(i,k,j+3)-phb(i,k,j-3))  )   )
2623 !        ENDDO
2624 !      ENDDO
2625 !   IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte ) &
2626 !  THEN
2627
2628 !        j = jds+2
2629
2630 !        DO k = 2, kte-1
2631 !        DO i = i_start, itf
2632 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                      &
2633 !!     &
2634 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                  &
2635 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  ) )* (1./12.) &
2636 !   *(    &
2637 !                       8.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2638 !                         -(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2639 !                      +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2640 !                         -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
2641 !        ENDDO
2642 !        ENDDO
2643 !        k = kte
2644
2645 !        DO i = i_start, itf
2646 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* (                       &
2647 !!             &
2648 !                    ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2649 !!                   &
2650 !                     +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j) ) &
2651 !   * (1./12.)*(    &
2652 !                       8.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2653 !!             &
2654 !                         -(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2655 !!             &
2656 !                      +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2657 !!             &
2658 !                         -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
2659 !        ENDDO
2660 !      END IF
2661 !   IF ( (config_flags%open_ye .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte ) &
2662 !  THEN
2663
2664 !        j = jde-3
2665
2666 !        DO k = 2, kte-1
2667 !        DO i = i_start, itf
2668 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                    &
2669 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
2670 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j) )* (1./12.)*(    &
2671 !                       8.*(ph(i,k,j+1)-ph(i,k,j-1))                                    &
2672 !                         -(ph(i,k,j+2)-ph(i,k,j-2))                                    &
2673 !                      +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                  &
2674 !                         -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
2675 !        ENDDO
2676 !        ENDDO
2677 !        k = kte
2678
2679 !        DO i = i_start, itf
2680 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* (                       &
2681 !!             &
2682 !                    ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2683 !!                   &
2684 !                     +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j) ) &
2685 !   * (1./12.)*(    &
2686 !                       8.*(ph(i,k,j+1)-ph(i,k,j-1))                                      &
2687 !!             &
2688 !                         -(ph(i,k,j+2)-ph(i,k,j-2))                                      &
2689 !!             &
2690 !                      +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                    &
2691 !!             &
2692 !                         -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
2693 !        ENDDO
2694 !      END IF
2695 !   IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte ) &
2696 !  THEN
2697
2698 !        j = jds+1
2699
2700 !        DO k = 2, kte-1
2701 !        DO i = i_start, itf
2702 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*            &
2703 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*     &
2704 !                     (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))     &
2705 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*     &
2706 !                     (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
2707 !        ENDDO
2708 !        ENDDO
2709 !        k = kte
2710
2711 !        DO i = i_start, itf
2712 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                         &
2713 !!     &
2714 !                     ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2715 !   *      &
2716 !                      (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))                &
2717 !!     &
2718 !                      +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) &
2719 !   *      &
2720 !                      (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
2721 !        ENDDO
2722 !      END IF
2723 !   IF ( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte ) &
2724 !  THEN
2725
2726 !        j = jde-2
2727
2728 !        DO k = 2, kte-1
2729 !        DO i = i_start, itf
2730 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*            &
2731 !                    ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*     &
2732 !                     (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))     &
2733 !                     +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*     &
2734 !                     (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
2735 !        ENDDO
2736 !        ENDDO
2737 !        k = kte
2738
2739 !        DO i = i_start, itf
2740 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                         &
2741 !!     &
2742 !                     ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) &
2743 !   *      &
2744 !                      (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))                &
2745 !!     &
2746 !                      +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) &
2747 !   *      &
2748 !                      (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
2749 !        ENDDO
2750 !      END IF
2751 !      i_start = its
2752 !      j_start = jts
2753 !      itf=MIN(ite,ide-1)
2754 !      jtf=MIN(jte,jde-1)
2755 !   IF (config_flags%open_xs .or. specified ) i_start = max(its,ids+3)
2756
2757 !   IF (config_flags%open_xe .or. specified ) itf     = min(itf,ide-4)
2758
2759 !      DO j = j_start, jtf
2760 !        DO k = 2, kte-1
2761 !        DO i = i_start, itf
2762 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                     &
2763 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)                &
2764 !                     +muu(i,j  )*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,j) )* (1./60.)*(    &
2765 !                      45.*(ph(i+1,k,j)-ph(i-1,k,j))                                    &
2766 !                      -9.*(ph(i+2,k,j)-ph(i-2,k,j))                                    &
2767 !                         +(ph(i+3,k,j)-ph(i-3,k,j))                                    &
2768 !                     +45.*(phb(i+1,k,j)-phb(i-1,k,j))                                  &
2769 !                      -9.*(phb(i+2,k,j)-phb(i-2,k,j))                                  &
2770 !                         +(phb(i+3,k,j)-phb(i-3,k,j))  )   )
2771 !        ENDDO
2772 !        ENDDO
2773 !        k = kte
2774
2775 !        DO i = i_start, itf
2776 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                        &
2777 !!           &
2778 !                    ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2779 !!                 &
2780 !                     +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) ) &
2781 !   * (1./60.)*(    &
2782 !                      45.*(ph(i+1,k,j)-ph(i-1,k,j))                                      &
2783 !!           &
2784 !                      -9.*(ph(i+2,k,j)-ph(i-2,k,j))                                      &
2785 !!           &
2786 !                         +(ph(i+3,k,j)-ph(i-3,k,j))                                      &
2787 !!           &
2788 !                     +45.*(phb(i+1,k,j)-phb(i-1,k,j))                                    &
2789 !!           &
2790 !                      -9.*(phb(i+2,k,j)-phb(i-2,k,j))                                    &
2791 !!           &
2792 !                         +(phb(i+3,k,j)-phb(i-3,k,j))  )     )
2793 !        ENDDO
2794 !      ENDDO
2795 !   IF ( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN
2796
2797 !        i = ids + 2
2798
2799 !        DO j = j_start, jtf
2800 !          DO k = 2, kte-1
2801 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                     &
2802 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)                &
2803 !                     +muu(i,j  )*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,j) )* (1./12.)*(    &
2804 !                       8.*(ph(i+1,k,j)-ph(i-1,k,j))                                    &
2805 !                         -(ph(i+2,k,j)-ph(i-2,k,j))                                    &
2806 !                      +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                  &
2807 !                         -(phb(i+2,k,j)-phb(i-2,k,j))  )   )
2808 !          ENDDO
2809 !          k = kte
2810 !          ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                         &
2811 !!          &
2812 !                   ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2813 !!                 &
2814 !                    +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) ) &
2815 !   * (1./12.)*(    &
2816 !                      8.*(ph(i+1,k,j)-ph(i-1,k,j))                                       &
2817 !!          &
2818 !                        -(ph(i+2,k,j)-ph(i-2,k,j))                                       &
2819 !!          &
2820 !                     +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                     &
2821 !!          &
2822 !                        -(phb(i+2,k,j)-phb(i-2,k,j))  )     )
2823 !        ENDDO
2824 !      END IF
2825 !   IF ( (config_flags%open_xe) .and. its <= ide-3 .and. ide-3 <= ite ) THEN
2826
2827 !        i = ide-3
2828
2829 !        DO j = j_start, jtf
2830 !          DO k = 2, kte-1
2831 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                     &
2832 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)                &
2833 !                     +muu(i,j  )*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,j) )* (1./12.)*(    &
2834 !                       8.*(ph(i+1,k,j)-ph(i-1,k,j))                                    &
2835 !                         -(ph(i+2,k,j)-ph(i-2,k,j))                                    &
2836 !                      +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                  &
2837 !                         -(phb(i+2,k,j)-phb(i-2,k,j))  )   )
2838 !          ENDDO
2839 !          k = kte
2840 !          ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                         &
2841 !!          &
2842 !                   ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2843 !!                 &
2844 !                    +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) ) &
2845 !   * (1./12.)*(    &
2846 !                      8.*(ph(i+1,k,j)-ph(i-1,k,j))                                       &
2847 !!          &
2848 !                        -(ph(i+2,k,j)-ph(i-2,k,j))                                       &
2849 !!          &
2850 !                     +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                     &
2851 !!          &
2852 !                        -(phb(i+2,k,j)-phb(i-2,k,j))  )     )
2853 !        ENDDO
2854 !      END IF
2855 !   IF ( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) &
2856 ! THEN
2857
2858 !        i = ids + 1
2859
2860 !        DO j = j_start, jtf
2861 !        DO k = 2, kte-1
2862 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*           &
2863 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*    &
2864 !                     (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))    &
2865 !                     +muu(i  ,j)*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*    &
2866 !                     (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2867 !        ENDDO
2868 !        ENDDO
2869 !        k = kte
2870
2871 !        DO j = j_start, jtf
2872 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                         &
2873 !!     &
2874 !                     ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2875 !   *      &
2876 !                      (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))                &
2877 !!     &
2878 !                      +muu(i  ,j)*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j) &
2879 !   *      &
2880 !                      (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2881 !        ENDDO
2882 !      END IF
2883 !   IF ( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) &
2884 ! THEN
2885
2886 !        i = ide-2
2887
2888 !        DO j = j_start, jtf
2889 !        DO k = 2, kte-1
2890 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*           &
2891 !                    ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*    &
2892 !                     (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))    &
2893 !                     +muu(i  ,j)*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*    &
2894 !                     (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2895 !        ENDDO
2896 !        ENDDO
2897 !        k = kte
2898
2899 !        DO j = j_start, jtf
2900 !           ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                         &
2901 !!     &
2902 !                     ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) &
2903 !   *      &
2904 !                      (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))                &
2905 !!     &
2906 !                      +muu(i  ,j)*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j) &
2907 !   *      &
2908 !                      (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2909 !        ENDDO
2910 !      END IF
2911
2912 !   END IF
2913
2914 !LPB[8]
2915
2916 !      i_start = its
2917 !      itf=MIN(ite,ide-1)
2918
2919 !LPB[9]
2920 !   IF ( (config_flags%open_ys) .and. jts == jds ) THEN
2921
2922 !        j=jts
2923
2924 !        DO k=2,kde
2925 !          kz = min(k,kde-1)
2926
2927 !          DO i = its,itf
2928 !            vb =.5*( fnm(kz)*(v(i,kz  ,j+1)+v(i,kz  ,j  ))      &
2929 !                    +fnp(kz)*(v(i,kz-1,j+1)+v(i,kz-1,j  )) )
2930 !            vl=amin1(vb,0.)
2931 !            ph_tend(i,k,j)=ph_tend(i,k,j)-rdy*mut(i,j)*(        &
2932 !                                 +vl*(ph_old(i,k,j+1)-ph_old(i,k,j)))
2933 !          ENDDO
2934 !        ENDDO
2935
2936 !   END IF
2937
2938 !LPB[10]
2939
2940 !LPB[11]
2941
2942 !   IF ( (config_flags%open_ye) .and. jte == jde ) THEN
2943
2944 !        j=jte-1
2945
2946 !        DO k=2,kde
2947 !          kz = min(k,kde-1)
2948
2949 !          DO i = its,itf
2950 !           vb=.5*( fnm(kz)*(v(i,kz  ,j+1)+v(i,kz  ,j))     &
2951 !                  +fnp(kz)*(v(i,kz-1,j+1)+v(i,kz-1,j)) )
2952 !           vr=amax1(vb,0.)
2953 !           ph_tend(i,k,j)=ph_tend(i,k,j)-rdy*mut(i,j)*(        &
2954 !                      +vr*(ph_old(i,k,j)-ph_old(i,k,j-1)))
2955 !          ENDDO
2956 !        ENDDO
2957
2958 !   END IF
2959
2960 !LPB[12]
2961
2962 !      j_start = its
2963 !      jtf=MIN(jte,jde-1)
2964
2965 !LPB[13]
2966 !   IF ( (config_flags%open_xs) .and. its == ids ) THEN
2967
2968 !        i=its
2969
2970 !        DO j = jts,jtf
2971 !          DO k=2,kde-1
2972 !            kz = k
2973 !            ub =.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i  ,kz  ,j))       &
2974 !                    +fnp(kz)*(u(i+1,kz-1,j)+u(i  ,kz-1,j)) )
2975 !            ul=amin1(ub,0.)
2976 !            ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*mut(i,j) &
2977 !   *(         &
2978 !                                 +ul*(ph_old(i+1,k,j)-ph_old(i,k,j)))
2979 !          ENDDO
2980 !            k = kde
2981 !            kz = k
2982 !            ub =.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i  ,kz  ,j))       &
2983 !                    +fnp(kz)*(u(i+1,kz-1,j)+u(i  ,kz-1,j)) )
2984 !            ul=amin1(ub,0.)
2985 !            ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*mut(i,j) &
2986 !   *(         &
2987 !                                 +ul*(ph_old(i+1,k,j)-ph_old(i,k,j)))
2988 !        ENDDO
2989
2990 !   END IF
2991
2992 !!LPB[14]
2993
2994 !!LPB[15]
2995 !
2996 !   IF ( (config_flags%open_xe) .and. ite == ide ) THEN
2997
2998 !        i = ite-1
2999
3000 !        DO j = jts,jtf
3001 !          DO k=2,kde-1
3002 !           kz = k
3003 !           ub=.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i,kz  ,j))    &
3004 !                  +fnp(kz)*(u(i+1,kz-1,j)+u(i,kz-1,j)) )
3005 !           ur=amax1(ub,0.)
3006 !           ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*(   &
3007 !                      +ur*(ph_old(i,k,j)-ph_old(i-1,k,j)))
3008 !          ENDDO
3009 !           k = kde
3010 !           kz = k-1
3011 !           ub=.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i,kz  ,j))     &
3012 !                  +fnp(kz)*(u(i+1,kz-1,j)+u(i,kz-1,j)) )
3013 !           ur=amax1(ub,0.)
3014 !           ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*(    &
3015 !                      +ur*(ph_old(i,k,j)-ph_old(i-1,k,j)))
3016 !        ENDDO
3017
3018 !   END IF
3019
3020 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
3021
3022    a_ur =0.0
3023    a_ul =0.0
3024    a_ub =0.0
3025    a_vr =0.0
3026    a_vl =0.0
3027    a_vb =0.0
3028
3029    Do K1_ADJ =kts, kte
3030    Do K0_ADJ =its, ite
3031    a_wdwn(K0_ADJ,K1_ADJ) =0.0
3032    End Do
3033    End Do
3034
3035 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
3036
3037 ! Added by Ning Pan, 2010-07-20
3038    j_start =its
3039    jtf =min(jte, jde-1)
3040
3041 !LPB[15]
3042    IF( (config_flags%open_xe) .and. ite == ide ) THEN
3043    i =ite-1
3044    DO j =jts, jtf
3045    DO k =2, kde-1
3046    kz =k
3047    Tmpv001 =u(i+1,kz,j) +u(i,kz,j)
3048    Tmpv002 =fnm(kz)*Tmpv001
3049    Tmpv003 =u(i+1,kz-1,j) +u(i,kz-1,j)
3050    Tmpv004 =fnp(kz)*Tmpv003
3051    Tmpv005 =Tmpv002 +Tmpv004
3052    Tmpv006 =.5*Tmpv005
3053    ub =Tmpv006  ! Removed remark by Ning Pan, 2010-07-20
3054
3055 ! Revised by Ning Pan, 2010-07-20
3056 !   Tmpv300(k,j) =ur
3057 !   ur =max(ub, 0.)
3058    Tmpv300(k,j) =ub
3059    ur =amax1(ub, 0.)
3060
3061    Tmpv001 =ph_old(i,k,j) -ph_old(i-1,k,j)
3062    Tmpv301(k,j) =Tmpv001
3063    Tmpv002 =ur*Tmpv301(k,j)
3064    Tmpv302(k,j) =+Tmpv002
3065 !   Tmpv003 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*Tmpv302(k,j)  ! Remarked by Ning Pan, 2010-07-20
3066 !   Tmpv004 =ph_tend(i,k,j) -Tmpv003  ! Remarked by Ning Pan, 2010-07-20
3067 !  ph_tend(i,k,j) =Tmpv004
3068
3069    ENDDO
3070    k =kde
3071    kz =k-1
3072    Tmpv001 =u(i+1,kz,j) +u(i,kz,j)
3073    Tmpv002 =fnm(kz)*Tmpv001
3074    Tmpv003 =u(i+1,kz-1,j) +u(i,kz-1,j)
3075    Tmpv004 =fnp(kz)*Tmpv003
3076    Tmpv005 =Tmpv002 +Tmpv004
3077    Tmpv006 =.5*Tmpv005
3078    ub =Tmpv006  ! Removed remark by Ning Pan, 2010-07-20
3079
3080 ! Revised by Ning Pan, 2010-07-20
3081 !   Tmpv200(j) =ur
3082 !   ur =max(ub, 0.)
3083    Tmpv200(j) =ub
3084    ur =amax1(ub, 0.)
3085
3086    Tmpv001 =ph_old(i,k,j) -ph_old(i-1,k,j)
3087    Tmpv201(j) =Tmpv001
3088    Tmpv002 =ur*Tmpv201(j)
3089    Tmpv202(j) =+Tmpv002
3090 !   Tmpv003 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*Tmpv202(j)  ! Remarked by Ning Pan, 2010-07-20
3091 !   Tmpv004 =ph_tend(i,k,j) -Tmpv003  ! Remarked by Ning Pan, 2010-07-20
3092 !  ph_tend(i,k,j) =Tmpv004
3093
3094    ENDDO
3095
3096    END IF
3097
3098    IF( (config_flags%open_xe) .and. ite == ide ) THEN
3099 !  Added by Ning Pan, 2010-07-20
3100    i =ite-1
3101
3102    DO j =jtf, jts, -1
3103 !  Added by Ning Pan, 2010-07-20
3104    k =kde
3105    kz =k-1
3106    ub =Tmpv200(j)
3107    ur =amax1(ub, 0.)
3108
3109    a_Tmpv4 =a_ph_tend(i,k,j)
3110    a_ph_tend(i,k,j) =0.0
3111    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv4
3112    a_Tmpv3 =-a_Tmpv4
3113    a_mut(i,j) =a_mut(i,j) +(msftx(i,j)/msfty(i,j))*rdx*Tmpv202(j)*a_Tmpv3
3114    a_Tmpv2 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*a_Tmpv3
3115    a_ur =a_ur +Tmpv201(j)*a_Tmpv2
3116    a_Tmpv1 =ur*a_Tmpv2
3117    a_ph_old(i,k,j) =a_ph_old(i,k,j) +a_Tmpv1
3118    a_ph_old(i-1,k,j) =a_ph_old(i-1,k,j) -a_Tmpv1
3119
3120 !   ur =Tmpv200(j)  ! Remarked by Ning Pan, 2010-07-20
3121
3122    a_ub =a_ub +(1.0 +(1.0)*sign(1.0, ub -0.))*0.5*a_ur
3123    a_ur =0.0
3124    a_Tmpv6 =a_ub
3125    a_ub =0.0
3126    a_Tmpv5 =.5*a_Tmpv6
3127    a_Tmpv2 =a_Tmpv5
3128    a_Tmpv4 =a_Tmpv5
3129    a_Tmpv3 =fnp(kz)*a_Tmpv4
3130    a_u(i+1,kz-1,j) =a_u(i+1,kz-1,j) +a_Tmpv3
3131    a_u(i,kz-1,j) =a_u(i,kz-1,j) +a_Tmpv3
3132    a_Tmpv1 =fnm(kz)*a_Tmpv2
3133    a_u(i+1,kz,j) =a_u(i+1,kz,j) +a_Tmpv1
3134    a_u(i,kz,j) =a_u(i,kz,j) +a_Tmpv1
3135    DO k =kde-1, 2, -1
3136 ! Added by Ning Pan, 2010-07-20
3137    kz =k
3138    ub =Tmpv300(k,j)
3139    ur =amax1(ub, 0.)
3140
3141    a_Tmpv4 =a_ph_tend(i,k,j)
3142    a_ph_tend(i,k,j) =0.0
3143    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv4
3144    a_Tmpv3 =-a_Tmpv4
3145    a_mut(i,j) =a_mut(i,j) +(msftx(i,j)/msfty(i,j))*rdx*Tmpv302(k,j)*a_Tmpv3
3146    a_Tmpv2 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*a_Tmpv3
3147    a_ur =a_ur +Tmpv301(k,j)*a_Tmpv2
3148    a_Tmpv1 =ur*a_Tmpv2
3149    a_ph_old(i,k,j) =a_ph_old(i,k,j) +a_Tmpv1
3150    a_ph_old(i-1,k,j) =a_ph_old(i-1,k,j) -a_Tmpv1
3151
3152 !   ur =Tmpv300(k,j)  ! Remarked by Ning Pan, 2010-07-20
3153
3154    a_ub =a_ub +(1.0 +(1.0)*sign(1.0, ub -0.))*0.5*a_ur
3155    a_ur =0.0
3156    a_Tmpv6 =a_ub
3157    a_ub =0.0
3158    a_Tmpv5 =.5*a_Tmpv6
3159    a_Tmpv2 =a_Tmpv5
3160    a_Tmpv4 =a_Tmpv5
3161    a_Tmpv3 =fnp(kz)*a_Tmpv4
3162    a_u(i+1,kz-1,j) =a_u(i+1,kz-1,j) +a_Tmpv3
3163    a_u(i,kz-1,j) =a_u(i,kz-1,j) +a_Tmpv3
3164    a_Tmpv1 =fnm(kz)*a_Tmpv2
3165    a_u(i+1,kz,j) =a_u(i+1,kz,j) +a_Tmpv1
3166    a_u(i,kz,j) =a_u(i,kz,j) +a_Tmpv1
3167    ENDDO
3168    ENDDO
3169
3170    END IF
3171
3172 !LPB[14]
3173
3174 !LPB[13]
3175
3176    IF( (config_flags%open_xs) .and. its == ids ) THEN
3177    i =its
3178    DO j =jts, jtf
3179    DO k =2, kde-1
3180    kz =k
3181    Tmpv001 =u(i+1,kz,j) +u(i,kz,j)
3182    Tmpv002 =fnm(kz)*Tmpv001
3183    Tmpv003 =u(i+1,kz-1,j) +u(i,kz-1,j)
3184    Tmpv004 =fnp(kz)*Tmpv003
3185    Tmpv005 =Tmpv002 +Tmpv004
3186    Tmpv006 =.5*Tmpv005
3187    ub =Tmpv006  ! Removed remark by Ning Pan, 2010-07-20
3188
3189 ! Revised by Ning Pan, 2010-07-20
3190 !   Tmpv300(k,j) =ul
3191 !   ul =min(ub, 0.)
3192    Tmpv300(k,j) =ub
3193    ul =amin1(ub, 0.)
3194
3195    Tmpv001 =ph_old(i+1,k,j) -ph_old(i,k,j)
3196    Tmpv301(k,j) =Tmpv001
3197    Tmpv002 =ul*Tmpv301(k,j)
3198    Tmpv302(k,j) =+Tmpv002
3199 !   Tmpv003 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*Tmpv302(k,j)  ! Remarked by Ning Pan, 2010-07-20
3200 !   Tmpv004 =ph_tend(i,k,j) -Tmpv003  ! Remarked by Ning Pan, 2010-07-20
3201 !  ph_tend(i,k,j) =Tmpv004
3202
3203    ENDDO
3204    k =kde
3205    kz =k
3206    Tmpv001 =u(i+1,kz,j) +u(i,kz,j)
3207    Tmpv002 =fnm(kz)*Tmpv001
3208    Tmpv003 =u(i+1,kz-1,j) +u(i,kz-1,j)
3209    Tmpv004 =fnp(kz)*Tmpv003
3210    Tmpv005 =Tmpv002 +Tmpv004
3211    Tmpv006 =.5*Tmpv005
3212    ub =Tmpv006  ! Removed remark by Ning Pan, 2010-07-20
3213
3214 ! Revised by Ning Pan, 2010-07-20
3215 !   Tmpv200(j) =ul
3216 !   ul =min(ub, 0.)
3217    Tmpv200(j) =ub
3218    ul =amin1(ub, 0.)
3219
3220    Tmpv001 =ph_old(i+1,k,j) -ph_old(i,k,j)
3221    Tmpv201(j) =Tmpv001
3222    Tmpv002 =ul*Tmpv201(j)
3223    Tmpv202(j) =+Tmpv002
3224 !   Tmpv003 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*Tmpv202(j)  ! Remarked by Ning Pan, 2010-07-20
3225 !   Tmpv004 =ph_tend(i,k,j) -Tmpv003  ! Remarked by Ning Pan, 2010-07-20
3226 !  ph_tend(i,k,j) =Tmpv004
3227
3228    ENDDO
3229
3230    END IF
3231
3232    IF( (config_flags%open_xs) .and. its == ids ) THEN
3233 !  Added by Ning Pan, 2010-07-20
3234    i =its
3235
3236    DO j =jtf, jts, -1
3237 !  Added by Ning Pan, 2010-07-20
3238    k =kde
3239    kz =k
3240    ub =Tmpv200(j)
3241    ul =amin1(ub, 0.)
3242
3243    a_Tmpv4 =a_ph_tend(i,k,j)
3244    a_ph_tend(i,k,j) =0.0
3245    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv4
3246    a_Tmpv3 =-a_Tmpv4
3247    a_mut(i,j) =a_mut(i,j) +(msftx(i,j)/msfty(i,j))*rdx*Tmpv202(j)*a_Tmpv3
3248    a_Tmpv2 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*a_Tmpv3
3249    a_ul =a_ul +Tmpv201(j)*a_Tmpv2
3250    a_Tmpv1 =ul*a_Tmpv2
3251    a_ph_old(i+1,k,j) =a_ph_old(i+1,k,j) +a_Tmpv1
3252    a_ph_old(i,k,j) =a_ph_old(i,k,j) -a_Tmpv1
3253
3254 !   ul =Tmpv200(j)  ! Remarked by Ning Pan, 2010-07-20
3255
3256    a_ub =a_ub +(1.0 -(1.0)*sign(1.0, ub -0.))*0.5*a_ul
3257    a_ul =0.0
3258    a_Tmpv6 =a_ub
3259    a_ub =0.0
3260    a_Tmpv5 =.5*a_Tmpv6
3261    a_Tmpv2 =a_Tmpv5
3262    a_Tmpv4 =a_Tmpv5
3263    a_Tmpv3 =fnp(kz)*a_Tmpv4
3264    a_u(i+1,kz-1,j) =a_u(i+1,kz-1,j) +a_Tmpv3
3265    a_u(i,kz-1,j) =a_u(i,kz-1,j) +a_Tmpv3
3266    a_Tmpv1 =fnm(kz)*a_Tmpv2
3267    a_u(i+1,kz,j) =a_u(i+1,kz,j) +a_Tmpv1
3268    a_u(i,kz,j) =a_u(i,kz,j) +a_Tmpv1
3269    DO k =kde-1, 2, -1
3270 ! Added by Ning Pan, 2010-07-20
3271    kz =k
3272    ub =Tmpv300(k,j)
3273    ul =amin1(ub, 0.)
3274
3275    a_Tmpv4 =a_ph_tend(i,k,j)
3276    a_ph_tend(i,k,j) =0.0
3277    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv4
3278    a_Tmpv3 =-a_Tmpv4
3279    a_mut(i,j) =a_mut(i,j) +(msftx(i,j)/msfty(i,j))*rdx*Tmpv302(k,j)*a_Tmpv3
3280    a_Tmpv2 =(msftx(i,j)/msfty(i,j))*rdx*mut(i,j)*a_Tmpv3
3281    a_ul =a_ul +Tmpv301(k,j)*a_Tmpv2
3282    a_Tmpv1 =ul*a_Tmpv2
3283    a_ph_old(i+1,k,j) =a_ph_old(i+1,k,j) +a_Tmpv1
3284    a_ph_old(i,k,j) =a_ph_old(i,k,j) -a_Tmpv1
3285
3286 !   ul =Tmpv300(k,j)  ! Remarked by Ning Pan, 2010-07-20
3287
3288    a_ub =a_ub +(1.0 -(1.0)*sign(1.0, ub -0.))*0.5*a_ul
3289    a_ul =0.0
3290    a_Tmpv6 =a_ub
3291    a_ub =0.0
3292    a_Tmpv5 =.5*a_Tmpv6
3293    a_Tmpv2 =a_Tmpv5
3294    a_Tmpv4 =a_Tmpv5
3295    a_Tmpv3 =fnp(kz)*a_Tmpv4
3296    a_u(i+1,kz-1,j) =a_u(i+1,kz-1,j) +a_Tmpv3
3297    a_u(i,kz-1,j) =a_u(i,kz-1,j) +a_Tmpv3
3298    a_Tmpv1 =fnm(kz)*a_Tmpv2
3299    a_u(i+1,kz,j) =a_u(i+1,kz,j) +a_Tmpv1
3300    a_u(i,kz,j) =a_u(i,kz,j) +a_Tmpv1
3301    ENDDO
3302    ENDDO
3303
3304    END IF
3305
3306 !LPB[12]
3307 !  j_start =its
3308 !  jtf =min(jte, jde-1)
3309
3310 !LPB[11]
3311 ! Added by Ning Pan, 2010-07-20
3312    i_start =its
3313    itf =min(ite,ide-1)
3314
3315    IF( (config_flags%open_ye) .and. jte == jde ) THEN
3316    j =jte-1
3317    DO k =2, kde
3318    kz =min(k, kde-1)
3319
3320    DO i =its, itf
3321    Tmpv001 =v(i,kz,j+1) +v(i,kz,j)
3322    Tmpv002 =fnm(kz)*Tmpv001
3323    Tmpv003 =v(i,kz-1,j+1) +v(i,kz-1,j)
3324    Tmpv004 =fnp(kz)*Tmpv003
3325    Tmpv005 =Tmpv002 +Tmpv004
3326    Tmpv006 =.5*Tmpv005
3327    vb =Tmpv006  ! Removed remark by Ning Pan, 2010-07-20
3328
3329 ! Revised by Ning Pan, 2010-07-20
3330 !   Tmpv300(i,k) =vr
3331 !   vr =max(vb, 0.)
3332    Tmpv300(i,k) =vb
3333    vr =amax1(vb, 0.)
3334
3335    Tmpv001 =ph_old(i,k,j) -ph_old(i,k,j-1)
3336    Tmpv301(i,k) =Tmpv001
3337    Tmpv002 =vr*Tmpv301(i,k)
3338    Tmpv302(i,k) =+Tmpv002
3339 !   Tmpv003 =rdy*mut(i,j)*Tmpv302(i,k)  ! Remarked by Ning Pan, 2010-07-20
3340 !   Tmpv004 =ph_tend(i,k,j) -Tmpv003  ! Remarked by Ning Pan, 2010-07-20
3341 !  ph_tend(i,k,j) =Tmpv004
3342
3343    ENDDO
3344    ENDDO
3345    END IF
3346
3347    IF( (config_flags%open_ye) .and. jte == jde ) THEN
3348
3349    j =jte-1  ! Added by Ning Pan, 2010-07-20
3350    DO k =kde, 2, -1
3351    kz =min(k, kde-1)  ! Added by Ning Pan, 2010-07-20
3352
3353    DO i =itf, its, -1
3354 ! Added by Ning Pan, 2010-07-20
3355    vb =Tmpv300(i,k)
3356    vr =amax1(vb, 0.)
3357
3358    a_Tmpv4 =a_ph_tend(i,k,j)
3359    a_ph_tend(i,k,j) =0.0
3360    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv4
3361    a_Tmpv3 =-a_Tmpv4
3362    a_mut(i,j) =a_mut(i,j) +rdy*Tmpv302(i,k)*a_Tmpv3
3363    a_Tmpv2 =rdy*mut(i,j)*a_Tmpv3
3364    a_vr =a_vr +Tmpv301(i,k)*a_Tmpv2
3365    a_Tmpv1 =vr*a_Tmpv2
3366    a_ph_old(i,k,j) =a_ph_old(i,k,j) +a_Tmpv1
3367    a_ph_old(i,k,j-1) =a_ph_old(i,k,j-1) -a_Tmpv1
3368
3369 !   vr =Tmpv300(i,k)  ! Remarked by Ning Pan, 2010-07-20
3370
3371    a_vb =a_vb +(1.0 +(1.0)*sign(1.0, vb -0.))*0.5*a_vr
3372    a_vr =0.0
3373    a_Tmpv6 =a_vb
3374    a_vb =0.0
3375    a_Tmpv5 =.5*a_Tmpv6
3376    a_Tmpv2 =a_Tmpv5
3377    a_Tmpv4 =a_Tmpv5
3378    a_Tmpv3 =fnp(kz)*a_Tmpv4
3379    a_v(i,kz-1,j+1) =a_v(i,kz-1,j+1) +a_Tmpv3
3380    a_v(i,kz-1,j) =a_v(i,kz-1,j) +a_Tmpv3
3381    a_Tmpv1 =fnm(kz)*a_Tmpv2
3382    a_v(i,kz,j+1) =a_v(i,kz,j+1) +a_Tmpv1
3383    a_v(i,kz,j) =a_v(i,kz,j) +a_Tmpv1
3384    ENDDO
3385    ENDDO
3386
3387    END IF
3388
3389 !LPB[10]
3390
3391 !LPB[9]
3392
3393    IF( (config_flags%open_ys) .and. jts == jds ) THEN
3394    j =jts
3395    DO k =2, kde
3396    kz =min(k, kde-1)
3397
3398    DO i =its, itf
3399    Tmpv001 =v(i,kz,j+1) +v(i,kz,j)
3400    Tmpv002 =fnm(kz)*Tmpv001
3401    Tmpv003 =v(i,kz-1,j+1) +v(i,kz-1,j)
3402    Tmpv004 =fnp(kz)*Tmpv003
3403    Tmpv005 =Tmpv002 +Tmpv004
3404    Tmpv006 =.5*Tmpv005
3405    vb =Tmpv006  ! Removed remark by Ning Pan, 2010-07-20
3406
3407 ! Revised by Ning Pan, 2010-07-20
3408 !   Tmpv300(i,k) =vl
3409 !   vl =min(vb, 0.)
3410    Tmpv300(i,k) =vb
3411    vl =amin1(vb, 0.)
3412
3413    Tmpv001 =ph_old(i,k,j+1) -ph_old(i,k,j)
3414    Tmpv301(i,k) =Tmpv001
3415    Tmpv002 =vl*Tmpv301(i,k)
3416    Tmpv302(i,k) =+Tmpv002
3417 !   Tmpv003 =rdy*mut(i,j)*Tmpv302(i,k)  ! Remarked by Ning Pan, 2010-07-20
3418 !   Tmpv004 =ph_tend(i,k,j) -Tmpv003  ! Remarked by Ning Pan, 2010-07-20
3419 !  ph_tend(i,k,j) =Tmpv004
3420
3421    ENDDO
3422    ENDDO
3423    END IF
3424
3425    IF( (config_flags%open_ys) .and. jts == jds ) THEN
3426
3427    j =jts  ! Added by Ning Pan, 2010-07-20
3428    DO k =kde, 2, -1
3429    kz =min(k, kde-1)  ! Added by Ning Pan, 2010-07-20
3430
3431    DO i =itf, its, -1
3432 ! Added by Ning Pan, 2010-07-20
3433    vb =Tmpv300(i,k)
3434    vl =amin1(vb, 0.)
3435
3436    a_Tmpv4 =a_ph_tend(i,k,j)
3437    a_ph_tend(i,k,j) =0.0
3438    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv4
3439    a_Tmpv3 =-a_Tmpv4
3440    a_mut(i,j) =a_mut(i,j) +rdy*Tmpv302(i,k)*a_Tmpv3
3441    a_Tmpv2 =rdy*mut(i,j)*a_Tmpv3
3442    a_vl =a_vl +Tmpv301(i,k)*a_Tmpv2
3443    a_Tmpv1 =vl*a_Tmpv2
3444    a_ph_old(i,k,j+1) =a_ph_old(i,k,j+1) +a_Tmpv1
3445    a_ph_old(i,k,j) =a_ph_old(i,k,j) -a_Tmpv1
3446
3447 !   vl =Tmpv300(i,k)  ! Remarked by Ning Pan, 2010-07-20
3448
3449    a_vb =a_vb +(1.0 -(1.0)*sign(1.0, vb -0.))*0.5*a_vl
3450    a_vl =0.0
3451    a_Tmpv6 =a_vb
3452    a_vb =0.0
3453    a_Tmpv5 =.5*a_Tmpv6
3454    a_Tmpv2 =a_Tmpv5
3455    a_Tmpv4 =a_Tmpv5
3456    a_Tmpv3 =fnp(kz)*a_Tmpv4
3457    a_v(i,kz-1,j+1) =a_v(i,kz-1,j+1) +a_Tmpv3
3458    a_v(i,kz-1,j) =a_v(i,kz-1,j) +a_Tmpv3
3459    a_Tmpv1 =fnm(kz)*a_Tmpv2
3460    a_v(i,kz,j+1) =a_v(i,kz,j+1) +a_Tmpv1
3461    a_v(i,kz,j) =a_v(i,kz,j) +a_Tmpv1
3462    ENDDO
3463    ENDDO
3464
3465    END IF
3466
3467 !LPB[8]
3468 !  i_start =its
3469 !  itf =min(ite, ide-1)
3470
3471 !LPB[7]
3472
3473    IF(advective_order <= 2) THEN
3474    i_start =its
3475    j_start =jts
3476    itf =min(ite, ide-1)
3477    jtf =min(jte, jde-1)
3478    IF( (config_flags%open_ys .or. specified) .and. jts == jds ) THEN
3479    j_start =jts+1
3480    END IF
3481    IF( (config_flags%open_ye .or. specified) .and. jte == jde ) THEN
3482    jtf =jtf-2
3483    END IF
3484    DO j =j_start, jtf
3485    DO k =2, kte-1
3486    DO i =i_start, itf
3487    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
3488    Tmpv400(i,k,j) =Tmpv001
3489    Tmpv002 =muv(i,j+1)*Tmpv400(i,k,j)
3490    Tmpv003 =Tmpv002*msfvy(i,j+1)
3491    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
3492    Tmpv401(i,k,j) =Tmpv003
3493    Tmpv402(i,k,j) =Tmpv004
3494    Tmpv005 =Tmpv401(i,k,j)*Tmpv402(i,k,j)
3495    Tmpv006 =v(i,k,j) +v(i,k-1,j)
3496    Tmpv403(i,k,j) =Tmpv006
3497    Tmpv007 =muv(i,j)*Tmpv403(i,k,j)
3498    Tmpv008 =Tmpv007*msfvy(i,j)
3499    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
3500    Tmpv404(i,k,j) =Tmpv008
3501    Tmpv405(i,k,j) =Tmpv009
3502 ! Remarked by Ning Pan, 2010-07-20
3503 !   Tmpv010 =Tmpv404(i,k,j)*Tmpv405(i,k,j)
3504 !   Tmpv011 =Tmpv005 +Tmpv010
3505 !   Tmpv012 =(0.25*rdy/msfty(i,j))*Tmpv011
3506 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3507 !  ph_tend(i,k,j) =Tmpv013
3508
3509    ENDDO
3510    ENDDO
3511    k =kte
3512
3513    DO i =i_start, itf
3514    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
3515    Tmpv300(i,j) =Tmpv001
3516    Tmpv002 =muv(i,j+1)*Tmpv300(i,j)
3517    Tmpv003 =Tmpv002*msfvy(i,j+1)
3518    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
3519    Tmpv301(i,j) =Tmpv003
3520    Tmpv302(i,j) =Tmpv004
3521    Tmpv005 =Tmpv301(i,j)*Tmpv302(i,j)
3522    Tmpv006 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
3523    Tmpv303(i,j) =Tmpv006
3524    Tmpv007 =muv(i,j)*Tmpv303(i,j)
3525    Tmpv008 =Tmpv007*msfvy(i,j)
3526    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
3527    Tmpv304(i,j) =Tmpv008
3528    Tmpv305(i,j) =Tmpv009
3529 ! Remarked by Ning Pan, 2010-07-20
3530 !   Tmpv010 =Tmpv304(i,j)*Tmpv305(i,j)
3531 !   Tmpv011 =Tmpv005 +Tmpv010
3532 !   Tmpv012 =(0.5*rdy/msfty(i,j))*Tmpv011
3533 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3534 !  ph_tend(i,k,j) =Tmpv013
3535
3536    ENDDO
3537    ENDDO
3538    i_start =its
3539    j_start =jts
3540    itf =min(ite, ide-1)
3541    jtf =min(jte, jde-1)
3542    IF( (config_flags%open_xs .or. specified) .and. its == ids ) THEN
3543    i_start =its+1
3544    END IF
3545    IF( (config_flags%open_xe .or. specified) .and. ite == ide ) THEN
3546    itf =itf-2
3547    END IF
3548    DO j =j_start, jtf
3549    DO k =2, kte-1
3550    DO i =i_start, itf
3551    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
3552    Tmpv406(i,k,j) =Tmpv001
3553    Tmpv002 =muu(i+1,j)*Tmpv406(i,k,j)
3554    Tmpv003 =Tmpv002*msfux(i+1,j)
3555    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
3556    Tmpv407(i,k,j) =Tmpv003
3557    Tmpv408(i,k,j) =Tmpv004
3558    Tmpv005 =Tmpv407(i,k,j)*Tmpv408(i,k,j)
3559    Tmpv006 =u(i,k,j) +u(i,k-1,j)
3560    Tmpv409(i,k,j) =Tmpv006
3561    Tmpv007 =muu(i,j)*Tmpv409(i,k,j)
3562    Tmpv008 =Tmpv007*msfux(i,j)
3563    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
3564    Tmpv4010(i,k,j) =Tmpv008
3565    Tmpv4011(i,k,j) =Tmpv009
3566 ! Remarked by Ning Pan, 2010-07-20
3567 !   Tmpv010 =Tmpv4010(i,k,j)*Tmpv4011(i,k,j)
3568 !   Tmpv011 =Tmpv005 +Tmpv010
3569 !   Tmpv012 =(0.25*rdx/msfty(i,j))*Tmpv011
3570 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3571 !  ph_tend(i,k,j) =Tmpv013
3572
3573    ENDDO
3574    ENDDO
3575    k =kte
3576
3577    DO i =i_start, itf
3578    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
3579    Tmpv306(i,j) =Tmpv001
3580    Tmpv002 =muu(i+1,j)*Tmpv306(i,j)
3581    Tmpv003 =Tmpv002*msfux(i+1,j)
3582    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
3583    Tmpv307(i,j) =Tmpv003
3584    Tmpv308(i,j) =Tmpv004
3585    Tmpv005 =Tmpv307(i,j)*Tmpv308(i,j)
3586    Tmpv006 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
3587    Tmpv309(i,j) =Tmpv006
3588    Tmpv007 =muu(i,j)*Tmpv309(i,j)
3589    Tmpv008 =Tmpv007*msfux(i,j)
3590    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
3591    Tmpv3010(i,j) =Tmpv008
3592    Tmpv3011(i,j) =Tmpv009
3593 ! Remarked by Ning Pan, 2010-07-20
3594 !   Tmpv010 =Tmpv3010(i,j)*Tmpv3011(i,j)
3595 !   Tmpv011 =Tmpv005 +Tmpv010
3596 !   Tmpv012 =(0.5*rdx/msfty(i,j))*Tmpv011
3597 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3598 !  ph_tend(i,k,j) =Tmpv013
3599
3600    ENDDO
3601    ENDDO
3602    ELSE IF(advective_order <= 4) THEN
3603    i_start =its
3604    j_start =jts
3605    itf =min(ite, ide-1)
3606    jtf =min(jte, jde-1)
3607    IF( (config_flags%open_ys .or. specified) .and. jts == jds ) THEN
3608    j_start =jts+2
3609    END IF
3610    IF( (config_flags%open_ye .or. specified) .and. jte == jde ) THEN
3611    jtf =jtf-3
3612    END IF
3613    DO j =j_start, jtf
3614    DO k =2, kte-1
3615    DO i =i_start, itf
3616    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
3617    Tmpv4012(i,k,j) =Tmpv001
3618    Tmpv002 =muv(i,j+1)*Tmpv4012(i,k,j)
3619    Tmpv003 =Tmpv002*msfvy(i,j+1)
3620    Tmpv004 =v(i,k,j) +v(i,k-1,j)
3621    Tmpv4013(i,k,j) =Tmpv004
3622    Tmpv005 =muv(i,j)*Tmpv4013(i,k,j)
3623    Tmpv006 =Tmpv005*msfvy(i,j)
3624    Tmpv007 =Tmpv003 +Tmpv006
3625    Tmpv008 =Tmpv007*(1./12.)
3626    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
3627    Tmpv010 =8.*Tmpv009
3628    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
3629    Tmpv012 =Tmpv010 -Tmpv011
3630    Tmpv013 =Tmpv012 +8.*(phb(i,k,j+1)-phb(i,k,j-1))
3631    Tmpv014 =Tmpv013 -(phb(i,k,j+2)-phb(i,k,j-2))
3632    Tmpv4014(i,k,j) =Tmpv008
3633    Tmpv4015(i,k,j) =Tmpv014
3634 ! Remarked by Ning Pan, 2010-07-20
3635 !   Tmpv015 =Tmpv4014(i,k,j)*Tmpv4015(i,k,j)
3636 !   Tmpv016 =(0.25*rdy/msfty(i,j))*Tmpv015
3637 !   Tmpv017 =ph_tend(i,k,j) -Tmpv016
3638 !  ph_tend(i,k,j) =Tmpv017
3639
3640    ENDDO
3641    ENDDO
3642    k =kte
3643
3644    DO i =i_start, itf
3645    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
3646    Tmpv3012(i,j) =Tmpv001
3647    Tmpv002 =muv(i,j+1)*Tmpv3012(i,j)
3648    Tmpv003 =Tmpv002*msfvy(i,j+1)
3649    Tmpv004 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
3650    Tmpv3013(i,j) =Tmpv004
3651    Tmpv005 =muv(i,j)*Tmpv3013(i,j)
3652    Tmpv006 =Tmpv005*msfvy(i,j)
3653    Tmpv007 =Tmpv003 +Tmpv006
3654    Tmpv008 =Tmpv007*(1./12.)
3655    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
3656    Tmpv010 =8.*Tmpv009
3657    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
3658    Tmpv012 =Tmpv010 -Tmpv011
3659    Tmpv013 =Tmpv012 +8.*(phb(i,k,j+1)-phb(i,k,j-1))
3660    Tmpv014 =Tmpv013 -(phb(i,k,j+2)-phb(i,k,j-2))
3661    Tmpv3014(i,j) =Tmpv008
3662    Tmpv3015(i,j) =Tmpv014
3663 ! Remarked by Ning Pan, 2010-07-20
3664 !   Tmpv015 =Tmpv3014(i,j)*Tmpv3015(i,j)
3665 !   Tmpv016 =(0.5*rdy/msfty(i,j))*Tmpv015
3666 !   Tmpv017 =ph_tend(i,k,j) -Tmpv016
3667 !  ph_tend(i,k,j) =Tmpv017
3668
3669    ENDDO
3670    ENDDO
3671    IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 ) THEN
3672    j =jds+1
3673    DO k =2, kte-1
3674    DO i =i_start, itf
3675    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
3676    Tmpv3016(i,k) =Tmpv001
3677    Tmpv002 =muv(i,j+1)*Tmpv3016(i,k)
3678    Tmpv003 =Tmpv002*msfvy(i,j+1)
3679    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
3680    Tmpv3017(i,k) =Tmpv003
3681    Tmpv3018(i,k) =Tmpv004
3682    Tmpv005 =Tmpv3017(i,k)*Tmpv3018(i,k)
3683    Tmpv006 =v(i,k,j) +v(i,k-1,j)
3684    Tmpv3019(i,k) =Tmpv006
3685    Tmpv007 =muv(i,j)*Tmpv3019(i,k)
3686    Tmpv008 =Tmpv007*msfvy(i,j)
3687    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
3688    Tmpv3020(i,k) =Tmpv008
3689    Tmpv3021(i,k) =Tmpv009
3690 ! Remarked by Ning Pan, 2010-07-20
3691 !   Tmpv010 =Tmpv3020(i,k)*Tmpv3021(i,k)
3692 !   Tmpv011 =Tmpv005 +Tmpv010
3693 !   Tmpv012 =(0.25*rdy/msfty(i,j))*Tmpv011
3694 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3695 !  ph_tend(i,k,j) =Tmpv013
3696
3697    ENDDO
3698    ENDDO
3699    k =kte
3700    DO i =i_start, itf
3701    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
3702    Tmpv200(i) =Tmpv001
3703    Tmpv002 =muv(i,j+1)*Tmpv200(i)
3704    Tmpv003 =Tmpv002*msfvy(i,j+1)
3705    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
3706    Tmpv201(i) =Tmpv003
3707    Tmpv202(i) =Tmpv004
3708    Tmpv005 =Tmpv201(i)*Tmpv202(i)
3709    Tmpv006 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
3710    Tmpv203(i) =Tmpv006
3711    Tmpv007 =muv(i,j)*Tmpv203(i)
3712    Tmpv008 =Tmpv007*msfvy(i,j)
3713    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
3714    Tmpv204(i) =Tmpv008
3715    Tmpv205(i) =Tmpv009
3716 ! Remarked by Ning Pan, 2010-07-20
3717 !   Tmpv010 =Tmpv204(i)*Tmpv205(i)
3718 !   Tmpv011 =Tmpv005 +Tmpv010
3719 !   Tmpv012 =(0.5*rdy/msfty(i,j))*Tmpv011
3720 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3721 !  ph_tend(i,k,j) =Tmpv013
3722
3723    ENDDO
3724
3725    END IF
3726    IF( (config_flags%open_ye .or. specified) .and. jte >= jde-2 ) THEN
3727    j =jde-2
3728    DO k =2, kte-1
3729    DO i =i_start, itf
3730    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
3731    Tmpv3022(i,k) =Tmpv001
3732    Tmpv002 =muv(i,j+1)*Tmpv3022(i,k)
3733    Tmpv003 =Tmpv002*msfvy(i,j+1)
3734    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
3735    Tmpv3023(i,k) =Tmpv003
3736    Tmpv3024(i,k) =Tmpv004
3737    Tmpv005 =Tmpv3023(i,k)*Tmpv3024(i,k)
3738    Tmpv006 =v(i,k,j) +v(i,k-1,j)
3739    Tmpv3025(i,k) =Tmpv006
3740    Tmpv007 =muv(i,j)*Tmpv3025(i,k)
3741    Tmpv008 =Tmpv007*msfvy(i,j)
3742    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
3743    Tmpv3026(i,k) =Tmpv008
3744    Tmpv3027(i,k) =Tmpv009
3745 ! Remarked by Ning Pan, 2010-07-20
3746 !   Tmpv010 =Tmpv3026(i,k)*Tmpv3027(i,k)
3747 !   Tmpv011 =Tmpv005 +Tmpv010
3748 !   Tmpv012 =(0.25*rdy/msfty(i,j))*Tmpv011
3749 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3750 !  ph_tend(i,k,j) =Tmpv013
3751
3752    ENDDO
3753    ENDDO
3754    k =kte
3755    DO i =i_start, itf
3756    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
3757    Tmpv206(i) =Tmpv001
3758    Tmpv002 =muv(i,j+1)*Tmpv206(i)
3759    Tmpv003 =Tmpv002*msfvy(i,j+1)
3760    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
3761    Tmpv207(i) =Tmpv003
3762    Tmpv208(i) =Tmpv004
3763    Tmpv005 =Tmpv207(i)*Tmpv208(i)
3764    Tmpv006 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
3765    Tmpv209(i) =Tmpv006
3766    Tmpv007 =muv(i,j)*Tmpv209(i)
3767    Tmpv008 =Tmpv007*msfvy(i,j)
3768    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
3769    Tmpv2010(i) =Tmpv008
3770    Tmpv2011(i) =Tmpv009
3771 ! Remarked by Ning Pan, 2010-07-20
3772 !   Tmpv010 =Tmpv2010(i)*Tmpv2011(i)
3773 !   Tmpv011 =Tmpv005 +Tmpv010
3774 !   Tmpv012 =(0.5*rdy/msfty(i,j))*Tmpv011
3775 !   Tmpv013 =ph_tend(i,k,j) -Tmpv012
3776 !  ph_tend(i,k,j) =Tmpv013
3777
3778    ENDDO
3779
3780    END IF
3781    i_start =its
3782    j_start =jts
3783    itf =min(ite, ide-1)
3784    jtf =min(jte, jde-1)
3785    IF( (config_flags%open_xs) .and. its == ids ) THEN
3786    i_start =its+2
3787    END IF
3788    IF( (config_flags%open_xe) .and. ite == ide ) THEN
3789    itf =itf-3
3790    END IF
3791    DO j =j_start, jtf
3792    DO k =2, kte-1
3793    DO i =i_start, itf
3794    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
3795    Tmpv4016(i,k,j) =Tmpv001
3796    Tmpv002 =muu(i+1,j)*Tmpv4016(i,k,j)
3797    Tmpv003 =Tmpv002*msfux(i+1,j)
3798    Tmpv004 =u(i,k,j) +u(i,k-1,j)
3799    Tmpv4017(i,k,j) =Tmpv004
3800    Tmpv005 =muu(i,j)*Tmpv4017(i,k,j)
3801    Tmpv006 =Tmpv005*msfux(i,j)
3802    Tmpv007 =Tmpv003 +Tmpv006
3803    Tmpv008 =Tmpv007*(1./12.)
3804    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
3805    Tmpv010 =8.*Tmpv009
3806    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
3807    Tmpv012 =Tmpv010 -Tmpv011
3808    Tmpv013 =Tmpv012 +8.*(phb(i+1,k,j)-phb(i-1,k,j))
3809    Tmpv014 =Tmpv013 -(phb(i+2,k,j)-phb(i-2,k,j))
3810    Tmpv4018(i,k,j) =Tmpv008
3811    Tmpv4019(i,k,j) =Tmpv014
3812 ! Remarked by Ning Pan, 2010-07-20
3813 !   Tmpv015 =Tmpv4018(i,k,j)*Tmpv4019(i,k,j)
3814 !   Tmpv016 =(0.25*rdx/msfty(i,j))*Tmpv015
3815 !   Tmpv017 =ph_tend(i,k,j) -Tmpv016
3816 !  ph_tend(i,k,j) =Tmpv017
3817
3818    ENDDO
3819    ENDDO
3820    k =kte
3821
3822    DO i =i_start, itf
3823    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
3824    Tmpv3028(i,j) =Tmpv001
3825    Tmpv002 =muu(i+1,j)*Tmpv3028(i,j)
3826    Tmpv003 =Tmpv002*msfux(i+1,j)
3827    Tmpv004 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
3828    Tmpv3029(i,j) =Tmpv004
3829    Tmpv005 =muu(i,j)*Tmpv3029(i,j)
3830    Tmpv006 =Tmpv005*msfux(i,j)
3831    Tmpv007 =Tmpv003 +Tmpv006
3832    Tmpv008 =Tmpv007*(1./12.)
3833    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
3834    Tmpv010 =8.*Tmpv009
3835    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
3836    Tmpv012 =Tmpv010 -Tmpv011
3837    Tmpv013 =Tmpv012 +8.*(phb(i+1,k,j)-phb(i-1,k,j))
3838    Tmpv014 =Tmpv013 -(phb(i+2,k,j)-phb(i-2,k,j))
3839    Tmpv3030(i,j) =Tmpv008
3840    Tmpv3031(i,j) =Tmpv014
3841 ! Remarked by Ning Pan, 2010-07-20
3842 !   Tmpv015 =Tmpv3030(i,j)*Tmpv3031(i,j)
3843 !   Tmpv016 =(0.5*rdx/msfty(i,j))*Tmpv015
3844 !   Tmpv017 =ph_tend(i,k,j) -Tmpv016
3845 !  ph_tend(i,k,j) =Tmpv017
3846
3847    ENDDO
3848    ENDDO
3849    IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 ) THEN
3850    i =ids+1
3851    DO j =j_start, jtf
3852    DO k =2, kte-1
3853    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
3854    Tmpv3032(k,j) =Tmpv001
3855    Tmpv002 =muu(i+1,j)*Tmpv3032(k,j)
3856    Tmpv003 =Tmpv002*msfux(i+1,j)
3857    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
3858    Tmpv3033(k,j) =Tmpv003
3859    Tmpv3034(k,j) =Tmpv004
3860    Tmpv005 =Tmpv3033(k,j)*Tmpv3034(k,j)
3861    Tmpv006 =u(i,k,j) +u(i,k-1,j)
3862    Tmpv3035(k,j) =Tmpv006
3863    Tmpv007 =muu(i,j)*Tmpv3035(k,j)
3864    Tmpv008 =Tmpv007*msfux(i,j)
3865    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
3866    Tmpv3036(k,j) =Tmpv008
3867    Tmpv3037(k,j) =Tmpv009
3868    Tmpv010 =Tmpv3036(k,j)*Tmpv3037(k,j)
3869    Tmpv011 =Tmpv005 +Tmpv010
3870    Tmpv012 =(0.25*rdx/msfty(i,j))*Tmpv011
3871    Tmpv013 =ph_tend(i,k,j) -Tmpv012
3872 !  ph_tend(i,k,j) =Tmpv013
3873
3874    ENDDO
3875    ENDDO
3876    k =kte
3877    DO j =j_start, jtf
3878    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
3879    Tmpv2012(j) =Tmpv001
3880    Tmpv002 =muu(i+1,j)*Tmpv2012(j)
3881    Tmpv003 =Tmpv002*msfux(i+1,j)
3882    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
3883    Tmpv2013(j) =Tmpv003
3884    Tmpv2014(j) =Tmpv004
3885    Tmpv005 =Tmpv2013(j)*Tmpv2014(j)
3886    Tmpv006 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
3887    Tmpv2015(j) =Tmpv006
3888    Tmpv007 =muu(i,j)*Tmpv2015(j)
3889    Tmpv008 =Tmpv007*msfux(i,j)
3890    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
3891    Tmpv2016(j) =Tmpv008
3892    Tmpv2017(j) =Tmpv009
3893    Tmpv010 =Tmpv2016(j)*Tmpv2017(j)
3894    Tmpv011 =Tmpv005 +Tmpv010
3895    Tmpv012 =(0.5*rdx/msfty(i,j))*Tmpv011
3896    Tmpv013 =ph_tend(i,k,j) -Tmpv012
3897 !  ph_tend(i,k,j) =Tmpv013
3898
3899    ENDDO
3900
3901    END IF
3902    IF( (config_flags%open_xe .or. specified) .and. ite >= ide-2 ) THEN
3903    i =ide-2
3904    DO j =j_start, jtf
3905    DO k =2, kte-1
3906    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
3907    Tmpv3038(k,j) =Tmpv001
3908    Tmpv002 =muu(i+1,j)*Tmpv3038(k,j)
3909    Tmpv003 =Tmpv002*msfux(i+1,j)
3910    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
3911    Tmpv3039(k,j) =Tmpv003
3912    Tmpv3040(k,j) =Tmpv004
3913    Tmpv005 =Tmpv3039(k,j)*Tmpv3040(k,j)
3914    Tmpv006 =u(i,k,j) +u(i,k-1,j)
3915    Tmpv3041(k,j) =Tmpv006
3916    Tmpv007 =muu(i,j)*Tmpv3041(k,j)
3917    Tmpv008 =Tmpv007*msfux(i,j)
3918    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
3919    Tmpv3042(k,j) =Tmpv008
3920    Tmpv3043(k,j) =Tmpv009
3921    Tmpv010 =Tmpv3042(k,j)*Tmpv3043(k,j)
3922    Tmpv011 =Tmpv005 +Tmpv010
3923    Tmpv012 =(0.25*rdx/msfty(i,j))*Tmpv011
3924    Tmpv013 =ph_tend(i,k,j) -Tmpv012
3925 !  ph_tend(i,k,j) =Tmpv013
3926
3927    ENDDO
3928    ENDDO
3929    k =kte
3930    DO j =j_start, jtf
3931    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
3932    Tmpv2018(j) =Tmpv001
3933    Tmpv002 =muu(i+1,j)*Tmpv2018(j)
3934    Tmpv003 =Tmpv002*msfux(i+1,j)
3935    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
3936    Tmpv2019(j) =Tmpv003
3937    Tmpv2020(j) =Tmpv004
3938    Tmpv005 =Tmpv2019(j)*Tmpv2020(j)
3939    Tmpv006 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
3940    Tmpv2021(j) =Tmpv006
3941    Tmpv007 =muu(i,j)*Tmpv2021(j)
3942    Tmpv008 =Tmpv007*msfux(i,j)
3943    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
3944    Tmpv2022(j) =Tmpv008
3945    Tmpv2023(j) =Tmpv009
3946    Tmpv010 =Tmpv2022(j)*Tmpv2023(j)
3947    Tmpv011 =Tmpv005 +Tmpv010
3948    Tmpv012 =(0.5*rdx/msfty(i,j))*Tmpv011
3949    Tmpv013 =ph_tend(i,k,j) -Tmpv012
3950 !  ph_tend(i,k,j) =Tmpv013
3951
3952    ENDDO
3953
3954    END IF
3955    ELSE IF(advective_order <= 6) THEN
3956    i_start =its
3957    j_start =jts
3958    itf =min(ite, ide-1)
3959    jtf =min(jte, jde-1)
3960    IF(config_flags%open_ys .or. specified ) THEN
3961    j_start =max(jts, jds+3)
3962    END IF
3963    IF(config_flags%open_ye .or. specified ) THEN
3964    jtf =min(jtf, jde-4)
3965    END IF
3966    DO j =j_start, jtf
3967    DO k =2, kte-1
3968    DO i =i_start, itf
3969    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
3970    Tmpv4020(i,k,j) =Tmpv001
3971    Tmpv002 =muv(i,j+1)*Tmpv4020(i,k,j)
3972    Tmpv003 =Tmpv002*msfvy(i,j+1)
3973    Tmpv004 =v(i,k,j) +v(i,k-1,j)
3974    Tmpv4021(i,k,j) =Tmpv004
3975    Tmpv005 =muv(i,j)*Tmpv4021(i,k,j)
3976    Tmpv006 =Tmpv005*msfvy(i,j)
3977    Tmpv007 =Tmpv003 +Tmpv006
3978    Tmpv008 =Tmpv007*(1./60.)
3979    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
3980    Tmpv010 =45.*Tmpv009
3981    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
3982    Tmpv012 =9.*Tmpv011
3983    Tmpv013 =Tmpv010 -Tmpv012
3984    Tmpv014 =ph(i,k,j+3) -ph(i,k,j-3)
3985    Tmpv015 =Tmpv013 +Tmpv014
3986    Tmpv016 =Tmpv015 +45.*(phb(i,k,j+1)-phb(i,k,j-1))
3987    Tmpv017 =Tmpv016 -9.*(phb(i,k,j+2)-phb(i,k,j-2))
3988    Tmpv018 =Tmpv017 +(phb(i,k,j+3)-phb(i,k,j-3))
3989    Tmpv4022(i,k,j) =Tmpv008
3990    Tmpv4023(i,k,j) =Tmpv018
3991    Tmpv019 =Tmpv4022(i,k,j)*Tmpv4023(i,k,j)
3992    Tmpv020 =(0.25*rdy/msfty(i,j))*Tmpv019
3993    Tmpv021 =ph_tend(i,k,j) -Tmpv020
3994 !  ph_tend(i,k,j) =Tmpv021
3995
3996    ENDDO
3997    ENDDO
3998    k =kte
3999
4000    DO i =i_start, itf
4001    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
4002    Tmpv3044(i,j) =Tmpv001
4003    Tmpv002 =muv(i,j+1)*Tmpv3044(i,j)
4004    Tmpv003 =Tmpv002*msfvy(i,j+1)
4005    Tmpv004 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
4006    Tmpv3045(i,j) =Tmpv004
4007    Tmpv005 =muv(i,j)*Tmpv3045(i,j)
4008    Tmpv006 =Tmpv005*msfvy(i,j)
4009    Tmpv007 =Tmpv003 +Tmpv006
4010    Tmpv008 =Tmpv007*(1./60.)
4011    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
4012    Tmpv010 =45.*Tmpv009
4013    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
4014    Tmpv012 =9.*Tmpv011
4015    Tmpv013 =Tmpv010 -Tmpv012
4016    Tmpv014 =ph(i,k,j+3) -ph(i,k,j-3)
4017    Tmpv015 =Tmpv013 +Tmpv014
4018    Tmpv016 =Tmpv015 +45.*(phb(i,k,j+1)-phb(i,k,j-1))
4019    Tmpv017 =Tmpv016 -9.*(phb(i,k,j+2)-phb(i,k,j-2))
4020    Tmpv018 =Tmpv017 +(phb(i,k,j+3)-phb(i,k,j-3))
4021    Tmpv3046(i,j) =Tmpv008
4022    Tmpv3047(i,j) =Tmpv018
4023    Tmpv019 =Tmpv3046(i,j)*Tmpv3047(i,j)
4024    Tmpv020 =(0.5*rdy/msfty(i,j))*Tmpv019
4025    Tmpv021 =ph_tend(i,k,j) -Tmpv020
4026 !  ph_tend(i,k,j) =Tmpv021
4027
4028    ENDDO
4029    ENDDO
4030    IF( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte ) THEN
4031    j =jds+2
4032    DO k =2, kte-1
4033    DO i =i_start, itf
4034    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
4035    Tmpv3048(i,k) =Tmpv001
4036    Tmpv002 =muv(i,j+1)*Tmpv3048(i,k)
4037    Tmpv003 =Tmpv002*msfvy(i,j+1)
4038    Tmpv004 =v(i,k,j) +v(i,k-1,j)
4039    Tmpv3049(i,k) =Tmpv004
4040    Tmpv005 =muv(i,j)*Tmpv3049(i,k)
4041    Tmpv006 =Tmpv005*msfvy(i,j)
4042    Tmpv007 =Tmpv003 +Tmpv006
4043    Tmpv008 =Tmpv007*(1./12.)
4044    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
4045    Tmpv010 =8.*Tmpv009
4046    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
4047    Tmpv012 =Tmpv010 -Tmpv011
4048    Tmpv013 =Tmpv012 +8.*(phb(i,k,j+1)-phb(i,k,j-1))
4049    Tmpv014 =Tmpv013 -(phb(i,k,j+2)-phb(i,k,j-2))
4050    Tmpv3050(i,k) =Tmpv008
4051    Tmpv3051(i,k) =Tmpv014
4052    Tmpv015 =Tmpv3050(i,k)*Tmpv3051(i,k)
4053    Tmpv016 =(0.25*rdy/msfty(i,j))*Tmpv015
4054    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4055 !  ph_tend(i,k,j) =Tmpv017
4056
4057    ENDDO
4058    ENDDO
4059    k =kte
4060    DO i =i_start, itf
4061    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
4062    Tmpv2024(i) =Tmpv001
4063    Tmpv002 =muv(i,j+1)*Tmpv2024(i)
4064    Tmpv003 =Tmpv002*msfvy(i,j+1)
4065    Tmpv004 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
4066    Tmpv2025(i) =Tmpv004
4067    Tmpv005 =muv(i,j)*Tmpv2025(i)
4068    Tmpv006 =Tmpv005*msfvy(i,j)
4069    Tmpv007 =Tmpv003 +Tmpv006
4070    Tmpv008 =Tmpv007*(1./12.)
4071    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
4072    Tmpv010 =8.*Tmpv009
4073    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
4074    Tmpv012 =Tmpv010 -Tmpv011
4075    Tmpv013 =Tmpv012 +8.*(phb(i,k,j+1)-phb(i,k,j-1))
4076    Tmpv014 =Tmpv013 -(phb(i,k,j+2)-phb(i,k,j-2))
4077    Tmpv2026(i) =Tmpv008
4078    Tmpv2027(i) =Tmpv014
4079    Tmpv015 =Tmpv2026(i)*Tmpv2027(i)
4080    Tmpv016 =(0.5*rdy/msfty(i,j))*Tmpv015
4081    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4082 !  ph_tend(i,k,j) =Tmpv017
4083
4084    ENDDO
4085
4086    END IF
4087    IF( (config_flags%open_ye .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte ) THEN
4088    j =jde-3
4089    DO k =2, kte-1
4090    DO i =i_start, itf
4091    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
4092    Tmpv3052(i,k) =Tmpv001
4093    Tmpv002 =muv(i,j+1)*Tmpv3052(i,k)
4094    Tmpv003 =Tmpv002*msfvy(i,j+1)
4095    Tmpv004 =v(i,k,j) +v(i,k-1,j)
4096    Tmpv3053(i,k) =Tmpv004
4097    Tmpv005 =muv(i,j)*Tmpv3053(i,k)
4098    Tmpv006 =Tmpv005*msfvy(i,j)
4099    Tmpv007 =Tmpv003 +Tmpv006
4100    Tmpv008 =Tmpv007*(1./12.)
4101    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
4102    Tmpv010 =8.*Tmpv009
4103    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
4104    Tmpv012 =Tmpv010 -Tmpv011
4105    Tmpv013 =Tmpv012 +8.*(phb(i,k,j+1)-phb(i,k,j-1))
4106    Tmpv014 =Tmpv013 -(phb(i,k,j+2)-phb(i,k,j-2))
4107    Tmpv3054(i,k) =Tmpv008
4108    Tmpv3055(i,k) =Tmpv014
4109    Tmpv015 =Tmpv3054(i,k)*Tmpv3055(i,k)
4110    Tmpv016 =(0.25*rdy/msfty(i,j))*Tmpv015
4111    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4112 !  ph_tend(i,k,j) =Tmpv017
4113
4114    ENDDO
4115    ENDDO
4116    k =kte
4117    DO i =i_start, itf
4118    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
4119    Tmpv2028(i) =Tmpv001
4120    Tmpv002 =muv(i,j+1)*Tmpv2028(i)
4121    Tmpv003 =Tmpv002*msfvy(i,j+1)
4122    Tmpv004 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
4123    Tmpv2029(i) =Tmpv004
4124    Tmpv005 =muv(i,j)*Tmpv2029(i)
4125    Tmpv006 =Tmpv005*msfvy(i,j)
4126    Tmpv007 =Tmpv003 +Tmpv006
4127    Tmpv008 =Tmpv007*(1./12.)
4128    Tmpv009 =ph(i,k,j+1) -ph(i,k,j-1)
4129    Tmpv010 =8.*Tmpv009
4130    Tmpv011 =ph(i,k,j+2) -ph(i,k,j-2)
4131    Tmpv012 =Tmpv010 -Tmpv011
4132    Tmpv013 =Tmpv012 +8.*(phb(i,k,j+1)-phb(i,k,j-1))
4133    Tmpv014 =Tmpv013 -(phb(i,k,j+2)-phb(i,k,j-2))
4134    Tmpv2030(i) =Tmpv008
4135    Tmpv2031(i) =Tmpv014
4136    Tmpv015 =Tmpv2030(i)*Tmpv2031(i)
4137    Tmpv016 =(0.5*rdy/msfty(i,j))*Tmpv015
4138    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4139 !  ph_tend(i,k,j) =Tmpv017
4140
4141    ENDDO
4142
4143    END IF
4144    IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte ) THEN
4145    j =jds+1
4146    DO k =2, kte-1
4147    DO i =i_start, itf
4148    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
4149    Tmpv3056(i,k) =Tmpv001
4150    Tmpv002 =muv(i,j+1)*Tmpv3056(i,k)
4151    Tmpv003 =Tmpv002*msfvy(i,j+1)
4152    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
4153    Tmpv3057(i,k) =Tmpv003
4154    Tmpv3058(i,k) =Tmpv004
4155    Tmpv005 =Tmpv3057(i,k)*Tmpv3058(i,k)
4156    Tmpv006 =v(i,k,j) +v(i,k-1,j)
4157    Tmpv3059(i,k) =Tmpv006
4158    Tmpv007 =muv(i,j)*Tmpv3059(i,k)
4159    Tmpv008 =Tmpv007*msfvy(i,j)
4160    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
4161    Tmpv3060(i,k) =Tmpv008
4162    Tmpv3061(i,k) =Tmpv009
4163    Tmpv010 =Tmpv3060(i,k)*Tmpv3061(i,k)
4164    Tmpv011 =Tmpv005 +Tmpv010
4165    Tmpv012 =(0.25*rdy/msfty(i,j))*Tmpv011
4166    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4167 !  ph_tend(i,k,j) =Tmpv013
4168
4169    ENDDO
4170    ENDDO
4171    k =kte
4172    DO i =i_start, itf
4173    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
4174    Tmpv2032(i) =Tmpv001
4175    Tmpv002 =muv(i,j+1)*Tmpv2032(i)
4176    Tmpv003 =Tmpv002*msfvy(i,j+1)
4177    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
4178    Tmpv2033(i) =Tmpv003
4179    Tmpv2034(i) =Tmpv004
4180    Tmpv005 =Tmpv2033(i)*Tmpv2034(i)
4181    Tmpv006 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
4182    Tmpv2035(i) =Tmpv006
4183    Tmpv007 =muv(i,j)*Tmpv2035(i)
4184    Tmpv008 =Tmpv007*msfvy(i,j)
4185    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
4186    Tmpv2036(i) =Tmpv008
4187    Tmpv2037(i) =Tmpv009
4188    Tmpv010 =Tmpv2036(i)*Tmpv2037(i)
4189    Tmpv011 =Tmpv005 +Tmpv010
4190    Tmpv012 =(0.5*rdy/msfty(i,j))*Tmpv011
4191    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4192 !  ph_tend(i,k,j) =Tmpv013
4193
4194    ENDDO
4195
4196    END IF
4197    IF( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte ) THEN
4198    j =jde-2
4199    DO k =2, kte-1
4200    DO i =i_start, itf
4201    Tmpv001 =v(i,k,j+1) +v(i,k-1,j+1)
4202    Tmpv3062(i,k) =Tmpv001
4203    Tmpv002 =muv(i,j+1)*Tmpv3062(i,k)
4204    Tmpv003 =Tmpv002*msfvy(i,j+1)
4205    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
4206    Tmpv3063(i,k) =Tmpv003
4207    Tmpv3064(i,k) =Tmpv004
4208    Tmpv005 =Tmpv3063(i,k)*Tmpv3064(i,k)
4209    Tmpv006 =v(i,k,j) +v(i,k-1,j)
4210    Tmpv3065(i,k) =Tmpv006
4211    Tmpv007 =muv(i,j)*Tmpv3065(i,k)
4212    Tmpv008 =Tmpv007*msfvy(i,j)
4213    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
4214    Tmpv3066(i,k) =Tmpv008
4215    Tmpv3067(i,k) =Tmpv009
4216    Tmpv010 =Tmpv3066(i,k)*Tmpv3067(i,k)
4217    Tmpv011 =Tmpv005 +Tmpv010
4218    Tmpv012 =(0.25*rdy/msfty(i,j))*Tmpv011
4219    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4220 !  ph_tend(i,k,j) =Tmpv013
4221
4222    ENDDO
4223    ENDDO
4224    k =kte
4225    DO i =i_start, itf
4226    Tmpv001 =cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)
4227    Tmpv2038(i) =Tmpv001
4228    Tmpv002 =muv(i,j+1)*Tmpv2038(i)
4229    Tmpv003 =Tmpv002*msfvy(i,j+1)
4230    Tmpv004 =phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)
4231    Tmpv2039(i) =Tmpv003
4232    Tmpv2040(i) =Tmpv004
4233    Tmpv005 =Tmpv2039(i)*Tmpv2040(i)
4234    Tmpv006 =cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)
4235    Tmpv2041(i) =Tmpv006
4236    Tmpv007 =muv(i,j)*Tmpv2041(i)
4237    Tmpv008 =Tmpv007*msfvy(i,j)
4238    Tmpv009 =phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)
4239    Tmpv2042(i) =Tmpv008
4240    Tmpv2043(i) =Tmpv009
4241    Tmpv010 =Tmpv2042(i)*Tmpv2043(i)
4242    Tmpv011 =Tmpv005 +Tmpv010
4243    Tmpv012 =(0.5*rdy/msfty(i,j))*Tmpv011
4244    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4245 !  ph_tend(i,k,j) =Tmpv013
4246
4247    ENDDO
4248
4249    END IF
4250    i_start =its
4251    j_start =jts
4252    itf =min(ite, ide-1)
4253    jtf =min(jte, jde-1)
4254    IF(config_flags%open_xs .or. specified ) THEN
4255    i_start =max(its, ids+3)
4256    END IF
4257    IF(config_flags%open_xe .or. specified ) THEN
4258    itf =min(itf, ide-4)
4259    END IF
4260    DO j =j_start, jtf
4261    DO k =2, kte-1
4262    DO i =i_start, itf
4263    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
4264    Tmpv4024(i,k,j) =Tmpv001
4265    Tmpv002 =muu(i+1,j)*Tmpv4024(i,k,j)
4266    Tmpv003 =Tmpv002*msfux(i+1,j)
4267    Tmpv004 =u(i,k,j) +u(i,k-1,j)
4268    Tmpv4025(i,k,j) =Tmpv004
4269    Tmpv005 =muu(i,j)*Tmpv4025(i,k,j)
4270    Tmpv006 =Tmpv005*msfux(i,j)
4271    Tmpv007 =Tmpv003 +Tmpv006
4272    Tmpv008 =Tmpv007*(1./60.)
4273    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
4274    Tmpv010 =45.*Tmpv009
4275    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
4276    Tmpv012 =9.*Tmpv011
4277    Tmpv013 =Tmpv010 -Tmpv012
4278    Tmpv014 =ph(i+3,k,j) -ph(i-3,k,j)
4279    Tmpv015 =Tmpv013 +Tmpv014
4280    Tmpv016 =Tmpv015 +45.*(phb(i+1,k,j)-phb(i-1,k,j))
4281    Tmpv017 =Tmpv016 -9.*(phb(i+2,k,j)-phb(i-2,k,j))
4282    Tmpv018 =Tmpv017 +(phb(i+3,k,j)-phb(i-3,k,j))
4283    Tmpv4026(i,k,j) =Tmpv008
4284    Tmpv4027(i,k,j) =Tmpv018
4285    Tmpv019 =Tmpv4026(i,k,j)*Tmpv4027(i,k,j)
4286    Tmpv020 =(0.25*rdx/msfty(i,j))*Tmpv019
4287    Tmpv021 =ph_tend(i,k,j) -Tmpv020
4288 !  ph_tend(i,k,j) =Tmpv021
4289
4290    ENDDO
4291    ENDDO
4292    k =kte
4293
4294    DO i =i_start, itf
4295    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
4296    Tmpv3068(i,j) =Tmpv001
4297    Tmpv002 =muu(i+1,j)*Tmpv3068(i,j)
4298    Tmpv003 =Tmpv002*msfux(i+1,j)
4299    Tmpv004 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
4300    Tmpv3069(i,j) =Tmpv004
4301    Tmpv005 =muu(i,j)*Tmpv3069(i,j)
4302    Tmpv006 =Tmpv005*msfux(i,j)
4303    Tmpv007 =Tmpv003 +Tmpv006
4304    Tmpv008 =Tmpv007*(1./60.)
4305    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
4306    Tmpv010 =45.*Tmpv009
4307    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
4308    Tmpv012 =9.*Tmpv011
4309    Tmpv013 =Tmpv010 -Tmpv012
4310    Tmpv014 =ph(i+3,k,j) -ph(i-3,k,j)
4311    Tmpv015 =Tmpv013 +Tmpv014
4312    Tmpv016 =Tmpv015 +45.*(phb(i+1,k,j)-phb(i-1,k,j))
4313    Tmpv017 =Tmpv016 -9.*(phb(i+2,k,j)-phb(i-2,k,j))
4314    Tmpv018 =Tmpv017 +(phb(i+3,k,j)-phb(i-3,k,j))
4315    Tmpv3070(i,j) =Tmpv008
4316    Tmpv3071(i,j) =Tmpv018
4317    Tmpv019 =Tmpv3070(i,j)*Tmpv3071(i,j)
4318    Tmpv020 =(0.5*rdx/msfty(i,j))*Tmpv019
4319    Tmpv021 =ph_tend(i,k,j) -Tmpv020
4320 !  ph_tend(i,k,j) =Tmpv021
4321
4322    ENDDO
4323    ENDDO
4324    IF( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN
4325    i =ids+2
4326    DO j =j_start, jtf
4327    DO k =2, kte-1
4328    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
4329    Tmpv3072(k,j) =Tmpv001
4330    Tmpv002 =muu(i+1,j)*Tmpv3072(k,j)
4331    Tmpv003 =Tmpv002*msfux(i+1,j)
4332    Tmpv004 =u(i,k,j) +u(i,k-1,j)
4333    Tmpv3073(k,j) =Tmpv004
4334    Tmpv005 =muu(i,j)*Tmpv3073(k,j)
4335    Tmpv006 =Tmpv005*msfux(i,j)
4336    Tmpv007 =Tmpv003 +Tmpv006
4337    Tmpv008 =Tmpv007*(1./12.)
4338    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
4339    Tmpv010 =8.*Tmpv009
4340    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
4341    Tmpv012 =Tmpv010 -Tmpv011
4342    Tmpv013 =Tmpv012 +8.*(phb(i+1,k,j)-phb(i-1,k,j))
4343    Tmpv014 =Tmpv013 -(phb(i+2,k,j)-phb(i-2,k,j))
4344    Tmpv3074(k,j) =Tmpv008
4345    Tmpv3075(k,j) =Tmpv014
4346    Tmpv015 =Tmpv3074(k,j)*Tmpv3075(k,j)
4347    Tmpv016 =(0.25*rdx/msfty(i,j))*Tmpv015
4348    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4349 !  ph_tend(i,k,j) =Tmpv017
4350
4351    ENDDO
4352    k =kte
4353    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
4354    Tmpv2044(j) =Tmpv001
4355    Tmpv002 =muu(i+1,j)*Tmpv2044(j)
4356    Tmpv003 =Tmpv002*msfux(i+1,j)
4357    Tmpv004 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
4358    Tmpv2045(j) =Tmpv004
4359    Tmpv005 =muu(i,j)*Tmpv2045(j)
4360    Tmpv006 =Tmpv005*msfux(i,j)
4361    Tmpv007 =Tmpv003 +Tmpv006
4362    Tmpv008 =Tmpv007*(1./12.)
4363    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
4364    Tmpv010 =8.*Tmpv009
4365    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
4366    Tmpv012 =Tmpv010 -Tmpv011
4367    Tmpv013 =Tmpv012 +8.*(phb(i+1,k,j)-phb(i-1,k,j))
4368    Tmpv014 =Tmpv013 -(phb(i+2,k,j)-phb(i-2,k,j))
4369    Tmpv2046(j) =Tmpv008
4370    Tmpv2047(j) =Tmpv014
4371    Tmpv015 =Tmpv2046(j)*Tmpv2047(j)
4372    Tmpv016 =(0.5*rdx/msfty(i,j))*Tmpv015
4373    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4374 !  ph_tend(i,k,j) =Tmpv017
4375
4376    ENDDO
4377
4378    END IF
4379    IF( (config_flags%open_xe) .and. its <= ide-3 .and. ide-3 <= ite ) THEN
4380    i =ide-3
4381    DO j =j_start, jtf
4382    DO k =2, kte-1
4383    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
4384    Tmpv3076(k,j) =Tmpv001
4385    Tmpv002 =muu(i+1,j)*Tmpv3076(k,j)
4386    Tmpv003 =Tmpv002*msfux(i+1,j)
4387    Tmpv004 =u(i,k,j) +u(i,k-1,j)
4388    Tmpv3077(k,j) =Tmpv004
4389    Tmpv005 =muu(i,j)*Tmpv3077(k,j)
4390    Tmpv006 =Tmpv005*msfux(i,j)
4391    Tmpv007 =Tmpv003 +Tmpv006
4392    Tmpv008 =Tmpv007*(1./12.)
4393    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
4394    Tmpv010 =8.*Tmpv009
4395    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
4396    Tmpv012 =Tmpv010 -Tmpv011
4397    Tmpv013 =Tmpv012 +8.*(phb(i+1,k,j)-phb(i-1,k,j))
4398    Tmpv014 =Tmpv013 -(phb(i+2,k,j)-phb(i-2,k,j))
4399    Tmpv3078(k,j) =Tmpv008
4400    Tmpv3079(k,j) =Tmpv014
4401    Tmpv015 =Tmpv3078(k,j)*Tmpv3079(k,j)
4402    Tmpv016 =(0.25*rdx/msfty(i,j))*Tmpv015
4403    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4404 !  ph_tend(i,k,j) =Tmpv017
4405
4406    ENDDO
4407    k =kte
4408    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
4409    Tmpv2048(j) =Tmpv001
4410    Tmpv002 =muu(i+1,j)*Tmpv2048(j)
4411    Tmpv003 =Tmpv002*msfux(i+1,j)
4412    Tmpv004 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
4413    Tmpv2049(j) =Tmpv004
4414    Tmpv005 =muu(i,j)*Tmpv2049(j)
4415    Tmpv006 =Tmpv005*msfux(i,j)
4416    Tmpv007 =Tmpv003 +Tmpv006
4417    Tmpv008 =Tmpv007*(1./12.)
4418    Tmpv009 =ph(i+1,k,j) -ph(i-1,k,j)
4419    Tmpv010 =8.*Tmpv009
4420    Tmpv011 =ph(i+2,k,j) -ph(i-2,k,j)
4421    Tmpv012 =Tmpv010 -Tmpv011
4422    Tmpv013 =Tmpv012 +8.*(phb(i+1,k,j)-phb(i-1,k,j))
4423    Tmpv014 =Tmpv013 -(phb(i+2,k,j)-phb(i-2,k,j))
4424    Tmpv2050(j) =Tmpv008
4425    Tmpv2051(j) =Tmpv014
4426    Tmpv015 =Tmpv2050(j)*Tmpv2051(j)
4427    Tmpv016 =(0.5*rdx/msfty(i,j))*Tmpv015
4428    Tmpv017 =ph_tend(i,k,j) -Tmpv016
4429 !  ph_tend(i,k,j) =Tmpv017
4430
4431    ENDDO
4432
4433    END IF
4434    IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) THEN
4435    i =ids+1
4436    DO j =j_start, jtf
4437    DO k =2, kte-1
4438    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
4439    Tmpv3080(k,j) =Tmpv001
4440    Tmpv002 =muu(i+1,j)*Tmpv3080(k,j)
4441    Tmpv003 =Tmpv002*msfux(i+1,j)
4442    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
4443    Tmpv3081(k,j) =Tmpv003
4444    Tmpv3082(k,j) =Tmpv004
4445    Tmpv005 =Tmpv3081(k,j)*Tmpv3082(k,j)
4446    Tmpv006 =u(i,k,j) +u(i,k-1,j)
4447    Tmpv3083(k,j) =Tmpv006
4448    Tmpv007 =muu(i,j)*Tmpv3083(k,j)
4449    Tmpv008 =Tmpv007*msfux(i,j)
4450    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
4451    Tmpv3084(k,j) =Tmpv008
4452    Tmpv3085(k,j) =Tmpv009
4453    Tmpv010 =Tmpv3084(k,j)*Tmpv3085(k,j)
4454    Tmpv011 =Tmpv005 +Tmpv010
4455    Tmpv012 =(0.25*rdx/msfty(i,j))*Tmpv011
4456    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4457 !  ph_tend(i,k,j) =Tmpv013
4458
4459    ENDDO
4460    ENDDO
4461    k =kte
4462    DO j =j_start, jtf
4463    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
4464    Tmpv2052(j) =Tmpv001
4465    Tmpv002 =muu(i+1,j)*Tmpv2052(j)
4466    Tmpv003 =Tmpv002*msfux(i+1,j)
4467    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
4468    Tmpv2053(j) =Tmpv003
4469    Tmpv2054(j) =Tmpv004
4470    Tmpv005 =Tmpv2053(j)*Tmpv2054(j)
4471    Tmpv006 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
4472    Tmpv2055(j) =Tmpv006
4473    Tmpv007 =muu(i,j)*Tmpv2055(j)
4474    Tmpv008 =Tmpv007*msfux(i,j)
4475    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
4476    Tmpv2056(j) =Tmpv008
4477    Tmpv2057(j) =Tmpv009
4478    Tmpv010 =Tmpv2056(j)*Tmpv2057(j)
4479    Tmpv011 =Tmpv005 +Tmpv010
4480    Tmpv012 =(0.5*rdx/msfty(i,j))*Tmpv011
4481    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4482 !  ph_tend(i,k,j) =Tmpv013
4483
4484    ENDDO
4485
4486    END IF
4487    IF( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) THEN
4488    i =ide-2
4489    DO j =j_start, jtf
4490    DO k =2, kte-1
4491    Tmpv001 =u(i+1,k,j) +u(i+1,k-1,j)
4492    Tmpv3086(k,j) =Tmpv001
4493    Tmpv002 =muu(i+1,j)*Tmpv3086(k,j)
4494    Tmpv003 =Tmpv002*msfux(i+1,j)
4495    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
4496    Tmpv3087(k,j) =Tmpv003
4497    Tmpv3088(k,j) =Tmpv004
4498    Tmpv005 =Tmpv3087(k,j)*Tmpv3088(k,j)
4499    Tmpv006 =u(i,k,j) +u(i,k-1,j)
4500    Tmpv3089(k,j) =Tmpv006
4501    Tmpv007 =muu(i,j)*Tmpv3089(k,j)
4502    Tmpv008 =Tmpv007*msfux(i,j)
4503    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
4504    Tmpv3090(k,j) =Tmpv008
4505    Tmpv3091(k,j) =Tmpv009
4506    Tmpv010 =Tmpv3090(k,j)*Tmpv3091(k,j)
4507    Tmpv011 =Tmpv005 +Tmpv010
4508    Tmpv012 =(0.25*rdx/msfty(i,j))*Tmpv011
4509    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4510 !  ph_tend(i,k,j) =Tmpv013
4511
4512    ENDDO
4513    ENDDO
4514    k =kte
4515    DO j =j_start, jtf
4516    Tmpv001 =cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)
4517    Tmpv2058(j) =Tmpv001
4518    Tmpv002 =muu(i+1,j)*Tmpv2058(j)
4519    Tmpv003 =Tmpv002*msfux(i+1,j)
4520    Tmpv004 =phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)
4521    Tmpv2059(j) =Tmpv003
4522    Tmpv2060(j) =Tmpv004
4523    Tmpv005 =Tmpv2059(j)*Tmpv2060(j)
4524    Tmpv006 =cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)
4525    Tmpv2061(j) =Tmpv006
4526    Tmpv007 =muu(i,j)*Tmpv2061(j)
4527    Tmpv008 =Tmpv007*msfux(i,j)
4528    Tmpv009 =phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)
4529    Tmpv2062(j) =Tmpv008
4530    Tmpv2063(j) =Tmpv009
4531    Tmpv010 =Tmpv2062(j)*Tmpv2063(j)
4532    Tmpv011 =Tmpv005 +Tmpv010
4533    Tmpv012 =(0.5*rdx/msfty(i,j))*Tmpv011
4534    Tmpv013 =ph_tend(i,k,j) -Tmpv012
4535 !  ph_tend(i,k,j) =Tmpv013
4536
4537    ENDDO
4538
4539    END IF
4540    END IF
4541
4542    IF(advective_order <= 2) THEN
4543
4544 ! Added by Ning Pan, 2010-07-20
4545 !  x (u) advection
4546    i_start = its
4547    j_start = jts
4548    itf=MIN(ite,ide-1)
4549    jtf=MIN(jte,jde-1)
4550    IF ( (config_flags%open_xs .or. specified) .and. its == ids ) i_start = its+1
4551    IF ( (config_flags%open_xe .or. specified) .and. ite == ide ) itf = itf-2
4552
4553    DO j =jtf, j_start, -1
4554    k = kte  ! Added by Ning Pan, 2010-07-20
4555    DO i =itf, i_start, -1
4556    a_Tmpv13 =a_ph_tend(i,k,j)
4557    a_ph_tend(i,k,j) =0.0
4558    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4559    a_Tmpv12 =-a_Tmpv13
4560    a_Tmpv11 =(0.5*rdx/msfty(i,j))*a_Tmpv12
4561    a_Tmpv5 =a_Tmpv11
4562    a_Tmpv10 =a_Tmpv11
4563    a_Tmpv8 =Tmpv3011(i,j)*a_Tmpv10
4564    a_Tmpv9 =Tmpv3010(i,j)*a_Tmpv10
4565    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4566    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4567    a_Tmpv7 =msfux(i,j)*a_Tmpv8
4568    a_muu(i,j) =a_muu(i,j) +Tmpv309(i,j)*a_Tmpv7
4569    a_Tmpv6 =muu(i,j)*a_Tmpv7
4570    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv6
4571    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv6
4572    a_Tmpv3 =Tmpv308(i,j)*a_Tmpv5
4573    a_Tmpv4 =Tmpv307(i,j)*a_Tmpv5
4574    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4575    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4576    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4577    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv306(i,j)*a_Tmpv2
4578    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4579    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
4580    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
4581    ENDDO
4582    DO k =kte-1, 2, -1
4583    DO i =itf, i_start, -1
4584    a_Tmpv13 =a_ph_tend(i,k,j)
4585    a_ph_tend(i,k,j) =0.0
4586    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4587    a_Tmpv12 =-a_Tmpv13
4588    a_Tmpv11 =(0.25*rdx/msfty(i,j))*a_Tmpv12
4589    a_Tmpv5 =a_Tmpv11
4590    a_Tmpv10 =a_Tmpv11
4591    a_Tmpv8 =Tmpv4011(i,k,j)*a_Tmpv10
4592    a_Tmpv9 =Tmpv4010(i,k,j)*a_Tmpv10
4593    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4594    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4595    a_Tmpv7 =msfux(i,j)*a_Tmpv8
4596    a_muu(i,j) =a_muu(i,j) +Tmpv409(i,k,j)*a_Tmpv7
4597    a_Tmpv6 =muu(i,j)*a_Tmpv7
4598    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv6
4599    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv6
4600    a_Tmpv3 =Tmpv408(i,k,j)*a_Tmpv5
4601    a_Tmpv4 =Tmpv407(i,k,j)*a_Tmpv5
4602    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4603    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4604    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4605    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv406(i,k,j)*a_Tmpv2
4606    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4607    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
4608    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
4609    ENDDO
4610    ENDDO
4611    ENDDO
4612
4613 ! Remarked by Ning Pan, 2010-07-20
4614 !   IF( (config_flags%open_xe .or. specified) .and. ite == ide ) THEN
4615
4616 !   END IF
4617
4618 !   IF( (config_flags%open_xs .or. specified) .and. its == ids ) THEN
4619
4620 !   END IF
4621
4622 ! Added by Ning Pan, 2010-07-20
4623 !  y (v) advection
4624    i_start = its
4625    j_start = jts
4626    itf=MIN(ite,ide-1)
4627    jtf=MIN(jte,jde-1)
4628    IF ( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start = jts+1
4629    IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jtf-2
4630
4631    DO j =jtf, j_start, -1
4632    k = kte  ! Added by Ning Pan, 2010-07-20
4633    DO i =itf, i_start, -1
4634    a_Tmpv13 =a_ph_tend(i,k,j)
4635    a_ph_tend(i,k,j) =0.0
4636    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4637    a_Tmpv12 =-a_Tmpv13
4638    a_Tmpv11 =(0.5*rdy/msfty(i,j))*a_Tmpv12
4639    a_Tmpv5 =a_Tmpv11
4640    a_Tmpv10 =a_Tmpv11
4641    a_Tmpv8 =Tmpv305(i,j)*a_Tmpv10
4642    a_Tmpv9 =Tmpv304(i,j)*a_Tmpv10
4643    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4644    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
4645    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
4646    a_muv(i,j) =a_muv(i,j) +Tmpv303(i,j)*a_Tmpv7
4647    a_Tmpv6 =muv(i,j)*a_Tmpv7
4648    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv6
4649    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv6
4650    a_Tmpv3 =Tmpv302(i,j)*a_Tmpv5
4651    a_Tmpv4 =Tmpv301(i,j)*a_Tmpv5
4652    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
4653    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4654    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
4655    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv300(i,j)*a_Tmpv2
4656    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
4657    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
4658    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
4659    ENDDO
4660    DO k =kte-1, 2, -1
4661    DO i =itf, i_start, -1
4662    a_Tmpv13 =a_ph_tend(i,k,j)
4663    a_ph_tend(i,k,j) =0.0
4664    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4665    a_Tmpv12 =-a_Tmpv13
4666    a_Tmpv11 =(0.25*rdy/msfty(i,j))*a_Tmpv12
4667    a_Tmpv5 =a_Tmpv11
4668    a_Tmpv10 =a_Tmpv11
4669    a_Tmpv8 =Tmpv405(i,k,j)*a_Tmpv10
4670    a_Tmpv9 =Tmpv404(i,k,j)*a_Tmpv10
4671    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4672    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
4673    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
4674    a_muv(i,j) =a_muv(i,j) +Tmpv403(i,k,j)*a_Tmpv7
4675    a_Tmpv6 =muv(i,j)*a_Tmpv7
4676    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv6
4677    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv6
4678    a_Tmpv3 =Tmpv402(i,k,j)*a_Tmpv5
4679    a_Tmpv4 =Tmpv401(i,k,j)*a_Tmpv5
4680    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
4681    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4682    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
4683    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv400(i,k,j)*a_Tmpv2
4684    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
4685    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
4686    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
4687    ENDDO
4688    ENDDO
4689    ENDDO
4690
4691 ! Remarked by Ning Pan, 2010-07-20
4692 !   IF( (config_flags%open_ye .or. specified) .and. jte == jde ) THEN
4693
4694 !   END IF
4695
4696 !   IF( (config_flags%open_ys .or. specified) .and. jts == jds ) THEN
4697
4698 !   END IF
4699
4700    ELSE IF(advective_order <= 4) THEN
4701
4702 ! Added by Ning Pan, 2010-07-20
4703 !  x (u) advection
4704    i_start = its
4705    j_start = jts
4706    itf=MIN(ite,ide-1)
4707    jtf=MIN(jte,jde-1)
4708    IF ( (config_flags%open_xs) .and. its == ids ) i_start = its+2
4709    IF ( (config_flags%open_xe) .and. ite == ide ) itf = itf-3
4710
4711    IF( (config_flags%open_xe .or. specified) .and. ite >= ide-2 ) THEN
4712
4713    i = ide-2  ! Added by Ning Pan, 2010-07-20
4714    k = kte  ! Added by Ning Pan, 2010-07-20
4715    DO j =jtf, j_start, -1
4716    a_Tmpv13 =a_ph_tend(i,k,j)
4717    a_ph_tend(i,k,j) =0.0
4718    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4719    a_Tmpv12 =-a_Tmpv13
4720    a_Tmpv11 =(0.5*rdx/msfty(i,j))*a_Tmpv12
4721    a_Tmpv5 =a_Tmpv11
4722    a_Tmpv10 =a_Tmpv11
4723    a_Tmpv8 =Tmpv2023(j)*a_Tmpv10
4724    a_Tmpv9 =Tmpv2022(j)*a_Tmpv10
4725    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4726    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4727    a_Tmpv7 =msfux(i,j)*a_Tmpv8
4728    a_muu(i,j) =a_muu(i,j) +Tmpv2021(j)*a_Tmpv7
4729    a_Tmpv6 =muu(i,j)*a_Tmpv7
4730    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv6
4731    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv6
4732    a_Tmpv3 =Tmpv2020(j)*a_Tmpv5
4733    a_Tmpv4 =Tmpv2019(j)*a_Tmpv5
4734    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4735    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4736    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4737    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2018(j)*a_Tmpv2
4738    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4739    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
4740    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
4741    ENDDO
4742    DO j =jtf, j_start, -1
4743    DO k =kte-1, 2, -1
4744    a_Tmpv13 =a_ph_tend(i,k,j)
4745    a_ph_tend(i,k,j) =0.0
4746    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4747    a_Tmpv12 =-a_Tmpv13
4748    a_Tmpv11 =(0.25*rdx/msfty(i,j))*a_Tmpv12
4749    a_Tmpv5 =a_Tmpv11
4750    a_Tmpv10 =a_Tmpv11
4751    a_Tmpv8 =Tmpv3043(k,j)*a_Tmpv10
4752    a_Tmpv9 =Tmpv3042(k,j)*a_Tmpv10
4753    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4754    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4755    a_Tmpv7 =msfux(i,j)*a_Tmpv8
4756    a_muu(i,j) =a_muu(i,j) +Tmpv3041(k,j)*a_Tmpv7
4757    a_Tmpv6 =muu(i,j)*a_Tmpv7
4758    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv6
4759    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv6
4760    a_Tmpv3 =Tmpv3040(k,j)*a_Tmpv5
4761    a_Tmpv4 =Tmpv3039(k,j)*a_Tmpv5
4762    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4763    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4764    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4765    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3038(k,j)*a_Tmpv2
4766    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4767    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
4768    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
4769    ENDDO
4770    ENDDO
4771
4772    END IF
4773
4774    IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 ) THEN
4775
4776 ! Added by Ning Pan, 2010-07-20
4777    i = ids + 1  ! Added by Ning Pan, 2010-07-20
4778    k = kte  ! Added by Ning Pan, 2010-07-20
4779    DO j =jtf, j_start, -1
4780    a_Tmpv13 =a_ph_tend(i,k,j)
4781    a_ph_tend(i,k,j) =0.0
4782    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4783    a_Tmpv12 =-a_Tmpv13
4784    a_Tmpv11 =(0.5*rdx/msfty(i,j))*a_Tmpv12
4785    a_Tmpv5 =a_Tmpv11
4786    a_Tmpv10 =a_Tmpv11
4787    a_Tmpv8 =Tmpv2017(j)*a_Tmpv10
4788    a_Tmpv9 =Tmpv2016(j)*a_Tmpv10
4789    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4790    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4791    a_Tmpv7 =msfux(i,j)*a_Tmpv8
4792    a_muu(i,j) =a_muu(i,j) +Tmpv2015(j)*a_Tmpv7
4793    a_Tmpv6 =muu(i,j)*a_Tmpv7
4794    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv6
4795    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv6
4796    a_Tmpv3 =Tmpv2014(j)*a_Tmpv5
4797    a_Tmpv4 =Tmpv2013(j)*a_Tmpv5
4798    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4799    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4800    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4801    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2012(j)*a_Tmpv2
4802    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4803    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
4804    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
4805    ENDDO
4806
4807    DO j =jtf, j_start, -1
4808    DO k =kte-1, 2, -1
4809    a_Tmpv13 =a_ph_tend(i,k,j)
4810    a_ph_tend(i,k,j) =0.0
4811    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4812    a_Tmpv12 =-a_Tmpv13
4813    a_Tmpv11 =(0.25*rdx/msfty(i,j))*a_Tmpv12
4814    a_Tmpv5 =a_Tmpv11
4815    a_Tmpv10 =a_Tmpv11
4816    a_Tmpv8 =Tmpv3037(k,j)*a_Tmpv10
4817    a_Tmpv9 =Tmpv3036(k,j)*a_Tmpv10
4818    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4819    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4820    a_Tmpv7 =msfux(i,j)*a_Tmpv8
4821    a_muu(i,j) =a_muu(i,j) +Tmpv3035(k,j)*a_Tmpv7
4822    a_Tmpv6 =muu(i,j)*a_Tmpv7
4823    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv6
4824    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv6
4825    a_Tmpv3 =Tmpv3034(k,j)*a_Tmpv5
4826    a_Tmpv4 =Tmpv3033(k,j)*a_Tmpv5
4827    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4828    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4829    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4830    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3032(k,j)*a_Tmpv2
4831    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4832    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
4833    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
4834    ENDDO
4835    ENDDO
4836 !   DO j =jtf, j_start, -1
4837 !   a_Tmpv13 =a_ph_tend(i,k,j)
4838 !   a_ph_tend(i,k,j) =0.0
4839 !   a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4840 !   a_Tmpv12 =-a_Tmpv13
4841 !   a_Tmpv11 =(0.5*rdx/msfty(i,j))*a_Tmpv12
4842 !   a_Tmpv5 =a_Tmpv11
4843 !   a_Tmpv10 =a_Tmpv11
4844 !   a_Tmpv8 =Tmpv2017(j)*a_Tmpv10
4845 !   a_Tmpv9 =Tmpv2016(j)*a_Tmpv10
4846 !   a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4847 !   a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4848 !   a_Tmpv7 =msfux(i,j)*a_Tmpv8
4849 !   a_muu(i,j) =a_muu(i,j) +Tmpv2015(j)*a_Tmpv7
4850 !   a_Tmpv6 =muu(i,j)*a_Tmpv7
4851 !   a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv6
4852 !   a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv6
4853 !   a_Tmpv3 =Tmpv2014(j)*a_Tmpv5
4854 !   a_Tmpv4 =Tmpv2013(j)*a_Tmpv5
4855 !   a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
4856 !   a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4857 !   a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4858 !   a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2012(j)*a_Tmpv2
4859 !   a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4860 !   a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
4861 !   a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
4862 !   ENDDO
4863
4864    END IF
4865
4866    DO j =jtf, j_start, -1
4867    k = kte  ! Added by Ning Pan, 2010-07-20
4868    DO i =itf, i_start, -1
4869    a_Tmpv17 =a_ph_tend(i,k,j)
4870    a_ph_tend(i,k,j) =0.0
4871    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
4872    a_Tmpv16 =-a_Tmpv17
4873    a_Tmpv15 =(0.5*rdx/msfty(i,j))*a_Tmpv16
4874    a_Tmpv8 =Tmpv3031(i,j)*a_Tmpv15
4875    a_Tmpv14 =Tmpv3030(i,j)*a_Tmpv15
4876    a_Tmpv13 =a_Tmpv14
4877    a_Tmpv12 =a_Tmpv13
4878    a_Tmpv10 =a_Tmpv12
4879    a_Tmpv11 =-a_Tmpv12
4880    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
4881    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
4882    a_Tmpv9 =8.*a_Tmpv10
4883    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
4884    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4885    a_Tmpv7 =(1./12.)*a_Tmpv8
4886    a_Tmpv3 =a_Tmpv7
4887    a_Tmpv6 =a_Tmpv7
4888    a_Tmpv5 =msfux(i,j)*a_Tmpv6
4889    a_muu(i,j) =a_muu(i,j) +Tmpv3029(i,j)*a_Tmpv5
4890    a_Tmpv4 =muu(i,j)*a_Tmpv5
4891    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv4
4892    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv4
4893    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4894    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3028(i,j)*a_Tmpv2
4895    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4896    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
4897    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
4898    ENDDO
4899    DO k =kte-1, 2, -1
4900    DO i =itf, i_start, -1
4901    a_Tmpv17 =a_ph_tend(i,k,j)
4902    a_ph_tend(i,k,j) =0.0
4903    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
4904    a_Tmpv16 =-a_Tmpv17
4905    a_Tmpv15 =(0.25*rdx/msfty(i,j))*a_Tmpv16
4906    a_Tmpv8 =Tmpv4019(i,k,j)*a_Tmpv15
4907    a_Tmpv14 =Tmpv4018(i,k,j)*a_Tmpv15
4908    a_Tmpv13 =a_Tmpv14
4909    a_Tmpv12 =a_Tmpv13
4910    a_Tmpv10 =a_Tmpv12
4911    a_Tmpv11 =-a_Tmpv12
4912    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
4913    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
4914    a_Tmpv9 =8.*a_Tmpv10
4915    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
4916    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
4917    a_Tmpv7 =(1./12.)*a_Tmpv8
4918    a_Tmpv3 =a_Tmpv7
4919    a_Tmpv6 =a_Tmpv7
4920    a_Tmpv5 =msfux(i,j)*a_Tmpv6
4921    a_muu(i,j) =a_muu(i,j) +Tmpv4017(i,k,j)*a_Tmpv5
4922    a_Tmpv4 =muu(i,j)*a_Tmpv5
4923    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv4
4924    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv4
4925    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
4926    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv4016(i,k,j)*a_Tmpv2
4927    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
4928    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
4929    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
4930    ENDDO
4931    ENDDO
4932    ENDDO
4933
4934 ! Remarked by Ning Pan, 2010-07-20
4935 !   IF( (config_flags%open_xe) .and. ite == ide ) THEN
4936
4937 !   END IF
4938
4939 !   IF( (config_flags%open_xs) .and. its == ids ) THEN
4940
4941 !   END IF
4942
4943 ! Added by Ning Pan, 2010-07-20
4944 !  y (v) advection
4945    i_start = its
4946    j_start = jts
4947    itf=MIN(ite,ide-1)
4948    jtf=MIN(jte,jde-1)
4949    IF ( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start = jts+2
4950    IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jtf-3
4951
4952    IF( (config_flags%open_ye .or. specified) .and. jte >= jde-2 ) THEN
4953
4954    j = jde-2  ! Added by Ning Pan, 2010-07-20
4955    k = kte  ! Added by Ning Pan, 2010-07-20
4956    DO i =itf, i_start, -1
4957    a_Tmpv13 =a_ph_tend(i,k,j)
4958    a_ph_tend(i,k,j) =0.0
4959    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4960    a_Tmpv12 =-a_Tmpv13
4961    a_Tmpv11 =(0.5*rdy/msfty(i,j))*a_Tmpv12
4962    a_Tmpv5 =a_Tmpv11
4963    a_Tmpv10 =a_Tmpv11
4964    a_Tmpv8 =Tmpv2011(i)*a_Tmpv10
4965    a_Tmpv9 =Tmpv2010(i)*a_Tmpv10
4966    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4967    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
4968    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
4969    a_muv(i,j) =a_muv(i,j) +Tmpv209(i)*a_Tmpv7
4970    a_Tmpv6 =muv(i,j)*a_Tmpv7
4971    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv6
4972    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv6
4973    a_Tmpv3 =Tmpv208(i)*a_Tmpv5
4974    a_Tmpv4 =Tmpv207(i)*a_Tmpv5
4975    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
4976    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
4977    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
4978    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv206(i)*a_Tmpv2
4979    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
4980    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
4981    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
4982    ENDDO
4983    DO k =kte-1, 2, -1
4984    DO i =itf, i_start, -1
4985    a_Tmpv13 =a_ph_tend(i,k,j)
4986    a_ph_tend(i,k,j) =0.0
4987    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
4988    a_Tmpv12 =-a_Tmpv13
4989    a_Tmpv11 =(0.25*rdy/msfty(i,j))*a_Tmpv12
4990    a_Tmpv5 =a_Tmpv11
4991    a_Tmpv10 =a_Tmpv11
4992    a_Tmpv8 =Tmpv3027(i,k)*a_Tmpv10
4993    a_Tmpv9 =Tmpv3026(i,k)*a_Tmpv10
4994    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
4995    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
4996    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
4997    a_muv(i,j) =a_muv(i,j) +Tmpv3025(i,k)*a_Tmpv7
4998    a_Tmpv6 =muv(i,j)*a_Tmpv7
4999    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv6
5000    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv6
5001    a_Tmpv3 =Tmpv3024(i,k)*a_Tmpv5
5002    a_Tmpv4 =Tmpv3023(i,k)*a_Tmpv5
5003    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5004    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5005    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5006    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3022(i,k)*a_Tmpv2
5007    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5008    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5009    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5010    ENDDO
5011    ENDDO
5012
5013    END IF
5014
5015    IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 ) THEN
5016
5017    j = jds+1  ! Added by Ning Pan, 2010-07-20
5018    k = kte  ! Added by Ning Pan, 2010-07-20
5019    DO i =itf, i_start, -1
5020    a_Tmpv13 =a_ph_tend(i,k,j)
5021    a_ph_tend(i,k,j) =0.0
5022    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5023    a_Tmpv12 =-a_Tmpv13
5024    a_Tmpv11 =(0.5*rdy/msfty(i,j))*a_Tmpv12
5025    a_Tmpv5 =a_Tmpv11
5026    a_Tmpv10 =a_Tmpv11
5027    a_Tmpv8 =Tmpv205(i)*a_Tmpv10
5028    a_Tmpv9 =Tmpv204(i)*a_Tmpv10
5029    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5030    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5031    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5032    a_muv(i,j) =a_muv(i,j) +Tmpv203(i)*a_Tmpv7
5033    a_Tmpv6 =muv(i,j)*a_Tmpv7
5034    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv6
5035    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv6
5036    a_Tmpv3 =Tmpv202(i)*a_Tmpv5
5037    a_Tmpv4 =Tmpv201(i)*a_Tmpv5
5038    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5039    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5040    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5041    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv200(i)*a_Tmpv2
5042    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5043    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5044    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5045    ENDDO
5046
5047    DO k =kte-1, 2, -1
5048    DO i =itf, i_start, -1
5049    a_Tmpv13 =a_ph_tend(i,k,j)
5050    a_ph_tend(i,k,j) =0.0
5051    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5052    a_Tmpv12 =-a_Tmpv13
5053    a_Tmpv11 =(0.25*rdy/msfty(i,j))*a_Tmpv12
5054    a_Tmpv5 =a_Tmpv11
5055    a_Tmpv10 =a_Tmpv11
5056    a_Tmpv8 =Tmpv3021(i,k)*a_Tmpv10
5057    a_Tmpv9 =Tmpv3020(i,k)*a_Tmpv10
5058    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5059    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5060    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5061    a_muv(i,j) =a_muv(i,j) +Tmpv3019(i,k)*a_Tmpv7
5062    a_Tmpv6 =muv(i,j)*a_Tmpv7
5063    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv6
5064    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv6
5065    a_Tmpv3 =Tmpv3018(i,k)*a_Tmpv5
5066    a_Tmpv4 =Tmpv3017(i,k)*a_Tmpv5
5067    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5068    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5069    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5070    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3016(i,k)*a_Tmpv2
5071    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5072    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5073    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5074    ENDDO
5075    ENDDO
5076 ! Remarked by Ning Pan, 2010-07-20
5077 !   DO i =itf, i_start, -1
5078 !   a_Tmpv13 =a_ph_tend(i,k,j)
5079 !   a_ph_tend(i,k,j) =0.0
5080 !   a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5081 !   a_Tmpv12 =-a_Tmpv13
5082 !   a_Tmpv11 =(0.5*rdy/msfty(i,j))*a_Tmpv12
5083 !   a_Tmpv5 =a_Tmpv11
5084 !   a_Tmpv10 =a_Tmpv11
5085 !   a_Tmpv8 =Tmpv205(i)*a_Tmpv10
5086 !   a_Tmpv9 =Tmpv204(i)*a_Tmpv10
5087 !   a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5088 !   a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5089 !   a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5090 !   a_muv(i,j) =a_muv(i,j) +Tmpv203(i)*a_Tmpv7
5091 !   a_Tmpv6 =muv(i,j)*a_Tmpv7
5092 !   a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv6
5093 !   a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv6
5094 !   a_Tmpv3 =Tmpv202(i)*a_Tmpv5
5095 !   a_Tmpv4 =Tmpv201(i)*a_Tmpv5
5096 !   a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5097 !   a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5098 !   a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5099 !   a_muv(i,j+1) =a_muv(i,j+1) +Tmpv200(i)*a_Tmpv2
5100 !   a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5101 !   a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5102 !   a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5103 !   ENDDO
5104
5105    END IF
5106    DO j =jtf, j_start, -1
5107    k = kte  ! Added by Ning Pan, 2010-07-20
5108    DO i =itf, i_start, -1
5109    a_Tmpv17 =a_ph_tend(i,k,j)
5110    a_ph_tend(i,k,j) =0.0
5111    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5112    a_Tmpv16 =-a_Tmpv17
5113    a_Tmpv15 =(0.5*rdy/msfty(i,j))*a_Tmpv16
5114    a_Tmpv8 =Tmpv3015(i,j)*a_Tmpv15
5115    a_Tmpv14 =Tmpv3014(i,j)*a_Tmpv15
5116    a_Tmpv13 =a_Tmpv14
5117    a_Tmpv12 =a_Tmpv13
5118    a_Tmpv10 =a_Tmpv12
5119    a_Tmpv11 =-a_Tmpv12
5120    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5121    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5122    a_Tmpv9 =8.*a_Tmpv10
5123    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5124    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5125    a_Tmpv7 =(1./12.)*a_Tmpv8
5126    a_Tmpv3 =a_Tmpv7
5127    a_Tmpv6 =a_Tmpv7
5128    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5129    a_muv(i,j) =a_muv(i,j) +Tmpv3013(i,j)*a_Tmpv5
5130    a_Tmpv4 =muv(i,j)*a_Tmpv5
5131    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv4
5132    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv4
5133    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5134    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3012(i,j)*a_Tmpv2
5135    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5136    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5137    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5138    ENDDO
5139    DO k =kte-1, 2, -1
5140    DO i =itf, i_start, -1
5141    a_Tmpv17 =a_ph_tend(i,k,j)
5142    a_ph_tend(i,k,j) =0.0
5143    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5144    a_Tmpv16 =-a_Tmpv17
5145    a_Tmpv15 =(0.25*rdy/msfty(i,j))*a_Tmpv16
5146    a_Tmpv8 =Tmpv4015(i,k,j)*a_Tmpv15
5147    a_Tmpv14 =Tmpv4014(i,k,j)*a_Tmpv15
5148    a_Tmpv13 =a_Tmpv14
5149    a_Tmpv12 =a_Tmpv13
5150    a_Tmpv10 =a_Tmpv12
5151    a_Tmpv11 =-a_Tmpv12
5152    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5153    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5154    a_Tmpv9 =8.*a_Tmpv10
5155    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5156    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5157    a_Tmpv7 =(1./12.)*a_Tmpv8
5158    a_Tmpv3 =a_Tmpv7
5159    a_Tmpv6 =a_Tmpv7
5160    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5161    a_muv(i,j) =a_muv(i,j) +Tmpv4013(i,k,j)*a_Tmpv5
5162    a_Tmpv4 =muv(i,j)*a_Tmpv5
5163    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv4
5164    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv4
5165    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5166    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv4012(i,k,j)*a_Tmpv2
5167    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5168    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5169    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5170    ENDDO
5171    ENDDO
5172    ENDDO
5173
5174 ! Remarked by Ning Pan, 2010-07-20
5175 !   IF( (config_flags%open_ye .or. specified) .and. jte == jde ) THEN
5176
5177 !   END IF
5178
5179 !   IF( (config_flags%open_ys .or. specified) .and. jts == jds ) THEN
5180
5181 !   END IF
5182
5183    ELSE IF(advective_order <= 6) THEN
5184
5185 ! Added by Ning Pan, 2010-07-20
5186 !  x (u) advection
5187    i_start = its
5188    j_start = jts
5189    itf=MIN(ite,ide-1)
5190    jtf=MIN(jte,jde-1)
5191    IF (config_flags%open_xs .or. specified ) i_start = max(its,ids+3)
5192    IF (config_flags%open_xe .or. specified ) itf     = min(itf,ide-4)
5193
5194    IF( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) THEN
5195
5196    i = ide-2  ! Added by Ning Pan, 2010-07-20
5197    k = kte  ! Added by Ning Pan, 2010-07-20
5198    DO j =jtf, j_start, -1
5199    a_Tmpv13 =a_ph_tend(i,k,j)
5200    a_ph_tend(i,k,j) =0.0
5201    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5202    a_Tmpv12 =-a_Tmpv13
5203    a_Tmpv11 =(0.5*rdx/msfty(i,j))*a_Tmpv12
5204    a_Tmpv5 =a_Tmpv11
5205    a_Tmpv10 =a_Tmpv11
5206    a_Tmpv8 =Tmpv2063(j)*a_Tmpv10
5207    a_Tmpv9 =Tmpv2062(j)*a_Tmpv10
5208    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5209    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5210    a_Tmpv7 =msfux(i,j)*a_Tmpv8
5211    a_muu(i,j) =a_muu(i,j) +Tmpv2061(j)*a_Tmpv7
5212    a_Tmpv6 =muu(i,j)*a_Tmpv7
5213    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv6
5214    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv6
5215    a_Tmpv3 =Tmpv2060(j)*a_Tmpv5
5216    a_Tmpv4 =Tmpv2059(j)*a_Tmpv5
5217    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
5218    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5219    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5220    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2058(j)*a_Tmpv2
5221    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5222    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
5223    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
5224    ENDDO
5225    DO j =jtf, j_start, -1
5226    DO k =kte-1, 2, -1
5227    a_Tmpv13 =a_ph_tend(i,k,j)
5228    a_ph_tend(i,k,j) =0.0
5229    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5230    a_Tmpv12 =-a_Tmpv13
5231    a_Tmpv11 =(0.25*rdx/msfty(i,j))*a_Tmpv12
5232    a_Tmpv5 =a_Tmpv11
5233    a_Tmpv10 =a_Tmpv11
5234    a_Tmpv8 =Tmpv3091(k,j)*a_Tmpv10
5235    a_Tmpv9 =Tmpv3090(k,j)*a_Tmpv10
5236    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5237    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5238    a_Tmpv7 =msfux(i,j)*a_Tmpv8
5239    a_muu(i,j) =a_muu(i,j) +Tmpv3089(k,j)*a_Tmpv7
5240    a_Tmpv6 =muu(i,j)*a_Tmpv7
5241    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv6
5242    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv6
5243    a_Tmpv3 =Tmpv3088(k,j)*a_Tmpv5
5244    a_Tmpv4 =Tmpv3087(k,j)*a_Tmpv5
5245    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
5246    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5247    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5248    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3086(k,j)*a_Tmpv2
5249    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5250    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
5251    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
5252    ENDDO
5253    ENDDO
5254
5255    END IF
5256
5257    IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) THEN
5258
5259    i = ids + 1  ! Added by Ning Pan, 2010-07-20
5260    k = kte  ! Added by Ning Pan, 2010-07-20
5261    DO j =jtf, j_start, -1
5262    a_Tmpv13 =a_ph_tend(i,k,j)
5263    a_ph_tend(i,k,j) =0.0
5264    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5265    a_Tmpv12 =-a_Tmpv13
5266    a_Tmpv11 =(0.5*rdx/msfty(i,j))*a_Tmpv12
5267    a_Tmpv5 =a_Tmpv11
5268    a_Tmpv10 =a_Tmpv11
5269    a_Tmpv8 =Tmpv2057(j)*a_Tmpv10
5270    a_Tmpv9 =Tmpv2056(j)*a_Tmpv10
5271    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5272    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5273    a_Tmpv7 =msfux(i,j)*a_Tmpv8
5274    a_muu(i,j) =a_muu(i,j) +Tmpv2055(j)*a_Tmpv7
5275    a_Tmpv6 =muu(i,j)*a_Tmpv7
5276    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv6
5277    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv6
5278    a_Tmpv3 =Tmpv2054(j)*a_Tmpv5
5279    a_Tmpv4 =Tmpv2053(j)*a_Tmpv5
5280    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
5281    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5282    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5283    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2052(j)*a_Tmpv2
5284    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5285    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
5286    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
5287    ENDDO
5288    DO j =jtf, j_start, -1
5289    DO k =kte-1, 2, -1
5290    a_Tmpv13 =a_ph_tend(i,k,j)
5291    a_ph_tend(i,k,j) =0.0
5292    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5293    a_Tmpv12 =-a_Tmpv13
5294    a_Tmpv11 =(0.25*rdx/msfty(i,j))*a_Tmpv12
5295    a_Tmpv5 =a_Tmpv11
5296    a_Tmpv10 =a_Tmpv11
5297    a_Tmpv8 =Tmpv3085(k,j)*a_Tmpv10
5298    a_Tmpv9 =Tmpv3084(k,j)*a_Tmpv10
5299    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5300    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5301    a_Tmpv7 =msfux(i,j)*a_Tmpv8
5302    a_muu(i,j) =a_muu(i,j) +Tmpv3083(k,j)*a_Tmpv7
5303    a_Tmpv6 =muu(i,j)*a_Tmpv7
5304    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv6
5305    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv6
5306    a_Tmpv3 =Tmpv3082(k,j)*a_Tmpv5
5307    a_Tmpv4 =Tmpv3081(k,j)*a_Tmpv5
5308    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv4
5309    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5310    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5311    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3080(k,j)*a_Tmpv2
5312    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5313    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
5314    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
5315    ENDDO
5316    ENDDO
5317
5318    END IF
5319
5320    IF( (config_flags%open_xe) .and. its <= ide-3 .and. ide-3 <= ite ) THEN
5321
5322    i = ide-3  ! Added by Ning Pan, 2010-07-20
5323    DO j =jtf, j_start, -1
5324    k = kte  ! Added by Ning Pan, 2010-07-20
5325    a_Tmpv17 =a_ph_tend(i,k,j)
5326    a_ph_tend(i,k,j) =0.0
5327    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5328    a_Tmpv16 =-a_Tmpv17
5329    a_Tmpv15 =(0.5*rdx/msfty(i,j))*a_Tmpv16
5330    a_Tmpv8 =Tmpv2051(j)*a_Tmpv15
5331    a_Tmpv14 =Tmpv2050(j)*a_Tmpv15
5332    a_Tmpv13 =a_Tmpv14
5333    a_Tmpv12 =a_Tmpv13
5334    a_Tmpv10 =a_Tmpv12
5335    a_Tmpv11 =-a_Tmpv12
5336    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
5337    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
5338    a_Tmpv9 =8.*a_Tmpv10
5339    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
5340    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5341    a_Tmpv7 =(1./12.)*a_Tmpv8
5342    a_Tmpv3 =a_Tmpv7
5343    a_Tmpv6 =a_Tmpv7
5344    a_Tmpv5 =msfux(i,j)*a_Tmpv6
5345    a_muu(i,j) =a_muu(i,j) +Tmpv2049(j)*a_Tmpv5
5346    a_Tmpv4 =muu(i,j)*a_Tmpv5
5347    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv4
5348    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv4
5349    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5350    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2048(j)*a_Tmpv2
5351    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5352    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
5353    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
5354    DO k =kte-1, 2, -1
5355    a_Tmpv17 =a_ph_tend(i,k,j)
5356    a_ph_tend(i,k,j) =0.0
5357    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5358    a_Tmpv16 =-a_Tmpv17
5359    a_Tmpv15 =(0.25*rdx/msfty(i,j))*a_Tmpv16
5360    a_Tmpv8 =Tmpv3079(k,j)*a_Tmpv15
5361    a_Tmpv14 =Tmpv3078(k,j)*a_Tmpv15
5362    a_Tmpv13 =a_Tmpv14
5363    a_Tmpv12 =a_Tmpv13
5364    a_Tmpv10 =a_Tmpv12
5365    a_Tmpv11 =-a_Tmpv12
5366    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
5367    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
5368    a_Tmpv9 =8.*a_Tmpv10
5369    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
5370    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5371    a_Tmpv7 =(1./12.)*a_Tmpv8
5372    a_Tmpv3 =a_Tmpv7
5373    a_Tmpv6 =a_Tmpv7
5374    a_Tmpv5 =msfux(i,j)*a_Tmpv6
5375    a_muu(i,j) =a_muu(i,j) +Tmpv3077(k,j)*a_Tmpv5
5376    a_Tmpv4 =muu(i,j)*a_Tmpv5
5377    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv4
5378    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv4
5379    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5380    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3076(k,j)*a_Tmpv2
5381    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5382    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
5383    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
5384    ENDDO
5385    ENDDO
5386
5387    END IF
5388
5389    IF( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN
5390
5391    i = ids + 2  ! Added by Ning Pan, 2010-07-20
5392    DO j =jtf, j_start, -1
5393    k = kte  ! Added by Ning Pan, 2010-07-20
5394    a_Tmpv17 =a_ph_tend(i,k,j)
5395    a_ph_tend(i,k,j) =0.0
5396    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5397    a_Tmpv16 =-a_Tmpv17
5398    a_Tmpv15 =(0.5*rdx/msfty(i,j))*a_Tmpv16
5399    a_Tmpv8 =Tmpv2047(j)*a_Tmpv15
5400    a_Tmpv14 =Tmpv2046(j)*a_Tmpv15
5401    a_Tmpv13 =a_Tmpv14
5402    a_Tmpv12 =a_Tmpv13
5403    a_Tmpv10 =a_Tmpv12
5404    a_Tmpv11 =-a_Tmpv12
5405    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
5406    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
5407    a_Tmpv9 =8.*a_Tmpv10
5408    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
5409    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5410    a_Tmpv7 =(1./12.)*a_Tmpv8
5411    a_Tmpv3 =a_Tmpv7
5412    a_Tmpv6 =a_Tmpv7
5413    a_Tmpv5 =msfux(i,j)*a_Tmpv6
5414    a_muu(i,j) =a_muu(i,j) +Tmpv2045(j)*a_Tmpv5
5415    a_Tmpv4 =muu(i,j)*a_Tmpv5
5416    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv4
5417    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv4
5418    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5419    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv2044(j)*a_Tmpv2
5420    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5421    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
5422    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
5423    DO k =kte-1, 2, -1
5424    a_Tmpv17 =a_ph_tend(i,k,j)
5425    a_ph_tend(i,k,j) =0.0
5426    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5427    a_Tmpv16 =-a_Tmpv17
5428    a_Tmpv15 =(0.25*rdx/msfty(i,j))*a_Tmpv16
5429    a_Tmpv8 =Tmpv3075(k,j)*a_Tmpv15
5430    a_Tmpv14 =Tmpv3074(k,j)*a_Tmpv15
5431    a_Tmpv13 =a_Tmpv14
5432    a_Tmpv12 =a_Tmpv13
5433    a_Tmpv10 =a_Tmpv12
5434    a_Tmpv11 =-a_Tmpv12
5435    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
5436    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
5437    a_Tmpv9 =8.*a_Tmpv10
5438    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
5439    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5440    a_Tmpv7 =(1./12.)*a_Tmpv8
5441    a_Tmpv3 =a_Tmpv7
5442    a_Tmpv6 =a_Tmpv7
5443    a_Tmpv5 =msfux(i,j)*a_Tmpv6
5444    a_muu(i,j) =a_muu(i,j) +Tmpv3073(k,j)*a_Tmpv5
5445    a_Tmpv4 =muu(i,j)*a_Tmpv5
5446    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv4
5447    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv4
5448    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5449    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3072(k,j)*a_Tmpv2
5450    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5451    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
5452    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
5453    ENDDO
5454    ENDDO
5455
5456    END IF
5457    DO j =jtf, j_start, -1
5458    k = kte  ! Added by Ning Pan, 2010-07-20
5459    DO i =itf, i_start, -1
5460    a_Tmpv21 =a_ph_tend(i,k,j)
5461    a_ph_tend(i,k,j) =0.0
5462    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv21
5463    a_Tmpv20 =-a_Tmpv21
5464    a_Tmpv19 =(0.5*rdx/msfty(i,j))*a_Tmpv20
5465    a_Tmpv8 =Tmpv3071(i,j)*a_Tmpv19
5466    a_Tmpv18 =Tmpv3070(i,j)*a_Tmpv19
5467    a_Tmpv17 =a_Tmpv18
5468    a_Tmpv16 =a_Tmpv17
5469    a_Tmpv15 =a_Tmpv16
5470    a_Tmpv13 =a_Tmpv15
5471    a_Tmpv14 =a_Tmpv15
5472    a_ph(i+3,k,j) =a_ph(i+3,k,j) +a_Tmpv14
5473    a_ph(i-3,k,j) =a_ph(i-3,k,j) -a_Tmpv14
5474    a_Tmpv10 =a_Tmpv13
5475    a_Tmpv12 =-a_Tmpv13
5476    a_Tmpv11 =9.*a_Tmpv12
5477    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
5478    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
5479    a_Tmpv9 =45.*a_Tmpv10
5480    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
5481    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5482    a_Tmpv7 =(1./60.)*a_Tmpv8
5483    a_Tmpv3 =a_Tmpv7
5484    a_Tmpv6 =a_Tmpv7
5485    a_Tmpv5 =msfux(i,j)*a_Tmpv6
5486    a_muu(i,j) =a_muu(i,j) +Tmpv3069(i,j)*a_Tmpv5
5487    a_Tmpv4 =muu(i,j)*a_Tmpv5
5488    a_u(i,k-1,j) =a_u(i,k-1,j) +cfn*a_Tmpv4
5489    a_u(i,k-2,j) =a_u(i,k-2,j) +cfn1*a_Tmpv4
5490    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5491    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv3068(i,j)*a_Tmpv2
5492    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5493    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +cfn*a_Tmpv1
5494    a_u(i+1,k-2,j) =a_u(i+1,k-2,j) +cfn1*a_Tmpv1
5495    ENDDO
5496    DO k =kte-1, 2, -1
5497    DO i =itf, i_start, -1
5498    a_Tmpv21 =a_ph_tend(i,k,j)
5499    a_ph_tend(i,k,j) =0.0
5500    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv21
5501    a_Tmpv20 =-a_Tmpv21
5502    a_Tmpv19 =(0.25*rdx/msfty(i,j))*a_Tmpv20
5503    a_Tmpv8 =Tmpv4027(i,k,j)*a_Tmpv19
5504    a_Tmpv18 =Tmpv4026(i,k,j)*a_Tmpv19
5505    a_Tmpv17 =a_Tmpv18
5506    a_Tmpv16 =a_Tmpv17
5507    a_Tmpv15 =a_Tmpv16
5508    a_Tmpv13 =a_Tmpv15
5509    a_Tmpv14 =a_Tmpv15
5510    a_ph(i+3,k,j) =a_ph(i+3,k,j) +a_Tmpv14
5511    a_ph(i-3,k,j) =a_ph(i-3,k,j) -a_Tmpv14
5512    a_Tmpv10 =a_Tmpv13
5513    a_Tmpv12 =-a_Tmpv13
5514    a_Tmpv11 =9.*a_Tmpv12
5515    a_ph(i+2,k,j) =a_ph(i+2,k,j) +a_Tmpv11
5516    a_ph(i-2,k,j) =a_ph(i-2,k,j) -a_Tmpv11
5517    a_Tmpv9 =45.*a_Tmpv10
5518    a_ph(i+1,k,j) =a_ph(i+1,k,j) +a_Tmpv9
5519    a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv9
5520    a_Tmpv7 =(1./60.)*a_Tmpv8
5521    a_Tmpv3 =a_Tmpv7
5522    a_Tmpv6 =a_Tmpv7
5523    a_Tmpv5 =msfux(i,j)*a_Tmpv6
5524    a_muu(i,j) =a_muu(i,j) +Tmpv4025(i,k,j)*a_Tmpv5
5525    a_Tmpv4 =muu(i,j)*a_Tmpv5
5526    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv4
5527    a_u(i,k-1,j) =a_u(i,k-1,j) +a_Tmpv4
5528    a_Tmpv2 =msfux(i+1,j)*a_Tmpv3
5529    a_muu(i+1,j) =a_muu(i+1,j) +Tmpv4024(i,k,j)*a_Tmpv2
5530    a_Tmpv1 =muu(i+1,j)*a_Tmpv2
5531    a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
5532    a_u(i+1,k-1,j) =a_u(i+1,k-1,j) +a_Tmpv1
5533    ENDDO
5534    ENDDO
5535    ENDDO
5536
5537 ! Remarked by Ning Pan, 2010-07-20
5538 !   IF(config_flags%open_xe .or. specified ) THEN
5539
5540 !   END IF
5541
5542 !   IF(config_flags%open_xs .or. specified ) THEN
5543
5544 !   END IF
5545
5546 ! Added by Ning Pan, 2010-07-20
5547 !  y (v) advection
5548    i_start = its
5549    j_start = jts
5550    itf=MIN(ite,ide-1)
5551    jtf=MIN(jte,jde-1)
5552    IF (config_flags%open_ys .or. specified ) j_start = max(jts,jds+3)
5553    IF (config_flags%open_ye .or. specified ) jtf     = min(jtf,jde-4)
5554
5555    IF( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte ) THEN
5556
5557    j = jde-2  ! Added by Ning Pan, 2010-07-20
5558    k = kte  ! Added by Ning Pan, 2010-07-20
5559    DO i =itf, i_start, -1
5560    a_Tmpv13 =a_ph_tend(i,k,j)
5561    a_ph_tend(i,k,j) =0.0
5562    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5563    a_Tmpv12 =-a_Tmpv13
5564    a_Tmpv11 =(0.5*rdy/msfty(i,j))*a_Tmpv12
5565    a_Tmpv5 =a_Tmpv11
5566    a_Tmpv10 =a_Tmpv11
5567    a_Tmpv8 =Tmpv2043(i)*a_Tmpv10
5568    a_Tmpv9 =Tmpv2042(i)*a_Tmpv10
5569    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5570    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5571    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5572    a_muv(i,j) =a_muv(i,j) +Tmpv2041(i)*a_Tmpv7
5573    a_Tmpv6 =muv(i,j)*a_Tmpv7
5574    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv6
5575    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv6
5576    a_Tmpv3 =Tmpv2040(i)*a_Tmpv5
5577    a_Tmpv4 =Tmpv2039(i)*a_Tmpv5
5578    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5579    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5580    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5581    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv2038(i)*a_Tmpv2
5582    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5583    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5584    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5585    ENDDO
5586    DO k =kte-1, 2, -1
5587    DO i =itf, i_start, -1
5588    a_Tmpv13 =a_ph_tend(i,k,j)
5589    a_ph_tend(i,k,j) =0.0
5590    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5591    a_Tmpv12 =-a_Tmpv13
5592    a_Tmpv11 =(0.25*rdy/msfty(i,j))*a_Tmpv12
5593    a_Tmpv5 =a_Tmpv11
5594    a_Tmpv10 =a_Tmpv11
5595    a_Tmpv8 =Tmpv3067(i,k)*a_Tmpv10
5596    a_Tmpv9 =Tmpv3066(i,k)*a_Tmpv10
5597    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5598    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5599    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5600    a_muv(i,j) =a_muv(i,j) +Tmpv3065(i,k)*a_Tmpv7
5601    a_Tmpv6 =muv(i,j)*a_Tmpv7
5602    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv6
5603    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv6
5604    a_Tmpv3 =Tmpv3064(i,k)*a_Tmpv5
5605    a_Tmpv4 =Tmpv3063(i,k)*a_Tmpv5
5606    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5607    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5608    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5609    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3062(i,k)*a_Tmpv2
5610    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5611    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5612    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5613    ENDDO
5614    ENDDO
5615
5616    END IF
5617
5618    IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte ) THEN
5619
5620    j = jds+1  ! Added by Ning Pan, 2010-07-20
5621    k = kte  ! Added by Ning Pan, 2010-07-20
5622    DO i =itf, i_start, -1
5623    a_Tmpv13 =a_ph_tend(i,k,j)
5624    a_ph_tend(i,k,j) =0.0
5625    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5626    a_Tmpv12 =-a_Tmpv13
5627    a_Tmpv11 =(0.5*rdy/msfty(i,j))*a_Tmpv12
5628    a_Tmpv5 =a_Tmpv11
5629    a_Tmpv10 =a_Tmpv11
5630    a_Tmpv8 =Tmpv2037(i)*a_Tmpv10
5631    a_Tmpv9 =Tmpv2036(i)*a_Tmpv10
5632    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5633    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5634    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5635    a_muv(i,j) =a_muv(i,j) +Tmpv2035(i)*a_Tmpv7
5636    a_Tmpv6 =muv(i,j)*a_Tmpv7
5637    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv6
5638    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv6
5639    a_Tmpv3 =Tmpv2034(i)*a_Tmpv5
5640    a_Tmpv4 =Tmpv2033(i)*a_Tmpv5
5641    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5642    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5643    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5644    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv2032(i)*a_Tmpv2
5645    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5646    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5647    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5648    ENDDO
5649    DO k =kte-1, 2, -1
5650    DO i =itf, i_start, -1
5651    a_Tmpv13 =a_ph_tend(i,k,j)
5652    a_ph_tend(i,k,j) =0.0
5653    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv13
5654    a_Tmpv12 =-a_Tmpv13
5655    a_Tmpv11 =(0.25*rdy/msfty(i,j))*a_Tmpv12
5656    a_Tmpv5 =a_Tmpv11
5657    a_Tmpv10 =a_Tmpv11
5658    a_Tmpv8 =Tmpv3061(i,k)*a_Tmpv10
5659    a_Tmpv9 =Tmpv3060(i,k)*a_Tmpv10
5660    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv9
5661    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5662    a_Tmpv7 =msfvy(i,j)*a_Tmpv8
5663    a_muv(i,j) =a_muv(i,j) +Tmpv3059(i,k)*a_Tmpv7
5664    a_Tmpv6 =muv(i,j)*a_Tmpv7
5665    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv6
5666    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv6
5667    a_Tmpv3 =Tmpv3058(i,k)*a_Tmpv5
5668    a_Tmpv4 =Tmpv3057(i,k)*a_Tmpv5
5669    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv4
5670    a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4
5671    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5672    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3056(i,k)*a_Tmpv2
5673    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5674    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5675    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5676    ENDDO
5677    ENDDO
5678
5679    END IF
5680
5681    IF( (config_flags%open_ye .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte ) THEN
5682
5683    j = jde-3  ! Added by Ning Pan, 2010-07-20
5684    k = kte  ! Added by Ning Pan, 2010-07-20
5685    DO i =itf, i_start, -1
5686    a_Tmpv17 =a_ph_tend(i,k,j)
5687    a_ph_tend(i,k,j) =0.0
5688    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5689    a_Tmpv16 =-a_Tmpv17
5690    a_Tmpv15 =(0.5*rdy/msfty(i,j))*a_Tmpv16
5691    a_Tmpv8 =Tmpv2031(i)*a_Tmpv15
5692    a_Tmpv14 =Tmpv2030(i)*a_Tmpv15
5693    a_Tmpv13 =a_Tmpv14
5694    a_Tmpv12 =a_Tmpv13
5695    a_Tmpv10 =a_Tmpv12
5696    a_Tmpv11 =-a_Tmpv12
5697    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5698    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5699    a_Tmpv9 =8.*a_Tmpv10
5700    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5701    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5702    a_Tmpv7 =(1./12.)*a_Tmpv8
5703    a_Tmpv3 =a_Tmpv7
5704    a_Tmpv6 =a_Tmpv7
5705    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5706    a_muv(i,j) =a_muv(i,j) +Tmpv2029(i)*a_Tmpv5
5707    a_Tmpv4 =muv(i,j)*a_Tmpv5
5708    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv4
5709    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv4
5710    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5711    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv2028(i)*a_Tmpv2
5712    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5713    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5714    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5715    ENDDO
5716    DO k =kte-1, 2, -1
5717    DO i =itf, i_start, -1
5718    a_Tmpv17 =a_ph_tend(i,k,j)
5719    a_ph_tend(i,k,j) =0.0
5720    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5721    a_Tmpv16 =-a_Tmpv17
5722    a_Tmpv15 =(0.25*rdy/msfty(i,j))*a_Tmpv16
5723    a_Tmpv8 =Tmpv3055(i,k)*a_Tmpv15
5724    a_Tmpv14 =Tmpv3054(i,k)*a_Tmpv15
5725    a_Tmpv13 =a_Tmpv14
5726    a_Tmpv12 =a_Tmpv13
5727    a_Tmpv10 =a_Tmpv12
5728    a_Tmpv11 =-a_Tmpv12
5729    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5730    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5731    a_Tmpv9 =8.*a_Tmpv10
5732    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5733    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5734    a_Tmpv7 =(1./12.)*a_Tmpv8
5735    a_Tmpv3 =a_Tmpv7
5736    a_Tmpv6 =a_Tmpv7
5737    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5738    a_muv(i,j) =a_muv(i,j) +Tmpv3053(i,k)*a_Tmpv5
5739    a_Tmpv4 =muv(i,j)*a_Tmpv5
5740    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv4
5741    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv4
5742    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5743    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3052(i,k)*a_Tmpv2
5744    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5745    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5746    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5747    ENDDO
5748    ENDDO
5749
5750    END IF
5751
5752    IF( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte ) THEN
5753
5754    j = jds+2  ! Added by Ning Pan, 2010-07-20
5755    k = kte  ! Added by Ning Pan, 2010-07-20
5756    DO i =itf, i_start, -1
5757    a_Tmpv17 =a_ph_tend(i,k,j)
5758    a_ph_tend(i,k,j) =0.0
5759    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5760    a_Tmpv16 =-a_Tmpv17
5761    a_Tmpv15 =(0.5*rdy/msfty(i,j))*a_Tmpv16
5762    a_Tmpv8 =Tmpv2027(i)*a_Tmpv15
5763    a_Tmpv14 =Tmpv2026(i)*a_Tmpv15
5764    a_Tmpv13 =a_Tmpv14
5765    a_Tmpv12 =a_Tmpv13
5766    a_Tmpv10 =a_Tmpv12
5767    a_Tmpv11 =-a_Tmpv12
5768    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5769    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5770    a_Tmpv9 =8.*a_Tmpv10
5771    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5772    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5773    a_Tmpv7 =(1./12.)*a_Tmpv8
5774    a_Tmpv3 =a_Tmpv7
5775    a_Tmpv6 =a_Tmpv7
5776    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5777    a_muv(i,j) =a_muv(i,j) +Tmpv2025(i)*a_Tmpv5
5778    a_Tmpv4 =muv(i,j)*a_Tmpv5
5779    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv4
5780    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv4
5781    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5782    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv2024(i)*a_Tmpv2
5783    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5784    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5785    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5786    ENDDO
5787
5788    DO k =kte-1, 2, -1
5789    DO i =itf, i_start, -1
5790    a_Tmpv17 =a_ph_tend(i,k,j)
5791    a_ph_tend(i,k,j) =0.0
5792    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5793    a_Tmpv16 =-a_Tmpv17
5794    a_Tmpv15 =(0.25*rdy/msfty(i,j))*a_Tmpv16
5795    a_Tmpv8 =Tmpv3051(i,k)*a_Tmpv15
5796    a_Tmpv14 =Tmpv3050(i,k)*a_Tmpv15
5797    a_Tmpv13 =a_Tmpv14
5798    a_Tmpv12 =a_Tmpv13
5799    a_Tmpv10 =a_Tmpv12
5800    a_Tmpv11 =-a_Tmpv12
5801    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5802    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5803    a_Tmpv9 =8.*a_Tmpv10
5804    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5805    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5806    a_Tmpv7 =(1./12.)*a_Tmpv8
5807    a_Tmpv3 =a_Tmpv7
5808    a_Tmpv6 =a_Tmpv7
5809    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5810    a_muv(i,j) =a_muv(i,j) +Tmpv3049(i,k)*a_Tmpv5
5811    a_Tmpv4 =muv(i,j)*a_Tmpv5
5812    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv4
5813    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv4
5814    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5815    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3048(i,k)*a_Tmpv2
5816    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5817    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5818    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5819    ENDDO
5820    ENDDO
5821 !   DO i =itf, i_start, -1
5822 !   a_Tmpv17 =a_ph_tend(i,k,j)
5823 !   a_ph_tend(i,k,j) =0.0
5824 !   a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv17
5825 !   a_Tmpv16 =-a_Tmpv17
5826 !   a_Tmpv15 =(0.5*rdy/msfty(i,j))*a_Tmpv16
5827 !   a_Tmpv8 =Tmpv2027(i)*a_Tmpv15
5828 !   a_Tmpv14 =Tmpv2026(i)*a_Tmpv15
5829 !   a_Tmpv13 =a_Tmpv14
5830 !   a_Tmpv12 =a_Tmpv13
5831 !   a_Tmpv10 =a_Tmpv12
5832 !   a_Tmpv11 =-a_Tmpv12
5833 !   a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5834 !   a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5835 !   a_Tmpv9 =8.*a_Tmpv10
5836 !   a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5837 !   a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5838 !   a_Tmpv7 =(1./12.)*a_Tmpv8
5839 !   a_Tmpv3 =a_Tmpv7
5840 !   a_Tmpv6 =a_Tmpv7
5841 !   a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5842 !   a_muv(i,j) =a_muv(i,j) +Tmpv2025(i)*a_Tmpv5
5843 !   a_Tmpv4 =muv(i,j)*a_Tmpv5
5844 !   a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv4
5845 !   a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv4
5846 !   a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5847 !   a_muv(i,j+1) =a_muv(i,j+1) +Tmpv2024(i)*a_Tmpv2
5848 !   a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5849 !   a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5850 !   a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5851 !   ENDDO
5852
5853    END IF
5854    DO j =jtf, j_start, -1
5855    k = kte  ! Added by Ning Pan, 2010-07-20
5856    DO i =itf, i_start, -1
5857    a_Tmpv21 =a_ph_tend(i,k,j)
5858    a_ph_tend(i,k,j) =0.0
5859    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv21
5860    a_Tmpv20 =-a_Tmpv21
5861    a_Tmpv19 =(0.5*rdy/msfty(i,j))*a_Tmpv20
5862    a_Tmpv8 =Tmpv3047(i,j)*a_Tmpv19
5863    a_Tmpv18 =Tmpv3046(i,j)*a_Tmpv19
5864    a_Tmpv17 =a_Tmpv18
5865    a_Tmpv16 =a_Tmpv17
5866    a_Tmpv15 =a_Tmpv16
5867    a_Tmpv13 =a_Tmpv15
5868    a_Tmpv14 =a_Tmpv15
5869    a_ph(i,k,j+3) =a_ph(i,k,j+3) +a_Tmpv14
5870    a_ph(i,k,j-3) =a_ph(i,k,j-3) -a_Tmpv14
5871    a_Tmpv10 =a_Tmpv13
5872    a_Tmpv12 =-a_Tmpv13
5873    a_Tmpv11 =9.*a_Tmpv12
5874    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5875    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5876    a_Tmpv9 =45.*a_Tmpv10
5877    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5878    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5879    a_Tmpv7 =(1./60.)*a_Tmpv8
5880    a_Tmpv3 =a_Tmpv7
5881    a_Tmpv6 =a_Tmpv7
5882    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5883    a_muv(i,j) =a_muv(i,j) +Tmpv3045(i,j)*a_Tmpv5
5884    a_Tmpv4 =muv(i,j)*a_Tmpv5
5885    a_v(i,k-1,j) =a_v(i,k-1,j) +cfn*a_Tmpv4
5886    a_v(i,k-2,j) =a_v(i,k-2,j) +cfn1*a_Tmpv4
5887    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5888    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv3044(i,j)*a_Tmpv2
5889    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5890    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +cfn*a_Tmpv1
5891    a_v(i,k-2,j+1) =a_v(i,k-2,j+1) +cfn1*a_Tmpv1
5892    ENDDO
5893    DO k =kte-1, 2, -1
5894    DO i =itf, i_start, -1
5895    a_Tmpv21 =a_ph_tend(i,k,j)
5896    a_ph_tend(i,k,j) =0.0
5897    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv21
5898    a_Tmpv20 =-a_Tmpv21
5899    a_Tmpv19 =(0.25*rdy/msfty(i,j))*a_Tmpv20
5900    a_Tmpv8 =Tmpv4023(i,k,j)*a_Tmpv19
5901    a_Tmpv18 =Tmpv4022(i,k,j)*a_Tmpv19
5902    a_Tmpv17 =a_Tmpv18
5903    a_Tmpv16 =a_Tmpv17
5904    a_Tmpv15 =a_Tmpv16
5905    a_Tmpv13 =a_Tmpv15
5906    a_Tmpv14 =a_Tmpv15
5907    a_ph(i,k,j+3) =a_ph(i,k,j+3) +a_Tmpv14
5908    a_ph(i,k,j-3) =a_ph(i,k,j-3) -a_Tmpv14
5909    a_Tmpv10 =a_Tmpv13
5910    a_Tmpv12 =-a_Tmpv13
5911    a_Tmpv11 =9.*a_Tmpv12
5912    a_ph(i,k,j+2) =a_ph(i,k,j+2) +a_Tmpv11
5913    a_ph(i,k,j-2) =a_ph(i,k,j-2) -a_Tmpv11
5914    a_Tmpv9 =45.*a_Tmpv10
5915    a_ph(i,k,j+1) =a_ph(i,k,j+1) +a_Tmpv9
5916    a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv9
5917    a_Tmpv7 =(1./60.)*a_Tmpv8
5918    a_Tmpv3 =a_Tmpv7
5919    a_Tmpv6 =a_Tmpv7
5920    a_Tmpv5 =msfvy(i,j)*a_Tmpv6
5921    a_muv(i,j) =a_muv(i,j) +Tmpv4021(i,k,j)*a_Tmpv5
5922    a_Tmpv4 =muv(i,j)*a_Tmpv5
5923    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv4
5924    a_v(i,k-1,j) =a_v(i,k-1,j) +a_Tmpv4
5925    a_Tmpv2 =msfvy(i,j+1)*a_Tmpv3
5926    a_muv(i,j+1) =a_muv(i,j+1) +Tmpv4020(i,k,j)*a_Tmpv2
5927    a_Tmpv1 =muv(i,j+1)*a_Tmpv2
5928    a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
5929    a_v(i,k-1,j+1) =a_v(i,k-1,j+1) +a_Tmpv1
5930    ENDDO
5931    ENDDO
5932    ENDDO
5933
5934 ! Remarked by Ning Pan, 2010-07-20
5935 !   IF(config_flags%open_ye .or. specified ) THEN
5936
5937 !   END IF
5938
5939 !   IF(config_flags%open_ys .or. specified ) THEN
5940
5941 !   END IF
5942
5943    END IF
5944
5945 !LPB[6]
5946
5947 !LPB[5]
5948 !   IF(non_hydrostatic) THEN
5949 !   DO j =jts, jtf
5950 !   DO i =its, itf
5951 !   ph_tend(i,kde,j) =0.
5952
5953 !   ENDDO
5954
5955 !   DO k =2, kte
5956 !   DO i =its, itf
5957 !   Tmpv001 =mut(i,j)*g*w(i,k,j)
5958 !   Tmpv002 =Tmpv001/msfty(i,j)
5959 !   Tmpv003 =ph_tend(i,k,j) +Tmpv002
5960 !!  ph_tend(i,k,j) =Tmpv003
5961
5962 !   ENDDO
5963 !   ENDDO
5964 !   ENDDO
5965 !   END IF
5966
5967 ! Added by Ning Pan, 2010-07-20
5968    itf=MIN(ite,ide-1)
5969    jtf=MIN(jte,jde-1)
5970
5971    IF(non_hydrostatic) THEN
5972
5973    DO j =jtf, jts, -1
5974    DO k =kte, 2, -1
5975    DO i =itf, its, -1
5976    a_Tmpv3 =a_ph_tend(i,k,j)
5977    a_ph_tend(i,k,j) =0.0
5978    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv3
5979    a_Tmpv2 =a_Tmpv3
5980    a_Tmpv1 =a_Tmpv2/msfty(i,j)
5981    a_mut(i,j) =a_mut(i,j) +g*w(i,k,j)*a_Tmpv1
5982    a_w(i,k,j) =a_w(i,k,j) +mut(i,j)*g*a_Tmpv1
5983    ENDDO
5984    ENDDO
5985    DO i =itf, its, -1
5986    a_ph_tend(i,kde,j) =0.0
5987    ENDDO
5988    ENDDO
5989
5990    END IF
5991
5992 !LPB[4]
5993
5994 !LPB[3]
5995    DO j =jtf, jts, -1
5996
5997    DO k =2, kte
5998    DO i =its, itf
5999    Tmpv001 =ww(i,k,j) +ww(i,k-1,j)
6000    Tmpv002 =.5*Tmpv001
6001    Tmpv003 =Tmpv002*rdnw(k-1)
6002    Tmpv004 =ph(i,k,j) -ph(i,k-1,j)
6003    Tmpv005 =Tmpv004 +phb(i,k,j)
6004    Tmpv006 =Tmpv005 -phb(i,k-1,j)
6005    Tmpv300(i,k) =Tmpv003
6006    Tmpv301(i,k) =Tmpv006
6007    Tmpv007 =Tmpv300(i,k)*Tmpv301(i,k)
6008 !  wdwn(i,k) =Tmpv007
6009
6010    ENDDO
6011    ENDDO
6012 ! Remarked by Ning Pan, 2010-07-20
6013 !   DO k =2, kte-1
6014 !   DO i =its, itf
6015 !   Tmpv001 =fnm(k)*wdwn(i,k+1) +fnp(k)*wdwn(i,k)
6016 !   Tmpv002 =ph_tend(i,k,j) -Tmpv001
6017 !!  ph_tend(i,k,j) =Tmpv002
6018
6019 !   ENDDO
6020 !   ENDDO
6021
6022    DO k =kte-1, 2, -1
6023    DO i =itf, its, -1
6024    a_Tmpv2 =a_ph_tend(i,k,j)
6025    a_ph_tend(i,k,j) =0.0
6026    a_ph_tend(i,k,j) =a_ph_tend(i,k,j) +a_Tmpv2
6027    a_Tmpv1 =-a_Tmpv2
6028    a_wdwn(i,k+1) =a_wdwn(i,k+1) +fnm(k)*a_Tmpv1
6029    a_wdwn(i,k) =a_wdwn(i,k) +fnp(k)*a_Tmpv1
6030    ENDDO
6031    ENDDO
6032
6033    DO k =kte, 2, -1
6034    DO i =itf, its, -1
6035    a_Tmpv7 =a_wdwn(i,k)
6036    a_wdwn(i,k) =0.0
6037    a_Tmpv3 =Tmpv301(i,k)*a_Tmpv7
6038    a_Tmpv6 =Tmpv300(i,k)*a_Tmpv7
6039    a_Tmpv5 =a_Tmpv6
6040    a_Tmpv4 =a_Tmpv5
6041    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv4
6042    a_ph(i,k-1,j) =a_ph(i,k-1,j) -a_Tmpv4
6043    a_Tmpv2 =rdnw(k-1)*a_Tmpv3
6044    a_Tmpv1 =.5*a_Tmpv2
6045    a_ww(i,k,j) =a_ww(i,k,j) +a_Tmpv1
6046    a_ww(i,k-1,j) =a_ww(i,k-1,j) +a_Tmpv1
6047    ENDDO
6048    ENDDO
6049
6050    ENDDO
6051
6052 !LPB[2]
6053 !  advective_order =config_flags%h_sca_adv_order
6054 !  itf =min(ite, ide-1)
6055 !  jtf =min(jte, jde-1)
6056 !  ktf =min(kte, kde-1)
6057
6058 !LPB[1]
6059
6060 !  IF(config_flags%specified .or. config_flags%nested) THEN
6061 !  specified =.true.
6062 !  END IF
6063
6064 !  IF(config_flags%specified .or. config_flags%nested) THEN
6065
6066 !  END IF
6067
6068 !LPB[0]
6069 !  specified =.false.
6070
6071    END SUBROUTINE a_rhs_ph
6072
6073 !        Generated by TAPENADE     (INRIA, Tropics team)
6074 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
6075 !
6076 !  Differentiation of horizontal_pressure_gradient in reverse (adjoint) mode:
6077 !   gradient     of useful results: p al ru_tend cqu cqv php rv_tend
6078 !                ph alt muu muv mu
6079 !   with respect to varying inputs: p al ru_tend cqu cqv php rv_tend
6080 !                ph alt muu muv mu
6081 !   RW status of diff variables: p:incr al:incr ru_tend:in-out
6082 !                cqu:incr cqv:incr php:incr rv_tend:in-out ph:incr
6083 !                alt:incr muu:incr muv:incr mu:incr
6084 SUBROUTINE A_HORIZONTAL_PRESSURE_GRADIENT(ru_tend, ru_tendb, rv_tend, &
6085 &  rv_tendb, ph, phb, alt, altb, p, pb0, pb, al, alb, php, phpb, cqu, &
6086 &  cqub, cqv, cqvb, muu, muub, muv, muvb, mu, mub, fnm, fnp, rdnw, cf1, &
6087 &  cf2, cf3, cfn, cfn1, rdx, rdy, msfux, msfuy, msfvx, msfvy, msftx, msfty, &
6088 &  config_flags, non_hydrostatic, top_lid, ids, ide, jds, jde, kds, kde, &
6089 &  ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
6090   IMPLICIT NONE
6091 ! Input data
6092   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
6093   LOGICAL, INTENT(IN) :: non_hydrostatic, top_lid
6094   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
6095 &  jme, kms, kme, its, ite, jts, jte, kts, kte
6096   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ph, alt, al&
6097 &  , p, pb, php, cqu, cqv
6098   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: phb, altb, alb, pb0, &
6099 &  phpb, cqub, cqvb
6100   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
6101 &  rv_tend
6102   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ru_tendb, rv_tendb
6103   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muu, muv, mu, msfux, &
6104 &  msfuy, msfvx, msfvy, msftx, msfty
6105   REAL, DIMENSION(ims:ime, jms:jme) :: muub, muvb, mub
6106   REAL, DIMENSION(kms:kme), INTENT(IN) :: rdnw, fnm, fnp
6107   REAL, INTENT(IN) :: rdx, rdy, cf1, cf2, cf3, cfn, cfn1
6108   INTEGER :: i, j, k, itf, jtf, ktf, i_start, j_start
6109   REAL, DIMENSION(ims:ime, kms:kme) :: dpn
6110   REAL, DIMENSION(ims:ime, kms:kme) :: dpnb
6111   REAL :: dpx, dpy
6112   REAL :: dpxb, dpyb
6113   LOGICAL :: specified
6114   INTEGER :: ad_from
6115   INTEGER :: ad_to
6116   INTEGER :: ad_from0
6117   INTEGER :: ad_to0
6118   INTEGER :: ad_from1
6119   INTEGER :: ad_to1
6120   INTEGER :: ad_to2
6121   INTEGER :: ad_from2
6122   INTEGER :: ad_to3
6123   INTEGER :: ad_to4
6124   INTEGER :: ad_from3
6125   INTEGER :: ad_to5
6126   INTEGER :: ad_to6
6127   INTEGER :: branch
6128   INTEGER :: ad_from4
6129   INTEGER :: ad_to7
6130   REAL :: temp3
6131   REAL :: temp2
6132   REAL :: temp1
6133   REAL :: temp0
6134   REAL :: tempb3
6135   REAL :: tempb2
6136   REAL :: tempb1
6137   REAL :: tempb0
6138   REAL :: temp2b3
6139   REAL :: temp2b2
6140   REAL :: temp2b1
6141   REAL :: temp2b0
6142   REAL :: temp10
6143   REAL :: temp5b3
6144   REAL :: temp5b2
6145   REAL :: temp5b1
6146   REAL :: temp5b0
6147   REAL :: tempb
6148   REAL :: temp2b
6149   REAL :: temp5b
6150   REAL :: temp8b3
6151   REAL :: temp8b2
6152   REAL :: temp8b1
6153   REAL :: temp8b0
6154   REAL :: temp8b
6155   INTRINSIC MIN
6156   REAL :: temp
6157   REAL :: temp9
6158   REAL :: temp8
6159   REAL :: temp7
6160   REAL :: temp6
6161   REAL :: temp5
6162   REAL :: temp4
6163 !<DESCRIPTION>
6164 !
6165 !  horizontal_pressure_gradient calculates the
6166 !  horizontal pressure gradient terms for the large-timestep tendency
6167 !  in the horizontal momentum equations (u,v).
6168 !
6169 !</DESCRIPTION>
6170   specified = .false.
6171   IF (config_flags%specified .OR. config_flags%nested) specified = &
6172 &      .true.
6173   IF (ite .GT. ide - 1) THEN
6174     itf = ide - 1
6175   ELSE
6176     itf = ite
6177   END IF
6178   jtf = jte
6179   IF (kte .GT. kde - 1) THEN
6180     ktf = kde - 1
6181   ELSE
6182     ktf = kte
6183   END IF
6184   i_start = its
6185   j_start = jts
6186   IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
6187 &      .OR. config_flags%polar) .AND. jts .EQ. jds) j_start = jts + 1
6188   IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
6189 &      .OR. config_flags%polar) .AND. jte .EQ. jde) jtf = jtf - 1
6190   ad_from4 = j_start
6191   DO j=ad_from4,jtf
6192     IF (non_hydrostatic) THEN
6193       k = 1
6194       ad_from = i_start
6195       DO i=ad_from,itf
6196         CALL PUSHREAL8(dpn(i, k))
6197         dpn(i, k) = .5*(cf1*(p(i, k, j-1)+p(i, k, j))+cf2*(p(i, k+1, j-1&
6198 &          )+p(i, k+1, j))+cf3*(p(i, k+2, j-1)+p(i, k+2, j)))
6199         CALL PUSHREAL8(dpn(i, kde))
6200         dpn(i, kde) = 0.
6201       END DO
6202       CALL PUSHINTEGER4(i - 1)
6203       CALL PUSHINTEGER4(ad_from)
6204       IF (top_lid) THEN
6205         ad_from0 = i_start
6206         DO i=ad_from0,itf
6207           CALL PUSHREAL8(dpn(i, kde))
6208 !commented out for bug fix, Jan 2016
6209 !          dpn(i, kde) = .5*(cf1*(p(i, kde-1, j-1)+p(i, kde-1, j))+cf2*(p&
6210 !&            (i, kde-2, j-1)+p(i, kde-2, j))+cf3*(p(i, kde-3, j-1)+p(i, &
6211 !&            kde-3, j)))
6212            dpn(i,kde) = .5*( cfn *(p(i,kde-1,j-1)+p(i,kde-1,j))   &
6213                             +cfn1*(p(i,kde-2,j-1)+p(i,kde-2,j)) )
6214         END DO
6215         CALL PUSHINTEGER4(i - 1)
6216         CALL PUSHINTEGER4(ad_from0)
6217         CALL PUSHCONTROL1B(1)
6218       ELSE
6219         CALL PUSHCONTROL1B(0)
6220       END IF
6221       CALL PUSHINTEGER4(k)
6222       DO k=2,ktf
6223         ad_from1 = i_start
6224         DO i=ad_from1,itf
6225           CALL PUSHREAL8(dpn(i, k))
6226           dpn(i, k) = .5*(fnm(k)*(p(i, k, j-1)+p(i, k, j))+fnp(k)*(p(i, &
6227 &            k-1, j-1)+p(i, k-1, j)))
6228         END DO
6229         CALL PUSHINTEGER4(i - 1)
6230         CALL PUSHINTEGER4(ad_from1)
6231       END DO
6232       CALL PUSHINTEGER4(k - 1)
6233 !       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
6234 !       [alt, al are 1/rho terms; muv, mu are NOT coupled]
6235       DO k=1,ktf
6236         ad_from2 = i_start
6237         DO i=ad_from2,itf
6238           CALL PUSHREAL8(dpy)
6239 ! Here are mu dp/dy terms 1-3
6240           dpy = msfvy(i, j)/msfvx(i, j)*.5*rdy*muv(i, j)*(ph(i, k+1, j)-&
6241 &            ph(i, k+1, j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(&
6242 &            i, k, j-1))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, &
6243 &            j-1))*(pb(i, k, j)-pb(i, k, j-1)))
6244 ! Here is mu dp/dy term 4
6245           dpy = dpy + msfvy(i, j)/msfvx(i, j)*rdy*(php(i, k, j)-php(i, k&
6246 &            , j-1))*(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i, j-1)+mu(i&
6247 &            , j)))
6248         END DO
6249         CALL PUSHINTEGER4(i - 1)
6250         CALL PUSHINTEGER4(ad_from2)
6251       END DO
6252       CALL PUSHINTEGER4(k - 1)
6253       CALL PUSHCONTROL1B(1)
6254     ELSE
6255 !       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
6256 !       [alt, al are 1/rho terms; muv, mu are NOT coupled]
6257       DO k=1,ktf
6258         ad_from3 = i_start
6259         DO i=ad_from3,itf
6260           CALL PUSHREAL8(dpy)
6261 ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
6262           dpy = msfvy(i, j)/msfvx(i, j)*.5*rdy*muv(i, j)*(ph(i, k+1, j)-&
6263 &            ph(i, k+1, j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(&
6264 &            i, k, j-1))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, &
6265 &            j-1))*(pb(i, k, j)-pb(i, k, j-1)))
6266         END DO
6267         CALL PUSHINTEGER4(i - 1)
6268         CALL PUSHINTEGER4(ad_from3)
6269       END DO
6270       CALL PUSHINTEGER4(k - 1)
6271       CALL PUSHCONTROL1B(0)
6272     END IF
6273   END DO
6274   CALL PUSHINTEGER4(j - 1)
6275   CALL PUSHINTEGER4(ad_from4)
6276 !  now the east-west (x) pressure gradient
6277   itf = ite
6278   IF (jte .GT. jde - 1) THEN
6279     jtf = jde - 1
6280   ELSE
6281     jtf = jte
6282   END IF
6283   IF (kte .GT. kde - 1) THEN
6284     ktf = kde - 1
6285   ELSE
6286     ktf = kte
6287   END IF
6288   i_start = its
6289   j_start = jts
6290   IF (((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
6291 &      .AND. its .EQ. ids) i_start = its + 1
6292   IF (((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
6293 &      .AND. ite .EQ. ide) itf = itf - 1
6294   IF (config_flags%periodic_x) i_start = its
6295   IF (config_flags%periodic_x) itf = ite
6296   DO j=j_start,jtf
6297     IF (non_hydrostatic) THEN
6298       k = 1
6299       DO i=i_start,itf
6300         CALL PUSHREAL8(dpn(i, k))
6301         dpn(i, k) = .5*(cf1*(p(i-1, k, j)+p(i, k, j))+cf2*(p(i-1, k+1, j&
6302 &          )+p(i, k+1, j))+cf3*(p(i-1, k+2, j)+p(i, k+2, j)))
6303         CALL PUSHREAL8(dpn(i, kde))
6304         dpn(i, kde) = 0.
6305       END DO
6306       IF (top_lid) THEN
6307         DO i=i_start,itf
6308           CALL PUSHREAL8(dpn(i, kde))
6309 !commented out for bug fix, Jan 2016
6310 !          dpn(i, kde) = .5*(cf1*(p(i-1, kde-1, j)+p(i, kde-1, j))+cf2*(p&
6311 !&            (i-1, kde-2, j)+p(i, kde-2, j))+cf3*(p(i-1, kde-3, j)+p(i, &
6312 !&            kde-3, j)))
6313            dpn(i,kde) = .5*( cfn *(p(i-1,kde-1,j)+p(i,kde-1,j))   &
6314                             +cfn1*(p(i-1,kde-2,j)+p(i,kde-2,j)) )
6315         END DO
6316         CALL PUSHCONTROL1B(1)
6317       ELSE
6318         CALL PUSHCONTROL1B(0)
6319       END IF
6320       CALL PUSHINTEGER4(k)
6321       DO k=2,ktf
6322         DO i=i_start,itf
6323           CALL PUSHREAL8(dpn(i, k))
6324           dpn(i, k) = .5*(fnm(k)*(p(i-1, k, j)+p(i, k, j))+fnp(k)*(p(i-1&
6325 &            , k-1, j)+p(i, k-1, j)))
6326         END DO
6327       END DO
6328 ! ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
6329 ! [alt, al are 1/rho terms; muu, mu are NOT coupled]
6330       DO k=1,ktf
6331         DO i=i_start,itf
6332           CALL PUSHREAL8(dpx)
6333 ! Here are mu dp/dy terms 1-3
6334           dpx = msfux(i, j)/msfuy(i, j)*.5*rdx*muu(i, j)*(ph(i, k+1, j)-&
6335 &            ph(i-1, k+1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(&
6336 &            i-1, k, j))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k&
6337 &            , j))*(pb(i, k, j)-pb(i-1, k, j)))
6338 ! Here is mu dp/dy term 4
6339           dpx = dpx + msfux(i, j)/msfuy(i, j)*rdx*(php(i, k, j)-php(i-1&
6340 &            , k, j))*(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i-1, j)+mu(&
6341 &            i, j)))
6342         END DO
6343       END DO
6344       CALL PUSHCONTROL1B(1)
6345     ELSE
6346 !       ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
6347 !       [alt, al are 1/rho terms; muu, mu are NOT coupled]
6348       DO k=1,ktf
6349         DO i=i_start,itf
6350           CALL PUSHREAL8(dpx)
6351 ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
6352           dpx = msfux(i, j)/msfuy(i, j)*.5*rdx*muu(i, j)*(ph(i, k+1, j)-&
6353 &            ph(i-1, k+1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(&
6354 &            i-1, k, j))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k&
6355 &            , j))*(pb(i, k, j)-pb(i-1, k, j)))
6356         END DO
6357       END DO
6358       CALL PUSHCONTROL1B(0)
6359     END IF
6360   END DO
6361   dpnb = 0.0
6362   DO j=jtf,j_start,-1
6363     CALL POPCONTROL1B(branch)
6364     IF (branch .EQ. 0) THEN
6365       DO k=ktf,1,-1
6366         DO i=itf,i_start,-1
6367           dpxb = -(ru_tendb(i, k, j))
6368           CALL POPREAL8(dpx)
6369           temp10 = pb(i, k, j) - pb(i-1, k, j)
6370           temp9 = p(i, k, j) - p(i-1, k, j)
6371           temp8 = alt(i, k, j) + alt(i-1, k, j)
6372           temp8b2 = msfux(i, j)*rdx*.5*dpxb
6373           temp8b3 = muu(i, j)*temp8b2/msfuy(i, j)
6374           phb(i, k+1, j) = phb(i, k+1, j) + temp8b3
6375           phb(i-1, k+1, j) = phb(i-1, k+1, j) - temp8b3
6376           phb(i, k, j) = phb(i, k, j) + temp8b3
6377           altb(i, k, j) = altb(i, k, j) + temp9*temp8b3
6378           altb(i-1, k, j) = altb(i-1, k, j) + temp9*temp8b3
6379           pb0(i, k, j) = pb0(i, k, j) + temp8*temp8b3
6380           pb0(i-1, k, j) = pb0(i-1, k, j) - temp8*temp8b3
6381           phb(i-1, k, j) = phb(i-1, k, j) - temp8b3
6382           alb(i, k, j) = alb(i, k, j) + temp10*temp8b3
6383           alb(i-1, k, j) = alb(i-1, k, j) + temp10*temp8b3
6384           muub(i, j) = muub(i, j) + (ph(i, k+1, j)-ph(i-1, k+1, j)+ph(i&
6385 &            , k, j)+temp8*temp9-ph(i-1, k, j)+temp10*(al(i, k, j)+al(i-1&
6386 &            , k, j)))*temp8b2/msfuy(i, j)
6387         END DO
6388       END DO
6389     ELSE
6390       DO k=ktf,1,-1
6391         DO i=itf,i_start,-1
6392           cqub(i, k, j) = cqub(i, k, j) - dpx*ru_tendb(i, k, j)
6393           dpxb = -(cqu(i, k, j)*ru_tendb(i, k, j))
6394           temp8b = msfux(i, j)*rdx*dpxb
6395           temp8b0 = (rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i-1, j)+mu(i&
6396 &            , j)))*temp8b/msfuy(i, j)
6397           temp8b1 = (php(i, k, j)-php(i-1, k, j))*temp8b/msfuy(i, j)
6398           phpb(i, k, j) = phpb(i, k, j) + temp8b0
6399           phpb(i-1, k, j) = phpb(i-1, k, j) - temp8b0
6400           dpnb(i, k+1) = dpnb(i, k+1) + rdnw(k)*temp8b1
6401           dpnb(i, k) = dpnb(i, k) - rdnw(k)*temp8b1
6402           mub(i-1, j) = mub(i-1, j) - .5*temp8b1
6403           mub(i, j) = mub(i, j) - .5*temp8b1
6404           CALL POPREAL8(dpx)
6405           temp7 = pb(i, k, j) - pb(i-1, k, j)
6406           temp6 = p(i, k, j) - p(i-1, k, j)
6407           temp5 = alt(i, k, j) + alt(i-1, k, j)
6408           temp5b2 = msfux(i, j)*rdx*.5*dpxb
6409           temp5b3 = muu(i, j)*temp5b2/msfuy(i, j)
6410           phb(i, k+1, j) = phb(i, k+1, j) + temp5b3
6411           phb(i-1, k+1, j) = phb(i-1, k+1, j) - temp5b3
6412           phb(i, k, j) = phb(i, k, j) + temp5b3
6413           altb(i, k, j) = altb(i, k, j) + temp6*temp5b3
6414           altb(i-1, k, j) = altb(i-1, k, j) + temp6*temp5b3
6415           pb0(i, k, j) = pb0(i, k, j) + temp5*temp5b3
6416           pb0(i-1, k, j) = pb0(i-1, k, j) - temp5*temp5b3
6417           phb(i-1, k, j) = phb(i-1, k, j) - temp5b3
6418           alb(i, k, j) = alb(i, k, j) + temp7*temp5b3
6419           alb(i-1, k, j) = alb(i-1, k, j) + temp7*temp5b3
6420           muub(i, j) = muub(i, j) + (ph(i, k+1, j)-ph(i-1, k+1, j)+ph(i&
6421 &            , k, j)+temp5*temp6-ph(i-1, k, j)+temp7*(al(i, k, j)+al(i-1&
6422 &            , k, j)))*temp5b2/msfuy(i, j)
6423         END DO
6424       END DO
6425       DO k=ktf,2,-1
6426         DO i=itf,i_start,-1
6427           CALL POPREAL8(dpn(i, k))
6428           temp5b1 = .5*dpnb(i, k)
6429           pb0(i-1, k, j) = pb0(i-1, k, j) + fnm(k)*temp5b1
6430           pb0(i, k, j) = pb0(i, k, j) + fnm(k)*temp5b1
6431           pb0(i-1, k-1, j) = pb0(i-1, k-1, j) + fnp(k)*temp5b1
6432           pb0(i, k-1, j) = pb0(i, k-1, j) + fnp(k)*temp5b1
6433           dpnb(i, k) = 0.0
6434         END DO
6435       END DO
6436       CALL POPINTEGER4(k)
6437       CALL POPCONTROL1B(branch)
6438       IF (branch .NE. 0) THEN
6439         DO i=itf,i_start,-1
6440           CALL POPREAL8(dpn(i, kde))
6441           temp5b0 = .5*dpnb(i, kde)
6442           pb0(i-1, kde-1, j) = pb0(i-1, kde-1, j) + cf1*temp5b0
6443           pb0(i, kde-1, j) = pb0(i, kde-1, j) + cf1*temp5b0
6444           pb0(i-1, kde-2, j) = pb0(i-1, kde-2, j) + cf2*temp5b0
6445           pb0(i, kde-2, j) = pb0(i, kde-2, j) + cf2*temp5b0
6446           pb0(i-1, kde-3, j) = pb0(i-1, kde-3, j) + cf3*temp5b0
6447           pb0(i, kde-3, j) = pb0(i, kde-3, j) + cf3*temp5b0
6448           dpnb(i, kde) = 0.0
6449         END DO
6450       END IF
6451       k = 1
6452       DO i=itf,i_start,-1
6453         CALL POPREAL8(dpn(i, kde))
6454         dpnb(i, kde) = 0.0
6455         CALL POPREAL8(dpn(i, k))
6456         temp5b = .5*dpnb(i, k)
6457         pb0(i-1, k, j) = pb0(i-1, k, j) + cf1*temp5b
6458         pb0(i, k, j) = pb0(i, k, j) + cf1*temp5b
6459         pb0(i-1, k+1, j) = pb0(i-1, k+1, j) + cf2*temp5b
6460         pb0(i, k+1, j) = pb0(i, k+1, j) + cf2*temp5b
6461         pb0(i-1, k+2, j) = pb0(i-1, k+2, j) + cf3*temp5b
6462         pb0(i, k+2, j) = pb0(i, k+2, j) + cf3*temp5b
6463         dpnb(i, k) = 0.0
6464       END DO
6465     END IF
6466   END DO
6467   CALL POPINTEGER4(ad_from4)
6468   CALL POPINTEGER4(ad_to7)
6469   DO j=ad_to7,ad_from4,-1
6470     CALL POPCONTROL1B(branch)
6471     IF (branch .EQ. 0) THEN
6472       CALL POPINTEGER4(ad_to6)
6473       DO k=ad_to6,1,-1
6474         CALL POPINTEGER4(ad_from3)
6475         CALL POPINTEGER4(ad_to5)
6476         DO i=ad_to5,ad_from3,-1
6477           dpyb = -(rv_tendb(i, k, j))
6478           CALL POPREAL8(dpy)
6479           temp4 = pb(i, k, j) - pb(i, k, j-1)
6480           temp3 = p(i, k, j) - p(i, k, j-1)
6481           temp2 = alt(i, k, j) + alt(i, k, j-1)
6482           temp2b2 = msfvy(i, j)*rdy*.5*dpyb
6483           temp2b3 = muv(i, j)*temp2b2/msfvx(i, j)
6484           phb(i, k+1, j) = phb(i, k+1, j) + temp2b3
6485           phb(i, k+1, j-1) = phb(i, k+1, j-1) - temp2b3
6486           phb(i, k, j) = phb(i, k, j) + temp2b3
6487           altb(i, k, j) = altb(i, k, j) + temp3*temp2b3
6488           altb(i, k, j-1) = altb(i, k, j-1) + temp3*temp2b3
6489           pb0(i, k, j) = pb0(i, k, j) + temp2*temp2b3
6490           pb0(i, k, j-1) = pb0(i, k, j-1) - temp2*temp2b3
6491           phb(i, k, j-1) = phb(i, k, j-1) - temp2b3
6492           alb(i, k, j) = alb(i, k, j) + temp4*temp2b3
6493           alb(i, k, j-1) = alb(i, k, j-1) + temp4*temp2b3
6494           muvb(i, j) = muvb(i, j) + (ph(i, k+1, j)-ph(i, k+1, j-1)+ph(i&
6495 &            , k, j)+temp2*temp3-ph(i, k, j-1)+temp4*(al(i, k, j)+al(i, k&
6496 &            , j-1)))*temp2b2/msfvx(i, j)
6497         END DO
6498       END DO
6499     ELSE
6500       CALL POPINTEGER4(ad_to4)
6501       DO k=ad_to4,1,-1
6502         CALL POPINTEGER4(ad_from2)
6503         CALL POPINTEGER4(ad_to3)
6504         DO i=ad_to3,ad_from2,-1
6505           cqvb(i, k, j) = cqvb(i, k, j) - dpy*rv_tendb(i, k, j)
6506           dpyb = -(cqv(i, k, j)*rv_tendb(i, k, j))
6507           temp2b = msfvy(i, j)*rdy*dpyb
6508           temp2b0 = (rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i, j-1)+mu(i&
6509 &            , j)))*temp2b/msfvx(i, j)
6510           temp2b1 = (php(i, k, j)-php(i, k, j-1))*temp2b/msfvx(i, j)
6511           phpb(i, k, j) = phpb(i, k, j) + temp2b0
6512           phpb(i, k, j-1) = phpb(i, k, j-1) - temp2b0
6513           dpnb(i, k+1) = dpnb(i, k+1) + rdnw(k)*temp2b1
6514           dpnb(i, k) = dpnb(i, k) - rdnw(k)*temp2b1
6515           mub(i, j-1) = mub(i, j-1) - .5*temp2b1
6516           mub(i, j) = mub(i, j) - .5*temp2b1
6517           CALL POPREAL8(dpy)
6518           temp1 = pb(i, k, j) - pb(i, k, j-1)
6519           temp0 = p(i, k, j) - p(i, k, j-1)
6520           temp = alt(i, k, j) + alt(i, k, j-1)
6521           tempb2 = msfvy(i, j)*rdy*.5*dpyb
6522           tempb3 = muv(i, j)*tempb2/msfvx(i, j)
6523           phb(i, k+1, j) = phb(i, k+1, j) + tempb3
6524           phb(i, k+1, j-1) = phb(i, k+1, j-1) - tempb3
6525           phb(i, k, j) = phb(i, k, j) + tempb3
6526           altb(i, k, j) = altb(i, k, j) + temp0*tempb3
6527           altb(i, k, j-1) = altb(i, k, j-1) + temp0*tempb3
6528           pb0(i, k, j) = pb0(i, k, j) + temp*tempb3
6529           pb0(i, k, j-1) = pb0(i, k, j-1) - temp*tempb3
6530           phb(i, k, j-1) = phb(i, k, j-1) - tempb3
6531           alb(i, k, j) = alb(i, k, j) + temp1*tempb3
6532           alb(i, k, j-1) = alb(i, k, j-1) + temp1*tempb3
6533           muvb(i, j) = muvb(i, j) + (ph(i, k+1, j)-ph(i, k+1, j-1)+ph(i&
6534 &            , k, j)+temp*temp0-ph(i, k, j-1)+temp1*(al(i, k, j)+al(i, k&
6535 &            , j-1)))*tempb2/msfvx(i, j)
6536         END DO
6537       END DO
6538       CALL POPINTEGER4(ad_to2)
6539       DO k=ad_to2,2,-1
6540         CALL POPINTEGER4(ad_from1)
6541         CALL POPINTEGER4(ad_to1)
6542         DO i=ad_to1,ad_from1,-1
6543           CALL POPREAL8(dpn(i, k))
6544           tempb1 = .5*dpnb(i, k)
6545           pb0(i, k, j-1) = pb0(i, k, j-1) + fnm(k)*tempb1
6546           pb0(i, k, j) = pb0(i, k, j) + fnm(k)*tempb1
6547           pb0(i, k-1, j-1) = pb0(i, k-1, j-1) + fnp(k)*tempb1
6548           pb0(i, k-1, j) = pb0(i, k-1, j) + fnp(k)*tempb1
6549           dpnb(i, k) = 0.0
6550         END DO
6551       END DO
6552       CALL POPINTEGER4(k)
6553       CALL POPCONTROL1B(branch)
6554       IF (branch .NE. 0) THEN
6555         CALL POPINTEGER4(ad_from0)
6556         CALL POPINTEGER4(ad_to0)
6557         DO i=ad_to0,ad_from0,-1
6558           CALL POPREAL8(dpn(i, kde))
6559           tempb0 = .5*dpnb(i, kde)
6560           pb0(i, kde-1, j-1) = pb0(i, kde-1, j-1) + cf1*tempb0
6561           pb0(i, kde-1, j) = pb0(i, kde-1, j) + cf1*tempb0
6562           pb0(i, kde-2, j-1) = pb0(i, kde-2, j-1) + cf2*tempb0
6563           pb0(i, kde-2, j) = pb0(i, kde-2, j) + cf2*tempb0
6564           pb0(i, kde-3, j-1) = pb0(i, kde-3, j-1) + cf3*tempb0
6565           pb0(i, kde-3, j) = pb0(i, kde-3, j) + cf3*tempb0
6566           dpnb(i, kde) = 0.0
6567         END DO
6568       END IF
6569       k = 1
6570       CALL POPINTEGER4(ad_from)
6571       CALL POPINTEGER4(ad_to)
6572       DO i=ad_to,ad_from,-1
6573         CALL POPREAL8(dpn(i, kde))
6574         dpnb(i, kde) = 0.0
6575         CALL POPREAL8(dpn(i, k))
6576         tempb = .5*dpnb(i, k)
6577         pb0(i, k, j-1) = pb0(i, k, j-1) + cf1*tempb
6578         pb0(i, k, j) = pb0(i, k, j) + cf1*tempb
6579         pb0(i, k+1, j-1) = pb0(i, k+1, j-1) + cf2*tempb
6580         pb0(i, k+1, j) = pb0(i, k+1, j) + cf2*tempb
6581         pb0(i, k+2, j-1) = pb0(i, k+2, j-1) + cf3*tempb
6582         pb0(i, k+2, j) = pb0(i, k+2, j) + cf3*tempb
6583         dpnb(i, k) = 0.0
6584       END DO
6585     END IF
6586   END DO
6587 END SUBROUTINE A_HORIZONTAL_PRESSURE_GRADIENT
6588
6589    SUBROUTINE a_pg_buoy_w(rw_tend,a_rw_tend,p,a_p,cqw,a_cqw,mu,a_mu,mub,rdnw, &
6590    rdn,g,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6591
6592 !PART I: DECLARATION OF VARIABLES
6593
6594    IMPLICIT NONE
6595
6596    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
6597    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6598    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: p,a_p
6599    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: cqw,a_cqw
6600    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rw_tend,a_rw_tend
6601    REAL,DIMENSION(ims:ime,jms:jme) :: mub,mu,a_mu,msftx,msfty
6602    REAL,DIMENSION(kms:kme) :: rdnw,rdn
6603    REAL :: g
6604    INTEGER :: itf,jtf,i,j,k
6605    REAL :: cq1,a_cq1,cq2,a_cq2
6606
6607 !  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_cqw
6608    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
6609    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006
6610    REAL,DIMENSION(its:MAX(ite,ide-1)) :: Tmpv200
6611    REAL,DIMENSION(its:MAX(ite,ide-1),2:kde-1) :: Tmpv300
6612    REAL,DIMENSION(its:MAX(ite,ide-1),2:kde-1) :: Tmpv301
6613    REAL,DIMENSION(its:MAX(ite,ide-1),2:kde-1) :: Tmpv302
6614
6615 !PART II: CALCULATIONS OF B. S. TRAJECTORY
6616
6617 !LPB[0]
6618       itf=MIN(ite,ide-1)
6619       jtf=MIN(jte,jde-1)
6620
6621 !!LPB[1]
6622 !      DO j = jts,jtf
6623
6624 !!      DO k=2, kde-1
6625 !!      DO i=its, min(ite,ide-1)
6626 !    !  Keep_Lpb1_cqw(i,k,j) =cqw(i,k,j)
6627 !!      END DO
6628 !!      END DO
6629
6630 !        k=kde
6631
6632 !        DO i=its,itf
6633 !          cq1 = 1./(1.+cqw(i,k-1,j))
6634 !          cq2 = cqw(i,k-1,j)*cq1
6635 !          rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msfty(i,j))*g*(        &
6636 !                           cq1*2.*rdnw(k-1)*(  -p(i,k-1,j))    &
6637 !                           -mu(i,j)-cq2*mub(i,j)            )
6638 !        END DO
6639
6640 !        DO k = 2, kde-1
6641 !        DO i = its,itf
6642 !         cq1 = 1./(1.+cqw(i,k,j))
6643 !         cq2 = cqw(i,k,j)*cq1
6644 !         cqw(i,k,j) = cq1
6645 !         rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msfty(i,j))*g*(        &
6646 !                          cq1*rdn(k)*(p(i,k,j)-p(i,k-1,j))    &
6647 !                          -mu(i,j)-cq2*mub(i,j)            )
6648 !        END DO
6649 !        ENDDO
6650
6651 !      ENDDO
6652
6653 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
6654
6655    a_cq1 =0.0
6656    a_cq2 =0.0
6657
6658 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
6659
6660 !LPB[1]
6661    DO j =jtf, jts, -1
6662
6663 !  DO k=2, kde-1
6664 !  DO i=its, min(ite,ide-1)
6665 !  cqw(i,k,j) =Keep_Lpb1_cqw(i,k,j)
6666 !  END DO
6667 !  END DO
6668
6669    k =kde
6670    DO i =its, itf
6671 ! Revised by Ning Pan, 2010-07-21
6672 !   Tmpv200(i) =cq1
6673 !   cq1 =1./(1. +cqw(i,k-1,j))
6674    cq1 =1./(1. +cqw(i,k-1,j))
6675    Tmpv200(i) =cq1
6676
6677 !   Tmpv001 =cqw(i,k-1,j)*cq1  ! Remarked by Ning Pan, 2010-07-21
6678 !  cq2 =Tmpv001
6679
6680 ! Remarked by Ning Pan, 2010-07-21
6681 !   Tmpv001 =cq1*2.*rdnw(k-1)*(-p(i,k-1,j))
6682 !   Tmpv002 =Tmpv001 -mu(i,j)
6683 !   Tmpv003 =Tmpv002 -cq2*mub(i,j)
6684 !   Tmpv004 =(1./msfty(i,j))*g*Tmpv003
6685 !   Tmpv005 =rw_tend(i,k,j) +Tmpv004
6686 !!  rw_tend(i,k,j) =Tmpv005
6687
6688    ENDDO
6689
6690    DO k =2, kde-1
6691    DO i =its, itf
6692 ! Revised by Ning Pan, 2010-07-21
6693 !   Tmpv300(i,k) =cq1
6694 !   cq1 =1./(1. +cqw(i,k,j))
6695    cq1 =1./(1. +cqw(i,k,j))
6696    Tmpv300(i,k) =cq1
6697
6698 !   Tmpv001 =cqw(i,k,j)*cq1  ! Remarked by Ning Pan, 2010-07-21
6699 !  cq2 =Tmpv001
6700
6701 ! Remarked by Ning Pan, 2010-07-21
6702 !   Tmpv301(i,k) =cqw(i,k,j)
6703 !   cqw(i,k,j) =cq1
6704
6705    Tmpv001 =p(i,k,j) -p(i,k-1,j)
6706    Tmpv302(i,k) =Tmpv001
6707 ! Remarked by Ning Pan, 2010-07-21
6708 !   Tmpv002 =cq1*rdn(k)*Tmpv302(i,k)
6709 !   Tmpv003 =Tmpv002 -mu(i,j)
6710 !   Tmpv004 =Tmpv003 -cq2*mub(i,j)
6711 !   Tmpv005 =(1./msfty(i,j))*g*Tmpv004
6712 !   Tmpv006 =rw_tend(i,k,j) +Tmpv005
6713 !!  rw_tend(i,k,j) =Tmpv006
6714
6715    ENDDO
6716    ENDDO
6717
6718    DO k =kde-1, 2, -1
6719    DO i =itf, its, -1
6720    cq1 =Tmpv300(i,k)  ! Added by Ning Pan, 2010-07-21
6721
6722    a_Tmpv6 =a_rw_tend(i,k,j)
6723    a_rw_tend(i,k,j) =0.0
6724    a_rw_tend(i,k,j) =a_rw_tend(i,k,j) +a_Tmpv6
6725    a_Tmpv5 =a_Tmpv6
6726    a_Tmpv4 =(1./msfty(i,j))*g*a_Tmpv5
6727    a_Tmpv3 =a_Tmpv4
6728    a_cq2 =a_cq2 -mub(i,j)*a_Tmpv4
6729    a_Tmpv2 =a_Tmpv3
6730    a_mu(i,j) =a_mu(i,j) -a_Tmpv3
6731    a_cq1 =a_cq1 +rdn(k)*Tmpv302(i,k)*a_Tmpv2
6732    a_Tmpv1 =cq1*rdn(k)*a_Tmpv2
6733    a_p(i,k,j) =a_p(i,k,j) +a_Tmpv1
6734    a_p(i,k-1,j) =a_p(i,k-1,j) -a_Tmpv1
6735
6736 !   cqw(i,k,j) =Tmpv301(i,k)  ! Remarked by Ning Pan, 2010-07-21
6737
6738    a_cq1 =a_cq1 +a_cqw(i,k,j)
6739    a_cqw(i,k,j) =0.0
6740    a_Tmpv1 =a_cq2
6741    a_cq2 =0.0
6742    a_cqw(i,k,j) =a_cqw(i,k,j) +cq1*a_Tmpv1
6743    a_cq1 =a_cq1 +cqw(i,k,j)*a_Tmpv1
6744
6745 !   cq1 =Tmpv300(i,k)  ! Remarked by Ning Pan, 2010-07-21
6746
6747    a_cqw(i,k,j) =a_cqw(i,k,j) -1./((1. +cqw(i,k,j))*(1. +cqw(i,k,j)))*a_cq1
6748    a_cq1 =0.0
6749    ENDDO
6750    ENDDO
6751
6752    k=kde  ! Added by Ning Pan, 2010-07-21
6753    DO i =itf, its, -1
6754    cq1 =Tmpv200(i)  ! Added by Ning Pan, 2010-07-21
6755
6756    a_Tmpv5 =a_rw_tend(i,k,j)
6757    a_rw_tend(i,k,j) =0.0
6758    a_rw_tend(i,k,j) =a_rw_tend(i,k,j) +a_Tmpv5
6759    a_Tmpv4 =a_Tmpv5
6760    a_Tmpv3 =(1./msfty(i,j))*g*a_Tmpv4
6761    a_Tmpv2 =a_Tmpv3
6762    a_cq2 =a_cq2 -mub(i,j)*a_Tmpv3
6763    a_Tmpv1 =a_Tmpv2
6764    a_mu(i,j) =a_mu(i,j) -a_Tmpv2
6765    a_cq1 =a_cq1 +2.*rdnw(k-1)*(-p(i,k-1,j))*a_Tmpv1
6766    a_p(i,k-1,j) =a_p(i,k-1,j) -1.0*cq1*2.*rdnw(k-1)*a_Tmpv1
6767    a_Tmpv1 =a_cq2
6768    a_cq2 =0.0
6769    a_cqw(i,k-1,j) =a_cqw(i,k-1,j) +cq1*a_Tmpv1
6770    a_cq1 =a_cq1 +cqw(i,k-1,j)*a_Tmpv1
6771
6772 !   cq1 =Tmpv200(i)  ! Remarkded by Ning Pan, 2010-07-21
6773
6774    a_cqw(i,k-1,j) =a_cqw(i,k-1,j) -1./((1. +cqw(i,k-1,j))*(1. +cqw(i,k-1,j)))*a_cq1
6775    a_cq1 =0.0
6776    ENDDO
6777
6778    ENDDO
6779
6780 !LPB[0]
6781 !  itf =min(ite, ide-1)
6782 !  jtf =min(jte, jde-1)
6783
6784    END SUBROUTINE a_pg_buoy_w
6785
6786 ! Revised by Ning Pan, 2010-07-21
6787 !   SUBROUTINE a_w_damp(rw_tend,a_rw_tend,max_vert_cfl,a_max_vert_cfl, &
6788 !   max_horiz_cfl,a_max_horiz_cfl,u,a_u,v,a_v,ww,a_ww,w,a_w,mut,a_mut,rdnw, &
6789    SUBROUTINE a_w_damp(rw_tend,a_rw_tend,max_vert_cfl, &
6790    max_horiz_cfl,u,a_u,v,a_v,ww,a_ww,w,a_w,mut,a_mut,rdnw, &
6791    rdx,rdy,msfux,msfuy,msfvx,msfvy,dt,config_flags,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
6792    jme,kms,kme,its,ite,jts,jte,kts,kte)
6793
6794 !PART I: DECLARATION OF VARIABLES
6795
6796    USE module_llxy
6797
6798    IMPLICIT NONE
6799
6800    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
6801    TYPE(grid_config_rec_type) :: config_flags
6802    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6803    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,a_u,v,a_v,ww,a_ww,w,a_w
6804    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rw_tend,a_rw_tend
6805 ! Revised by Ning Pan, 2010-07-21
6806 !   REAL :: max_vert_cfl,a_max_vert_cfl
6807 !   REAL :: max_horiz_cfl,a_max_horiz_cfl
6808    REAL :: max_vert_cfl
6809    REAL :: max_horiz_cfl
6810    REAL :: horiz_cfl,a_horiz_cfl
6811    REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut
6812    REAL,DIMENSION(kms:kme) :: rdnw
6813    REAL :: dt
6814    REAL :: rdx,rdy
6815    REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy
6816    REAL,DIMENSION(ims:ime,jms:jme) :: msfvx,msfvy
6817 ! Revised by Ning Pan, 2010-07-21
6818 !   REAL :: vert_cfl,a_vert_cfl,cf_n,a_cf_n,cf_d,a_cf_d,maxdub,a_maxdub,maxdeta, &
6819 !   a_maxdeta
6820    REAL :: vert_cfl,a_vert_cfl,cf_n,a_cf_n,cf_d,a_cf_d,maxdub,maxdeta
6821    INTEGER :: itf,jtf,i,j,k,maxi,maxj,maxk
6822    INTEGER :: some
6823    CHARACTER*512 :: temp
6824    CHARACTER (LEN=256) :: time_str
6825    CHARACTER (LEN=256) :: grid_str
6826    integer :: total
6827 ! Revised by Ning Pan, 2010-07-21
6828 !   REAL :: msfuxt,a_msfuxt,msfxffl,a_msfxffl
6829    REAL :: msfuxt,msfxffl
6830
6831 ! Revised by Ning Pan, 2010-07-21
6832 !   REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004
6833    REAL :: a_Tmpv1,Tmpv1
6834 ! Remarked by Ning Pan, 2010-07-21
6835 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv400
6836 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv401
6837 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv402
6838 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv403
6839 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv404
6840 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv405
6841 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv406
6842 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv407
6843 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv408
6844 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv409
6845 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv4010
6846 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv4011
6847 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv4012
6848 !   REAL,DIMENSION(its:min(ite,ide-1),2:kde-1,jts:min(jte,jde-1)) :: Tmpv4013
6849
6850 !DELETED BY WALLS
6851 !#if 1
6852 !#else
6853 !#endif
6854 !This line is fail to be recognized
6855 !              CALL wrf_debug ( 100 , TRIM(temp) )  ! Remarked by Ning Pan, 2010-07-21
6856 !#if 1
6857 !#else
6858 !#endif
6859 !This line is fail to be recognized
6860 !              CALL wrf_debug ( 100 , TRIM(temp) )  ! Remarked by Ning Pan, 2010-07-21
6861 !This line is fail to be recognized
6862 !        CALL get_current_time_string( time_str )  ! Remarked by Ning Pan, 2010-07-21
6863 !This line is fail to be recognized
6864 !        CALL get_current_grid_name( grid_str )  ! Remarked by Ning Pan, 2010-07-21
6865 !This line is fail to be recognized
6866 !        CALL wrf_debug ( 0 , TRIM(wrf_err_message) )  ! Remarked by Ning Pan, 2010-07-21
6867 !This line is fail to be recognized
6868 !        CALL wrf_debug ( 0 , TRIM(wrf_err_message) )  ! Remarked by Ning Pan, 2010-07-21
6869
6870 !PART II: CALCULATIONS OF B. S. TRAJECTORY
6871
6872 !LPB[0]
6873       itf=MIN(ite,ide-1)
6874       jtf=MIN(jte,jde-1)
6875       some = 0
6876       max_vert_cfl = 0.
6877       max_horiz_cfl = 0.
6878       total = 0
6879
6880 !LPB[1]
6881    IF(config_flags%polar) then
6882
6883         msfxffl = 1.0/COS(config_flags%fft_filter_lat*degrad)
6884
6885    END IF
6886
6887 !LPB[2]
6888
6889 !!LPB[3]
6890 !
6891 !   IF ( config_flags%w_damping == 1 ) THEN
6892
6893 !        DO j = jts,jtf
6894 !        DO k = 2, kde-1
6895 !        DO i = its,itf
6896 !        IF(config_flags%polar) then
6897
6898 !              msfuxt = MIN(msfux(i,j), msfxffl)
6899 !           ELSE
6900 !              msfuxt = msfux(i,j)
6901 !           END IF
6902 !           vert_cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt)
6903 !        IF ( vert_cfl > max_vert_cfl ) THEN
6904
6905 !              max_vert_cfl = vert_cfl
6906 !    maxi = i
6907 !    maxj = j
6908 !    maxk = k
6909 !              maxdub = w(i,k,j)
6910 !    maxdeta = -1./rdnw(k)
6911 !           ENDIF
6912 !           horiz_cfl = max( abs(u(i,k,j) * rdx * msfuxt * dt),                           &
6913 !     &
6914 !                abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
6915 !        if (horiz_cfl > max_horiz_cfl) then
6916
6917 !              max_horiz_cfl = horiz_cfl
6918 !           endif
6919 !        if(vert_cfl .gt. w_beta)then
6920
6921 !           cf_n = abs(ww(i,k,j)*rdnw(k)*dt)
6922 !           cf_d = abs(mut(i,j))
6923 !        if(cf_n .gt. cf_d*w_beta )then
6924
6925 !              WRITE(temp,*)i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
6926 !           if ( vert_cfl > 2. ) some = some + 1
6927
6928 !              rw_tend(i,k,j) = rw_tend(i,k,j)-sign(1.,w(i,k,j))*w_alpha*(vert_cfl- &
6929 !   w_beta)*mut(i,j)
6930 !           endif
6931 !        END DO
6932 !        ENDDO
6933 !        ENDDO
6934 !      ELSE
6935
6936 !        DO j = jts,jtf
6937 !        DO k = 2, kde-1
6938 !        DO i = its,itf
6939 !        IF(config_flags%polar) then
6940
6941 !              msfuxt = MIN(msfux(i,j), msfxffl)
6942 !           ELSE
6943 !              msfuxt = msfux(i,j)
6944 !           END IF
6945 !           vert_cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt)
6946 !        IF ( vert_cfl > max_vert_cfl ) THEN
6947
6948 !              max_vert_cfl = vert_cfl
6949 !    maxi = i
6950 !    maxj = j
6951 !    maxk = k
6952 !              maxdub = w(i,k,j)
6953 !    maxdeta = -1./rdnw(k)
6954 !           ENDIF
6955 !           horiz_cfl = max( abs(u(i,k,j) * rdx * msfuxt * dt),                           &
6956 !     &
6957 !                abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
6958 !        if (horiz_cfl > max_horiz_cfl) then
6959
6960 !              max_horiz_cfl = horiz_cfl
6961 !           endif
6962 !        if(vert_cfl .gt. w_beta)then
6963
6964 !           cf_n = abs(ww(i,k,j)*rdnw(k)*dt)
6965 !           cf_d = abs(mut(i,j))
6966 !        if(cf_n .gt. cf_d*w_beta )then
6967
6968 !              WRITE(temp,*)i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
6969 !           if ( vert_cfl > 2. ) some = some + 1
6970
6971 !           endif
6972 !        END DO
6973 !        ENDDO
6974 !        ENDDO
6975 !      ENDIF
6976 !   IF ( some .GT. 0 ) THEN
6977
6978 !        WRITE(wrf_err_message,*)some,                                              &
6979 !               ' points exceeded cfl=2 in domain '//TRIM(grid_str)//' at time '//TRIM( &
6980 !   time_str)//' hours'
6981 !        WRITE(wrf_err_message,*)'MAX AT i,j,k: ',maxi,maxj,maxk,' vert_cfl,w,d(eta) &
6982 !   =',max_vert_cfl,   &
6983 !                                maxdub,maxdeta
6984 !      ENDIF
6985
6986 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
6987
6988 !REVISED BY WALLS
6989 !  a_PROJ_GAUSS =0.0
6990 !  a_PROJ_CYL =0.0
6991 !  a_PROJ_CASSINI =0.0
6992 !  a_PROJ_ROTLL =0.0
6993    a_horiz_cfl =0.0
6994    a_vert_cfl =0.0
6995    a_cf_n =0.0
6996    a_cf_d =0.0
6997    a_Tmpv1 = 0.0  ! Added by Ning Pan, 2010-07-21
6998 ! Remarked by Ning Pan, 2010-07-21
6999 !   a_maxdub =0.0
7000 !   a_maxdeta =0.0
7001 !   a_msfuxt =0.0
7002 !   a_msfxffl =0.0
7003
7004 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
7005
7006 !LPB[3]
7007 ! Reconstructed by Ning Pan, 2010-07-21
7008    IF( config_flags%w_damping == 1 ) THEN
7009      DO j =jts, jtf
7010      DO k =2, kde-1
7011      DO i =its, itf
7012
7013        IF(config_flags%polar) THEN
7014          msfuxt =min(msfux(i,j), msfxffl)
7015        ELSE
7016          msfuxt =msfux(i,j)
7017        END IF
7018
7019        vert_cfl =abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt)
7020        IF( vert_cfl > max_vert_cfl ) THEN
7021          max_vert_cfl = vert_cfl ; maxi = i ; maxj = j ; maxk = k
7022          maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k)
7023        ENDIF
7024
7025        horiz_cfl =max( abs(u(i,k,j) * rdx * msfuxt * dt), &
7026                        abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
7027        IF(horiz_cfl > max_horiz_cfl) THEN
7028          max_horiz_cfl =horiz_cfl
7029        ENDIF
7030
7031        IF(vert_cfl .gt. w_beta) THEN
7032          WRITE(temp,*)i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
7033          CALL wrf_debug ( 100 , TRIM(temp) )
7034          IF( vert_cfl > 2. ) some =some+1
7035
7036          a_Tmpv1 = -a_rw_tend(i,k,j)
7037          a_vert_cfl = a_vert_cfl + sign(1., w(i,k,j)) *w_alpha*(a_Tmpv1)*mut(i,j)
7038          a_mut(i,j) = a_mut(i,j) + sign(1., w(i,k,j)) *w_alpha*(vert_cfl -w_beta)*a_Tmpv1
7039          a_Tmpv1 = 0.0
7040        ENDIF
7041
7042 !       a_v(i,k,j) =a_v(i,k,j) - sign(1.0,v(i,k,j)*rdy*msfvy(i,j)*dt)*a_horiz_cfl*rdy*msfvy(i,j)*dt &
7043 !                                    *sign(1.0, abs(Tmpv1*dt)-(abs(v(i,k,j)*rdy*msfvy(i,j)*dt)))*0.5
7044 !       a_Tmpv1 =a_Tmpv1 + sign(1.0, Tmpv1*dt)*a_horiz_cfl*dt &
7045 !                              *sign(1.0, abs(Tmpv1*dt)-(abs(v(i,k,j)*rdy*msfvy(i,j)*dt)))*0.5
7046 !       a_v(i,k,j) =a_v(i,k,j) + sign(1.0, v(i,k,j)*rdy*msfvy(i,j)*dt)*a_horiz_cfl*rdy*msfvy(i,j)*dt*0.5
7047 !       a_Tmpv1 =a_Tmpv1 + sign(1.0, Tmpv1*dt)*a_horiz_cfl*dt*0.5
7048 !       a_horiz_cfl =0.0
7049 !       a_u(i,k,j) =a_u(i,k,j) + a_Tmpv1*rdx*msfuxt
7050 !       a_Tmpv1 =0.0
7051
7052        Tmpv1 =ww(i,k,j)/mut(i,j)
7053        a_Tmpv1 = a_Tmpv1 + sign(1.0, Tmpv1*rdnw(k)*dt)*a_vert_cfl*rdnw(k)*dt
7054        a_vert_cfl = 0.0
7055        a_mut(i,j) = a_mut(i,j) - a_Tmpv1*ww(i,k,j)/(mut(i,j)*mut(i,j))
7056        a_ww(i,k,j) = a_ww(i,k,j) + a_Tmpv1/mut(i,j)
7057        a_Tmpv1 = 0.0
7058      ENDDO
7059      ENDDO
7060      ENDDO
7061    ELSE
7062      DO j =jts, jtf
7063      DO k =2, kde-1
7064      DO i =its, itf
7065        IF(config_flags%polar) THEN
7066          msfuxt =min(msfux(i,j), msfxffl)
7067        ELSE
7068          msfuxt =msfux(i,j)
7069        END IF
7070
7071        vert_cfl =abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt)
7072        IF( vert_cfl > max_vert_cfl ) THEN
7073          max_vert_cfl = vert_cfl ; maxi = i ; maxj = j ; maxk = k
7074          maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k)
7075        ENDIF
7076
7077        horiz_cfl = max( abs(u(i,k,j) * rdx * msfuxt * dt), &
7078                         abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
7079        IF(horiz_cfl > max_horiz_cfl) THEN
7080          max_horiz_cfl =horiz_cfl
7081        ENDIF
7082
7083        IF(vert_cfl .gt. w_beta) THEN
7084          WRITE(temp,*)i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
7085          CALL wrf_debug ( 100 , TRIM(temp) )
7086          IF( vert_cfl > 2. ) some =some+1
7087        ENDIF
7088      ENDDO
7089      ENDDO
7090      ENDDO
7091    ENDIF
7092
7093    IF ( some .GT. 0 ) THEN
7094      CALL get_current_time_string( time_str )
7095      CALL get_current_grid_name( grid_str )
7096      WRITE(temp,*)some,                                            &
7097             ' points exceeded cfl=2 in domain '//TRIM(grid_str)//' at time '//TRIM(time_str)//' hours'
7098      CALL wrf_debug ( 0 , TRIM(temp) )
7099      WRITE(temp,*)'MAX AT i,j,k: ',maxi,maxj,maxk,' vert_cfl,w,d(eta)=',max_vert_cfl, &
7100                              maxdub,maxdeta
7101      CALL wrf_debug ( 0 , TRIM(temp) )
7102    ENDIF
7103
7104 !DELETED BY WALLS
7105 !   IF( config_flags%w_damping == 1 ) THEN
7106 !   DO j =jts, jtf
7107 !   DO k =2, kde-1
7108 !   DO i =its, itf
7109 !   IF(config_flags%polar) THEN
7110 !   Tmpv400(i,k,j) =msfuxt
7111 !   msfuxt =min(msfux(i,j), msfxffl)
7112 !
7113 !   ELSE
7114 !   Tmpv401(i,k,j) =msfuxt
7115 !   msfuxt =msfux(i,j)
7116 !
7117 !   END IF
7118 !   Tmpv001 =ww(i,k,j)/mut(i,j)
7119 !   Tmpv002 =Tmpv001*rdnw(k)
7120 !   Tmpv003 =Tmpv002*dt
7121 !   Tmpv402(i,k,j) =Tmpv003
7122 !   Tmpv004 =abs(Tmpv402(i,k,j))
7123 !   Tmpv403(i,k,j) =vert_cfl
7124 !   vert_cfl =Tmpv004
7125 !
7126 !   IF( vert_cfl > max_vert_cfl ) THEN
7127 !!  max_vert_cfl =vert_cfl
7128 !
7129 !   maxi =i
7130 !   maxj =j
7131 !   maxk =k
7132 !!  maxdub =w(i,k,j)
7133 !
7134 !   maxdeta =-1./rdnw(k)
7135 !
7136 !   ENDIF
7137 !   Tmpv001 =u(i,k,j)*rdx*msfuxt
7138 !   Tmpv002 =Tmpv001*dt
7139 !   Tmpv404(i,k,j) =Tmpv002
7140 !   Tmpv003 =abs(Tmpv404(i,k,j))
7141 !   Tmpv405(i,k,j) =Tmpv003
7142 !   Tmpv406(i,k,j) =Tmpv405(i,k,j)
7143 !   Tmpv004 =max(Tmpv406(i,k,j), abs(v(i,k,j)*rdy*msfvy(i,j)*dt))
7144 !!  horiz_cfl =Tmpv004
7145 !
7146 !   IF(horiz_cfl > max_horiz_cfl) THEN
7147 !!  max_horiz_cfl =horiz_cfl
7148 !
7149 !DELETED BY WALLS
7150 !   endif
7151 !   IF(vert_cfl .gt. w_beta) THEN
7152 !!  cf_n =abs(ww(i,k,j)*rdnw(k)*dt)
7153
7154 !!  cf_d =abs(mut(i,j))
7155
7156 !   IF(cf_n .gt. cf_d*w_beta ) THEN
7157 !   IF( vert_cfl > 2. ) THEN
7158 !   some =some+1
7159 !   END IF
7160 !   Tmpv001 =sign(1., w(i,k,j))*w_alpha*(vert_cfl -w_beta)*mut(i,j)
7161 !   Tmpv002 =rw_tend(i,k,j) -Tmpv001
7162 !!  rw_tend(i,k,j) =Tmpv002
7163
7164 !   endif
7165 !   ENDDO
7166 !   ENDDO
7167 !   ENDDO
7168 !   ELSE
7169 !   DO j =jts, jtf
7170 !   DO k =2, kde-1
7171 !   DO i =its, itf
7172 !   IF(config_flags%polar) THEN
7173 !   Tmpv407(i,k,j) =msfuxt
7174 !   msfuxt =min(msfux(i,j), msfxffl)
7175
7176 !   ELSE
7177 !   Tmpv408(i,k,j) =msfuxt
7178 !   msfuxt =msfux(i,j)
7179
7180 !   END IF
7181 !   Tmpv001 =ww(i,k,j)/mut(i,j)
7182 !   Tmpv002 =Tmpv001*rdnw(k)
7183 !   Tmpv003 =Tmpv002*dt
7184 !   Tmpv409(i,k,j) =Tmpv003
7185 !   Tmpv004 =abs(Tmpv409(i,k,j))
7186 !   Tmpv4010(i,k,j) =vert_cfl
7187 !   vert_cfl =Tmpv004
7188
7189 !   IF( vert_cfl > max_vert_cfl ) THEN
7190 !!  max_vert_cfl =vert_cfl
7191
7192 !   maxi =i
7193 !   maxj =j
7194 !   maxk =k
7195 !!  maxdub =w(i,k,j)
7196
7197 !   maxdeta =-1./rdnw(k)
7198
7199 !   ENDIF
7200 !   Tmpv001 =u(i,k,j)*rdx*msfuxt
7201 !   Tmpv002 =Tmpv001*dt
7202 !   Tmpv4011(i,k,j) =Tmpv002
7203 !   Tmpv003 =abs(Tmpv4011(i,k,j))
7204 !   Tmpv4012(i,k,j) =Tmpv003
7205 !   Tmpv4013(i,k,j) =Tmpv4012(i,k,j)
7206 !   Tmpv004 =max(Tmpv4013(i,k,j), abs(v(i,k,j)*rdy*msfvy(i,j)*dt))
7207 !  horiz_cfl =Tmpv004
7208
7209 !   IF(horiz_cfl > max_horiz_cfl) THEN
7210 !!  max_horiz_cfl =horiz_cfl
7211
7212 !   endif
7213 !   IF(vert_cfl .gt. w_beta) THEN
7214 !!  cf_n =abs(ww(i,k,j)*rdnw(k)*dt)
7215
7216 !!  cf_d =abs(mut(i,j))
7217
7218 !   IF(cf_n .gt. cf_d*w_beta ) THEN
7219 !   IF( vert_cfl > 2. ) THEN
7220 !   some =some+1
7221 !   END IF
7222 !   endif
7223 !   ENDDO
7224 !   ENDDO
7225 !   ENDDO
7226 !   ENDIF
7227 !!   IF( some .GT. 0 ) THEN
7228 !   ENDIF
7229 !
7230 !!WARNING: DEADLY ERRORS OCCUR IN ADJOINT ACCUMULATING PROCESS.
7231 !WARNING: DEADLY ERRORS OCCUR IN ADJOINT ACCUMULATING PROCESS.
7232 !
7233 !LPB[2]
7234
7235 !LPB[1]
7236
7237 !  IF(config_flags%polar) THEN
7238 !  msfxffl =1.0/cos(config_flags%fft_filter_lat*degrad)
7239
7240 !  END IF
7241
7242 !   IF(config_flags%polar) THEN  ! Remarked by Ning Pan, 2010-07-21
7243
7244 !STOP  ! Remarked by Ning Pan, 2010-07-21
7245 !DELETED BY WALLS
7246 !  a_config_flags%fft_filter_lat =a_config_flags%fft_filter_lat +1.0*degrad*sin(  &
7247 !  config_flags%fft_filter_lat*degrad)/(cos(config_flags%fft_filter_lat*degrad)  &
7248 !  *cos(config_flags%fft_filter_lat*degrad))*a_msfxffl
7249 !   a_msfxffl =0.0  ! Remarked by Ning Pan, 2010-07-21
7250
7251 !   END IF  ! Remarked by Ning Pan, 2010-07-21
7252
7253 !LPB[0]
7254 !  itf =min(ite, ide-1)
7255 !  jtf =min(jte, jde-1)
7256 !  some =0
7257 !  max_vert_cfl =0.
7258
7259 !  max_horiz_cfl =0.
7260
7261 !  total =0
7262
7263 ! Remarked by Ning Pan, 2010-07-21
7264 !   a_max_horiz_cfl =0.0
7265 !   a_max_vert_cfl =0.0
7266
7267    END SUBROUTINE a_w_damp
7268
7269 !        Generated by TAPENADE     (INRIA, Tropics team)
7270 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
7271 !
7272 !  Differentiation of horizontal_diffusion in reverse (adjoint) mode:
7273 !   gradient     of useful results: field tendency xkmhd mu
7274 !   with respect to varying inputs: field tendency xkmhd mu
7275 !   RW status of diff variables: field:incr tendency:in-out xkmhd:incr
7276 !                mu:incr
7277 SUBROUTINE A_HORIZONTAL_DIFFUSION(name, field, fieldb, tendency, &
7278 &  tendencyb, mu, mub, config_flags, msfux, msfuy, msfvx, msfvx_inv, &
7279 &  msfvy, msftx, msfty, khdif, xkmhd, xkmhdb, rdx, rdy, ids, ide, jds, &
7280 &  jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
7281 &  kte)
7282   IMPLICIT NONE
7283 ! Input data
7284   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
7285   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
7286 &  jme, kms, kme, its, ite, jts, jte, kts, kte
7287   CHARACTER(len=1), INTENT(IN) :: name
7288   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, xkmhd
7289   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, xkmhdb
7290   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
7291   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb
7292   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu
7293   REAL, DIMENSION(ims:ime, jms:jme) :: mub
7294   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
7295 &  msfvx_inv, msfvy, msftx, msfty
7296   REAL, INTENT(IN) :: rdx, rdy, khdif
7297 ! Local data
7298   INTEGER :: i, j, k, itf, jtf, ktf
7299   INTEGER :: i_start, i_end, j_start, j_end
7300   REAL :: mrdx, mkrdxm, mkrdxp, mrdy, mkrdym, mkrdyp
7301   REAL :: mkrdxmb, mkrdxpb, mkrdymb, mkrdypb
7302   LOGICAL :: specified
7303   REAL :: temp2
7304   REAL :: temp1
7305   REAL :: temp1b33
7306   REAL :: temp0
7307   REAL :: temp1b32
7308   REAL :: temp1b31
7309   REAL :: temp1b30
7310   REAL :: tempb1
7311   REAL :: temp0b
7312   REAL :: tempb0
7313   REAL :: temp1b29
7314   REAL :: temp1b28
7315   REAL :: temp3b
7316   REAL :: temp1b27
7317   REAL :: temp1b26
7318   REAL :: temp1b25
7319   REAL :: temp1b24
7320   REAL :: temp1b23
7321   REAL :: temp1b22
7322   REAL :: temp2b1
7323   REAL :: temp1b21
7324   REAL :: temp2b0
7325   REAL :: temp1b20
7326   REAL :: tempb
7327   REAL :: temp0b1
7328   REAL :: temp0b0
7329   REAL :: temp1b19
7330   REAL :: temp1b18
7331   REAL :: temp2b
7332   REAL :: temp1b17
7333   REAL :: temp1b16
7334   REAL :: temp1b15
7335   REAL :: temp1b14
7336   REAL :: temp1b13
7337   REAL :: temp1b12
7338   REAL :: temp1b11
7339   REAL :: temp1b10
7340   REAL :: temp3b0
7341   REAL :: temp1b9
7342   REAL :: temp1b8
7343   REAL :: temp1b7
7344   REAL :: temp1b
7345   REAL :: temp1b6
7346   REAL :: temp
7347   REAL :: temp1b5
7348   REAL :: temp1b4
7349   REAL :: temp1b3
7350   REAL :: temp1b2
7351   REAL :: temp1b1
7352   REAL :: temp1b0
7353 !<DESCRIPTION>
7354 !
7355 !  horizontal_diffusion computes the horizontal diffusion tendency
7356 !  on model horizontal coordinate surfaces.
7357 !
7358 !</DESCRIPTION>
7359   specified = .false.
7360   IF (config_flags%specified .OR. config_flags%nested) specified = &
7361 &      .true.
7362   IF (kte .GT. kde - 1) THEN
7363     ktf = kde - 1
7364   ELSE
7365     ktf = kte
7366   END IF
7367   IF (name .EQ. 'u') THEN
7368     i_start = its
7369     i_end = ite
7370     j_start = jts
7371     IF (jte .GT. jde - 1) THEN
7372       j_end = jde - 1
7373     ELSE
7374       j_end = jte
7375     END IF
7376     IF (config_flags%open_xs .OR. specified) THEN
7377       IF (ids + 1 .LT. its) THEN
7378         i_start = its
7379       ELSE
7380         i_start = ids + 1
7381       END IF
7382     END IF
7383     IF (config_flags%open_xe .OR. specified) THEN
7384       IF (ide - 1 .GT. ite) THEN
7385         i_end = ite
7386       ELSE
7387         i_end = ide - 1
7388       END IF
7389     END IF
7390     IF (config_flags%open_ys .OR. specified) THEN
7391       IF (jds + 1 .LT. jts) THEN
7392         j_start = jts
7393       ELSE
7394         j_start = jds + 1
7395       END IF
7396     END IF
7397     IF (config_flags%open_ye .OR. specified) THEN
7398       IF (jde - 2 .GT. jte) THEN
7399         j_end = jte
7400       ELSE
7401         j_end = jde - 2
7402       END IF
7403     END IF
7404     IF (config_flags%periodic_x) i_start = its
7405     IF (config_flags%periodic_x) i_end = ite
7406     DO j=j_start,j_end
7407       DO k=kts,ktf
7408         DO i=i_start,i_end
7409           CALL PUSHREAL8(mkrdxm)
7410 ! The interior is grad: (m_x*d/dx), the exterior is div: (m_x*m_y*d/dx(/m_y))
7411 ! setting up different averagings of m^2 partial d/dX and m^2 partial d/dY
7412           mkrdxm = msftx(i-1, j)/msfty(i-1, j)*mu(i-1, j)*xkmhd(i-1, k, &
7413 &            j)*rdx
7414           CALL PUSHREAL8(mkrdxp)
7415           mkrdxp = msftx(i, j)/msfty(i, j)*mu(i, j)*xkmhd(i, k, j)*rdx
7416           CALL PUSHREAL8(mkrdym)
7417           mkrdym = (msfuy(i, j)+msfuy(i, j-1))/(msfux(i, j)+msfux(i, j-1&
7418 &            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*0.25*(&
7419 &            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1&
7420 &            , k, j))*rdy
7421           CALL PUSHREAL8(mkrdyp)
7422           mkrdyp = (msfuy(i, j)+msfuy(i, j+1))/(msfux(i, j)+msfux(i, j+1&
7423 &            ))*0.25*(mu(i, j)+mu(i, j+1)+mu(i-1, j+1)+mu(i-1, j))*0.25*(&
7424 &            xkmhd(i, k, j)+xkmhd(i, k, j+1)+xkmhd(i-1, k, j+1)+xkmhd(i-1&
7425 &            , k, j))*rdy
7426 ! need to do four-corners (t) for diffusion coefficient as there are
7427 ! no values at u,v points
7428 ! msfuy - has to be y as part of d/dY
7429 !         has to be u as we're at a u point
7430 ! correctly averaged version of rho~ * m^2 *
7431 !    [partial d/dX(partial du^/dX) + partial d/dY(partial du^/dY)]
7432         END DO
7433       END DO
7434     END DO
7435     DO j=j_end,j_start,-1
7436       DO k=ktf,kts,-1
7437         DO i=i_end,i_start,-1
7438           mrdx = msfux(i, j)*msfuy(i, j)*rdx
7439           mrdy = msfux(i, j)*msfuy(i, j)*rdy
7440           temp3b = mrdx*tendencyb(i, k, j)
7441           temp3b0 = mrdy*tendencyb(i, k, j)
7442           mkrdxpb = (field(i+1, k, j)-field(i, k, j))*temp3b
7443           fieldb(i+1, k, j) = fieldb(i+1, k, j) + mkrdxp*temp3b
7444           fieldb(i, k, j) = fieldb(i, k, j) + (-mkrdym-mkrdyp)*temp3b0 +&
7445 &            (-mkrdxm-mkrdxp)*temp3b
7446           mkrdxmb = -((field(i, k, j)-field(i-1, k, j))*temp3b)
7447           fieldb(i-1, k, j) = fieldb(i-1, k, j) + mkrdxm*temp3b
7448           mkrdypb = (field(i, k, j+1)-field(i, k, j))*temp3b0
7449           fieldb(i, k, j+1) = fieldb(i, k, j+1) + mkrdyp*temp3b0
7450           mkrdymb = -((field(i, k, j)-field(i, k, j-1))*temp3b0)
7451           fieldb(i, k, j-1) = fieldb(i, k, j-1) + mkrdym*temp3b0
7452           CALL POPREAL8(mkrdyp)
7453           temp2 = msfux(i, j) + msfux(i, j+1)
7454           temp2b = (msfuy(i, j)+msfuy(i, j+1))*rdy*0.25**2*mkrdypb
7455           temp2b0 = (xkmhd(i, k, j)+xkmhd(i, k, j+1)+xkmhd(i-1, k, j+1)+&
7456 &            xkmhd(i-1, k, j))*temp2b/temp2
7457           temp2b1 = (mu(i, j)+mu(i, j+1)+mu(i-1, j+1)+mu(i-1, j))*temp2b&
7458 &            /temp2
7459           mub(i, j) = mub(i, j) + temp2b0
7460           mub(i, j+1) = mub(i, j+1) + temp2b0
7461           mub(i-1, j+1) = mub(i-1, j+1) + temp2b0
7462           mub(i-1, j) = mub(i-1, j) + temp2b0
7463           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp2b1
7464           xkmhdb(i, k, j+1) = xkmhdb(i, k, j+1) + temp2b1
7465           xkmhdb(i-1, k, j+1) = xkmhdb(i-1, k, j+1) + temp2b1
7466           xkmhdb(i-1, k, j) = xkmhdb(i-1, k, j) + temp2b1
7467           CALL POPREAL8(mkrdym)
7468           temp1 = msfux(i, j) + msfux(i, j-1)
7469           temp1b29 = (msfuy(i, j)+msfuy(i, j-1))*rdy*0.25**2*mkrdymb
7470           temp1b30 = (xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)&
7471 &            +xkmhd(i-1, k, j))*temp1b29/temp1
7472           temp1b31 = (mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*&
7473 &            temp1b29/temp1
7474           mub(i, j) = mub(i, j) + temp1b30
7475           mub(i, j-1) = mub(i, j-1) + temp1b30
7476           mub(i-1, j-1) = mub(i-1, j-1) + temp1b30
7477           mub(i-1, j) = mub(i-1, j) + temp1b30
7478           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b31
7479           xkmhdb(i, k, j-1) = xkmhdb(i, k, j-1) + temp1b31
7480           xkmhdb(i-1, k, j-1) = xkmhdb(i-1, k, j-1) + temp1b31
7481           xkmhdb(i-1, k, j) = xkmhdb(i-1, k, j) + temp1b31
7482           CALL POPREAL8(mkrdxp)
7483           temp1b32 = msftx(i, j)*rdx*mkrdxpb
7484           xkmhdb(i, k, j) = xkmhdb(i, k, j) + mu(i, j)*temp1b32/msfty(i&
7485 &            , j)
7486           mub(i, j) = mub(i, j) + xkmhd(i, k, j)*temp1b32/msfty(i, j)
7487           CALL POPREAL8(mkrdxm)
7488           temp1b33 = msftx(i-1, j)*rdx*mkrdxmb
7489           xkmhdb(i-1, k, j) = xkmhdb(i-1, k, j) + mu(i-1, j)*temp1b33/&
7490 &            msfty(i-1, j)
7491           mub(i-1, j) = mub(i-1, j) + xkmhd(i-1, k, j)*temp1b33/msfty(i-&
7492 &            1, j)
7493         END DO
7494       END DO
7495     END DO
7496   ELSE IF (name .EQ. 'v') THEN
7497     i_start = its
7498     IF (ite .GT. ide - 1) THEN
7499       i_end = ide - 1
7500     ELSE
7501       i_end = ite
7502     END IF
7503     j_start = jts
7504     j_end = jte
7505     IF (config_flags%open_xs .OR. specified) THEN
7506       IF (ids + 1 .LT. its) THEN
7507         i_start = its
7508       ELSE
7509         i_start = ids + 1
7510       END IF
7511     END IF
7512     IF (config_flags%open_xe .OR. specified) THEN
7513       IF (ide - 2 .GT. ite) THEN
7514         i_end = ite
7515       ELSE
7516         i_end = ide - 2
7517       END IF
7518     END IF
7519     IF (config_flags%open_ys .OR. specified) THEN
7520       IF (jds + 1 .LT. jts) THEN
7521         j_start = jts
7522       ELSE
7523         j_start = jds + 1
7524       END IF
7525     END IF
7526     IF (config_flags%open_ye .OR. specified) THEN
7527       IF (jde - 1 .GT. jte) THEN
7528         j_end = jte
7529       ELSE
7530         j_end = jde - 1
7531       END IF
7532     END IF
7533     IF (config_flags%periodic_x) i_start = its
7534     IF (config_flags%periodic_x) THEN
7535       IF (ite .GT. ide - 1) THEN
7536         i_end = ide - 1
7537       ELSE
7538         i_end = ite
7539       END IF
7540     END IF
7541     IF (config_flags%polar) THEN
7542       IF (jds + 1 .LT. jts) THEN
7543         j_start = jts
7544       ELSE
7545         j_start = jds + 1
7546       END IF
7547     END IF
7548     IF (config_flags%polar) THEN
7549       IF (jde - 1 .GT. jte) THEN
7550         j_end = jte
7551       ELSE
7552         j_end = jde - 1
7553       END IF
7554     END IF
7555     DO j=j_start,j_end
7556       DO k=kts,ktf
7557         DO i=i_start,i_end
7558           CALL PUSHREAL8(mkrdxm)
7559           mkrdxm = (msfvx(i, j)+msfvx(i-1, j))/(msfvy(i, j)+msfvy(i-1, j&
7560 &            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*0.25*(&
7561 &            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1&
7562 &            , k, j))*rdx
7563           CALL PUSHREAL8(mkrdxp)
7564           mkrdxp = (msfvx(i, j)+msfvx(i+1, j))/(msfvy(i, j)+msfvy(i+1, j&
7565 &            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i+1, j-1)+mu(i+1, j))*0.25*(&
7566 &            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i+1, k, j-1)+xkmhd(i+1&
7567 &            , k, j))*rdx
7568         END DO
7569       END DO
7570     END DO
7571     DO j=j_end,j_start,-1
7572       DO k=ktf,kts,-1
7573         DO i=i_end,i_start,-1
7574           mkrdym = msfty(i, j-1)/msftx(i, j-1)*xkmhd(i, k, j-1)*rdy
7575           mkrdyp = msfty(i, j)/msftx(i, j)*xkmhd(i, k, j)*rdy
7576           mrdx = msfvx(i, j)*msfvy(i, j)*rdx
7577           mrdy = msfvx(i, j)*msfvy(i, j)*rdy
7578           temp1b = mrdx*tendencyb(i, k, j)
7579           temp1b0 = mrdy*tendencyb(i, k, j)
7580           mkrdxpb = (field(i+1, k, j)-field(i, k, j))*temp1b
7581           fieldb(i+1, k, j) = fieldb(i+1, k, j) + mkrdxp*temp1b
7582           fieldb(i, k, j) = fieldb(i, k, j) + (-mkrdym-mkrdyp)*temp1b0 +&
7583 &            (-mkrdxm-mkrdxp)*temp1b
7584           mkrdxmb = -((field(i, k, j)-field(i-1, k, j))*temp1b)
7585           fieldb(i-1, k, j) = fieldb(i-1, k, j) + mkrdxm*temp1b
7586           mkrdypb = (field(i, k, j+1)-field(i, k, j))*temp1b0
7587           fieldb(i, k, j+1) = fieldb(i, k, j+1) + mkrdyp*temp1b0
7588           mkrdymb = -((field(i, k, j)-field(i, k, j-1))*temp1b0)
7589           fieldb(i, k, j-1) = fieldb(i, k, j-1) + mkrdym*temp1b0
7590           xkmhdb(i, k, j) = xkmhdb(i, k, j) + msfty(i, j)*rdy*mkrdypb/&
7591 &            msftx(i, j)
7592           xkmhdb(i, k, j-1) = xkmhdb(i, k, j-1) + msfty(i, j-1)*rdy*&
7593 &            mkrdymb/msftx(i, j-1)
7594           CALL POPREAL8(mkrdxp)
7595           temp0 = msfvy(i, j) + msfvy(i+1, j)
7596           temp0b = (msfvx(i, j)+msfvx(i+1, j))*rdx*0.25**2*mkrdxpb
7597           temp0b0 = (xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i+1, k, j-1)+&
7598 &            xkmhd(i+1, k, j))*temp0b/temp0
7599           temp0b1 = (mu(i, j)+mu(i, j-1)+mu(i+1, j-1)+mu(i+1, j))*temp0b&
7600 &            /temp0
7601           mub(i, j) = mub(i, j) + temp0b0
7602           mub(i, j-1) = mub(i, j-1) + temp0b0
7603           mub(i+1, j-1) = mub(i+1, j-1) + temp0b0
7604           mub(i+1, j) = mub(i+1, j) + temp0b0
7605           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp0b1
7606           xkmhdb(i, k, j-1) = xkmhdb(i, k, j-1) + temp0b1
7607           xkmhdb(i+1, k, j-1) = xkmhdb(i+1, k, j-1) + temp0b1
7608           xkmhdb(i+1, k, j) = xkmhdb(i+1, k, j) + temp0b1
7609           CALL POPREAL8(mkrdxm)
7610           temp = msfvy(i, j) + msfvy(i-1, j)
7611           tempb = (msfvx(i, j)+msfvx(i-1, j))*rdx*0.25**2*mkrdxmb
7612           tempb0 = (xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+&
7613 &            xkmhd(i-1, k, j))*tempb/temp
7614           tempb1 = (mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*tempb/&
7615 &            temp
7616           mub(i, j) = mub(i, j) + tempb0
7617           mub(i, j-1) = mub(i, j-1) + tempb0
7618           mub(i-1, j-1) = mub(i-1, j-1) + tempb0
7619           mub(i-1, j) = mub(i-1, j) + tempb0
7620           xkmhdb(i, k, j) = xkmhdb(i, k, j) + tempb1
7621           xkmhdb(i, k, j-1) = xkmhdb(i, k, j-1) + tempb1
7622           xkmhdb(i-1, k, j-1) = xkmhdb(i-1, k, j-1) + tempb1
7623           xkmhdb(i-1, k, j) = xkmhdb(i-1, k, j) + tempb1
7624         END DO
7625       END DO
7626     END DO
7627   ELSE IF (name .EQ. 'w') THEN
7628     i_start = its
7629     IF (ite .GT. ide - 1) THEN
7630       i_end = ide - 1
7631     ELSE
7632       i_end = ite
7633     END IF
7634     j_start = jts
7635     IF (jte .GT. jde - 1) THEN
7636       j_end = jde - 1
7637     ELSE
7638       j_end = jte
7639     END IF
7640     IF (config_flags%open_xs .OR. specified) THEN
7641       IF (ids + 1 .LT. its) THEN
7642         i_start = its
7643       ELSE
7644         i_start = ids + 1
7645       END IF
7646     END IF
7647     IF (config_flags%open_xe .OR. specified) THEN
7648       IF (ide - 2 .GT. ite) THEN
7649         i_end = ite
7650       ELSE
7651         i_end = ide - 2
7652       END IF
7653     END IF
7654     IF (config_flags%open_ys .OR. specified) THEN
7655       IF (jds + 1 .LT. jts) THEN
7656         j_start = jts
7657       ELSE
7658         j_start = jds + 1
7659       END IF
7660     END IF
7661     IF (config_flags%open_ye .OR. specified) THEN
7662       IF (jde - 2 .GT. jte) THEN
7663         j_end = jte
7664       ELSE
7665         j_end = jde - 2
7666       END IF
7667     END IF
7668     IF (config_flags%periodic_x) i_start = its
7669     IF (config_flags%periodic_x) THEN
7670       IF (ite .GT. ide - 1) THEN
7671         i_end = ide - 1
7672       ELSE
7673         i_end = ite
7674       END IF
7675     END IF
7676     DO j=j_start,j_end
7677       DO k=kts+1,ktf
7678         DO i=i_start,i_end
7679           CALL PUSHREAL8(mkrdxm)
7680           mkrdxm = msfux(i, j)/msfuy(i, j)*0.25*(mu(i, j)+mu(i-1, j)+mu(&
7681 &            i, j)+mu(i-1, j))*0.25*(xkmhd(i, k, j)+xkmhd(i-1, k, j)+&
7682 &            xkmhd(i, k-1, j)+xkmhd(i-1, k-1, j))*rdx
7683           CALL PUSHREAL8(mkrdxp)
7684           mkrdxp = msfux(i+1, j)/msfuy(i+1, j)*0.25*(mu(i+1, j)+mu(i, j)&
7685 &            +mu(i+1, j)+mu(i, j))*0.25*(xkmhd(i+1, k, j)+xkmhd(i, k, j)+&
7686 &            xkmhd(i+1, k-1, j)+xkmhd(i, k-1, j))*rdx
7687           CALL PUSHREAL8(mkrdym)
7688 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*   &
7689           mkrdym = msfvy(i, j)*msfvx_inv(i, j)*0.25*(mu(i, j)+mu(i, j-1)&
7690 &            +mu(i, j)+mu(i, j-1))*0.25*(xkmhd(i, k, j)+xkmhd(i, k, j-1)+&
7691 &            xkmhd(i, k-1, j)+xkmhd(i, k-1, j-1))*rdy
7692           CALL PUSHREAL8(mkrdyp)
7693 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*   &
7694           mkrdyp = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.25*(mu(i, j+1)+mu(i&
7695 &            , j)+mu(i, j+1)+mu(i, j))*0.25*(xkmhd(i, k, j+1)+xkmhd(i, k&
7696 &            , j)+xkmhd(i, k-1, j+1)+xkmhd(i, k-1, j))*rdy
7697         END DO
7698       END DO
7699     END DO
7700     DO j=j_end,j_start,-1
7701       DO k=ktf,kts+1,-1
7702         DO i=i_end,i_start,-1
7703           mrdx = msftx(i, j)*msfty(i, j)*rdx
7704           mrdy = msftx(i, j)*msfty(i, j)*rdy
7705           temp1b1 = mrdx*tendencyb(i, k, j)
7706           temp1b2 = mrdy*tendencyb(i, k, j)
7707           mkrdxpb = (field(i+1, k, j)-field(i, k, j))*temp1b1
7708           fieldb(i+1, k, j) = fieldb(i+1, k, j) + mkrdxp*temp1b1
7709           fieldb(i, k, j) = fieldb(i, k, j) + (-mkrdym-mkrdyp)*temp1b2 +&
7710 &            (-mkrdxm-mkrdxp)*temp1b1
7711           mkrdxmb = -((field(i, k, j)-field(i-1, k, j))*temp1b1)
7712           fieldb(i-1, k, j) = fieldb(i-1, k, j) + mkrdxm*temp1b1
7713           mkrdypb = (field(i, k, j+1)-field(i, k, j))*temp1b2
7714           fieldb(i, k, j+1) = fieldb(i, k, j+1) + mkrdyp*temp1b2
7715           mkrdymb = -((field(i, k, j)-field(i, k, j-1))*temp1b2)
7716           fieldb(i, k, j-1) = fieldb(i, k, j-1) + mkrdym*temp1b2
7717           CALL POPREAL8(mkrdyp)
7718           temp1b3 = msfvy(i, j+1)*msfvx_inv(i, j+1)*rdy*0.25**2*mkrdypb
7719           temp1b4 = (xkmhd(i, k, j+1)+xkmhd(i, k, j)+xkmhd(i, k-1, j+1)+&
7720 &            xkmhd(i, k-1, j))*temp1b3
7721           temp1b5 = (2*mu(i, j+1)+2*mu(i, j))*temp1b3
7722           mub(i, j+1) = mub(i, j+1) + 2*temp1b4
7723           xkmhdb(i, k, j+1) = xkmhdb(i, k, j+1) + temp1b5
7724           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b5
7725           xkmhdb(i, k-1, j+1) = xkmhdb(i, k-1, j+1) + temp1b5
7726           xkmhdb(i, k-1, j) = xkmhdb(i, k-1, j) + temp1b5
7727           CALL POPREAL8(mkrdym)
7728           temp1b7 = msfvy(i, j)*msfvx_inv(i, j)*rdy*0.25**2*mkrdymb
7729           temp1b6 = (xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i, k-1, j)+&
7730 &            xkmhd(i, k-1, j-1))*temp1b7
7731           mub(i, j) = mub(i, j) + 2*temp1b6 + 2*temp1b4
7732           temp1b8 = (2*mu(i, j)+2*mu(i, j-1))*temp1b7
7733           mub(i, j-1) = mub(i, j-1) + 2*temp1b6
7734           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b8
7735           xkmhdb(i, k, j-1) = xkmhdb(i, k, j-1) + temp1b8
7736           xkmhdb(i, k-1, j) = xkmhdb(i, k-1, j) + temp1b8
7737           xkmhdb(i, k-1, j-1) = xkmhdb(i, k-1, j-1) + temp1b8
7738           CALL POPREAL8(mkrdxp)
7739           temp1b9 = msfux(i+1, j)*rdx*0.25**2*mkrdxpb
7740           temp1b10 = (xkmhd(i+1, k, j)+xkmhd(i, k, j)+xkmhd(i+1, k-1, j)&
7741 &            +xkmhd(i, k-1, j))*temp1b9/msfuy(i+1, j)
7742           temp1b11 = (2*mu(i+1, j)+2*mu(i, j))*temp1b9/msfuy(i+1, j)
7743           mub(i+1, j) = mub(i+1, j) + 2*temp1b10
7744           xkmhdb(i+1, k, j) = xkmhdb(i+1, k, j) + temp1b11
7745           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b11
7746           xkmhdb(i+1, k-1, j) = xkmhdb(i+1, k-1, j) + temp1b11
7747           xkmhdb(i, k-1, j) = xkmhdb(i, k-1, j) + temp1b11
7748           CALL POPREAL8(mkrdxm)
7749           temp1b13 = msfux(i, j)*rdx*0.25**2*mkrdxmb
7750           temp1b12 = (xkmhd(i, k, j)+xkmhd(i-1, k, j)+xkmhd(i, k-1, j)+&
7751 &            xkmhd(i-1, k-1, j))*temp1b13/msfuy(i, j)
7752           mub(i, j) = mub(i, j) + 2*temp1b12 + 2*temp1b10
7753           temp1b14 = (2*mu(i, j)+2*mu(i-1, j))*temp1b13/msfuy(i, j)
7754           mub(i-1, j) = mub(i-1, j) + 2*temp1b12
7755           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b14
7756           xkmhdb(i-1, k, j) = xkmhdb(i-1, k, j) + temp1b14
7757           xkmhdb(i, k-1, j) = xkmhdb(i, k-1, j) + temp1b14
7758           xkmhdb(i-1, k-1, j) = xkmhdb(i-1, k-1, j) + temp1b14
7759         END DO
7760       END DO
7761     END DO
7762   ELSE
7763     i_start = its
7764     IF (ite .GT. ide - 1) THEN
7765       i_end = ide - 1
7766     ELSE
7767       i_end = ite
7768     END IF
7769     j_start = jts
7770     IF (jte .GT. jde - 1) THEN
7771       j_end = jde - 1
7772     ELSE
7773       j_end = jte
7774     END IF
7775     IF (config_flags%open_xs .OR. specified) THEN
7776       IF (ids + 1 .LT. its) THEN
7777         i_start = its
7778       ELSE
7779         i_start = ids + 1
7780       END IF
7781     END IF
7782     IF (config_flags%open_xe .OR. specified) THEN
7783       IF (ide - 2 .GT. ite) THEN
7784         i_end = ite
7785       ELSE
7786         i_end = ide - 2
7787       END IF
7788     END IF
7789     IF (config_flags%open_ys .OR. specified) THEN
7790       IF (jds + 1 .LT. jts) THEN
7791         j_start = jts
7792       ELSE
7793         j_start = jds + 1
7794       END IF
7795     END IF
7796     IF (config_flags%open_ye .OR. specified) THEN
7797       IF (jde - 2 .GT. jte) THEN
7798         j_end = jte
7799       ELSE
7800         j_end = jde - 2
7801       END IF
7802     END IF
7803     IF (config_flags%periodic_x) i_start = its
7804     IF (config_flags%periodic_x) THEN
7805       IF (ite .GT. ide - 1) THEN
7806         i_end = ide - 1
7807       ELSE
7808         i_end = ite
7809       END IF
7810     END IF
7811     DO j=j_start,j_end
7812       DO k=kts,ktf
7813         DO i=i_start,i_end
7814           CALL PUSHREAL8(mkrdxm)
7815           mkrdxm = msfux(i, j)/msfuy(i, j)*0.5*(xkmhd(i, k, j)+xkmhd(i-1&
7816 &            , k, j))*0.5*(mu(i, j)+mu(i-1, j))*rdx
7817           CALL PUSHREAL8(mkrdxp)
7818           mkrdxp = msfux(i+1, j)/msfuy(i+1, j)*0.5*(xkmhd(i+1, k, j)+&
7819 &            xkmhd(i, k, j))*0.5*(mu(i+1, j)+mu(i, j))*rdx
7820           CALL PUSHREAL8(mkrdym)
7821 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
7822           mkrdym = msfvy(i, j)*msfvx_inv(i, j)*0.5*(xkmhd(i, k, j)+xkmhd&
7823 &            (i, k, j-1))*0.5*(mu(i, j)+mu(i, j-1))*rdy
7824           CALL PUSHREAL8(mkrdyp)
7825 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
7826           mkrdyp = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.5*(xkmhd(i, k, j+1)&
7827 &            +xkmhd(i, k, j))*0.5*(mu(i, j+1)+mu(i, j))*rdy
7828         END DO
7829       END DO
7830     END DO
7831     DO j=j_end,j_start,-1
7832       DO k=ktf,kts,-1
7833         DO i=i_end,i_start,-1
7834           mrdx = msftx(i, j)*msfty(i, j)*rdx
7835           mrdy = msftx(i, j)*msfty(i, j)*rdy
7836           temp1b15 = mrdx*tendencyb(i, k, j)
7837           temp1b16 = mrdy*tendencyb(i, k, j)
7838           mkrdxpb = (field(i+1, k, j)-field(i, k, j))*temp1b15
7839           fieldb(i+1, k, j) = fieldb(i+1, k, j) + mkrdxp*temp1b15
7840           fieldb(i, k, j) = fieldb(i, k, j) + (-mkrdym-mkrdyp)*temp1b16 &
7841 &            + (-mkrdxm-mkrdxp)*temp1b15
7842           mkrdxmb = -((field(i, k, j)-field(i-1, k, j))*temp1b15)
7843           fieldb(i-1, k, j) = fieldb(i-1, k, j) + mkrdxm*temp1b15
7844           mkrdypb = (field(i, k, j+1)-field(i, k, j))*temp1b16
7845           fieldb(i, k, j+1) = fieldb(i, k, j+1) + mkrdyp*temp1b16
7846           mkrdymb = -((field(i, k, j)-field(i, k, j-1))*temp1b16)
7847           fieldb(i, k, j-1) = fieldb(i, k, j-1) + mkrdym*temp1b16
7848           CALL POPREAL8(mkrdyp)
7849           temp1b17 = msfvy(i, j+1)*msfvx_inv(i, j+1)*rdy*0.5**2*mkrdypb
7850           temp1b18 = (mu(i, j+1)+mu(i, j))*temp1b17
7851           temp1b19 = (xkmhd(i, k, j+1)+xkmhd(i, k, j))*temp1b17
7852           xkmhdb(i, k, j+1) = xkmhdb(i, k, j+1) + temp1b18
7853           mub(i, j+1) = mub(i, j+1) + temp1b19
7854           CALL POPREAL8(mkrdym)
7855           temp1b22 = msfvy(i, j)*msfvx_inv(i, j)*rdy*0.5**2*mkrdymb
7856           temp1b20 = (mu(i, j)+mu(i, j-1))*temp1b22
7857           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b20 + temp1b18
7858           temp1b21 = (xkmhd(i, k, j)+xkmhd(i, k, j-1))*temp1b22
7859           mub(i, j) = mub(i, j) + temp1b21 + temp1b19
7860           xkmhdb(i, k, j-1) = xkmhdb(i, k, j-1) + temp1b20
7861           mub(i, j-1) = mub(i, j-1) + temp1b21
7862           CALL POPREAL8(mkrdxp)
7863           temp1b23 = msfux(i+1, j)*rdx*0.5**2*mkrdxpb
7864           temp1b24 = (mu(i+1, j)+mu(i, j))*temp1b23/msfuy(i+1, j)
7865           temp1b25 = (xkmhd(i+1, k, j)+xkmhd(i, k, j))*temp1b23/msfuy(i+&
7866 &            1, j)
7867           xkmhdb(i+1, k, j) = xkmhdb(i+1, k, j) + temp1b24
7868           mub(i+1, j) = mub(i+1, j) + temp1b25
7869           CALL POPREAL8(mkrdxm)
7870           temp1b28 = msfux(i, j)*rdx*0.5**2*mkrdxmb
7871           temp1b26 = (mu(i, j)+mu(i-1, j))*temp1b28/msfuy(i, j)
7872           xkmhdb(i, k, j) = xkmhdb(i, k, j) + temp1b26 + temp1b24
7873           temp1b27 = (xkmhd(i, k, j)+xkmhd(i-1, k, j))*temp1b28/msfuy(i&
7874 &            , j)
7875           mub(i, j) = mub(i, j) + temp1b27 + temp1b25
7876           xkmhdb(i-1, k, j) = xkmhdb(i-1, k, j) + temp1b26
7877           mub(i-1, j) = mub(i-1, j) + temp1b27
7878         END DO
7879       END DO
7880     END DO
7881   END IF
7882 END SUBROUTINE A_HORIZONTAL_DIFFUSION
7883
7884    SUBROUTINE a_horizontal_diffusion_3dmp(name,field,a_field,tendency,a_tendency, &
7885    mu,a_mu,config_flags,base_3d,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,khdif, &
7886    xkmhd,a_xkmhd,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
7887    jte,kts,kte)
7888
7889 !PART I: DECLARATION OF VARIABLES
7890
7891    IMPLICIT NONE
7892
7893    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
7894    TYPE(grid_config_rec_type) :: config_flags
7895    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
7896    CHARACTER (LEN=1) :: name
7897    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,xkmhd,a_xkmhd,base_3d
7898    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
7899    REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
7900    REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty
7901    REAL :: rdx,rdy,khdif
7902    INTEGER :: i,j,k,itf,jtf,ktf
7903    INTEGER :: i_start,i_end,j_start,j_end
7904 ! Revised by Ning Pan, 2010-07-23
7905 !   REAL :: mrdx,a_mrdx,mkrdxm,a_mkrdxm,mkrdxp,a_mkrdxp,mrdy,a_mrdy,mkrdym, &
7906    REAL :: mrdx,mkrdxm,a_mkrdxm,mkrdxp,a_mkrdxp,mrdy,mkrdym, &
7907    a_mkrdym,mkrdyp,a_mkrdyp
7908    LOGICAL :: specified
7909
7910    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
7911    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, &
7912    Tmpv009,a_Tmpv10,Tmpv010,a_Tmpv11,Tmpv011,a_Tmpv12,Tmpv012,a_Tmpv13,Tmpv013, &
7913    a_Tmpv14,Tmpv014,a_Tmpv15,Tmpv015,a_Tmpv16,Tmpv016,a_Tmpv17,Tmpv017, &
7914    a_Tmpv18,Tmpv018,a_Tmpv19,Tmpv019,a_Tmpv20,Tmpv020,a_Tmpv21,Tmpv021,a_Tmpv22,Tmpv022
7915    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv300
7916    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv301
7917    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv302
7918    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv303
7919    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv304
7920    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv305
7921    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv306
7922    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv307
7923    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv308
7924    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv309
7925    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3010
7926    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3011
7927    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3012
7928    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3013
7929    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3014
7930    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3015
7931    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3016
7932    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3017
7933    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3018
7934    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv3019
7935
7936 !PART II: CALCULATIONS OF B. S. TRAJECTORY
7937
7938 !LPB[0]
7939
7940       specified = .false.
7941
7942 !LPB[1]
7943    if(config_flags%specified .or. config_flags%nested) specified = .true.
7944
7945 !LPB[2]
7946       ktf=MIN(kte,kde-1)
7947          i_start = its
7948          i_end   = MIN(ite,ide-1)
7949          j_start = jts
7950          j_end   = MIN(jte,jde-1)
7951
7952 !LPB[3]
7953       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
7954
7955 !LPB[4]
7956
7957 !LPB[5]
7958       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
7959
7960 !LPB[6]
7961
7962 !LPB[7]
7963       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
7964
7965 !LPB[8]
7966
7967 !LPB[9]
7968       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
7969
7970 !LPB[10]
7971
7972 !LPB[11]
7973       IF ( config_flags%periodic_x ) i_start = its
7974
7975 !LPB[12]
7976
7977 !LPB[13]
7978       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
7979
7980 !!LPB[14]
7981 !         DO j = j_start, j_end
7982
7983 !         DO k=kts,ktf
7984 !         DO i = i_start, i_end
7985 !            mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j)) &
7986 !   *0.5*(mu(i,j)+mu(i-1,j))*rdx
7987 !            mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j)) &
7988 !   *0.5*(mu(i+1,j)+mu(i,j))*rdx
7989 !            mrdx=msftx(i,j)*msfty(i,j)*rdx
7990 !            mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1)) &
7991 !   *0.5*(mu(i,j)+mu(i,j-1))*rdy
7992 !            mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j)) &
7993 !   *0.5*(mu(i,j+1)+mu(i,j))*rdy
7994 !            mrdy=msftx(i,j)*msfty(i,j)*rdy
7995 !               tendency(i,k,j)=tendency(i,k,j)+(                          &
7996 !                       mrdx*( mkrdxp*(   field(i+1,k,j)  -field(i  ,k,j)        &
7997 !                                      -base_3d(i+1,k,j)+base_3d(i  ,k,j) )      &
7998 !                             -mkrdxm*(   field(i  ,k,j)  -field(i-1,k,j)        &
7999 !                                      -base_3d(i  ,k,j)+base_3d(i-1,k,j) )  )   &
8000 !                      +mrdy*( mkrdyp*(   field(i,k,j+1)  -field(i,k,j  )        &
8001 !                                      -base_3d(i,k,j+1)+base_3d(i,k,j  ) )      &
8002 !                             -mkrdym*(   field(i,k,j  )  -field(i,k,j-1)        &
8003 !                                      -base_3d(i,k,j  )+base_3d(i,k,j-1) )  )   &
8004 !                                                                            )
8005 !         ENDDO
8006 !         ENDDO
8007
8008 !         ENDDO
8009
8010 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
8011
8012 !   a_mrdx =0.0  ! Remarked by Ning Pan, 2010-07-23
8013    a_mkrdxm =0.0
8014    a_mkrdxp =0.0
8015 !   a_mrdy =0.0  ! Remarked by Ning Pan, 2010-07-23
8016    a_mkrdym =0.0
8017    a_mkrdyp =0.0
8018
8019 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
8020
8021 !LPB[14]
8022    DO j =j_end, j_start, -1
8023
8024    DO k =kts, ktf
8025    DO i =i_start, i_end
8026    Tmpv001 =xkmhd(i,k,j) +xkmhd(i-1,k,j)
8027    Tmpv002 =(msfux(i,j)/msfuy(i,j))*0.5*Tmpv001
8028    Tmpv003 =Tmpv002*0.5
8029    Tmpv004 =mu(i,j) +mu(i-1,j)
8030    Tmpv300(i,k) =Tmpv003
8031    Tmpv301(i,k) =Tmpv004
8032    Tmpv005 =Tmpv300(i,k)*Tmpv301(i,k)
8033    Tmpv006 =Tmpv005*rdx
8034 ! Revised by Ning Pan, 2010-07-23
8035 !   Tmpv302(i,k) =mkrdxm
8036 !   mkrdxm =Tmpv006
8037    mkrdxm =Tmpv006
8038    Tmpv302(i,k) =mkrdxm
8039
8040    Tmpv001 =xkmhd(i+1,k,j) +xkmhd(i,k,j)
8041    Tmpv002 =(msfux(i+1,j)/msfuy(i+1,j))*0.5*Tmpv001
8042    Tmpv003 =Tmpv002*0.5
8043    Tmpv004 =mu(i+1,j) +mu(i,j)
8044    Tmpv303(i,k) =Tmpv003
8045    Tmpv304(i,k) =Tmpv004
8046    Tmpv005 =Tmpv303(i,k)*Tmpv304(i,k)
8047    Tmpv006 =Tmpv005*rdx
8048 ! Revised by Ning Pan, 2010-07-23
8049 !   Tmpv305(i,k) =mkrdxp
8050 !   mkrdxp =Tmpv006
8051    mkrdxp =Tmpv006
8052    Tmpv305(i,k) =mkrdxp
8053
8054 ! Revised by Ning Pan, 2010-07-23
8055 !   Tmpv306(i,k) =mrdx
8056 !   mrdx =msftx(i,j)*msfty(i,j)*rdx
8057    mrdx =msftx(i,j)*msfty(i,j)*rdx
8058    Tmpv306(i,k) =mrdx
8059
8060    Tmpv001 =xkmhd(i,k,j) +xkmhd(i,k,j-1)
8061    Tmpv002 =(msfvy(i,j)*msfvx_inv(i,j))*0.5*Tmpv001
8062    Tmpv003 =Tmpv002*0.5
8063    Tmpv004 =mu(i,j) +mu(i,j-1)
8064    Tmpv307(i,k) =Tmpv003
8065    Tmpv308(i,k) =Tmpv004
8066    Tmpv005 =Tmpv307(i,k)*Tmpv308(i,k)
8067    Tmpv006 =Tmpv005*rdy
8068 ! Revised by Ning Pan, 2010-07-23
8069 !   Tmpv309(i,k) =mkrdym
8070 !   mkrdym =Tmpv006
8071    mkrdym =Tmpv006
8072    Tmpv309(i,k) =mkrdym
8073
8074    Tmpv001 =xkmhd(i,k,j+1) +xkmhd(i,k,j)
8075    Tmpv002 =(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*Tmpv001
8076    Tmpv003 =Tmpv002*0.5
8077    Tmpv004 =mu(i,j+1) +mu(i,j)
8078    Tmpv3010(i,k) =Tmpv003
8079    Tmpv3011(i,k) =Tmpv004
8080    Tmpv005 =Tmpv3010(i,k)*Tmpv3011(i,k)
8081    Tmpv006 =Tmpv005*rdy
8082 ! Revised by Ning Pan, 2010-07-23
8083 !   Tmpv3012(i,k) =mkrdyp
8084 !   mkrdyp =Tmpv006
8085    mkrdyp =Tmpv006
8086    Tmpv3012(i,k) =mkrdyp
8087
8088 ! Revised by Ning Pan, 2010-07-23
8089 !   Tmpv3013(i,k) =mrdy
8090 !   mrdy =msftx(i,j)*msfty(i,j)*rdy
8091    mrdy =msftx(i,j)*msfty(i,j)*rdy
8092    Tmpv3013(i,k) =mrdy
8093
8094    Tmpv001 =field(i+1,k,j) -field(i,k,j)
8095    Tmpv002 =Tmpv001 -base_3d(i+1,k,j)
8096    Tmpv003 =Tmpv002 +base_3d(i,k,j)
8097    Tmpv3014(i,k) =Tmpv003
8098    Tmpv004 =mkrdxp*Tmpv3014(i,k)
8099    Tmpv005 =field(i,k,j) -field(i-1,k,j)
8100    Tmpv006 =Tmpv005 -base_3d(i,k,j)
8101    Tmpv007 =Tmpv006 +base_3d(i-1,k,j)
8102    Tmpv3015(i,k) =Tmpv007
8103    Tmpv008 =mkrdxm*Tmpv3015(i,k)
8104    Tmpv009 =Tmpv004 -Tmpv008
8105    Tmpv3016(i,k) =Tmpv009
8106    Tmpv010 =mrdx*Tmpv3016(i,k)
8107    Tmpv011 =field(i,k,j+1) -field(i,k,j)
8108    Tmpv012 =Tmpv011 -base_3d(i,k,j+1)
8109    Tmpv013 =Tmpv012 +base_3d(i,k,j)
8110    Tmpv3017(i,k) =Tmpv013
8111    Tmpv014 =mkrdyp*Tmpv3017(i,k)
8112    Tmpv015 =field(i,k,j) -field(i,k,j-1)
8113    Tmpv016 =Tmpv015 -base_3d(i,k,j)
8114    Tmpv017 =Tmpv016 +base_3d(i,k,j-1)
8115    Tmpv3018(i,k) =Tmpv017
8116    Tmpv018 =mkrdym*Tmpv3018(i,k)
8117    Tmpv019 =Tmpv014 -Tmpv018
8118    Tmpv3019(i,k) =Tmpv019
8119 ! Remarked by Ning Pan, 2010-07-23
8120 !   Tmpv020 =mrdy*Tmpv3019(i,k)
8121 !   Tmpv021 =Tmpv010 +Tmpv020
8122 !   Tmpv022 =tendency(i,k,j) +Tmpv021
8123 !!  tendency(i,k,j) =Tmpv022
8124
8125    ENDDO
8126    ENDDO
8127
8128    DO k =ktf, kts, -1
8129    DO i =i_end, i_start, -1
8130 ! Added by Ning Pan, 2010-07-23
8131    mkrdxm = Tmpv302(i,k)
8132    mkrdxp = Tmpv305(i,k)
8133    mrdx = Tmpv306(i,k)
8134    mkrdym = Tmpv309(i,k)
8135    mkrdyp = Tmpv3012(i,k)
8136    mrdy = Tmpv3013(i,k)
8137
8138    a_Tmpv22 =a_tendency(i,k,j)
8139    a_tendency(i,k,j) =0.0
8140    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv22
8141    a_Tmpv21 =a_Tmpv22
8142    a_Tmpv10 =a_Tmpv21
8143    a_Tmpv20 =a_Tmpv21
8144 !   a_mrdy =a_mrdy +Tmpv3019(i,k)*a_Tmpv20  ! Remarked by Ning Pan, 2010-07-23
8145    a_Tmpv19 =mrdy*a_Tmpv20
8146    a_Tmpv14 =a_Tmpv19
8147    a_Tmpv18 =-a_Tmpv19
8148    a_mkrdym =a_mkrdym +Tmpv3018(i,k)*a_Tmpv18
8149    a_Tmpv17 =mkrdym*a_Tmpv18
8150    a_Tmpv16 =a_Tmpv17
8151    a_Tmpv15 =a_Tmpv16
8152    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv15
8153    a_field(i,k,j-1) =a_field(i,k,j-1) -a_Tmpv15
8154    a_mkrdyp =a_mkrdyp +Tmpv3017(i,k)*a_Tmpv14
8155    a_Tmpv13 =mkrdyp*a_Tmpv14
8156    a_Tmpv12 =a_Tmpv13
8157    a_Tmpv11 =a_Tmpv12
8158    a_field(i,k,j+1) =a_field(i,k,j+1) +a_Tmpv11
8159    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv11
8160 !   a_mrdx =a_mrdx +Tmpv3016(i,k)*a_Tmpv10  ! Remarked by Ning Pan, 2010-07-23
8161    a_Tmpv9 =mrdx*a_Tmpv10
8162    a_Tmpv4 =a_Tmpv9
8163    a_Tmpv8 =-a_Tmpv9
8164    a_mkrdxm =a_mkrdxm +Tmpv3015(i,k)*a_Tmpv8
8165    a_Tmpv7 =mkrdxm*a_Tmpv8
8166    a_Tmpv6 =a_Tmpv7
8167    a_Tmpv5 =a_Tmpv6
8168    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv5
8169    a_field(i-1,k,j) =a_field(i-1,k,j) -a_Tmpv5
8170    a_mkrdxp =a_mkrdxp +Tmpv3014(i,k)*a_Tmpv4
8171    a_Tmpv3 =mkrdxp*a_Tmpv4
8172    a_Tmpv2 =a_Tmpv3
8173    a_Tmpv1 =a_Tmpv2
8174    a_field(i+1,k,j) =a_field(i+1,k,j) +a_Tmpv1
8175    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv1
8176
8177 !   mrdy =Tmpv3013(i,k)  ! Remarked by Ning Pan, 2010-07-23
8178
8179 !   a_mrdy =0.0  ! Remarked by Ning Pan, 2010-07-23
8180
8181 !   mkrdyp =Tmpv3012(i,k)  ! Remarked by Ning Pan, 2010-07-23
8182
8183    a_Tmpv6 =a_mkrdyp
8184    a_mkrdyp =0.0
8185    a_Tmpv5 =rdy*a_Tmpv6
8186    a_Tmpv3 =Tmpv3011(i,k)*a_Tmpv5
8187    a_Tmpv4 =Tmpv3010(i,k)*a_Tmpv5
8188    a_mu(i,j+1) =a_mu(i,j+1) +a_Tmpv4
8189    a_mu(i,j) =a_mu(i,j) +a_Tmpv4
8190    a_Tmpv2 =0.5*a_Tmpv3
8191    a_Tmpv1 =(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*a_Tmpv2
8192    a_xkmhd(i,k,j+1) =a_xkmhd(i,k,j+1) +a_Tmpv1
8193    a_xkmhd(i,k,j) =a_xkmhd(i,k,j) +a_Tmpv1
8194
8195 !   mkrdym =Tmpv309(i,k)  ! Remarked by Ning Pan, 2010-07-23
8196
8197    a_Tmpv6 =a_mkrdym
8198    a_mkrdym =0.0
8199    a_Tmpv5 =rdy*a_Tmpv6
8200    a_Tmpv3 =Tmpv308(i,k)*a_Tmpv5
8201    a_Tmpv4 =Tmpv307(i,k)*a_Tmpv5
8202    a_mu(i,j) =a_mu(i,j) +a_Tmpv4
8203    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv4
8204    a_Tmpv2 =0.5*a_Tmpv3
8205    a_Tmpv1 =(msfvy(i,j)*msfvx_inv(i,j))*0.5*a_Tmpv2
8206    a_xkmhd(i,k,j) =a_xkmhd(i,k,j) +a_Tmpv1
8207    a_xkmhd(i,k,j-1) =a_xkmhd(i,k,j-1) +a_Tmpv1
8208
8209 !   mrdx =Tmpv306(i,k)  ! Remarked by Ning Pan, 2010-07-23
8210
8211 !   a_mrdx =0.0  ! Remarked by Ning Pan, 2010-07-23
8212
8213 !   mkrdxp =Tmpv305(i,k)  ! Remarked by Ning Pan, 2010-07-23
8214
8215    a_Tmpv6 =a_mkrdxp
8216    a_mkrdxp =0.0
8217    a_Tmpv5 =rdx*a_Tmpv6
8218    a_Tmpv3 =Tmpv304(i,k)*a_Tmpv5
8219    a_Tmpv4 =Tmpv303(i,k)*a_Tmpv5
8220    a_mu(i+1,j) =a_mu(i+1,j) +a_Tmpv4
8221    a_mu(i,j) =a_mu(i,j) +a_Tmpv4
8222    a_Tmpv2 =0.5*a_Tmpv3
8223    a_Tmpv1 =(msfux(i+1,j)/msfuy(i+1,j))*0.5*a_Tmpv2
8224    a_xkmhd(i+1,k,j) =a_xkmhd(i+1,k,j) +a_Tmpv1
8225    a_xkmhd(i,k,j) =a_xkmhd(i,k,j) +a_Tmpv1
8226
8227 !   mkrdxm =Tmpv302(i,k)  ! Remarked by Ning Pan, 2010-07-23
8228
8229    a_Tmpv6 =a_mkrdxm
8230    a_mkrdxm =0.0
8231    a_Tmpv5 =rdx*a_Tmpv6
8232    a_Tmpv3 =Tmpv301(i,k)*a_Tmpv5
8233    a_Tmpv4 =Tmpv300(i,k)*a_Tmpv5
8234    a_mu(i,j) =a_mu(i,j) +a_Tmpv4
8235    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv4
8236    a_Tmpv2 =0.5*a_Tmpv3
8237    a_Tmpv1 =(msfux(i,j)/msfuy(i,j))*0.5*a_Tmpv2
8238    a_xkmhd(i,k,j) =a_xkmhd(i,k,j) +a_Tmpv1
8239    a_xkmhd(i-1,k,j) =a_xkmhd(i-1,k,j) +a_Tmpv1
8240    ENDDO
8241    ENDDO
8242
8243    ENDDO
8244
8245 !LPB[13]
8246
8247 !  IF( config_flags%periodic_x ) THEN
8248 !  i_end =min(ite, ide-1)
8249 !  END IF
8250
8251 !  IF( config_flags%periodic_x ) THEN
8252
8253 !  END IF
8254
8255 !LPB[12]
8256
8257 !LPB[11]
8258
8259 !  IF( config_flags%periodic_x ) THEN
8260 !  i_start =its
8261 !  END IF
8262
8263 !  IF( config_flags%periodic_x ) THEN
8264
8265 !  END IF
8266
8267 !LPB[10]
8268
8269 !LPB[9]
8270
8271 !  IF( config_flags%open_ye .or. specified ) THEN
8272 !  j_end =min(jde-2, jte)
8273 !  END IF
8274
8275 !  IF( config_flags%open_ye .or. specified ) THEN
8276
8277 !  END IF
8278
8279 !LPB[8]
8280
8281 !LPB[7]
8282
8283 !  IF( config_flags%open_ys .or. specified ) THEN
8284 !  j_start =max(jds+1, jts)
8285 !  END IF
8286
8287 !  IF( config_flags%open_ys .or. specified ) THEN
8288
8289 !  END IF
8290
8291 !LPB[6]
8292
8293 !LPB[5]
8294
8295 !  IF( config_flags%open_xe .or. specified ) THEN
8296 !  i_end =min(ide-2, ite)
8297 !  END IF
8298
8299 !  IF( config_flags%open_xe .or. specified ) THEN
8300
8301 !  END IF
8302
8303 !LPB[4]
8304
8305 !LPB[3]
8306
8307 !  IF( config_flags%open_xs .or. specified ) THEN
8308 !  i_start =max(ids+1, its)
8309 !  END IF
8310
8311 !  IF( config_flags%open_xs .or. specified ) THEN
8312
8313 !  END IF
8314
8315 !LPB[2]
8316 !  ktf =min(kte, kde-1)
8317 !  i_start =its
8318 !  i_end =min(ite, ide-1)
8319 !  j_start =jts
8320 !  j_end =min(jte, jde-1)
8321
8322 !LPB[1]
8323
8324 !  IF(config_flags%specified .or. config_flags%nested) THEN
8325 !  specified =.true.
8326 !  END IF
8327
8328 !  IF(config_flags%specified .or. config_flags%nested) THEN
8329
8330 !  END IF
8331
8332 !LPB[0]
8333 !  specified =.false.
8334
8335    END SUBROUTINE a_horizontal_diffusion_3dmp
8336
8337    SUBROUTINE a_vertical_diffusion(name,field,a_field,tendency,a_tendency, &
8338    config_flags,alt,a_alt,mut,a_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims,ime, &
8339    jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
8340
8341 !PART I: DECLARATION OF VARIABLES
8342
8343    IMPLICIT NONE
8344
8345    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
8346    TYPE(grid_config_rec_type) :: config_flags
8347    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
8348    CHARACTER (LEN=1) :: name
8349    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,alt,a_alt
8350    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
8351    REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut
8352    REAL,DIMENSION(kms:kme) :: rdn,rdnw
8353    REAL :: kvdif
8354    INTEGER :: i,j,k,itf,jtf,ktf
8355    INTEGER :: i_start,i_end,j_start,j_end
8356 !   REAL,DIMENSION(its:ite,jts:jte) :: vfluxm,a_vfluxm,vfluxp,a_vfluxp,zz,a_zz  ! Remarked by Ning Pan, 2010-07-23
8357    REAL,DIMENSION(its:ite,0:kte+1) :: vflux,a_vflux
8358 !   REAL :: rdz,a_rdz  ! Remarked by Ning Pan, 2010-07-23
8359    LOGICAL :: specified
8360
8361    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
8362    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006
8363    REAL,DIMENSION(its:MAX(ite,ide-1),kts:MAX(kte,kde-1)-1,jts:MAX(jte,jde-1)) :: Tmpv400
8364    REAL,DIMENSION(its:MAX(ite,ide-1),kts+1:MAX(kte,kde-1),jts:MAX(jte,jde-1)) :: Tmpv401
8365    REAL,DIMENSION(its:MAX(ite,ide-1),kts+1:MAX(kte,kde-1),jts:MAX(jte,jde-1)) :: Tmpv402
8366    REAL,DIMENSION(its:MAX(ite,ide-1),kts+1:MAX(kte,kde-1),jts:MAX(jte,jde-1)) :: Tmpv403
8367    REAL,DIMENSION(its:MAX(ite,ide-1),kts:MAX(kte,kde-1)-1,jts:MAX(jte,jde-1)) :: Tmpv404
8368    REAL,DIMENSION(its:MAX(ite,ide-1),kts:MAX(kte,kde-1)-1,jts:MAX(jte,jde-1)) :: Tmpv405
8369    REAL,DIMENSION(its:MAX(ite,ide-1),kts:MAX(kte,kde-1),jts:MAX(jte,jde-1)) :: Tmpv406
8370    REAL,DIMENSION(its:MAX(ite,ide-1),kts:MAX(kte,kde-1),jts:MAX(jte,jde-1)) :: Tmpv407
8371    REAL,DIMENSION(its:MAX(ite,ide-1),kts:MAX(kte,kde-1),jts:MAX(jte,jde-1)) :: Tmpv408
8372
8373 !PART II: CALCULATIONS OF B. S. TRAJECTORY
8374
8375 !LPB[0]
8376       specified = .false.
8377
8378 !LPB[1]
8379    if(config_flags%specified .or. config_flags%nested) specified = .true.
8380
8381 !LPB[2]
8382       ktf=MIN(kte,kde-1)
8383
8384 !!LPB[3]
8385 !   IF (name .EQ. 'w')THEN
8386
8387 !      i_start = its
8388 !      i_end   = MIN(ite,ide-1)
8389 !      j_start = jts
8390 !      j_end   = MIN(jte,jde-1)
8391
8392 !   j_loop_w : DO j = j_start, j_end
8393 !        DO k=kts,ktf-1
8394 !          DO i = i_start, i_end
8395 !             vflux(i,k)= (kvdif/alt(i,k,j))*rdnw(k)*(field(i,k+1,j)-field(i,k,j))
8396 !          ENDDO
8397 !        ENDDO
8398
8399 !        DO i = i_start, i_end
8400 !          vflux(i,ktf)=0.
8401 !        ENDDO
8402
8403 !        DO k=kts+1,ktf
8404 !          DO i = i_start, i_end
8405 !               tendency(i,k,j)=tendency(i,k,j)                                           &
8406 !                                 +rdn(k)*g*g/mut(i,j)/(0.5*(alt(i,k,j)+alt(i,k-1,j))) &
8407 !       &
8408 !                                            *(vflux(i,k)-vflux(i,k-1))
8409 !          ENDDO
8410 !        ENDDO
8411 !       ENDDO j_loop_w
8412 !      ELSE IF(name .EQ. 'm')THEN
8413 !        i_start = its
8414 !        i_end   = MIN(ite,ide-1)
8415 !        j_start = jts
8416 !        j_end   = MIN(jte,jde-1)
8417
8418 !   j_loop_s : DO j = j_start, j_end
8419 !        DO k=kts,ktf-1
8420 !          DO i = i_start, i_end
8421 !            vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j)))     &
8422 !                     *(field(i,k+1,j)-field(i,k,j))
8423 !          ENDDO
8424 !        ENDDO
8425
8426 !        DO i = i_start, i_end
8427 !          vflux(i,0)=vflux(i,1)
8428 !        ENDDO
8429
8430 !        DO i = i_start, i_end
8431 !          vflux(i,ktf)=0.
8432 !        ENDDO
8433
8434 !        DO k=kts,ktf
8435 !          DO i = i_start, i_end
8436 !            tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j)    &
8437 !                   *rdnw(k)*(vflux(i,k)-vflux(i,k-1))
8438 !          ENDDO
8439 !        ENDDO
8440 !    ENDDO j_loop_s
8441
8442 !   ENDIF
8443
8444 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
8445
8446 ! Remarked by Ning Pan, 2010-07-23
8447 !   Do K1_ADJ =jts, jte
8448 !   Do K0_ADJ =its, ite
8449 !   a_vfluxm(K0_ADJ,K1_ADJ) =0.0
8450 !   End Do
8451 !   End Do
8452
8453 !   Do K1_ADJ =jts, jte
8454 !   Do K0_ADJ =its, ite
8455 !   a_vfluxp(K0_ADJ,K1_ADJ) =0.0
8456 !   End Do
8457 !   End Do
8458
8459 !   Do K1_ADJ =jts, jte
8460 !   Do K0_ADJ =its, ite
8461 !   a_zz(K0_ADJ,K1_ADJ) =0.0
8462 !   End Do
8463 !   End Do
8464
8465    Do K1_ADJ =0, kte+1
8466    Do K0_ADJ =its, ite
8467    a_vflux(K0_ADJ,K1_ADJ) =0.0
8468    End Do
8469    End Do
8470
8471 !   a_rdz =0.0  ! Remarked by Ning Pan, 2010-07-23
8472
8473 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
8474
8475 !LPB[3]
8476
8477    IF(name .EQ. 'w') THEN
8478    i_start =its
8479    i_end =min(ite, ide-1)
8480    j_start =jts
8481    j_end =min(jte, jde-1)
8482    DO j =j_start, j_end
8483    DO k =kts, ktf-1
8484    DO i =i_start, i_end
8485    Tmpv001 =field(i,k+1,j) -field(i,k,j)
8486    Tmpv400(i,k,j) =Tmpv001
8487    Tmpv002 =(kvdif/alt(i,k,j))*rdnw(k)*Tmpv400(i,k,j)
8488    vflux(i,k) =Tmpv002
8489
8490    ENDDO
8491    ENDDO
8492
8493    DO i =i_start, i_end
8494    vflux(i,ktf) =0.
8495
8496    ENDDO
8497
8498    DO k =kts+1, ktf
8499    DO i =i_start, i_end
8500    Tmpv001 =alt(i,k,j) +alt(i,k-1,j)
8501    Tmpv002 =0.5*Tmpv001
8502    Tmpv401(i,k,j) =Tmpv002
8503    Tmpv003 =rdn(k)*g*g/mut(i,j)/Tmpv401(i,k,j)
8504    Tmpv004 =vflux(i,k) -vflux(i,k-1)
8505    Tmpv402(i,k,j) =Tmpv003
8506    Tmpv403(i,k,j) =Tmpv004
8507 ! Remarked by Ning Pan, 2010-07-23
8508 !   Tmpv005 =Tmpv402(i,k,j)*Tmpv403(i,k,j)
8509 !   Tmpv006 =tendency(i,k,j) +Tmpv005
8510 !!  tendency(i,k,j) =Tmpv006
8511
8512    ENDDO
8513    ENDDO
8514    ENDDO
8515    ELSE IF(name .EQ. 'm') THEN
8516    i_start =its
8517    i_end =min(ite, ide-1)
8518    j_start =jts
8519    j_end =min(jte, jde-1)
8520    DO j =j_start, j_end
8521    DO k =kts, ktf-1
8522    DO i =i_start, i_end
8523    Tmpv001 =alt(i,k,j) +alt(i,k+1,j)
8524    Tmpv002 =0.5*Tmpv001
8525    Tmpv408(i,k,j) =Tmpv002  ! Added by Ning Pan, 2010-07-23
8526    Tmpv003 =kvdif*rdn(k+1)/Tmpv002
8527    Tmpv004 =field(i,k+1,j) -field(i,k,j)
8528    Tmpv404(i,k,j) =Tmpv003
8529    Tmpv405(i,k,j) =Tmpv004
8530    Tmpv005 =Tmpv404(i,k,j)*Tmpv405(i,k,j)
8531    vflux(i,k) =Tmpv005
8532
8533    ENDDO
8534    ENDDO
8535
8536    DO i =i_start, i_end
8537    vflux(i,0) =vflux(i,1)
8538
8539    ENDDO
8540
8541    DO i =i_start, i_end
8542    vflux(i,ktf) =0.
8543
8544    ENDDO
8545
8546    DO k =kts, ktf
8547    DO i =i_start, i_end
8548    Tmpv001 =g*g/mut(i,j)/alt(i,k,j)
8549    Tmpv002 =Tmpv001*rdnw(k)
8550    Tmpv003 =vflux(i,k) -vflux(i,k-1)
8551    Tmpv406(i,k,j) =Tmpv002
8552    Tmpv407(i,k,j) =Tmpv003
8553 ! Remarked by Ning Pan, 2010-07-23
8554 !   Tmpv004 =Tmpv406(i,k,j)*Tmpv407(i,k,j)
8555 !   Tmpv005 =tendency(i,k,j) +Tmpv004
8556 !!  tendency(i,k,j) =Tmpv005
8557
8558    ENDDO
8559    ENDDO
8560    ENDDO
8561    ENDIF
8562
8563    IF(name .EQ. 'w') THEN
8564
8565    DO j =j_end, j_start, -1
8566    DO k =ktf, kts+1, -1
8567    DO i =i_end, i_start, -1
8568    a_Tmpv6 =a_tendency(i,k,j)
8569    a_tendency(i,k,j) =0.0
8570    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv6
8571    a_Tmpv5 =a_Tmpv6
8572    a_Tmpv3 =Tmpv403(i,k,j)*a_Tmpv5
8573    a_Tmpv4 =Tmpv402(i,k,j)*a_Tmpv5
8574    a_vflux(i,k) =a_vflux(i,k) +a_Tmpv4
8575    a_vflux(i,k-1) =a_vflux(i,k-1) -a_Tmpv4
8576    a_mut(i,j) =a_mut(i,j) -rdn(k)*g*g/(mut(i,j)*mut(i,j))/Tmpv401(i,k,j)*a_Tmpv3
8577    a_Tmpv2 =-rdn(k)*g*g/mut(i,j)/(Tmpv401(i,k,j)*Tmpv401(i,k,j))*a_Tmpv3
8578    a_Tmpv1 =0.5*a_Tmpv2
8579    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
8580    a_alt(i,k-1,j) =a_alt(i,k-1,j) +a_Tmpv1
8581    ENDDO
8582    ENDDO
8583    DO i =i_end, i_start, -1
8584    a_vflux(i,ktf) =0.0
8585    ENDDO
8586    DO k =ktf-1, kts, -1
8587    DO i =i_end, i_start, -1
8588    a_Tmpv2 =a_vflux(i,k)
8589    a_vflux(i,k) =0.0
8590    a_alt(i,k,j) =a_alt(i,k,j) -kvdif/(alt(i,k,j)*alt(i,k,j))*rdnw(k)  &
8591    *Tmpv400(i,k,j)*a_Tmpv2
8592    a_Tmpv1 =(kvdif/alt(i,k,j))*rdnw(k)*a_Tmpv2
8593    a_field(i,k+1,j) =a_field(i,k+1,j) +a_Tmpv1
8594    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv1
8595    ENDDO
8596    ENDDO
8597    ENDDO
8598
8599    ELSE IF(name .EQ. 'm') THEN
8600
8601    DO j =j_end, j_start, -1
8602    DO k =ktf, kts, -1
8603    DO i =i_end, i_start, -1
8604    a_Tmpv5 =a_tendency(i,k,j)
8605    a_tendency(i,k,j) =0.0
8606    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv5
8607    a_Tmpv4 =a_Tmpv5
8608    a_Tmpv2 =Tmpv407(i,k,j)*a_Tmpv4
8609    a_Tmpv3 =Tmpv406(i,k,j)*a_Tmpv4
8610    a_vflux(i,k) =a_vflux(i,k) +a_Tmpv3
8611    a_vflux(i,k-1) =a_vflux(i,k-1) -a_Tmpv3
8612    a_Tmpv1 =rdnw(k)*a_Tmpv2
8613    a_mut(i,j) =a_mut(i,j) -g*g/(mut(i,j)*mut(i,j))/alt(i,k,j)*a_Tmpv1
8614    a_alt(i,k,j) =a_alt(i,k,j) -g*g/mut(i,j)/(alt(i,k,j)*alt(i,k,j))*a_Tmpv1
8615    ENDDO
8616    ENDDO
8617    DO i =i_end, i_start, -1
8618    a_vflux(i,ktf) =0.0
8619    ENDDO
8620    DO i =i_end, i_start, -1
8621    a_vflux(i,1) =a_vflux(i,1) +a_vflux(i,0)
8622    a_vflux(i,0) =0.0
8623    ENDDO
8624    DO k =ktf-1, kts, -1
8625    DO i =i_end, i_start, -1
8626    a_Tmpv5 =a_vflux(i,k)
8627    a_vflux(i,k) =0.0
8628    a_Tmpv3 =Tmpv405(i,k,j)*a_Tmpv5
8629    a_Tmpv4 =Tmpv404(i,k,j)*a_Tmpv5
8630    a_field(i,k+1,j) =a_field(i,k+1,j) +a_Tmpv4
8631    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv4
8632 ! Revised by Ning Pan, 2010-07-23
8633 !   a_Tmpv2 =-(kvdif*rdn(k+1))*a_Tmpv3/(Tmpv002*Tmpv002)
8634    a_Tmpv2 =-(kvdif*rdn(k+1))*a_Tmpv3/(Tmpv408(i,k,j)*Tmpv408(i,k,j))
8635    a_Tmpv1 =0.5*a_Tmpv2
8636    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
8637    a_alt(i,k+1,j) =a_alt(i,k+1,j) +a_Tmpv1
8638    ENDDO
8639    ENDDO
8640    ENDDO
8641
8642    ENDIF
8643
8644 !LPB[2]
8645 !  ktf =min(kte, kde-1)
8646
8647 !LPB[1]
8648
8649 !  IF(config_flags%specified .or. config_flags%nested) THEN
8650 !  specified =.true.
8651 !  END IF
8652
8653 !  IF(config_flags%specified .or. config_flags%nested) THEN
8654
8655 !  END IF
8656
8657 !LPB[0]
8658 !  specified =.false.
8659
8660    END SUBROUTINE a_vertical_diffusion
8661
8662    SUBROUTINE a_vertical_diffusion_mp(field,a_field,tendency,a_tendency, &
8663    config_flags,base,alt,a_alt,mut,a_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims, &
8664    ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
8665
8666 !PART I: DECLARATION OF VARIABLES
8667
8668    IMPLICIT NONE
8669
8670    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
8671    TYPE(grid_config_rec_type) :: config_flags
8672    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
8673    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,alt,a_alt
8674    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
8675    REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut
8676    REAL,DIMENSION(kms:kme) :: rdn,rdnw,base
8677    REAL :: kvdif
8678    INTEGER :: i,j,k,itf,jtf,ktf
8679    INTEGER :: i_start,i_end,j_start,j_end
8680    REAL,DIMENSION(its:ite,0:kte+1) :: vflux,a_vflux
8681 !   REAL :: rdz,a_rdz  ! Remarked by Ning Pan, 2010-07-25
8682    LOGICAL :: specified
8683
8684    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
8685    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007
8686    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv300
8687    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv301
8688    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv302
8689    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv303
8690    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv304  ! Added by Ning Pan, 2010-07-25
8691
8692 !PART II: CALCULATIONS OF B. S. TRAJECTORY
8693
8694 !LPB[0]
8695
8696       specified = .false.
8697
8698 !LPB[1]
8699    if(config_flags%specified .or. config_flags%nested) specified = .true.
8700
8701 !LPB[2]
8702       ktf=MIN(kte,kde-1)
8703         i_start = its
8704         i_end   = MIN(ite,ide-1)
8705         j_start = jts
8706         j_end   = MIN(jte,jde-1)
8707
8708 !!LPB[3]
8709 !   j_loop_s : DO j = j_start, j_end
8710
8711 !        DO k=kts,ktf-1
8712 !          DO i = i_start, i_end
8713 !            vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j)))     &
8714 !                       *(field(i,k+1,j)-field(i,k,j)-base(k+1)+base(k))
8715 !          ENDDO
8716 !        ENDDO
8717
8718 !        DO i = i_start, i_end
8719 !          vflux(i,0)=vflux(i,1)
8720 !        ENDDO
8721
8722 !        DO i = i_start, i_end
8723 !          vflux(i,ktf)=0.
8724 !        ENDDO
8725
8726 !        DO k=kts,ktf
8727 !          DO i = i_start, i_end
8728 !            tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j)    &
8729 !                   *rdnw(k)*(vflux(i,k)-vflux(i,k-1))
8730 !          ENDDO
8731 !        ENDDO
8732
8733 !    ENDDO j_loop_s
8734
8735 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
8736
8737    Do K1_ADJ =0, kte+1
8738    Do K0_ADJ =its, ite
8739    a_vflux(K0_ADJ,K1_ADJ) =0.0
8740    End Do
8741    End Do
8742
8743 !   a_rdz =0.0  ! Remarked by Ning Pan, 2010-07-25
8744
8745 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
8746
8747 !LPB[3]
8748    DO j =j_end, j_start, -1
8749
8750    DO k =kts, ktf-1
8751    DO i =i_start, i_end
8752    Tmpv001 =alt(i,k,j) +alt(i,k+1,j)
8753    Tmpv002 =0.5*Tmpv001
8754    Tmpv304(i,k) =Tmpv002  ! Added by Ning Pan, 2010-07-25
8755    Tmpv003 =kvdif*rdn(k+1)/Tmpv002
8756    Tmpv004 =field(i,k+1,j) -field(i,k,j)
8757    Tmpv005 =Tmpv004 -base(k+1)
8758    Tmpv006 =Tmpv005 +base(k)
8759    Tmpv300(i,k) =Tmpv003
8760    Tmpv301(i,k) =Tmpv006
8761    Tmpv007 =Tmpv300(i,k)*Tmpv301(i,k)
8762    vflux(i,k) =Tmpv007
8763
8764    ENDDO
8765    ENDDO
8766    DO i =i_start, i_end
8767    vflux(i,0) =vflux(i,1)
8768
8769    ENDDO
8770
8771    DO i =i_start, i_end
8772    vflux(i,ktf) =0.
8773
8774    ENDDO
8775
8776    DO k =kts, ktf
8777    DO i =i_start, i_end
8778    Tmpv001 =g*g/mut(i,j)/alt(i,k,j)
8779    Tmpv002 =Tmpv001*rdnw(k)
8780    Tmpv003 =vflux(i,k) -vflux(i,k-1)
8781    Tmpv302(i,k) =Tmpv002
8782    Tmpv303(i,k) =Tmpv003
8783 ! Remarked by Ning Pan, 2010-07-25
8784 !   Tmpv004 =Tmpv302(i,k)*Tmpv303(i,k)
8785 !   Tmpv005 =tendency(i,k,j) +Tmpv004
8786 !!  tendency(i,k,j) =Tmpv005
8787
8788    ENDDO
8789    ENDDO
8790
8791    DO k =ktf, kts, -1
8792    DO i =i_end, i_start, -1
8793    a_Tmpv5 =a_tendency(i,k,j)
8794    a_tendency(i,k,j) =0.0
8795    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv5
8796    a_Tmpv4 =a_Tmpv5
8797    a_Tmpv2 =Tmpv303(i,k)*a_Tmpv4
8798    a_Tmpv3 =Tmpv302(i,k)*a_Tmpv4
8799    a_vflux(i,k) =a_vflux(i,k) +a_Tmpv3
8800    a_vflux(i,k-1) =a_vflux(i,k-1) -a_Tmpv3
8801    a_Tmpv1 =rdnw(k)*a_Tmpv2
8802    a_mut(i,j) =a_mut(i,j) -g*g/(mut(i,j)*mut(i,j))/alt(i,k,j)*a_Tmpv1
8803    a_alt(i,k,j) =a_alt(i,k,j) -g*g/mut(i,j)/(alt(i,k,j)*alt(i,k,j))*a_Tmpv1
8804    ENDDO
8805    ENDDO
8806
8807    DO i =i_end, i_start, -1
8808    a_vflux(i,ktf) =0.0
8809    ENDDO
8810
8811    DO i =i_end, i_start, -1
8812    a_vflux(i,1) =a_vflux(i,1) +a_vflux(i,0)
8813    a_vflux(i,0) =0.0
8814    ENDDO
8815
8816    DO k =ktf-1, kts, -1
8817    DO i =i_end, i_start, -1
8818    a_Tmpv7 =a_vflux(i,k)
8819    a_vflux(i,k) =0.0
8820    a_Tmpv3 =Tmpv301(i,k)*a_Tmpv7
8821    a_Tmpv6 =Tmpv300(i,k)*a_Tmpv7
8822    a_Tmpv5 =a_Tmpv6
8823    a_Tmpv4 =a_Tmpv5
8824    a_field(i,k+1,j) =a_field(i,k+1,j) +a_Tmpv4
8825    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv4
8826 ! Revised by Ning Pan, 2010-07-25
8827 !   a_Tmpv2 =-(kvdif*rdn(k+1))*a_Tmpv3/(Tmpv002*Tmpv002)
8828    a_Tmpv2 =-(kvdif*rdn(k+1))*a_Tmpv3/(Tmpv304(i,k)*Tmpv304(i,k))
8829    a_Tmpv1 =0.5*a_Tmpv2
8830    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
8831    a_alt(i,k+1,j) =a_alt(i,k+1,j) +a_Tmpv1
8832    ENDDO
8833    ENDDO
8834
8835    ENDDO
8836
8837 !LPB[2]
8838 !  ktf =min(kte, kde-1)
8839 !  i_start =its
8840 !  i_end =min(ite, ide-1)
8841 !  j_start =jts
8842 !  j_end =min(jte, jde-1)
8843
8844 !LPB[1]
8845
8846 !  IF(config_flags%specified .or. config_flags%nested) THEN
8847 !  specified =.true.
8848 !  END IF
8849
8850 !  IF(config_flags%specified .or. config_flags%nested) THEN
8851
8852 !  END IF
8853
8854 !LPB[0]
8855 !  specified =.false.
8856
8857    END SUBROUTINE a_vertical_diffusion_mp
8858
8859    SUBROUTINE a_vertical_diffusion_3dmp(field,a_field,tendency,a_tendency, &
8860    config_flags,base_3d,alt,a_alt,mut,a_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde, &
8861    ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
8862
8863 !PART I: DECLARATION OF VARIABLES
8864
8865    IMPLICIT NONE
8866
8867    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
8868    TYPE(grid_config_rec_type) :: config_flags
8869    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
8870    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,alt,a_alt,base_3d
8871    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
8872    REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut
8873    REAL,DIMENSION(kms:kme) :: rdn,rdnw
8874    REAL :: kvdif
8875    INTEGER :: i,j,k,itf,jtf,ktf
8876    INTEGER :: i_start,i_end,j_start,j_end
8877    REAL,DIMENSION(its:ite,0:kte+1) :: vflux,a_vflux
8878 !   REAL :: rdz,a_rdz  ! Remarked by Ning Pan, 2010-07-23
8879    LOGICAL :: specified
8880
8881    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
8882    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007
8883    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv300
8884    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv301
8885    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv302
8886    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv303
8887    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv304  ! Added by Ning Pan, 2010-07-23
8888
8889 !PART II: CALCULATIONS OF B. S. TRAJECTORY
8890
8891 !LPB[0]
8892       specified = .false.
8893
8894 !LPB[1]
8895    if(config_flags%specified .or. config_flags%nested) specified = .true.
8896
8897 !LPB[2]
8898       ktf=MIN(kte,kde-1)
8899         i_start = its
8900         i_end   = MIN(ite,ide-1)
8901         j_start = jts
8902         j_end   = MIN(jte,jde-1)
8903
8904 !!LPB[3]
8905 !   j_loop_s : DO j = j_start, j_end
8906
8907 !        DO k=kts,ktf-1
8908 !          DO i = i_start, i_end
8909 !            vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j)))     &
8910 !                       *(   field(i,k+1,j)  -field(i,k,j)                 &
8911 !                         -base_3d(i,k+1,j)+base_3d(i,k,j) )
8912 !          ENDDO
8913 !        ENDDO
8914
8915 !        DO i = i_start, i_end
8916 !          vflux(i,0)=vflux(i,1)
8917 !        ENDDO
8918
8919 !        DO i = i_start, i_end
8920 !          vflux(i,ktf)=0.
8921 !        ENDDO
8922
8923 !        DO k=kts,ktf
8924 !          DO i = i_start, i_end
8925 !            tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j)    &
8926 !                   *rdnw(k)*(vflux(i,k)-vflux(i,k-1))
8927 !          ENDDO
8928 !        ENDDO
8929
8930 !    ENDDO j_loop_s
8931
8932 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
8933
8934    Do K1_ADJ =0, kte+1
8935    Do K0_ADJ =its, ite
8936    a_vflux(K0_ADJ,K1_ADJ) =0.0
8937    End Do
8938    End Do
8939
8940 !   a_rdz =0.0  ! Remarked by Ning Pan, 2010-07-23
8941
8942 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
8943
8944 !LPB[3]
8945    DO j =j_end, j_start, -1
8946
8947    DO k =kts, ktf-1
8948    DO i =i_start, i_end
8949    Tmpv001 =alt(i,k,j) +alt(i,k+1,j)
8950    Tmpv002 =0.5*Tmpv001
8951    Tmpv304(i,k) =Tmpv002
8952    Tmpv003 =kvdif*rdn(k+1)/Tmpv002
8953    Tmpv004 =field(i,k+1,j) -field(i,k,j)
8954    Tmpv005 =Tmpv004 -base_3d(i,k+1,j)
8955    Tmpv006 =Tmpv005 +base_3d(i,k,j)
8956    Tmpv300(i,k) =Tmpv003
8957    Tmpv301(i,k) =Tmpv006
8958    Tmpv007 =Tmpv300(i,k)*Tmpv301(i,k)
8959    vflux(i,k) =Tmpv007
8960
8961    ENDDO
8962    ENDDO
8963    DO i =i_start, i_end
8964    vflux(i,0) =vflux(i,1)
8965
8966    ENDDO
8967
8968    DO i =i_start, i_end
8969    vflux(i,ktf) =0.
8970
8971    ENDDO
8972
8973    DO k =kts, ktf
8974    DO i =i_start, i_end
8975    Tmpv001 =g*g/mut(i,j)/alt(i,k,j)
8976    Tmpv002 =Tmpv001*rdnw(k)
8977    Tmpv003 =vflux(i,k) -vflux(i,k-1)
8978    Tmpv302(i,k) =Tmpv002
8979    Tmpv303(i,k) =Tmpv003
8980 ! Remarked by Ning Pan, 2010-07-23
8981 !   Tmpv004 =Tmpv302(i,k)*Tmpv303(i,k)
8982 !   Tmpv005 =tendency(i,k,j) +Tmpv004
8983 !!  tendency(i,k,j) =Tmpv005
8984
8985    ENDDO
8986    ENDDO
8987
8988    DO k =ktf, kts, -1
8989    DO i =i_end, i_start, -1
8990    a_Tmpv5 =a_tendency(i,k,j)
8991    a_tendency(i,k,j) =0.0
8992    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv5
8993    a_Tmpv4 =a_Tmpv5
8994    a_Tmpv2 =Tmpv303(i,k)*a_Tmpv4
8995    a_Tmpv3 =Tmpv302(i,k)*a_Tmpv4
8996    a_vflux(i,k) =a_vflux(i,k) +a_Tmpv3
8997    a_vflux(i,k-1) =a_vflux(i,k-1) -a_Tmpv3
8998    a_Tmpv1 =rdnw(k)*a_Tmpv2
8999    a_mut(i,j) =a_mut(i,j) -g*g/(mut(i,j)*mut(i,j))/alt(i,k,j)*a_Tmpv1
9000    a_alt(i,k,j) =a_alt(i,k,j) -g*g/mut(i,j)/(alt(i,k,j)*alt(i,k,j))*a_Tmpv1
9001    ENDDO
9002    ENDDO
9003
9004    DO i =i_end, i_start, -1
9005    a_vflux(i,ktf) =0.0
9006    ENDDO
9007
9008    DO i =i_end, i_start, -1
9009    a_vflux(i,1) =a_vflux(i,1) +a_vflux(i,0)
9010    a_vflux(i,0) =0.0
9011    ENDDO
9012
9013    DO k =ktf-1, kts, -1
9014    DO i =i_end, i_start, -1
9015    a_Tmpv7 =a_vflux(i,k)
9016    a_vflux(i,k) =0.0
9017    a_Tmpv3 =Tmpv301(i,k)*a_Tmpv7
9018    a_Tmpv6 =Tmpv300(i,k)*a_Tmpv7
9019    a_Tmpv5 =a_Tmpv6
9020    a_Tmpv4 =a_Tmpv5
9021    a_field(i,k+1,j) =a_field(i,k+1,j) +a_Tmpv4
9022    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv4
9023 ! Revised by Ning Pan, 2010-07-23
9024 !   a_Tmpv2 =-(kvdif*rdn(k+1))*a_Tmpv3/(Tmpv002*Tmpv002)
9025    a_Tmpv2 =-(kvdif*rdn(k+1))*a_Tmpv3/(Tmpv304(i,k)*Tmpv304(i,k))
9026    a_Tmpv1 =0.5*a_Tmpv2
9027    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
9028    a_alt(i,k+1,j) =a_alt(i,k+1,j) +a_Tmpv1
9029    ENDDO
9030    ENDDO
9031
9032    ENDDO
9033
9034 !LPB[2]
9035 !  ktf =min(kte, kde-1)
9036 !  i_start =its
9037 !  i_end =min(ite, ide-1)
9038 !  j_start =jts
9039 !  j_end =min(jte, jde-1)
9040
9041 !LPB[1]
9042
9043 !  IF(config_flags%specified .or. config_flags%nested) THEN
9044 !  specified =.true.
9045 !  END IF
9046
9047 !  IF(config_flags%specified .or. config_flags%nested) THEN
9048
9049 !  END IF
9050
9051 !LPB[0]
9052 !  specified =.false.
9053
9054    END SUBROUTINE a_vertical_diffusion_3dmp
9055
9056    SUBROUTINE a_vertical_diffusion_u(field,a_field,tendency,a_tendency, &
9057    config_flags,u_base,alt,a_alt,muu,a_muu,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde, &
9058    ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
9059
9060 !PART I: DECLARATION OF VARIABLES
9061
9062    IMPLICIT NONE
9063
9064    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
9065    TYPE(grid_config_rec_type) :: config_flags
9066    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
9067    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,alt,a_alt
9068    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
9069    REAL,DIMENSION(ims:ime,jms:jme) :: muu,a_muu
9070    REAL,DIMENSION(kms:kme) :: rdn,rdnw,u_base
9071    REAL :: kvdif
9072    INTEGER :: i,j,k,itf,jtf,ktf
9073    INTEGER :: i_start,i_end,j_start,j_end
9074    REAL,DIMENSION(its:ite,0:kte+1) :: vflux,a_vflux
9075 !   REAL :: rdz,a_rdz,zz,a_zz  ! Remarked by Ning Pan, 2010-07-23
9076    LOGICAL :: specified
9077
9078    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
9079    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9,Tmpv009
9080    REAL,DIMENSION(its:ite,kts:min(kte,kde-1)-1) :: Tmpv300
9081    REAL,DIMENSION(its:ite,kts:min(kte,kde-1)-1) :: Tmpv301
9082    REAL,DIMENSION(its:ite,kts:min(kte,kde-1)-1) :: Tmpv302
9083    REAL,DIMENSION(its:ite,kts:min(kte,kde-1)-1) :: Tmpv303
9084    REAL,DIMENSION(its:ite,kts:min(kte,kde-1)-1) :: Tmpv304
9085    REAL,DIMENSION(its:ite,kts:min(kte,kde-1)-1) :: Tmpv305  ! Added by Ning Pan, 2010-07-23
9086
9087 !PART II: CALCULATIONS OF B. S. TRAJECTORY
9088
9089 !LPB[0]
9090       specified = .false.
9091
9092 !LPB[1]
9093    if(config_flags%specified .or. config_flags%nested) specified = .true.
9094
9095 !LPB[2]
9096       ktf=MIN(kte,kde-1)
9097          i_start = its
9098          i_end   = ite
9099          j_start = jts
9100          j_end   = MIN(jte,jde-1)
9101
9102 !LPB[3]
9103       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
9104
9105 !LPB[4]
9106
9107 !LPB[5]
9108       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
9109
9110 !LPB[6]
9111
9112 !LPB[7]
9113       IF ( config_flags%periodic_x ) i_start = its
9114
9115 !LPB[8]
9116
9117 !LPB[9]
9118       IF ( config_flags%periodic_x ) i_end = ite
9119
9120 !!LPB[10]
9121 !   j_loop_u : DO j = j_start, j_end
9122
9123 !        DO k=kts,ktf-1
9124 !          DO i = i_start, i_end
9125 !            vflux(i,k)=kvdif*rdn(k+1)/(0.25*( alt(i  ,k  ,j)        &
9126 !                                           +alt(i-1,k  ,j)        &
9127 !                                           +alt(i  ,k+1,j)        &
9128 !                                           +alt(i-1,k+1,j) ) )    &
9129 !                                *(field(i,k+1,j)-field(i,k,j)     &
9130 !                                  -u_base(k+1)   +u_base(k)  )
9131 !          ENDDO
9132 !        ENDDO
9133
9134 !        DO i = i_start, i_end
9135 !          vflux(i,0)=vflux(i,1)
9136 !        ENDDO
9137
9138 !        DO i = i_start, i_end
9139 !          vflux(i,ktf)=0.
9140 !        ENDDO
9141
9142 !        DO k=kts,ktf-1
9143 !          DO i = i_start, i_end
9144 !            tendency(i,k,j)=tendency(i,k,j)+                               &
9145 !                   g*g*rdnw(k)/muu(i,j)/(0.5*(alt(i-1,k,j)+alt(i,k,j)))*   &
9146 !                                 (vflux(i,k)-vflux(i,k-1))
9147 !          ENDDO
9148 !        ENDDO
9149
9150 !    ENDDO j_loop_u
9151
9152 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
9153
9154    Do K1_ADJ =0, kte+1
9155    Do K0_ADJ =its, ite
9156    a_vflux(K0_ADJ,K1_ADJ) =0.0
9157    End Do
9158    End Do
9159
9160 ! Remarked by Ning Pan, 2010-07-23
9161 !   a_rdz =0.0
9162 !   a_zz =0.0
9163
9164 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
9165
9166 !LPB[10]
9167    DO j =j_end, j_start, -1
9168
9169    DO k =kts, ktf-1
9170    DO i =i_start, i_end
9171    Tmpv001 =alt(i,k,j) +alt(i-1,k,j)
9172    Tmpv002 =Tmpv001 +alt(i,k+1,j)
9173    Tmpv003 =Tmpv002 +alt(i-1,k+1,j)
9174    Tmpv004 =0.25*Tmpv003
9175    Tmpv305(i,k) =Tmpv004  ! Added by Ning Pan, 2010-07-23
9176    Tmpv005 =kvdif*rdn(k+1)/Tmpv004
9177    Tmpv006 =field(i,k+1,j) -field(i,k,j)
9178    Tmpv007 =Tmpv006 -u_base(k+1)
9179    Tmpv008 =Tmpv007 +u_base(k)
9180    Tmpv300(i,k) =Tmpv005
9181    Tmpv301(i,k) =Tmpv008
9182    Tmpv009 =Tmpv300(i,k)*Tmpv301(i,k)
9183    vflux(i,k) =Tmpv009
9184
9185    ENDDO
9186    ENDDO
9187    DO i =i_start, i_end
9188    vflux(i,0) =vflux(i,1)
9189
9190    ENDDO
9191
9192    DO i =i_start, i_end
9193    vflux(i,ktf) =0.
9194
9195    ENDDO
9196
9197    DO k =kts, ktf-1
9198    DO i =i_start, i_end
9199    Tmpv001 =alt(i-1,k,j) +alt(i,k,j)
9200    Tmpv002 =0.5*Tmpv001
9201    Tmpv302(i,k) =Tmpv002
9202    Tmpv003 =g*g*rdnw(k)/muu(i,j)/Tmpv302(i,k)
9203    Tmpv004 =vflux(i,k) -vflux(i,k-1)
9204    Tmpv303(i,k) =Tmpv003
9205    Tmpv304(i,k) =Tmpv004
9206 ! Remarked by Ning Pan, 2010-07-23
9207 !   Tmpv005 =Tmpv303(i,k)*Tmpv304(i,k)
9208 !   Tmpv006 =tendency(i,k,j) +Tmpv005
9209 !!  tendency(i,k,j) =Tmpv006
9210
9211    ENDDO
9212    ENDDO
9213
9214    DO k =ktf-1, kts, -1
9215    DO i =i_end, i_start, -1
9216    a_Tmpv6 =a_tendency(i,k,j)
9217    a_tendency(i,k,j) =0.0
9218    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv6
9219    a_Tmpv5 =a_Tmpv6
9220    a_Tmpv3 =Tmpv304(i,k)*a_Tmpv5
9221    a_Tmpv4 =Tmpv303(i,k)*a_Tmpv5
9222    a_vflux(i,k) =a_vflux(i,k) +a_Tmpv4
9223    a_vflux(i,k-1) =a_vflux(i,k-1) -a_Tmpv4
9224    a_muu(i,j) =a_muu(i,j) -g*g*rdnw(k)/(muu(i,j)*muu(i,j))/Tmpv302(i,k)*a_Tmpv3
9225    a_Tmpv2 =-g*g*rdnw(k)/muu(i,j)/(Tmpv302(i,k)*Tmpv302(i,k))*a_Tmpv3
9226    a_Tmpv1 =0.5*a_Tmpv2
9227    a_alt(i-1,k,j) =a_alt(i-1,k,j) +a_Tmpv1
9228    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
9229    ENDDO
9230    ENDDO
9231
9232    DO i =i_end, i_start, -1
9233    a_vflux(i,ktf) =0.0
9234    ENDDO
9235
9236    DO i =i_end, i_start, -1
9237    a_vflux(i,1) =a_vflux(i,1) +a_vflux(i,0)
9238    a_vflux(i,0) =0.0
9239    ENDDO
9240
9241    DO k =ktf-1, kts, -1
9242    DO i =i_end, i_start, -1
9243    a_Tmpv9 =a_vflux(i,k)
9244    a_vflux(i,k) =0.0
9245    a_Tmpv5 =Tmpv301(i,k)*a_Tmpv9
9246    a_Tmpv8 =Tmpv300(i,k)*a_Tmpv9
9247    a_Tmpv7 =a_Tmpv8
9248    a_Tmpv6 =a_Tmpv7
9249    a_field(i,k+1,j) =a_field(i,k+1,j) +a_Tmpv6
9250    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv6
9251 ! Revised by Ning Pan, 2010-07-23
9252 !   a_Tmpv4 =-(kvdif*rdn(k+1))*a_Tmpv5/(Tmpv004*Tmpv004)
9253    a_Tmpv4 =-(kvdif*rdn(k+1))*a_Tmpv5/(Tmpv305(i,k)*Tmpv305(i,k))
9254    a_Tmpv3 =0.25*a_Tmpv4
9255    a_Tmpv2 =a_Tmpv3
9256    a_alt(i-1,k+1,j) =a_alt(i-1,k+1,j) +a_Tmpv3
9257    a_Tmpv1 =a_Tmpv2
9258    a_alt(i,k+1,j) =a_alt(i,k+1,j) +a_Tmpv2
9259    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
9260    a_alt(i-1,k,j) =a_alt(i-1,k,j) +a_Tmpv1
9261    ENDDO
9262    ENDDO
9263
9264    ENDDO
9265
9266 !LPB[9]
9267
9268 !  IF( config_flags%periodic_x ) THEN
9269 !  i_end =ite
9270 !  END IF
9271
9272 !  IF( config_flags%periodic_x ) THEN
9273
9274 !  END IF
9275
9276 !LPB[8]
9277
9278 !LPB[7]
9279
9280 !  IF( config_flags%periodic_x ) THEN
9281 !  i_start =its
9282 !  END IF
9283
9284 !  IF( config_flags%periodic_x ) THEN
9285
9286 !  END IF
9287
9288 !LPB[6]
9289
9290 !LPB[5]
9291
9292 !  IF( config_flags%open_xe .or. specified ) THEN
9293 !  i_end =min(ide-1, ite)
9294 !  END IF
9295
9296 !  IF( config_flags%open_xe .or. specified ) THEN
9297
9298 !  END IF
9299
9300 !LPB[4]
9301
9302 !LPB[3]
9303
9304 !  IF( config_flags%open_xs .or. specified ) THEN
9305 !  i_start =max(ids+1, its)
9306 !  END IF
9307
9308 !  IF( config_flags%open_xs .or. specified ) THEN
9309
9310 !  END IF
9311
9312 !LPB[2]
9313 !  ktf =min(kte, kde-1)
9314 !  i_start =its
9315 !  i_end =ite
9316 !  j_start =jts
9317 !  j_end =min(jte, jde-1)
9318
9319 !LPB[1]
9320
9321 !  IF(config_flags%specified .or. config_flags%nested) THEN
9322 !  specified =.true.
9323 !  END IF
9324
9325 !  IF(config_flags%specified .or. config_flags%nested) THEN
9326
9327 !  END IF
9328
9329 !LPB[0]
9330 !  specified =.false.
9331
9332    END SUBROUTINE a_vertical_diffusion_u
9333
9334    SUBROUTINE a_vertical_diffusion_v(field,a_field,tendency,a_tendency, &
9335    config_flags,v_base,alt,a_alt,muv,a_muv,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde, &
9336    ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
9337
9338 !PART I: DECLARATION OF VARIABLES
9339
9340    IMPLICIT NONE
9341
9342    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
9343    TYPE(grid_config_rec_type) :: config_flags
9344    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
9345    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,alt,a_alt
9346    REAL,DIMENSION(kms:kme) :: rdn,rdnw,v_base
9347    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
9348    REAL,DIMENSION(ims:ime,jms:jme) :: muv,a_muv
9349    REAL :: kvdif
9350    INTEGER :: i,j,k,itf,jtf,ktf,jm1
9351    INTEGER :: i_start,i_end,j_start,j_end
9352    REAL,DIMENSION(its:ite,0:kte+1) :: vflux,a_vflux
9353 !   REAL :: rdz,a_rdz,zz,a_zz  ! Remarked by Ning Pan, 2010-07-23
9354    LOGICAL :: specified
9355
9356    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
9357    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9,Tmpv009
9358    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv300
9359    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv301
9360    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv302
9361    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv303
9362    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv304
9363    REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv305  ! Added by Ning Pan, 2010-07-23
9364
9365 !PART II: CALCULATIONS OF B. S. TRAJECTORY
9366
9367 !LPB[0]
9368       specified = .false.
9369
9370 !LPB[1]
9371    if(config_flags%specified .or. config_flags%nested) specified = .true.
9372
9373 !LPB[2]
9374       ktf=MIN(kte,kde-1)
9375          i_start = its
9376          i_end   = MIN(ite,ide-1)
9377          j_start = jts
9378          j_end   = MIN(jte,jde-1)
9379
9380 !LPB[3]
9381       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
9382
9383 !LPB[4]
9384
9385 !LPB[5]
9386       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-1,jte)
9387
9388 !!LPB[6]
9389 !   j_loop_v : DO j = j_start, j_end
9390
9391 !        jm1 = j-1
9392
9393 !        DO k=kts,ktf-1
9394 !          DO i = i_start, i_end
9395 !            vflux(i,k)=kvdif*rdn(k+1)/(0.25*( alt(i,k  ,j  )        &
9396 !                                           +alt(i,k  ,jm1)        &
9397 !                                           +alt(i,k+1,j  )        &
9398 !                                           +alt(i,k+1,jm1) ) )    &
9399 !                                *(field(i,k+1,j)-field(i,k,j)     &
9400 !                                  -v_base(k+1)   +v_base(k)  )
9401 !          ENDDO
9402 !        ENDDO
9403
9404 !        DO i = i_start, i_end
9405 !          vflux(i,0)=vflux(i,1)
9406 !        ENDDO
9407
9408 !        DO i = i_start, i_end
9409 !          vflux(i,ktf)=0.
9410 !        ENDDO
9411
9412 !        DO k=kts,ktf-1
9413 !          DO i = i_start, i_end
9414 !            tendency(i,k,j)=tendency(i,k,j)+                                &
9415 !                   g*g*rdnw(k)/muv(i,j)/(0.5*(alt(i,k,jm1)+alt(i,k,j)))*    &
9416 !                                 (vflux(i,k)-vflux(i,k-1))
9417 !          ENDDO
9418 !        ENDDO
9419
9420 !    ENDDO j_loop_v
9421
9422 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
9423
9424    Do K1_ADJ =0, kte+1
9425    Do K0_ADJ =its, ite
9426    a_vflux(K0_ADJ,K1_ADJ) =0.0
9427    End Do
9428    End Do
9429
9430 ! Remarked by Ning Pan, 2010-07-23
9431 !   a_rdz =0.0
9432 !   a_zz =0.0
9433
9434 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
9435
9436 !LPB[6]
9437    DO j =j_end, j_start, -1
9438
9439    jm1 =j-1
9440    DO k =kts, ktf-1
9441    DO i =i_start, i_end
9442    Tmpv001 =alt(i,k,j) +alt(i,k,jm1)
9443    Tmpv002 =Tmpv001 +alt(i,k+1,j)
9444    Tmpv003 =Tmpv002 +alt(i,k+1,jm1)
9445    Tmpv004 =0.25*Tmpv003
9446    Tmpv305(i,k) =Tmpv004  ! Added by Ning Pan, 2010-07-23
9447    Tmpv005 =kvdif*rdn(k+1)/Tmpv004
9448    Tmpv006 =field(i,k+1,j) -field(i,k,j)
9449    Tmpv007 =Tmpv006 -v_base(k+1)
9450    Tmpv008 =Tmpv007 +v_base(k)
9451    Tmpv300(i,k) =Tmpv005
9452    Tmpv301(i,k) =Tmpv008
9453    Tmpv009 =Tmpv300(i,k)*Tmpv301(i,k)
9454    vflux(i,k) =Tmpv009
9455
9456    ENDDO
9457    ENDDO
9458    DO i =i_start, i_end
9459    vflux(i,0) =vflux(i,1)
9460
9461    ENDDO
9462
9463    DO i =i_start, i_end
9464    vflux(i,ktf) =0.
9465
9466    ENDDO
9467
9468    DO k =kts, ktf-1
9469    DO i =i_start, i_end
9470    Tmpv001 =alt(i,k,jm1) +alt(i,k,j)
9471    Tmpv002 =0.5*Tmpv001
9472    Tmpv302(i,k) =Tmpv002
9473    Tmpv003 =g*g*rdnw(k)/muv(i,j)/Tmpv302(i,k)
9474    Tmpv004 =vflux(i,k) -vflux(i,k-1)
9475    Tmpv303(i,k) =Tmpv003
9476    Tmpv304(i,k) =Tmpv004
9477 ! Remarked by Ning Pan, 2010-07-23
9478 !   Tmpv005 =Tmpv303(i,k)*Tmpv304(i,k)
9479 !   Tmpv006 =tendency(i,k,j) +Tmpv005
9480 !!  tendency(i,k,j) =Tmpv006
9481
9482    ENDDO
9483    ENDDO
9484
9485    DO k =ktf-1, kts, -1
9486    DO i =i_end, i_start, -1
9487    a_Tmpv6 =a_tendency(i,k,j)
9488    a_tendency(i,k,j) =0.0
9489    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv6
9490    a_Tmpv5 =a_Tmpv6
9491    a_Tmpv3 =Tmpv304(i,k)*a_Tmpv5
9492    a_Tmpv4 =Tmpv303(i,k)*a_Tmpv5
9493    a_vflux(i,k) =a_vflux(i,k) +a_Tmpv4
9494    a_vflux(i,k-1) =a_vflux(i,k-1) -a_Tmpv4
9495    a_muv(i,j) =a_muv(i,j) -g*g*rdnw(k)/(muv(i,j)*muv(i,j))/Tmpv302(i,k)*a_Tmpv3
9496    a_Tmpv2 =-g*g*rdnw(k)/muv(i,j)/(Tmpv302(i,k)*Tmpv302(i,k))*a_Tmpv3
9497    a_Tmpv1 =0.5*a_Tmpv2
9498    a_alt(i,k,jm1) =a_alt(i,k,jm1) +a_Tmpv1
9499    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
9500    ENDDO
9501    ENDDO
9502
9503    DO i =i_end, i_start, -1
9504    a_vflux(i,ktf) =0.0
9505    ENDDO
9506
9507    DO i =i_end, i_start, -1
9508    a_vflux(i,1) =a_vflux(i,1) +a_vflux(i,0)
9509    a_vflux(i,0) =0.0
9510    ENDDO
9511
9512    DO k =ktf-1, kts, -1
9513    DO i =i_end, i_start, -1
9514    a_Tmpv9 =a_vflux(i,k)
9515    a_vflux(i,k) =0.0
9516    a_Tmpv5 =Tmpv301(i,k)*a_Tmpv9
9517    a_Tmpv8 =Tmpv300(i,k)*a_Tmpv9
9518    a_Tmpv7 =a_Tmpv8
9519    a_Tmpv6 =a_Tmpv7
9520    a_field(i,k+1,j) =a_field(i,k+1,j) +a_Tmpv6
9521    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv6
9522 ! Revised by Ning Pan, 2010-07-23
9523 !   a_Tmpv4 =-(kvdif*rdn(k+1))*a_Tmpv5/(Tmpv004*Tmpv004)
9524    a_Tmpv4 =-(kvdif*rdn(k+1))*a_Tmpv5/(Tmpv305(i,k)*Tmpv305(i,k))
9525    a_Tmpv3 =0.25*a_Tmpv4
9526    a_Tmpv2 =a_Tmpv3
9527    a_alt(i,k+1,jm1) =a_alt(i,k+1,jm1) +a_Tmpv3
9528    a_Tmpv1 =a_Tmpv2
9529    a_alt(i,k+1,j) =a_alt(i,k+1,j) +a_Tmpv2
9530    a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv1
9531    a_alt(i,k,jm1) =a_alt(i,k,jm1) +a_Tmpv1
9532    ENDDO
9533    ENDDO
9534
9535    ENDDO
9536
9537 !LPB[5]
9538
9539 !  IF( config_flags%open_ye .or. specified ) THEN
9540 !  j_end =min(jde-1, jte)
9541 !  END IF
9542
9543 !  IF( config_flags%open_ye .or. specified ) THEN
9544
9545 !  END IF
9546
9547 !LPB[4]
9548
9549 !LPB[3]
9550
9551 !  IF( config_flags%open_ys .or. specified ) THEN
9552 !  j_start =max(jds+1, jts)
9553 !  END IF
9554
9555 !  IF( config_flags%open_ys .or. specified ) THEN
9556
9557 !  END IF
9558
9559 !LPB[2]
9560 !  ktf =min(kte, kde-1)
9561 !  i_start =its
9562 !  i_end =min(ite, ide-1)
9563 !  j_start =jts
9564 !  j_end =min(jte, jde-1)
9565
9566 !LPB[1]
9567
9568 !  IF(config_flags%specified .or. config_flags%nested) THEN
9569 !  specified =.true.
9570 !  END IF
9571
9572 !  IF(config_flags%specified .or. config_flags%nested) THEN
9573
9574 !  END IF
9575
9576 !LPB[0]
9577 !  specified =.false.
9578
9579    END SUBROUTINE a_vertical_diffusion_v
9580
9581 SUBROUTINE a_calculate_full ( a_rfield, a_rfieldp, &
9582                               ids, ide, jds, jde, kds, kde, &
9583                               ims, ime, jms, jme, kms, kme, &
9584                               its, ite, jts, jte, kts, kte )
9585
9586    IMPLICIT NONE
9587
9588    ! Input data
9589
9590    INTEGER ,      INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
9591                                    ims, ime, jms, jme, kms, kme, &
9592                                    its, ite, jts, jte, kts, kte
9593
9594    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: a_rfieldp
9595    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: a_rfield
9596
9597    ! Local indices.
9598
9599    INTEGER :: i, j, k, itf, jtf, ktf
9600
9601 !<DESCRIPTION>
9602 !
9603 !  calculate_full
9604 !  calculates full 3D field from pertubation and base field.
9605 !
9606 !</DESCRIPTION>
9607
9608    itf=MIN(ite,ide-1)
9609    jtf=MIN(jte,jde-1)
9610    ktf=MIN(kte,kde-1)
9611
9612    DO j=jts,jtf
9613    DO k=kts,ktf
9614    DO i=its,itf
9615       a_rfieldp(i,k,j)=a_rfieldp(i,k,j) + a_rfield(i,k,j)
9616       a_rfield(i,k,j)=0.
9617    ENDDO
9618    ENDDO
9619    ENDDO
9620
9621 END SUBROUTINE a_calculate_full
9622
9623 !        Generated by TAPENADE     (INRIA, Tropics team)
9624 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
9625 !
9626 !  Differentiation of coriolis in reverse (adjoint) mode:
9627 !   gradient     of useful results: ru_tend rw_tend ru rv rw rv_tend
9628 !   with respect to varying inputs: ru_tend rw_tend ru rv rw rv_tend
9629 !   RW status of diff variables: ru_tend:in-out rw_tend:in-out
9630 !                ru:incr rv:incr rw:incr rv_tend:in-out
9631 SUBROUTINE A_CORIOLIS(ru, rub, rv, rvb, rw, rwb, ru_tend, ru_tendb, &
9632 &  rv_tend, rv_tendb, rw_tend, rw_tendb, config_flags, msftx, msfty, &
9633 &  msfux, msfuy, msfvx, msfvy, f, e, sina, cosa, fzm, fzp, ids, ide, jds&
9634 &  , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
9635 &  , kte)
9636   IMPLICIT NONE
9637 ! Input data
9638   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
9639   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
9640 &  jme, kms, kme, its, ite, jts, jte, kts, kte
9641   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
9642 &  rv_tend, rw_tend
9643   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ru_tendb, rv_tendb, &
9644 &  rw_tendb
9645   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ru, rv, rw
9646   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rub, rvb, rwb
9647   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
9648 &  msfvy, msftx, msfty
9649   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: f, e, sina, cosa
9650   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
9651 ! Local indices.
9652   INTEGER :: i, j, k, ktf
9653   INTEGER :: i_start, i_end, j_start, j_end
9654   LOGICAL :: specified
9655   INTEGER :: ad_to
9656   INTEGER :: ad_to0
9657   INTEGER :: min4
9658   INTEGER :: min3
9659   INTEGER :: min2
9660   INTEGER :: min1
9661   REAL :: tempb5
9662   REAL :: tempb4
9663   REAL :: tempb3
9664   REAL :: tempb2
9665   REAL :: tempb1
9666   REAL :: tempb0
9667   REAL :: tempb
9668 !<DESCRIPTION>
9669 !
9670 !  coriolis calculates the large timestep tendency terms in the
9671 !  u, v, and w momentum equations arise from the coriolis force.
9672 !
9673 !</DESCRIPTION>
9674   specified = .false.
9675   IF (config_flags%specified .OR. config_flags%nested) specified = &
9676 &      .true.
9677   IF (kte .GT. kde - 1) THEN
9678     ktf = kde - 1
9679   ELSE
9680     ktf = kte
9681   END IF
9682 ! coriolis for u-momentum equation
9683 !  Notes on map scale factor
9684 !  cosa, sina are related to rotating the coordinate frame if desired
9685 !  generally sina=0, cosa=1
9686 !  ADT eqn 44, RHS terms 6 and 7: -2 mu w omega cos(lat)/my
9687 !                                + 2 mu v omega sin(lat)/my
9688 !  Define f=2 omega sin(lat), e=2 omega cos(lat)
9689 !   => terms are: -e mu w / my + f mu v / my
9690 !  rv = mu v / mx ; rw = mu w / my
9691 !   => terms are: -e rw + f rv *mx / my
9692   i_start = its
9693   i_end = ite
9694   IF ((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
9695 &  THEN
9696     IF (ids + 1 .LT. its) THEN
9697       i_start = its
9698     ELSE
9699       i_start = ids + 1
9700     END IF
9701   END IF
9702   IF ((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
9703 &  THEN
9704     IF (ide - 1 .GT. ite) THEN
9705       i_end = ite
9706     ELSE
9707       i_end = ide - 1
9708     END IF
9709   END IF
9710   IF (config_flags%periodic_x) i_start = its
9711   IF (config_flags%periodic_x) i_end = ite
9712   IF (jte .GT. jde - 1) THEN
9713     min1 = jde - 1
9714   ELSE
9715     min1 = jte
9716   END IF
9717 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
9718 !  IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
9719 !    DO k=kts,ktf
9720 !
9721 !      ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))   &
9722 !        *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) &
9723 !            - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) &
9724 !        *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j))
9725 !    ENDDO
9726 !  ENDIF
9727 !  IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN
9728 !    DO k=kts,ktf
9729 !
9730 !      ru_tend(ite,k,j)=ru_tend(ite,k,j) + (msfux(ite,j)/msfuy(ite,j))*0.5*(f(ite-1,j)+f(ite-1,j)) &
9731 !        *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) &
9732 !            - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) &
9733 !        *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j))
9734 !    ENDDO
9735 !  ENDIF
9736 !  coriolis term for v-momentum equation
9737 !  Notes on map scale factors
9738 !  ADT eqn 45, RHS terms 6 and 6b [0 for sina=0]: -2 mu u omega sin(lat)/mx + ?
9739 !  Define f=2 omega sin(lat), e=2 omega cos(lat)
9740 !   => terms are: -f mu u / mx
9741 !  ru = mu u / my ; rw = mu w / my
9742 !   => terms are: -f ru *my / mx + ?
9743   j_start = jts
9744   j_end = jte
9745   IF (((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
9746 &      .OR. config_flags%polar) THEN
9747     IF (jds + 1 .LT. jts) THEN
9748       j_start = jts
9749     ELSE
9750       j_start = jds + 1
9751     END IF
9752   END IF
9753   IF (((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
9754 &      .OR. config_flags%polar) THEN
9755     IF (jde - 1 .GT. jte) THEN
9756       j_end = jte
9757     ELSE
9758       j_end = jde - 1
9759     END IF
9760   END IF
9761 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
9762 !  IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN
9763 !    DO k=kts,ktf
9764 !    DO i=its,MIN(ide-1,ite)
9765 !
9766 !       rv_tend(i,k,jts)=rv_tend(i,k,jts) - (msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))    &
9767 !        *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts))   &
9768 !            + (msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts))   &
9769 !            *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts))
9770 !    ENDDO
9771 !    ENDDO
9772 !  ENDIF
9773   DO j=j_start,j_end
9774     DO k=kts,ktf
9775       IF (ide - 1 .GT. ite) THEN
9776         min2 = ite
9777       ELSE
9778         min2 = ide - 1
9779       END IF
9780       i = min2 + 1
9781       CALL PUSHINTEGER4(i - 1)
9782     END DO
9783   END DO
9784   IF (jte .GT. jde - 1) THEN
9785     min3 = jde - 1
9786   ELSE
9787     min3 = jte
9788   END IF
9789 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
9790 !  IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN
9791 !    DO k=kts,ktf
9792 !    DO i=its,MIN(ide-1,ite)
9793 !
9794 !       rv_tend(i,k,jte)=rv_tend(i,k,jte) - (msfvy(i,jte)/msfvx(i,jte))*0.5*(f(i,jte-1)+f(i,jte-1))        &
9795 !        *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1))   &
9796 !            + (msfvy(i,jte)/msfvx(i,jte))*0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,jte-1)+sina(i,jte-1))   &
9797 !            *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1))
9798 !    ENDDO
9799 !    ENDDO
9800 !  ENDIF
9801 ! coriolis term for w-mometum
9802 ! Notes on map scale factors
9803 ! ADT eqn 46/my, RHS terms 5 and 5b [0 for sina=0]: 2 mu u omega cos(lat)/my +?
9804 ! Define e=2 omega cos(lat)
9805 !  => terms are: e mu u / my + ???
9806 ! ru = mu u / my ; ru = mu v / mx
9807 !  => terms are: e ru + ???
9808   DO j=jts,min3
9809     DO k=kts+1,ktf
9810       IF (ite .GT. ide - 1) THEN
9811         min4 = ide - 1
9812       ELSE
9813         min4 = ite
9814       END IF
9815       i = min4 + 1
9816       CALL PUSHINTEGER4(i - 1)
9817     END DO
9818   END DO
9819   DO j=min3,jts,-1
9820     DO k=ktf,kts+1,-1
9821       CALL POPINTEGER4(ad_to0)
9822       DO i=ad_to0,its,-1
9823         tempb3 = e(i, j)*rw_tendb(i, k, j)
9824         tempb4 = cosa(i, j)*0.5*tempb3
9825         tempb5 = -(msftx(i, j)*0.5*sina(i, j)*tempb3/msfty(i, j))
9826         rub(i, k, j) = rub(i, k, j) + fzm(k)*tempb4
9827         rub(i+1, k, j) = rub(i+1, k, j) + fzm(k)*tempb4
9828         rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*tempb4
9829         rub(i+1, k-1, j) = rub(i+1, k-1, j) + fzp(k)*tempb4
9830         rvb(i, k, j) = rvb(i, k, j) + fzm(k)*tempb5
9831         rvb(i, k, j+1) = rvb(i, k, j+1) + fzm(k)*tempb5
9832         rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*tempb5
9833         rvb(i, k-1, j+1) = rvb(i, k-1, j+1) + fzp(k)*tempb5
9834       END DO
9835     END DO
9836   END DO
9837   DO j=j_end,j_start,-1
9838     DO k=ktf,kts,-1
9839       CALL POPINTEGER4(ad_to)
9840       DO i=ad_to,its,-1
9841         tempb1 = -(msfvy(i, j)*0.25*0.5*(f(i, j)+f(i, j-1))*rv_tendb(i, &
9842 &          k, j)/msfvx(i, j))
9843         tempb2 = (e(i, j)+e(i, j-1))*(sina(i, j)+sina(i, j-1))*msfvy(i, &
9844 &          j)*0.5**2*0.25*rv_tendb(i, k, j)/msfvx(i, j)
9845         rub(i, k, j) = rub(i, k, j) + tempb1
9846         rub(i+1, k, j) = rub(i+1, k, j) + tempb1
9847         rub(i, k, j-1) = rub(i, k, j-1) + tempb1
9848         rub(i+1, k, j-1) = rub(i+1, k, j-1) + tempb1
9849         rwb(i, k+1, j-1) = rwb(i, k+1, j-1) + tempb2
9850         rwb(i, k, j-1) = rwb(i, k, j-1) + tempb2
9851         rwb(i, k+1, j) = rwb(i, k+1, j) + tempb2
9852         rwb(i, k, j) = rwb(i, k, j) + tempb2
9853       END DO
9854     END DO
9855   END DO
9856   DO j=min1,jts,-1
9857     DO k=ktf,kts,-1
9858       DO i=i_end,i_start,-1
9859         tempb = msfux(i, j)*0.25*0.5*(f(i, j)+f(i-1, j))*ru_tendb(i, k, &
9860 &          j)/msfuy(i, j)
9861         tempb0 = -((e(i, j)+e(i-1, j))*0.5**2*0.25*(cosa(i, j)+cosa(i-1&
9862 &          , j))*ru_tendb(i, k, j))
9863         rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + tempb
9864         rvb(i, k, j+1) = rvb(i, k, j+1) + tempb
9865         rvb(i-1, k, j) = rvb(i-1, k, j) + tempb
9866         rvb(i, k, j) = rvb(i, k, j) + tempb
9867         rwb(i-1, k+1, j) = rwb(i-1, k+1, j) + tempb0
9868         rwb(i-1, k, j) = rwb(i-1, k, j) + tempb0
9869         rwb(i, k+1, j) = rwb(i, k+1, j) + tempb0
9870         rwb(i, k, j) = rwb(i, k, j) + tempb0
9871       END DO
9872     END DO
9873   END DO
9874 END SUBROUTINE A_CORIOLIS
9875
9876    SUBROUTINE a_perturbation_coriolis(ru_in,a_ru_in,rv_in,a_rv_in,rw,a_rw, &
9877    ru_tend,a_ru_tend,rv_tend,a_rv_tend,rw_tend,a_rw_tend,config_flags,u_base, &
9878    v_base,z_base,muu,a_muu,muv,a_muv,phb,ph,a_ph,msftx,msfty,msfux,msfuy,msfvx, &
9879    msfvy,f,e,sina,cosa,fzm,fzp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
9880    jts,jte,kts,kte)
9881
9882 !PART I: DECLARATION OF VARIABLES
9883
9884    IMPLICIT NONE
9885
9886    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
9887    TYPE(grid_config_rec_type) :: config_flags
9888    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
9889    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tend,a_ru_tend,rv_tend,a_rv_tend, &
9890    rw_tend,a_rw_tend
9891    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_in,a_ru_in,rv_in,a_rv_in,rw,a_rw, &
9892    ph,a_ph,phb
9893    REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
9894    REAL,DIMENSION(ims:ime,jms:jme) :: f,e,sina,cosa
9895    REAL,DIMENSION(ims:ime,jms:jme) :: muu,a_muu,muv,a_muv
9896    REAL,DIMENSION(kms:kme) :: fzm,fzp
9897    REAL,DIMENSION(kms:kme) :: u_base,v_base,z_base
9898    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru,a_ru,rv,a_rv
9899    REAL :: z_at_u,a_z_at_u,z_at_v,a_z_at_v,wkp1,a_wkp1,wk,a_wk,wkm1,a_wkm1
9900    INTEGER :: i,j,k,ktf
9901    INTEGER :: i_start,i_end,j_start,j_end
9902    LOGICAL :: specified
9903
9904 !REVISED BY WALLS
9905 !  REAL,DIMENSION(jts:Tmpv001) :: Keep_Lpb11_wkp1
9906    REAL,DIMENSION(jts:jme) :: Keep_Lpb11_wkp1
9907    REAL,DIMENSION(jts:jme) :: Keep_Lpb11_wk
9908    REAL,DIMENSION(jts:jme) :: Keep_Lpb11_wkm1
9909    REAL,DIMENSION(max(jds+1,jts)-1:min(jde-1,jte)) :: Keep_Lpb17_wkp1
9910    REAL,DIMENSION(max(jds+1,jts)-1:min(jde-1,jte)) :: Keep_Lpb17_wkm1
9911    REAL,DIMENSION(max(jds+1,jts)-1:min(jde-1,jte)) :: Keep_Lpb17_wk
9912 !  REAL,DIMENSION(max(jds+1,jts)-1:min(jde-1,jte)) :: Keep_Lpb18_wkp1
9913 !  REAL,DIMENSION(max(jds+1,jts)-1:min(jde-1,jte)) :: Keep_Lpb18_wk
9914 !  REAL,DIMENSION(max(jds+1,jts)-1:min(jde-1,jte)) :: Keep_Lpb18_wkm1
9915    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
9916    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, &
9917    Tmpv009,a_Tmpv10,Tmpv010,a_Tmpv11,Tmpv011,a_Tmpv12,Tmpv012,a_Tmpv13,Tmpv013, &
9918    a_Tmpv14,Tmpv014,a_Tmpv15,Tmpv015
9919 !REVISED BY WALLS
9920 !  REAL,DIMENSION(min0(its-1,its):ite) :: Tmpv200
9921    REAL,DIMENSION(min0(its-1,its):ite) :: Tmpv200
9922    REAL,DIMENSION(min0(its-1,its):ite) :: Tmpv201
9923    REAL,DIMENSION(min0(its-1,its):ite,kts+1:min(kte,kde-1)-1) :: Tmpv300
9924 ! Added by Ning Pan, 2010-07-22
9925    REAL,DIMENSION(its-1:ite,kts:min(kte,kde-1),jts:min(jte,jde-1)+1) :: Tmpv400
9926    REAL,DIMENSION(its-1:ite,kts:min(kte,kde-1),jts:min(jte,jde-1)+1) :: Tmpv401
9927    REAL,DIMENSION(its:min(ite,ide-1)+1,kts:min(kte,kde-1),jts-1:jte) :: Tmpv500
9928    REAL,DIMENSION(its:min(ite,ide-1)+1,kts:min(kte,kde-1),jts-1:jte) :: Tmpv501
9929
9930 !PART II: CALCULATIONS OF B. S. TRAJECTORY
9931
9932 !LPB[0]
9933       specified = .false.
9934
9935 !LPB[1]
9936    if(config_flags%specified .or. config_flags%nested) specified = .true.
9937
9938 !LPB[2]
9939       ktf=MIN(kte,kde-1)
9940
9941       i_start = its
9942       i_end   = ite
9943
9944 !LPB[3]
9945    IF ( config_flags%open_xs .or. specified .or.   &
9946         config_flags%nested) i_start = MAX(ids+1,its)
9947
9948 !LPB[4]
9949
9950 !LPB[5]
9951    IF ( config_flags%open_xe .or. specified .or.   &
9952         config_flags%nested) i_end   = MIN(ide-1,ite)
9953
9954 !LPB[6]
9955
9956 !LPB[7]
9957       IF ( config_flags%periodic_x ) i_start = its
9958
9959 !LPB[8]
9960
9961 !LPB[9]
9962       IF ( config_flags%periodic_x ) i_end = ite
9963
9964 !LPB[10]
9965       DO j = jts, MIN(jte,jde-1)+1
9966
9967       DO k=kts+1,ktf-1
9968       DO i = i_start-1, i_end
9969         z_at_v = 0.25*( phb(i,k,j  )+phb(i,k+1,j  )    &
9970                        +phb(i,k,j-1)+phb(i,k+1,j-1)    &
9971                        +ph(i,k,j  )+ph(i,k+1,j  )      &
9972                        +ph(i,k,j-1)+ph(i,k+1,j-1))/g
9973         wkp1 = min(1.,max(0.,z_at_v-z_base(k))/(z_base(k+1)-z_base(k)))
9974         wkm1 = min(1.,max(0.,z_base(k)-z_at_v)/(z_base(k)-z_base(k-1)))
9975         wk   = 1.-wkp1-wkm1
9976
9977 ! Revised by Ning Pan, 2010-07-22
9978 !        rv(i,k,j) = rv_in(i,k,j) - muv(i,j)*(              &
9979 !                                     wkm1*v_base(k-1)      &
9980 !                                    +wk  *v_base(k  )      &
9981 !                                    +wkp1*v_base(k+1)   )
9982         Tmpv001 =wkm1*v_base(k-1) +wk*v_base(k)
9983         Tmpv002 =Tmpv001 +wkp1*v_base(k+1)
9984         Tmpv400(i,k,j) =Tmpv002
9985         Tmpv003 =muv(i,j)*Tmpv400(i,k,j)
9986         Tmpv004 =rv_in(i,k,j) -Tmpv003
9987         rv(i,k,j) =Tmpv004
9988         Tmpv401(i,k,j) =z_at_v
9989
9990       ENDDO
9991       ENDDO
9992
9993       ENDDO
9994
9995 !LPB[11]
9996       DO j = jts, MIN(jte,jde-1)+1
9997
9998 ! Remarked by Ning Pan, 2010-07-22
9999 !       Keep_Lpb11_wkp1(j) =wkp1
10000 !       Keep_Lpb11_wk(j) =wk
10001 !       Keep_Lpb11_wkm1(j) =wkm1
10002
10003       DO i = i_start-1, i_end
10004         k = kts
10005         z_at_v = 0.25*( phb(i,k,j  )+phb(i,k+1,j  )    &
10006                        +phb(i,k,j-1)+phb(i,k+1,j-1)    &
10007                        +ph(i,k,j  )+ph(i,k+1,j  )      &
10008                        +ph(i,k,j-1)+ph(i,k+1,j-1))/g
10009         wkp1 = min(1.,max(0.,z_at_v-z_base(k))/(z_base(k+1)-z_base(k)))
10010         wk   = 1.-wkp1
10011 ! Revised by Ning Pan, 2010-07-22
10012 !        rv(i,k,j) = rv_in(i,k,j) - muv(i,j)*(              &
10013 !                                    +wk  *v_base(k  )      &
10014 !                                    +wkp1*v_base(k+1)   )
10015         Tmpv001 =+wk*v_base(k) +wkp1*v_base(k+1)
10016         Tmpv400(i,k,j) =Tmpv001
10017         Tmpv002 =muv(i,j)*Tmpv400(i,k,j)
10018         Tmpv003 =rv_in(i,k,j) -Tmpv002
10019         rv(i,k,j) =Tmpv003
10020         Tmpv401(i,k,j) =z_at_v
10021
10022         k = ktf
10023         z_at_v = 0.25*( phb(i,k,j  )+phb(i,k+1,j  )    &
10024                        +phb(i,k,j-1)+phb(i,k+1,j-1)    &
10025                        +ph(i,k,j  )+ph(i,k+1,j  )      &
10026                        +ph(i,k,j-1)+ph(i,k+1,j-1))/g
10027         wkm1 = min(1.,max(0.,z_base(k)-z_at_v)/(z_base(k)-z_base(k-1)))
10028         wk   = 1.-wkm1
10029 ! Revised by Ning Pan, 2010-07-22
10030 !        rv(i,k,j) = rv_in(i,k,j) - muv(i,j)*(              &
10031 !                                     wkm1*v_base(k-1)      &
10032 !                                    +wk  *v_base(k  )   )
10033         Tmpv001 =wkm1*v_base(k-1) +wk*v_base(k)
10034         Tmpv400(i,k,j) =Tmpv001
10035         Tmpv002 =muv(i,j)*Tmpv400(i,k,j)
10036         Tmpv003 =rv_in(i,k,j) -Tmpv002
10037         rv(i,k,j) =Tmpv003
10038         Tmpv401(i,k,j) =z_at_v
10039
10040       ENDDO
10041
10042       ENDDO
10043
10044 ! Remarked by Ning Pan, 2010-07-22: LPB[12] is useless
10045 !LPB[12]
10046 !      DO j = jts, MIN(jte,jde-1)
10047
10048 !      DO k=kts,ktf
10049 !        DO i = i_start, i_end
10050 !          ru_tend(i,k,j)=ru_tend(i,k,j) + (msfux(i,j)/msfuy(i,j))*0.5*(f(i,j)+f(i-1,j)) &
10051 !REVISED! BY WALLS
10052 !!     &
10053 !            *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j))   &
10054 !                - 0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j))   &
10055 !            *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j))
10056 !        ENDDO
10057 !      ENDDO
10058 !   IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
10059
10060 !        DO k=kts,ktf
10061 !          ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,j))*0.5*(f(its,j) &
10062 !   +f(its,j))     &
10063 !            *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j))   &
10064 !                - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j))   &
10065 !            *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j))
10066 !        ENDDO
10067 !      ENDIF
10068 !   IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN
10069
10070 !        DO k=kts,ktf
10071 !          ru_tend(ite,k,j)=ru_tend(ite,k,j) + (msfux(ite,j)/msfuy(ite,j))*0.5*(f(ite-1, &
10072 !   j)+f(ite-1,j))   &
10073 !            *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j))   &
10074 !                - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j))   &
10075 !            *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j))
10076 !        ENDDO
10077 !      ENDIF
10078
10079 !      ENDDO
10080
10081 !LPB[13]
10082       j_start = jts
10083       j_end   = jte
10084
10085 !LPB[14]
10086    IF ( config_flags%open_ys .or. specified .or.   &
10087         config_flags%nested .or. config_flags%polar) j_start = MAX(jds+1,jts)
10088
10089 !LPB[15]
10090
10091 !LPB[16]
10092    IF ( config_flags%open_ye .or. specified .or.   &
10093         config_flags%nested .or. config_flags%polar) j_end   = MIN(jde-1,jte)
10094
10095 !LPB[17]
10096       DO j = j_start-1,j_end
10097
10098 ! Remarked by Ning Pan, 2010-07-22
10099 !       Keep_Lpb17_wkp1(j) =wkp1
10100 !       Keep_Lpb17_wkm1(j) =wkm1
10101 !       Keep_Lpb17_wk(j) =wk
10102
10103       DO k=kts+1,ktf-1
10104       DO i = its, MIN(ite,ide-1)+1
10105         z_at_u = 0.25*( phb(i  ,k,j)+phb(i  ,k+1,j)    &
10106                        +phb(i-1,k,j)+phb(i-1,k+1,j)    &
10107                        +ph(i  ,k,j)+ph(i  ,k+1,j)      &
10108                        +ph(i-1,k,j)+ph(i-1,k+1,j))/g
10109         wkp1 = min(1.,max(0.,z_at_u-z_base(k))/(z_base(k+1)-z_base(k)))
10110         wkm1 = min(1.,max(0.,z_base(k)-z_at_u)/(z_base(k)-z_base(k-1)))
10111         wk   = 1.-wkp1-wkm1
10112 ! Revised by Ning Pan, 2010-07-22
10113 !        ru(i,k,j) = ru_in(i,k,j) - muu(i,j)*(              &
10114 !                                     wkm1*u_base(k-1)      &
10115 !                                    +wk  *u_base(k  )      &
10116 !                                    +wkp1*u_base(k+1)   )
10117         Tmpv001 =wkm1*u_base(k-1) +wk*u_base(k)
10118         Tmpv002 =Tmpv001 +wkp1*u_base(k+1)
10119         Tmpv500(i,k,j) =Tmpv002
10120         Tmpv003 =muu(i,j)*Tmpv500(i,k,j)
10121         Tmpv004 =ru_in(i,k,j) -Tmpv003
10122         ru(i,k,j) =Tmpv004
10123         Tmpv501(i,k,j) =z_at_u
10124
10125       ENDDO
10126       ENDDO
10127
10128       ENDDO
10129
10130 !!LPB[18]
10131       DO j = j_start-1,j_end
10132
10133     !  Keep_Lpb18_wkp1(j) =wkp1
10134     !  Keep_Lpb18_wk(j) =wk
10135     !  Keep_Lpb18_wkm1(j) =wkm1
10136
10137       DO i = its, MIN(ite,ide-1)+1
10138         k = kts
10139         z_at_u = 0.25*( phb(i  ,k,j)+phb(i  ,k+1,j)    &
10140                        +phb(i-1,k,j)+phb(i-1,k+1,j)    &
10141                        +ph(i  ,k,j)+ph(i  ,k+1,j)      &
10142                        +ph(i-1,k,j)+ph(i-1,k+1,j))/g
10143         wkp1 = min(1.,max(0.,z_at_u-z_base(k))/(z_base(k+1)-z_base(k)))
10144         wk   = 1.-wkp1
10145 ! Revised by Ning Pan, 2010-07-22
10146 !        ru(i,k,j) = ru_in(i,k,j) - muu(i,j)*(              &
10147 !                                    +wk  *u_base(k  )      &
10148 !                                    +wkp1*u_base(k+1)   )
10149         Tmpv001 =+wk*u_base(k) +wkp1*u_base(k+1)
10150         Tmpv500(i,k,j) =Tmpv001
10151         Tmpv002 =muu(i,j)*Tmpv500(i,k,j)
10152         Tmpv003 =ru_in(i,k,j) -Tmpv002
10153         ru(i,k,j) =Tmpv003
10154         Tmpv501(i,k,j) =z_at_u
10155
10156         k = ktf
10157         z_at_u = 0.25*( phb(i  ,k,j)+phb(i  ,k+1,j)    &
10158                        +phb(i-1,k,j)+phb(i-1,k+1,j)    &
10159                        +ph(i  ,k,j)+ph(i  ,k+1,j)      &
10160                        +ph(i-1,k,j)+ph(i-1,k+1,j))/g
10161         wkm1 = min(1.,max(0.,z_base(k)-z_at_u)/(z_base(k)-z_base(k-1)))
10162         wk   = 1.-wkm1
10163 ! Revised by Ning Pan, 2010-07-22
10164 !        ru(i,k,j) = ru_in(i,k,j) - muu(i,j)*(              &
10165 !                                     wkm1*u_base(k-1)      &
10166 !                                    +wk  *u_base(k  )   )
10167         Tmpv001 =wkm1*u_base(k-1) +wk*u_base(k)
10168         Tmpv500(i,k,j) =Tmpv001
10169         Tmpv002 =muu(i,j)*Tmpv500(i,k,j)
10170         Tmpv003 =ru_in(i,k,j) -Tmpv002
10171         ru(i,k,j) =Tmpv003
10172         Tmpv501(i,k,j) =z_at_u
10173
10174       ENDDO
10175
10176       ENDDO
10177
10178 !!LPB[19]
10179
10180 ! Remarked by Ning Pan, 2010-07-22: LPB[20]-[24] are useless
10181 !!LPB[20]
10182 !   IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN
10183
10184 !        DO k=kts,ktf
10185 !        DO i=its,MIN(ide-1,ite)
10186 !           rv_tend(i,k,jts)=rv_tend(i,k,jts) - (msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts) &
10187 !   +f(i,jts))      &
10188 !            *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts))     &
10189 !                + (msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts) &
10190 !   +sina(i,jts))     &
10191 !                *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts))
10192 !        ENDDO
10193 !        ENDDO
10194
10195 !   ENDIF
10196
10197 !!LPB[21]
10198 !      DO j=j_start, j_end
10199
10200 !
10201 !      DO k=kts,ktf
10202 !      DO i=its,MIN(ide-1,ite)
10203 !         rv_tend(i,k,j)=rv_tend(i,k,j) - (msfvy(i,j)/msfvx(i,j))*0.5*(f(i,j)+f(i,j-1)) &
10204 !         &
10205 !          *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1))   &
10206 !              + (msfvy(i,j)/msfvx(i,j))*0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j) &
10207 !   +sina(i,j-1))   &
10208 !              *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j))
10209 !      ENDDO
10210 !      ENDDO
10211
10212 !      ENDDO
10213
10214 !!LPB[22]
10215
10216 !!LPB[23]
10217 !   IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN
10218
10219 !        DO k=kts,ktf
10220 !        DO i=its,MIN(ide-1,ite)
10221 !           rv_tend(i,k,jte)=rv_tend(i,k,jte) - (msfvy(i,jte)/msfvx(i,jte)) &
10222 !   *0.5*(f(i,jte-1)+f(i,jte-1))          &
10223 !            *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1))     &
10224 !                + (msfvy(i,jte)/msfvx(i,jte))*0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i, &
10225 !   jte-1)+sina(i,jte-1))     &
10226 !                *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1))
10227 !        ENDDO
10228 !        ENDDO
10229
10230 !   ENDIF
10231
10232 !!LPB[24]
10233 !      DO j=jts,MIN(jte, jde-1)
10234
10235 !
10236 !      DO k=kts+1,ktf
10237 !      DO i=its,MIN(ite, ide-1)
10238 !          rw_tend(i,k,j)=rw_tend(i,k,j) + e(i,j)*             &
10239 !             (cosa(i,j)*0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j))   &
10240 !             +fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j)))             &
10241 !             -(msftx(i,j)/msfty(i,j))*sina(i,j)*0.5*(fzm(k)*(rv(i,k,j)+rv(i,k,j+1))   &
10242 !             +fzp(k)*(rv(i,k-1,j)+rv(i,k-1,j+1))))
10243 !      ENDDO
10244 !      ENDDO
10245
10246 !      ENDDO
10247
10248 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
10249
10250    Do K2_ADJ =jms, jme
10251    Do K1_ADJ =kms, kme
10252    Do K0_ADJ =ims, ime
10253    a_ru(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
10254    End Do
10255    End Do
10256    End Do
10257
10258    Do K2_ADJ =jms, jme
10259    Do K1_ADJ =kms, kme
10260    Do K0_ADJ =ims, ime
10261    a_rv(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
10262    End Do
10263    End Do
10264    End Do
10265
10266    a_z_at_u =0.0
10267    a_z_at_v =0.0
10268    a_wkp1 =0.0
10269    a_wk =0.0
10270    a_wkm1 =0.0
10271
10272 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
10273
10274 !LPB[24]
10275 !  coriolis term for w-momentum equation
10276    DO j =min(jte, jde-1), jts, -1
10277
10278 !  DO k =kts+1, ktf
10279 !  DO i =its, min(ite, ide-1)
10280 !  Tmpv001 =ru(i,k,j) +ru(i+1,k,j)
10281 !  Tmpv002 =fzm(k)*Tmpv001
10282 !  Tmpv003 =ru(i,k-1,j) +ru(i+1,k-1,j)
10283 !  Tmpv004 =fzp(k)*Tmpv003
10284 !  Tmpv005 =Tmpv002 +Tmpv004
10285 !  Tmpv006 =cosa(i,j)*0.5*Tmpv005
10286 !  Tmpv007 =rv(i,k,j) +rv(i,k,j+1)
10287 !  Tmpv008 =fzm(k)*Tmpv007
10288 !  Tmpv009 =rv(i,k-1,j) +rv(i,k-1,j+1)
10289 !  Tmpv010 =fzp(k)*Tmpv009
10290 !  Tmpv011 =Tmpv008 +Tmpv010
10291 !  Tmpv012 =(msftx(i,j)/msfty(i,j))*sina(i,j)*0.5*Tmpv011
10292 !  Tmpv013 =Tmpv006 -Tmpv012
10293 !  Tmpv014 =e(i,j)*Tmpv013
10294 !  Tmpv015 =rw_tend(i,k,j) +Tmpv014
10295 !  rw_tend(i,k,j) =Tmpv015
10296
10297 !  ENDDO
10298 !  ENDDO
10299
10300    DO k =ktf, kts+1, -1
10301    DO i =min(ite, ide-1), its, -1
10302    a_Tmpv15 =a_rw_tend(i,k,j)
10303    a_rw_tend(i,k,j) =0.0
10304    a_rw_tend(i,k,j) =a_rw_tend(i,k,j) +a_Tmpv15
10305    a_Tmpv14 =a_Tmpv15
10306    a_Tmpv13 =e(i,j)*a_Tmpv14
10307    a_Tmpv6 =a_Tmpv13
10308    a_Tmpv12 =-a_Tmpv13
10309    a_Tmpv11 =(msftx(i,j)/msfty(i,j))*sina(i,j)*0.5*a_Tmpv12
10310    a_Tmpv8 =a_Tmpv11
10311    a_Tmpv10 =a_Tmpv11
10312    a_Tmpv9 =fzp(k)*a_Tmpv10
10313    a_rv(i,k-1,j) =a_rv(i,k-1,j) +a_Tmpv9
10314    a_rv(i,k-1,j+1) =a_rv(i,k-1,j+1) +a_Tmpv9
10315    a_Tmpv7 =fzm(k)*a_Tmpv8
10316    a_rv(i,k,j) =a_rv(i,k,j) +a_Tmpv7
10317    a_rv(i,k,j+1) =a_rv(i,k,j+1) +a_Tmpv7
10318    a_Tmpv5 =cosa(i,j)*0.5*a_Tmpv6
10319    a_Tmpv2 =a_Tmpv5
10320    a_Tmpv4 =a_Tmpv5
10321    a_Tmpv3 =fzp(k)*a_Tmpv4
10322    a_ru(i,k-1,j) =a_ru(i,k-1,j) +a_Tmpv3
10323    a_ru(i+1,k-1,j) =a_ru(i+1,k-1,j) +a_Tmpv3
10324    a_Tmpv1 =fzm(k)*a_Tmpv2
10325    a_ru(i,k,j) =a_ru(i,k,j) +a_Tmpv1
10326    a_ru(i+1,k,j) =a_ru(i+1,k,j) +a_Tmpv1
10327    ENDDO
10328    ENDDO
10329
10330    ENDDO
10331
10332 !LPB[23]
10333
10334 !  IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
10335 !  DO k =kts, ktf
10336 !  DO i =its, min(ide-1, ite)
10337 !  Tmpv001 =ru(i,k,jte-1) +ru(i+1,k,jte-1)
10338 !  Tmpv002 =Tmpv001 +ru(i,k,jte-1)
10339 !  Tmpv003 =Tmpv002 +ru(i+1,k,jte-1)
10340 !  Tmpv004 =(msfvy(i,jte)/msfvx(i,jte))*0.5*(f(i,jte-1)+f(i,jte-1))*0.25*Tmpv003
10341 !  Tmpv005 =rv_tend(i,k,jte) -Tmpv004
10342 !  Tmpv006 =rw(i,k+1,jte-1) +rw(i,k,jte-1)
10343 !  Tmpv007 =Tmpv006 +rw(i,k+1,jte-1)
10344 !  Tmpv008 =Tmpv007 +rw(i,k,jte-1)
10345 !  Tmpv009 =(msfvy(i,jte)/msfvx(i,jte))*0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,jte-1)+sina(i,jte-1))*0.25*Tmpv008
10346 !  Tmpv010 =Tmpv005 +Tmpv009
10347 !  rv_tend(i,k,jte) =Tmpv010
10348
10349 !  ENDDO
10350 !  ENDDO
10351 !  ENDIF
10352
10353 ! Added by Ning Pan, 2010-07-22
10354 !  coriolis term for v-momentum equation
10355    j_start = jts
10356    j_end   = jte
10357    IF ( config_flags%open_ys .or. specified .or. &
10358         config_flags%nested .or. config_flags%polar) j_start = MAX(jds+1,jts)
10359    IF ( config_flags%open_ye .or. specified .or. &
10360         config_flags%nested .or. config_flags%polar) j_end   = MIN(jde-1,jte)
10361
10362 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 XZ)
10363 !   IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
10364
10365 !   DO k =ktf, kts, -1
10366 !   DO i =min(ide-1, ite), its, -1
10367 !   a_Tmpv10 =a_rv_tend(i,k,jte)
10368 !   a_rv_tend(i,k,jte) =0.0
10369 !   a_Tmpv5 =a_Tmpv10
10370 !   a_Tmpv9 =a_Tmpv10
10371 !   a_Tmpv8 =(msfvy(i,jte)/msfvx(i,jte))*0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,  &
10372 !   jte-1)+sina(i,jte-1))*0.25*a_Tmpv9
10373 !   a_Tmpv7 =a_Tmpv8
10374 !   a_rw(i,k,jte-1) =a_rw(i,k,jte-1) +a_Tmpv8
10375 !   a_Tmpv6 =a_Tmpv7
10376 !   a_rw(i,k+1,jte-1) =a_rw(i,k+1,jte-1) +a_Tmpv7
10377 !   a_rw(i,k+1,jte-1) =a_rw(i,k+1,jte-1) +a_Tmpv6
10378 !   a_rw(i,k,jte-1) =a_rw(i,k,jte-1) +a_Tmpv6
10379 !   a_rv_tend(i,k,jte) =a_rv_tend(i,k,jte) +a_Tmpv5
10380 !   a_Tmpv4 =-a_Tmpv5
10381 !   a_Tmpv3 =(msfvy(i,jte)/msfvx(i,jte))*0.5*(f(i,jte-1)+f(i,jte-1))*0.25*a_Tmpv4
10382 !   a_Tmpv2 =a_Tmpv3
10383 !   a_ru(i+1,k,jte-1) =a_ru(i+1,k,jte-1) +a_Tmpv3
10384 !   a_Tmpv1 =a_Tmpv2
10385 !   a_ru(i,k,jte-1) =a_ru(i,k,jte-1) +a_Tmpv2
10386 !   a_ru(i,k,jte-1) =a_ru(i,k,jte-1) +a_Tmpv1
10387 !   a_ru(i+1,k,jte-1) =a_ru(i+1,k,jte-1) +a_Tmpv1
10388 !   ENDDO
10389 !   ENDDO
10390
10391 !   ENDIF
10392
10393 !LPB[22]
10394
10395 !LPB[21]
10396    DO j =j_end, j_start, -1
10397
10398 !  DO k =kts, ktf
10399 !  DO i =its, min(ide-1, ite)
10400 !  Tmpv001 =ru(i,k,j) +ru(i+1,k,j)
10401 !  Tmpv002 =Tmpv001 +ru(i,k,j-1)
10402 !  Tmpv003 =Tmpv002 +ru(i+1,k,j-1)
10403 !  Tmpv004 =(msfvy(i,j)/msfvx(i,j))*0.5*(f(i,j)+f(i,j-1))*0.25*Tmpv003
10404 !  Tmpv005 =rv_tend(i,k,j) -Tmpv004
10405 !  Tmpv006 =rw(i,k+1,j-1) +rw(i,k,j-1)
10406 !  Tmpv007 =Tmpv006 +rw(i,k+1,j)
10407 !  Tmpv008 =Tmpv007 +rw(i,k,j)
10408 !  Tmpv009 =(msfvy(i,j)/msfvx(i,j))*0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j)+sina(i,j-1))*0.25*Tmpv008
10409 !  Tmpv010 =Tmpv005 +Tmpv009
10410 !  rv_tend(i,k,j) =Tmpv010
10411
10412 !  ENDDO
10413 !  ENDDO
10414
10415    DO k =ktf, kts, -1
10416    DO i =min(ide-1, ite), its, -1
10417    a_Tmpv10 =a_rv_tend(i,k,j)
10418    a_rv_tend(i,k,j) =0.0
10419    a_Tmpv5 =a_Tmpv10
10420    a_Tmpv9 =a_Tmpv10
10421    a_Tmpv8 =(msfvy(i,j)/msfvx(i,j))*0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j)  &
10422    +sina(i,j-1))*0.25*a_Tmpv9
10423    a_Tmpv7 =a_Tmpv8
10424    a_rw(i,k,j) =a_rw(i,k,j) +a_Tmpv8
10425    a_Tmpv6 =a_Tmpv7
10426    a_rw(i,k+1,j) =a_rw(i,k+1,j) +a_Tmpv7
10427    a_rw(i,k+1,j-1) =a_rw(i,k+1,j-1) +a_Tmpv6
10428    a_rw(i,k,j-1) =a_rw(i,k,j-1) +a_Tmpv6
10429    a_rv_tend(i,k,j) =a_rv_tend(i,k,j) +a_Tmpv5
10430    a_Tmpv4 =-a_Tmpv5
10431    a_Tmpv3 =(msfvy(i,j)/msfvx(i,j))*0.5*(f(i,j)+f(i,j-1))*0.25*a_Tmpv4
10432    a_Tmpv2 =a_Tmpv3
10433    a_ru(i+1,k,j-1) =a_ru(i+1,k,j-1) +a_Tmpv3
10434    a_Tmpv1 =a_Tmpv2
10435    a_ru(i,k,j-1) =a_ru(i,k,j-1) +a_Tmpv2
10436    a_ru(i,k,j) =a_ru(i,k,j) +a_Tmpv1
10437    a_ru(i+1,k,j) =a_ru(i+1,k,j) +a_Tmpv1
10438    ENDDO
10439    ENDDO
10440
10441    ENDDO
10442
10443 !LPB[20]
10444
10445 !  IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
10446 !  DO k =kts, ktf
10447 !  DO i =its, min(ide-1, ite)
10448 !  Tmpv001 =ru(i,k,jts) +ru(i+1,k,jts)
10449 !  Tmpv002 =Tmpv001 +ru(i,k,jts)
10450 !  Tmpv003 =Tmpv002 +ru(i+1,k,jts)
10451 !  Tmpv004 =(msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))*0.25*Tmpv003
10452 !  Tmpv005 =rv_tend(i,k,jts) -Tmpv004
10453 !  Tmpv006 =rw(i,k+1,jts) +rw(i,k,jts)
10454 !  Tmpv007 =Tmpv006 +rw(i,k+1,jts)
10455 !  Tmpv008 =Tmpv007 +rw(i,k,jts)
10456 !  Tmpv009 =(msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts))*0.25*Tmpv008
10457 !  Tmpv010 =Tmpv005 +Tmpv009
10458 !  rv_tend(i,k,jts) =Tmpv010
10459
10460 !  ENDDO
10461 !  ENDDO
10462 !  ENDIF
10463
10464 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 XZ)
10465 !   IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
10466
10467 !   DO k =ktf, kts, -1
10468 !   DO i =min(ide-1, ite), its, -1
10469 !   a_Tmpv10 =a_rv_tend(i,k,jts)
10470 !   a_rv_tend(i,k,jts) =0.0
10471 !   a_Tmpv5 =a_Tmpv10
10472 !   a_Tmpv9 =a_Tmpv10
10473 !   a_Tmpv8 =(msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)  &
10474 !   +sina(i,jts))*0.25*a_Tmpv9
10475 !   a_Tmpv7 =a_Tmpv8
10476 !   a_rw(i,k,jts) =a_rw(i,k,jts) +a_Tmpv8
10477 !   a_Tmpv6 =a_Tmpv7
10478 !   a_rw(i,k+1,jts) =a_rw(i,k+1,jts) +a_Tmpv7
10479 !   a_rw(i,k+1,jts) =a_rw(i,k+1,jts) +a_Tmpv6
10480 !   a_rw(i,k,jts) =a_rw(i,k,jts) +a_Tmpv6
10481 !   a_rv_tend(i,k,jts) =a_rv_tend(i,k,jts) +a_Tmpv5
10482 !   a_Tmpv4 =-a_Tmpv5
10483 !   a_Tmpv3 =(msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))*0.25*a_Tmpv4
10484 !   a_Tmpv2 =a_Tmpv3
10485 !   a_ru(i+1,k,jts) =a_ru(i+1,k,jts) +a_Tmpv3
10486 !   a_Tmpv1 =a_Tmpv2
10487 !   a_ru(i,k,jts) =a_ru(i,k,jts) +a_Tmpv2
10488 !   a_ru(i,k,jts) =a_ru(i,k,jts) +a_Tmpv1
10489 !   a_ru(i+1,k,jts) =a_ru(i+1,k,jts) +a_Tmpv1
10490 !   ENDDO
10491 !   ENDDO
10492 !
10493 !   ENDIF
10494
10495 !LPB[19]
10496
10497 !LPB[18]
10498    DO j =j_end, j_start-1, -1
10499
10500 !  wkp1 =Keep_Lpb18_wkp1(j)
10501 !  wk =Keep_Lpb18_wk(j)
10502 !  wkm1 =Keep_Lpb18_wkm1(j)
10503
10504 ! Remarked by Ning Pan, 2010-07-22: redundant recalculation
10505 !   DO i =its, Tmpv001
10506 !   k =kts
10507 !   Tmpv001 =phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) +ph(i,k+1,j)
10508 !   Tmpv002 =Tmpv001 +ph(i-1,k,j)
10509 !   Tmpv003 =Tmpv002 +ph(i-1,k+1,j)
10510 !   Tmpv004 =0.25*Tmpv003
10511 !   Tmpv005 =Tmpv004/g
10512 !!  z_at_u =Tmpv005
10513
10514 !   wkp1 =min(1., max(0., z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))
10515
10516 !   wk =1. -wkp1
10517
10518 !   Tmpv001 =+wk*u_base(k) +wkp1*u_base(k+1)
10519 !   Tmpv200(i) =Tmpv001
10520 !   Tmpv002 =muu(i,j)*Tmpv200(i)
10521 !   Tmpv003 =ru_in(i,k,j) -Tmpv002
10522 !!  ru(i,k,j) =Tmpv003
10523
10524 !   k =ktf
10525 !   Tmpv001 =phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) +ph(i,k+1,j)
10526 !   Tmpv002 =Tmpv001 +ph(i-1,k,j)
10527 !   Tmpv003 =Tmpv002 +ph(i-1,k+1,j)
10528 !   Tmpv004 =0.25*Tmpv003
10529 !   Tmpv005 =Tmpv004/g
10530 !!  z_at_u =Tmpv005
10531
10532 !   wkm1 =min(1., max(0., z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))
10533
10534 !   wk =1. -wkm1
10535
10536 !   Tmpv001 =wkm1*u_base(k-1) +wk*u_base(k)
10537 !   Tmpv201(i) =Tmpv001
10538 !   Tmpv002 =muu(i,j)*Tmpv201(i)
10539 !   Tmpv003 =ru_in(i,k,j) -Tmpv002
10540 !!  ru(i,k,j) =Tmpv003
10541
10542 !   ENDDO
10543
10544 ! Revised by Ning Pan, 2010-07-22
10545 !   DO i =Tmpv001, its, -1
10546    DO i =MIN(ite,ide-1)+1, its, -1
10547
10548 !STOP  ! Remarked by Ning Pan, 2010-07-22
10549 !REVISED BY WALLS
10550 !  0.0 =a_Tmpv1
10551 ! Added by Ning Pan, 2010-07-22
10552    k = ktf
10553    z_at_u = Tmpv501(i,k,j)
10554
10555    a_Tmpv3 =a_ru(i,k,j)
10556    a_ru(i,k,j) =0.0
10557    a_ru_in(i,k,j) =a_ru_in(i,k,j) +a_Tmpv3
10558    a_Tmpv2 =-a_Tmpv3
10559 ! Revised by Ning Pan, 2010-07-22
10560 !   a_muu(i,j) =a_muu(i,j) +Tmpv201(i)*a_Tmpv2
10561    a_muu(i,j) =a_muu(i,j) +Tmpv500(i,k,j)*a_Tmpv2
10562    a_Tmpv1 =muu(i,j)*a_Tmpv2
10563    a_wkm1 =a_wkm1 +u_base(k-1)*a_Tmpv1
10564    a_wk =a_wk +u_base(k)*a_Tmpv1
10565    a_wkm1 =a_wkm1 -a_wk
10566    a_wk =0.0
10567    a_z_at_u =a_z_at_u +((-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_u))  &
10568    *0.5/(z_base(k)-z_base(k-1)) -(-(-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_u))  &
10569    *0.5/(z_base(k)-z_base(k-1)))*sign(1.0, 1. -max(0., z_base(k) -z_at_u)/(z_base(k)  &
10570    -z_base(k-1))))*0.5*a_wkm1
10571    a_wkm1 =0.0
10572    a_Tmpv5 =a_z_at_u
10573    a_z_at_u =0.0
10574    a_Tmpv4 =a_Tmpv5/g
10575    a_Tmpv3 =0.25*a_Tmpv4
10576    a_Tmpv2 =a_Tmpv3
10577    a_ph(i-1,k+1,j) =a_ph(i-1,k+1,j) +a_Tmpv3
10578    a_Tmpv1 =a_Tmpv2
10579    a_ph(i-1,k,j) =a_ph(i-1,k,j) +a_Tmpv2
10580    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
10581    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
10582
10583 ! Added by Ning Pan, 2010-07-22
10584    k = kts
10585    z_at_u = Tmpv501(i,k,j)
10586
10587    a_Tmpv3 =a_ru(i,k,j)
10588    a_ru(i,k,j) =0.0
10589    a_ru_in(i,k,j) =a_ru_in(i,k,j) +a_Tmpv3
10590    a_Tmpv2 =-a_Tmpv3
10591 ! Revised by Ning Pan, 2010-07-22
10592 !   a_muu(i,j) =a_muu(i,j) +Tmpv200(i)*a_Tmpv2
10593    a_muu(i,j) =a_muu(i,j) +Tmpv500(i,k,j)*a_Tmpv2
10594    a_Tmpv1 =muu(i,j)*a_Tmpv2
10595    a_wk =a_wk +u_base(k)*a_Tmpv1
10596    a_wkp1 =a_wkp1 +u_base(k+1)*a_Tmpv1
10597    a_wkp1 =a_wkp1 -a_wk
10598    a_wk =0.0
10599    a_z_at_u =a_z_at_u +((1.0 +(-1.0)*sign(1.0, 0. -z_at_u -z_base(k)))  &
10600    *0.5/(z_base(k+1)-z_base(k)) -(-(1.0 +(-1.0)*sign(1.0, 0. -z_at_u -z_base(k)))  &
10601    *0.5/(z_base(k+1)-z_base(k)))*sign(1.0, 1. -max(0., z_at_u -z_base(k))/(z_base(k+1)  &
10602    -z_base(k))))*0.5*a_wkp1
10603    a_wkp1 =0.0
10604    a_Tmpv5 =a_z_at_u
10605    a_z_at_u =0.0
10606    a_Tmpv4 =a_Tmpv5/g
10607    a_Tmpv3 =0.25*a_Tmpv4
10608    a_Tmpv2 =a_Tmpv3
10609    a_ph(i-1,k+1,j) =a_ph(i-1,k+1,j) +a_Tmpv3
10610    a_Tmpv1 =a_Tmpv2
10611    a_ph(i-1,k,j) =a_ph(i-1,k,j) +a_Tmpv2
10612    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
10613    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
10614    ENDDO
10615
10616    ENDDO
10617
10618 !LPB[17]
10619    DO j =j_end, j_start-1, -1
10620
10621 ! Remarked by Ning Pan, 2010-07-22: redundant recalculation
10622 !   wkp1 =Keep_Lpb17_wkp1(j)
10623 !   wkm1 =Keep_Lpb17_wkm1(j)
10624 !   wk =Keep_Lpb17_wk(j)
10625
10626 !   DO k =kts+1, ktf-1
10627 !   DO i =its, Tmpv001
10628 !   Tmpv001 =phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) +ph(i,k+1,j)
10629 !   Tmpv002 =Tmpv001 +ph(i-1,k,j)
10630 !   Tmpv003 =Tmpv002 +ph(i-1,k+1,j)
10631 !   Tmpv004 =0.25*Tmpv003
10632 !   Tmpv005 =Tmpv004/g
10633 !!  z_at_u =Tmpv005
10634
10635 !   wkp1 =min(1., max(0., z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))
10636
10637 !   wkm1 =min(1., max(0., z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))
10638
10639 !   Tmpv001 =1. -wkp1 -wkm1
10640 !   wk =Tmpv001
10641
10642 !   Tmpv001 =wkm1*u_base(k-1) +wk*u_base(k)
10643 !   Tmpv002 =Tmpv001 +wkp1*u_base(k+1)
10644 !   Tmpv300(i,k) =Tmpv002
10645 !   Tmpv003 =muu(i,j)*Tmpv300(i,k)
10646 !   Tmpv004 =ru_in(i,k,j) -Tmpv003
10647 !!  ru(i,k,j) =Tmpv004
10648
10649 !   ENDDO
10650 !   ENDDO
10651
10652    DO k =ktf-1, kts+1, -1
10653 ! Revised by Ning Pan, 2010-07-22
10654 !   DO i =Tmpv001, its, -1
10655    DO i =MIN(ite,ide-1)+1, its, -1
10656
10657 !STOP  ! Remarked by Ning Pan, 2010-07-22
10658 !REVISED BY WALLS
10659 !  0.0 =a_Tmpv1
10660    z_at_u = Tmpv501(i,k,j)  ! Added by Ning Pan, 2010-07-22
10661    a_Tmpv4 =a_ru(i,k,j)
10662    a_ru(i,k,j) =0.0
10663    a_ru_in(i,k,j) =a_ru_in(i,k,j) +a_Tmpv4
10664    a_Tmpv3 =-a_Tmpv4
10665 ! Revised by Ning Pan, 2010-07-22
10666 !   a_muu(i,j) =a_muu(i,j) +Tmpv300(i,k)*a_Tmpv3
10667    a_muu(i,j) =a_muu(i,j) +Tmpv500(i,k,j)*a_Tmpv3
10668    a_Tmpv2 =muu(i,j)*a_Tmpv3
10669    a_Tmpv1 =a_Tmpv2
10670    a_wkp1 =a_wkp1 +u_base(k+1)*a_Tmpv2
10671    a_wkm1 =a_wkm1 +u_base(k-1)*a_Tmpv1
10672    a_wk =a_wk +u_base(k)*a_Tmpv1
10673    a_Tmpv1 =a_wk
10674    a_wk =0.0
10675    a_wkp1 =a_wkp1 -a_Tmpv1
10676    a_wkm1 =a_wkm1 -a_Tmpv1
10677 !REVISED BY WALLS
10678 !  a_z_at_u =a_z_at_u +((-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_u))  &
10679    a_z_at_u =a_z_at_u +((-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_u))  &
10680    *0.5/(z_base(k)-z_base(k-1)) -(-(-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_u))  &
10681    *0.5/(z_base(k)-z_base(k-1)))*sign(1.0, 1. -max(0., z_base(k) -z_at_u)/(z_base(k)  &
10682    -z_base(k-1))))*0.5*a_wkm1
10683    a_wkm1 =0.0
10684    a_z_at_u =a_z_at_u +((1.0 +(-1.0)*sign(1.0, 0. -z_at_u -z_base(k)))  &
10685    *0.5/(z_base(k+1)-z_base(k)) -(-(1.0 +(-1.0)*sign(1.0, 0. -z_at_u -z_base(k)))  &
10686    *0.5/(z_base(k+1)-z_base(k)))*sign(1.0, 1. -max(0., z_at_u -z_base(k))/(z_base(k+1)  &
10687    -z_base(k))))*0.5*a_wkp1
10688    a_wkp1 =0.0
10689    a_Tmpv5 =a_z_at_u
10690    a_z_at_u =0.0
10691    a_Tmpv4 =a_Tmpv5/g
10692    a_Tmpv3 =0.25*a_Tmpv4
10693    a_Tmpv2 =a_Tmpv3
10694    a_ph(i-1,k+1,j) =a_ph(i-1,k+1,j) +a_Tmpv3
10695    a_Tmpv1 =a_Tmpv2
10696    a_ph(i-1,k,j) =a_ph(i-1,k,j) +a_Tmpv2
10697    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
10698    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
10699    ENDDO
10700    ENDDO
10701
10702    ENDDO
10703
10704 !LPB[16]
10705
10706 !  IF( config_flags%open_ye .or. specified .or.                 config_flags%nested .or. config_flags%polar) THEN
10707 !  j_end =min(jde-1, jte)
10708 !  END IF
10709
10710 !  IF( config_flags%open_ye .or. specified .or.   &
10711 !           config_flags%nested .or. config_flags%polar) THEN
10712
10713 !  END IF
10714
10715 !LPB[15]
10716
10717 !LPB[14]
10718
10719 !  IF( config_flags%open_ys .or. specified .or.                 config_flags%nested .or. config_flags%polar) THEN
10720 !  j_start =max(jds+1, jts)
10721 !  END IF
10722
10723 !  IF( config_flags%open_ys .or. specified .or.   &
10724 !           config_flags%nested .or. config_flags%polar) THEN
10725
10726 !  END IF
10727
10728 !LPB[13]
10729 !  j_start =jts
10730 !  j_end =jte
10731
10732 ! Added by Ning Pan, 2010-07-22
10733 ! coriolis for u-momentum equation
10734    i_start = its
10735    i_end   = ite
10736    IF ( config_flags%open_xs .or. specified .or. &
10737         config_flags%nested) i_start = MAX(ids+1,its)
10738    IF ( config_flags%open_xe .or. specified .or. &
10739         config_flags%nested) i_end   = MIN(ide-1,ite)
10740       IF ( config_flags%periodic_x ) i_start = its
10741       IF ( config_flags%periodic_x ) i_end = ite
10742
10743 !!LPB[12]
10744    DO j =min(jte, jde-1), jts, -1
10745
10746 !  DO k =kts, ktf
10747 !  DO i =i_start, i_end
10748 !  Tmpv001 =rv(i-1,k,j+1) +rv(i,k,j+1)
10749 !  Tmpv002 =Tmpv001 +rv(i-1,k,j)
10750 !  Tmpv003 =Tmpv002 +rv(i,k,j)
10751 !  Tmpv004 =(msfux(i,j)/msfuy(i,j))*0.5*(f(i,j)+f(i-1,j))*0.25*Tmpv003
10752 !  Tmpv005 =ru_tend(i,k,j) +Tmpv004
10753 !  Tmpv006 =rw(i-1,k+1,j) +rw(i-1,k,j)
10754 !  Tmpv007 =Tmpv006 +rw(i,k+1,j)
10755 !  Tmpv008 =Tmpv007 +rw(i,k,j)
10756 !  Tmpv009 =0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j))*0.25*Tmpv008
10757 !  Tmpv010 =Tmpv005 -Tmpv009
10758 !  ru_tend(i,k,j) =Tmpv010
10759
10760 !  ENDDO
10761 !  ENDDO
10762 !  IF( (config_flags%open_xs) .and. (its == ids) ) THEN
10763 !  DO k =kts, ktf
10764 !  Tmpv001 =rv(its,k,j+1) +rv(its,k,j+1) +rv(its,k,j)
10765 !  Tmpv002 =Tmpv001 +rv(its,k,j)
10766 !  Tmpv003 =(msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))*0.25*Tmpv002
10767 !  Tmpv004 =ru_tend(its,k,j) +Tmpv003
10768 !  Tmpv005 =rw(its,k+1,j) +rw(its,k,j)
10769 !  Tmpv006 =Tmpv005 +rw(its,k+1,j)
10770 !  Tmpv007 =Tmpv006 +rw(its,k,j)
10771 !  Tmpv008 =0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j))*0.25*Tmpv007
10772 !  Tmpv009 =Tmpv004 -Tmpv008
10773 !  ru_tend(its,k,j) =Tmpv009
10774
10775 !  ENDDO
10776
10777 !  ENDIF
10778 !  IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
10779 !  DO k =kts, ktf
10780 !  Tmpv001 =rv(ite-1,k,j+1) +rv(ite-1,k,j+1) +rv(ite-1,k,j)
10781 !  Tmpv002 =Tmpv001 +rv(ite-1,k,j)
10782 !  Tmpv003 =(msfux(ite,j)/msfuy(ite,j))*0.5*(f(ite-1,j)+f(ite-1,j))*0.25*Tmpv002
10783 !  Tmpv004 =ru_tend(ite,k,j) +Tmpv003
10784 !  Tmpv005 =rw(ite-1,k+1,j) +rw(ite-1,k,j)
10785 !  Tmpv006 =Tmpv005 +rw(ite-1,k+1,j)
10786 !  Tmpv007 =Tmpv006 +rw(ite-1,k,j)
10787 !  Tmpv008 =0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j))*0.25*Tmpv007
10788 !  Tmpv009 =Tmpv004 -Tmpv008
10789 !  ru_tend(ite,k,j) =Tmpv009
10790
10791 !  ENDDO
10792
10793 !  ENDIF
10794
10795 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 XZ)
10796 !  IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
10797
10798 !  DO k =ktf, kts, -1
10799 !  a_Tmpv9 =a_ru_tend(ite,k,j)
10800 !  a_ru_tend(ite,k,j) =0.0
10801 !  a_Tmpv4 =a_Tmpv9
10802 !  a_Tmpv8 =-a_Tmpv9
10803 !  a_Tmpv7 =0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j))*0.25*a_Tmpv8
10804 !  a_Tmpv6 =a_Tmpv7
10805 !  a_rw(ite-1,k,j) =a_rw(ite-1,k,j) +a_Tmpv7
10806 !  a_Tmpv5 =a_Tmpv6
10807 !  a_rw(ite-1,k+1,j) =a_rw(ite-1,k+1,j) +a_Tmpv6
10808 !  a_rw(ite-1,k+1,j) =a_rw(ite-1,k+1,j) +a_Tmpv5
10809 !  a_rw(ite-1,k,j) =a_rw(ite-1,k,j) +a_Tmpv5
10810 !  a_ru_tend(ite,k,j) =a_ru_tend(ite,k,j) +a_Tmpv4
10811 !  a_Tmpv3 =a_Tmpv4
10812 !  a_Tmpv2 =(msfux(ite,j)/msfuy(ite,j))*0.5*(f(ite-1,j)+f(ite-1,j))*0.25*a_Tmpv3
10813 !  a_Tmpv1 =a_Tmpv2
10814 !  a_rv(ite-1,k,j) =a_rv(ite-1,k,j) +a_Tmpv2
10815 !  a_rv(ite-1,k,j+1) =a_rv(ite-1,k,j+1) +(1.0 +1.0)*a_Tmpv1
10816 !  a_rv(ite-1,k,j) =a_rv(ite-1,k,j) +a_Tmpv1
10817 !  ENDDO
10818
10819 !  ENDIF
10820
10821 !  IF( (config_flags%open_xs) .and. (its == ids) ) THEN
10822
10823 !  DO k =ktf, kts, -1
10824 !  a_Tmpv9 =a_ru_tend(its,k,j)
10825 !  a_ru_tend(its,k,j) =0.0
10826 !  a_Tmpv4 =a_Tmpv9
10827 !  a_Tmpv8 =-a_Tmpv9
10828 !  a_Tmpv7 =0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j))*0.25*a_Tmpv8
10829 !  a_Tmpv6 =a_Tmpv7
10830 !  a_rw(its,k,j) =a_rw(its,k,j) +a_Tmpv7
10831 !  a_Tmpv5 =a_Tmpv6
10832 !  a_rw(its,k+1,j) =a_rw(its,k+1,j) +a_Tmpv6
10833 !  a_rw(its,k+1,j) =a_rw(its,k+1,j) +a_Tmpv5
10834 !  a_rw(its,k,j) =a_rw(its,k,j) +a_Tmpv5
10835 !  a_ru_tend(its,k,j) =a_ru_tend(its,k,j) +a_Tmpv4
10836 !  a_Tmpv3 =a_Tmpv4
10837 !  a_Tmpv2 =(msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))*0.25*a_Tmpv3
10838 !  a_Tmpv1 =a_Tmpv2
10839 !  a_rv(its,k,j) =a_rv(its,k,j) +a_Tmpv2
10840 !  a_rv(its,k,j+1) =a_rv(its,k,j+1) +(1.0 +1.0)*a_Tmpv1
10841 !  a_rv(its,k,j) =a_rv(its,k,j) +a_Tmpv1
10842 !  ENDDO
10843
10844 !  ENDIF
10845
10846    DO k =ktf, kts, -1
10847    DO i =i_end, i_start, -1
10848    a_Tmpv10 =a_ru_tend(i,k,j)
10849    a_ru_tend(i,k,j) =0.0
10850    a_Tmpv5 =a_Tmpv10
10851    a_Tmpv9 =-a_Tmpv10
10852    a_Tmpv8 =0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j))*0.25*a_Tmpv9
10853    a_Tmpv7 =a_Tmpv8
10854    a_rw(i,k,j) =a_rw(i,k,j) +a_Tmpv8
10855    a_Tmpv6 =a_Tmpv7
10856    a_rw(i,k+1,j) =a_rw(i,k+1,j) +a_Tmpv7
10857    a_rw(i-1,k+1,j) =a_rw(i-1,k+1,j) +a_Tmpv6
10858    a_rw(i-1,k,j) =a_rw(i-1,k,j) +a_Tmpv6
10859    a_ru_tend(i,k,j) =a_ru_tend(i,k,j) +a_Tmpv5
10860    a_Tmpv4 =a_Tmpv5
10861    a_Tmpv3 =(msfux(i,j)/msfuy(i,j))*0.5*(f(i,j)+f(i-1,j))*0.25*a_Tmpv4
10862    a_Tmpv2 =a_Tmpv3
10863    a_rv(i,k,j) =a_rv(i,k,j) +a_Tmpv3
10864    a_Tmpv1 =a_Tmpv2
10865    a_rv(i-1,k,j) =a_rv(i-1,k,j) +a_Tmpv2
10866    a_rv(i-1,k,j+1) =a_rv(i-1,k,j+1) +a_Tmpv1
10867    a_rv(i,k,j+1) =a_rv(i,k,j+1) +a_Tmpv1
10868    ENDDO
10869    ENDDO
10870
10871    ENDDO
10872
10873 !LPB[11]
10874 ! Revised by Ning Pan, 2010-07-22
10875 !   DO j =Tmpv001, jts, -1
10876    DO j =MIN(jte,jde-1)+1, jts, -1
10877
10878 ! Remarked by Ning Pan, 2010-07-22: redundant recalculation
10879 !   wkp1 =Keep_Lpb11_wkp1(j)
10880 !   wk =Keep_Lpb11_wk(j)
10881 !   wkm1 =Keep_Lpb11_wkm1(j)
10882
10883 !   DO i =i_start-1, i_end
10884 !   k =kts
10885 !   Tmpv001 =phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) +ph(i,k+1,j)
10886 !   Tmpv002 =Tmpv001 +ph(i,k,j-1)
10887 !   Tmpv003 =Tmpv002 +ph(i,k+1,j-1)
10888 !   Tmpv004 =0.25*Tmpv003
10889 !   Tmpv005 =Tmpv004/g
10890 !!  z_at_v =Tmpv005
10891
10892 !   wkp1 =min(1., max(0., z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))
10893
10894 !   wk =1. -wkp1
10895
10896 !   Tmpv001 =+wk*v_base(k) +wkp1*v_base(k+1)
10897 !   Tmpv200(i) =Tmpv001
10898 !   Tmpv002 =muv(i,j)*Tmpv200(i)
10899 !   Tmpv003 =rv_in(i,k,j) -Tmpv002
10900 !!  rv(i,k,j) =Tmpv003
10901
10902 !   k =ktf
10903 !   Tmpv001 =phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) +ph(i,k+1,j)
10904 !   Tmpv002 =Tmpv001 +ph(i,k,j-1)
10905 !   Tmpv003 =Tmpv002 +ph(i,k+1,j-1)
10906 !   Tmpv004 =0.25*Tmpv003
10907 !   Tmpv005 =Tmpv004/g
10908 !!  z_at_v =Tmpv005
10909
10910 !   wkm1 =min(1., max(0., z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))
10911
10912 !   wk =1. -wkm1
10913
10914 !   Tmpv001 =wkm1*v_base(k-1) +wk*v_base(k)
10915 !   Tmpv201(i) =Tmpv001
10916 !   Tmpv002 =muv(i,j)*Tmpv201(i)
10917 !   Tmpv003 =rv_in(i,k,j) -Tmpv002
10918 !!  rv(i,k,j) =Tmpv003
10919
10920 !   ENDDO
10921
10922    DO i =i_end, i_start-1, -1
10923 ! Added by Ning Pan, 2010-07-22
10924    k = ktf
10925    z_at_v = Tmpv401(i,k,j)
10926
10927    a_Tmpv3 =a_rv(i,k,j)
10928    a_rv(i,k,j) =0.0
10929    a_rv_in(i,k,j) =a_rv_in(i,k,j) +a_Tmpv3
10930    a_Tmpv2 =-a_Tmpv3
10931 ! Revised by Ning Pan, 2010-07-22
10932 !   a_muv(i,j) =a_muv(i,j) +Tmpv201(i)*a_Tmpv2
10933    a_muv(i,j) =a_muv(i,j) +Tmpv400(i,k,j)*a_Tmpv2
10934    a_Tmpv1 =muv(i,j)*a_Tmpv2
10935    a_wkm1 =a_wkm1 +v_base(k-1)*a_Tmpv1
10936    a_wk =a_wk +v_base(k)*a_Tmpv1
10937    a_wkm1 =a_wkm1 -a_wk
10938    a_wk =0.0
10939    a_z_at_v =a_z_at_v +((-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_v))  &
10940    *0.5/(z_base(k)-z_base(k-1)) -(-(-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_v))  &
10941    *0.5/(z_base(k)-z_base(k-1)))*sign(1.0, 1. -max(0., z_base(k) -z_at_v)/(z_base(k)  &
10942    -z_base(k-1))))*0.5*a_wkm1
10943    a_wkm1 =0.0
10944    a_Tmpv5 =a_z_at_v
10945    a_z_at_v =0.0
10946    a_Tmpv4 =a_Tmpv5/g
10947    a_Tmpv3 =0.25*a_Tmpv4
10948    a_Tmpv2 =a_Tmpv3
10949    a_ph(i,k+1,j-1) =a_ph(i,k+1,j-1) +a_Tmpv3
10950    a_Tmpv1 =a_Tmpv2
10951    a_ph(i,k,j-1) =a_ph(i,k,j-1) +a_Tmpv2
10952    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
10953    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
10954
10955 ! Added by Ning Pan, 2010-07-22
10956    k = kts
10957    z_at_v = Tmpv401(i,k,j)
10958
10959    a_Tmpv3 =a_rv(i,k,j)
10960    a_rv(i,k,j) =0.0
10961    a_rv_in(i,k,j) =a_rv_in(i,k,j) +a_Tmpv3
10962    a_Tmpv2 =-a_Tmpv3
10963 ! Revised by Ning Pan, 2010-07-22
10964 !   a_muv(i,j) =a_muv(i,j) +Tmpv200(i)*a_Tmpv2
10965    a_muv(i,j) =a_muv(i,j) +Tmpv400(i,k,j)*a_Tmpv2
10966    a_Tmpv1 =muv(i,j)*a_Tmpv2
10967    a_wk =a_wk +v_base(k)*a_Tmpv1
10968    a_wkp1 =a_wkp1 +v_base(k+1)*a_Tmpv1
10969    a_wkp1 =a_wkp1 -a_wk
10970    a_wk =0.0
10971    a_z_at_v =a_z_at_v +((1.0 +(-1.0)*sign(1.0, 0. -z_at_v -z_base(k)))  &
10972    *0.5/(z_base(k+1)-z_base(k)) -(-(1.0 +(-1.0)*sign(1.0, 0. -z_at_v -z_base(k)))  &
10973    *0.5/(z_base(k+1)-z_base(k)))*sign(1.0, 1. -max(0., z_at_v -z_base(k))/(z_base(k+1)  &
10974    -z_base(k))))*0.5*a_wkp1
10975    a_wkp1 =0.0
10976    a_Tmpv5 =a_z_at_v
10977    a_z_at_v =0.0
10978    a_Tmpv4 =a_Tmpv5/g
10979    a_Tmpv3 =0.25*a_Tmpv4
10980    a_Tmpv2 =a_Tmpv3
10981    a_ph(i,k+1,j-1) =a_ph(i,k+1,j-1) +a_Tmpv3
10982    a_Tmpv1 =a_Tmpv2
10983    a_ph(i,k,j-1) =a_ph(i,k,j-1) +a_Tmpv2
10984    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
10985    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
10986    ENDDO
10987
10988    ENDDO
10989
10990 !LPB[10]
10991 ! Revised by Ning Pan, 2010-07-22
10992 !   DO j =Tmpv001, jts, -1
10993    DO j =MIN(jte,jde-1)+1, jts, -1
10994
10995 ! Remarked by Ning Pan, 2010-07-22: redundant recalculation
10996 !   DO k =kts+1, ktf-1
10997 !   DO i =i_start-1, i_end
10998 !   Tmpv001 =phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) +ph(i,k+1,j)
10999 !   Tmpv002 =Tmpv001 +ph(i,k,j-1)
11000 !   Tmpv003 =Tmpv002 +ph(i,k+1,j-1)
11001 !   Tmpv004 =0.25*Tmpv003
11002 !   Tmpv005 =Tmpv004/g
11003 !!  z_at_v =Tmpv005
11004
11005 !   wkp1 =min(1., max(0., z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))
11006
11007 !   wkm1 =min(1., max(0., z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))
11008
11009 !   Tmpv001 =1. -wkp1 -wkm1
11010 !   wk =Tmpv001
11011
11012 !   Tmpv001 =wkm1*v_base(k-1) +wk*v_base(k)
11013 !   Tmpv002 =Tmpv001 +wkp1*v_base(k+1)
11014 !   Tmpv300(i,k) =Tmpv002
11015 !   Tmpv003 =muv(i,j)*Tmpv300(i,k)
11016 !   Tmpv004 =rv_in(i,k,j) -Tmpv003
11017 !!  rv(i,k,j) =Tmpv004
11018
11019 !   ENDDO
11020 !   ENDDO
11021
11022    DO k =ktf-1, kts+1, -1
11023    DO i =i_end, i_start-1, -1
11024    z_at_v = Tmpv401(i,k,j)  ! Added by Ning Pan, 2010-07-22
11025    a_Tmpv4 =a_rv(i,k,j)
11026    a_rv(i,k,j) =0.0
11027    a_rv_in(i,k,j) =a_rv_in(i,k,j) +a_Tmpv4
11028    a_Tmpv3 =-a_Tmpv4
11029 ! Revised by Ning Pan, 2010-07-22
11030 !   a_muv(i,j) =a_muv(i,j) +Tmpv300(i,k)*a_Tmpv3
11031    a_muv(i,j) =a_muv(i,j) +Tmpv400(i,k,j)*a_Tmpv3
11032    a_Tmpv2 =muv(i,j)*a_Tmpv3
11033    a_Tmpv1 =a_Tmpv2
11034    a_wkp1 =a_wkp1 +v_base(k+1)*a_Tmpv2
11035    a_wkm1 =a_wkm1 +v_base(k-1)*a_Tmpv1
11036    a_wk =a_wk +v_base(k)*a_Tmpv1
11037    a_Tmpv1 =a_wk
11038    a_wk =0.0
11039    a_wkp1 =a_wkp1 -a_Tmpv1
11040    a_wkm1 =a_wkm1 -a_Tmpv1
11041    a_z_at_v =a_z_at_v +((-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_v))  &
11042    *0.5/(z_base(k)-z_base(k-1)) -(-(-1.0 +(1.0)*sign(1.0, 0. -z_base(k) -z_at_v))  &
11043    *0.5/(z_base(k)-z_base(k-1)))*sign(1.0, 1. -max(0., z_base(k) -z_at_v)/(z_base(k)  &
11044    -z_base(k-1))))*0.5*a_wkm1
11045    a_wkm1 =0.0
11046    a_z_at_v =a_z_at_v +((1.0 +(-1.0)*sign(1.0, 0. -z_at_v -z_base(k)))  &
11047    *0.5/(z_base(k+1)-z_base(k)) -(-(1.0 +(-1.0)*sign(1.0, 0. -z_at_v -z_base(k)))  &
11048    *0.5/(z_base(k+1)-z_base(k)))*sign(1.0, 1. -max(0., z_at_v -z_base(k))/(z_base(k+1)  &
11049    -z_base(k))))*0.5*a_wkp1
11050    a_wkp1 =0.0
11051    a_Tmpv5 =a_z_at_v
11052    a_z_at_v =0.0
11053    a_Tmpv4 =a_Tmpv5/g
11054    a_Tmpv3 =0.25*a_Tmpv4
11055    a_Tmpv2 =a_Tmpv3
11056    a_ph(i,k+1,j-1) =a_ph(i,k+1,j-1) +a_Tmpv3
11057    a_Tmpv1 =a_Tmpv2
11058    a_ph(i,k,j-1) =a_ph(i,k,j-1) +a_Tmpv2
11059    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
11060    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1
11061    ENDDO
11062    ENDDO
11063
11064    ENDDO
11065
11066 !LPB[9]
11067
11068 !  IF( config_flags%periodic_x ) THEN
11069 !  i_end =ite
11070 !  END IF
11071
11072 !  IF( config_flags%periodic_x ) THEN
11073
11074 !  END IF
11075
11076 !LPB[8]
11077
11078 !LPB[7]
11079
11080 !  IF( config_flags%periodic_x ) THEN
11081 !  i_start =its
11082 !  END IF
11083
11084 !  IF( config_flags%periodic_x ) THEN
11085
11086 !  END IF
11087
11088 !LPB[6]
11089
11090 !LPB[5]
11091
11092 !  IF( config_flags%open_xe .or. specified .or.                 config_flags%nested) THEN
11093 !  i_end =min(ide-1, ite)
11094 !  END IF
11095
11096 !  IF( config_flags%open_xe .or. specified .or.   &
11097 !           config_flags%nested) THEN
11098
11099 !  END IF
11100
11101 !LPB[4]
11102
11103 !LPB[3]
11104
11105 !  IF( config_flags%open_xs .or. specified .or.                 config_flags%nested) THEN
11106 !  i_start =max(ids+1, its)
11107 !  END IF
11108
11109 !  IF( config_flags%open_xs .or. specified .or.   &
11110 !           config_flags%nested) THEN
11111
11112 !  END IF
11113
11114 !LPB[2]
11115 !  ktf =min(kte, kde-1)
11116 !  i_start =its
11117 !  i_end =ite
11118
11119 !LPB[1]
11120
11121 !  IF(config_flags%specified .or. config_flags%nested) THEN
11122 !  specified =.true.
11123 !  END IF
11124
11125 !  IF(config_flags%specified .or. config_flags%nested) THEN
11126
11127 !  END IF
11128
11129 !LPB[0]
11130 !  specified =.false.
11131
11132    END SUBROUTINE a_perturbation_coriolis
11133
11134 !        Generated by TAPENADE     (INRIA, Tropics team)
11135 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
11136 !
11137 !  Differentiation of curvature in reverse (adjoint) mode:
11138 !   gradient     of useful results: u v ru_tend rw_tend ru rv rw
11139 !                rv_tend
11140 !   with respect to varying inputs: u v ru_tend rw_tend ru rv rw
11141 !                rv_tend
11142 !   RW status of diff variables: u:incr v:incr ru_tend:in-out rw_tend:in-out
11143 !                ru:incr rv:incr rw:incr rv_tend:in-out
11144 SUBROUTINE A_CURVATURE(ru, rub, rv, rvb, rw, rwb, u, ub, v, vb, w, &
11145 &  ru_tend, ru_tendb, rv_tend, rv_tendb, rw_tend, rw_tendb, config_flags&
11146 &  , msfux, msfuy, msfvx, msfvy, msftx, msfty, xlat, fzm, fzp, rdx, rdy, &
11147 &  ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, &
11148 &  jts, jte, kts, kte)
11149   IMPLICIT NONE
11150 ! Input data
11151   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
11152   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
11153 &  jme, kms, kme, its, ite, jts, jte, kts, kte
11154   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
11155 &  rv_tend, rw_tend
11156   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ru_tendb, rv_tendb, &
11157 &  rw_tendb
11158   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ru, rv, rw, &
11159 &  u, v, w
11160   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rub, rvb, rwb, ub, vb
11161   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
11162 &  msfvy, msftx, msfty, xlat
11163   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
11164   REAL, INTENT(IN) :: rdx, rdy
11165 ! Local data
11166 !   INTEGER :: i, j, k, itf, jtf, ktf, kp1, im, ip, jm, jp
11167   INTEGER :: i, j, k, itf, jtf, ktf
11168   INTEGER :: i_start, i_end, j_start, j_end
11169 !   INTEGER :: irmin, irmax, jrmin, jrmax
11170   REAL, DIMENSION(its - 1:ite, kts:kte, jts - 1:jte) :: vxgm
11171   REAL, DIMENSION(its-1:ite, kts:kte, jts-1:jte) :: vxgmb
11172   LOGICAL :: specified
11173   INTEGER :: ad_from
11174   INTEGER :: ad_to
11175   INTEGER :: ad_from0
11176   INTEGER :: ad_to0
11177   INTEGER :: ad_to1
11178   INTEGER :: ad_to2
11179   INTEGER :: ad_to3
11180   INTEGER :: ad_from1
11181   INTEGER :: branch
11182   INTEGER :: min6
11183   INTEGER :: min5
11184   INTEGER :: min4
11185   INTEGER :: min3
11186   INTEGER :: min2
11187   INTEGER :: min1
11188   REAL :: tempb3
11189   REAL :: tempb2
11190   REAL :: tempb1
11191   REAL :: tempb0
11192   REAL :: temp0b
11193   REAL :: temp0b9
11194   REAL :: temp0b8
11195   REAL :: temp0b19
11196   REAL :: temp0b7
11197   REAL :: temp0b18
11198   REAL :: temp0b6
11199   REAL :: temp0b17
11200   REAL :: temp0b5
11201   REAL :: temp0b16
11202   REAL :: tempb
11203   REAL :: temp0b4
11204   REAL :: temp0b15
11205   REAL :: temp0b3
11206   REAL :: temp0b14
11207   REAL :: temp0b2
11208   REAL :: temp0b13
11209   REAL :: temp0b1
11210   REAL :: temp0b12
11211   REAL :: temp0b0
11212   REAL :: temp0b11
11213   REAL :: temp0b10
11214   REAL :: temp
11215   INTEGER :: max1
11216 !<DESCRIPTION>
11217 !
11218 !  curvature calculates the large timestep tendency terms in the
11219 !  u, v, and w momentum equations arise from the curvature terms.
11220 !
11221 !</DESCRIPTION>
11222   specified = .false.
11223   IF (config_flags%specified .OR. config_flags%nested) specified = &
11224 &      .true.
11225   IF (kte .GT. kde - 1) THEN
11226     ktf = kde - 1
11227   ELSE
11228     ktf = kte
11229   END IF
11230 !   irmin = ims
11231 !   irmax = ime
11232 !   jrmin = jms
11233 !   jrmax = jme
11234 !   IF ( config_flags%open_xs ) irmin = ids
11235 !   IF ( config_flags%open_xe ) irmax = ide-1
11236 !   IF ( config_flags%open_ys ) jrmin = jds
11237 !   IF ( config_flags%open_ye ) jrmax = jde-1
11238 ! Define v cross grad m at scalar points - vxgm(i,j)
11239   i_start = its - 1
11240   i_end = ite
11241   j_start = jts - 1
11242   j_end = jte
11243   IF (((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
11244 &      .AND. its .EQ. ids) i_start = its
11245   IF (((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
11246 &      .AND. ite .EQ. ide) i_end = ite - 1
11247   IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
11248 &      .OR. config_flags%polar) .AND. jts .EQ. jds) j_start = jts
11249   IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
11250 &      .OR. config_flags%polar) .AND. jte .EQ. jde) j_end = jte - 1
11251   IF (config_flags%periodic_x) i_start = its - 1
11252   IF (config_flags%periodic_x) i_end = ite
11253   ad_from0 = j_start
11254   DO j=ad_from0,j_end
11255     DO k=kts,ktf
11256       ad_from = i_start
11257       DO i=ad_from,i_end
11258 !     Map scale factor notes:
11259 !     msf...y is constant everywhere for cylindrical map projection
11260 !     msf...x varies with y only
11261 !     But we know that this is not = 0 for cylindrical,
11262 !     therefore use msfvX in 1st line
11263 !     which => by symmetry use msfuY in 2nd line - ???
11264         vxgm(i, k, j) = 0.5*(u(i, k, j)+u(i+1, k, j))*(msfvx(i, j+1)-&
11265 &          msfvx(i, j))*rdy - 0.5*(v(i, k, j)+v(i, k, j+1))*(msfuy(i+1, j&
11266 &          )-msfuy(i, j))*rdx
11267       END DO
11268       CALL PUSHINTEGER4(i - 1)
11269       CALL PUSHINTEGER4(ad_from)
11270     END DO
11271   END DO
11272   CALL PUSHINTEGER4(j - 1)
11273   CALL PUSHINTEGER4(ad_from0)
11274 !  Pick up the boundary rows for open (radiation) lateral b.c.
11275 !  Rather crude at present, we are assuming there is no
11276 !    variation in this term at the boundary.
11277   IF (((config_flags%open_xs .OR. (specified .AND. (.NOT.config_flags%&
11278 &      periodic_x))) .OR. config_flags%nested) .AND. its .EQ. ids) THEN
11279     DO j=jts,jte-1
11280       DO k=kts,ktf
11281         vxgm(its-1, k, j) = vxgm(its, k, j)
11282       END DO
11283     END DO
11284     CALL PUSHCONTROL1B(0)
11285   ELSE
11286     CALL PUSHCONTROL1B(1)
11287   END IF
11288   IF (((config_flags%open_xe .OR. (specified .AND. (.NOT.config_flags%&
11289 &      periodic_x))) .OR. config_flags%nested) .AND. ite .EQ. ide) THEN
11290     DO j=jts,jte-1
11291       DO k=kts,ktf
11292         vxgm(ite, k, j) = vxgm(ite-1, k, j)
11293       END DO
11294     END DO
11295     CALL PUSHCONTROL1B(0)
11296   ELSE
11297     CALL PUSHCONTROL1B(1)
11298   END IF
11299 !  Polar boundary condition:
11300 !  The following change is needed in case one tries using the vxgm route with
11301 !  polar B.C.'s in the future, but not needed if 'tan' used
11302   IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
11303 &      .OR. config_flags%polar) .AND. jts .EQ. jds) THEN
11304     DO k=kts,ktf
11305       DO i=its-1,ite
11306         vxgm(i, k, jts-1) = vxgm(i, k, jts)
11307       END DO
11308     END DO
11309     CALL PUSHCONTROL1B(0)
11310   ELSE
11311     CALL PUSHCONTROL1B(1)
11312   END IF
11313 !  Polar boundary condition:
11314 !  The following change is needed in case one tries using the vxgm route with
11315 !  polar B.C.'s in the future, but not needed if 'tan' used
11316   IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
11317 &      .OR. config_flags%polar) .AND. jte .EQ. jde) THEN
11318     DO k=kts,ktf
11319       DO i=its-1,ite
11320         vxgm(i, k, jte) = vxgm(i, k, jte-1)
11321       END DO
11322     END DO
11323     CALL PUSHCONTROL1B(0)
11324   ELSE
11325     CALL PUSHCONTROL1B(1)
11326   END IF
11327 !  curvature term for u momentum eqn.
11328 !  Map scale factor notes:
11329 !  ADT eqn 44, RHS terms 4 and 5, in cylindrical: mu u v tan(lat)/(a my)
11330 !                                               - mu u w /(a my)
11331 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
11332 !   => terms are:
11333 !  (mx/my)*u rv tan(lat) / a - u rw / a = (u/a)*[(mx/my) rv tan(lat) - rw]
11334 !  ru v tan(lat) / a - u rw / a
11335 !  xlat defined with end points half grid space from pole,
11336 !  hence are on u latitude points
11337   i_start = its
11338   IF ((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
11339 &  THEN
11340     IF (ids + 1 .LT. its) THEN
11341       i_start = its
11342     ELSE
11343       i_start = ids + 1
11344     END IF
11345   END IF
11346   IF ((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
11347 &  THEN
11348     IF (ide - 1 .GT. ite) THEN
11349       i_end = ite
11350     ELSE
11351       i_end = ide - 1
11352     END IF
11353   END IF
11354   IF (config_flags%periodic_x) i_start = its
11355   IF (config_flags%periodic_x) i_end = ite
11356 !  Polar boundary condition
11357   IF (config_flags%map_proj .EQ. 6 .OR. config_flags%polar) THEN
11358     IF (jde - 1 .GT. jte) THEN
11359       min1 = jte
11360     ELSE
11361       min1 = jde - 1
11362     END IF
11363     CALL PUSHCONTROL1B(0)
11364   ELSE
11365     IF (jde - 1 .GT. jte) THEN
11366       min2 = jte
11367     ELSE
11368       min2 = jde - 1
11369     END IF
11370     CALL PUSHCONTROL1B(1)
11371   END IF
11372 !  curvature term for v momentum eqn.
11373 !  Map scale factor notes
11374 !  ADT eqn 45, RHS terms 4 and 5, in cylindrical:  - mu u*u tan(lat)/(a mx)
11375 !                                               - mu v w /(a mx)
11376 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
11377 !  terms are:
11378 !  - (my/mx)*u ru tan(lat) / a - (my/mx)*v rw / a
11379 !  = - [my/(mx*a)]*[u ru tan(lat) + v rw]
11380 !  - (1/a)*[(my/mx)*u ru tan(lat) + w rv]
11381 !  xlat defined with end points half grid space from pole, hence are on
11382 !  u latitude points => av here
11383 !
11384 !  in original wrf, there was a sign error for the rw contribution
11385   j_start = jts
11386   IF (((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
11387 &      .OR. config_flags%polar) THEN
11388     IF (jds + 1 .LT. jts) THEN
11389       j_start = jts
11390     ELSE
11391       j_start = jds + 1
11392     END IF
11393   END IF
11394   IF (((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
11395 &      .OR. config_flags%polar) THEN
11396     IF (jde - 1 .GT. jte) THEN
11397       j_end = jte
11398     ELSE
11399       j_end = jde - 1
11400     END IF
11401   END IF
11402   IF (config_flags%map_proj .EQ. 6 .OR. config_flags%polar) THEN
11403     DO j=j_start,j_end
11404       DO k=kts,ktf
11405         IF (ite .GT. ide - 1) THEN
11406           min3 = ide - 1
11407         ELSE
11408           min3 = ite
11409         END IF
11410         i = min3 + 1
11411         CALL PUSHINTEGER4(i - 1)
11412       END DO
11413     END DO
11414     CALL PUSHCONTROL1B(1)
11415   ELSE
11416 ! normal code
11417     DO j=j_start,j_end
11418       DO k=kts,ktf
11419         IF (ite .GT. ide - 1) THEN
11420           min4 = ide - 1
11421         ELSE
11422           min4 = ite
11423         END IF
11424         i = min4 + 1
11425         CALL PUSHINTEGER4(i - 1)
11426       END DO
11427     END DO
11428     CALL PUSHCONTROL1B(0)
11429   END IF
11430   IF (jte .GT. jde - 1) THEN
11431     min5 = jde - 1
11432   ELSE
11433     min5 = jte
11434   END IF
11435 !  curvature term for vertical momentum eqn.
11436 !  Notes on map scale factors:
11437 !  ADT eqn 46, RHS term 4: [mu/(a my)]*[u*u + v*v]
11438 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
11439 !  terms are: u ru / a + (mx/my)v rv / a
11440   DO j=jts,min5
11441     IF (2 .LT. kts) THEN
11442       max1 = kts
11443     ELSE
11444       max1 = 2
11445     END IF
11446     ad_from1 = max1
11447     DO k=ad_from1,ktf
11448       IF (ite .GT. ide - 1) THEN
11449         min6 = ide - 1
11450       ELSE
11451         min6 = ite
11452       END IF
11453       i = min6 + 1
11454       CALL PUSHINTEGER4(i - 1)
11455     END DO
11456     CALL PUSHINTEGER4(ad_from1)
11457   END DO
11458   DO j=min5,jts,-1
11459     CALL POPINTEGER4(ad_from1)
11460     DO k=ktf,ad_from1,-1
11461       CALL POPINTEGER4(ad_to3)
11462       DO i=ad_to3,its,-1
11463         temp0b14 = reradius*0.5**2*rw_tendb(i, k, j)
11464         temp0b15 = (fzm(k)*(u(i, k, j)+u(i+1, k, j))+fzp(k)*(u(i, k-1, j&
11465 &          )+u(i+1, k-1, j)))*temp0b14
11466         temp0b16 = (fzm(k)*(ru(i, k, j)+ru(i+1, k, j))+fzp(k)*(ru(i, k-1&
11467 &          , j)+ru(i+1, k-1, j)))*temp0b14
11468         temp0b17 = reradius*msftx(i, j)*0.5**2*rw_tendb(i, k, j)
11469         temp0b18 = (fzm(k)*(v(i, k, j)+v(i, k, j+1))+fzp(k)*(v(i, k-1, j&
11470 &          )+v(i, k-1, j+1)))*temp0b17/msfty(i, j)
11471         temp0b19 = (fzm(k)*(rv(i, k, j)+rv(i, k, j+1))+fzp(k)*(rv(i, k-1&
11472 &          , j)+rv(i, k-1, j+1)))*temp0b17/msfty(i, j)
11473         rub(i, k, j) = rub(i, k, j) + fzm(k)*temp0b15
11474         rub(i+1, k, j) = rub(i+1, k, j) + fzm(k)*temp0b15
11475         rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp0b15
11476         rub(i+1, k-1, j) = rub(i+1, k-1, j) + fzp(k)*temp0b15
11477         ub(i, k, j) = ub(i, k, j) + fzm(k)*temp0b16
11478         ub(i+1, k, j) = ub(i+1, k, j) + fzm(k)*temp0b16
11479         ub(i, k-1, j) = ub(i, k-1, j) + fzp(k)*temp0b16
11480         ub(i+1, k-1, j) = ub(i+1, k-1, j) + fzp(k)*temp0b16
11481         rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp0b18
11482         rvb(i, k, j+1) = rvb(i, k, j+1) + fzm(k)*temp0b18
11483         rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp0b18
11484         rvb(i, k-1, j+1) = rvb(i, k-1, j+1) + fzp(k)*temp0b18
11485         vb(i, k, j) = vb(i, k, j) + fzm(k)*temp0b19
11486         vb(i, k, j+1) = vb(i, k, j+1) + fzm(k)*temp0b19
11487         vb(i, k-1, j) = vb(i, k-1, j) + fzp(k)*temp0b19
11488         vb(i, k-1, j+1) = vb(i, k-1, j+1) + fzp(k)*temp0b19
11489       END DO
11490     END DO
11491   END DO
11492   CALL POPCONTROL1B(branch)
11493   IF (branch .EQ. 0) THEN
11494     vxgmb = 0.0
11495     DO j=j_end,j_start,-1
11496       DO k=ktf,kts,-1
11497         CALL POPINTEGER4(ad_to2)
11498         DO i=ad_to2,its,-1
11499           temp0b9 = -(0.25*0.5*rv_tendb(i, k, j))
11500           temp0b10 = (ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j-1)+ru(i+1, k&
11501 &            , j-1))*temp0b9
11502           temp0b11 = (vxgm(i, k, j)+vxgm(i, k, j-1))*temp0b9
11503           temp0b12 = -(msfvy(i, j)*reradius*0.25*rv_tendb(i, k, j))
11504           temp0b13 = v(i, k, j)*temp0b12/msfvx(i, j)
11505           vxgmb(i, k, j) = vxgmb(i, k, j) + temp0b10
11506           vxgmb(i, k, j-1) = vxgmb(i, k, j-1) + temp0b10
11507           rub(i, k, j) = rub(i, k, j) + temp0b11
11508           rub(i+1, k, j) = rub(i+1, k, j) + temp0b11
11509           rub(i, k, j-1) = rub(i, k, j-1) + temp0b11
11510           rub(i+1, k, j-1) = rub(i+1, k, j-1) + temp0b11
11511           vb(i, k, j) = vb(i, k, j) + (rw(i, k+1, j-1)+rw(i, k, j-1)+rw(&
11512 &            i, k+1, j)+rw(i, k, j))*temp0b12/msfvx(i, j)
11513           rwb(i, k+1, j-1) = rwb(i, k+1, j-1) + temp0b13
11514           rwb(i, k, j-1) = rwb(i, k, j-1) + temp0b13
11515           rwb(i, k+1, j) = rwb(i, k+1, j) + temp0b13
11516           rwb(i, k, j) = rwb(i, k, j) + temp0b13
11517         END DO
11518       END DO
11519     END DO
11520   ELSE
11521     DO j=j_end,j_start,-1
11522       DO k=ktf,kts,-1
11523         CALL POPINTEGER4(ad_to1)
11524         DO i=ad_to1,its,-1
11525           temp0b4 = -(msfvy(i, j)*reradius*rv_tendb(i, k, j)/msfvx(i, j)&
11526 &            )
11527           temp0b5 = TAN((xlat(i, j)+xlat(i, j-1))*(degrad*0.5))*0.25**2*&
11528 &            temp0b4
11529           temp0b6 = (ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j-1)+ru(i+1, k, &
11530 &            j-1))*temp0b5
11531           temp0b7 = (u(i, k, j)+u(i+1, k, j)+u(i, k, j-1)+u(i+1, k, j-1)&
11532 &            )*temp0b5
11533           temp0b8 = 0.25*v(i, k, j)*temp0b4
11534           ub(i, k, j) = ub(i, k, j) + temp0b6
11535           ub(i+1, k, j) = ub(i+1, k, j) + temp0b6
11536           ub(i, k, j-1) = ub(i, k, j-1) + temp0b6
11537           ub(i+1, k, j-1) = ub(i+1, k, j-1) + temp0b6
11538           rub(i, k, j) = rub(i, k, j) + temp0b7
11539           rub(i+1, k, j) = rub(i+1, k, j) + temp0b7
11540           rub(i, k, j-1) = rub(i, k, j-1) + temp0b7
11541           rub(i+1, k, j-1) = rub(i+1, k, j-1) + temp0b7
11542           vb(i, k, j) = vb(i, k, j) + 0.25*(rw(i, k+1, j-1)+rw(i, k, j-1&
11543 &            )+rw(i, k+1, j)+rw(i, k, j))*temp0b4
11544           rwb(i, k+1, j-1) = rwb(i, k+1, j-1) + temp0b8
11545           rwb(i, k, j-1) = rwb(i, k, j-1) + temp0b8
11546           rwb(i, k+1, j) = rwb(i, k+1, j) + temp0b8
11547           rwb(i, k, j) = rwb(i, k, j) + temp0b8
11548         END DO
11549       END DO
11550     END DO
11551     vxgmb = 0.0
11552   END IF
11553   CALL POPCONTROL1B(branch)
11554   IF (branch .EQ. 0) THEN
11555     DO j=min1,jts,-1
11556       DO k=ktf,kts,-1
11557         DO i=i_end,i_start,-1
11558           temp = 0.25*msfux(i, j)*TAN(xlat(i, j)*degrad)
11559           tempb1 = reradius*u(i, k, j)*ru_tendb(i, k, j)
11560           tempb2 = temp*tempb1/msfuy(i, j)
11561           tempb3 = -(0.25*tempb1)
11562           ub(i, k, j) = ub(i, k, j) + reradius*(temp*((rv(i-1, k, j+1)+&
11563 &            rv(i, k, j+1)+rv(i-1, k, j)+rv(i, k, j))/msfuy(i, j))-0.25*(&
11564 &            rw(i-1, k+1, j)+rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j)))*&
11565 &            ru_tendb(i, k, j)
11566           rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + tempb2
11567           rvb(i, k, j+1) = rvb(i, k, j+1) + tempb2
11568           rvb(i-1, k, j) = rvb(i-1, k, j) + tempb2
11569           rvb(i, k, j) = rvb(i, k, j) + tempb2
11570           rwb(i-1, k+1, j) = rwb(i-1, k+1, j) + tempb3
11571           rwb(i-1, k, j) = rwb(i-1, k, j) + tempb3
11572           rwb(i, k+1, j) = rwb(i, k+1, j) + tempb3
11573           rwb(i, k, j) = rwb(i, k, j) + tempb3
11574         END DO
11575       END DO
11576     END DO
11577   ELSE
11578     DO j=min2,jts,-1
11579       DO k=ktf,kts,-1
11580         DO i=i_end,i_start,-1
11581           temp0b = 0.25*0.5*ru_tendb(i, k, j)
11582           temp0b0 = (rv(i-1, k, j+1)+rv(i, k, j+1)+rv(i-1, k, j)+rv(i, k&
11583 &            , j))*temp0b
11584           temp0b1 = (vxgm(i, k, j)+vxgm(i-1, k, j))*temp0b
11585           temp0b2 = -(reradius*0.25*ru_tendb(i, k, j))
11586           temp0b3 = u(i, k, j)*temp0b2
11587           vxgmb(i, k, j) = vxgmb(i, k, j) + temp0b0
11588           vxgmb(i-1, k, j) = vxgmb(i-1, k, j) + temp0b0
11589           rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + temp0b1
11590           rvb(i, k, j+1) = rvb(i, k, j+1) + temp0b1
11591           rvb(i-1, k, j) = rvb(i-1, k, j) + temp0b1
11592           rvb(i, k, j) = rvb(i, k, j) + temp0b1
11593           ub(i, k, j) = ub(i, k, j) + (rw(i-1, k+1, j)+rw(i-1, k, j)+rw(&
11594 &            i, k+1, j)+rw(i, k, j))*temp0b2
11595           rwb(i-1, k+1, j) = rwb(i-1, k+1, j) + temp0b3
11596           rwb(i-1, k, j) = rwb(i-1, k, j) + temp0b3
11597           rwb(i, k+1, j) = rwb(i, k+1, j) + temp0b3
11598           rwb(i, k, j) = rwb(i, k, j) + temp0b3
11599         END DO
11600       END DO
11601     END DO
11602   END IF
11603   CALL POPCONTROL1B(branch)
11604   IF (branch .EQ. 0) THEN
11605     DO k=ktf,kts,-1
11606       DO i=ite,its-1,-1
11607         vxgmb(i, k, jte-1) = vxgmb(i, k, jte-1) + vxgmb(i, k, jte)
11608         vxgmb(i, k, jte) = 0.0
11609       END DO
11610     END DO
11611   END IF
11612   CALL POPCONTROL1B(branch)
11613   IF (branch .EQ. 0) THEN
11614     DO k=ktf,kts,-1
11615       DO i=ite,its-1,-1
11616         vxgmb(i, k, jts) = vxgmb(i, k, jts) + vxgmb(i, k, jts-1)
11617         vxgmb(i, k, jts-1) = 0.0
11618       END DO
11619     END DO
11620   END IF
11621   CALL POPCONTROL1B(branch)
11622   IF (branch .EQ. 0) THEN
11623     DO j=jte-1,jts,-1
11624       DO k=ktf,kts,-1
11625         vxgmb(ite-1, k, j) = vxgmb(ite-1, k, j) + vxgmb(ite, k, j)
11626         vxgmb(ite, k, j) = 0.0
11627       END DO
11628     END DO
11629   END IF
11630   CALL POPCONTROL1B(branch)
11631   IF (branch .EQ. 0) THEN
11632     DO j=jte-1,jts,-1
11633       DO k=ktf,kts,-1
11634         vxgmb(its, k, j) = vxgmb(its, k, j) + vxgmb(its-1, k, j)
11635         vxgmb(its-1, k, j) = 0.0
11636       END DO
11637     END DO
11638   END IF
11639   CALL POPINTEGER4(ad_from0)
11640   CALL POPINTEGER4(ad_to0)
11641   DO j=ad_to0,ad_from0,-1
11642     DO k=ktf,kts,-1
11643       CALL POPINTEGER4(ad_from)
11644       CALL POPINTEGER4(ad_to)
11645       DO i=ad_to,ad_from,-1
11646         tempb = (msfvx(i, j+1)-msfvx(i, j))*rdy*0.5*vxgmb(i, k, j)
11647         tempb0 = -((msfuy(i+1, j)-msfuy(i, j))*rdx*0.5*vxgmb(i, k, j))
11648         ub(i, k, j) = ub(i, k, j) + tempb
11649         ub(i+1, k, j) = ub(i+1, k, j) + tempb
11650         vb(i, k, j) = vb(i, k, j) + tempb0
11651         vb(i, k, j+1) = vb(i, k, j+1) + tempb0
11652         vxgmb(i, k, j) = 0.0
11653       END DO
11654     END DO
11655   END DO
11656 END SUBROUTINE A_CURVATURE
11657
11658    SUBROUTINE a_zero_tend(a_tendency,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
11659    jme,kms,kme,its,ite,jts,jte,kts,kte)
11660
11661 !PART I: DECLARATION OF VARIABLES
11662
11663    IMPLICIT NONE
11664
11665    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
11666    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
11667    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_tendency
11668    INTEGER :: i,j,k,itf,jtf,ktf
11669
11670 !PART II: CALCULATIONS OF B. S. TRAJECTORY
11671
11672 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
11673
11674 !LPB[0]
11675    DO j =jte, jts, -1
11676
11677 !  DO k =kts, kte
11678 !  DO i =its, ite
11679 !  tendency(i,k,j) =0.
11680
11681 !  ENDDO
11682 !  ENDDO
11683
11684    DO k =kte, kts, -1
11685    DO i =ite, its, -1
11686    a_tendency(i,k,j) =0.0
11687    ENDDO
11688    ENDDO
11689
11690    ENDDO
11691
11692    END SUBROUTINE a_zero_tend
11693
11694 !        Generated by TAPENADE     (INRIA, Tropics team)
11695 !  Tapenade 3.6 (r4343) - 10 Feb 2012 10:52
11696 !
11697 !  Differentiation of zero_tend2d in reverse (adjoint) mode:
11698 !   gradient     of useful results: tendency
11699 !   with respect to varying inputs: tendency
11700 !   RW status of diff variables: tendency:in-out
11701 SUBROUTINE A_ZERO_TEND2D(tendencyb, ids, ide, jds, jde, kds, &
11702 &  kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
11703   IMPLICIT NONE
11704 ! Input data
11705   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
11706 &  jme, kms, kme, its, ite, jts, jte, kts, kte
11707   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: tendencyb
11708 ! Local data
11709   INTEGER :: i, j, k, itf, jtf, ktf
11710   DO j=jte,jts,-1
11711     DO i=ite,its,-1
11712       tendencyb(i, j) = 0.0
11713     END DO
11714   END DO
11715 END SUBROUTINE A_ZERO_TEND2D
11716
11717    SUBROUTINE a_zero_pole(field,a_field,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
11718    kme,its,ite,jts,jte,kts,kte)
11719
11720 !PART I: DECLARATION OF VARIABLES
11721
11722    IMPLICIT NONE
11723
11724    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
11725    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
11726    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field
11727    INTEGER :: i,k
11728
11729 !PART II: CALCULATIONS OF B. S. TRAJECTORY
11730
11731 !REVISED BY WALLS, BIG ERRORS
11732 !  IF (jts == jds) THEN
11733
11734 !  IF (jte == jde) THEN
11735
11736 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
11737
11738 !LPB[3]
11739
11740 !  IF(jte == jde) THEN
11741 !  DO k =kts, kte
11742 !  DO i =its-1, ite+1
11743 !  field(i,k,jte) =0.
11744
11745 !  ENDDO
11746 !  ENDDO
11747 !  END IF
11748
11749    IF(jte == jde) THEN
11750
11751    DO k =kte, kts, -1
11752    DO i =ite+1, its-1, -1
11753    a_field(i,k,jte) =0.0
11754    ENDDO
11755    ENDDO
11756
11757    END IF
11758
11759 !LPB[2]
11760
11761 !LPB[1]
11762
11763 !  IF(jts == jds) THEN
11764 !  DO k =kts, kte
11765 !  DO i =its-1, ite+1
11766 !  field(i,k,jts) =0.
11767
11768 !  ENDDO
11769 !  ENDDO
11770 !  END IF
11771
11772    IF(jts == jds) THEN
11773
11774    DO k =kte, kts, -1
11775    DO i =ite+1, its-1, -1
11776    a_field(i,k,jts) =0.0
11777    ENDDO
11778    ENDDO
11779
11780    END IF
11781
11782 !LPB[0]
11783
11784    END SUBROUTINE a_zero_pole
11785
11786    SUBROUTINE a_pole_point_bc(field,a_field,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
11787    kms,kme,its,ite,jts,jte,kts,kte)
11788
11789 !PART I: DECLARATION OF VARIABLES
11790
11791    IMPLICIT NONE
11792
11793    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
11794    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
11795    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field
11796    INTEGER :: i,k
11797
11798 !PART II: CALCULATIONS OF B. S. TRAJECTORY
11799
11800 !REVISED BY WALLS, BIG ERROR
11801 !  IF (jts == jds) THEN
11802
11803 !  IF (jte == jde) THEN
11804
11805 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
11806
11807 !LPB[3]
11808
11809 !  IF(jte == jde) THEN
11810 !  DO k =kts, kte
11811 !  DO i =its, ite
11812 !  field(i,k,jte) =field(i,k,jte-1)
11813
11814 !  ENDDO
11815 !  ENDDO
11816 !  END IF
11817
11818    IF(jte == jde) THEN
11819
11820    DO k =kte, kts, -1
11821    DO i =ite, its, -1
11822    a_field(i,k,jte-1) =a_field(i,k,jte-1) +a_field(i,k,jte)
11823    a_field(i,k,jte) =0.0
11824    ENDDO
11825    ENDDO
11826
11827    END IF
11828
11829 !LPB[2]
11830
11831 !LPB[1]
11832
11833 !  IF(jts == jds) THEN
11834 !  DO k =kts, kte
11835 !  DO i =its, ite
11836 !  field(i,k,jts) =field(i,k,jts+1)
11837
11838 !  ENDDO
11839 !  ENDDO
11840 !  END IF
11841
11842    IF(jts == jds) THEN
11843
11844    DO k =kte, kts, -1
11845    DO i =ite, its, -1
11846    a_field(i,k,jts+1) =a_field(i,k,jts+1) +a_field(i,k,jts)
11847    a_field(i,k,jts) =0.0
11848    ENDDO
11849    ENDDO
11850
11851    END IF
11852
11853 !LPB[0]
11854
11855    END SUBROUTINE a_pole_point_bc
11856
11857 !        Generated by TAPENADE     (INRIA, Tropics team)
11858 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
11859 !
11860 !  Differentiation of phy_prep in reverse (adjoint) mode:
11861 !   gradient     of useful results: rthndgdten rublten v_phy rqvndgdten
11862 !                rthraten p rqccuten t rthcuten u v rqicuten z
11863 !                th_phy rthften rvndgdten rqscuten t8w rqrshten
11864 !                rqvshten rucuten pi_phy rvshten rqvblten rvblten
11865 !                rphndgdten t_phy rqcshten rqvften rthshten rqgshten
11866 !                p_hyd_w rqishten p_phy rqcblten moist ph rthblten
11867 !                u_phy rqrcuten rqiblten alt rqsshten rqvcuten
11868 !                p8w z_at_w rho rvcuten p_hyd rushten muu muv rundgdten
11869 !                mu dz8w
11870 !   with respect to varying inputs: rthndgdten rublten v_phy rqvndgdten
11871 !                rthraten p rqccuten t rthcuten u v rqicuten z
11872 !                th_phy rthften rvndgdten rqscuten t8w rqrshten
11873 !                rqvshten rucuten pi_phy rvshten rqvblten rvblten
11874 !                rphndgdten t_phy rqcshten rqvften rthshten rqgshten
11875 !                p_hyd_w rqishten p_phy rqcblten moist ph rthblten
11876 !                u_phy rqrcuten rqiblten alt rqsshten rqvcuten
11877 !                p8w z_at_w rho rvcuten p_hyd rushten muu muv rundgdten
11878 !                mu dz8w
11879 !   RW status of diff variables: rthndgdten:in-out rublten:in-out
11880 !                v_phy:in-out rqvndgdten:in-out rthraten:in-out
11881 !                p:incr rqccuten:in-out t:incr rthcuten:in-out
11882 !                u:incr v:incr rqicuten:in-out z:in-out th_phy:in-out
11883 !                rthften:in-out rvndgdten:in-out rqscuten:in-out
11884 !                t8w:in-out rqrshten:in-out rqvshten:in-out rucuten:in-out
11885 !                pi_phy:in-out rvshten:in-out rqvblten:in-out rvblten:in-out
11886 !                rphndgdten:in-out t_phy:in-out rqcshten:in-out
11887 !                rqvften:in-out rthshten:in-out rqgshten:in-out
11888 !                p_hyd_w:in-out rqishten:in-out p_phy:in-out rqcblten:in-out
11889 !                moist:incr ph:incr rthblten:in-out u_phy:in-out
11890 !                rqrcuten:in-out rqiblten:in-out alt:incr rqsshten:in-out
11891 !                rqvcuten:in-out p8w:in-out z_at_w:in-out rho:in-out
11892 !                rvcuten:in-out p_hyd:in-out rushten:in-out muu:incr
11893 !                muv:incr rundgdten:in-out mu:incr dz8w:in-out
11894 ! input
11895 ! input
11896 ! input
11897 ! output
11898 ! output
11899 ! output
11900 ! output
11901 ! params
11902 !01/2017 decoupling mu in A_PHY_PREP is moved to A_PHY_PREP_part2
11903 SUBROUTINE A_PHY_PREP_part2(config_flags, mu, mub, muu, muub, muv, muvb, &
11904 &  rthraten, rthratenb, rthblten, &
11905 &  rthbltenb, rublten, rubltenb, rvblten, rvbltenb, rqvblten, rqvbltenb, &
11906 &  rqcblten, rqcbltenb, rqiblten, rqibltenb, rucuten, rucutenb, rvcuten, &
11907 &  rvcutenb, rthcuten, rthcutenb, rqvcuten, rqvcutenb, rqccuten, &
11908 &  rqccutenb, rqrcuten, rqrcutenb, rqicuten, rqicutenb, rqscuten, &
11909 &  rqscutenb, rushten, rushtenb, rvshten, rvshtenb, rthshten, rthshtenb, &
11910 &  rqvshten, rqvshtenb, rqcshten, rqcshtenb, rqrshten, rqrshtenb, &
11911 &  rqishten, rqishtenb, rqsshten, rqsshtenb, rqgshten, rqgshtenb, rthften&
11912 &  , rthftenb, rqvften, rqvftenb, rundgdten, rundgdtenb, rvndgdten, &
11913 &  rvndgdtenb, rthndgdten, rthndgdtenb, rphndgdten, rphndgdtenb, &
11914 &  rqvndgdten, rqvndgdtenb, rmundgdten, ids, ide, jds, jde, kds, kde, ims&
11915 &  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
11916   IMPLICIT NONE
11917 !----------------------------------------------------------------------
11918   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
11919   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
11920 &  jme, kms, kme, its, ite, jts, jte, kts, kte
11921   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muu, muv
11922   REAL, DIMENSION(ims:ime, jms:jme) :: mub, muub, muvb
11923   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthraten
11924   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rthratenb
11925   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rucuten, &
11926 &  rvcuten, rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, &
11927 &  rushten, rvshten, rthshten, rqvshten, rqcshten, rqrshten, rqishten, &
11928 &  rqsshten, rqgshten
11929   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rucutenb, rvcutenb, &
11930 &  rthcutenb, rqvcutenb, rqccutenb, rqrcutenb, rqicutenb, rqscutenb, &
11931 &  rushtenb, rvshtenb, rthshtenb, rqvshtenb, rqcshtenb, rqrshtenb, &
11932 &  rqishtenb, rqsshtenb, rqgshtenb
11933   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
11934 &  rvblten, rthblten, rqvblten, rqcblten, rqiblten
11935   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rubltenb, rvbltenb, &
11936 &  rthbltenb, rqvbltenb, rqcbltenb, rqibltenb
11937   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthften, &
11938 &  rqvften
11939   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rthftenb, rqvftenb
11940   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rundgdten&
11941 &  , rvndgdten, rthndgdten, rphndgdten, rqvndgdten
11942   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rundgdtenb, rvndgdtenb, &
11943 &  rthndgdtenb, rphndgdtenb, rqvndgdtenb
11944   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rmundgdten
11945   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, &
11946 &  j_startv
11947   INTEGER :: i, j, k
11948   INTEGER :: branch
11949   REAL :: temp1b29
11950   REAL :: temp1b28
11951   REAL :: temp1b27
11952   REAL :: temp1b26
11953   REAL :: temp1b25
11954   REAL :: temp1b24
11955   REAL :: temp1b23
11956   REAL :: temp1b22
11957   REAL :: temp1b21
11958   REAL :: temp1b20
11959   REAL :: temp1b19
11960   REAL :: temp1b18
11961   REAL :: temp1b17
11962   REAL :: temp1b16
11963   REAL :: temp1b15
11964   REAL :: temp1b14
11965   REAL :: temp1b13
11966   REAL :: temp1b12
11967   REAL :: temp1b11
11968   REAL :: temp1b10
11969   REAL :: temp1b9
11970   REAL :: temp1b8
11971   REAL :: temp1b7
11972   REAL :: temp1b6
11973   REAL :: temp1b5
11974   REAL :: temp1b4
11975   REAL :: temp1b3
11976   REAL :: temp1b2
11977   REAL :: temp1b1
11978   REAL :: temp1b0
11979   REAL :: temp1b
11980 !-----------------------------------------------------------------------
11981 !<DESCRIPTION>
11982 !
11983 !  phys_prep_part2 decouples the physics tendencies from
11984 !  the column dry-air mass (the physics routines expect to see/update the
11985 !  uncoupled tendencies).
11986 !
11987 !</DESCRIPTION>
11988 !  set up loop bounds for this grid's boundary conditions
11989   i_start = its
11990   IF (ite .GT. ide - 1) THEN
11991     i_end = ide - 1
11992   ELSE
11993     i_end = ite
11994   END IF
11995   j_start = jts
11996   IF (jte .GT. jde - 1) THEN
11997     j_end = jde - 1
11998   ELSE
11999     j_end = jte
12000   END IF
12001   k_start = kts
12002   IF (kte .GT. kde - 1) THEN
12003     k_end = kde - 1
12004   ELSE
12005     k_end = kte
12006   END IF
12007 ! decouple all physics tendencies
12008   IF (config_flags%ra_lw_physics .GT. 0 .OR. config_flags%ra_sw_physics &
12009 &      .GT. 0) THEN
12010     CALL PUSHCONTROL1B(0)
12011   ELSE
12012     CALL PUSHCONTROL1B(1)
12013   END IF
12014   IF (config_flags%cu_physics .GT. 0) THEN
12015     IF (p_qv .GE. param_first_scalar) THEN
12016       CALL PUSHCONTROL1B(0)
12017     ELSE
12018       CALL PUSHCONTROL1B(1)
12019     END IF
12020     IF (p_qc .GE. param_first_scalar) THEN
12021       CALL PUSHCONTROL1B(0)
12022     ELSE
12023       CALL PUSHCONTROL1B(1)
12024     END IF
12025     IF (p_qr .GE. param_first_scalar) THEN
12026       CALL PUSHCONTROL1B(0)
12027     ELSE
12028       CALL PUSHCONTROL1B(1)
12029     END IF
12030     IF (p_qi .GE. param_first_scalar) THEN
12031       CALL PUSHCONTROL1B(0)
12032     ELSE
12033       CALL PUSHCONTROL1B(1)
12034     END IF
12035     IF (p_qs .GE. param_first_scalar) THEN
12036       CALL PUSHCONTROL2B(0)
12037     ELSE
12038       CALL PUSHCONTROL2B(1)
12039     END IF
12040   ELSE
12041     CALL PUSHCONTROL2B(2)
12042   END IF
12043   IF (config_flags%shcu_physics .GT. 0) THEN
12044     IF (p_qv .GE. param_first_scalar) THEN
12045       CALL PUSHCONTROL1B(0)
12046     ELSE
12047       CALL PUSHCONTROL1B(1)
12048     END IF
12049     IF (p_qc .GE. param_first_scalar) THEN
12050       CALL PUSHCONTROL1B(0)
12051     ELSE
12052       CALL PUSHCONTROL1B(1)
12053     END IF
12054     IF (p_qr .GE. param_first_scalar) THEN
12055       CALL PUSHCONTROL1B(0)
12056     ELSE
12057       CALL PUSHCONTROL1B(1)
12058     END IF
12059     IF (p_qi .GE. param_first_scalar) THEN
12060       CALL PUSHCONTROL1B(0)
12061     ELSE
12062       CALL PUSHCONTROL1B(1)
12063     END IF
12064     IF (p_qs .GE. param_first_scalar) THEN
12065       CALL PUSHCONTROL1B(0)
12066     ELSE
12067       CALL PUSHCONTROL1B(1)
12068     END IF
12069     IF (p_qg .GE. param_first_scalar) THEN
12070       CALL PUSHCONTROL2B(0)
12071     ELSE
12072       CALL PUSHCONTROL2B(1)
12073     END IF
12074   ELSE
12075     CALL PUSHCONTROL2B(2)
12076   END IF
12077   IF (config_flags%bl_pbl_physics .GT. 0) THEN
12078     IF (p_qv .GE. param_first_scalar) THEN
12079       CALL PUSHCONTROL1B(0)
12080     ELSE
12081       CALL PUSHCONTROL1B(1)
12082     END IF
12083     IF (p_qc .GE. param_first_scalar) THEN
12084       CALL PUSHCONTROL1B(0)
12085     ELSE
12086       CALL PUSHCONTROL1B(1)
12087     END IF
12088     IF (p_qi .GE. param_first_scalar) THEN
12089       CALL PUSHCONTROL2B(0)
12090     ELSE
12091       CALL PUSHCONTROL2B(1)
12092     END IF
12093   ELSE
12094     CALL PUSHCONTROL2B(2)
12095   END IF
12096 !  decouple advective forcing required by Grell-Devenyi scheme
12097   IF (((config_flags%cu_physics .EQ. gdscheme .OR. config_flags%&
12098 &      cu_physics .EQ. g3scheme) .OR. config_flags%cu_physics .EQ. &
12099 &      kfetascheme) .OR. config_flags%cu_physics .EQ. tiedtkescheme &
12100 &      .OR. (config_flags%cu_physics == NTIEDTKESCHEME) &
12101 &      .OR. (config_flags%cu_physics == MSKFSCHEME) ) THEN
12102     IF (p_qv .GE. param_first_scalar) THEN
12103       CALL PUSHCONTROL2B(0)
12104     ELSE
12105       CALL PUSHCONTROL2B(1)
12106     END IF
12107   ELSE
12108     CALL PUSHCONTROL2B(2)
12109   END IF
12110 ! fdda
12111 ! note fdda u and v tendencies are staggered, also only interior points have muu/muv,
12112 !   so only decouple those
12113   IF (config_flags%grid_fdda .GT. 0) THEN
12114     IF (its .LT. ids + 1) THEN
12115       i_startu = ids + 1
12116     ELSE
12117       i_startu = its
12118     END IF
12119     IF (jts .LT. jds + 1) THEN
12120       j_startv = jds + 1
12121     ELSE
12122       j_startv = jts
12123     END IF
12124 !        RMUNDGDTEN(I,J) - no coupling
12125     IF (config_flags%grid_fdda .EQ. 2) THEN
12126       DO j=j_end,j_start,-1
12127         DO k=kte,k_start,-1
12128           DO i=i_end,i_start,-1
12129             temp1b28 = rphndgdtenb(i, k, j)/mu(i, j)
12130             mub(i, j) = mub(i, j) - rphndgdten(i, k, j)*temp1b28/mu(i, j&
12131 &              )
12132             rphndgdtenb(i, k, j) = temp1b28
12133           END DO
12134         END DO
12135       END DO
12136     ELSE IF (config_flags%grid_fdda .EQ. 1) THEN
12137       IF (p_qv .GE. param_first_scalar) THEN
12138         DO j=j_end,j_start,-1
12139           DO k=k_end,k_start,-1
12140             DO i=i_end,i_start,-1
12141               temp1b29 = rqvndgdtenb(i, k, j)/mu(i, j)
12142               mub(i, j) = mub(i, j) - rqvndgdten(i, k, j)*temp1b29/mu(i&
12143 &                , j)
12144               rqvndgdtenb(i, k, j) = temp1b29
12145             END DO
12146           END DO
12147         END DO
12148       END IF
12149     END IF
12150     DO j=j_end,j_start,-1
12151       DO k=k_end,k_start,-1
12152         DO i=i_end,i_start,-1
12153           temp1b27 = rthndgdtenb(i, k, j)/mu(i, j)
12154           mub(i, j) = mub(i, j) - rthndgdten(i, k, j)*temp1b27/mu(i, j)
12155           rthndgdtenb(i, k, j) = temp1b27
12156         END DO
12157       END DO
12158     END DO
12159     DO j=j_end,j_startv,-1
12160       DO k=k_end,k_start,-1
12161         DO i=i_end,i_start,-1
12162           temp1b26 = rvndgdtenb(i, k, j)/muv(i, j)
12163           muvb(i, j) = muvb(i, j) - rvndgdten(i, k, j)*temp1b26/muv(i, j&
12164 &            )
12165           rvndgdtenb(i, k, j) = temp1b26
12166         END DO
12167       END DO
12168     END DO
12169     DO j=j_end,j_start,-1
12170       DO k=k_end,k_start,-1
12171         DO i=i_end,i_startu,-1
12172           temp1b25 = rundgdtenb(i, k, j)/muu(i, j)
12173           muub(i, j) = muub(i, j) - rundgdten(i, k, j)*temp1b25/muu(i, j&
12174 &            )
12175           rundgdtenb(i, k, j) = temp1b25
12176         END DO
12177       END DO
12178     END DO
12179   END IF
12180   CALL POPCONTROL2B(branch)
12181   IF (branch .EQ. 0) THEN
12182     DO j=j_end,j_start,-1
12183       DO i=i_end,i_start,-1
12184         DO k=k_end,k_start,-1
12185           temp1b24 = rqvftenb(i, k, j)/mu(i, j)
12186           mub(i, j) = mub(i, j) - rqvften(i, k, j)*temp1b24/mu(i, j)
12187           rqvftenb(i, k, j) = temp1b24
12188         END DO
12189       END DO
12190     END DO
12191   ELSE IF (branch .NE. 1) THEN
12192     GOTO 100
12193   END IF
12194   DO j=j_end,j_start,-1
12195     DO i=i_end,i_start,-1
12196       DO k=k_end,k_start,-1
12197         temp1b23 = rthftenb(i, k, j)/mu(i, j)
12198         mub(i, j) = mub(i, j) - rthften(i, k, j)*temp1b23/mu(i, j)
12199         rthftenb(i, k, j) = temp1b23
12200       END DO
12201     END DO
12202   END DO
12203  100 CALL POPCONTROL2B(branch)
12204   IF (branch .EQ. 0) THEN
12205     DO j=j_end,j_start,-1
12206       DO k=k_end,k_start,-1
12207         DO i=i_end,i_start,-1
12208           temp1b22 = rqibltenb(i, k, j)/mu(i, j)
12209           mub(i, j) = mub(i, j) - rqiblten(i, k, j)*temp1b22/mu(i, j)
12210           rqibltenb(i, k, j) = temp1b22
12211         END DO
12212       END DO
12213     END DO
12214   ELSE IF (branch .NE. 1) THEN
12215     GOTO 110
12216   END IF
12217   CALL POPCONTROL1B(branch)
12218   IF (branch .EQ. 0) THEN
12219     DO j=j_end,j_start,-1
12220       DO k=k_end,k_start,-1
12221         DO i=i_end,i_start,-1
12222           temp1b21 = rqcbltenb(i, k, j)/mu(i, j)
12223           mub(i, j) = mub(i, j) - rqcblten(i, k, j)*temp1b21/mu(i, j)
12224           rqcbltenb(i, k, j) = temp1b21
12225         END DO
12226       END DO
12227     END DO
12228   END IF
12229   CALL POPCONTROL1B(branch)
12230   IF (branch .EQ. 0) THEN
12231     DO j=j_end,j_start,-1
12232       DO k=k_end,k_start,-1
12233         DO i=i_end,i_start,-1
12234           temp1b20 = rqvbltenb(i, k, j)/mu(i, j)
12235           mub(i, j) = mub(i, j) - rqvblten(i, k, j)*temp1b20/mu(i, j)
12236           rqvbltenb(i, k, j) = temp1b20
12237         END DO
12238       END DO
12239     END DO
12240   END IF
12241   DO j=j_end,j_start,-1
12242     DO k=k_end,k_start,-1
12243       DO i=i_end,i_start,-1
12244         temp1b19 = rubltenb(i, k, j)/mu(i, j)
12245         temp1b18 = rvbltenb(i, k, j)/mu(i, j)
12246         temp1b17 = rthbltenb(i, k, j)/mu(i, j)
12247         mub(i, j) = mub(i, j) - rvblten(i, k, j)*temp1b18/mu(i, j) - &
12248 &          rublten(i, k, j)*temp1b19/mu(i, j) - rthblten(i, k, j)*&
12249 &          temp1b17/mu(i, j)
12250         rthbltenb(i, k, j) = temp1b17
12251         rvbltenb(i, k, j) = temp1b18
12252         rubltenb(i, k, j) = temp1b19
12253       END DO
12254     END DO
12255   END DO
12256  110 CALL POPCONTROL2B(branch)
12257   IF (branch .EQ. 0) THEN
12258     DO j=j_end,j_start,-1
12259       DO i=i_end,i_start,-1
12260         DO k=k_end,k_start,-1
12261           temp1b16 = rqgshtenb(i, k, j)/mu(i, j)
12262           mub(i, j) = mub(i, j) - rqgshten(i, k, j)*temp1b16/mu(i, j)
12263           rqgshtenb(i, k, j) = temp1b16
12264         END DO
12265       END DO
12266     END DO
12267   ELSE IF (branch .NE. 1) THEN
12268     GOTO 120
12269   END IF
12270   CALL POPCONTROL1B(branch)
12271   IF (branch .EQ. 0) THEN
12272     DO j=j_end,j_start,-1
12273       DO i=i_end,i_start,-1
12274         DO k=k_end,k_start,-1
12275           temp1b15 = rqsshtenb(i, k, j)/mu(i, j)
12276           mub(i, j) = mub(i, j) - rqsshten(i, k, j)*temp1b15/mu(i, j)
12277           rqsshtenb(i, k, j) = temp1b15
12278         END DO
12279       END DO
12280     END DO
12281   END IF
12282   CALL POPCONTROL1B(branch)
12283   IF (branch .EQ. 0) THEN
12284     DO j=j_end,j_start,-1
12285       DO i=i_end,i_start,-1
12286         DO k=k_end,k_start,-1
12287           temp1b14 = rqishtenb(i, k, j)/mu(i, j)
12288           mub(i, j) = mub(i, j) - rqishten(i, k, j)*temp1b14/mu(i, j)
12289           rqishtenb(i, k, j) = temp1b14
12290         END DO
12291       END DO
12292     END DO
12293   END IF
12294   CALL POPCONTROL1B(branch)
12295   IF (branch .EQ. 0) THEN
12296     DO j=j_end,j_start,-1
12297       DO i=i_end,i_start,-1
12298         DO k=k_end,k_start,-1
12299           temp1b13 = rqrshtenb(i, k, j)/mu(i, j)
12300           mub(i, j) = mub(i, j) - rqrshten(i, k, j)*temp1b13/mu(i, j)
12301           rqrshtenb(i, k, j) = temp1b13
12302         END DO
12303       END DO
12304     END DO
12305   END IF
12306   CALL POPCONTROL1B(branch)
12307   IF (branch .EQ. 0) THEN
12308     DO j=j_end,j_start,-1
12309       DO i=i_end,i_start,-1
12310         DO k=k_end,k_start,-1
12311           temp1b12 = rqcshtenb(i, k, j)/mu(i, j)
12312           mub(i, j) = mub(i, j) - rqcshten(i, k, j)*temp1b12/mu(i, j)
12313           rqcshtenb(i, k, j) = temp1b12
12314         END DO
12315       END DO
12316     END DO
12317   END IF
12318   CALL POPCONTROL1B(branch)
12319   IF (branch .EQ. 0) THEN
12320     DO j=j_end,j_start,-1
12321       DO i=i_end,i_start,-1
12322         DO k=k_end,k_start,-1
12323           temp1b11 = rqvshtenb(i, k, j)/mu(i, j)
12324           mub(i, j) = mub(i, j) - rqvshten(i, k, j)*temp1b11/mu(i, j)
12325           rqvshtenb(i, k, j) = temp1b11
12326         END DO
12327       END DO
12328     END DO
12329   END IF
12330   DO j=j_end,j_start,-1
12331     DO i=i_end,i_start,-1
12332       DO k=k_end,k_start,-1
12333         temp1b10 = rushtenb(i, k, j)/mu(i, j)
12334         temp1b9 = rvshtenb(i, k, j)/mu(i, j)
12335         temp1b8 = rthshtenb(i, k, j)/mu(i, j)
12336         mub(i, j) = mub(i, j) - rvshten(i, k, j)*temp1b9/mu(i, j) - &
12337 &          rushten(i, k, j)*temp1b10/mu(i, j) - rthshten(i, k, j)*temp1b8&
12338 &          /mu(i, j)
12339         rthshtenb(i, k, j) = temp1b8
12340         rvshtenb(i, k, j) = temp1b9
12341         rushtenb(i, k, j) = temp1b10
12342       END DO
12343     END DO
12344   END DO
12345  120 CALL POPCONTROL2B(branch)
12346   IF (branch .EQ. 0) THEN
12347     DO j=j_end,j_start,-1
12348       DO i=i_end,i_start,-1
12349         DO k=k_end,k_start,-1
12350           temp1b7 = rqscutenb(i, k, j)/mu(i, j)
12351           mub(i, j) = mub(i, j) - rqscuten(i, k, j)*temp1b7/mu(i, j)
12352           rqscutenb(i, k, j) = temp1b7
12353         END DO
12354       END DO
12355     END DO
12356   ELSE IF (branch .NE. 1) THEN
12357     GOTO 130
12358   END IF
12359   CALL POPCONTROL1B(branch)
12360   IF (branch .EQ. 0) THEN
12361     DO j=j_end,j_start,-1
12362       DO i=i_end,i_start,-1
12363         DO k=k_end,k_start,-1
12364           temp1b6 = rqicutenb(i, k, j)/mu(i, j)
12365           mub(i, j) = mub(i, j) - rqicuten(i, k, j)*temp1b6/mu(i, j)
12366           rqicutenb(i, k, j) = temp1b6
12367         END DO
12368       END DO
12369     END DO
12370   END IF
12371   CALL POPCONTROL1B(branch)
12372   IF (branch .EQ. 0) THEN
12373     DO j=j_end,j_start,-1
12374       DO i=i_end,i_start,-1
12375         DO k=k_end,k_start,-1
12376           temp1b5 = rqrcutenb(i, k, j)/mu(i, j)
12377           mub(i, j) = mub(i, j) - rqrcuten(i, k, j)*temp1b5/mu(i, j)
12378           rqrcutenb(i, k, j) = temp1b5
12379         END DO
12380       END DO
12381     END DO
12382   END IF
12383   CALL POPCONTROL1B(branch)
12384   IF (branch .EQ. 0) THEN
12385     DO j=j_end,j_start,-1
12386       DO i=i_end,i_start,-1
12387         DO k=k_end,k_start,-1
12388           temp1b4 = rqccutenb(i, k, j)/mu(i, j)
12389           mub(i, j) = mub(i, j) - rqccuten(i, k, j)*temp1b4/mu(i, j)
12390           rqccutenb(i, k, j) = temp1b4
12391         END DO
12392       END DO
12393     END DO
12394   END IF
12395   CALL POPCONTROL1B(branch)
12396   IF (branch .EQ. 0) THEN
12397     DO j=j_end,j_start,-1
12398       DO i=i_end,i_start,-1
12399         DO k=k_end,k_start,-1
12400           temp1b3 = rqvcutenb(i, k, j)/mu(i, j)
12401           mub(i, j) = mub(i, j) - rqvcuten(i, k, j)*temp1b3/mu(i, j)
12402           rqvcutenb(i, k, j) = temp1b3
12403         END DO
12404       END DO
12405     END DO
12406   END IF
12407   DO j=j_end,j_start,-1
12408     DO i=i_end,i_start,-1
12409       DO k=k_end,k_start,-1
12410         temp1b2 = rucutenb(i, k, j)/mu(i, j)
12411         temp1b1 = rvcutenb(i, k, j)/mu(i, j)
12412         temp1b0 = rthcutenb(i, k, j)/mu(i, j)
12413         mub(i, j) = mub(i, j) - rvcuten(i, k, j)*temp1b1/mu(i, j) - &
12414 &          rucuten(i, k, j)*temp1b2/mu(i, j) - rthcuten(i, k, j)*temp1b0/&
12415 &          mu(i, j)
12416         rthcutenb(i, k, j) = temp1b0
12417         rvcutenb(i, k, j) = temp1b1
12418         rucutenb(i, k, j) = temp1b2
12419       END DO
12420     END DO
12421   END DO
12422  130 CALL POPCONTROL1B(branch)
12423   IF (branch .EQ. 0) THEN
12424     DO j=j_end,j_start,-1
12425       DO k=k_end,k_start,-1
12426         DO i=i_end,i_start,-1
12427           temp1b = rthratenb(i, k, j)/mu(i, j)
12428           mub(i, j) = mub(i, j) - rthraten(i, k, j)*temp1b/mu(i, j)
12429           rthratenb(i, k, j) = temp1b
12430         END DO
12431       END DO
12432     END DO
12433   END IF
12434 END SUBROUTINE A_PHY_PREP_part2
12435 SUBROUTINE A_PHY_PREP(config_flags, mu, mub, muu, muub, muv, muvb, u, ub&
12436 &  , v, vb, p, pb0, pb, alt, altb, ph, phb0, phb, t, tb, moist, &
12437 &  moistb, n_moist, rho, rhob, th_phy, th_phyb, p_phy, p_phyb, pi_phy, &
12438 &  pi_phyb, u_phy, u_phyb, v_phy, v_phyb, p8w, p8wb, t_phy, t_phyb, t8w, &
12439 &  t8wb, z, zb, z_at_w, z_at_wb, dz8w, dz8wb, p_hyd, p_hydb, p_hyd_w, &
12440 &  p_hyd_wb, dnw, fzm, fzp, znw, p_top, &
12441 &  ids, ide, jds, jde, kds, kde, ims&
12442 &  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
12443   IMPLICIT NONE
12444 !----------------------------------------------------------------------
12445   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
12446   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
12447 &  jme, kms, kme, its, ite, jts, jte, kts, kte
12448   INTEGER, INTENT(IN) :: n_moist
12449   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
12450 &  moist
12451   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist) :: moistb
12452   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muu, muv
12453   REAL, DIMENSION(ims:ime, jms:jme) :: mub, muub, muvb
12454   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phy, v_phy, pi_phy, &
12455 &  p_phy, p8w, t_phy, th_phy, t8w, rho, z, dz8w, z_at_w
12456   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phyb, v_phyb, pi_phyb&
12457 &  , p_phyb, p8wb, t_phyb, th_phyb, t8wb, rhob, zb, dz8wb, z_at_wb
12458   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: p_hyd, p_hyd_w
12459   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: p_hydb, p_hyd_wb
12460   REAL, INTENT(IN) :: p_top
12461   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: pb, p, u, v&
12462 &  , alt, ph, phb, t
12463   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: pb0, ub, vb, altb, phb0&
12464 &  , tb
12465   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
12466   REAL, DIMENSION(kms:kme), INTENT(IN) :: znw, dnw
12467   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, &
12468 &  j_startv
12469   INTEGER :: i, j, k
12470   REAL :: w1, w2, z0, z1, z2
12471   REAL :: w1b, w2b, z0b, z1b, z2b
12472   REAL :: qtot
12473   REAL :: qtotb
12474   INTEGER :: n
12475   INTEGER :: branch
12476   REAL :: temp0
12477   REAL :: tempb4
12478   REAL :: tempb3
12479   REAL :: tempb2
12480   REAL :: tempb1
12481   REAL :: tempb0
12482   REAL :: tempb
12483   REAL :: temp
12484 !-----------------------------------------------------------------------
12485 !<DESCRIPTION>
12486 !
12487 !  phys_prep calculates a number of diagnostic quantities needed by
12488 !  the physics routines.
12489 !
12490 !</DESCRIPTION>
12491 !  set up loop bounds for this grid's boundary conditions
12492   i_start = its
12493   IF (ite .GT. ide - 1) THEN
12494     i_end = ide - 1
12495   ELSE
12496     i_end = ite
12497   END IF
12498   j_start = jts
12499   IF (jte .GT. jde - 1) THEN
12500     j_end = jde - 1
12501   ELSE
12502     j_end = jte
12503   END IF
12504   k_start = kts
12505   IF (kte .GT. kde - 1) THEN
12506     k_end = kde - 1
12507   ELSE
12508     k_end = kte
12509   END IF
12510
12511 !  compute thermodynamics and velocities at pressure points (or half levels)
12512   DO j=j_start,j_end
12513     DO k=k_start,k_end
12514       DO i=i_start,i_end
12515         th_phy(i, k, j) = t(i, k, j) + t0
12516         p_phy(i, k, j) = p(i, k, j) + pb(i, k, j)
12517         pi_phy(i, k, j) = (p_phy(i, k, j)/p1000mb)**rcp
12518         t_phy(i, k, j) = th_phy(i, k, j)*pi_phy(i, k, j)
12519       END DO
12520     END DO
12521   END DO
12522 !  compute z at w points
12523   DO j=j_start,j_end
12524     DO k=k_start,kte
12525       DO i=i_start,i_end
12526         z_at_w(i, k, j) = (phb(i, k, j)+ph(i, k, j))/g
12527       END DO
12528     END DO
12529   END DO
12530 !  compute z at p points or half levels (average of z at full levels)
12531   DO j=j_start,j_end
12532     DO k=k_start,k_end
12533       DO i=i_start,i_end
12534         z(i, k, j) = 0.5*(z_at_w(i, k, j)+z_at_w(i, k+1, j))
12535       END DO
12536     END DO
12537   END DO
12538   DO j=j_start,j_end
12539     DO k=kte-1,k_start,-1
12540       DO i=i_start,i_end
12541         CALL PUSHREAL8(qtot)
12542         qtot = 0.
12543         DO n=param_first_scalar,n_moist
12544           qtot = qtot + moist(i, k, j, n)
12545         END DO
12546       END DO
12547     END DO
12548   END DO
12549   DO j=j_end,j_start,-1
12550     DO k=k_end,k_start,-1
12551       DO i=i_end,i_start,-1
12552         p_hyd_wb(i, k, j) = p_hyd_wb(i, k, j) + 0.5*p_hydb(i, k, j)
12553         p_hyd_wb(i, k+1, j) = p_hyd_wb(i, k+1, j) + 0.5*p_hydb(i, k, j)
12554         p_hydb(i, k, j) = 0.0
12555       END DO
12556     END DO
12557   END DO
12558   DO j=j_end,j_start,-1
12559     DO k=k_start,kte-1,1
12560       DO i=i_end,i_start,-1
12561         p_hyd_wb(i, k+1, j) = p_hyd_wb(i, k+1, j) + p_hyd_wb(i, k, j)
12562         qtotb = -(dnw(k)*mu(i, j)*p_hyd_wb(i, k, j))
12563         mub(i, j) = mub(i, j) - dnw(k)*(qtot+1.)*p_hyd_wb(i, k, j)
12564         p_hyd_wb(i, k, j) = 0.0
12565         DO n=n_moist,param_first_scalar,-1
12566           moistb(i, k, j, n) = moistb(i, k, j, n) + qtotb
12567         END DO
12568         CALL POPREAL8(qtot)
12569       END DO
12570     END DO
12571   END DO
12572   DO j=j_end,j_start,-1
12573     DO i=i_end,i_start,-1
12574       p_hyd_wb(i, kte, j) = 0.0
12575     END DO
12576   END DO
12577   DO j=j_end,j_start,-1
12578     DO i=i_end,i_start,-1
12579       z0 = z_at_w(i, kte, j)
12580       z1 = z(i, k_end, j)
12581       z2 = z(i, k_end-1, j)
12582       w1 = (z0-z2)/(z1-z2)
12583       w2 = 1. - w1
12584       t_phyb(i, kde-1, j) = t_phyb(i, kde-1, j) + w1*t8wb(i, kde, j)
12585       t_phyb(i, kde-2, j) = t_phyb(i, kde-2, j) + w2*t8wb(i, kde, j)
12586       temp0 = LOG(p_phy(i, kde-2, j))
12587       temp = LOG(p_phy(i, kde-1, j))
12588       tempb0 = EXP(w1*temp+w2*temp0)*p8wb(i, kde, j)
12589       w2b = temp0*tempb0 + t_phy(i, kde-2, j)*t8wb(i, kde, j)
12590       w1b = temp*tempb0 - w2b + t_phy(i, kde-1, j)*t8wb(i, kde, j)
12591       t8wb(i, kde, j) = 0.0
12592       p_phyb(i, kde-1, j) = p_phyb(i, kde-1, j) + w1*tempb0/p_phy(i, kde&
12593 &        -1, j)
12594       p_phyb(i, kde-2, j) = p_phyb(i, kde-2, j) + w2*tempb0/p_phy(i, kde&
12595 &        -2, j)
12596       p8wb(i, kde, j) = 0.0
12597       tempb1 = w1b/(z1-z2)
12598       tempb2 = -((z0-z2)*tempb1/(z1-z2))
12599       z0b = tempb1
12600       z2b = -tempb2 - tempb1
12601       z1b = tempb2
12602       zb(i, k_end-1, j) = zb(i, k_end-1, j) + z2b
12603       zb(i, k_end, j) = zb(i, k_end, j) + z1b
12604       z_at_wb(i, kte, j) = z_at_wb(i, kte, j) + z0b
12605       z0 = z_at_w(i, 1, j)
12606       z1 = z(i, 1, j)
12607       z2 = z(i, 2, j)
12608       w1 = (z0-z2)/(z1-z2)
12609       w2 = 1. - w1
12610       t_phyb(i, 1, j) = t_phyb(i, 1, j) + w1*t8wb(i, 1, j)
12611       w2b = p_phy(i, 2, j)*p8wb(i, 1, j) + t_phy(i, 2, j)*t8wb(i, 1, j)
12612       w1b = p_phy(i, 1, j)*p8wb(i, 1, j) - w2b + t_phy(i, 1, j)*t8wb(i, &
12613 &        1, j)
12614       t_phyb(i, 2, j) = t_phyb(i, 2, j) + w2*t8wb(i, 1, j)
12615       t8wb(i, 1, j) = 0.0
12616       p_phyb(i, 1, j) = p_phyb(i, 1, j) + w1*p8wb(i, 1, j)
12617       p_phyb(i, 2, j) = p_phyb(i, 2, j) + w2*p8wb(i, 1, j)
12618       p8wb(i, 1, j) = 0.0
12619       tempb3 = w1b/(z1-z2)
12620       tempb4 = -((z0-z2)*tempb3/(z1-z2))
12621       z0b = tempb3
12622       z2b = -tempb4 - tempb3
12623       z1b = tempb4
12624       zb(i, 2, j) = zb(i, 2, j) + z2b
12625       zb(i, 1, j) = zb(i, 1, j) + z1b
12626       z_at_wb(i, 1, j) = z_at_wb(i, 1, j) + z0b
12627     END DO
12628   END DO
12629   DO j=j_end,j_start,-1
12630     DO k=k_end,2,-1
12631       DO i=i_end,i_start,-1
12632         t_phyb(i, k, j) = t_phyb(i, k, j) + fzm(k)*t8wb(i, k, j)
12633         t_phyb(i, k-1, j) = t_phyb(i, k-1, j) + fzp(k)*t8wb(i, k, j)
12634         t8wb(i, k, j) = 0.0
12635         p_phyb(i, k, j) = p_phyb(i, k, j) + fzm(k)*p8wb(i, k, j)
12636         p_phyb(i, k-1, j) = p_phyb(i, k-1, j) + fzp(k)*p8wb(i, k, j)
12637         p8wb(i, k, j) = 0.0
12638       END DO
12639     END DO
12640   END DO
12641   DO j=j_end,j_start,-1
12642     DO k=k_end,k_start,-1
12643       DO i=i_end,i_start,-1
12644         z_at_wb(i, k, j) = z_at_wb(i, k, j) + 0.5*zb(i, k, j)
12645         z_at_wb(i, k+1, j) = z_at_wb(i, k+1, j) + 0.5*zb(i, k, j)
12646         zb(i, k, j) = 0.0
12647       END DO
12648     END DO
12649   END DO
12650   DO j=j_end,j_start,-1
12651     DO i=i_end,i_start,-1
12652       dz8wb(i, kte, j) = 0.0
12653     END DO
12654   END DO
12655   DO j=j_end,j_start,-1
12656     DO k=kte-1,k_start,-1
12657       DO i=i_end,i_start,-1
12658         z_at_wb(i, k+1, j) = z_at_wb(i, k+1, j) + dz8wb(i, k, j)
12659         z_at_wb(i, k, j) = z_at_wb(i, k, j) - dz8wb(i, k, j)
12660         dz8wb(i, k, j) = 0.0
12661       END DO
12662     END DO
12663   END DO
12664   DO j=j_end,j_start,-1
12665     DO k=kte,k_start,-1
12666       DO i=i_end,i_start,-1
12667         phb0(i, k, j) = phb0(i, k, j) + z_at_wb(i, k, j)/g
12668         z_at_wb(i, k, j) = 0.0
12669       END DO
12670     END DO
12671   END DO
12672   DO j=j_end,j_start,-1
12673     DO k=k_end,k_start,-1
12674       DO i=i_end,i_start,-1
12675         vb(i, k, j) = vb(i, k, j) + 0.5*v_phyb(i, k, j)
12676         vb(i, k, j+1) = vb(i, k, j+1) + 0.5*v_phyb(i, k, j)
12677         v_phyb(i, k, j) = 0.0
12678         ub(i, k, j) = ub(i, k, j) + 0.5*u_phyb(i, k, j)
12679         ub(i+1, k, j) = ub(i+1, k, j) + 0.5*u_phyb(i, k, j)
12680         u_phyb(i, k, j) = 0.0
12681         tempb = rhob(i, k, j)/alt(i, k, j)
12682         moistb(i, k, j, p_qv) = moistb(i, k, j, p_qv) + tempb
12683         altb(i, k, j) = altb(i, k, j) - (moist(i, k, j, p_qv)+1.)*tempb/&
12684 &          alt(i, k, j)
12685         rhob(i, k, j) = 0.0
12686         th_phyb(i, k, j) = th_phyb(i, k, j) + pi_phy(i, k, j)*t_phyb(i, &
12687 &          k, j)
12688         pi_phyb(i, k, j) = pi_phyb(i, k, j) + th_phy(i, k, j)*t_phyb(i, &
12689 &          k, j)
12690         t_phyb(i, k, j) = 0.0
12691         IF (.NOT.(p_phy(i, k, j)/p1000mb .LE. 0.0 .AND. (rcp .EQ. 0.0 &
12692 &            .OR. rcp .NE. INT(rcp)))) p_phyb(i, k, j) = p_phyb(i, k, j) &
12693 &            + rcp*(p_phy(i, k, j)/p1000mb)**(rcp-1)*pi_phyb(i, k, j)/&
12694 &            p1000mb
12695         pi_phyb(i, k, j) = 0.0
12696         pb0(i, k, j) = pb0(i, k, j) + p_phyb(i, k, j)
12697         p_phyb(i, k, j) = 0.0
12698         tb(i, k, j) = tb(i, k, j) + th_phyb(i, k, j)
12699         th_phyb(i, k, j) = 0.0
12700       END DO
12701     END DO
12702   END DO
12703 END SUBROUTINE A_PHY_PREP
12704
12705 !        Generated by TAPENADE     (INRIA, Tropics team)
12706 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
12707 !
12708 !  Differentiation of moist_physics_prep_em in reverse (adjoint) mode:
12709 !   gradient     of useful results: p al z th_phy h_diabatic t_new
12710 !                pf ph p8w z_at_w rho pii dz8w
12711 !   with respect to varying inputs: p al z th_phy h_diabatic t_new
12712 !                pf ph p8w z_at_w rho pii dz8w
12713 !   RW status of diff variables: p:incr al:incr z:in-out th_phy:in-out
12714 !                h_diabatic:in-out t_new:incr pf:in-out ph:incr
12715 !                p8w:in-out z_at_w:in-out rho:in-out pii:in-out
12716 !                dz8w:in-out
12717 SUBROUTINE A_MOIST_PHYSICS_PREP_EM(t_new, t_newb, t_old, t0, rho, rhob, &
12718 &  al, alb0, alb, p, pb0, p8w, p8wb, p0, pb, ph, phb0, phb, th_phy, &
12719 &  th_phyb, pii, piib, pf, pfb, z, zb, z_at_w, z_at_wb, dz8w, dz8wb, dt, &
12720 &  h_diabatic, h_diabaticb, &
12721 &  qv, qvb, qv_diabatic, qv_diabaticb, &
12722 &  qc, qcb, qc_diabatic, qc_diabaticb, &
12723 &  config_flags, fzm, fzp, ids, ide, jds, jde, &
12724 &  kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
12725   IMPLICIT NONE
12726 ! Here we construct full fields
12727 ! needed by the microphysics
12728   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
12729   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
12730   INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
12731   INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
12732   REAL, INTENT(IN) :: dt
12733   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: al, alb, p, &
12734 &  pb, ph, phb, qv, qc
12735   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: alb0, pb0, phb0
12736   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: qvb, qcb
12737   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
12738   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rho, th_phy, pii, pf, z&
12739 &  , z_at_w, dz8w, p8w
12740   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rhob, th_phyb, piib, pfb&
12741 &  , zb, z_at_wb, dz8wb, p8wb
12742   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
12743 &  h_diabatic, qv_diabatic, qc_diabatic
12744   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: h_diabaticb, &
12745 &  qv_diabaticb, qc_diabaticb
12746   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_new, &
12747 &  t_old
12748   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: t_newb
12749   REAL, INTENT(IN) :: t0, p0
12750   REAL :: z0, z1, z2, w1, w2
12751   REAL :: z0b, z1b, z2b, w1b, w2b
12752   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
12753   INTEGER :: i, j, k
12754   INTEGER :: branch
12755   REAL :: temp1
12756   REAL :: temp0
12757   REAL :: temp0b
12758   REAL :: temp0b3
12759   REAL :: temp0b2
12760   REAL :: temp0b1
12761   REAL :: temp0b0
12762   REAL :: temp
12763 !--------------------------------------------------------------------
12764 !<DESCRIPTION>
12765 !
12766 !  moist_phys_prep_em calculates a number of diagnostic quantities needed by
12767 !  the microphysics routines.
12768 !
12769 !</DESCRIPTION>
12770 !  set up loop bounds for this grid's boundary conditions
12771   i_start = its
12772   IF (ite .GT. ide - 1) THEN
12773     i_end = ide - 1
12774   ELSE
12775     i_end = ite
12776   END IF
12777   j_start = jts
12778   IF (jte .GT. jde - 1) THEN
12779     j_end = jde - 1
12780   ELSE
12781     j_end = jte
12782   END IF
12783   k_start = kts
12784   IF (kte .GT. kde - 1) THEN
12785     k_end = kde - 1
12786   ELSE
12787     k_end = kte
12788   END IF
12789   DO j=j_start,j_end
12790     DO k=k_start,kte
12791       DO i=i_start,i_end
12792         z_at_w(i, k, j) = (ph(i, k, j)+phb(i, k, j))/g
12793       END DO
12794     END DO
12795   END DO
12796 !  compute full pii, rho, and z at the new time-level
12797 !  (needed for physics).
12798 !  convert perturbation theta to full theta (th_phy)
12799 !  use h_diabatic to temporarily save pre-microphysics full theta
12800   DO j=j_start,j_end
12801     DO k=k_start,k_end
12802       DO i=i_start,i_end
12803         IF (p_qv .GE. param_first_scalar) THEN
12804           CALL PUSHCONTROL1B(0)
12805         ELSE
12806           CALL PUSHCONTROL1B(1)
12807         END IF
12808         IF (p_qc .GE. param_first_scalar) THEN
12809           CALL PUSHCONTROL1B(0)
12810         ELSE
12811           CALL PUSHCONTROL1B(1)
12812         END IF
12813         z(i, k, j) = 0.5*(z_at_w(i, k, j)+z_at_w(i, k+1, j))
12814         pf(i, k, j) = p(i, k, j) + pb(i, k, j)
12815       END DO
12816     END DO
12817   END DO
12818   DO j=j_end,j_start,-1
12819     DO i=i_end,i_start,-1
12820       z0 = z_at_w(i, kte, j)
12821       z1 = z(i, k_end, j)
12822       z2 = z(i, k_end-1, j)
12823       w1 = (z0-z2)/(z1-z2)
12824       w2 = 1. - w1
12825       temp1 = LOG(pf(i, kde-2, j))
12826       temp0 = LOG(pf(i, kde-1, j))
12827       temp0b = EXP(w1*temp0+w2*temp1)*p8wb(i, kde, j)
12828       pfb(i, kde-1, j) = pfb(i, kde-1, j) + w1*temp0b/pf(i, kde-1, j)
12829       w2b = temp1*temp0b
12830       w1b = temp0*temp0b - w2b
12831       pfb(i, kde-2, j) = pfb(i, kde-2, j) + w2*temp0b/pf(i, kde-2, j)
12832       p8wb(i, kde, j) = 0.0
12833       temp0b0 = w1b/(z1-z2)
12834       temp0b1 = -((z0-z2)*temp0b0/(z1-z2))
12835       z0b = temp0b0
12836       z2b = -temp0b1 - temp0b0
12837       z1b = temp0b1
12838       zb(i, k_end-1, j) = zb(i, k_end-1, j) + z2b
12839       zb(i, k_end, j) = zb(i, k_end, j) + z1b
12840       z_at_wb(i, kte, j) = z_at_wb(i, kte, j) + z0b
12841       z0 = z_at_w(i, 1, j)
12842       z1 = z(i, 1, j)
12843       z2 = z(i, 2, j)
12844       w1 = (z0-z2)/(z1-z2)
12845       w2 = 1. - w1
12846       pfb(i, 1, j) = pfb(i, 1, j) + w1*p8wb(i, 1, j)
12847       w2b = pf(i, 2, j)*p8wb(i, 1, j)
12848       w1b = pf(i, 1, j)*p8wb(i, 1, j) - w2b
12849       pfb(i, 2, j) = pfb(i, 2, j) + w2*p8wb(i, 1, j)
12850       p8wb(i, 1, j) = 0.0
12851       temp0b2 = w1b/(z1-z2)
12852       temp0b3 = -((z0-z2)*temp0b2/(z1-z2))
12853       z0b = temp0b2
12854       z2b = -temp0b3 - temp0b2
12855       z1b = temp0b3
12856       zb(i, 2, j) = zb(i, 2, j) + z2b
12857       zb(i, 1, j) = zb(i, 1, j) + z1b
12858       z_at_wb(i, 1, j) = z_at_wb(i, 1, j) + z0b
12859     END DO
12860   END DO
12861   DO j=j_end,j_start,-1
12862     DO k=k_end,2,-1
12863       DO i=i_end,i_start,-1
12864         pfb(i, k, j) = pfb(i, k, j) + fzm(k)*p8wb(i, k, j)
12865         pfb(i, k-1, j) = pfb(i, k-1, j) + fzp(k)*p8wb(i, k, j)
12866         p8wb(i, k, j) = 0.0
12867       END DO
12868     END DO
12869   END DO
12870   DO j=j_end,j_start,-1
12871     DO k=k_end,k_start,-1
12872       DO i=i_end,i_start,-1
12873         IF ((pb(i, k, j)+p(i, k, j))/p0 .LE. 0.0 .AND. (rcp .EQ. 0.0 &
12874 &            .OR. rcp .NE. INT(rcp))) THEN
12875           pb0(i, k, j) = pb0(i, k, j) + pfb(i, k, j)
12876         ELSE
12877           pb0(i, k, j) = pb0(i, k, j) + rcp*((pb(i, k, j)+p(i, k, j))/p0&
12878 &            )**(rcp-1)*piib(i, k, j)/p0 + pfb(i, k, j)
12879         END IF
12880         pfb(i, k, j) = 0.0
12881         z_at_wb(i, k, j) = z_at_wb(i, k, j) + 0.5*zb(i, k, j)
12882         z_at_wb(i, k+1, j) = z_at_wb(i, k+1, j) + 0.5*zb(i, k, j)
12883         zb(i, k, j) = 0.0
12884         piib(i, k, j) = 0.0
12885         temp = alb(i, k, j) + al(i, k, j)
12886         alb0(i, k, j) = alb0(i, k, j) - rhob(i, k, j)/temp**2
12887         rhob(i, k, j) = 0.0
12888         CALL POPCONTROL1B(branch)
12889         IF (branch .EQ. 0) THEN
12890           qcb(i, k, j) = qcb(i, k, j) + qc_diabaticb(i, k, j)
12891           qc_diabaticb(i, k, j) = 0.0
12892         ELSE
12893           qc_diabaticb(i, k, j) = 0.0
12894         END IF
12895         CALL POPCONTROL1B(branch)
12896         IF (branch .EQ. 0) THEN
12897           qvb(i, k, j) = qvb(i, k, j) + qv_diabaticb(i, k, j)
12898           qv_diabaticb(i, k, j) = 0.0
12899         ELSE
12900           qv_diabaticb(i, k, j) = 0.0
12901         END IF
12902         th_phyb(i, k, j) = th_phyb(i, k, j) + h_diabaticb(i, k, j)
12903         h_diabaticb(i, k, j) = 0.0
12904         t_newb(i, k, j) = t_newb(i, k, j) + th_phyb(i, k, j)
12905         th_phyb(i, k, j) = 0.0
12906       END DO
12907     END DO
12908   END DO
12909   DO j=j_end,j_start,-1
12910     DO i=i_end,i_start,-1
12911       dz8wb(i, kte, j) = 0.0
12912     END DO
12913   END DO
12914   DO j=j_end,j_start,-1
12915     DO k=kte-1,k_start,-1
12916       DO i=i_end,i_start,-1
12917         z_at_wb(i, k+1, j) = z_at_wb(i, k+1, j) + dz8wb(i, k, j)
12918         z_at_wb(i, k, j) = z_at_wb(i, k, j) - dz8wb(i, k, j)
12919         dz8wb(i, k, j) = 0.0
12920       END DO
12921     END DO
12922   END DO
12923   DO j=j_end,j_start,-1
12924     DO k=kte,k_start,-1
12925       DO i=i_end,i_start,-1
12926         phb0(i, k, j) = phb0(i, k, j) + z_at_wb(i, k, j)/g
12927         z_at_wb(i, k, j) = 0.0
12928       END DO
12929     END DO
12930   END DO
12931 END SUBROUTINE A_MOIST_PHYSICS_PREP_EM
12932
12933 !        Generated by TAPENADE     (INRIA, Tropics team)
12934 !  Tapenade 3.7 (r4786) - 21 Feb 2013 15:53
12935 !
12936 !  Differentiation of moist_physics_finish_em in reverse (adjoint) mode (with options i4 r8):
12937 !   gradient     of useful results: th_phy h_diabatic t_new
12938 !   with respect to varying inputs: th_phy h_diabatic t_new
12939 !   RW status of diff variables: th_phy:incr h_diabatic:in-out
12940 !                t_new:in-out
12941 SUBROUTINE A_MOIST_PHYSICS_FINISH_EM(t_new, t_newb, t_old, t0, mut, &
12942 &  th_phy, th_phyb, h_diabatic, h_diabaticb, &
12943 &  qv, qvb, qv_diabatic, qv_diabaticb, &
12944 &  qc, qcb, qc_diabatic, qc_diabaticb, &
12945 &  dt, config_flags, ids, ide, &
12946 &  jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, &
12947 &  kts, kte)
12948   IMPLICIT NONE
12949 ! Here we construct full fields
12950 ! needed by the microphysics
12951   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
12952   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
12953   INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
12954   INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
12955   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_new, &
12956 &  t_old, th_phy, h_diabatic
12957   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qv, qc
12958   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: qvb, qcb
12959   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
12960 &   qv_diabatic, qv_diabaticb, qc_diabatic, qc_diabaticb
12961   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_newb
12962   REAL :: mpten, qvten, qcten
12963   REAL :: mptenb, qvtenb, qctenb
12964   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mut
12965   REAL, INTENT(IN) :: t0, dt
12966   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
12967   INTEGER :: i, j, k, imax, jmax, imin, jmin
12968   INTEGER :: branch
12969   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
12970 &  h_diabaticb
12971   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th_phyb
12972 !--------------------------------------------------------------------
12973 !<DESCRIPTION>
12974 !
12975 !  moist_phys_finish_em resets theta to its perturbation value and
12976 !  computes and stores the microphysics diabatic heating term.
12977 !
12978 !</DESCRIPTION>
12979 !  set up loop bounds for this grid's boundary conditions
12980   i_start = its
12981   IF (ite .GT. ide - 1) THEN
12982     i_end = ide - 1
12983   ELSE
12984     i_end = ite
12985   END IF
12986   j_start = jts
12987   IF (jte .GT. jde - 1) THEN
12988     j_end = jde - 1
12989   ELSE
12990     j_end = jte
12991   END IF
12992   k_start = kts
12993   IF (kte .GT. kde - 1) THEN
12994     k_end = kde - 1
12995   ELSE
12996     k_end = kte
12997   END IF
12998 !  add microphysics theta diff to perturbation theta, set h_diabatic
12999   IF (config_flags%no_mp_heating .EQ. 0) THEN
13000     DO j=j_start,j_end
13001       DO k=k_start,k_end
13002         DO i=i_start,i_end
13003           mpten = th_phy(i, k, j) - h_diabatic(i, k, j)
13004           IF (p_qv .GE. param_first_scalar) THEN
13005             !qvten = qv(i, k, j) - qv_diabatic(i, k, j)
13006             CALL PUSHCONTROL1B(0)
13007           ELSE
13008             CALL PUSHCONTROL1B(1)
13009           END IF
13010           IF (p_qc .GE. param_first_scalar) THEN
13011             !qcten = qc(i, k, j) - qc_diabatic(i, k, j)
13012             CALL PUSHCONTROL1B(0)
13013           ELSE
13014             CALL PUSHCONTROL1B(1)
13015           END IF
13016           IF (config_flags%mp_tend_lim*dt .GT. mpten) THEN
13017             CALL PUSHCONTROL1B(0)
13018             mpten = mpten
13019           ELSE
13020             mpten = config_flags%mp_tend_lim*dt
13021             CALL PUSHCONTROL1B(1)
13022           END IF
13023           IF (-(config_flags%mp_tend_lim*dt) .LT. mpten) THEN
13024             CALL PUSHCONTROL1B(0)
13025           ELSE
13026             CALL PUSHCONTROL1B(1)
13027           END IF
13028           IF (p_qv .GE. param_first_scalar) THEN
13029             CALL PUSHCONTROL1B(0)
13030           ELSE
13031             CALL PUSHCONTROL1B(1)
13032           END IF
13033           IF (p_qc .GE. param_first_scalar) THEN
13034             CALL PUSHCONTROL1B(0)
13035           ELSE
13036             CALL PUSHCONTROL1B(1)
13037           END IF
13038         END DO
13039       END DO
13040     END DO
13041     qvtenb = 0.0
13042     qctenb = 0.0
13043     DO j=j_end,j_start,-1
13044       DO k=k_end,k_start,-1
13045         DO i=i_end,i_start,-1
13046           CALL POPCONTROL1B(branch)
13047           IF (branch .EQ. 0) THEN
13048             qctenb = qctenb + qc_diabaticb(i, k, j)/dt
13049             qc_diabaticb(i, k, j) = 0.0
13050           ELSE
13051             qc_diabaticb(i, k, j) = 0.0
13052           END IF
13053           CALL POPCONTROL1B(branch)
13054           IF (branch .EQ. 0) THEN
13055             qvtenb = qvtenb + qv_diabaticb(i, k, j)/dt
13056             qv_diabaticb(i, k, j) = 0.0
13057           ELSE
13058             qv_diabaticb(i, k, j) = 0.0
13059           END IF
13060           mptenb = t_newb(i, k, j) + h_diabaticb(i, k, j)/dt
13061           h_diabaticb(i, k, j) = 0.0_8
13062           CALL POPCONTROL1B(branch)
13063           IF (branch .NE. 0) mptenb = 0.0_8
13064           CALL POPCONTROL1B(branch)
13065           IF (branch .NE. 0) mptenb = 0.0_8
13066           CALL POPCONTROL1B(branch)
13067           IF (branch .EQ. 0) THEN
13068             qcb(i, k, j) = qcb(i, k, j) + qctenb
13069             qc_diabaticb(i, k, j) = qc_diabaticb(i, k, j) - qctenb
13070             qctenb = 0.0
13071           END IF
13072           CALL POPCONTROL1B(branch)
13073           IF (branch .EQ. 0) THEN
13074             qvb(i, k, j) = qvb(i, k, j) + qvtenb
13075             qv_diabaticb(i, k, j) = qv_diabaticb(i, k, j) - qvtenb
13076             qvtenb = 0.0
13077           END IF
13078           th_phyb(i, k, j) = th_phyb(i, k, j) + mptenb
13079           h_diabaticb(i, k, j) = h_diabaticb(i, k, j) - mptenb
13080         END DO
13081       END DO
13082     END DO
13083   ELSE
13084     DO j=j_end,j_start,-1
13085       DO k=k_end,k_start,-1
13086         DO i=i_end,i_start,-1
13087           qc_diabaticb(i, k, j) = 0.0
13088           qv_diabaticb(i, k, j) = 0.0
13089           h_diabaticb(i, k, j) = 0.0_8
13090         END DO
13091       END DO
13092     END DO
13093   END IF
13094 END SUBROUTINE A_MOIST_PHYSICS_FINISH_EM
13095
13096    SUBROUTINE a_init_module_big_step
13097
13098    END SUBROUTINE a_init_module_big_step
13099
13100    SUBROUTINE a_set_tend(field,a_field,field_adv_tend,a_field_adv_tend,msf, &
13101 ! Revised by Ning Pan, 2010-07-19
13102 !   a_msf,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
13103    ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
13104
13105 !PART I: DECLARATION OF VARIABLES
13106
13107    IMPLICIT NONE
13108
13109    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
13110    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
13111    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field
13112    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field_adv_tend,a_field_adv_tend
13113 ! Revised by Ning Pan, 2010-07-19
13114 !   REAL,DIMENSION(ims:ime,jms:jme) :: msf,a_msf
13115    REAL,DIMENSION(ims:ime,jms:jme) :: msf
13116    INTEGER :: i,j,k,itf,jtf,ktf
13117
13118    REAL :: a_Tmpv1,Tmpv001
13119
13120 !PART II: CALCULATIONS OF B. S. TRAJECTORY
13121
13122 !LPB[0]
13123
13124          jtf = MIN(jte,jde-1)
13125          ktf = MIN(kte,kde-1)
13126          itf = MIN(ite,ide-1)
13127
13128 !!LPB[1]
13129 !         DO j = jts, jtf
13130
13131 !         DO k = kts, ktf
13132 !         DO i = its, itf
13133 !            field(i,k,j) = field_adv_tend(i,k,j)*msf(i,j)
13134 !         ENDDO
13135 !         ENDDO
13136
13137 !         ENDDO
13138
13139 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
13140
13141 !LPB[1]
13142    DO j =jtf, jts, -1
13143
13144 !  DO k =kts, ktf
13145 !  DO i =its, itf
13146 !  Tmpv001 =field_adv_tend(i,k,j)*msf(i,j)
13147 !  field(i,k,j) =Tmpv001
13148
13149 !  ENDDO
13150 !  ENDDO
13151
13152    DO k =ktf, kts, -1
13153    DO i =itf, its, -1
13154    a_Tmpv1 =a_field(i,k,j)
13155    a_field(i,k,j) =0.0
13156    a_field_adv_tend(i,k,j) =a_field_adv_tend(i,k,j) +msf(i,j)*a_Tmpv1
13157 !   a_msf(i,j) =a_msf(i,j) +field_adv_tend(i,k,j)*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-19
13158    ENDDO
13159    ENDDO
13160
13161    ENDDO
13162
13163 !LPB[0]
13164 !  jtf =min(jte, jde-1)
13165 !  ktf =min(kte, kde-1)
13166 !  itf =min(ite, ide-1)
13167
13168    END SUBROUTINE a_set_tend
13169
13170 !        Generated by TAPENADE     (INRIA, Tropics team)
13171 !  Tapenade 3.5 (r3805) - 29 Mar 2011 12:57
13172 !
13173 !  Differentiation of theta_relaxation in reverse (adjoint) mode:
13174 !   gradient     of useful results: t ph t_tendf mut
13175 !   with respect to varying inputs: t ph t_tendf mut
13176 !   RW status of diff variables: t:incr ph:incr t_tendf:in-out
13177 !                mut:incr
13178 SUBROUTINE A_THETA_RELAXATION(t_tendf, t_tendfb, t, tb, t_init, mut, &
13179 &  mutb, ph, phb0, phb, t_base, z_base, ids, ide, jds, jde, kds, kde, ims&
13180 &  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
13181   IMPLICIT NONE
13182   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
13183 &  jme, kms, kme, its, ite, jts, jte, kts, kte
13184   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_tendf
13185   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: t_tendfb
13186   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: t, t_init, &
13187 &  ph, phb
13188   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tb, phb0
13189   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
13190   REAL, DIMENSION(ims:ime, jms:jme) :: mutb
13191   REAL, DIMENSION(kms:kme), INTENT(IN) :: t_base, z_base
13192 ! Local variables.
13193   INTEGER :: i, j, k, ktf, k2
13194   REAL :: tau_r, rmax, rmin, inv_tau_r, inv_g, rterm
13195   REAL :: rtermb
13196   REAL, DIMENSION(kms:kme) :: z00, t00
13197   REAL, DIMENSION(kms:kme) :: z00b, t00b
13198   INTEGER :: branch
13199   INTEGER :: ad_to
13200   INTEGER :: min2
13201   INTEGER :: min1
13202   REAL :: tempb
13203 ! End declarations.
13204 !-----------------------------------------------------------------------
13205 ! set tau_r to 12 h, following RE87
13206   tau_r = 12.0*3600.0
13207 ! limit rterm to +/- 2 K/day
13208   rmax = 2.0/86400.0
13209   rmin = -rmax
13210   IF (kte .GT. kde - 1) THEN
13211     ktf = kde - 1
13212   ELSE
13213     ktf = kte
13214   END IF
13215   inv_tau_r = 1.0/tau_r
13216   inv_g = 1.0/g
13217   IF (jte .GT. jde - 1) THEN
13218     min1 = jde - 1
13219   ELSE
13220     min1 = jte
13221   END IF
13222 !-----------------------------------------------------------------------
13223 ! Adjust potential temperature to base state.
13224   DO j=jts,min1
13225     IF (ite .GT. ide - 1) THEN
13226       min2 = ide - 1
13227     ELSE
13228       min2 = ite
13229     END IF
13230     DO i=its,min2
13231 ! Get height of model levels:
13232       DO k=kts,ktf
13233         z00(k) = 0.5*(phb(i, k, j)+phb(i, k+1, j)+ph(i, k, j)+ph(i, k+1&
13234 &          , j))*inv_g
13235       END DO
13236 ! Get reference state:
13237       DO k=kts,ktf
13238         CALL PUSHINTEGER4(k2)
13239         k2 = ktf
13240         DO WHILE (z_base(k2) .GT. z00(k) .AND. k2 .GT. 1)
13241           k2 = k2 - 1
13242         END DO
13243         IF (k2 + 1 .GT. ktf) THEN
13244           t00(k) = t_base(k2) + (t_base(k2)-t_base(k2-1))*(z00(k)-z_base&
13245 &            (k2))/(z_base(k2)-z_base(k2-1))
13246           CALL PUSHCONTROL1B(1)
13247         ELSE
13248           t00(k) = t_base(k2) + (t_base(k2+1)-t_base(k2))*(z00(k)-z_base&
13249 &            (k2))/(z_base(k2+1)-z_base(k2))
13250           CALL PUSHCONTROL1B(0)
13251         END IF
13252       END DO
13253 ! Apply the RE87 R term:
13254       DO k=kts,ktf
13255         CALL PUSHREAL8(rterm)
13256         rterm = -((t(i, k, j)-t00(k))*inv_tau_r)
13257         IF (rterm .GT. rmax) THEN
13258           rterm = rmax
13259           CALL PUSHCONTROL1B(0)
13260         ELSE
13261           CALL PUSHCONTROL1B(1)
13262           rterm = rterm
13263         END IF
13264         IF (rterm .LT. rmin) THEN
13265           rterm = rmin
13266           CALL PUSHCONTROL1B(0)
13267         ELSE
13268           CALL PUSHCONTROL1B(1)
13269           rterm = rterm
13270         END IF
13271       END DO
13272     END DO
13273     CALL PUSHINTEGER4(i - 1)
13274   END DO
13275   t00b = 0.0
13276   z00b = 0.0
13277   DO j=min1,jts,-1
13278     CALL POPINTEGER4(ad_to)
13279     DO i=ad_to,its,-1
13280       DO k=ktf,kts,-1
13281         mutb(i, j) = mutb(i, j) + rterm*t_tendfb(i, k, j)
13282         rtermb = mut(i, j)*t_tendfb(i, k, j)
13283         CALL POPCONTROL1B(branch)
13284         IF (branch .EQ. 0) rtermb = 0.0
13285         CALL POPCONTROL1B(branch)
13286         IF (branch .EQ. 0) rtermb = 0.0
13287         CALL POPREAL8(rterm)
13288         tb(i, k, j) = tb(i, k, j) - inv_tau_r*rtermb
13289         t00b(k) = t00b(k) + inv_tau_r*rtermb
13290       END DO
13291       DO k=ktf,kts,-1
13292         CALL POPCONTROL1B(branch)
13293         IF (branch .EQ. 0) THEN
13294           z00b(k) = z00b(k) + (t_base(k2+1)-t_base(k2))*t00b(k)/(z_base(&
13295 &            k2+1)-z_base(k2))
13296           t00b(k) = 0.0
13297         ELSE
13298           z00b(k) = z00b(k) + (t_base(k2)-t_base(k2-1))*t00b(k)/(z_base(&
13299 &            k2)-z_base(k2-1))
13300           t00b(k) = 0.0
13301         END IF
13302         CALL POPINTEGER4(k2)
13303       END DO
13304       DO k=ktf,kts,-1
13305         tempb = inv_g*0.5*z00b(k)
13306         phb0(i, k, j) = phb0(i, k, j) + tempb
13307         phb0(i, k+1, j) = phb0(i, k+1, j) + tempb
13308         z00b(k) = 0.0
13309       END DO
13310     END DO
13311   END DO
13312 END SUBROUTINE A_THETA_RELAXATION
13313
13314    SUBROUTINE a_rk_rayleigh_damp(ru_tendf,a_ru_tendf,rv_tendf,a_rv_tendf,rw_tendf, &
13315 ! Revised by Ning Pan, 2010-07-23
13316 !   a_rw_tendf,t_tendf,a_t_tendf,u,a_u,v,a_v,w,a_w,t,a_t,t_init,a_t_init, &
13317 !   mut,a_mut,muu,a_muu,muv,a_muv,ph,a_ph,phb,a_phb,u_base,a_u_base,v_base, &
13318 !   a_v_base,t_base,a_t_base,z_base,a_z_base,dampcoef,a_dampcoef,zdamp,a_zdamp, &
13319    a_rw_tendf,t_tendf,a_t_tendf,u,a_u,v,a_v,w,a_w,t,a_t,t_init, &
13320    mut,a_mut,muu,a_muu,muv,a_muv,ph,a_ph,phb,u_base,v_base, &
13321    t_base,z_base,dampcoef,zdamp, &
13322    ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
13323
13324 !PART I: DECLARATION OF VARIABLES
13325
13326    IMPLICIT NONE
13327
13328    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
13329    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
13330    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tendf,a_ru_tendf,rv_tendf, &
13331    a_rv_tendf,rw_tendf,a_rw_tendf,t_tendf,a_t_tendf
13332    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,a_u,v,a_v,w,a_w,t,a_t,t_init, &
13333 ! Revised by Ning Pan, 2010-07-23
13334 !   a_t_init,ph,a_ph,phb,a_phb
13335    ph,a_ph,phb
13336    REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut,muu,a_muu,muv,a_muv
13337 ! Revised by Ning Pan, 2010-07-23
13338 !   REAL,DIMENSION(kms:kme) :: u_base,a_u_base,v_base,a_v_base,t_base,a_t_base, &
13339 !   z_base,a_z_base
13340 !   REAL :: dampcoef,a_dampcoef,zdamp,a_zdamp
13341    REAL,DIMENSION(kms:kme) :: u_base,v_base,t_base,z_base
13342    REAL :: dampcoef,zdamp
13343    INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end,i,j,k,ktf,k1,k2
13344 ! Revised by Ning Pan, 2010-07-23
13345 !   REAL :: pii,a_pii,dcoef,a_dcoef,z,a_z,ztop,a_ztop
13346 !   REAL :: wkp1,a_wkp1,wk,a_wk,wkm1,a_wkm1
13347    REAL :: pii,dcoef,a_dcoef,z,a_z,ztop,a_ztop
13348    REAL,DIMENSION(kms:kme) :: z00,a_z00,u00,a_u00,v00,a_v00,t00,a_t00
13349
13350    REAL,DIMENSION(jts:min(jte, jde)) :: Keep_Lpb2_ztop
13351    REAL,DIMENSION(jts:min(jte, jde)) :: Keep_Lpb2_dcoef
13352    REAL,DIMENSION(jts:min(jte, jde-1)) :: Keep_Lpb3_ztop
13353    REAL,DIMENSION(jts:min(jte, jde-1)) :: Keep_Lpb3_dcoef
13354 !  REAL,DIMENSION(jts:min(jte, jde-1)) :: Keep_Lpb4_ztop
13355 !  REAL,DIMENSION(jts:min(jte, jde-1)) :: Keep_Lpb4_dcoef
13356    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
13357    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9,Tmpv009
13358 !REVISED BY WALLS
13359 !  REAL,DIMENSION(k1+2:min(kte,kde-1)) :: Tmpv200
13360    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv200
13361    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv201
13362    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv202
13363    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv203
13364    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv204
13365    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv205
13366    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv206
13367    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv207
13368    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv208
13369    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv209
13370    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2010
13371    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2011
13372    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2012
13373    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2013
13374    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2014
13375    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2015
13376    REAL,DIMENSION(kts:min(kte,kde-1)) :: Tmpv2016
13377    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv300
13378    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv301
13379    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv302
13380    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv303
13381    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv304
13382    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv305
13383    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv306
13384    REAL,DIMENSION(kts:min(kte, kde),its:min(ite, ide-1)) :: Tmpv307
13385
13386 !REVISED BY WALLS
13387 !!This line is fail to be recognized
13388 !         DO WHILE( z >= (ztop-zdamp) )
13389 !
13390 !!This line is fail to be recognized
13391 !         DO WHILE( z >= (ztop-zdamp) )
13392 !
13393 !!This line is fail to be recognized
13394 !         DO WHILE( z >= (ztop-zdamp) )
13395
13396 !PART II: CALCULATIONS OF B. S. TRAJECTORY
13397
13398 !LPB[0]
13399        pii = 2.0 * asin(1.0)
13400        ktf = MIN( kte,   kde-1 )
13401
13402 !LPB[1]
13403 !DELETED BY WALLS, ERRORS IN DO WHILE STRUCTURES
13404
13405 !       DO j = jts, MIN( jte, jde-1 )
13406 !
13407 !       DO i = its, MIN( ite, ide   )
13408 !         ztop = 0.5*( phb(i  ,kde,j)+phb(i-1,kde,j)     &
13409 !                     +ph(i  ,kde,j)+ph(i-1,kde,j) )/g
13410 !         k1 = ktf
13411 !         z = ztop
13412 !           z = 0.25*( phb(i  ,k1,j)+phb(i  ,k1+1,j)    &
13413 !                     +phb(i-1,k1,j)+phb(i-1,k1+1,j)    &
13414 !                     +ph(i  ,k1,j)+ph(i  ,k1+1,j)      &
13415 !                     +ph(i-1,k1,j)+ph(i-1,k1+1,j))/g
13416 !           z00(k1) = z
13417 !           k1 = k1 - 1
13418 !         ENDDO
13419 !         k1 = k1 + 2
13420 !
13421 !         DO k = k1, ktf
13422 !           k2 = ktf
13423 !
13424 !           DO WHILE( z_base(k2) .gt. z00(k) )
13425 !             k2 = k2 - 1
13426 !           ENDDO
13427 !        if(k2+1.gt.ktf)then
13428 !
13429 !             u00(k) = u_base(k2) + ( u_base(k2) - u_base(k2-1) )     &
13430 !                                 * (     z00(k) - z_base(k2)   )     &
13431 !                                 / ( z_base(k2) - z_base(k2-1) )
13432 !           else
13433 !             u00(k) = u_base(k2) + ( u_base(k2+1) - u_base(k2) )     &
13434 !                                 * (       z00(k) - z_base(k2) )     &
13435 !                                 / ( z_base(k2+1) - z_base(k2) )
13436 !           endif
13437 !         ENDDO
13438 !
13439 !         DO k = k1, ktf
13440 !           dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp )
13441 !           dcoef = (SIN( 0.5 * pii * dcoef ) )**2
13442 !           ru_tendf(i,k,j) = ru_tendf(i,k,j) -                      &
13443 !                             muu(i,j) * ( dcoef * dampcoef ) *      &
13444 !                             ( u(i,k,j) - u00(k) )
13445 !         END DO
13446 !
13447 !       END DO
13448 !
13449 !!LPB[2]
13450 !       DO j = jts, MIN( jte, jde   )
13451 !
13452 !       Keep_Lpb2_ztop(j) =ztop
13453 !       Keep_Lpb2_dcoef(j) =dcoef
13454 !
13455 !       END DO
13456 !       DO i = its, MIN( ite, ide-1 )
13457 !         ztop = 0.5*( phb(i,kde,j  )+phb(i,kde,j-1)     &
13458 !                     +ph(i,kde,j  )+ph(i,kde,j-1) )/g
13459 !         k1 = ktf
13460 !         z = ztop
13461 !           z = 0.25*( phb(i,k1,j  )+phb(i,k1+1,j  )    &
13462 !                     +phb(i,k1,j-1)+phb(i,k1+1,j-1)    &
13463 !                     +ph(i,k1,j  )+ph(i,k1+1,j  )      &
13464 !                     +ph(i,k1,j-1)+ph(i,k1+1,j-1))/g
13465 !           z00(k1) = z
13466 !           k1 = k1 - 1
13467 !         ENDDO
13468 !         k1 = k1 + 2
13469 !
13470 !         DO k = k1, ktf
13471 !           k2 = ktf
13472 !
13473 !           DO WHILE( z_base(k2) .gt. z00(k) )
13474 !             k2 = k2 - 1
13475 !           ENDDO
13476 !        if(k2+1.gt.ktf)then
13477 !
13478 !             v00(k) = v_base(k2) + ( v_base(k2) - v_base(k2-1) )     &
13479 !                                 * (     z00(k) - z_base(k2)   )     &
13480 !                                 / ( z_base(k2) - z_base(k2-1) )
13481 !           else
13482 !             v00(k) = v_base(k2) + ( v_base(k2+1) - v_base(k2) )     &
13483 !                                 * (       z00(k) - z_base(k2) )     &
13484 !                                 / ( z_base(k2+1) - z_base(k2) )
13485 !           endif
13486 !         ENDDO
13487 !
13488 !         DO k = k1, ktf
13489 !           dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp )
13490 !           dcoef = (SIN( 0.5 * pii * dcoef ) )**2
13491 !           rv_tendf(i,k,j) = rv_tendf(i,k,j) -                      &
13492 !                             muv(i,j) * ( dcoef * dampcoef ) *      &
13493 !                             ( v(i,k,j) - v00(k) )
13494 !         END DO
13495 !
13496 !       END DO
13497
13498 !LPB[3]
13499 !       DO j = jts, MIN( jte,   jde-1 )
13500 !
13501 !       Keep_Lpb3_ztop(j) =ztop
13502 !       Keep_Lpb3_dcoef(j) =dcoef
13503 !
13504 !       END DO
13505 !       DO i = its, MIN( ite,   ide-1 )
13506 !         ztop = ( phb(i,kde,j) + ph(i,kde,j) ) / g
13507 !
13508 !         DO k = kts, MIN( kte,   kde   )
13509 !           z = ( phb(i,k,j) + ph(i,k,j) ) / g
13510 !        IF ( z >= (ztop-zdamp) ) THEN
13511 !
13512 !             dcoef = 1.0 - MIN( 1.0, ( ztop - z ) / zdamp )
13513 !             dcoef = ( SIN( 0.5 * pii * dcoef ) )**2
13514 !             rw_tendf(i,k,j) = rw_tendf(i,k,j) -    &
13515 !                               mut(i,j) * ( dcoef * dampcoef ) * w(i,k,j)
13516 !           END IF
13517 !         END DO
13518 !       END DO
13519 !
13520 !       END DO
13521 !
13522 !!!LPB[4]
13523 !       DO j = jts, MIN( jte,   jde-1 )
13524 !
13525 !!    !  Keep_Lpb4_ztop(j) =ztop
13526 !!    !  Keep_Lpb4_dcoef(j) =dcoef
13527
13528 !!       DO i = its, MIN( ite,   ide-1 )
13529 !!         ztop = ( phb(i,kde,j) + ph(i,kde,j) ) / g
13530 !!         k1 = ktf
13531 !!         z = ztop
13532 !           z = 0.5 * ( phb(i,k1,j) + phb(i,k1+1,j) +    &
13533 !!!                        ph(i,k1,j) +  ph(i,k1+1,j) ) / g
13534 !!           z00(k1) = z
13535 !!           k1 = k1 - 1
13536 !         ENDDO
13537 !!         k1 = k1 + 2
13538 !
13539 !!         DO k = k1, ktf
13540 !!           k2 = ktf
13541 !
13542 !!           DO WHILE( z_base(k2) .gt. z00(k) )
13543 !!             k2 = k2 - 1
13544 !!           ENDDO
13545 !!        if(k2+1.gt.ktf)then
13546 !
13547 !!             t00(k) = t_base(k2) + ( t_base(k2) - t_base(k2-1) )     &
13548 !                                 * (     z00(k) - z_base(k2)   )     &
13549 !!                                 / ( z_base(k2) - z_base(k2-1) )
13550 !!           else
13551 !!             t00(k) = t_base(k2) + ( t_base(k2+1) - t_base(k2) )     &
13552 !!                                 * (       z00(k) - z_base(k2) )     &
13553 !!                                 / ( z_base(k2+1) - z_base(k2) )
13554 !!           endif
13555 !         ENDDO
13556 !
13557 !!         DO k = k1, ktf
13558 !!           dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp )
13559 !!           dcoef = (SIN( 0.5 * pii * dcoef ) )**2
13560 !!           t_tendf(i,k,j) = t_tendf(i,k,j) -                        &
13561 !                            mut(i,j) * ( dcoef * dampcoef )  *      &
13562 !!                            ( t(i,k,j) - t00(k) )
13563 !!         END DO
13564 !
13565 !!       END DO
13566 !
13567 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
13568
13569 !   a_pii =0.0  ! Remarked by Ning Pan, 2010-07-23
13570    a_dcoef =0.0
13571    a_z =0.0
13572    a_ztop =0.0
13573 ! Remarked by Ning Pan, 2010-07-23
13574 !   a_wkp1 =0.0
13575 !   a_wk =0.0
13576 !   a_wkm1 =0.0
13577
13578    Do K0_ADJ =kms, kme
13579    a_z00(K0_ADJ) =0.0
13580    End Do
13581
13582    Do K0_ADJ =kms, kme
13583    a_u00(K0_ADJ) =0.0
13584    End Do
13585
13586    Do K0_ADJ =kms, kme
13587    a_v00(K0_ADJ) =0.0
13588    End Do
13589
13590    Do K0_ADJ =kms, kme
13591    a_t00(K0_ADJ) =0.0
13592    End Do
13593
13594 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
13595
13596 !LPB[4]
13597    DO j =min(jte, jde-1), jts, -1
13598
13599 !  ztop =Keep_Lpb4_ztop(j)
13600 !  dcoef =Keep_Lpb4_dcoef(j)
13601
13602    DO i =its, min(ite, ide-1)
13603    Tmpv001 =phb(i,kde,j) +ph(i,kde,j)
13604    Tmpv002 =Tmpv001/g
13605    ztop =Tmpv002
13606
13607    k1 =ktf
13608    z =ztop  ! Removed remark by Ning Pan, 2010-07-23
13609
13610    DO WHILE( z >= (ztop-zdamp) )  ! Added by Ning Pan, 2010-07-23
13611    Tmpv001 =phb(i,k1,j) +phb(i,k1+1,j)
13612    Tmpv002 =Tmpv001 +ph(i,k1,j)
13613    Tmpv003 =Tmpv002 +ph(i,k1+1,j)
13614    Tmpv004 =0.5*Tmpv003
13615    Tmpv005 =Tmpv004/g
13616    z =Tmpv005  ! Removed remark by Ning Pan, 2010-07-23
13617
13618    z00(k1) =z
13619
13620    k1 =k1-1
13621    ENDDO
13622
13623    k1 =k1+2
13624    DO k =k1, ktf
13625    k2 =ktf
13626
13627    DO WHILE(z_base(k2) .gt. z00(k))
13628    k2 =k2-1
13629    ENDDO
13630    IF(k2+1.gt.ktf) THEN
13631    Tmpv001 =t_base(k2) -t_base(k2-1)
13632    Tmpv002 =z00(k) -z_base(k2)
13633    Tmpv200(k) =Tmpv001
13634    Tmpv201(k) =Tmpv002
13635    Tmpv003 =Tmpv200(k)*Tmpv201(k)
13636    Tmpv004 =z_base(k2) -z_base(k2-1)
13637    Tmpv202(k) =Tmpv003
13638    Tmpv203(k) =Tmpv004
13639    Tmpv005 =Tmpv202(k)/Tmpv203(k)
13640    Tmpv006 =t_base(k2) +Tmpv005
13641    t00(k) =Tmpv006
13642
13643    else
13644    Tmpv001 =t_base(k2+1) -t_base(k2)
13645    Tmpv002 =z00(k) -z_base(k2)
13646    Tmpv204(k) =Tmpv001
13647    Tmpv205(k) =Tmpv002
13648    Tmpv003 =Tmpv204(k)*Tmpv205(k)
13649    Tmpv004 =z_base(k2+1) -z_base(k2)
13650    Tmpv206(k) =Tmpv003
13651    Tmpv207(k) =Tmpv004
13652    Tmpv005 =Tmpv206(k)/Tmpv207(k)
13653    Tmpv006 =t_base(k2) +Tmpv005
13654    t00(k) =Tmpv006
13655
13656    endif
13657    ENDDO
13658
13659    DO k =k1, ktf
13660    Tmpv001 =ztop -z00(k)
13661    Tmpv208(k) =Tmpv001
13662    Tmpv002 =Tmpv208(k)/zdamp
13663    Tmpv209(k) =Tmpv002
13664    Tmpv003 =1.0 -min(1.0, Tmpv209(k))
13665    Tmpv2010(k) =dcoef
13666    dcoef =Tmpv003
13667
13668    Tmpv001 =0.5*pii*dcoef
13669    Tmpv2011(k) =Tmpv001
13670    Tmpv002 =sin(Tmpv2011(k))
13671    Tmpv2012(k) =Tmpv002
13672    Tmpv003 =Tmpv2012(k)**2
13673    Tmpv2013(k) =dcoef
13674    dcoef =Tmpv003
13675
13676    Tmpv001 =dcoef*dampcoef
13677    Tmpv2014(k) =Tmpv001
13678    Tmpv002 =mut(i,j)*Tmpv2014(k)
13679    Tmpv003 =t(i,k,j) -t00(k)
13680    Tmpv2015(k) =Tmpv002
13681    Tmpv2016(k) =Tmpv003
13682 ! Remarked by Ning Pan, 2010-07-23
13683 !   Tmpv004 =Tmpv2015(k)*Tmpv2016(k)
13684 !   Tmpv005 =t_tendf(i,k,j) -Tmpv004
13685 !!  t_tendf(i,k,j) =Tmpv005
13686
13687    ENDDO
13688
13689    DO k =ktf, k1, -1
13690    a_Tmpv5 =a_t_tendf(i,k,j)
13691    a_t_tendf(i,k,j) =0.0
13692    a_t_tendf(i,k,j) =a_t_tendf(i,k,j) +a_Tmpv5
13693    a_Tmpv4 =-a_Tmpv5
13694    a_Tmpv2 =Tmpv2016(k)*a_Tmpv4
13695    a_Tmpv3 =Tmpv2015(k)*a_Tmpv4
13696    a_t(i,k,j) =a_t(i,k,j) +a_Tmpv3
13697    a_t00(k) =a_t00(k) -a_Tmpv3
13698    a_mut(i,j) =a_mut(i,j) +Tmpv2014(k)*a_Tmpv2
13699    a_Tmpv1 =mut(i,j)*a_Tmpv2
13700    a_dcoef =a_dcoef +dampcoef*a_Tmpv1
13701 !   a_dampcoef =a_dampcoef +dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13702
13703 !   dcoef =Tmpv2013(k)  ! Remarked by Ning Pan, 2010-07-24
13704
13705    a_Tmpv3 =a_dcoef
13706    a_dcoef =0.0
13707    a_Tmpv2 =2.0*Tmpv2012(k)*a_Tmpv3
13708    a_Tmpv1 =cos(Tmpv2011(k))*a_Tmpv2
13709 !   a_pii =a_pii +0.5*dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13710    a_dcoef =a_dcoef +0.5*pii*a_Tmpv1
13711
13712 !   dcoef =Tmpv2010(k) ! Remarked by Ning Pan, 2010-07-23
13713
13714    a_Tmpv3 =a_dcoef
13715    a_dcoef =0.0
13716 !STOP  ! Remarked by Ning Pan, 2010-07-23
13717 !REVISED BY WALLS
13718 !  (1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv209(k)))*0.5* =-a_Tmpv3
13719    a_Tmpv2 = -(1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv209(k)))*0.5*a_Tmpv3  ! Added by Ning Pan, 2010-07-23
13720    a_Tmpv1 =a_Tmpv2/zdamp
13721 !   a_zdamp =a_zdamp -Tmpv208(k)/(zdamp*zdamp)*a_Tmpv2  ! Remarked by Ning Pan, 2010-07-23
13722    a_ztop =a_ztop +a_Tmpv1
13723    a_z00(k) =a_z00(k) -a_Tmpv1
13724    ENDDO
13725
13726    DO k =ktf, k1, -1
13727
13728 ! Added by Ning Pan, 2010-07-23
13729    k2 = ktf
13730    DO WHILE(z_base(k2) .gt. z00(k))
13731    k2 =k2-1
13732    ENDDO
13733
13734    IF(k2+1.gt.ktf) THEN
13735
13736    a_Tmpv6 =a_t00(k)
13737    a_t00(k) =0.0
13738 !   a_t_base(k2) =a_t_base(k2) +a_Tmpv6  ! Remarked by Ning Pan, 2010-07-23
13739    a_Tmpv5 =a_Tmpv6
13740    a_Tmpv3 =a_Tmpv5/Tmpv203(k)
13741 ! Remarked by Ning Pan, 2010-07-23
13742 !   a_Tmpv4 =-Tmpv202(k)/(Tmpv203(k)*Tmpv203(k))*a_Tmpv5
13743 !   a_z_base(k2) =a_z_base(k2) +a_Tmpv4
13744 !   a_z_base(k2-1) =a_z_base(k2-1) -a_Tmpv4
13745 !   a_Tmpv1 =Tmpv201(k)*a_Tmpv3
13746    a_Tmpv2 =Tmpv200(k)*a_Tmpv3
13747    a_z00(k) =a_z00(k) +a_Tmpv2
13748 ! Remarked by Ning Pan, 2010-07-23
13749 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv2
13750 !   a_t_base(k2) =a_t_base(k2) +a_Tmpv1
13751 !   a_t_base(k2-1) =a_t_base(k2-1) -a_Tmpv1
13752
13753    else
13754
13755    a_Tmpv6 =a_t00(k)
13756    a_t00(k) =0.0
13757 !   a_t_base(k2) =a_t_base(k2) +a_Tmpv6  ! Remarked by Ning Pan, 2010-07-23
13758    a_Tmpv5 =a_Tmpv6
13759    a_Tmpv3 =a_Tmpv5/Tmpv207(k)
13760 ! Remarked by Ning Pan, 2010-07-23
13761 !   a_Tmpv4 =-Tmpv206(k)/(Tmpv207(k)*Tmpv207(k))*a_Tmpv5
13762 !   a_z_base(k2+1) =a_z_base(k2+1) +a_Tmpv4
13763 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv4
13764 !   a_Tmpv1 =Tmpv205(k)*a_Tmpv3
13765    a_Tmpv2 =Tmpv204(k)*a_Tmpv3
13766    a_z00(k) =a_z00(k) +a_Tmpv2
13767 ! Remarked by Ning Pan, 2010-07-23
13768 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv2
13769 !   a_t_base(k2+1) =a_t_base(k2+1) +a_Tmpv1
13770 !   a_t_base(k2) =a_t_base(k2) -a_Tmpv1
13771
13772    endif
13773 ! Remarked by Ning Pan, 2010-07-23
13774 !   DO
13775 !   ENDDO
13776
13777    ENDDO
13778
13779 !   DO i =min(ite, ide-1), its, -1  ! Remarked by Ning Pan, 2010-07-23
13780    DO k = k1-1, ktf  ! Added by Ning Pan, 2010-07-23
13781 ! Revised by Ning Pan, 2010-07-23
13782 !   a_z =a_z +a_z00(k1)
13783 !   a_z00(k1) =0.0
13784    a_z =a_z +a_z00(k)
13785    a_z00(k) =0.0
13786    a_Tmpv5 =a_z
13787    a_z =0.0
13788    a_Tmpv4 =a_Tmpv5/g
13789    a_Tmpv3 =0.5*a_Tmpv4
13790    a_Tmpv2 =a_Tmpv3
13791 ! Revised by Ning Pan, 2010-07-23
13792 !   a_ph(i,k1+1,j) =a_ph(i,k1+1,j) +a_Tmpv3
13793    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv3
13794    a_Tmpv1 =a_Tmpv2
13795 ! Revised by Ning Pan, 2010-07-23
13796 !   a_ph(i,k1,j) =a_ph(i,k1,j) +a_Tmpv2
13797    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv2
13798 ! Remarked by Ning Pan, 2010-07-23
13799 !   a_phb(i,k1,j) =a_phb(i,k1,j) +a_Tmpv1
13800 !   a_phb(i,k1+1,j) =a_phb(i,k1+1,j) +a_Tmpv1
13801    ENDDO  ! Added by Ning Pan, 2010-07-23
13802    a_Tmpv2 =a_ztop
13803    a_ztop =0.0
13804    a_Tmpv1 =a_Tmpv2/g
13805 !   a_phb(i,kde,j) =a_phb(i,kde,j) +a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13806    a_ph(i,kde,j) =a_ph(i,kde,j) +a_Tmpv1
13807    ENDDO
13808
13809    ENDDO
13810
13811 !LPB[3]
13812    DO j =min(jte, jde-1), jts, -1
13813
13814 ! Remarked by Ning Pan, 2010-07-23
13815 !   ztop =Keep_Lpb3_ztop(j)
13816 !   dcoef =Keep_Lpb3_dcoef(j)
13817
13818    DO i =its, min(ite, ide-1)
13819    Tmpv001 =phb(i,kde,j) +ph(i,kde,j)
13820    Tmpv002 =Tmpv001/g
13821    ztop =Tmpv002
13822
13823    DO k =kts, min(kte, kde)
13824    Tmpv001 =phb(i,k,j) +ph(i,k,j)
13825    Tmpv002 =Tmpv001/g
13826    z =Tmpv002
13827
13828    IF( z >= (ztop-zdamp) ) THEN
13829    Tmpv001 =ztop -z
13830    Tmpv300(k,i) =Tmpv001
13831    Tmpv002 =Tmpv300(k,i)/zdamp
13832    Tmpv301(k,i) =Tmpv002
13833    Tmpv003 =1.0 -min(1.0, Tmpv301(k,i))
13834    Tmpv302(k,i) =dcoef
13835    dcoef =Tmpv003
13836
13837    Tmpv001 =0.5*pii*dcoef
13838    Tmpv303(k,i) =Tmpv001
13839    Tmpv002 =sin(Tmpv303(k,i))
13840    Tmpv304(k,i) =Tmpv002
13841    Tmpv003 =Tmpv304(k,i)**2
13842    Tmpv305(k,i) =dcoef
13843    dcoef =Tmpv003
13844
13845    Tmpv001 =dcoef*dampcoef
13846    Tmpv306(k,i) =Tmpv001
13847    Tmpv002 =mut(i,j)*Tmpv306(k,i)
13848    Tmpv307(k,i) =Tmpv002
13849 ! Remarked by Ning Pan, 2010-07-24
13850 !   Tmpv003 =Tmpv307(k,i)*w(i,k,j)
13851 !   Tmpv004 =rw_tendf(i,k,j) -Tmpv003
13852 !!  rw_tendf(i,k,j) =Tmpv004
13853
13854    END IF
13855 ! Remarked by Ning Pan, 2010-07-23
13856 !   ENDDO
13857 !   ENDDO
13858
13859 ! Remarked by Ning Pan, 2010-07-23
13860 !   DO i =min(ite, ide-1), its, -1
13861 !   DO k =min(kte, kde), kts, -1
13862
13863    IF( z >= (ztop-zdamp) ) THEN
13864
13865    a_Tmpv4 =a_rw_tendf(i,k,j)
13866    a_rw_tendf(i,k,j) =0.0
13867    a_rw_tendf(i,k,j) =a_rw_tendf(i,k,j) +a_Tmpv4
13868    a_Tmpv3 =-a_Tmpv4
13869    a_Tmpv2 =w(i,k,j)*a_Tmpv3
13870    a_w(i,k,j) =a_w(i,k,j) +Tmpv307(k,i)*a_Tmpv3
13871    a_mut(i,j) =a_mut(i,j) +Tmpv306(k,i)*a_Tmpv2
13872    a_Tmpv1 =mut(i,j)*a_Tmpv2
13873    a_dcoef =a_dcoef +dampcoef*a_Tmpv1
13874 !   a_dampcoef =a_dampcoef +dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13875
13876 !   dcoef =Tmpv305(k,i)  ! Remarkedby Ning Pan, 2010-07-24
13877
13878    a_Tmpv3 =a_dcoef
13879    a_dcoef =0.0
13880    a_Tmpv2 =2.0*Tmpv304(k,i)*a_Tmpv3
13881    a_Tmpv1 =cos(Tmpv303(k,i))*a_Tmpv2
13882 !   a_pii =a_pii +0.5*dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13883    a_dcoef =a_dcoef +0.5*pii*a_Tmpv1
13884
13885 !   dcoef =Tmpv302(k,i)  ! Remarked by Ning Pan, 2010-07-23
13886
13887    a_Tmpv3 =a_dcoef
13888    a_dcoef =0.0
13889 !STOP  ! Remarked by Ning Pan, 2010-07-23
13890 !REVISED BY WALLS
13891 !  (1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv301(k,i)))*0.5* =-a_Tmpv3
13892    a_Tmpv2 = -(1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv301(k,i)))*0.5*a_Tmpv3  ! Added by Ning Pan, 2010-07-23
13893    a_Tmpv1 =a_Tmpv2/zdamp
13894 !   a_zdamp =a_zdamp -Tmpv300(k,i)/(zdamp*zdamp)*a_Tmpv2  ! Remarked by Ning Pan, 2010-07-23
13895    a_ztop =a_ztop +a_Tmpv1
13896    a_z =a_z -a_Tmpv1
13897
13898    END IF
13899    a_Tmpv2 =a_z
13900    a_z =0.0
13901    a_Tmpv1 =a_Tmpv2/g
13902 !   a_phb(i,k,j) =a_phb(i,k,j) +a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13903    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv1
13904    ENDDO
13905    a_Tmpv2 =a_ztop
13906    a_ztop =0.0
13907    a_Tmpv1 =a_Tmpv2/g
13908 !   a_phb(i,kde,j) =a_phb(i,kde,j) +a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
13909    a_ph(i,kde,j) =a_ph(i,kde,j) +a_Tmpv1
13910    ENDDO
13911
13912    ENDDO
13913
13914 !LPB[2]
13915    DO j =min(jte, jde), jts, -1
13916
13917 ! Remarked by Ning Pan, 2010-07-23
13918 !   ztop =Keep_Lpb2_ztop(j)
13919 !   dcoef =Keep_Lpb2_dcoef(j)
13920
13921    DO i =its, min(ite, ide-1)
13922    Tmpv001 =phb(i,kde,j) +phb(i,kde,j-1)
13923    Tmpv002 =Tmpv001 +ph(i,kde,j)
13924    Tmpv003 =Tmpv002 +ph(i,kde,j-1)
13925    Tmpv004 =0.5*Tmpv003
13926    Tmpv005 =Tmpv004/g
13927    ztop =Tmpv005
13928
13929    k1 =ktf
13930    z =ztop  ! Removed remark by Ning Pan, 2010-07-23
13931
13932    DO WHILE( z >= (ztop-zdamp) )  ! Added by Ning Pan, 2010-07-23
13933    Tmpv001 =phb(i,k1,j) +phb(i,k1+1,j)
13934    Tmpv002 =Tmpv001 +phb(i,k1,j-1)
13935    Tmpv003 =Tmpv002 +phb(i,k1+1,j-1)
13936    Tmpv004 =Tmpv003 +ph(i,k1,j)
13937    Tmpv005 =Tmpv004 +ph(i,k1+1,j)
13938    Tmpv006 =Tmpv005 +ph(i,k1,j-1)
13939    Tmpv007 =Tmpv006 +ph(i,k1+1,j-1)
13940    Tmpv008 =0.25*Tmpv007
13941    Tmpv009 =Tmpv008/g
13942    z =Tmpv009  ! Removed remark by Ning Pan, 2010-07-23
13943
13944    z00(k1) =z
13945
13946    k1 =k1-1
13947    ENDDO
13948
13949    k1 =k1+2
13950    DO k =k1, ktf
13951    k2 =ktf
13952
13953    DO WHILE(z_base(k2) .gt. z00(k))
13954    k2 =k2-1
13955    ENDDO
13956    IF(k2+1.gt.ktf) THEN
13957    Tmpv001 =v_base(k2) -v_base(k2-1)
13958    Tmpv002 =z00(k) -z_base(k2)
13959    Tmpv200(k) =Tmpv001
13960    Tmpv201(k) =Tmpv002
13961    Tmpv003 =Tmpv200(k)*Tmpv201(k)
13962    Tmpv004 =z_base(k2) -z_base(k2-1)
13963    Tmpv202(k) =Tmpv003
13964    Tmpv203(k) =Tmpv004
13965    Tmpv005 =Tmpv202(k)/Tmpv203(k)
13966    Tmpv006 =v_base(k2) +Tmpv005
13967    v00(k) =Tmpv006
13968
13969    else
13970    Tmpv001 =v_base(k2+1) -v_base(k2)
13971    Tmpv002 =z00(k) -z_base(k2)
13972    Tmpv204(k) =Tmpv001
13973    Tmpv205(k) =Tmpv002
13974    Tmpv003 =Tmpv204(k)*Tmpv205(k)
13975    Tmpv004 =z_base(k2+1) -z_base(k2)
13976    Tmpv206(k) =Tmpv003
13977    Tmpv207(k) =Tmpv004
13978    Tmpv005 =Tmpv206(k)/Tmpv207(k)
13979    Tmpv006 =v_base(k2) +Tmpv005
13980    v00(k) =Tmpv006
13981
13982    endif
13983    ENDDO
13984
13985    DO k =k1, ktf
13986    Tmpv001 =ztop -z00(k)
13987    Tmpv208(k) =Tmpv001
13988    Tmpv002 =Tmpv208(k)/zdamp
13989    Tmpv209(k) =Tmpv002
13990    Tmpv003 =1.0 -min(1.0, Tmpv209(k))
13991    Tmpv2010(k) =dcoef
13992    dcoef =Tmpv003
13993
13994    Tmpv001 =0.5*pii*dcoef
13995    Tmpv2011(k) =Tmpv001
13996    Tmpv002 =sin(Tmpv2011(k))
13997    Tmpv2012(k) =Tmpv002
13998    Tmpv003 =Tmpv2012(k)**2
13999    Tmpv2013(k) =dcoef
14000    dcoef =Tmpv003
14001
14002    Tmpv001 =dcoef*dampcoef
14003    Tmpv2014(k) =Tmpv001
14004    Tmpv002 =muv(i,j)*Tmpv2014(k)
14005    Tmpv003 =v(i,k,j) -v00(k)
14006    Tmpv2015(k) =Tmpv002
14007    Tmpv2016(k) =Tmpv003
14008    Tmpv004 =Tmpv2015(k)*Tmpv2016(k)
14009    Tmpv005 =rv_tendf(i,k,j) -Tmpv004
14010 !  rv_tendf(i,k,j) =Tmpv005
14011
14012    ENDDO
14013
14014    DO k =ktf, k1, -1
14015    a_Tmpv5 =a_rv_tendf(i,k,j)
14016    a_rv_tendf(i,k,j) =0.0
14017    a_rv_tendf(i,k,j) =a_rv_tendf(i,k,j) +a_Tmpv5
14018    a_Tmpv4 =-a_Tmpv5
14019    a_Tmpv2 =Tmpv2016(k)*a_Tmpv4
14020    a_Tmpv3 =Tmpv2015(k)*a_Tmpv4
14021    a_v(i,k,j) =a_v(i,k,j) +a_Tmpv3
14022    a_v00(k) =a_v00(k) -a_Tmpv3
14023    a_muv(i,j) =a_muv(i,j) +Tmpv2014(k)*a_Tmpv2
14024    a_Tmpv1 =muv(i,j)*a_Tmpv2
14025    a_dcoef =a_dcoef +dampcoef*a_Tmpv1
14026 !   a_dampcoef =a_dampcoef +dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
14027
14028 !   dcoef =Tmpv2013(k)  ! Remarked by Ning Pan, 2010-07-24
14029
14030    a_Tmpv3 =a_dcoef
14031    a_dcoef =0.0
14032    a_Tmpv2 =2.0*Tmpv2012(k)*a_Tmpv3
14033    a_Tmpv1 =cos(Tmpv2011(k))*a_Tmpv2
14034 !   a_pii =a_pii +0.5*dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
14035    a_dcoef =a_dcoef +0.5*pii*a_Tmpv1
14036
14037 !   dcoef =Tmpv2010(k)  ! Remarked by Ning Pan, 2010-07-23
14038
14039    a_Tmpv3 =a_dcoef
14040    a_dcoef =0.0
14041 !STOP  ! Remarked by Ning Pan, 2010-07-23
14042 !REVISED BY WALLS
14043 !  (1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv209(k)))*0.5* =-a_Tmpv3
14044    a_Tmpv2 = -(1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv209(k)))*0.5*a_Tmpv3  ! Added by Ning Pan, 2010-07-23
14045    a_Tmpv1 =a_Tmpv2/zdamp
14046 !   a_zdamp =a_zdamp -Tmpv208(k)/(zdamp*zdamp)*a_Tmpv2  ! Remarked by Ning Pan, 2010-07-23
14047    a_ztop =a_ztop +a_Tmpv1
14048    a_z00(k) =a_z00(k) -a_Tmpv1
14049    ENDDO
14050
14051    DO k =ktf, k1, -1
14052
14053 ! Added by Ning Pan, 2010-07-23
14054    k2 = ktf
14055    DO WHILE( z_base(k2) .gt. z00(k) )
14056      k2 = k2 - 1
14057    ENDDO
14058
14059    IF(k2+1.gt.ktf) THEN
14060
14061    a_Tmpv6 =a_v00(k)
14062    a_v00(k) =0.0
14063 !   a_v_base(k2) =a_v_base(k2) +a_Tmpv6  ! Remarked by Ning Pan, 2010-07-23
14064    a_Tmpv5 =a_Tmpv6
14065    a_Tmpv3 =a_Tmpv5/Tmpv203(k)
14066 ! Remarked by Ning Pan, 2010-07-23
14067 !   a_Tmpv4 =-Tmpv202(k)/(Tmpv203(k)*Tmpv203(k))*a_Tmpv5
14068 !   a_z_base(k2) =a_z_base(k2) +a_Tmpv4
14069 !   a_z_base(k2-1) =a_z_base(k2-1) -a_Tmpv4
14070 !   a_Tmpv1 =Tmpv201(k)*a_Tmpv3
14071    a_Tmpv2 =Tmpv200(k)*a_Tmpv3
14072    a_z00(k) =a_z00(k) +a_Tmpv2
14073 ! Remarked by Ning Pan, 2010-07-23
14074 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv2
14075 !   a_v_base(k2) =a_v_base(k2) +a_Tmpv1
14076 !   a_v_base(k2-1) =a_v_base(k2-1) -a_Tmpv1
14077
14078    else
14079
14080    a_Tmpv6 =a_v00(k)
14081    a_v00(k) =0.0
14082 !   a_v_base(k2) =a_v_base(k2) +a_Tmpv6   ! Remarked by Ning Pan, 2010-07-23
14083    a_Tmpv5 =a_Tmpv6
14084    a_Tmpv3 =a_Tmpv5/Tmpv207(k)
14085 ! Remarked by Ning Pan, 2010-07-23
14086 !   a_Tmpv4 =-Tmpv206(k)/(Tmpv207(k)*Tmpv207(k))*a_Tmpv5
14087 !   a_z_base(k2+1) =a_z_base(k2+1) +a_Tmpv4
14088 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv4
14089 !   a_Tmpv1 =Tmpv205(k)*a_Tmpv3
14090    a_Tmpv2 =Tmpv204(k)*a_Tmpv3
14091    a_z00(k) =a_z00(k) +a_Tmpv2
14092 ! Remarked by Ning Pan, 2010-07-23
14093 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv2
14094 !   a_v_base(k2+1) =a_v_base(k2+1) +a_Tmpv1
14095 !   a_v_base(k2) =a_v_base(k2) -a_Tmpv1
14096
14097    endif
14098 ! Remarked by Ning Pan, 2010-07-23
14099 !   DO
14100 !   ENDDO
14101    ENDDO
14102
14103 !   DO i =min(ite, ide-1), its, -1  ! Remarked by Ning Pan, 2010-07-23
14104    DO k = k1-1, ktf  ! Added by Ning Pan, 2010-07-23
14105 ! Revised by Ning Pan, 2010-07-23
14106 !   a_z =a_z +a_z00(k1)
14107 !   a_z00(k1) =0.0
14108    a_z =a_z +a_z00(k)
14109    a_z00(k) =0.0
14110    a_Tmpv9 =a_z
14111    a_z =0.0
14112    a_Tmpv8 =a_Tmpv9/g
14113    a_Tmpv7 =0.25*a_Tmpv8
14114    a_Tmpv6 =a_Tmpv7
14115 ! Revised by Ning Pan, 2010-07-23
14116 !   a_ph(i,k1+1,j-1) =a_ph(i,k1+1,j-1) +a_Tmpv7
14117    a_ph(i,k+1,j-1) =a_ph(i,k+1,j-1) +a_Tmpv7
14118    a_Tmpv5 =a_Tmpv6
14119 ! Revised by Ning Pan, 2010-07-23
14120 !   a_ph(i,k1,j-1) =a_ph(i,k1,j-1) +a_Tmpv6
14121    a_ph(i,k,j-1) =a_ph(i,k,j-1) +a_Tmpv6
14122    a_Tmpv4 =a_Tmpv5
14123 ! Revised by Ning Pan, 2010-07-23
14124 !   a_ph(i,k1+1,j) =a_ph(i,k1+1,j) +a_Tmpv5
14125    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv5
14126    a_Tmpv3 =a_Tmpv4
14127 ! Revised by Ning Pan, 2010-07-23
14128 !   a_ph(i,k1,j) =a_ph(i,k1,j) +a_Tmpv4
14129    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv4
14130 ! Remarked by Ning Pan, 2010-07-23
14131 !   a_Tmpv2 =a_Tmpv3
14132 !   a_phb(i,k1+1,j-1) =a_phb(i,k1+1,j-1) +a_Tmpv3
14133 !   a_Tmpv1 =a_Tmpv2
14134 !   a_phb(i,k1,j-1) =a_phb(i,k1,j-1) +a_Tmpv2
14135 !   a_phb(i,k1,j) =a_phb(i,k1,j) +a_Tmpv1
14136 !   a_phb(i,k1+1,j) =a_phb(i,k1+1,j) +a_Tmpv1
14137    ENDDO  ! Added by Ning Pan, 2010-07-23
14138    a_Tmpv5 =a_ztop
14139    a_ztop =0.0
14140    a_Tmpv4 =a_Tmpv5/g
14141    a_Tmpv3 =0.5*a_Tmpv4
14142    a_Tmpv2 =a_Tmpv3
14143    a_ph(i,kde,j-1) =a_ph(i,kde,j-1) +a_Tmpv3
14144    a_Tmpv1 =a_Tmpv2
14145    a_ph(i,kde,j) =a_ph(i,kde,j) +a_Tmpv2
14146 ! Remarked by Ning Pan, 2010-07-23
14147 !   a_phb(i,kde,j) =a_phb(i,kde,j) +a_Tmpv1
14148 !   a_phb(i,kde,j-1) =a_phb(i,kde,j-1) +a_Tmpv1
14149    ENDDO
14150
14151    ENDDO
14152
14153 !LPB[1]
14154    DO j =min(jte, jde-1), jts, -1
14155
14156 ! Revised by Ning Pan, 2010-07-23
14157 !   DO i =its, min(ite, ide)
14158    DO i =min(ite, ide), its, -1
14159    Tmpv001 =phb(i,kde,j) +phb(i-1,kde,j)
14160    Tmpv002 =Tmpv001 +ph(i,kde,j)
14161    Tmpv003 =Tmpv002 +ph(i-1,kde,j)
14162    Tmpv004 =0.5*Tmpv003
14163    Tmpv005 =Tmpv004/g
14164    ztop =Tmpv005
14165
14166    k1 =ktf
14167    z =ztop  ! Removed remark by Ning Pan, 2010-07-23
14168
14169    DO WHILE( z >= (ztop-zdamp) )  ! Added by Ning Pan, 2010-07-23
14170    Tmpv001 =phb(i,k1,j) +phb(i,k1+1,j)
14171    Tmpv002 =Tmpv001 +phb(i-1,k1,j)
14172    Tmpv003 =Tmpv002 +phb(i-1,k1+1,j)
14173    Tmpv004 =Tmpv003 +ph(i,k1,j)
14174    Tmpv005 =Tmpv004 +ph(i,k1+1,j)
14175    Tmpv006 =Tmpv005 +ph(i-1,k1,j)
14176    Tmpv007 =Tmpv006 +ph(i-1,k1+1,j)
14177    Tmpv008 =0.25*Tmpv007
14178    Tmpv009 =Tmpv008/g
14179    z =Tmpv009  ! Removed remark by Ning Pan, 2010-07-23
14180
14181    z00(k1) =z
14182
14183    k1 =k1-1
14184    ENDDO
14185
14186    k1 =k1+2
14187    DO k =k1, ktf
14188    k2 =ktf
14189
14190    DO WHILE(z_base(k2) .gt. z00(k))
14191    k2 =k2-1
14192    ENDDO
14193    IF(k2+1.gt.ktf) THEN
14194    Tmpv001 =u_base(k2) -u_base(k2-1)
14195    Tmpv002 =z00(k) -z_base(k2)
14196    Tmpv200(k) =Tmpv001
14197    Tmpv201(k) =Tmpv002
14198    Tmpv003 =Tmpv200(k)*Tmpv201(k)
14199    Tmpv004 =z_base(k2) -z_base(k2-1)
14200    Tmpv202(k) =Tmpv003
14201    Tmpv203(k) =Tmpv004
14202    Tmpv005 =Tmpv202(k)/Tmpv203(k)
14203    Tmpv006 =u_base(k2) +Tmpv005
14204    u00(k) =Tmpv006
14205
14206    else
14207    Tmpv001 =u_base(k2+1) -u_base(k2)
14208    Tmpv002 =z00(k) -z_base(k2)
14209    Tmpv204(k) =Tmpv001
14210    Tmpv205(k) =Tmpv002
14211    Tmpv003 =Tmpv204(k)*Tmpv205(k)
14212    Tmpv004 =z_base(k2+1) -z_base(k2)
14213    Tmpv206(k) =Tmpv003
14214    Tmpv207(k) =Tmpv004
14215    Tmpv005 =Tmpv206(k)/Tmpv207(k)
14216    Tmpv006 =u_base(k2) +Tmpv005
14217    u00(k) =Tmpv006
14218
14219    endif
14220    ENDDO
14221
14222    DO k =k1, ktf
14223    Tmpv001 =ztop -z00(k)
14224    Tmpv208(k) =Tmpv001
14225    Tmpv002 =Tmpv208(k)/zdamp
14226    Tmpv209(k) =Tmpv002
14227    Tmpv003 =1.0 -min(1.0, Tmpv209(k))
14228    Tmpv2010(k) =dcoef
14229    dcoef =Tmpv003
14230
14231    Tmpv001 =0.5*pii*dcoef
14232    Tmpv2011(k) =Tmpv001
14233    Tmpv002 =sin(Tmpv2011(k))
14234    Tmpv2012(k) =Tmpv002
14235    Tmpv003 =Tmpv2012(k)**2
14236    Tmpv2013(k) =dcoef
14237    dcoef =Tmpv003
14238
14239    Tmpv001 =dcoef*dampcoef
14240    Tmpv2014(k) =Tmpv001
14241    Tmpv002 =muu(i,j)*Tmpv2014(k)
14242    Tmpv003 =u(i,k,j) -u00(k)
14243    Tmpv2015(k) =Tmpv002
14244    Tmpv2016(k) =Tmpv003
14245 ! Remarked by Ning Pan, 2010-07-24
14246 !   Tmpv004 =Tmpv2015(k)*Tmpv2016(k)
14247 !   Tmpv005 =ru_tendf(i,k,j) -Tmpv004
14248 !!  ru_tendf(i,k,j) =Tmpv005
14249
14250    ENDDO
14251
14252    DO k =ktf, k1, -1
14253    a_Tmpv5 =a_ru_tendf(i,k,j)
14254    a_ru_tendf(i,k,j) =0.0
14255    a_ru_tendf(i,k,j) =a_ru_tendf(i,k,j) +a_Tmpv5
14256    a_Tmpv4 =-a_Tmpv5
14257    a_Tmpv2 =Tmpv2016(k)*a_Tmpv4
14258    a_Tmpv3 =Tmpv2015(k)*a_Tmpv4
14259    a_u(i,k,j) =a_u(i,k,j) +a_Tmpv3
14260    a_u00(k) =a_u00(k) -a_Tmpv3
14261    a_muu(i,j) =a_muu(i,j) +Tmpv2014(k)*a_Tmpv2
14262    a_Tmpv1 =muu(i,j)*a_Tmpv2
14263    a_dcoef =a_dcoef +dampcoef*a_Tmpv1
14264 !   a_dampcoef =a_dampcoef +dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
14265
14266 !   dcoef =Tmpv2013(k)  ! Remarked by Ning Pan, 2010-07-24
14267
14268    a_Tmpv3 =a_dcoef
14269    a_dcoef =0.0
14270    a_Tmpv2 =2.0*Tmpv2012(k)*a_Tmpv3
14271    a_Tmpv1 =cos(Tmpv2011(k))*a_Tmpv2
14272 !   a_pii =a_pii +0.5*dcoef*a_Tmpv1  ! Remarked by Ning Pan, 2010-07-23
14273    a_dcoef =a_dcoef +0.5*pii*a_Tmpv1
14274
14275 !   dcoef =Tmpv2010(k)  ! Remarked by Ning Pan, 2010-07-23
14276
14277    a_Tmpv3 =a_dcoef
14278    a_dcoef =0.0
14279 !STOP  ! Remarked by Ning Pan, 2010-07-23
14280 !REVISED BY WALLS
14281 !  (1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv209(k)))*0.5* =-a_Tmpv3
14282    a_Tmpv2 = -(1.0 -(-1.0)*sign(1.0, 1.0 -Tmpv209(k)))*0.5*a_Tmpv3  ! Added by Ning Pan, 2010-07-23
14283    a_Tmpv1 =a_Tmpv2/zdamp
14284 !   a_zdamp =a_zdamp -Tmpv208(k)/(zdamp*zdamp)*a_Tmpv2  ! Added by Ning Pan, 2010-07-23
14285    a_ztop =a_ztop +a_Tmpv1
14286    a_z00(k) =a_z00(k) -a_Tmpv1
14287    ENDDO
14288
14289    DO k =ktf, k1, -1
14290
14291 ! Added by Ning Pan, 2010-07-23
14292    k2 = ktf
14293    DO WHILE( z_base(k2) .gt. z00(k) )
14294    k2 = k2 - 1
14295    ENDDO
14296
14297    IF(k2+1.gt.ktf) THEN
14298
14299    a_Tmpv6 =a_u00(k)
14300    a_u00(k) =0.0
14301 !   a_u_base(k2) =a_u_base(k2) +a_Tmpv6  ! Remarked by Ning Pan, 2010-07-23
14302    a_Tmpv5 =a_Tmpv6
14303    a_Tmpv3 =a_Tmpv5/Tmpv203(k)
14304 ! Remarked by Ning Pan, 2010-07-23
14305 !   a_Tmpv4 =-Tmpv202(k)/(Tmpv203(k)*Tmpv203(k))*a_Tmpv5
14306 !   a_z_base(k2) =a_z_base(k2) +a_Tmpv4
14307 !   a_z_base(k2-1) =a_z_base(k2-1) -a_Tmpv4
14308 !   a_Tmpv1 =Tmpv201(k)*a_Tmpv3
14309    a_Tmpv2 =Tmpv200(k)*a_Tmpv3
14310    a_z00(k) =a_z00(k) +a_Tmpv2
14311 ! Remarked by Ning Pan, 2010-07-23
14312 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv2
14313 !   a_u_base(k2) =a_u_base(k2) +a_Tmpv1
14314 !   a_u_base(k2-1) =a_u_base(k2-1) -a_Tmpv1
14315
14316    else
14317
14318    a_Tmpv6 =a_u00(k)
14319    a_u00(k) =0.0
14320 !   a_u_base(k2) =a_u_base(k2) +a_Tmpv6   ! Remarked by Ning Pan, 2010-07-23
14321    a_Tmpv5 =a_Tmpv6
14322    a_Tmpv3 =a_Tmpv5/Tmpv207(k)
14323 ! Remarked by Ning Pan, 2010-07-23
14324 !   a_Tmpv4 =-Tmpv206(k)/(Tmpv207(k)*Tmpv207(k))*a_Tmpv5
14325 !   a_z_base(k2+1) =a_z_base(k2+1) +a_Tmpv4
14326 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv4
14327 !   a_Tmpv1 =Tmpv205(k)*a_Tmpv3
14328    a_Tmpv2 =Tmpv204(k)*a_Tmpv3
14329    a_z00(k) =a_z00(k) +a_Tmpv2
14330 ! Remarked by Ning Pan, 2010-07-23
14331 !   a_z_base(k2) =a_z_base(k2) -a_Tmpv2
14332 !   a_u_base(k2+1) =a_u_base(k2+1) +a_Tmpv1
14333 !   a_u_base(k2) =a_u_base(k2) -a_Tmpv1
14334
14335    endif
14336 ! Remarked by Ning Pan, 2010-07-23
14337 !   DO
14338 !   ENDDO
14339    ENDDO
14340
14341 !   DO i =min(ite, ide), its, -1  ! Remarked by Ning Pan, 2010-07-23
14342    DO k = k1-1, ktf   ! Added by Ning Pan, 2010-07-23
14343 ! Revised by Ning Pan, 2010-07-23
14344 !   a_z =a_z +a_z00(k1)
14345 !   a_z00(k1) =0.0
14346    a_z =a_z +a_z00(k)
14347    a_z00(k) =0.0
14348    a_Tmpv9 =a_z
14349    a_z =0.0
14350    a_Tmpv8 =a_Tmpv9/g
14351    a_Tmpv7 =0.25*a_Tmpv8
14352    a_Tmpv6 =a_Tmpv7
14353 ! Revised by Ning Pan, 2010-07-23
14354 !   a_ph(i-1,k1+1,j) =a_ph(i-1,k1+1,j) +a_Tmpv7
14355    a_ph(i-1,k+1,j) =a_ph(i-1,k+1,j) +a_Tmpv7
14356    a_Tmpv5 =a_Tmpv6
14357 ! Revised by Ning Pan, 2010-07-23
14358 !   a_ph(i-1,k1,j) =a_ph(i-1,k1,j) +a_Tmpv6
14359    a_ph(i-1,k,j) =a_ph(i-1,k,j) +a_Tmpv6
14360    a_Tmpv4 =a_Tmpv5
14361 ! Revised by Ning Pan, 2010-07-23
14362 !   a_ph(i,k1+1,j) =a_ph(i,k1+1,j) +a_Tmpv5
14363    a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv5
14364    a_Tmpv3 =a_Tmpv4
14365 ! Revised by Ning Pan, 2010-07-23
14366 !   a_ph(i,k1,j) =a_ph(i,k1,j) +a_Tmpv4
14367    a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv4
14368 ! Remarked by Ning Pan, 2010-07-23
14369 !   a_Tmpv2 =a_Tmpv3
14370 !   a_phb(i-1,k1+1,j) =a_phb(i-1,k1+1,j) +a_Tmpv3
14371 !   a_Tmpv1 =a_Tmpv2
14372 !   a_phb(i-1,k1,j) =a_phb(i-1,k1,j) +a_Tmpv2
14373 !   a_phb(i,k1,j) =a_phb(i,k1,j) +a_Tmpv1
14374 !   a_phb(i,k1+1,j) =a_phb(i,k1+1,j) +a_Tmpv1
14375    ENDDO  ! Added by Ning Pan, 2010-07-23
14376    a_Tmpv5 =a_ztop
14377    a_ztop =0.0
14378    a_Tmpv4 =a_Tmpv5/g
14379    a_Tmpv3 =0.5*a_Tmpv4
14380    a_Tmpv2 =a_Tmpv3
14381    a_ph(i-1,kde,j) =a_ph(i-1,kde,j) +a_Tmpv3
14382    a_Tmpv1 =a_Tmpv2
14383    a_ph(i,kde,j) =a_ph(i,kde,j) +a_Tmpv2
14384 ! Remarked by Ning Pan, 2010-07-23
14385 !   a_phb(i,kde,j) =a_phb(i,kde,j) +a_Tmpv1
14386 !   a_phb(i-1,kde,j) =a_phb(i-1,kde,j) +a_Tmpv1
14387    ENDDO
14388
14389    ENDDO
14390
14391 !LPB[0]
14392 !  pii =2.0*Asin(1.0)
14393
14394 !  ktf =min(kte, kde-1)
14395
14396 !   a_pii =0.0  ! Remarked by Ning Pan, 2010-07-23
14397
14398    END SUBROUTINE a_rk_rayleigh_damp
14399
14400    SUBROUTINE a_sixth_order_diffusion(name,field,a_field,tendency,a_tendency,mu, &
14401    a_mu,dt,config_flags,diff_6th_opt,diff_6th_factor,ids, &
14402    ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
14403
14404 !PART I: DECLARATION OF VARIABLES
14405
14406    IMPLICIT NONE
14407
14408    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
14409    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
14410    TYPE(grid_config_rec_type) :: config_flags
14411    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
14412    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field
14413    REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
14414    REAL :: dt
14415    REAL :: diff_6th_factor
14416    INTEGER :: diff_6th_opt
14417    CHARACTER (LEN=1) :: name
14418    INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end,ktf
14419    REAL :: dflux_x_p0,a_dflux_x_p0,dflux_y_p0,a_dflux_y_p0,dflux_x_p1, &
14420    a_dflux_x_p1,dflux_y_p1,a_dflux_y_p1,tendency_x,a_tendency_x,tendency_y, &
14421    a_tendency_y,mu_avg_p0,a_mu_avg_p0,mu_avg_p1,a_mu_avg_p1,diff_6th_coef
14422    LOGICAL :: specified
14423
14424    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
14425    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,Tmpv300, Tmpv301,Tmpv3011,Tmpv3012
14426
14427 !ADDED BY WALLS
14428 !   REAL :: a_diff_6th_coef  ! Remarked by Ning Pan, 2010-07-23
14429
14430 !PART II: CALCULATIONS OF B. S. TRAJECTORY
14431
14432 !LPB[0]
14433        diff_6th_coef = diff_6th_factor * 0.015625 / ( 2.0 * dt )
14434        ktf = MIN( kte, kde-1 )
14435
14436     IF ( name .EQ. 'u' ) THEN
14437          i_start = its
14438          i_end   = ite
14439          j_start = jts
14440          j_end   = MIN(jde-1,jte)
14441          k_start = kts
14442          k_end   = ktf
14443        ELSE IF ( name .EQ. 'v' ) THEN
14444          i_start = its
14445          i_end   = MIN(ide-1,ite)
14446          j_start = jts
14447          j_end   = jte
14448          k_start = kts
14449          k_end   = ktf
14450        ELSE IF ( name .EQ. 'w' ) THEN
14451          i_start = its
14452          i_end   = MIN(ide-1,ite)
14453          j_start = jts
14454          j_end   = MIN(jde-1,jte)
14455          k_start = kts+1
14456          k_end   = ktf
14457        ELSE
14458          i_start = its
14459          i_end   = MIN(ide-1,ite)
14460          j_start = jts
14461          j_end   = MIN(jde-1,jte)
14462          k_start = kts
14463          k_end   = ktf
14464    ENDIF
14465
14466 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
14467
14468    a_dflux_x_p0 =0.0
14469    a_dflux_y_p0 =0.0
14470    a_dflux_x_p1 =0.0
14471    a_dflux_y_p1 =0.0
14472    a_tendency_x =0.0
14473    a_tendency_y =0.0
14474    a_mu_avg_p0 =0.0
14475    a_mu_avg_p1 =0.0
14476
14477 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
14478
14479 !LPB[2]
14480    DO j =j_end, j_start, -1
14481
14482    DO k =k_end, k_start, -1
14483    DO i =i_end, i_start, -1
14484    Tmpv001 =field(i,k,j) -field(i,k,j-1)
14485    Tmpv002 =10.0*Tmpv001
14486    Tmpv003 =field(i,k,j+1) -field(i,k,j-2)
14487    Tmpv004 =5.0*Tmpv003
14488    Tmpv005 =Tmpv002 -Tmpv004
14489    Tmpv006 =field(i,k,j+2) -field(i,k,j-3)
14490    Tmpv007 =Tmpv005 +Tmpv006
14491    dflux_y_p0 =Tmpv007
14492    Tmpv3011 =dflux_y_p0
14493
14494    Tmpv001 =field(i,k,j+1) -field(i,k,j)
14495    Tmpv002 =10.0*Tmpv001
14496    Tmpv003 =field(i,k,j+2) -field(i,k,j-1)
14497    Tmpv004 =5.0*Tmpv003
14498    Tmpv005 =Tmpv002 -Tmpv004
14499    Tmpv006 =field(i,k,j+3) -field(i,k,j-2)
14500    Tmpv007 =Tmpv005 +Tmpv006
14501    dflux_y_p1 =Tmpv007
14502    Tmpv3012 =dflux_y_p1
14503
14504    IF( diff_6th_opt .EQ. 2 ) THEN
14505    IF( dflux_y_p0 * ( field(i,k,j  )-field(i,k,j-1) ) .LE. 0.0 ) THEN
14506    dflux_y_p0 =0.0
14507
14508    END IF
14509    IF( dflux_y_p1 * ( field(i,k,j+1)-field(i,k,j  ) ) .LE. 0.0 ) THEN
14510    dflux_y_p1 =0.0
14511
14512    END IF
14513    END IF
14514    IF( name .EQ. 'u' ) THEN
14515    Tmpv001 =mu(i-1,j-1) +mu(i,j-1)
14516    Tmpv002 =Tmpv001 +mu(i-1,j)
14517    Tmpv003 =Tmpv002 +mu(i,j)
14518    Tmpv004 =0.25*Tmpv003
14519    mu_avg_p0 =Tmpv004
14520
14521    Tmpv001 =mu(i-1,j) +mu(i,j)
14522    Tmpv002 =Tmpv001 +mu(i-1,j+1)
14523    Tmpv003 =Tmpv002 +mu(i,j+1)
14524    Tmpv004 =0.25*Tmpv003
14525    mu_avg_p1 =Tmpv004
14526
14527    ELSE IF( name .EQ. 'v' ) THEN
14528    mu_avg_p0 =mu(i,j-1)
14529
14530    mu_avg_p1 =mu(i,j)
14531
14532    ELSE
14533    Tmpv001 =mu(i,j-1) +mu(i,j)
14534    Tmpv002 =0.5*Tmpv001
14535    mu_avg_p0 =Tmpv002
14536
14537    Tmpv001 =mu(i,j) +mu(i,j+1)
14538    Tmpv002 =0.5*Tmpv001
14539    mu_avg_p1 =Tmpv002
14540
14541    END IF
14542
14543    a_Tmpv2 =a_tendency(i,k,j)
14544    a_tendency(i,k,j) =0.0
14545    a_Tmpv1 =a_Tmpv2
14546    a_tendency_y =a_tendency_y +a_Tmpv2
14547    a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv1
14548    a_tendency_x =a_tendency_x +a_Tmpv1
14549    a_Tmpv4 =a_tendency_y
14550    a_tendency_y =0.0
14551 !   a_diff_6th_coef =a_diff_6th_coef +Tmpv3021(i,k)*a_Tmpv4  ! Remarked by Ning Pan, 2010-07-23
14552    a_Tmpv3 =diff_6th_coef*a_Tmpv4
14553    a_Tmpv1 =a_Tmpv3
14554    a_Tmpv2 =-a_Tmpv3
14555    a_mu_avg_p0 =a_mu_avg_p0 +dflux_y_p0*a_Tmpv2
14556    a_dflux_y_p0 =a_dflux_y_p0 +mu_avg_p0*a_Tmpv2
14557    a_mu_avg_p1 =a_mu_avg_p1 +dflux_y_p1*a_Tmpv1
14558    a_dflux_y_p1 =a_dflux_y_p1 +mu_avg_p1*a_Tmpv1
14559
14560 ! Added by Ning Pan, 2010-07-23
14561    IF( name .EQ. 'u' ) THEN
14562    a_Tmpv4 =a_mu_avg_p1
14563    a_mu_avg_p1 =0.0
14564    a_Tmpv3 =0.25*a_Tmpv4
14565    a_Tmpv2 =a_Tmpv3
14566    a_mu(i,j+1) =a_mu(i,j+1) +a_Tmpv3
14567    a_Tmpv1 =a_Tmpv2
14568    a_mu(i-1,j+1) =a_mu(i-1,j+1) +a_Tmpv2
14569    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
14570    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
14571    a_Tmpv4 =a_mu_avg_p0
14572    a_mu_avg_p0 =0.0
14573    a_Tmpv3 =0.25*a_Tmpv4
14574    a_Tmpv2 =a_Tmpv3
14575    a_mu(i,j) =a_mu(i,j) +a_Tmpv3
14576    a_Tmpv1 =a_Tmpv2
14577    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv2
14578    a_mu(i-1,j-1) =a_mu(i-1,j-1) +a_Tmpv1
14579    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
14580    ELSE IF( name .EQ. 'v' ) THEN
14581    a_mu(i,j) =a_mu(i,j) +a_mu_avg_p1
14582    a_mu_avg_p1 =0.0
14583    a_mu(i,j-1) =a_mu(i,j-1) +a_mu_avg_p0
14584    a_mu_avg_p0 =0.0
14585    ELSE
14586    a_Tmpv2 =a_mu_avg_p1
14587    a_mu_avg_p1 =0.0
14588    a_Tmpv1 =0.5*a_Tmpv2
14589    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
14590    a_mu(i,j+1) =a_mu(i,j+1) +a_Tmpv1
14591    a_Tmpv2 =a_mu_avg_p0
14592    a_mu_avg_p0 =0.0
14593    a_Tmpv1 =0.5*a_Tmpv2
14594    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
14595    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
14596    END IF
14597
14598    dflux_y_p0 = Tmpv3011
14599    dflux_y_p1 = Tmpv3012
14600
14601    IF( diff_6th_opt .EQ. 2 ) THEN
14602
14603    IF( dflux_y_p1 * ( field(i,k,j+1)-field(i,k,j  ) ) .LE. 0.0 ) THEN
14604
14605    a_dflux_y_p1 =0.0
14606
14607    END IF
14608
14609    IF( dflux_y_p0 * ( field(i,k,j  )-field(i,k,j-1) ) .LE. 0.0 ) THEN
14610
14611    a_dflux_y_p0 =0.0
14612
14613    END IF
14614
14615    END IF
14616
14617    a_Tmpv7 =a_dflux_y_p1
14618    a_dflux_y_p1 =0.0
14619    a_Tmpv5 =a_Tmpv7
14620    a_Tmpv6 =a_Tmpv7
14621    a_field(i,k,j+3) =a_field(i,k,j+3) +a_Tmpv6
14622    a_field(i,k,j-2) =a_field(i,k,j-2) -a_Tmpv6
14623    a_Tmpv2 =a_Tmpv5
14624    a_Tmpv4 =-a_Tmpv5
14625    a_Tmpv3 =5.0*a_Tmpv4
14626    a_field(i,k,j+2) =a_field(i,k,j+2) +a_Tmpv3
14627    a_field(i,k,j-1) =a_field(i,k,j-1) -a_Tmpv3
14628    a_Tmpv1 =10.0*a_Tmpv2
14629    a_field(i,k,j+1) =a_field(i,k,j+1) +a_Tmpv1
14630    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv1
14631
14632    a_Tmpv7 =a_dflux_y_p0
14633    a_dflux_y_p0 =0.0
14634    a_Tmpv5 =a_Tmpv7
14635    a_Tmpv6 =a_Tmpv7
14636    a_field(i,k,j+2) =a_field(i,k,j+2) +a_Tmpv6
14637    a_field(i,k,j-3) =a_field(i,k,j-3) -a_Tmpv6
14638    a_Tmpv2 =a_Tmpv5
14639    a_Tmpv4 =-a_Tmpv5
14640    a_Tmpv3 =5.0*a_Tmpv4
14641    a_field(i,k,j+1) =a_field(i,k,j+1) +a_Tmpv3
14642    a_field(i,k,j-2) =a_field(i,k,j-2) -a_Tmpv3
14643    a_Tmpv1 =10.0*a_Tmpv2
14644    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1
14645    a_field(i,k,j-1) =a_field(i,k,j-1) -a_Tmpv1
14646
14647    Tmpv001 =field(i,k,j) -field(i-1,k,j)
14648    Tmpv002 =10.0*Tmpv001
14649    Tmpv003 =field(i+1,k,j) -field(i-2,k,j)
14650    Tmpv004 =5.0*Tmpv003
14651    Tmpv005 =Tmpv002 -Tmpv004
14652    Tmpv006 =field(i+2,k,j) -field(i-3,k,j)
14653    Tmpv007 =Tmpv005 +Tmpv006
14654    dflux_x_p0 =Tmpv007
14655    Tmpv300 =dflux_x_p0
14656
14657    Tmpv001 =field(i+1,k,j) -field(i,k,j)
14658    Tmpv002 =10.0*Tmpv001
14659    Tmpv003 =field(i+2,k,j) -field(i-1,k,j)
14660    Tmpv004 =5.0*Tmpv003
14661    Tmpv005 =Tmpv002 -Tmpv004
14662    Tmpv006 =field(i+3,k,j) -field(i-2,k,j)
14663    Tmpv007 =Tmpv005 +Tmpv006
14664    dflux_x_p1 =Tmpv007
14665    Tmpv301 =dflux_x_p1
14666
14667    IF( diff_6th_opt .EQ. 2 ) THEN
14668    IF( dflux_x_p0 * ( field(i  ,k,j)-field(i-1,k,j) ) .LE. 0.0 ) THEN
14669    dflux_x_p0 =0.0
14670
14671    END IF
14672    IF( dflux_x_p1 * ( field(i+1,k,j)-field(i  ,k,j) ) .LE. 0.0 ) THEN
14673    dflux_x_p1 =0.0
14674
14675    END IF
14676    END IF
14677    IF( name .EQ. 'u' ) THEN
14678    mu_avg_p0 =mu(i-1,j)
14679    mu_avg_p1 =mu(i,j)
14680
14681    ELSE IF( name .EQ. 'v' ) THEN
14682    Tmpv001 =mu(i-1,j-1) +mu(i,j-1)
14683    Tmpv002 =Tmpv001 +mu(i-1,j)
14684    Tmpv003 =Tmpv002 +mu(i,j)
14685    Tmpv004 =0.25*Tmpv003
14686    mu_avg_p0 =Tmpv004
14687
14688    Tmpv001 =mu(i,j-1) +mu(i+1,j-1)
14689    Tmpv002 =Tmpv001 +mu(i,j)
14690    Tmpv003 =Tmpv002 +mu(i+1,j)
14691    Tmpv004 =0.25*Tmpv003
14692    mu_avg_p1 =Tmpv004
14693
14694    ELSE
14695    Tmpv001 =mu(i-1,j) +mu(i,j)
14696    Tmpv002 =0.5*Tmpv001
14697    mu_avg_p0 =Tmpv002
14698
14699    Tmpv001 =mu(i,j) +mu(i+1,j)
14700    Tmpv002 =0.5*Tmpv001
14701    mu_avg_p1 =Tmpv002
14702
14703    END IF
14704
14705    a_Tmpv4 =a_tendency_x
14706    a_tendency_x =0.0
14707    a_Tmpv3 =diff_6th_coef*a_Tmpv4
14708    a_Tmpv1 =a_Tmpv3
14709    a_Tmpv2 =-a_Tmpv3
14710    a_mu_avg_p0 =a_mu_avg_p0 +dflux_x_p0*a_Tmpv2
14711    a_dflux_x_p0 =a_dflux_x_p0 +mu_avg_p0*a_Tmpv2
14712    a_mu_avg_p1 =a_mu_avg_p1 +dflux_x_p1*a_Tmpv1
14713    a_dflux_x_p1 =a_dflux_x_p1 +mu_avg_p1*a_Tmpv1
14714
14715    IF( name .EQ. 'u' ) THEN
14716    a_mu(i,j) =a_mu(i,j) +a_mu_avg_p1
14717    a_mu_avg_p1 =0.0
14718    a_mu(i-1,j) =a_mu(i-1,j) +a_mu_avg_p0
14719    a_mu_avg_p0 =0.0
14720    ELSE IF( name .EQ. 'v' ) THEN
14721    a_Tmpv4 =a_mu_avg_p1
14722    a_mu_avg_p1 =0.0
14723    a_Tmpv3 =0.25*a_Tmpv4
14724    a_Tmpv2 =a_Tmpv3
14725    a_mu(i+1,j) =a_mu(i+1,j) +a_Tmpv3
14726    a_Tmpv1 =a_Tmpv2
14727    a_mu(i,j) =a_mu(i,j) +a_Tmpv2
14728    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
14729    a_mu(i+1,j-1) =a_mu(i+1,j-1) +a_Tmpv1
14730    a_Tmpv4 =a_mu_avg_p0
14731    a_mu_avg_p0 =0.0
14732    a_Tmpv3 =0.25*a_Tmpv4
14733    a_Tmpv2 =a_Tmpv3
14734    a_mu(i,j) =a_mu(i,j) +a_Tmpv3
14735    a_Tmpv1 =a_Tmpv2
14736    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv2
14737    a_mu(i-1,j-1) =a_mu(i-1,j-1) +a_Tmpv1
14738    a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
14739    ELSE
14740    a_Tmpv2 =a_mu_avg_p1
14741    a_mu_avg_p1 =0.0
14742    a_Tmpv1 =0.5*a_Tmpv2
14743    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
14744    a_mu(i+1,j) =a_mu(i+1,j) +a_Tmpv1
14745    a_Tmpv2 =a_mu_avg_p0
14746    a_mu_avg_p0 =0.0
14747    a_Tmpv1 =0.5*a_Tmpv2
14748    a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
14749    a_mu(i,j) =a_mu(i,j) +a_Tmpv1
14750    END IF
14751
14752    dflux_x_p0 = Tmpv300
14753    dflux_x_p1 = Tmpv301
14754    IF( diff_6th_opt .EQ. 2 ) THEN
14755
14756    IF( dflux_x_p1 * ( field(i+1,k,j)-field(i  ,k,j) ) .LE. 0.0 ) THEN
14757
14758    a_dflux_x_p1 =0.0
14759
14760    END IF
14761
14762    IF( dflux_x_p0 * ( field(i  ,k,j)-field(i-1,k,j) ) .LE. 0.0 ) THEN
14763
14764    a_dflux_x_p0 =0.0
14765
14766    END IF
14767
14768    END IF
14769
14770    a_Tmpv7 =a_dflux_x_p1
14771    a_dflux_x_p1 =0.0
14772    a_Tmpv5 =a_Tmpv7
14773    a_Tmpv6 =a_Tmpv7
14774    a_field(i+3,k,j) =a_field(i+3,k,j) +a_Tmpv6
14775    a_field(i-2,k,j) =a_field(i-2,k,j) -a_Tmpv6
14776    a_Tmpv2 =a_Tmpv5
14777    a_Tmpv4 =-a_Tmpv5
14778    a_Tmpv3 =5.0*a_Tmpv4
14779    a_field(i+2,k,j) =a_field(i+2,k,j) +a_Tmpv3
14780    a_field(i-1,k,j) =a_field(i-1,k,j) -a_Tmpv3
14781    a_Tmpv1 =10.0*a_Tmpv2
14782    a_field(i+1,k,j) =a_field(i+1,k,j) +a_Tmpv1
14783    a_field(i,k,j) =a_field(i,k,j) -a_Tmpv1
14784
14785    a_Tmpv7 =a_dflux_x_p0
14786    a_dflux_x_p0 =0.0
14787    a_Tmpv5 =a_Tmpv7
14788    a_Tmpv6 =a_Tmpv7
14789    a_field(i+2,k,j) =a_field(i+2,k,j) +a_Tmpv6
14790    a_field(i-3,k,j) =a_field(i-3,k,j) -a_Tmpv6
14791    a_Tmpv2 =a_Tmpv5
14792    a_Tmpv4 =-a_Tmpv5
14793    a_Tmpv3 =5.0*a_Tmpv4
14794    a_field(i+1,k,j) =a_field(i+1,k,j) +a_Tmpv3
14795    a_field(i-2,k,j) =a_field(i-2,k,j) -a_Tmpv3
14796    a_Tmpv1 =10.0*a_Tmpv2
14797    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1
14798    a_field(i-1,k,j) =a_field(i-1,k,j) -a_Tmpv1
14799    ENDDO
14800    ENDDO
14801
14802    ENDDO
14803
14804    END SUBROUTINE a_sixth_order_diffusion
14805
14806 END MODULE a_module_big_step_utilities_em
14807