wrftladj/module_advect_em_ad.F

   1
   2 ! ======================================================================================
   3 ! This file was generated by the version 4.3.7 of ADG on 07/17/2010. The Adjoint Code
   4 ! Generator (ADG) was developed and sponsored by LASG of IAP (1999-2010)
   5 ! The Copyright of the ADG system was declared by Walls at LASG, 1999-2010
   6 ! ======================================================================================
   7
   8 MODULE a_module_advect_em
   9
  10    USE module_bc
  11    USE module_model_constants
  12    USE module_wrf_error
  13
  14 CONTAINS
  15
  16 !        Generated by TAPENADE     (INRIA, Tropics team)
  17 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
  18 !
  19 !  Differentiation of advect_u in reverse (adjoint) mode:
  20 !   gradient     of useful results: rom u tendency u_old ru rv
  21 !                mut
  22 !   with respect to varying inputs: rom u tendency u_old ru rv
  23 !                mut
  24 !   RW status of diff variables: rom:incr u:incr tendency:in-out
  25 !                u_old:incr ru:incr rv:incr mut:incr
  26 SUBROUTINE A_ADVECT_U(u, ub0, u_old, u_oldb, tendency, tendencyb, ru, &
  27 &  rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux, &
  28 &  msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide&
  29 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
  30 &  , kts, kte)
  31   IMPLICIT NONE
  32 ! Input data
  33   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
  34   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  35 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  36   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru&
  37 &  , rv, rom
  38   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ub0, u_oldb, rub, rvb, &
  39 &  romb
  40   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
  41   REAL, DIMENSION(ims:ime, jms:jme) :: mutb
  42   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
  43   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb
  44   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
  45 &  msfvy, msftx, msfty
  46   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
  47   REAL, INTENT(IN) :: rdx, rdy
  48   INTEGER, INTENT(IN) :: time_step
  49 ! Local data
  50   INTEGER :: i, j, k, itf, jtf, ktf
  51   INTEGER :: i_start, i_end, j_start, j_end
  52   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
  53   INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
  54   INTEGER :: jp1, jp0, jtmp
  55   INTEGER :: horz_order, vert_order
  56   REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
  57   REAL :: ubb, vbb, vwb, dvmb, dvpb
  58   REAL, DIMENSION(its:ite, kts:kte) :: vflux
  59   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
  60   REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx
  61   REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxb
  62   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
  63   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
  64   LOGICAL :: degrade_xs, degrade_ys
  65   LOGICAL :: degrade_xe, degrade_ye
  66 ! definition of flux operators, 3rd, 4th, 5th or 6th order
  67   REAL :: flux3, flux4, flux5, flux6
  68   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
  69   REAL :: velb
  70   LOGICAL :: specified
  71   INTEGER :: ad_from
  72   INTEGER :: ad_to
  73   INTEGER :: ad_from0
  74   INTEGER :: ad_to0
  75   INTEGER :: ad_from1
  76   INTEGER :: ad_to1
  77   INTEGER :: ad_from2
  78   INTEGER :: ad_to2
  79   INTEGER :: ad_from3
  80   INTEGER :: ad_to3
  81   INTEGER :: ad_from4
  82   INTEGER :: ad_to4
  83   INTEGER :: ad_from5
  84   INTEGER :: ad_to5
  85   INTEGER :: ad_from6
  86   INTEGER :: ad_to6
  87   INTEGER :: branch
  88   INTEGER :: ad_from7
  89   INTEGER :: ad_to7
  90   INTEGER :: ad_from8
  91   INTEGER :: ad_to8
  92   INTEGER :: ad_from9
  93   INTEGER :: ad_to9
  94   INTEGER :: ad_from10
  95   INTEGER :: ad_to10
  96   INTEGER :: ad_from11
  97   INTEGER :: ad_to11
  98   INTEGER :: ad_from12
  99   INTEGER :: ad_to12
 100   INTEGER :: ad_from13
 101   INTEGER :: ad_to13
 102   INTEGER :: ad_from14
 103   INTEGER :: ad_to14
 104   INTEGER :: ad_from15
 105   INTEGER :: ad_to15
 106   INTEGER :: ad_from16
 107   INTEGER :: ad_to16
 108   INTEGER :: ad_from17
 109   INTEGER :: ad_to17
 110   INTEGER :: ad_from18
 111   INTEGER :: ad_to18
 112   INTEGER :: ad_from19
 113   INTEGER :: ad_to19
 114   INTEGER :: ad_from20
 115   INTEGER :: ad_to20
 116   INTEGER :: ad_from21
 117   INTEGER :: ad_to21
 118   INTEGER :: ad_from22
 119   INTEGER :: ad_to22
 120   INTEGER :: ad_from23
 121   INTEGER :: ad_to23
 122   INTEGER :: ad_from24
 123   INTEGER :: ad_to24
 124   INTEGER :: ad_from25
 125   INTEGER :: ad_to25
 126   INTEGER :: ad_from26
 127   INTEGER :: ad_to26
 128   INTEGER :: ad_from27
 129   INTEGER :: ad_to27
 130   INTEGER :: ad_from28
 131   INTEGER :: ad_to28
 132   INTEGER :: ad_from29
 133   INTEGER :: ad_to29
 134   INTEGER :: ad_from30
 135   INTEGER :: ad_to30
 136   INTEGER :: ad_from31
 137   INTEGER :: ad_to31
 138   INTEGER :: ad_from32
 139   INTEGER :: ad_to32
 140   INTEGER :: ad_from33
 141   INTEGER :: ad_to33
 142   INTEGER :: ad_from34
 143   INTEGER :: ad_to34
 144   INTEGER :: ad_from35
 145   INTEGER :: ad_to35
 146   INTEGER :: ad_from36
 147   INTEGER :: ad_to36
 148   INTEGER :: ad_from37
 149   INTEGER :: ad_to37
 150   INTEGER :: ad_from38
 151   INTEGER :: ad_to38
 152   INTEGER :: ad_from39
 153   INTEGER :: ad_to39
 154   INTEGER :: ad_from40
 155   INTEGER :: ad_to40
 156   INTEGER :: ad_from41
 157   INTEGER :: ad_to41
 158   INTEGER :: ad_from42
 159   INTEGER :: ad_to42
 160   INTEGER :: ad_from43
 161   INTEGER :: ad_to43
 162   INTEGER :: ad_from44
 163   INTEGER :: ad_to44
 164   INTEGER :: ad_from45
 165   INTEGER :: ad_to45
 166   INTEGER :: ad_from46
 167   INTEGER :: ad_to46
 168   INTEGER :: ad_from47
 169   INTEGER :: ad_to47
 170   INTEGER :: ad_from48
 171   INTEGER :: ad_to48
 172   REAL :: temp3
 173   REAL :: temp29
 174   REAL :: temp31b43
 175   REAL :: temp2
 176   INTEGER :: temp28
 177   REAL :: temp31b42
 178   REAL :: temp1
 179   REAL :: temp27
 180   REAL :: temp31b41
 181   INTEGER :: temp0
 182   REAL :: temp26
 183   REAL :: temp31b40
 184   REAL :: temp7b
 185   REAL :: temp25
 186   INTEGER :: temp24
 187   REAL :: temp23
 188   REAL :: temp22
 189   REAL :: temp21
 190   REAL :: temp35b3
 191   INTEGER :: temp20
 192   REAL :: temp35b2
 193   REAL :: temp35b1
 194   REAL :: temp35b0
 195   REAL :: temp23b9
 196   REAL :: temp23b8
 197   REAL :: temp19b
 198   REAL :: temp23b7
 199   REAL :: temp23b6
 200   REAL :: temp27b
 201   REAL :: temp23b5
 202   REAL :: temp35b
 203   REAL :: tempb1
 204   REAL :: temp23b4
 205   REAL :: temp43b
 206   REAL :: tempb0
 207   REAL :: temp23b3
 208   REAL :: temp23b2
 209   REAL :: temp23b1
 210   REAL :: temp23b0
 211   REAL :: temp31b39
 212   REAL :: temp31b38
 213   REAL :: temp7b3
 214   REAL :: temp31b37
 215   REAL :: temp3b
 216   REAL :: temp7b2
 217   REAL :: temp31b36
 218   REAL :: temp7b1
 219   REAL :: temp31b35
 220   REAL :: temp7b0
 221   REAL :: temp31b34
 222   REAL :: temp19
 223   REAL :: temp31b33
 224   REAL :: temp18
 225   REAL :: temp31b32
 226   REAL :: temp17
 227   REAL :: temp31b31
 228   INTEGER :: temp16
 229   REAL :: temp23b11
 230   REAL :: temp31b30
 231   REAL :: temp43b8
 232   REAL :: temp15
 233   REAL :: temp23b10
 234   REAL :: temp43b7
 235   REAL :: temp14
 236   REAL :: temp11b1
 237   REAL :: temp43b6
 238   REAL :: temp13
 239   REAL :: temp11b0
 240   REAL :: temp43b5
 241   INTEGER :: temp12
 242   REAL :: temp43b4
 243   REAL :: temp11
 244   REAL :: temp43b3
 245   REAL :: temp10
 246   REAL :: temp43b2
 247   REAL :: temp15b
 248   REAL :: temp43b1
 249   REAL :: temp46
 250   REAL :: temp23b
 251   REAL :: temp43b0
 252   REAL :: temp45
 253   REAL :: temp31b
 254   INTEGER :: temp44
 255   REAL :: temp43
 256   REAL :: temp42
 257   REAL :: temp19b3
 258   REAL :: temp31b9
 259   REAL :: temp41
 260   REAL :: temp19b2
 261   REAL :: temp31b8
 262   INTEGER :: temp40
 263   REAL :: temp19b1
 264   REAL :: temp31b7
 265   REAL :: temp19b0
 266   REAL :: temp31b6
 267   REAL :: temp31b5
 268   REAL :: temp31b4
 269   REAL :: temp31b3
 270   REAL :: tempb
 271   REAL :: temp31b2
 272   REAL :: temp31b1
 273   REAL :: temp31b0
 274   REAL :: temp31b29
 275   REAL :: temp31b28
 276   REAL :: temp31b27
 277   REAL :: temp31b26
 278   REAL :: temp31b25
 279   REAL :: temp31b24
 280   REAL :: temp31b23
 281   REAL :: temp31b22
 282   REAL :: temp31b21
 283   REAL :: temp11b
 284   REAL :: temp31b20
 285   REAL :: temp39b1
 286   REAL :: temp39b0
 287   REAL :: temp31b54
 288   REAL :: temp31b53
 289   REAL :: temp39
 290   REAL :: temp31b52
 291   REAL :: temp38
 292   REAL :: temp3b3
 293   REAL :: temp27b9
 294   REAL :: temp31b51
 295   REAL :: temp37
 296   REAL :: temp3b2
 297   REAL :: temp27b8
 298   REAL :: temp31b50
 299   INTEGER :: temp36
 300   REAL :: temp3b1
 301   REAL :: temp27b7
 302   REAL :: temp35
 303   REAL :: temp3b0
 304   REAL :: temp27b6
 305   REAL :: temp34
 306   REAL :: temp27b5
 307   REAL :: temp33
 308   REAL :: temp27b4
 309   INTEGER :: temp32
 310   REAL :: temp27b3
 311   REAL :: temp31
 312   REAL :: temp27b2
 313   REAL :: temp30
 314   REAL :: temp27b1
 315   REAL :: temp27b0
 316   INTRINSIC MIN
 317   REAL :: temp31b19
 318   REAL :: temp31b18
 319   REAL :: temp31b17
 320   REAL :: temp15b3
 321   REAL :: temp31b16
 322   REAL :: temp
 323   REAL :: temp15b2
 324   REAL :: temp31b15
 325   REAL :: temp15b1
 326   REAL :: temp31b14
 327   REAL :: temp15b0
 328   REAL :: temp31b13
 329   REAL :: temp9
 330   REAL :: temp31b12
 331   REAL :: temp31b49
 332   REAL :: temp47b4
 333   INTEGER :: temp8
 334   REAL :: temp31b11
 335   REAL :: temp31b48
 336   REAL :: temp39b
 337   REAL :: temp47b3
 338   REAL :: temp7
 339   REAL :: temp31b10
 340   REAL :: temp31b47
 341   REAL :: temp47b
 342   REAL :: temp47b2
 343   REAL :: temp6
 344   REAL :: temp31b46
 345   REAL :: temp47b1
 346   REAL :: temp5
 347   REAL :: temp31b45
 348   REAL :: temp47b0
 349   INTEGER :: temp4
 350   REAL :: temp31b44
 351   specified = .false.
 352   IF (config_flags%specified .OR. config_flags%nested) specified = &
 353 &      .true.
 354 !  set order for vertical and horzontal flux operators
 355   horz_order = config_flags%h_mom_adv_order
 356   vert_order = config_flags%v_mom_adv_order
 357   IF (kte .GT. kde - 1) THEN
 358     ktf = kde - 1
 359   ELSE
 360     ktf = kte
 361   END IF
 362 !  begin with horizontal flux divergence
 363   IF (horz_order .EQ. 6) THEN
 364 !  determine boundary mods for flux operators
 365 !  We degrade the flux operators from 3rd/4th order
 366 !   to second order one gridpoint in from the boundaries for
 367 !   all boundary conditions except periodic and symmetry - these
 368 !   conditions have boundary zone data fill for correct application
 369 !   of the higher order flux stencils
 370     degrade_xs = .true.
 371     degrade_xe = .true.
 372     degrade_ys = .true.
 373     degrade_ye = .true.
 374     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
 375 &        its .GT. ids + 3) degrade_xs = .false.
 376     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
 377 &        ite .LT. ide - 2) degrade_xe = .false.
 378     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 379 &        jts .GT. jds + 3) degrade_ys = .false.
 380     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 381 &        jte .LT. jde - 4) degrade_ye = .false.
 382 !--------------- y - advection first
 383     i_start = its
 384     i_end = ite
 385     IF (config_flags%open_xs .OR. specified) THEN
 386       IF (ids + 1 .LT. its) THEN
 387         i_start = its
 388       ELSE
 389         i_start = ids + 1
 390       END IF
 391     END IF
 392     IF (config_flags%open_xe .OR. specified) THEN
 393       IF (ide - 1 .GT. ite) THEN
 394         i_end = ite
 395       ELSE
 396         i_end = ide - 1
 397       END IF
 398     END IF
 399     IF (config_flags%periodic_x) i_start = its
 400     IF (config_flags%periodic_x) i_end = ite
 401     j_start = jts
 402     IF (jte .GT. jde - 1) THEN
 403       j_end = jde - 1
 404     ELSE
 405       j_end = jte
 406     END IF
 407 !  higher order flux has a 5 or 7 point stencil, so compute
 408 !  bounds so we can switch to second order flux close to the boundary
 409     j_start_f = j_start
 410     j_end_f = j_end + 1
 411     IF (degrade_ys) THEN
 412       IF (jts .LT. jds + 1) THEN
 413         j_start = jds + 1
 414       ELSE
 415         j_start = jts
 416       END IF
 417       j_start_f = jds + 3
 418     END IF
 419     IF (degrade_ye) THEN
 420       IF (jte .GT. jde - 2) THEN
 421         j_end = jde - 2
 422       ELSE
 423         j_end = jte
 424       END IF
 425       j_end_f = jde - 3
 426     END IF
 427     IF (config_flags%polar) THEN
 428       IF (jte .GT. jde - 1) THEN
 429         j_end = jde - 1
 430       ELSE
 431         j_end = jte
 432       END IF
 433     END IF
 434 !  compute fluxes, 5th or 6th order
 435     jp1 = 2
 436     jp0 = 1
 437     ad_from42 = j_start
 438 j_loop_y_flux_6:DO j=ad_from42,j_end+1
 439       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
 440 ! use full stencil
 441         DO k=kts,ktf
 442           ad_from34 = i_start
 443           i = i_end + 1
 444           CALL PUSHINTEGER4(i - 1)
 445           CALL PUSHINTEGER4(ad_from34)
 446         END DO
 447         CALL PUSHCONTROL3B(0)
 448       ELSE IF (j .EQ. jds + 1) THEN
 449 !  we must be close to some boundary where we need to reduce the order of the stencil
 450 ! 2nd order flux next to south boundary
 451         DO k=kts,ktf
 452           ad_from35 = i_start
 453           i = i_end + 1
 454           CALL PUSHINTEGER4(i - 1)
 455           CALL PUSHINTEGER4(ad_from35)
 456         END DO
 457         CALL PUSHCONTROL3B(1)
 458       ELSE IF (j .EQ. jds + 2) THEN
 459 ! third of 4th order flux 2 in from south boundary
 460         DO k=kts,ktf
 461           ad_from36 = i_start
 462           i = i_end + 1
 463           CALL PUSHINTEGER4(i - 1)
 464           CALL PUSHINTEGER4(ad_from36)
 465         END DO
 466         CALL PUSHCONTROL3B(2)
 467       ELSE IF (j .EQ. jde - 1) THEN
 468 ! 2nd order flux next to north boundary
 469         DO k=kts,ktf
 470           ad_from37 = i_start
 471           i = i_end + 1
 472           CALL PUSHINTEGER4(i - 1)
 473           CALL PUSHINTEGER4(ad_from37)
 474         END DO
 475         CALL PUSHCONTROL3B(3)
 476       ELSE IF (j .EQ. jde - 2) THEN
 477 ! 3rd order flux 2 in from north boundary
 478         DO k=kts,ktf
 479           ad_from38 = i_start
 480           i = i_end + 1
 481           CALL PUSHINTEGER4(i - 1)
 482           CALL PUSHINTEGER4(ad_from38)
 483         END DO
 484         CALL PUSHCONTROL3B(4)
 485       ELSE
 486         CALL PUSHCONTROL3B(5)
 487       END IF
 488 !  y flux-divergence into tendency
 489 ! (j > j_start) will miss the u(,,jds) tendency
 490       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
 491         DO k=kts,ktf
 492           ad_from39 = i_start
 493           i = i_end + 1
 494           CALL PUSHINTEGER4(i - 1)
 495           CALL PUSHINTEGER4(ad_from39)
 496         END DO
 497         CALL PUSHCONTROL2B(0)
 498       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
 499 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 500         DO k=kts,ktf
 501           ad_from40 = i_start
 502           i = i_end + 1
 503           CALL PUSHINTEGER4(i - 1)
 504           CALL PUSHINTEGER4(ad_from40)
 505         END DO
 506         CALL PUSHCONTROL2B(1)
 507       ELSE IF (j .GT. j_start) THEN
 508 ! normal code
 509         DO k=kts,ktf
 510           ad_from41 = i_start
 511           i = i_end + 1
 512           CALL PUSHINTEGER4(i - 1)
 513           CALL PUSHINTEGER4(ad_from41)
 514         END DO
 515         CALL PUSHCONTROL2B(2)
 516       ELSE
 517         CALL PUSHCONTROL2B(3)
 518       END IF
 519       jtmp = jp1
 520       CALL PUSHINTEGER4(jp1)
 521       jp1 = jp0
 522       CALL PUSHINTEGER4(jp0)
 523       jp0 = jtmp
 524     END DO j_loop_y_flux_6
 525     CALL PUSHINTEGER4(j - 1)
 526     CALL PUSHINTEGER4(ad_from42)
 527 !  next, x - flux divergence
 528     i_start = its
 529     i_end = ite
 530     j_start = jts
 531     IF (jte .GT. jde - 1) THEN
 532       j_end = jde - 1
 533     ELSE
 534       j_end = jte
 535     END IF
 536 !  higher order flux has a 5 or 7 point stencil, so compute
 537 !  bounds so we can switch to second order flux close to the boundary
 538     i_start_f = i_start
 539     i_end_f = i_end + 1
 540     IF (degrade_xs) THEN
 541       IF (ids + 1 .LT. its) THEN
 542         i_start = its
 543       ELSE
 544         i_start = ids + 1
 545       END IF
 546       i_start_f = ids + 3
 547     END IF
 548     IF (degrade_xe) THEN
 549       IF (ide - 1 .GT. ite) THEN
 550         i_end = ite
 551       ELSE
 552         i_end = ide - 1
 553       END IF
 554       i_end_f = ide - 2
 555     END IF
 556     ad_from44 = j_start
 557 !  compute fluxes
 558     DO j=ad_from44,j_end
 559 !  5th or 6th order flux
 560       DO k=kts,ktf
 561         CALL PUSHINTEGER4(i)
 562       END DO
 563 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 564 !  specified uses upstream normal wind at boundaries
 565       IF (degrade_xs) THEN
 566         IF (i_start .EQ. ids + 1) THEN
 567           CALL PUSHINTEGER4(i)
 568 ! second order flux next to the boundary
 569           i = ids + 1
 570           DO k=kts,ktf
 571             CALL PUSHREAL8(ub)
 572             ub = u(i-1, k, j)
 573             IF (specified .AND. u(i, k, j) .LT. 0.) THEN
 574               ub = u(i, k, j)
 575               CALL PUSHCONTROL1B(0)
 576             ELSE
 577               CALL PUSHCONTROL1B(1)
 578             END IF
 579           END DO
 580           CALL PUSHCONTROL1B(0)
 581         ELSE
 582           CALL PUSHCONTROL1B(1)
 583         END IF
 584         CALL PUSHINTEGER4(i)
 585         i = ids + 2
 586         CALL PUSHCONTROL1B(0)
 587       ELSE
 588         CALL PUSHCONTROL1B(1)
 589       END IF
 590       IF (degrade_xe) THEN
 591         IF (i_end .EQ. ide - 1) THEN
 592           CALL PUSHINTEGER4(i)
 593 ! second order flux next to the boundary
 594           i = ide
 595           DO k=kts,ktf
 596             CALL PUSHREAL8(ub)
 597             ub = u(i, k, j)
 598             IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
 599               ub = u(i-1, k, j)
 600               CALL PUSHCONTROL1B(0)
 601             ELSE
 602               CALL PUSHCONTROL1B(1)
 603             END IF
 604           END DO
 605           CALL PUSHCONTROL1B(1)
 606         ELSE
 607           CALL PUSHCONTROL1B(0)
 608         END IF
 609         DO k=kts,ktf
 610           CALL PUSHINTEGER4(i)
 611         END DO
 612         CALL PUSHCONTROL1B(1)
 613       ELSE
 614         CALL PUSHCONTROL1B(0)
 615       END IF
 616 !  x flux-divergence into tendency
 617       DO k=kts,ktf
 618         ad_from43 = i_start
 619         CALL PUSHINTEGER4(i)
 620         i = i_end + 1
 621         CALL PUSHINTEGER4(i - 1)
 622         CALL PUSHINTEGER4(ad_from43)
 623       END DO
 624     END DO
 625     CALL PUSHINTEGER4(j - 1)
 626     CALL PUSHINTEGER4(ad_from44)
 627     CALL PUSHCONTROL3B(0)
 628   ELSE IF (horz_order .EQ. 5) THEN
 629 !  5th order horizontal flux calculation
 630 !  This code is EXACTLY the same as the 6th order code
 631 !  EXCEPT the 5th order and 3rd operators are used in
 632 !  place of the 6th and 4th order operators
 633 !  determine boundary mods for flux operators
 634 !  We degrade the flux operators from 3rd/4th order
 635 !   to second order one gridpoint in from the boundaries for
 636 !   all boundary conditions except periodic and symmetry - these
 637 !   conditions have boundary zone data fill for correct application
 638 !   of the higher order flux stencils
 639     degrade_xs = .true.
 640     degrade_xe = .true.
 641     degrade_ys = .true.
 642     degrade_ye = .true.
 643     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
 644 &        its .GT. ids + 3) degrade_xs = .false.
 645     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
 646 &        ite .LT. ide - 2) degrade_xe = .false.
 647     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 648 &        jts .GT. jds + 3) degrade_ys = .false.
 649     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 650 &        jte .LT. jde - 4) degrade_ye = .false.
 651 !--------------- y - advection first
 652     i_start = its
 653     i_end = ite
 654     IF (config_flags%open_xs .OR. specified) THEN
 655       IF (ids + 1 .LT. its) THEN
 656         i_start = its
 657       ELSE
 658         i_start = ids + 1
 659       END IF
 660     END IF
 661     IF (config_flags%open_xe .OR. specified) THEN
 662       IF (ide - 1 .GT. ite) THEN
 663         i_end = ite
 664       ELSE
 665         i_end = ide - 1
 666       END IF
 667     END IF
 668     IF (config_flags%periodic_x) i_start = its
 669     IF (config_flags%periodic_x) i_end = ite
 670     j_start = jts
 671     IF (jte .GT. jde - 1) THEN
 672       j_end = jde - 1
 673     ELSE
 674       j_end = jte
 675     END IF
 676 !  higher order flux has a 5 or 7 point stencil, so compute
 677 !  bounds so we can switch to second order flux close to the boundary
 678     j_start_f = j_start
 679     j_end_f = j_end + 1
 680     IF (degrade_ys) THEN
 681       IF (jts .LT. jds + 1) THEN
 682         j_start = jds + 1
 683       ELSE
 684         j_start = jts
 685       END IF
 686       j_start_f = jds + 3
 687     END IF
 688     IF (degrade_ye) THEN
 689       IF (jte .GT. jde - 2) THEN
 690         j_end = jde - 2
 691       ELSE
 692         j_end = jte
 693       END IF
 694       j_end_f = jde - 3
 695     END IF
 696     IF (config_flags%polar) THEN
 697       IF (jte .GT. jde - 1) THEN
 698         j_end = jde - 1
 699       ELSE
 700         j_end = jte
 701       END IF
 702     END IF
 703 !  compute fluxes, 5th or 6th order
 704     jp1 = 2
 705     jp0 = 1
 706     ad_from7 = j_start
 707 j_loop_y_flux_5:DO j=ad_from7,j_end+1
 708       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
 709 ! use full stencil
 710         DO k=kts,ktf
 711           ad_from = i_start
 712           i = i_end + 1
 713           CALL PUSHINTEGER4(i - 1)
 714           CALL PUSHINTEGER4(ad_from)
 715         END DO
 716         CALL PUSHCONTROL3B(0)
 717       ELSE IF (j .EQ. jds + 1) THEN
 718 !  we must be close to some boundary where we need to reduce the order of the stencil
 719 ! 2nd order flux next to south boundary
 720         DO k=kts,ktf
 721           ad_from0 = i_start
 722           i = i_end + 1
 723           CALL PUSHINTEGER4(i - 1)
 724           CALL PUSHINTEGER4(ad_from0)
 725         END DO
 726         CALL PUSHCONTROL3B(1)
 727       ELSE IF (j .EQ. jds + 2) THEN
 728 ! third of 4th order flux 2 in from south boundary
 729         DO k=kts,ktf
 730           ad_from1 = i_start
 731           i = i_end + 1
 732           CALL PUSHINTEGER4(i - 1)
 733           CALL PUSHINTEGER4(ad_from1)
 734         END DO
 735         CALL PUSHCONTROL3B(2)
 736       ELSE IF (j .EQ. jde - 1) THEN
 737 ! 2nd order flux next to north boundary
 738         DO k=kts,ktf
 739           ad_from2 = i_start
 740           i = i_end + 1
 741           CALL PUSHINTEGER4(i - 1)
 742           CALL PUSHINTEGER4(ad_from2)
 743         END DO
 744         CALL PUSHCONTROL3B(3)
 745       ELSE IF (j .EQ. jde - 2) THEN
 746 ! 3rd order flux 2 in from north boundary
 747         DO k=kts,ktf
 748           ad_from3 = i_start
 749           i = i_end + 1
 750           CALL PUSHINTEGER4(i - 1)
 751           CALL PUSHINTEGER4(ad_from3)
 752         END DO
 753         CALL PUSHCONTROL3B(4)
 754       ELSE
 755         CALL PUSHCONTROL3B(5)
 756       END IF
 757 !  y flux-divergence into tendency
 758 ! (j > j_start) will miss the u(,,jds) tendency
 759       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
 760         DO k=kts,ktf
 761           ad_from4 = i_start
 762           i = i_end + 1
 763           CALL PUSHINTEGER4(i - 1)
 764           CALL PUSHINTEGER4(ad_from4)
 765         END DO
 766         CALL PUSHCONTROL2B(0)
 767       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
 768 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 769         DO k=kts,ktf
 770           ad_from5 = i_start
 771           i = i_end + 1
 772           CALL PUSHINTEGER4(i - 1)
 773           CALL PUSHINTEGER4(ad_from5)
 774         END DO
 775         CALL PUSHCONTROL2B(1)
 776       ELSE IF (j .GT. j_start) THEN
 777 ! normal code
 778         DO k=kts,ktf
 779           ad_from6 = i_start
 780           i = i_end + 1
 781           CALL PUSHINTEGER4(i - 1)
 782           CALL PUSHINTEGER4(ad_from6)
 783         END DO
 784         CALL PUSHCONTROL2B(2)
 785       ELSE
 786         CALL PUSHCONTROL2B(3)
 787       END IF
 788       jtmp = jp1
 789       CALL PUSHINTEGER4(jp1)
 790       jp1 = jp0
 791       CALL PUSHINTEGER4(jp0)
 792       jp0 = jtmp
 793     END DO j_loop_y_flux_5
 794     CALL PUSHINTEGER4(j - 1)
 795     CALL PUSHINTEGER4(ad_from7)
 796 !  next, x - flux divergence
 797     i_start = its
 798     i_end = ite
 799     j_start = jts
 800     IF (jte .GT. jde - 1) THEN
 801       j_end = jde - 1
 802     ELSE
 803       j_end = jte
 804     END IF
 805 !  higher order flux has a 5 or 7 point stencil, so compute
 806 !  bounds so we can switch to second order flux close to the boundary
 807     i_start_f = i_start
 808     i_end_f = i_end + 1
 809     IF (degrade_xs) THEN
 810       IF (ids + 1 .LT. its) THEN
 811         i_start = its
 812       ELSE
 813         i_start = ids + 1
 814       END IF
 815       i_start_f = ids + 3
 816     END IF
 817     IF (degrade_xe) THEN
 818       IF (ide - 1 .GT. ite) THEN
 819         i_end = ite
 820       ELSE
 821         i_end = ide - 1
 822       END IF
 823       i_end_f = ide - 2
 824     END IF
 825     ad_from9 = j_start
 826 !  compute fluxes
 827     DO j=ad_from9,j_end
 828 !  5th or 6th order flux
 829       DO k=kts,ktf
 830         CALL PUSHINTEGER4(i)
 831       END DO
 832 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 833 !  specified uses upstream normal wind at boundaries
 834       IF (degrade_xs) THEN
 835         IF (i_start .EQ. ids + 1) THEN
 836           CALL PUSHINTEGER4(i)
 837 ! second order flux next to the boundary
 838           i = ids + 1
 839           DO k=kts,ktf
 840             CALL PUSHREAL8(ub)
 841             ub = u(i-1, k, j)
 842             IF (specified .AND. u(i, k, j) .LT. 0.) THEN
 843               ub = u(i, k, j)
 844               CALL PUSHCONTROL1B(0)
 845             ELSE
 846               CALL PUSHCONTROL1B(1)
 847             END IF
 848           END DO
 849           CALL PUSHCONTROL1B(0)
 850         ELSE
 851           CALL PUSHCONTROL1B(1)
 852         END IF
 853         CALL PUSHINTEGER4(i)
 854         i = ids + 2
 855         CALL PUSHCONTROL1B(0)
 856       ELSE
 857         CALL PUSHCONTROL1B(1)
 858       END IF
 859       IF (degrade_xe) THEN
 860         IF (i_end .EQ. ide - 1) THEN
 861           CALL PUSHINTEGER4(i)
 862 ! second order flux next to the boundary
 863           i = ide
 864           DO k=kts,ktf
 865             CALL PUSHREAL8(ub)
 866             ub = u(i, k, j)
 867             IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
 868               ub = u(i-1, k, j)
 869               CALL PUSHCONTROL1B(0)
 870             ELSE
 871               CALL PUSHCONTROL1B(1)
 872             END IF
 873           END DO
 874           CALL PUSHCONTROL1B(1)
 875         ELSE
 876           CALL PUSHCONTROL1B(0)
 877         END IF
 878         DO k=kts,ktf
 879           CALL PUSHINTEGER4(i)
 880         END DO
 881         CALL PUSHCONTROL1B(1)
 882       ELSE
 883         CALL PUSHCONTROL1B(0)
 884       END IF
 885 !  x flux-divergence into tendency
 886       DO k=kts,ktf
 887         ad_from8 = i_start
 888         CALL PUSHINTEGER4(i)
 889         i = i_end + 1
 890         CALL PUSHINTEGER4(i - 1)
 891         CALL PUSHINTEGER4(ad_from8)
 892       END DO
 893     END DO
 894     CALL PUSHINTEGER4(j - 1)
 895     CALL PUSHINTEGER4(ad_from9)
 896     CALL PUSHCONTROL3B(1)
 897   ELSE IF (horz_order .EQ. 4) THEN
 898 !  determine boundary mods for flux operators
 899 !  We degrade the flux operators from 3rd/4th order
 900 !   to second order one gridpoint in from the boundaries for
 901 !   all boundary conditions except periodic and symmetry - these
 902 !   conditions have boundary zone data fill for correct application
 903 !   of the higher order flux stencils
 904     degrade_xs = .true.
 905     degrade_xe = .true.
 906     degrade_ys = .true.
 907     degrade_ye = .true.
 908     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
 909 &        its .GT. ids + 2) degrade_xs = .false.
 910     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
 911 &        ite .LT. ide - 1) degrade_xe = .false.
 912     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 913 &        jts .GT. jds + 2) degrade_ys = .false.
 914     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 915 &        jte .LT. jde - 3) degrade_ye = .false.
 916 !--------------- x - advection first
 917     i_start = its
 918     i_end = ite
 919     j_start = jts
 920     IF (jte .GT. jde - 1) THEN
 921       j_end = jde - 1
 922     ELSE
 923       j_end = jte
 924     END IF
 925 !  3rd or 4th order flux has a 5 point stencil, so compute
 926 !  bounds so we can switch to second order flux close to the boundary
 927     i_start_f = i_start
 928     i_end_f = i_end + 1
 929     IF (degrade_xs) THEN
 930       i_start = ids + 1
 931       i_start_f = i_start + 1
 932     END IF
 933     IF (degrade_xe) THEN
 934       i_end = ide - 1
 935       i_end_f = ide - 1
 936     END IF
 937     ad_from11 = j_start
 938 !  compute fluxes
 939     DO j=ad_from11,j_end
 940       DO k=kts,ktf
 941         CALL PUSHINTEGER4(i)
 942       END DO
 943 !  second order flux close to boundaries (if not periodic or symmetric)
 944 !  specified uses upstream normal wind at boundaries
 945       IF (degrade_xs) THEN
 946         CALL PUSHINTEGER4(i)
 947         i = i_start
 948         DO k=kts,ktf
 949           CALL PUSHREAL8(ub)
 950           ub = u(i-1, k, j)
 951           IF (specified .AND. u(i, k, j) .LT. 0.) THEN
 952             ub = u(i, k, j)
 953             CALL PUSHCONTROL1B(0)
 954           ELSE
 955             CALL PUSHCONTROL1B(1)
 956           END IF
 957         END DO
 958         CALL PUSHCONTROL1B(0)
 959       ELSE
 960         CALL PUSHCONTROL1B(1)
 961       END IF
 962       IF (degrade_xe) THEN
 963         CALL PUSHINTEGER4(i)
 964         i = i_end + 1
 965         DO k=kts,ktf
 966           CALL PUSHREAL8(ub)
 967           ub = u(i, k, j)
 968           IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
 969             ub = u(i-1, k, j)
 970             CALL PUSHCONTROL1B(0)
 971           ELSE
 972             CALL PUSHCONTROL1B(1)
 973           END IF
 974         END DO
 975         CALL PUSHCONTROL1B(1)
 976       ELSE
 977         CALL PUSHCONTROL1B(0)
 978       END IF
 979 !  x flux-divergence into tendency
 980       DO k=kts,ktf
 981         ad_from10 = i_start
 982         CALL PUSHINTEGER4(i)
 983         i = i_end + 1
 984         CALL PUSHINTEGER4(i - 1)
 985         CALL PUSHINTEGER4(ad_from10)
 986       END DO
 987     END DO
 988     CALL PUSHINTEGER4(j - 1)
 989     CALL PUSHINTEGER4(ad_from11)
 990 !  y flux divergence
 991     i_start = its
 992     i_end = ite
 993     IF (config_flags%open_xs .OR. specified) THEN
 994       IF (ids + 1 .LT. its) THEN
 995         i_start = its
 996       ELSE
 997         i_start = ids + 1
 998       END IF
 999     END IF
1000     IF (config_flags%open_xe .OR. specified) THEN
1001       IF (ide - 1 .GT. ite) THEN
1002         i_end = ite
1003       ELSE
1004         i_end = ide - 1
1005       END IF
1006     END IF
1007     IF (config_flags%periodic_x) i_start = its
1008     IF (config_flags%periodic_x) i_end = ite
1009     j_start = jts
1010     IF (jte .GT. jde - 1) THEN
1011       j_end = jde - 1
1012     ELSE
1013       j_end = jte
1014     END IF
1015 !  3rd or 4th order flux has a 5 point stencil, so compute
1016 !  bounds so we can switch to second order flux close to the boundary
1017     j_start_f = j_start
1018     j_end_f = j_end + 1
1019 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
1020     IF (degrade_ys) THEN
1021       j_start = jds + 1
1022       j_start_f = j_start + 1
1023     END IF
1024     IF (degrade_ye) THEN
1025       j_end = jde - 2
1026       j_end_f = jde - 2
1027     END IF
1028     IF (config_flags%polar) THEN
1029       IF (jte .GT. jde - 1) THEN
1030         j_end = jde - 1
1031       ELSE
1032         j_end = jte
1033       END IF
1034     END IF
1035 !  j flux loop for v flux of u momentum
1036     jp1 = 2
1037     jp0 = 1
1038     ad_from18 = j_start
1039     DO j=ad_from18,j_end+1
1040       IF (j .LT. j_start_f .AND. degrade_ys) THEN
1041         DO k=kts,ktf
1042           ad_from12 = i_start
1043           CALL PUSHINTEGER4(i)
1044           i = i_end + 1
1045           CALL PUSHINTEGER4(i - 1)
1046           CALL PUSHINTEGER4(ad_from12)
1047         END DO
1048         CALL PUSHCONTROL2B(0)
1049       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
1050         DO k=kts,ktf
1051           ad_from13 = i_start
1052           CALL PUSHINTEGER4(i)
1053           i = i_end + 1
1054           CALL PUSHINTEGER4(i - 1)
1055           CALL PUSHINTEGER4(ad_from13)
1056         END DO
1057         CALL PUSHCONTROL2B(1)
1058       ELSE
1059 !  3rd or 4th order flux
1060         DO k=kts,ktf
1061           ad_from14 = i_start
1062           CALL PUSHINTEGER4(i)
1063           i = i_end + 1
1064           CALL PUSHINTEGER4(i - 1)
1065           CALL PUSHINTEGER4(ad_from14)
1066         END DO
1067         CALL PUSHCONTROL2B(2)
1068       END IF
1069 !  y flux-divergence into tendency
1070 ! (j > j_start) will miss the u(,,jds) tendency
1071       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
1072         DO k=kts,ktf
1073           ad_from15 = i_start
1074           CALL PUSHINTEGER4(i)
1075           i = i_end + 1
1076           CALL PUSHINTEGER4(i - 1)
1077           CALL PUSHINTEGER4(ad_from15)
1078         END DO
1079         CALL PUSHCONTROL2B(0)
1080       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
1081 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1082         DO k=kts,ktf
1083           ad_from16 = i_start
1084           CALL PUSHINTEGER4(i)
1085           i = i_end + 1
1086           CALL PUSHINTEGER4(i - 1)
1087           CALL PUSHINTEGER4(ad_from16)
1088         END DO
1089         CALL PUSHCONTROL2B(1)
1090       ELSE IF (j .GT. j_start) THEN
1091 ! normal code
1092         DO k=kts,ktf
1093           ad_from17 = i_start
1094           CALL PUSHINTEGER4(i)
1095           i = i_end + 1
1096           CALL PUSHINTEGER4(i - 1)
1097           CALL PUSHINTEGER4(ad_from17)
1098         END DO
1099         CALL PUSHCONTROL2B(2)
1100       ELSE
1101         CALL PUSHCONTROL2B(3)
1102       END IF
1103       jtmp = jp1
1104       CALL PUSHINTEGER4(jp1)
1105       jp1 = jp0
1106       CALL PUSHINTEGER4(jp0)
1107       jp0 = jtmp
1108     END DO
1109     CALL PUSHINTEGER4(j - 1)
1110     CALL PUSHINTEGER4(ad_from18)
1111     CALL PUSHCONTROL3B(2)
1112   ELSE IF (horz_order .EQ. 3) THEN
1113 !  As with the 5th and 6th order flux chioces, the 3rd and 4th order
1114 !  code is EXACTLY the same EXCEPT for the flux operator.
1115 !  determine boundary mods for flux operators
1116 !  We degrade the flux operators from 3rd/4th order
1117 !   to second order one gridpoint in from the boundaries for
1118 !   all boundary conditions except periodic and symmetry - these
1119 !   conditions have boundary zone data fill for correct application
1120 !   of the higher order flux stencils
1121     degrade_xs = .true.
1122     degrade_xe = .true.
1123     degrade_ys = .true.
1124     degrade_ye = .true.
1125     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
1126 &        its .GT. ids + 2) degrade_xs = .false.
1127     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
1128 &        ite .LT. ide - 1) degrade_xe = .false.
1129     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
1130 &        jts .GT. jds + 2) degrade_ys = .false.
1131     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
1132 &        jte .LT. jde - 3) degrade_ye = .false.
1133 !--------------- x - advection first
1134     i_start = its
1135     i_end = ite
1136     j_start = jts
1137     IF (jte .GT. jde - 1) THEN
1138       j_end = jde - 1
1139     ELSE
1140       j_end = jte
1141     END IF
1142 !  3rd or 4th order flux has a 5 point stencil, so compute
1143 !  bounds so we can switch to second order flux close to the boundary
1144     i_start_f = i_start
1145     i_end_f = i_end + 1
1146     IF (degrade_xs) THEN
1147       i_start = ids + 1
1148       i_start_f = i_start + 1
1149     END IF
1150     IF (degrade_xe) THEN
1151       i_end = ide - 1
1152       i_end_f = ide - 1
1153     END IF
1154     ad_from20 = j_start
1155 !  compute fluxes
1156     DO j=ad_from20,j_end
1157       DO k=kts,ktf
1158         CALL PUSHINTEGER4(i)
1159       END DO
1160 !  second order flux close to boundaries (if not periodic or symmetric)
1161 !  specified uses upstream normal wind at boundaries
1162       IF (degrade_xs) THEN
1163         CALL PUSHINTEGER4(i)
1164         i = i_start
1165         DO k=kts,ktf
1166           CALL PUSHREAL8(ub)
1167           ub = u(i-1, k, j)
1168           IF (specified .AND. u(i, k, j) .LT. 0.) THEN
1169             ub = u(i, k, j)
1170             CALL PUSHCONTROL1B(0)
1171           ELSE
1172             CALL PUSHCONTROL1B(1)
1173           END IF
1174         END DO
1175         CALL PUSHCONTROL1B(0)
1176       ELSE
1177         CALL PUSHCONTROL1B(1)
1178       END IF
1179       IF (degrade_xe) THEN
1180         CALL PUSHINTEGER4(i)
1181         i = i_end + 1
1182         DO k=kts,ktf
1183           CALL PUSHREAL8(ub)
1184           ub = u(i, k, j)
1185           IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
1186             ub = u(i-1, k, j)
1187             CALL PUSHCONTROL1B(0)
1188           ELSE
1189             CALL PUSHCONTROL1B(1)
1190           END IF
1191         END DO
1192         CALL PUSHCONTROL1B(1)
1193       ELSE
1194         CALL PUSHCONTROL1B(0)
1195       END IF
1196 !  x flux-divergence into tendency
1197       DO k=kts,ktf
1198         ad_from19 = i_start
1199         CALL PUSHINTEGER4(i)
1200         i = i_end + 1
1201         CALL PUSHINTEGER4(i - 1)
1202         CALL PUSHINTEGER4(ad_from19)
1203       END DO
1204     END DO
1205     CALL PUSHINTEGER4(j - 1)
1206     CALL PUSHINTEGER4(ad_from20)
1207 !  y flux divergence
1208     i_start = its
1209     i_end = ite
1210     IF (config_flags%open_xs .OR. specified) THEN
1211       IF (ids + 1 .LT. its) THEN
1212         i_start = its
1213       ELSE
1214         i_start = ids + 1
1215       END IF
1216     END IF
1217     IF (config_flags%open_xe .OR. specified) THEN
1218       IF (ide - 1 .GT. ite) THEN
1219         i_end = ite
1220       ELSE
1221         i_end = ide - 1
1222       END IF
1223     END IF
1224     IF (config_flags%periodic_x) i_start = its
1225     IF (config_flags%periodic_x) i_end = ite
1226     j_start = jts
1227     IF (jte .GT. jde - 1) THEN
1228       j_end = jde - 1
1229     ELSE
1230       j_end = jte
1231     END IF
1232 !  3rd or 4th order flux has a 5 point stencil, so compute
1233 !  bounds so we can switch to second order flux close to the boundary
1234     j_start_f = j_start
1235     j_end_f = j_end + 1
1236 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
1237     IF (degrade_ys) THEN
1238       j_start = jds + 1
1239       j_start_f = j_start + 1
1240     END IF
1241     IF (degrade_ye) THEN
1242       j_end = jde - 2
1243       j_end_f = jde - 2
1244     END IF
1245     IF (config_flags%polar) THEN
1246       IF (jte .GT. jde - 1) THEN
1247         j_end = jde - 1
1248       ELSE
1249         j_end = jte
1250       END IF
1251     END IF
1252 !  j flux loop for v flux of u momentum
1253     jp1 = 2
1254     jp0 = 1
1255     ad_from27 = j_start
1256     DO j=ad_from27,j_end+1
1257       IF (j .LT. j_start_f .AND. degrade_ys) THEN
1258         DO k=kts,ktf
1259           ad_from21 = i_start
1260           CALL PUSHINTEGER4(i)
1261           i = i_end + 1
1262           CALL PUSHINTEGER4(i - 1)
1263           CALL PUSHINTEGER4(ad_from21)
1264         END DO
1265         CALL PUSHCONTROL2B(0)
1266       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
1267         DO k=kts,ktf
1268           ad_from22 = i_start
1269           CALL PUSHINTEGER4(i)
1270           i = i_end + 1
1271           CALL PUSHINTEGER4(i - 1)
1272           CALL PUSHINTEGER4(ad_from22)
1273         END DO
1274         CALL PUSHCONTROL2B(1)
1275       ELSE
1276 !  3rd or 4th order flux
1277         DO k=kts,ktf
1278           ad_from23 = i_start
1279           CALL PUSHINTEGER4(i)
1280           i = i_end + 1
1281           CALL PUSHINTEGER4(i - 1)
1282           CALL PUSHINTEGER4(ad_from23)
1283         END DO
1284         CALL PUSHCONTROL2B(2)
1285       END IF
1286 !  y flux-divergence into tendency
1287 ! (j > j_start) will miss the u(,,jds) tendency
1288       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
1289         DO k=kts,ktf
1290           ad_from24 = i_start
1291           CALL PUSHINTEGER4(i)
1292           i = i_end + 1
1293           CALL PUSHINTEGER4(i - 1)
1294           CALL PUSHINTEGER4(ad_from24)
1295         END DO
1296         CALL PUSHCONTROL2B(0)
1297       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
1298 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1299         DO k=kts,ktf
1300           ad_from25 = i_start
1301           CALL PUSHINTEGER4(i)
1302           i = i_end + 1
1303           CALL PUSHINTEGER4(i - 1)
1304           CALL PUSHINTEGER4(ad_from25)
1305         END DO
1306         CALL PUSHCONTROL2B(1)
1307       ELSE IF (j .GT. j_start) THEN
1308 ! normal code
1309         DO k=kts,ktf
1310           ad_from26 = i_start
1311           CALL PUSHINTEGER4(i)
1312           i = i_end + 1
1313           CALL PUSHINTEGER4(i - 1)
1314           CALL PUSHINTEGER4(ad_from26)
1315         END DO
1316         CALL PUSHCONTROL2B(2)
1317       ELSE
1318         CALL PUSHCONTROL2B(3)
1319       END IF
1320       jtmp = jp1
1321       CALL PUSHINTEGER4(jp1)
1322       jp1 = jp0
1323       CALL PUSHINTEGER4(jp0)
1324       jp0 = jtmp
1325     END DO
1326     CALL PUSHINTEGER4(j - 1)
1327     CALL PUSHINTEGER4(ad_from27)
1328     CALL PUSHCONTROL3B(3)
1329   ELSE IF (horz_order .EQ. 2) THEN
1330     i_start = its
1331     i_end = ite
1332     j_start = jts
1333     IF (jte .GT. jde - 1) THEN
1334       j_end = jde - 1
1335     ELSE
1336       j_end = jte
1337     END IF
1338     IF (config_flags%open_xs) THEN
1339       IF (ids + 1 .LT. its) THEN
1340         i_start = its
1341       ELSE
1342         i_start = ids + 1
1343       END IF
1344     END IF
1345     IF (config_flags%open_xe) THEN
1346       IF (ide - 1 .GT. ite) THEN
1347         i_end = ite
1348       ELSE
1349         i_end = ide - 1
1350       END IF
1351     END IF
1352     IF (specified) THEN
1353       IF (ids + 2 .LT. its) THEN
1354         i_start = its
1355       ELSE
1356         i_start = ids + 2
1357       END IF
1358     END IF
1359     IF (specified) THEN
1360       IF (ide - 2 .GT. ite) THEN
1361         i_end = ite
1362       ELSE
1363         i_end = ide - 2
1364       END IF
1365     END IF
1366     IF (config_flags%periodic_x) i_start = its
1367     IF (config_flags%periodic_x) i_end = ite
1368     ad_from29 = j_start
1369     DO j=ad_from29,j_end
1370       DO k=kts,ktf
1371         ad_from28 = i_start
1372         i = i_end + 1
1373         CALL PUSHINTEGER4(i - 1)
1374         CALL PUSHINTEGER4(ad_from28)
1375       END DO
1376     END DO
1377     CALL PUSHINTEGER4(j - 1)
1378     CALL PUSHINTEGER4(ad_from29)
1379     IF (specified .AND. its .LE. ids + 1 .AND. (.NOT.config_flags%&
1380 &        periodic_x)) THEN
1381       ad_from30 = j_start
1382       DO j=ad_from30,j_end
1383         DO k=kts,ktf
1384           i = ids + 1
1385           CALL PUSHREAL8(ub)
1386 ! ADT eqn 44, 1st term on RHS
1387           ub = u(i-1, k, j)
1388           IF (u(i, k, j) .LT. 0.) THEN
1389             ub = u(i, k, j)
1390             CALL PUSHCONTROL1B(0)
1391           ELSE
1392             CALL PUSHCONTROL1B(1)
1393           END IF
1394         END DO
1395       END DO
1396       CALL PUSHINTEGER4(j - 1)
1397       CALL PUSHINTEGER4(ad_from30)
1398       CALL PUSHCONTROL1B(0)
1399     ELSE
1400       CALL PUSHCONTROL1B(1)
1401     END IF
1402     IF (specified .AND. ite .GE. ide - 1 .AND. (.NOT.config_flags%&
1403 &        periodic_x)) THEN
1404       ad_from31 = j_start
1405       DO j=ad_from31,j_end
1406         DO k=kts,ktf
1407           i = ide - 1
1408           CALL PUSHREAL8(ub)
1409 ! ADT eqn 44, 1st term on RHS
1410           ub = u(i+1, k, j)
1411           IF (u(i, k, j) .GT. 0.) THEN
1412             ub = u(i, k, j)
1413             CALL PUSHCONTROL1B(0)
1414           ELSE
1415             CALL PUSHCONTROL1B(1)
1416           END IF
1417         END DO
1418       END DO
1419       CALL PUSHINTEGER4(j - 1)
1420       CALL PUSHINTEGER4(ad_from31)
1421       CALL PUSHCONTROL1B(0)
1422     ELSE
1423       CALL PUSHCONTROL1B(1)
1424     END IF
1425     IF (config_flags%open_ys .OR. specified) THEN
1426       IF (jds + 1 .LT. jts) THEN
1427         j_start = jts
1428       ELSE
1429         j_start = jds + 1
1430       END IF
1431     END IF
1432     IF (config_flags%open_ye .OR. specified) THEN
1433       IF (jde - 2 .GT. jte) THEN
1434         j_end = jte
1435       ELSE
1436         j_end = jde - 2
1437       END IF
1438     END IF
1439     ad_from33 = j_start
1440     DO j=ad_from33,j_end
1441       DO k=kts,ktf
1442         ad_from32 = i_start
1443         CALL PUSHINTEGER4(i)
1444         DO i=ad_from32,i_end
1445 ! ADT eqn 44, 1st term on RHS
1446 ! Comments for polar boundary condition
1447 ! Flow is only from one side for points next to poles
1448           IF (config_flags%polar .AND. j .EQ. jds) THEN
1449             CALL PUSHCONTROL2B(2)
1450           ELSE IF (config_flags%polar .AND. j .EQ. jde - 1) THEN
1451             CALL PUSHCONTROL2B(1)
1452           ELSE
1453             CALL PUSHCONTROL2B(0)
1454           END IF
1455         END DO
1456         CALL PUSHINTEGER4(i - 1)
1457         CALL PUSHINTEGER4(ad_from32)
1458       END DO
1459     END DO
1460     CALL PUSHINTEGER4(j - 1)
1461     CALL PUSHINTEGER4(ad_from33)
1462     CALL PUSHCONTROL3B(4)
1463   ELSE
1464     CALL PUSHCONTROL3B(5)
1465   END IF
1466 !  radiative lateral boundary condition in x for normal velocity (u)
1467   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
1468     CALL PUSHINTEGER4(j_start)
1469     j_start = jts
1470     IF (jte .GT. jde - 1) THEN
1471       j_end = jde - 1
1472     ELSE
1473       j_end = jte
1474     END IF
1475     ad_from45 = j_start
1476     DO j=ad_from45,j_end
1477       DO k=kts,ktf
1478         IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN
1479           CALL PUSHREAL8(ub)
1480           ub = 0.
1481           CALL PUSHCONTROL1B(0)
1482         ELSE
1483           CALL PUSHREAL8(ub)
1484           ub = ru(its, k, j) - cb*mut(its, j)
1485           CALL PUSHCONTROL1B(1)
1486         END IF
1487       END DO
1488     END DO
1489     CALL PUSHINTEGER4(j - 1)
1490     CALL PUSHINTEGER4(ad_from45)
1491     CALL PUSHCONTROL1B(0)
1492   ELSE
1493     CALL PUSHCONTROL1B(1)
1494   END IF
1495   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
1496     CALL PUSHINTEGER4(j_start)
1497     j_start = jts
1498     IF (jte .GT. jde - 1) THEN
1499       j_end = jde - 1
1500     ELSE
1501       j_end = jte
1502     END IF
1503     ad_from46 = j_start
1504     DO j=ad_from46,j_end
1505       DO k=kts,ktf
1506         IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN
1507           CALL PUSHREAL8(ub)
1508           ub = 0.
1509           CALL PUSHCONTROL1B(0)
1510         ELSE
1511           CALL PUSHREAL8(ub)
1512           ub = ru(ite, k, j) + cb*mut(ite-1, j)
1513           CALL PUSHCONTROL1B(1)
1514         END IF
1515       END DO
1516     END DO
1517     CALL PUSHINTEGER4(j - 1)
1518     CALL PUSHINTEGER4(ad_from46)
1519     CALL PUSHCONTROL1B(1)
1520   ELSE
1521     CALL PUSHCONTROL1B(0)
1522   END IF
1523 !  pick up the rest of the horizontal radiation boundary conditions.
1524 !  (these are the computations that don't require 'cb')
1525 !  first, set to index ranges
1526   i_start = its
1527   IF (ite .GT. ide) THEN
1528     i_end = ide
1529   ELSE
1530     i_end = ite
1531   END IF
1532   imin = ids
1533   imax = ide - 1
1534   IF (config_flags%open_xs) THEN
1535     IF (ids + 1 .LT. its) THEN
1536       i_start = its
1537     ELSE
1538       i_start = ids + 1
1539     END IF
1540     imin = ids
1541   END IF
1542   IF (config_flags%open_xe) THEN
1543     IF (ite .GT. ide - 1) THEN
1544       i_end = ide - 1
1545     ELSE
1546       i_end = ite
1547     END IF
1548     imax = ide - 1
1549   END IF
1550   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
1551     ad_from47 = i_start
1552     CALL PUSHINTEGER4(i)
1553     DO i=ad_from47,i_end
1554       CALL PUSHREAL8(mrdy)
1555 ! ADT eqn 44, 2nd term on RHS
1556       mrdy = msfux(i, jts)*rdy
1557       IF (imax .GT. i) THEN
1558         CALL PUSHINTEGER4(ip)
1559         ip = i
1560         CALL PUSHCONTROL1B(0)
1561       ELSE
1562         CALL PUSHINTEGER4(ip)
1563         ip = imax
1564         CALL PUSHCONTROL1B(1)
1565       END IF
1566       IF (imin .LT. i - 1) THEN
1567         CALL PUSHINTEGER4(im)
1568         im = i - 1
1569         CALL PUSHCONTROL1B(0)
1570       ELSE
1571         CALL PUSHINTEGER4(im)
1572         im = imin
1573         CALL PUSHCONTROL1B(1)
1574       END IF
1575       DO k=kts,ktf
1576         vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts))
1577         IF (vw .GT. 0.) THEN
1578           CALL PUSHREAL8(vb)
1579           vb = 0.
1580           CALL PUSHCONTROL1B(0)
1581         ELSE
1582           CALL PUSHREAL8(vb)
1583           vb = vw
1584           CALL PUSHCONTROL1B(1)
1585         END IF
1586       END DO
1587     END DO
1588     CALL PUSHINTEGER4(i - 1)
1589     CALL PUSHINTEGER4(ad_from47)
1590     CALL PUSHCONTROL1B(0)
1591   ELSE
1592     CALL PUSHCONTROL1B(1)
1593   END IF
1594   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
1595     ad_from48 = i_start
1596     CALL PUSHINTEGER4(i)
1597     DO i=ad_from48,i_end
1598       CALL PUSHREAL8(mrdy)
1599 ! ADT eqn 44, 2nd term on RHS
1600       mrdy = msfux(i, jte-1)*rdy
1601       IF (imax .GT. i) THEN
1602         CALL PUSHINTEGER4(ip)
1603         ip = i
1604         CALL PUSHCONTROL1B(0)
1605       ELSE
1606         CALL PUSHINTEGER4(ip)
1607         ip = imax
1608         CALL PUSHCONTROL1B(1)
1609       END IF
1610       IF (imin .LT. i - 1) THEN
1611         CALL PUSHINTEGER4(im)
1612         im = i - 1
1613         CALL PUSHCONTROL1B(0)
1614       ELSE
1615         CALL PUSHINTEGER4(im)
1616         im = imin
1617         CALL PUSHCONTROL1B(1)
1618       END IF
1619       DO k=kts,ktf
1620         vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte))
1621         IF (vw .LT. 0.) THEN
1622           CALL PUSHREAL8(vb)
1623           vb = 0.
1624           CALL PUSHCONTROL1B(0)
1625         ELSE
1626           CALL PUSHREAL8(vb)
1627           vb = vw
1628           CALL PUSHCONTROL1B(1)
1629         END IF
1630       END DO
1631     END DO
1632     CALL PUSHINTEGER4(i - 1)
1633     CALL PUSHINTEGER4(ad_from48)
1634     CALL PUSHCONTROL1B(1)
1635   ELSE
1636     CALL PUSHCONTROL1B(0)
1637   END IF
1638 !-------------------- vertical advection
1639 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
1640 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
1641 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
1642 !  this is what we need, so leave unchanged in advect_u
1643   i_start = its
1644   i_end = ite
1645   CALL PUSHINTEGER4(j_start)
1646   j_start = jts
1647   IF (jte .GT. jde - 1) THEN
1648     j_end = jde - 1
1649   ELSE
1650     j_end = jte
1651   END IF
1652 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1653 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1654   IF (config_flags%open_ys .OR. specified) THEN
1655     IF (ids + 1 .LT. its) THEN
1656       i_start = its
1657     ELSE
1658       i_start = ids + 1
1659     END IF
1660   END IF
1661   IF (config_flags%open_ye .OR. specified) THEN
1662     IF (ide - 1 .GT. ite) THEN
1663       i_end = ite
1664     ELSE
1665       i_end = ide - 1
1666     END IF
1667   END IF
1668   IF (config_flags%periodic_x) i_start = its
1669   IF (config_flags%periodic_x) i_end = ite
1670   IF (vert_order .EQ. 6) THEN
1671     DO j=j_start,j_end
1672       DO k=kts+3,ktf-2
1673         CALL PUSHINTEGER4(i)
1674       END DO
1675       CALL PUSHINTEGER4(i)
1676       CALL PUSHINTEGER4(k)
1677     END DO
1678     vfluxb = 0.0
1679     DO j=j_end,j_start,-1
1680       DO k=ktf,kts,-1
1681         DO i=i_end,i_start,-1
1682           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
1683           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
1684         END DO
1685       END DO
1686       CALL POPINTEGER4(k)
1687       DO i=i_end,i_start,-1
1688         k = ktf
1689         temp31b46 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i&
1690 &          , k)
1691         temp31b47 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1692         romb(i, k, j) = romb(i, k, j) + temp31b46
1693         romb(i-1, k, j) = romb(i-1, k, j) + temp31b46
1694         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp31b47
1695         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp31b47
1696         vfluxb(i, k) = 0.0
1697         k = ktf - 1
1698         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1699         temp31b48 = vel*vfluxb(i, k)/12.0
1700         velb = (7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))*&
1701 &          vfluxb(i, k)/12.0
1702         ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b48
1703         ub0(i, k-1, j) = ub0(i, k-1, j) + 7.*temp31b48
1704         ub0(i, k+1, j) = ub0(i, k+1, j) - temp31b48
1705         ub0(i, k-2, j) = ub0(i, k-2, j) - temp31b48
1706         vfluxb(i, k) = 0.0
1707         romb(i, k, j) = romb(i, k, j) + 0.5*velb
1708         romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1709         k = kts + 2
1710         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1711         temp31b49 = vel*vfluxb(i, k)/12.0
1712         velb = (7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))*&
1713 &          vfluxb(i, k)/12.0
1714         ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b49
1715         ub0(i, k-1, j) = ub0(i, k-1, j) + 7.*temp31b49
1716         ub0(i, k+1, j) = ub0(i, k+1, j) - temp31b49
1717         ub0(i, k-2, j) = ub0(i, k-2, j) - temp31b49
1718         vfluxb(i, k) = 0.0
1719         romb(i, k, j) = romb(i, k, j) + 0.5*velb
1720         romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1721         k = kts + 1
1722         temp31b50 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i&
1723 &          , k)
1724         temp31b51 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1725         romb(i, k, j) = romb(i, k, j) + temp31b50
1726         romb(i-1, k, j) = romb(i-1, k, j) + temp31b50
1727         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp31b51
1728         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp31b51
1729         vfluxb(i, k) = 0.0
1730       END DO
1731       CALL POPINTEGER4(i)
1732       DO k=ktf-2,kts+3,-1
1733         DO i=i_end,i_start,-1
1734           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1735           temp31b45 = vel*vfluxb(i, k)/60.0
1736           velb = (37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1, j)+u(i, k-&
1737 &            2, j))+u(i, k+2, j)+u(i, k-3, j))*vfluxb(i, k)/60.0
1738           ub0(i, k, j) = ub0(i, k, j) + 37.*temp31b45
1739           ub0(i, k-1, j) = ub0(i, k-1, j) + 37.*temp31b45
1740           ub0(i, k+1, j) = ub0(i, k+1, j) - 8.*temp31b45
1741           ub0(i, k-2, j) = ub0(i, k-2, j) - 8.*temp31b45
1742           ub0(i, k+2, j) = ub0(i, k+2, j) + temp31b45
1743           ub0(i, k-3, j) = ub0(i, k-3, j) + temp31b45
1744           vfluxb(i, k) = 0.0
1745           romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1746           romb(i, k, j) = romb(i, k, j) + 0.5*velb
1747         END DO
1748         CALL POPINTEGER4(i)
1749       END DO
1750     END DO
1751   ELSE IF (vert_order .EQ. 5) THEN
1752     DO j=j_start,j_end
1753       DO k=kts+3,ktf-2
1754         CALL PUSHINTEGER4(i)
1755       END DO
1756       CALL PUSHINTEGER4(i)
1757       CALL PUSHINTEGER4(k)
1758     END DO
1759     vfluxb = 0.0
1760     DO j=j_end,j_start,-1
1761       DO k=ktf,kts,-1
1762         DO i=i_end,i_start,-1
1763           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
1764           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
1765         END DO
1766       END DO
1767       CALL POPINTEGER4(k)
1768       DO i=i_end,i_start,-1
1769         k = ktf
1770         temp43b = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, &
1771 &          k)
1772         temp43b0 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1773         romb(i, k, j) = romb(i, k, j) + temp43b
1774         romb(i-1, k, j) = romb(i-1, k, j) + temp43b
1775         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp43b0
1776         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp43b0
1777         vfluxb(i, k) = 0.0
1778         k = ktf - 1
1779         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1780         temp39 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, &
1781 &          j))
1782         temp42 = SIGN(1., -vel)
1783         temp41 = temp42/12.0
1784         temp40 = SIGN(1, time_step)
1785         temp39b = vel*vfluxb(i, k)
1786         temp39b0 = temp39b/12.0
1787         temp39b1 = temp40*temp41*temp39b
1788         velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))&
1789 &          /12.0+temp40*(temp41*temp39))*vfluxb(i, k)
1790         ub0(i, k, j) = ub0(i, k, j) + 7.*temp39b0 - 3.*temp39b1
1791         ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp39b1 + 7.*temp39b0
1792         ub0(i, k+1, j) = ub0(i, k+1, j) + temp39b1 - temp39b0
1793         ub0(i, k-2, j) = ub0(i, k-2, j) - temp39b1 - temp39b0
1794         vfluxb(i, k) = 0.0
1795         romb(i, k, j) = romb(i, k, j) + 0.5*velb
1796         romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1797         k = kts + 2
1798         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1799         temp35 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, &
1800 &          j))
1801         temp38 = SIGN(1., -vel)
1802         temp37 = temp38/12.0
1803         temp36 = SIGN(1, time_step)
1804         temp35b = vel*vfluxb(i, k)
1805         temp35b0 = temp35b/12.0
1806         temp35b1 = temp36*temp37*temp35b
1807         velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))&
1808 &          /12.0+temp36*(temp37*temp35))*vfluxb(i, k)
1809         ub0(i, k, j) = ub0(i, k, j) + 7.*temp35b0 - 3.*temp35b1
1810         ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp35b1 + 7.*temp35b0
1811         ub0(i, k+1, j) = ub0(i, k+1, j) + temp35b1 - temp35b0
1812         ub0(i, k-2, j) = ub0(i, k-2, j) - temp35b1 - temp35b0
1813         vfluxb(i, k) = 0.0
1814         romb(i, k, j) = romb(i, k, j) + 0.5*velb
1815         romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1816         k = kts + 1
1817         temp35b2 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i&
1818 &          , k)
1819         temp35b3 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1820         romb(i, k, j) = romb(i, k, j) + temp35b2
1821         romb(i-1, k, j) = romb(i-1, k, j) + temp35b2
1822         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp35b3
1823         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp35b3
1824         vfluxb(i, k) = 0.0
1825       END DO
1826       CALL POPINTEGER4(i)
1827       DO k=ktf-2,kts+3,-1
1828         DO i=i_end,i_start,-1
1829           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1830           temp31 = u(i, k+2, j) - u(i, k-3, j) + 10.*(u(i, k, j)-u(i, k-&
1831 &            1, j)) - 5.*(u(i, k+1, j)-u(i, k-2, j))
1832           temp34 = SIGN(1., -vel)
1833           temp33 = temp34/60.0
1834           temp32 = SIGN(1, time_step)
1835           temp31b52 = vel*vfluxb(i, k)
1836           temp31b53 = temp31b52/60.0
1837           temp31b54 = -(temp32*temp33*temp31b52)
1838           velb = ((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1, j)+u(i, k&
1839 &            -2, j))+u(i, k+2, j)+u(i, k-3, j))/60.0-temp32*(temp33*&
1840 &            temp31))*vfluxb(i, k)
1841           ub0(i, k, j) = ub0(i, k, j) + 10.*temp31b54 + 37.*temp31b53
1842           ub0(i, k-1, j) = ub0(i, k-1, j) + 37.*temp31b53 - 10.*&
1843 &            temp31b54
1844           ub0(i, k+1, j) = ub0(i, k+1, j) - 5.*temp31b54 - 8.*temp31b53
1845           ub0(i, k-2, j) = ub0(i, k-2, j) + 5.*temp31b54 - 8.*temp31b53
1846           ub0(i, k+2, j) = ub0(i, k+2, j) + temp31b54 + temp31b53
1847           ub0(i, k-3, j) = ub0(i, k-3, j) + temp31b53 - temp31b54
1848           vfluxb(i, k) = 0.0
1849           romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1850           romb(i, k, j) = romb(i, k, j) + 0.5*velb
1851         END DO
1852         CALL POPINTEGER4(i)
1853       END DO
1854     END DO
1855   ELSE IF (vert_order .EQ. 4) THEN
1856     DO j=j_start,j_end
1857       DO k=kts+2,ktf-1
1858         CALL PUSHINTEGER4(i)
1859       END DO
1860       CALL PUSHINTEGER4(i)
1861       CALL PUSHINTEGER4(k)
1862     END DO
1863     vfluxb = 0.0
1864     DO j=j_end,j_start,-1
1865       DO k=ktf,kts,-1
1866         DO i=i_end,i_start,-1
1867           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
1868           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
1869         END DO
1870       END DO
1871       CALL POPINTEGER4(k)
1872       DO i=i_end,i_start,-1
1873         k = ktf
1874         temp43b2 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i&
1875 &          , k)
1876         temp43b3 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1877         romb(i, k, j) = romb(i, k, j) + temp43b2
1878         romb(i-1, k, j) = romb(i-1, k, j) + temp43b2
1879         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp43b3
1880         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp43b3
1881         vfluxb(i, k) = 0.0
1882         k = kts + 1
1883         temp43b4 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i&
1884 &          , k)
1885         temp43b5 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1886         romb(i, k, j) = romb(i, k, j) + temp43b4
1887         romb(i-1, k, j) = romb(i-1, k, j) + temp43b4
1888         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp43b5
1889         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp43b5
1890         vfluxb(i, k) = 0.0
1891       END DO
1892       CALL POPINTEGER4(i)
1893       DO k=ktf-1,kts+2,-1
1894         DO i=i_end,i_start,-1
1895           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1896           temp43b1 = vel*vfluxb(i, k)/12.0
1897           velb = (7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j)&
1898 &            )*vfluxb(i, k)/12.0
1899           ub0(i, k, j) = ub0(i, k, j) + 7.*temp43b1
1900           ub0(i, k-1, j) = ub0(i, k-1, j) + 7.*temp43b1
1901           ub0(i, k+1, j) = ub0(i, k+1, j) - temp43b1
1902           ub0(i, k-2, j) = ub0(i, k-2, j) - temp43b1
1903           vfluxb(i, k) = 0.0
1904           romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1905           romb(i, k, j) = romb(i, k, j) + 0.5*velb
1906         END DO
1907         CALL POPINTEGER4(i)
1908       END DO
1909     END DO
1910   ELSE IF (vert_order .EQ. 3) THEN
1911     DO j=j_start,j_end
1912       DO k=kts+2,ktf-1
1913         CALL PUSHINTEGER4(i)
1914       END DO
1915       CALL PUSHINTEGER4(i)
1916       CALL PUSHINTEGER4(k)
1917     END DO
1918     vfluxb = 0.0
1919     DO j=j_end,j_start,-1
1920       DO k=ktf,kts,-1
1921         DO i=i_end,i_start,-1
1922           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
1923           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
1924         END DO
1925       END DO
1926       CALL POPINTEGER4(k)
1927       DO i=i_end,i_start,-1
1928         k = ktf
1929         temp47b = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, &
1930 &          k)
1931         temp47b0 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1932         romb(i, k, j) = romb(i, k, j) + temp47b
1933         romb(i-1, k, j) = romb(i-1, k, j) + temp47b
1934         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp47b0
1935         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp47b0
1936         vfluxb(i, k) = 0.0
1937         k = kts + 1
1938         temp47b1 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i&
1939 &          , k)
1940         temp47b2 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1941         romb(i, k, j) = romb(i, k, j) + temp47b1
1942         romb(i-1, k, j) = romb(i-1, k, j) + temp47b1
1943         ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp47b2
1944         ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp47b2
1945         vfluxb(i, k) = 0.0
1946       END DO
1947       CALL POPINTEGER4(i)
1948       DO k=ktf-1,kts+2,-1
1949         DO i=i_end,i_start,-1
1950           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1951           temp43 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1&
1952 &            , j))
1953           temp46 = SIGN(1., -vel)
1954           temp45 = temp46/12.0
1955           temp44 = SIGN(1, time_step)
1956           temp43b6 = vel*vfluxb(i, k)
1957           temp43b7 = temp43b6/12.0
1958           temp43b8 = temp44*temp45*temp43b6
1959           velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j&
1960 &            ))/12.0+temp44*(temp45*temp43))*vfluxb(i, k)
1961           ub0(i, k, j) = ub0(i, k, j) + 7.*temp43b7 - 3.*temp43b8
1962           ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp43b8 + 7.*temp43b7
1963           ub0(i, k+1, j) = ub0(i, k+1, j) + temp43b8 - temp43b7
1964           ub0(i, k-2, j) = ub0(i, k-2, j) - temp43b8 - temp43b7
1965           vfluxb(i, k) = 0.0
1966           romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
1967           romb(i, k, j) = romb(i, k, j) + 0.5*velb
1968         END DO
1969         CALL POPINTEGER4(i)
1970       END DO
1971     END DO
1972   ELSE IF (vert_order .EQ. 2) THEN
1973     DO j=j_start,j_end
1974       DO k=kts+1,ktf
1975         CALL PUSHINTEGER4(i)
1976       END DO
1977       DO k=kts,ktf
1978         CALL PUSHINTEGER4(i)
1979       END DO
1980     END DO
1981     vfluxb = 0.0
1982     DO j=j_end,j_start,-1
1983       DO k=ktf,kts,-1
1984         DO i=i_end,i_start,-1
1985           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
1986           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
1987         END DO
1988         CALL POPINTEGER4(i)
1989       END DO
1990       DO k=ktf,kts+1,-1
1991         DO i=i_end,i_start,-1
1992           temp47b3 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(&
1993 &            i, k)
1994           temp47b4 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
1995           romb(i, k, j) = romb(i, k, j) + temp47b3
1996           romb(i-1, k, j) = romb(i-1, k, j) + temp47b3
1997           ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp47b4
1998           ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp47b4
1999           vfluxb(i, k) = 0.0
2000         END DO
2001         CALL POPINTEGER4(i)
2002       END DO
2003     END DO
2004   END IF
2005   CALL POPINTEGER4(j_start)
2006   CALL POPCONTROL1B(branch)
2007   IF (branch .NE. 0) THEN
2008     CALL POPINTEGER4(ad_from48)
2009     CALL POPINTEGER4(ad_to48)
2010     DO i=ad_to48,ad_from48,-1
2011       DO k=ktf,kts,-1
2012         dvm = rv(ip, k, jte) - rv(ip, k, jte-1)
2013         dvp = rv(im, k, jte) - rv(im, k, jte-1)
2014         temp31b43 = -(mrdy*tendencyb(i, k, jte-1))
2015         temp31b44 = 0.5*u(i, k, jte-1)*temp31b43
2016         vbb = (u_old(i, k, jte-1)-u_old(i, k, jte-2))*temp31b43
2017         u_oldb(i, k, jte-1) = u_oldb(i, k, jte-1) + vb*temp31b43
2018         u_oldb(i, k, jte-2) = u_oldb(i, k, jte-2) - vb*temp31b43
2019         ub0(i, k, jte-1) = ub0(i, k, jte-1) + 0.5*(dvm+dvp)*temp31b43
2020         dvmb = temp31b44
2021         dvpb = temp31b44
2022         rvb(im, k, jte) = rvb(im, k, jte) + dvpb
2023         rvb(im, k, jte-1) = rvb(im, k, jte-1) - dvpb
2024         rvb(ip, k, jte) = rvb(ip, k, jte) + dvmb
2025         rvb(ip, k, jte-1) = rvb(ip, k, jte-1) - dvmb
2026         CALL POPCONTROL1B(branch)
2027         IF (branch .EQ. 0) THEN
2028           CALL POPREAL8(vb)
2029           vwb = 0.0
2030         ELSE
2031           CALL POPREAL8(vb)
2032           vwb = vbb
2033         END IF
2034         rvb(ip, k, jte) = rvb(ip, k, jte) + 0.5*vwb
2035         rvb(im, k, jte) = rvb(im, k, jte) + 0.5*vwb
2036       END DO
2037       CALL POPCONTROL1B(branch)
2038       IF (branch .EQ. 0) THEN
2039         CALL POPINTEGER4(im)
2040       ELSE
2041         CALL POPINTEGER4(im)
2042       END IF
2043       CALL POPCONTROL1B(branch)
2044       IF (branch .EQ. 0) THEN
2045         CALL POPINTEGER4(ip)
2046       ELSE
2047         CALL POPINTEGER4(ip)
2048       END IF
2049       CALL POPREAL8(mrdy)
2050     END DO
2051     CALL POPINTEGER4(i)
2052   END IF
2053   CALL POPCONTROL1B(branch)
2054   IF (branch .EQ. 0) THEN
2055     CALL POPINTEGER4(ad_from47)
2056     CALL POPINTEGER4(ad_to47)
2057     DO i=ad_to47,ad_from47,-1
2058       DO k=ktf,kts,-1
2059         dvm = rv(ip, k, jts+1) - rv(ip, k, jts)
2060         dvp = rv(im, k, jts+1) - rv(im, k, jts)
2061         temp31b41 = -(mrdy*tendencyb(i, k, jts))
2062         temp31b42 = 0.5*u(i, k, jts)*temp31b41
2063         vbb = (u_old(i, k, jts+1)-u_old(i, k, jts))*temp31b41
2064         u_oldb(i, k, jts+1) = u_oldb(i, k, jts+1) + vb*temp31b41
2065         u_oldb(i, k, jts) = u_oldb(i, k, jts) - vb*temp31b41
2066         ub0(i, k, jts) = ub0(i, k, jts) + 0.5*(dvm+dvp)*temp31b41
2067         dvmb = temp31b42
2068         dvpb = temp31b42
2069         rvb(im, k, jts+1) = rvb(im, k, jts+1) + dvpb
2070         rvb(im, k, jts) = rvb(im, k, jts) - dvpb
2071         rvb(ip, k, jts+1) = rvb(ip, k, jts+1) + dvmb
2072         rvb(ip, k, jts) = rvb(ip, k, jts) - dvmb
2073         CALL POPCONTROL1B(branch)
2074         IF (branch .EQ. 0) THEN
2075           CALL POPREAL8(vb)
2076           vwb = 0.0
2077         ELSE
2078           CALL POPREAL8(vb)
2079           vwb = vbb
2080         END IF
2081         rvb(ip, k, jts) = rvb(ip, k, jts) + 0.5*vwb
2082         rvb(im, k, jts) = rvb(im, k, jts) + 0.5*vwb
2083       END DO
2084       CALL POPCONTROL1B(branch)
2085       IF (branch .EQ. 0) THEN
2086         CALL POPINTEGER4(im)
2087       ELSE
2088         CALL POPINTEGER4(im)
2089       END IF
2090       CALL POPCONTROL1B(branch)
2091       IF (branch .EQ. 0) THEN
2092         CALL POPINTEGER4(ip)
2093       ELSE
2094         CALL POPINTEGER4(ip)
2095       END IF
2096       CALL POPREAL8(mrdy)
2097     END DO
2098     CALL POPINTEGER4(i)
2099   END IF
2100   CALL POPCONTROL1B(branch)
2101   IF (branch .NE. 0) THEN
2102     CALL POPINTEGER4(ad_from46)
2103     CALL POPINTEGER4(ad_to46)
2104     DO j=ad_to46,ad_from46,-1
2105       DO k=ktf,kts,-1
2106         temp31b40 = -(rdx*tendencyb(ite, k, j))
2107         ubb = (u_old(ite, k, j)-u_old(ite-1, k, j))*temp31b40
2108         u_oldb(ite, k, j) = u_oldb(ite, k, j) + ub*temp31b40
2109         u_oldb(ite-1, k, j) = u_oldb(ite-1, k, j) - ub*temp31b40
2110         CALL POPCONTROL1B(branch)
2111         IF (branch .EQ. 0) THEN
2112           CALL POPREAL8(ub)
2113         ELSE
2114           CALL POPREAL8(ub)
2115           rub(ite, k, j) = rub(ite, k, j) + ubb
2116           mutb(ite-1, j) = mutb(ite-1, j) + cb*ubb
2117         END IF
2118       END DO
2119     END DO
2120     CALL POPINTEGER4(j_start)
2121   END IF
2122   CALL POPCONTROL1B(branch)
2123   IF (branch .EQ. 0) THEN
2124     CALL POPINTEGER4(ad_from45)
2125     CALL POPINTEGER4(ad_to45)
2126     DO j=ad_to45,ad_from45,-1
2127       DO k=ktf,kts,-1
2128         temp31b39 = -(rdx*tendencyb(its, k, j))
2129         ubb = (u_old(its+1, k, j)-u_old(its, k, j))*temp31b39
2130         u_oldb(its+1, k, j) = u_oldb(its+1, k, j) + ub*temp31b39
2131         u_oldb(its, k, j) = u_oldb(its, k, j) - ub*temp31b39
2132         CALL POPCONTROL1B(branch)
2133         IF (branch .EQ. 0) THEN
2134           CALL POPREAL8(ub)
2135         ELSE
2136           CALL POPREAL8(ub)
2137           rub(its, k, j) = rub(its, k, j) + ubb
2138           mutb(its, j) = mutb(its, j) - cb*ubb
2139         END IF
2140       END DO
2141     END DO
2142     CALL POPINTEGER4(j_start)
2143   END IF
2144   CALL POPCONTROL3B(branch)
2145   IF (branch .LT. 3) THEN
2146     IF (branch .EQ. 0) THEN
2147       fqxb = 0.0
2148       CALL POPINTEGER4(ad_from44)
2149       CALL POPINTEGER4(ad_to44)
2150       DO j=ad_to44,ad_from44,-1
2151         DO k=ktf,kts,-1
2152           CALL POPINTEGER4(ad_from43)
2153           CALL POPINTEGER4(ad_to43)
2154           DO i=ad_to43,ad_from43,-1
2155             mrdx = msfux(i, j)*rdx
2156             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
2157             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
2158           END DO
2159           CALL POPINTEGER4(i)
2160         END DO
2161         CALL POPCONTROL1B(branch)
2162         IF (branch .NE. 0) THEN
2163           DO k=ktf,kts,-1
2164             i = ide - 1
2165             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2166             temp31b38 = vel*fqxb(i, k)/12.0
2167             velb = (7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, &
2168 &              j))*fqxb(i, k)/12.0
2169             ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b38
2170             ub0(i-1, k, j) = ub0(i-1, k, j) + 7.*temp31b38
2171             ub0(i+1, k, j) = ub0(i+1, k, j) - temp31b38
2172             ub0(i-2, k, j) = ub0(i-2, k, j) - temp31b38
2173             fqxb(i, k) = 0.0
2174             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2175             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2176             CALL POPINTEGER4(i)
2177           END DO
2178           CALL POPCONTROL1B(branch)
2179           IF (branch .NE. 0) THEN
2180             DO k=ktf,kts,-1
2181               temp31b36 = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k)
2182               temp31b37 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2183               rub(i, k, j) = rub(i, k, j) + temp31b36
2184               rub(i-1, k, j) = rub(i-1, k, j) + temp31b36
2185               ub0(i-1, k, j) = ub0(i-1, k, j) + temp31b37
2186               ubb = temp31b37
2187               fqxb(i, k) = 0.0
2188               CALL POPCONTROL1B(branch)
2189               IF (branch .EQ. 0) THEN
2190                 ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2191                 ubb = 0.0
2192               END IF
2193               CALL POPREAL8(ub)
2194               ub0(i, k, j) = ub0(i, k, j) + ubb
2195             END DO
2196             CALL POPINTEGER4(i)
2197           END IF
2198         END IF
2199         CALL POPCONTROL1B(branch)
2200         IF (branch .EQ. 0) THEN
2201           DO k=ktf,kts,-1
2202             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2203             temp31b35 = vel*fqxb(i, k)/12.0
2204             velb = (7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, &
2205 &              j))*fqxb(i, k)/12.0
2206             ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b35
2207             ub0(i-1, k, j) = ub0(i-1, k, j) + 7.*temp31b35
2208             ub0(i+1, k, j) = ub0(i+1, k, j) - temp31b35
2209             ub0(i-2, k, j) = ub0(i-2, k, j) - temp31b35
2210             fqxb(i, k) = 0.0
2211             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2212             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2213           END DO
2214           CALL POPINTEGER4(i)
2215           CALL POPCONTROL1B(branch)
2216           IF (branch .EQ. 0) THEN
2217             DO k=ktf,kts,-1
2218               temp31b33 = 0.25*(u(i, k, j)+ub)*fqxb(i, k)
2219               temp31b34 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2220               rub(i, k, j) = rub(i, k, j) + temp31b33
2221               rub(i-1, k, j) = rub(i-1, k, j) + temp31b33
2222               ub0(i, k, j) = ub0(i, k, j) + temp31b34
2223               ubb = temp31b34
2224               fqxb(i, k) = 0.0
2225               CALL POPCONTROL1B(branch)
2226               IF (branch .EQ. 0) THEN
2227                 ub0(i, k, j) = ub0(i, k, j) + ubb
2228                 ubb = 0.0
2229               END IF
2230               CALL POPREAL8(ub)
2231               ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2232             END DO
2233             CALL POPINTEGER4(i)
2234           END IF
2235         END IF
2236         DO k=ktf,kts,-1
2237           DO i=i_end_f,i_start_f,-1
2238             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2239             temp31b32 = vel*fqxb(i, k)/60.0
2240             velb = (37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, j)+u(i-2&
2241 &              , k, j))+u(i+2, k, j)+u(i-3, k, j))*fqxb(i, k)/60.0
2242             ub0(i, k, j) = ub0(i, k, j) + 37.*temp31b32
2243             ub0(i-1, k, j) = ub0(i-1, k, j) + 37.*temp31b32
2244             ub0(i+1, k, j) = ub0(i+1, k, j) - 8.*temp31b32
2245             ub0(i-2, k, j) = ub0(i-2, k, j) - 8.*temp31b32
2246             ub0(i+2, k, j) = ub0(i+2, k, j) + temp31b32
2247             ub0(i-3, k, j) = ub0(i-3, k, j) + temp31b32
2248             fqxb(i, k) = 0.0
2249             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2250             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2251           END DO
2252           CALL POPINTEGER4(i)
2253         END DO
2254       END DO
2255       fqyb = 0.0
2256       CALL POPINTEGER4(ad_from42)
2257       CALL POPINTEGER4(ad_to42)
2258       DO j=ad_to42,ad_from42,-1
2259         CALL POPINTEGER4(jp0)
2260         CALL POPINTEGER4(jp1)
2261         CALL POPCONTROL2B(branch)
2262         IF (branch .LT. 2) THEN
2263           IF (branch .EQ. 0) THEN
2264             DO k=ktf,kts,-1
2265               CALL POPINTEGER4(ad_from39)
2266               CALL POPINTEGER4(ad_to39)
2267               DO i=ad_to39,ad_from39,-1
2268                 mrdy = msfux(i, j-1)*rdy
2269                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
2270 &                  , j-1)
2271               END DO
2272             END DO
2273           ELSE
2274             DO k=ktf,kts,-1
2275               CALL POPINTEGER4(ad_from40)
2276               CALL POPINTEGER4(ad_to40)
2277               DO i=ad_to40,ad_from40,-1
2278                 mrdy = msfux(i, j-1)*rdy
2279                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
2280 &                  , j-1)
2281               END DO
2282             END DO
2283           END IF
2284         ELSE IF (branch .EQ. 2) THEN
2285           DO k=ktf,kts,-1
2286             CALL POPINTEGER4(ad_from41)
2287             CALL POPINTEGER4(ad_to41)
2288             DO i=ad_to41,ad_from41,-1
2289               mrdy = msfux(i, j-1)*rdy
2290               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
2291 &                -1)
2292               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
2293 &                -1)
2294             END DO
2295           END DO
2296         END IF
2297         CALL POPCONTROL3B(branch)
2298         IF (branch .LT. 3) THEN
2299           IF (branch .EQ. 0) THEN
2300             DO k=ktf,kts,-1
2301               CALL POPINTEGER4(ad_from34)
2302               CALL POPINTEGER4(ad_to34)
2303               DO i=ad_to34,ad_from34,-1
2304                 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2305                 temp31b25 = vel*fqyb(i, k, jp1)/60.0
2306                 velb = (37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i, k, j+1)+u&
2307 &                  (i, k, j-2))+u(i, k, j+2)+u(i, k, j-3))*fqyb(i, k, jp1&
2308 &                  )/60.0
2309                 ub0(i, k, j) = ub0(i, k, j) + 37.*temp31b25
2310                 ub0(i, k, j-1) = ub0(i, k, j-1) + 37.*temp31b25
2311                 ub0(i, k, j+1) = ub0(i, k, j+1) - 8.*temp31b25
2312                 ub0(i, k, j-2) = ub0(i, k, j-2) - 8.*temp31b25
2313                 ub0(i, k, j+2) = ub0(i, k, j+2) + temp31b25
2314                 ub0(i, k, j-3) = ub0(i, k, j-3) + temp31b25
2315                 fqyb(i, k, jp1) = 0.0
2316                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2317                 rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2318               END DO
2319             END DO
2320           ELSE IF (branch .EQ. 1) THEN
2321             DO k=ktf,kts,-1
2322               CALL POPINTEGER4(ad_from35)
2323               CALL POPINTEGER4(ad_to35)
2324               DO i=ad_to35,ad_from35,-1
2325                 temp31b26 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, &
2326 &                  jp1)
2327                 temp31b27 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, &
2328 &                  jp1)
2329                 rvb(i, k, j) = rvb(i, k, j) + temp31b26
2330                 rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b26
2331                 ub0(i, k, j) = ub0(i, k, j) + temp31b27
2332                 ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b27
2333                 fqyb(i, k, jp1) = 0.0
2334               END DO
2335             END DO
2336           ELSE
2337             DO k=ktf,kts,-1
2338               CALL POPINTEGER4(ad_from36)
2339               CALL POPINTEGER4(ad_to36)
2340               DO i=ad_to36,ad_from36,-1
2341                 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2342                 temp31b28 = vel*fqyb(i, k, jp1)/12.0
2343                 velb = (7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k&
2344 &                  , j-2))*fqyb(i, k, jp1)/12.0
2345                 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b28
2346                 ub0(i, k, j-1) = ub0(i, k, j-1) + 7.*temp31b28
2347                 ub0(i, k, j+1) = ub0(i, k, j+1) - temp31b28
2348                 ub0(i, k, j-2) = ub0(i, k, j-2) - temp31b28
2349                 fqyb(i, k, jp1) = 0.0
2350                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2351                 rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2352               END DO
2353             END DO
2354           END IF
2355         ELSE IF (branch .EQ. 3) THEN
2356           DO k=ktf,kts,-1
2357             CALL POPINTEGER4(ad_from37)
2358             CALL POPINTEGER4(ad_to37)
2359             DO i=ad_to37,ad_from37,-1
2360               temp31b29 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
2361               temp31b30 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, &
2362 &                jp1)
2363               rvb(i, k, j) = rvb(i, k, j) + temp31b29
2364               rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b29
2365               ub0(i, k, j) = ub0(i, k, j) + temp31b30
2366               ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b30
2367               fqyb(i, k, jp1) = 0.0
2368             END DO
2369           END DO
2370         ELSE IF (branch .EQ. 4) THEN
2371           DO k=ktf,kts,-1
2372             CALL POPINTEGER4(ad_from38)
2373             CALL POPINTEGER4(ad_to38)
2374             DO i=ad_to38,ad_from38,-1
2375               vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2376               temp31b31 = vel*fqyb(i, k, jp1)/12.0
2377               velb = (7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, &
2378 &                j-2))*fqyb(i, k, jp1)/12.0
2379               ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b31
2380               ub0(i, k, j-1) = ub0(i, k, j-1) + 7.*temp31b31
2381               ub0(i, k, j+1) = ub0(i, k, j+1) - temp31b31
2382               ub0(i, k, j-2) = ub0(i, k, j-2) - temp31b31
2383               fqyb(i, k, jp1) = 0.0
2384               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2385               rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2386             END DO
2387           END DO
2388         END IF
2389       END DO
2390     ELSE IF (branch .EQ. 1) THEN
2391       fqxb = 0.0
2392       CALL POPINTEGER4(ad_from9)
2393       CALL POPINTEGER4(ad_to9)
2394       DO j=ad_to9,ad_from9,-1
2395         DO k=ktf,kts,-1
2396           CALL POPINTEGER4(ad_from8)
2397           CALL POPINTEGER4(ad_to8)
2398           DO i=ad_to8,ad_from8,-1
2399             mrdx = msfux(i, j)*rdx
2400             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
2401             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
2402           END DO
2403           CALL POPINTEGER4(i)
2404         END DO
2405         CALL POPCONTROL1B(branch)
2406         IF (branch .NE. 0) THEN
2407           DO k=ktf,kts,-1
2408             i = ide - 1
2409             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2410             temp19 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1&
2411 &              , k, j))
2412             temp22 = SIGN(1., vel)
2413             temp21 = temp22/12.0
2414             temp20 = SIGN(1, time_step)
2415             temp19b1 = vel*fqxb(i, k)
2416             temp19b2 = temp19b1/12.0
2417             temp19b3 = temp20*temp21*temp19b1
2418             velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k&
2419 &              , j))/12.0+temp20*(temp21*temp19))*fqxb(i, k)
2420             ub0(i, k, j) = ub0(i, k, j) + 7.*temp19b2 - 3.*temp19b3
2421             ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp19b3 + 7.*temp19b2
2422             ub0(i+1, k, j) = ub0(i+1, k, j) + temp19b3 - temp19b2
2423             ub0(i-2, k, j) = ub0(i-2, k, j) - temp19b3 - temp19b2
2424             fqxb(i, k) = 0.0
2425             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2426             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2427             CALL POPINTEGER4(i)
2428           END DO
2429           CALL POPCONTROL1B(branch)
2430           IF (branch .NE. 0) THEN
2431             DO k=ktf,kts,-1
2432               temp19b = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k)
2433               temp19b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2434               rub(i, k, j) = rub(i, k, j) + temp19b
2435               rub(i-1, k, j) = rub(i-1, k, j) + temp19b
2436               ub0(i-1, k, j) = ub0(i-1, k, j) + temp19b0
2437               ubb = temp19b0
2438               fqxb(i, k) = 0.0
2439               CALL POPCONTROL1B(branch)
2440               IF (branch .EQ. 0) THEN
2441                 ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2442                 ubb = 0.0
2443               END IF
2444               CALL POPREAL8(ub)
2445               ub0(i, k, j) = ub0(i, k, j) + ubb
2446             END DO
2447             CALL POPINTEGER4(i)
2448           END IF
2449         END IF
2450         CALL POPCONTROL1B(branch)
2451         IF (branch .EQ. 0) THEN
2452           DO k=ktf,kts,-1
2453             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2454             temp15 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1&
2455 &              , k, j))
2456             temp18 = SIGN(1., vel)
2457             temp17 = temp18/12.0
2458             temp16 = SIGN(1, time_step)
2459             temp15b1 = vel*fqxb(i, k)
2460             temp15b2 = temp15b1/12.0
2461             temp15b3 = temp16*temp17*temp15b1
2462             velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k&
2463 &              , j))/12.0+temp16*(temp17*temp15))*fqxb(i, k)
2464             ub0(i, k, j) = ub0(i, k, j) + 7.*temp15b2 - 3.*temp15b3
2465             ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp15b3 + 7.*temp15b2
2466             ub0(i+1, k, j) = ub0(i+1, k, j) + temp15b3 - temp15b2
2467             ub0(i-2, k, j) = ub0(i-2, k, j) - temp15b3 - temp15b2
2468             fqxb(i, k) = 0.0
2469             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2470             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2471           END DO
2472           CALL POPINTEGER4(i)
2473           CALL POPCONTROL1B(branch)
2474           IF (branch .EQ. 0) THEN
2475             DO k=ktf,kts,-1
2476               temp15b = 0.25*(u(i, k, j)+ub)*fqxb(i, k)
2477               temp15b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2478               rub(i, k, j) = rub(i, k, j) + temp15b
2479               rub(i-1, k, j) = rub(i-1, k, j) + temp15b
2480               ub0(i, k, j) = ub0(i, k, j) + temp15b0
2481               ubb = temp15b0
2482               fqxb(i, k) = 0.0
2483               CALL POPCONTROL1B(branch)
2484               IF (branch .EQ. 0) THEN
2485                 ub0(i, k, j) = ub0(i, k, j) + ubb
2486                 ubb = 0.0
2487               END IF
2488               CALL POPREAL8(ub)
2489               ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2490             END DO
2491             CALL POPINTEGER4(i)
2492           END IF
2493         END IF
2494         DO k=ktf,kts,-1
2495           DO i=i_end_f,i_start_f,-1
2496             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2497             temp11 = u(i+2, k, j) - u(i-3, k, j) + 10.*(u(i, k, j)-u(i-1&
2498 &              , k, j)) - 5.*(u(i+1, k, j)-u(i-2, k, j))
2499             temp14 = SIGN(1., vel)
2500             temp13 = temp14/60.0
2501             temp12 = SIGN(1, time_step)
2502             temp11b = vel*fqxb(i, k)
2503             temp11b0 = temp11b/60.0
2504             temp11b1 = -(temp12*temp13*temp11b)
2505             velb = ((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, j)+u(i-&
2506 &              2, k, j))+u(i+2, k, j)+u(i-3, k, j))/60.0-temp12*(temp13*&
2507 &              temp11))*fqxb(i, k)
2508             ub0(i, k, j) = ub0(i, k, j) + 10.*temp11b1 + 37.*temp11b0
2509             ub0(i-1, k, j) = ub0(i-1, k, j) + 37.*temp11b0 - 10.*&
2510 &              temp11b1
2511             ub0(i+1, k, j) = ub0(i+1, k, j) - 5.*temp11b1 - 8.*temp11b0
2512             ub0(i-2, k, j) = ub0(i-2, k, j) + 5.*temp11b1 - 8.*temp11b0
2513             ub0(i+2, k, j) = ub0(i+2, k, j) + temp11b1 + temp11b0
2514             ub0(i-3, k, j) = ub0(i-3, k, j) + temp11b0 - temp11b1
2515             fqxb(i, k) = 0.0
2516             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2517             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2518           END DO
2519           CALL POPINTEGER4(i)
2520         END DO
2521       END DO
2522       fqyb = 0.0
2523       CALL POPINTEGER4(ad_from7)
2524       CALL POPINTEGER4(ad_to7)
2525       DO j=ad_to7,ad_from7,-1
2526         CALL POPINTEGER4(jp0)
2527         CALL POPINTEGER4(jp1)
2528         CALL POPCONTROL2B(branch)
2529         IF (branch .LT. 2) THEN
2530           IF (branch .EQ. 0) THEN
2531             DO k=ktf,kts,-1
2532               CALL POPINTEGER4(ad_from4)
2533               CALL POPINTEGER4(ad_to4)
2534               DO i=ad_to4,ad_from4,-1
2535                 mrdy = msfux(i, j-1)*rdy
2536                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
2537 &                  , j-1)
2538               END DO
2539             END DO
2540           ELSE
2541             DO k=ktf,kts,-1
2542               CALL POPINTEGER4(ad_from5)
2543               CALL POPINTEGER4(ad_to5)
2544               DO i=ad_to5,ad_from5,-1
2545                 mrdy = msfux(i, j-1)*rdy
2546                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
2547 &                  , j-1)
2548               END DO
2549             END DO
2550           END IF
2551         ELSE IF (branch .EQ. 2) THEN
2552           DO k=ktf,kts,-1
2553             CALL POPINTEGER4(ad_from6)
2554             CALL POPINTEGER4(ad_to6)
2555             DO i=ad_to6,ad_from6,-1
2556               mrdy = msfux(i, j-1)*rdy
2557               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
2558 &                -1)
2559               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
2560 &                -1)
2561             END DO
2562           END DO
2563         END IF
2564         CALL POPCONTROL3B(branch)
2565         IF (branch .LT. 3) THEN
2566           IF (branch .EQ. 0) THEN
2567             DO k=ktf,kts,-1
2568               CALL POPINTEGER4(ad_from)
2569               CALL POPINTEGER4(ad_to)
2570               DO i=ad_to,ad_from,-1
2571                 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2572                 temp = u(i, k, j+2) - u(i, k, j-3) + 10.*(u(i, k, j)-u(i&
2573 &                  , k, j-1)) - 5.*(u(i, k, j+1)-u(i, k, j-2))
2574                 temp2 = SIGN(1., vel)
2575                 temp1 = temp2/60.0
2576                 temp0 = SIGN(1, time_step)
2577                 tempb = vel*fqyb(i, k, jp1)
2578                 tempb0 = tempb/60.0
2579                 tempb1 = -(temp0*temp1*tempb)
2580                 velb = ((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i, k, j+1)+&
2581 &                  u(i, k, j-2))+u(i, k, j+2)+u(i, k, j-3))/60.0-temp0*(&
2582 &                  temp1*temp))*fqyb(i, k, jp1)
2583                 ub0(i, k, j) = ub0(i, k, j) + 10.*tempb1 + 37.*tempb0
2584                 ub0(i, k, j-1) = ub0(i, k, j-1) + 37.*tempb0 - 10.*&
2585 &                  tempb1
2586                 ub0(i, k, j+1) = ub0(i, k, j+1) - 5.*tempb1 - 8.*tempb0
2587                 ub0(i, k, j-2) = ub0(i, k, j-2) + 5.*tempb1 - 8.*tempb0
2588                 ub0(i, k, j+2) = ub0(i, k, j+2) + tempb1 + tempb0
2589                 ub0(i, k, j-3) = ub0(i, k, j-3) + tempb0 - tempb1
2590                 fqyb(i, k, jp1) = 0.0
2591                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2592                 rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2593               END DO
2594             END DO
2595           ELSE IF (branch .EQ. 1) THEN
2596             DO k=ktf,kts,-1
2597               CALL POPINTEGER4(ad_from0)
2598               CALL POPINTEGER4(ad_to0)
2599               DO i=ad_to0,ad_from0,-1
2600                 temp3b = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
2601                 temp3b0 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, &
2602 &                  jp1)
2603                 rvb(i, k, j) = rvb(i, k, j) + temp3b
2604                 rvb(i-1, k, j) = rvb(i-1, k, j) + temp3b
2605                 ub0(i, k, j) = ub0(i, k, j) + temp3b0
2606                 ub0(i, k, j-1) = ub0(i, k, j-1) + temp3b0
2607                 fqyb(i, k, jp1) = 0.0
2608               END DO
2609             END DO
2610           ELSE
2611             DO k=ktf,kts,-1
2612               CALL POPINTEGER4(ad_from1)
2613               CALL POPINTEGER4(ad_to1)
2614               DO i=ad_to1,ad_from1,-1
2615                 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2616                 temp3 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i&
2617 &                  , k, j-1))
2618                 temp6 = SIGN(1., vel)
2619                 temp5 = temp6/12.0
2620                 temp4 = SIGN(1, time_step)
2621                 temp3b1 = vel*fqyb(i, k, jp1)
2622                 temp3b2 = temp3b1/12.0
2623                 temp3b3 = temp4*temp5*temp3b1
2624                 velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, &
2625 &                  k, j-2))/12.0+temp4*(temp5*temp3))*fqyb(i, k, jp1)
2626                 ub0(i, k, j) = ub0(i, k, j) + 7.*temp3b2 - 3.*temp3b3
2627                 ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp3b3 + 7.*&
2628 &                  temp3b2
2629                 ub0(i, k, j+1) = ub0(i, k, j+1) + temp3b3 - temp3b2
2630                 ub0(i, k, j-2) = ub0(i, k, j-2) - temp3b3 - temp3b2
2631                 fqyb(i, k, jp1) = 0.0
2632                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2633                 rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2634               END DO
2635             END DO
2636           END IF
2637         ELSE IF (branch .EQ. 3) THEN
2638           DO k=ktf,kts,-1
2639             CALL POPINTEGER4(ad_from2)
2640             CALL POPINTEGER4(ad_to2)
2641             DO i=ad_to2,ad_from2,-1
2642               temp7b = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
2643               temp7b0 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1)
2644               rvb(i, k, j) = rvb(i, k, j) + temp7b
2645               rvb(i-1, k, j) = rvb(i-1, k, j) + temp7b
2646               ub0(i, k, j) = ub0(i, k, j) + temp7b0
2647               ub0(i, k, j-1) = ub0(i, k, j-1) + temp7b0
2648               fqyb(i, k, jp1) = 0.0
2649             END DO
2650           END DO
2651         ELSE IF (branch .EQ. 4) THEN
2652           DO k=ktf,kts,-1
2653             CALL POPINTEGER4(ad_from3)
2654             CALL POPINTEGER4(ad_to3)
2655             DO i=ad_to3,ad_from3,-1
2656               vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2657               temp7 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, &
2658 &                k, j-1))
2659               temp10 = SIGN(1., vel)
2660               temp9 = temp10/12.0
2661               temp8 = SIGN(1, time_step)
2662               temp7b1 = vel*fqyb(i, k, jp1)
2663               temp7b2 = temp7b1/12.0
2664               temp7b3 = temp8*temp9*temp7b1
2665               velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k&
2666 &                , j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, jp1)
2667               ub0(i, k, j) = ub0(i, k, j) + 7.*temp7b2 - 3.*temp7b3
2668               ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp7b3 + 7.*temp7b2
2669               ub0(i, k, j+1) = ub0(i, k, j+1) + temp7b3 - temp7b2
2670               ub0(i, k, j-2) = ub0(i, k, j-2) - temp7b3 - temp7b2
2671               fqyb(i, k, jp1) = 0.0
2672               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2673               rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2674             END DO
2675           END DO
2676         END IF
2677       END DO
2678     ELSE
2679       fqyb = 0.0
2680       CALL POPINTEGER4(ad_from18)
2681       CALL POPINTEGER4(ad_to18)
2682       DO j=ad_to18,ad_from18,-1
2683         CALL POPINTEGER4(jp0)
2684         CALL POPINTEGER4(jp1)
2685         CALL POPCONTROL2B(branch)
2686         IF (branch .LT. 2) THEN
2687           IF (branch .EQ. 0) THEN
2688             DO k=ktf,kts,-1
2689               CALL POPINTEGER4(ad_from15)
2690               CALL POPINTEGER4(ad_to15)
2691               DO i=ad_to15,ad_from15,-1
2692                 mrdy = msfux(i, j-1)*rdy
2693                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
2694 &                  , j-1)
2695               END DO
2696               CALL POPINTEGER4(i)
2697             END DO
2698           ELSE
2699             DO k=ktf,kts,-1
2700               CALL POPINTEGER4(ad_from16)
2701               CALL POPINTEGER4(ad_to16)
2702               DO i=ad_to16,ad_from16,-1
2703                 mrdy = msfux(i, j-1)*rdy
2704                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
2705 &                  , j-1)
2706               END DO
2707               CALL POPINTEGER4(i)
2708             END DO
2709           END IF
2710         ELSE IF (branch .EQ. 2) THEN
2711           DO k=ktf,kts,-1
2712             CALL POPINTEGER4(ad_from17)
2713             CALL POPINTEGER4(ad_to17)
2714             DO i=ad_to17,ad_from17,-1
2715               mrdy = msfux(i, j-1)*rdy
2716               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
2717 &                -1)
2718               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
2719 &                -1)
2720             END DO
2721             CALL POPINTEGER4(i)
2722           END DO
2723         END IF
2724         CALL POPCONTROL2B(branch)
2725         IF (branch .EQ. 0) THEN
2726           DO k=ktf,kts,-1
2727             CALL POPINTEGER4(ad_from12)
2728             CALL POPINTEGER4(ad_to12)
2729             DO i=ad_to12,ad_from12,-1
2730               temp23b4 = 0.25*(u(i, k, j_start)+u(i, k, j_start-1))*fqyb&
2731 &                (i, k, jp1)
2732               temp23b5 = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start))*&
2733 &                fqyb(i, k, jp1)
2734               rvb(i, k, j_start) = rvb(i, k, j_start) + temp23b4
2735               rvb(i-1, k, j_start) = rvb(i-1, k, j_start) + temp23b4
2736               ub0(i, k, j_start) = ub0(i, k, j_start) + temp23b5
2737               ub0(i, k, j_start-1) = ub0(i, k, j_start-1) + temp23b5
2738               fqyb(i, k, jp1) = 0.0
2739             END DO
2740             CALL POPINTEGER4(i)
2741           END DO
2742         ELSE IF (branch .EQ. 1) THEN
2743           DO k=ktf,kts,-1
2744             CALL POPINTEGER4(ad_from13)
2745             CALL POPINTEGER4(ad_to13)
2746             DO i=ad_to13,ad_from13,-1
2747               temp23b6 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
2748               temp23b7 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1&
2749 &                )
2750               rvb(i, k, j) = rvb(i, k, j) + temp23b6
2751               rvb(i-1, k, j) = rvb(i-1, k, j) + temp23b6
2752               ub0(i, k, j) = ub0(i, k, j) + temp23b7
2753               ub0(i, k, j-1) = ub0(i, k, j-1) + temp23b7
2754               fqyb(i, k, jp1) = 0.0
2755             END DO
2756             CALL POPINTEGER4(i)
2757           END DO
2758         ELSE
2759           DO k=ktf,kts,-1
2760             CALL POPINTEGER4(ad_from14)
2761             CALL POPINTEGER4(ad_to14)
2762             DO i=ad_to14,ad_from14,-1
2763               vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2764               temp23b8 = vel*fqyb(i, k, jp1)/12.0
2765               velb = (7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, &
2766 &                j-2))*fqyb(i, k, jp1)/12.0
2767               ub0(i, k, j) = ub0(i, k, j) + 7.*temp23b8
2768               ub0(i, k, j-1) = ub0(i, k, j-1) + 7.*temp23b8
2769               ub0(i, k, j+1) = ub0(i, k, j+1) - temp23b8
2770               ub0(i, k, j-2) = ub0(i, k, j-2) - temp23b8
2771               fqyb(i, k, jp1) = 0.0
2772               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2773               rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2774             END DO
2775             CALL POPINTEGER4(i)
2776           END DO
2777         END IF
2778       END DO
2779       fqxb = 0.0
2780       CALL POPINTEGER4(ad_from11)
2781       CALL POPINTEGER4(ad_to11)
2782       DO j=ad_to11,ad_from11,-1
2783         DO k=ktf,kts,-1
2784           CALL POPINTEGER4(ad_from10)
2785           CALL POPINTEGER4(ad_to10)
2786           DO i=ad_to10,ad_from10,-1
2787             mrdx = msfux(i, j)*rdx
2788             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
2789             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
2790           END DO
2791           CALL POPINTEGER4(i)
2792         END DO
2793         CALL POPCONTROL1B(branch)
2794         IF (branch .NE. 0) THEN
2795           DO k=ktf,kts,-1
2796             temp23b2 = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k)
2797             temp23b3 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2798             rub(i, k, j) = rub(i, k, j) + temp23b2
2799             rub(i-1, k, j) = rub(i-1, k, j) + temp23b2
2800             ub0(i-1, k, j) = ub0(i-1, k, j) + temp23b3
2801             ubb = temp23b3
2802             fqxb(i, k) = 0.0
2803             CALL POPCONTROL1B(branch)
2804             IF (branch .EQ. 0) THEN
2805               ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2806               ubb = 0.0
2807             END IF
2808             CALL POPREAL8(ub)
2809             ub0(i, k, j) = ub0(i, k, j) + ubb
2810           END DO
2811           CALL POPINTEGER4(i)
2812         END IF
2813         CALL POPCONTROL1B(branch)
2814         IF (branch .EQ. 0) THEN
2815           DO k=ktf,kts,-1
2816             temp23b0 = 0.25*(u(i, k, j)+ub)*fqxb(i, k)
2817             temp23b1 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2818             rub(i, k, j) = rub(i, k, j) + temp23b0
2819             rub(i-1, k, j) = rub(i-1, k, j) + temp23b0
2820             ub0(i, k, j) = ub0(i, k, j) + temp23b1
2821             ubb = temp23b1
2822             fqxb(i, k) = 0.0
2823             CALL POPCONTROL1B(branch)
2824             IF (branch .EQ. 0) THEN
2825               ub0(i, k, j) = ub0(i, k, j) + ubb
2826               ubb = 0.0
2827             END IF
2828             CALL POPREAL8(ub)
2829             ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2830           END DO
2831           CALL POPINTEGER4(i)
2832         END IF
2833         DO k=ktf,kts,-1
2834           DO i=i_end_f,i_start_f,-1
2835             vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
2836             temp23b = vel*fqxb(i, k)/12.0
2837             velb = (7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, &
2838 &              j))*fqxb(i, k)/12.0
2839             ub0(i, k, j) = ub0(i, k, j) + 7.*temp23b
2840             ub0(i-1, k, j) = ub0(i-1, k, j) + 7.*temp23b
2841             ub0(i+1, k, j) = ub0(i+1, k, j) - temp23b
2842             ub0(i-2, k, j) = ub0(i-2, k, j) - temp23b
2843             fqxb(i, k) = 0.0
2844             rub(i, k, j) = rub(i, k, j) + 0.5*velb
2845             rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
2846           END DO
2847           CALL POPINTEGER4(i)
2848         END DO
2849       END DO
2850     END IF
2851   ELSE IF (branch .EQ. 3) THEN
2852     fqyb = 0.0
2853     CALL POPINTEGER4(ad_from27)
2854     CALL POPINTEGER4(ad_to27)
2855     DO j=ad_to27,ad_from27,-1
2856       CALL POPINTEGER4(jp0)
2857       CALL POPINTEGER4(jp1)
2858       CALL POPCONTROL2B(branch)
2859       IF (branch .LT. 2) THEN
2860         IF (branch .EQ. 0) THEN
2861           DO k=ktf,kts,-1
2862             CALL POPINTEGER4(ad_from24)
2863             CALL POPINTEGER4(ad_to24)
2864             DO i=ad_to24,ad_from24,-1
2865               mrdy = msfux(i, j-1)*rdy
2866               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
2867 &                -1)
2868             END DO
2869             CALL POPINTEGER4(i)
2870           END DO
2871         ELSE
2872           DO k=ktf,kts,-1
2873             CALL POPINTEGER4(ad_from25)
2874             CALL POPINTEGER4(ad_to25)
2875             DO i=ad_to25,ad_from25,-1
2876               mrdy = msfux(i, j-1)*rdy
2877               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
2878 &                -1)
2879             END DO
2880             CALL POPINTEGER4(i)
2881           END DO
2882         END IF
2883       ELSE IF (branch .EQ. 2) THEN
2884         DO k=ktf,kts,-1
2885           CALL POPINTEGER4(ad_from26)
2886           CALL POPINTEGER4(ad_to26)
2887           DO i=ad_to26,ad_from26,-1
2888             mrdy = msfux(i, j-1)*rdy
2889             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
2890 &              )
2891             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
2892 &              )
2893           END DO
2894           CALL POPINTEGER4(i)
2895         END DO
2896       END IF
2897       CALL POPCONTROL2B(branch)
2898       IF (branch .EQ. 0) THEN
2899         DO k=ktf,kts,-1
2900           CALL POPINTEGER4(ad_from21)
2901           CALL POPINTEGER4(ad_to21)
2902           DO i=ad_to21,ad_from21,-1
2903             temp27b3 = 0.25*(u(i, k, j_start)+u(i, k, j_start-1))*fqyb(i&
2904 &              , k, jp1)
2905             temp27b4 = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start))*fqyb&
2906 &              (i, k, jp1)
2907             rvb(i, k, j_start) = rvb(i, k, j_start) + temp27b3
2908             rvb(i-1, k, j_start) = rvb(i-1, k, j_start) + temp27b3
2909             ub0(i, k, j_start) = ub0(i, k, j_start) + temp27b4
2910             ub0(i, k, j_start-1) = ub0(i, k, j_start-1) + temp27b4
2911             fqyb(i, k, jp1) = 0.0
2912           END DO
2913           CALL POPINTEGER4(i)
2914         END DO
2915       ELSE IF (branch .EQ. 1) THEN
2916         DO k=ktf,kts,-1
2917           CALL POPINTEGER4(ad_from22)
2918           CALL POPINTEGER4(ad_to22)
2919           DO i=ad_to22,ad_from22,-1
2920             temp27b5 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
2921             temp27b6 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1)
2922             rvb(i, k, j) = rvb(i, k, j) + temp27b5
2923             rvb(i-1, k, j) = rvb(i-1, k, j) + temp27b5
2924             ub0(i, k, j) = ub0(i, k, j) + temp27b6
2925             ub0(i, k, j-1) = ub0(i, k, j-1) + temp27b6
2926             fqyb(i, k, jp1) = 0.0
2927           END DO
2928           CALL POPINTEGER4(i)
2929         END DO
2930       ELSE
2931         DO k=ktf,kts,-1
2932           CALL POPINTEGER4(ad_from23)
2933           CALL POPINTEGER4(ad_to23)
2934           DO i=ad_to23,ad_from23,-1
2935             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
2936             temp27 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, k&
2937 &              , j-1))
2938             temp30 = SIGN(1., vel)
2939             temp29 = temp30/12.0
2940             temp28 = SIGN(1, time_step)
2941             temp27b7 = vel*fqyb(i, k, jp1)
2942             temp27b8 = temp27b7/12.0
2943             temp27b9 = temp28*temp29*temp27b7
2944             velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, j&
2945 &              -2))/12.0+temp28*(temp29*temp27))*fqyb(i, k, jp1)
2946             ub0(i, k, j) = ub0(i, k, j) + 7.*temp27b8 - 3.*temp27b9
2947             ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp27b9 + 7.*temp27b8
2948             ub0(i, k, j+1) = ub0(i, k, j+1) + temp27b9 - temp27b8
2949             ub0(i, k, j-2) = ub0(i, k, j-2) - temp27b9 - temp27b8
2950             fqyb(i, k, jp1) = 0.0
2951             rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
2952             rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
2953           END DO
2954           CALL POPINTEGER4(i)
2955         END DO
2956       END IF
2957     END DO
2958     fqxb = 0.0
2959     CALL POPINTEGER4(ad_from20)
2960     CALL POPINTEGER4(ad_to20)
2961     DO j=ad_to20,ad_from20,-1
2962       DO k=ktf,kts,-1
2963         CALL POPINTEGER4(ad_from19)
2964         CALL POPINTEGER4(ad_to19)
2965         DO i=ad_to19,ad_from19,-1
2966           mrdx = msfux(i, j)*rdx
2967           fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
2968           fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
2969         END DO
2970         CALL POPINTEGER4(i)
2971       END DO
2972       CALL POPCONTROL1B(branch)
2973       IF (branch .NE. 0) THEN
2974         DO k=ktf,kts,-1
2975           temp27b1 = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k)
2976           temp27b2 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2977           rub(i, k, j) = rub(i, k, j) + temp27b1
2978           rub(i-1, k, j) = rub(i-1, k, j) + temp27b1
2979           ub0(i-1, k, j) = ub0(i-1, k, j) + temp27b2
2980           ubb = temp27b2
2981           fqxb(i, k) = 0.0
2982           CALL POPCONTROL1B(branch)
2983           IF (branch .EQ. 0) THEN
2984             ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
2985             ubb = 0.0
2986           END IF
2987           CALL POPREAL8(ub)
2988           ub0(i, k, j) = ub0(i, k, j) + ubb
2989         END DO
2990         CALL POPINTEGER4(i)
2991       END IF
2992       CALL POPCONTROL1B(branch)
2993       IF (branch .EQ. 0) THEN
2994         DO k=ktf,kts,-1
2995           temp27b = 0.25*(u(i, k, j)+ub)*fqxb(i, k)
2996           temp27b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
2997           rub(i, k, j) = rub(i, k, j) + temp27b
2998           rub(i-1, k, j) = rub(i-1, k, j) + temp27b
2999           ub0(i, k, j) = ub0(i, k, j) + temp27b0
3000           ubb = temp27b0
3001           fqxb(i, k) = 0.0
3002           CALL POPCONTROL1B(branch)
3003           IF (branch .EQ. 0) THEN
3004             ub0(i, k, j) = ub0(i, k, j) + ubb
3005             ubb = 0.0
3006           END IF
3007           CALL POPREAL8(ub)
3008           ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
3009         END DO
3010         CALL POPINTEGER4(i)
3011       END IF
3012       DO k=ktf,kts,-1
3013         DO i=i_end_f,i_start_f,-1
3014           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
3015           temp23 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1, k&
3016 &            , j))
3017           temp26 = SIGN(1., vel)
3018           temp25 = temp26/12.0
3019           temp24 = SIGN(1, time_step)
3020           temp23b9 = vel*fqxb(i, k)
3021           temp23b10 = temp23b9/12.0
3022           temp23b11 = temp24*temp25*temp23b9
3023           velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, j&
3024 &            ))/12.0+temp24*(temp25*temp23))*fqxb(i, k)
3025           ub0(i, k, j) = ub0(i, k, j) + 7.*temp23b10 - 3.*temp23b11
3026           ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp23b11 + 7.*temp23b10
3027           ub0(i+1, k, j) = ub0(i+1, k, j) + temp23b11 - temp23b10
3028           ub0(i-2, k, j) = ub0(i-2, k, j) - temp23b11 - temp23b10
3029           fqxb(i, k) = 0.0
3030           rub(i, k, j) = rub(i, k, j) + 0.5*velb
3031           rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
3032         END DO
3033         CALL POPINTEGER4(i)
3034       END DO
3035     END DO
3036   ELSE IF (branch .EQ. 4) THEN
3037     CALL POPINTEGER4(ad_from33)
3038     CALL POPINTEGER4(ad_to33)
3039     DO j=ad_to33,ad_from33,-1
3040       DO k=ktf,kts,-1
3041         CALL POPINTEGER4(ad_from32)
3042         CALL POPINTEGER4(ad_to32)
3043         DO i=ad_to32,ad_from32,-1
3044           CALL POPCONTROL2B(branch)
3045           IF (branch .EQ. 0) THEN
3046             mrdy = msfux(i, j)*rdy
3047             temp31b20 = -(mrdy*0.25*tendencyb(i, k, j))
3048             temp31b21 = (u(i, k, j+1)+u(i, k, j))*temp31b20
3049             temp31b22 = (rv(i, k, j+1)+rv(i-1, k, j+1))*temp31b20
3050             temp31b23 = -((u(i, k, j)+u(i, k, j-1))*temp31b20)
3051             temp31b24 = -((rv(i, k, j)+rv(i-1, k, j))*temp31b20)
3052             rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b21
3053             rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + temp31b21
3054             ub0(i, k, j+1) = ub0(i, k, j+1) + temp31b22
3055             ub0(i, k, j) = ub0(i, k, j) + temp31b24 + temp31b22
3056             rvb(i, k, j) = rvb(i, k, j) + temp31b23
3057             rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b23
3058             ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b24
3059           ELSE IF (branch .EQ. 1) THEN
3060             mrdy = msfux(i, j)*rdy
3061             temp31b17 = mrdy*0.25*tendencyb(i, k, j)
3062             temp31b18 = (u(i, k, j)+u(i, k, j-1))*temp31b17
3063             temp31b19 = (rv(i, k, j)+rv(i-1, k, j))*temp31b17
3064             rvb(i, k, j) = rvb(i, k, j) + temp31b18
3065             rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b18
3066             ub0(i, k, j) = ub0(i, k, j) + temp31b19
3067             ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b19
3068           ELSE
3069             mrdy = msfux(i, j)*rdy
3070             temp31b14 = -(mrdy*0.25*tendencyb(i, k, j))
3071             temp31b15 = (u(i, k, j+1)+u(i, k, j))*temp31b14
3072             temp31b16 = (rv(i, k, j+1)+rv(i-1, k, j+1))*temp31b14
3073             rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b15
3074             rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + temp31b15
3075             ub0(i, k, j+1) = ub0(i, k, j+1) + temp31b16
3076             ub0(i, k, j) = ub0(i, k, j) + temp31b16
3077           END IF
3078         END DO
3079         CALL POPINTEGER4(i)
3080       END DO
3081     END DO
3082     CALL POPCONTROL1B(branch)
3083     IF (branch .EQ. 0) THEN
3084       CALL POPINTEGER4(ad_from31)
3085       CALL POPINTEGER4(ad_to31)
3086       DO j=ad_to31,ad_from31,-1
3087         DO k=ktf,kts,-1
3088           i = ide - 1
3089           mrdx = msfux(i, j)*rdx
3090           temp31b9 = -(mrdx*0.25*tendencyb(i, k, j))
3091           temp31b10 = (ub+u(i, k, j))*temp31b9
3092           temp31b11 = (ru(i+1, k, j)+ru(i, k, j))*temp31b9
3093           temp31b12 = -((u(i, k, j)+u(i-1, k, j))*temp31b9)
3094           temp31b13 = -((ru(i, k, j)+ru(i-1, k, j))*temp31b9)
3095           rub(i+1, k, j) = rub(i+1, k, j) + temp31b10
3096           rub(i, k, j) = rub(i, k, j) + temp31b12 + temp31b10
3097           ubb = temp31b11
3098           ub0(i, k, j) = ub0(i, k, j) + temp31b13 + temp31b11
3099           rub(i-1, k, j) = rub(i-1, k, j) + temp31b12
3100           ub0(i-1, k, j) = ub0(i-1, k, j) + temp31b13
3101           CALL POPCONTROL1B(branch)
3102           IF (branch .EQ. 0) THEN
3103             ub0(i, k, j) = ub0(i, k, j) + ubb
3104             ubb = 0.0
3105           END IF
3106           CALL POPREAL8(ub)
3107           ub0(i+1, k, j) = ub0(i+1, k, j) + ubb
3108         END DO
3109       END DO
3110     END IF
3111     CALL POPCONTROL1B(branch)
3112     IF (branch .EQ. 0) THEN
3113       CALL POPINTEGER4(ad_from30)
3114       CALL POPINTEGER4(ad_to30)
3115       DO j=ad_to30,ad_from30,-1
3116         DO k=ktf,kts,-1
3117           i = ids + 1
3118           mrdx = msfux(i, j)*rdx
3119           temp31b4 = -(mrdx*0.25*tendencyb(i, k, j))
3120           temp31b5 = (u(i+1, k, j)+u(i, k, j))*temp31b4
3121           temp31b6 = (ru(i+1, k, j)+ru(i, k, j))*temp31b4
3122           temp31b7 = -((u(i, k, j)+ub)*temp31b4)
3123           temp31b8 = -((ru(i, k, j)+ru(i-1, k, j))*temp31b4)
3124           rub(i+1, k, j) = rub(i+1, k, j) + temp31b5
3125           rub(i, k, j) = rub(i, k, j) + temp31b7 + temp31b5
3126           ub0(i+1, k, j) = ub0(i+1, k, j) + temp31b6
3127           ub0(i, k, j) = ub0(i, k, j) + temp31b8 + temp31b6
3128           rub(i-1, k, j) = rub(i-1, k, j) + temp31b7
3129           ubb = temp31b8
3130           CALL POPCONTROL1B(branch)
3131           IF (branch .EQ. 0) THEN
3132             ub0(i, k, j) = ub0(i, k, j) + ubb
3133             ubb = 0.0
3134           END IF
3135           CALL POPREAL8(ub)
3136           ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
3137         END DO
3138       END DO
3139     END IF
3140     CALL POPINTEGER4(ad_from29)
3141     CALL POPINTEGER4(ad_to29)
3142     DO j=ad_to29,ad_from29,-1
3143       DO k=ktf,kts,-1
3144         CALL POPINTEGER4(ad_from28)
3145         CALL POPINTEGER4(ad_to28)
3146         DO i=ad_to28,ad_from28,-1
3147           mrdx = msfux(i, j)*rdx
3148           temp31b = -(mrdx*0.25*tendencyb(i, k, j))
3149           temp31b0 = (u(i+1, k, j)+u(i, k, j))*temp31b
3150           temp31b1 = (ru(i+1, k, j)+ru(i, k, j))*temp31b
3151           temp31b2 = -((u(i, k, j)+u(i-1, k, j))*temp31b)
3152           temp31b3 = -((ru(i, k, j)+ru(i-1, k, j))*temp31b)
3153           rub(i+1, k, j) = rub(i+1, k, j) + temp31b0
3154           rub(i, k, j) = rub(i, k, j) + temp31b2 + temp31b0
3155           ub0(i+1, k, j) = ub0(i+1, k, j) + temp31b1
3156           ub0(i, k, j) = ub0(i, k, j) + temp31b3 + temp31b1
3157           rub(i-1, k, j) = rub(i-1, k, j) + temp31b2
3158           ub0(i-1, k, j) = ub0(i-1, k, j) + temp31b3
3159         END DO
3160       END DO
3161     END DO
3162   END IF
3163 END SUBROUTINE A_ADVECT_U
3164
3165 !        Generated by TAPENADE     (INRIA, Tropics team)
3166 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
3167 !
3168 !  Differentiation of advect_v in reverse (adjoint) mode:
3169 !   gradient     of useful results: rom tendency v v_old ru rv
3170 !                mut
3171 !   with respect to varying inputs: rom tendency v v_old ru rv
3172 !                mut
3173 !   RW status of diff variables: rom:incr tendency:in-out v:incr
3174 !                v_old:incr ru:incr rv:incr mut:incr
3175 SUBROUTINE A_ADVECT_V(v, vb0, v_old, v_oldb, tendency, tendencyb, ru, &
3176 &  rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux, &
3177 &  msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide&
3178 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
3179 &  , kts, kte)
3180   IMPLICIT NONE
3181 ! Input data
3182   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
3183   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3184 &  jme, kms, kme, its, ite, jts, jte, kts, kte
3185   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru&
3186 &  , rv, rom
3187   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: vb0, v_oldb, rub, rvb, &
3188 &  romb
3189   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
3190   REAL, DIMENSION(ims:ime, jms:jme) :: mutb
3191   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
3192   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb
3193   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
3194 &  msfvy, msftx, msfty
3195   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
3196   REAL, INTENT(IN) :: rdx, rdy
3197   INTEGER, INTENT(IN) :: time_step
3198 ! Local data
3199   INTEGER :: i, j, k, itf, jtf, ktf
3200   INTEGER :: i_start, i_end, j_start, j_end
3201   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
3202   INTEGER :: jmin, jmax, jp, jm, imin, imax
3203   REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
3204   REAL :: ubb, vbb, uwb, dupb, dumb
3205   REAL, DIMENSION(its:ite, kts:kte) :: vflux
3206   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
3207   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
3208   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb
3209   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
3210   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
3211   INTEGER :: horz_order
3212   INTEGER :: vert_order
3213   LOGICAL :: degrade_xs, degrade_ys
3214   LOGICAL :: degrade_xe, degrade_ye
3215   INTEGER :: jp1, jp0, jtmp
3216 ! definition of flux operators, 3rd, 4th, 5th or 6th order
3217   REAL :: flux3, flux4, flux5, flux6
3218   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
3219   REAL :: velb
3220   LOGICAL :: specified
3221   INTEGER :: ad_from
3222   INTEGER :: ad_to
3223   INTEGER :: branch
3224   INTEGER :: ad_from0
3225   INTEGER :: ad_to0
3226   INTEGER :: ad_from1
3227   INTEGER :: ad_to1
3228   INTEGER :: ad_from2
3229   INTEGER :: ad_to2
3230   INTEGER :: ad_from3
3231   INTEGER :: ad_to3
3232   INTEGER :: ad_from4
3233   INTEGER :: ad_to4
3234   INTEGER :: ad_from5
3235   INTEGER :: ad_to5
3236   INTEGER :: ad_from6
3237   INTEGER :: ad_to6
3238   INTEGER :: ad_from7
3239   INTEGER :: ad_to7
3240   INTEGER :: ad_from8
3241   INTEGER :: ad_to8
3242   INTEGER :: ad_from9
3243   INTEGER :: ad_to9
3244   INTEGER :: ad_from10
3245   INTEGER :: ad_to10
3246   INTEGER :: ad_from11
3247   INTEGER :: ad_to11
3248   INTEGER :: ad_from12
3249   INTEGER :: ad_to12
3250   INTEGER :: ad_from13
3251   INTEGER :: ad_to13
3252   INTEGER :: ad_from14
3253   INTEGER :: ad_to14
3254   INTEGER :: ad_from15
3255   INTEGER :: ad_to15
3256   INTEGER :: ad_from16
3257   INTEGER :: ad_to16
3258   INTEGER :: ad_from17
3259   INTEGER :: ad_to17
3260   INTEGER :: ad_from18
3261   INTEGER :: ad_to18
3262   INTEGER :: ad_from19
3263   INTEGER :: ad_to19
3264   INTEGER :: ad_from20
3265   INTEGER :: ad_to20
3266   INTEGER :: ad_from21
3267   INTEGER :: ad_to21
3268   INTEGER :: ad_from22
3269   INTEGER :: ad_to22
3270   INTEGER :: ad_from23
3271   INTEGER :: ad_to23
3272   INTEGER :: ad_from24
3273   INTEGER :: ad_to24
3274   INTEGER :: ad_from25
3275   INTEGER :: ad_to25
3276   INTEGER :: ad_from26
3277   INTEGER :: ad_to26
3278   INTEGER :: ad_from27
3279   INTEGER :: ad_to27
3280   INTEGER :: ad_from28
3281   INTEGER :: ad_to28
3282   INTEGER :: ad_from29
3283   INTEGER :: ad_to29
3284   INTEGER :: ad_from30
3285   INTEGER :: ad_to30
3286   INTEGER :: ad_from31
3287   INTEGER :: ad_to31
3288   INTEGER :: ad_from32
3289   INTEGER :: ad_to32
3290   INTEGER :: ad_from33
3291   INTEGER :: ad_to33
3292   INTEGER :: ad_from34
3293   INTEGER :: ad_to34
3294   INTEGER :: ad_from35
3295   INTEGER :: ad_to35
3296   INTEGER :: ad_from36
3297   INTEGER :: ad_to36
3298   INTEGER :: ad_from37
3299   INTEGER :: ad_to37
3300   INTEGER :: ad_from38
3301   INTEGER :: ad_to38
3302   INTEGER :: ad_from39
3303   INTEGER :: ad_to39
3304   INTEGER :: ad_from40
3305   INTEGER :: ad_to40
3306   INTEGER :: ad_from41
3307   INTEGER :: ad_to41
3308   INTEGER :: ad_from42
3309   INTEGER :: ad_to42
3310   INTEGER :: ad_from43
3311   INTEGER :: ad_to43
3312   INTEGER :: ad_from44
3313   INTEGER :: ad_to44
3314   INTEGER :: ad_from45
3315   INTEGER :: ad_to45
3316   INTEGER :: ad_from46
3317   INTEGER :: ad_to46
3318   INTEGER :: ad_from47
3319   INTEGER :: ad_to47
3320   INTEGER :: ad_from48
3321   INTEGER :: ad_to48
3322   INTEGER :: ad_from49
3323   INTEGER :: ad_to49
3324   INTEGER :: ad_from50
3325   INTEGER :: ad_to50
3326   INTEGER :: ad_from51
3327   INTEGER :: ad_to51
3328   INTEGER :: ad_from52
3329   INTEGER :: ad_to52
3330   REAL :: temp3
3331   REAL :: temp29
3332   REAL :: temp31b43
3333   REAL :: temp2
3334   INTEGER :: temp28
3335   REAL :: temp31b42
3336   REAL :: temp1
3337   REAL :: temp27
3338   REAL :: temp31b41
3339   INTEGER :: temp0
3340   REAL :: temp26
3341   REAL :: temp31b40
3342   REAL :: temp7b
3343   REAL :: temp25
3344   INTEGER :: temp24
3345   REAL :: temp23
3346   REAL :: temp22
3347   REAL :: temp21
3348   REAL :: temp35b3
3349   INTEGER :: temp20
3350   REAL :: temp35b2
3351   REAL :: temp35b1
3352   REAL :: temp35b0
3353   REAL :: temp23b9
3354   REAL :: temp23b8
3355   REAL :: temp19b
3356   REAL :: temp23b7
3357   REAL :: temp23b6
3358   REAL :: temp27b
3359   REAL :: temp23b5
3360   REAL :: temp35b
3361   REAL :: tempb1
3362   REAL :: temp23b4
3363   REAL :: temp43b
3364   REAL :: tempb0
3365   REAL :: temp23b3
3366   REAL :: temp23b2
3367   REAL :: temp23b1
3368   REAL :: temp23b0
3369   REAL :: temp31b39
3370   REAL :: temp31b38
3371   REAL :: temp7b3
3372   REAL :: temp31b37
3373   REAL :: temp3b
3374   REAL :: temp7b2
3375   REAL :: temp31b36
3376   REAL :: temp7b1
3377   REAL :: temp31b35
3378   REAL :: temp7b0
3379   REAL :: temp23b15
3380   REAL :: temp31b34
3381   REAL :: temp19
3382   REAL :: temp23b14
3383   REAL :: temp31b33
3384   REAL :: cb
3385   REAL :: temp18
3386   REAL :: temp23b13
3387   REAL :: temp31b32
3388   REAL :: temp17
3389   REAL :: temp23b12
3390   REAL :: temp31b31
3391   REAL :: temp43b9
3392   INTEGER :: temp16
3393   REAL :: temp23b11
3394   REAL :: temp31b30
3395   REAL :: temp43b8
3396   REAL :: temp15
3397   REAL :: temp23b10
3398   REAL :: temp43b7
3399   REAL :: temp14
3400   REAL :: temp11b1
3401   REAL :: temp43b6
3402   REAL :: temp13
3403   REAL :: temp11b0
3404   REAL :: temp43b5
3405   INTEGER :: temp12
3406   REAL :: temp43b4
3407   REAL :: temp11
3408   REAL :: temp43b3
3409   REAL :: temp10
3410   REAL :: temp43b2
3411   REAL :: temp15b
3412   REAL :: temp43b1
3413   REAL :: temp46
3414   REAL :: temp23b
3415   REAL :: temp43b0
3416   REAL :: temp45
3417   REAL :: temp31b
3418   INTEGER :: temp44
3419   REAL :: temp43
3420   REAL :: temp42
3421   REAL :: temp19b3
3422   REAL :: temp31b9
3423   REAL :: temp41
3424   REAL :: temp19b2
3425   REAL :: temp31b8
3426   INTEGER :: temp40
3427   REAL :: temp19b1
3428   REAL :: temp31b7
3429   REAL :: temp19b0
3430   REAL :: temp31b6
3431   REAL :: temp31b5
3432   REAL :: temp31b4
3433   REAL :: temp31b3
3434   REAL :: tempb
3435   REAL :: temp31b2
3436   REAL :: temp31b1
3437   REAL :: temp31b0
3438   REAL :: temp31b29
3439   REAL :: temp31b28
3440   REAL :: temp31b27
3441   REAL :: temp31b26
3442   REAL :: temp31b25
3443   REAL :: temp31b24
3444   REAL :: temp31b23
3445   REAL :: temp31b22
3446   REAL :: temp31b21
3447   REAL :: temp11b
3448   REAL :: temp31b20
3449   REAL :: temp39b1
3450   REAL :: temp39b0
3451   REAL :: temp31b53
3452   REAL :: temp39
3453   REAL :: temp31b52
3454   REAL :: temp38
3455   REAL :: temp3b3
3456   REAL :: temp31b51
3457   REAL :: temp37
3458   REAL :: temp3b2
3459   REAL :: temp31b50
3460   INTEGER :: temp36
3461   REAL :: temp3b1
3462   REAL :: temp35
3463   REAL :: temp3b0
3464   REAL :: temp34
3465   REAL :: temp33
3466   INTEGER :: temp32
3467   REAL :: temp31
3468   REAL :: temp30
3469   REAL :: temp27b1
3470   REAL :: temp27b0
3471   REAL :: temp31b19
3472   REAL :: temp31b18
3473   REAL :: temp31b17
3474   REAL :: temp15b3
3475   REAL :: temp31b16
3476   REAL :: temp
3477   REAL :: temp15b2
3478   REAL :: temp31b15
3479   REAL :: temp15b1
3480   REAL :: temp31b14
3481   REAL :: temp47b6
3482   REAL :: temp15b0
3483   REAL :: temp31b13
3484   REAL :: temp43b10
3485   REAL :: temp47b5
3486   REAL :: temp9
3487   REAL :: temp31b12
3488   REAL :: temp31b49
3489   REAL :: temp47b4
3490   INTEGER :: temp8
3491   REAL :: temp31b11
3492   REAL :: temp31b48
3493   REAL :: temp39b
3494   REAL :: temp47b3
3495   REAL :: temp7
3496   REAL :: temp31b10
3497   REAL :: temp31b47
3498   REAL :: temp47b
3499   REAL :: temp47b2
3500   REAL :: temp6
3501   REAL :: temp31b46
3502   REAL :: temp47b1
3503   REAL :: temp5
3504   REAL :: temp31b45
3505   REAL :: temp47b0
3506   INTEGER :: temp4
3507   REAL :: temp31b44
3508   specified = .false.
3509   IF (config_flags%specified .OR. config_flags%nested) specified = &
3510 &      .true.
3511   IF (kte .GT. kde - 1) THEN
3512     ktf = kde - 1
3513   ELSE
3514     ktf = kte
3515   END IF
3516   horz_order = config_flags%h_mom_adv_order
3517   vert_order = config_flags%v_mom_adv_order
3518 !  here is the choice of flux operators
3519   IF (horz_order .EQ. 6) THEN
3520 !  determine boundary mods for flux operators
3521 !  We degrade the flux operators from 3rd/4th order
3522 !   to second order one gridpoint in from the boundaries for
3523 !   all boundary conditions except periodic and symmetry - these
3524 !   conditions have boundary zone data fill for correct application
3525 !   of the higher order flux stencils
3526     degrade_xs = .true.
3527     degrade_xe = .true.
3528     degrade_ys = .true.
3529     degrade_ye = .true.
3530     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
3531 &        its .GT. ids + 3) degrade_xs = .false.
3532     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
3533 &        ite .LT. ide - 3) degrade_xe = .false.
3534     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
3535 &        jts .GT. jds + 3) degrade_ys = .false.
3536     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
3537 &        jte .LT. jde - 3) degrade_ye = .false.
3538 !--------------- y - advection first
3539     i_start = its
3540     IF (ite .GT. ide - 1) THEN
3541       i_end = ide - 1
3542     ELSE
3543       i_end = ite
3544     END IF
3545     j_start = jts
3546     j_end = jte
3547 !  higher order flux has a 5 or 7 point stencil, so compute
3548 !  bounds so we can switch to second order flux close to the boundary
3549     j_start_f = j_start
3550     j_end_f = j_end + 1
3551     IF (degrade_ys) THEN
3552       IF (jts .LT. jds + 1) THEN
3553         j_start = jds + 1
3554       ELSE
3555         j_start = jts
3556       END IF
3557       j_start_f = jds + 3
3558     END IF
3559     IF (degrade_ye) THEN
3560       IF (jte .GT. jde - 1) THEN
3561         j_end = jde - 1
3562       ELSE
3563         j_end = jte
3564       END IF
3565       j_end_f = jde - 2
3566     END IF
3567 !  compute fluxes, 5th or 6th order
3568     jp1 = 2
3569     jp0 = 1
3570     ad_from45 = j_start
3571 j_loop_y_flux_6:DO j=ad_from45,j_end+1
3572       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
3573         DO k=kts,ktf
3574           ad_from37 = i_start
3575           i = i_end + 1
3576           CALL PUSHINTEGER4(i - 1)
3577           CALL PUSHINTEGER4(ad_from37)
3578         END DO
3579         CALL PUSHCONTROL3B(0)
3580       ELSE IF (j .EQ. jds + 1) THEN
3581 !  we must be close to some boundary where we need to reduce the order of the stencil
3582 !  specified uses upstream normal wind at boundaries
3583 ! 2nd order flux next to south boundary
3584         DO k=kts,ktf
3585           ad_from38 = i_start
3586           DO i=ad_from38,i_end
3587             CALL PUSHREAL8(vb)
3588             vb = v(i, k, j-1)
3589             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
3590               vb = v(i, k, j)
3591               CALL PUSHCONTROL1B(0)
3592             ELSE
3593               CALL PUSHCONTROL1B(1)
3594             END IF
3595           END DO
3596           CALL PUSHINTEGER4(i - 1)
3597           CALL PUSHINTEGER4(ad_from38)
3598         END DO
3599         CALL PUSHCONTROL3B(1)
3600       ELSE IF (j .EQ. jds + 2) THEN
3601 ! third of 4th order flux 2 in from south boundary
3602         DO k=kts,ktf
3603           ad_from39 = i_start
3604           i = i_end + 1
3605           CALL PUSHINTEGER4(i - 1)
3606           CALL PUSHINTEGER4(ad_from39)
3607         END DO
3608         CALL PUSHCONTROL3B(2)
3609       ELSE IF (j .EQ. jde) THEN
3610 ! 2nd order flux next to north boundary
3611         DO k=kts,ktf
3612           ad_from40 = i_start
3613           DO i=ad_from40,i_end
3614             CALL PUSHREAL8(vb)
3615             vb = v(i, k, j)
3616             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
3617               vb = v(i, k, j-1)
3618               CALL PUSHCONTROL1B(0)
3619             ELSE
3620               CALL PUSHCONTROL1B(1)
3621             END IF
3622           END DO
3623           CALL PUSHINTEGER4(i - 1)
3624           CALL PUSHINTEGER4(ad_from40)
3625         END DO
3626         CALL PUSHCONTROL3B(3)
3627       ELSE IF (j .EQ. jde - 1) THEN
3628 ! 3rd or 4th order flux 2 in from north boundary
3629         DO k=kts,ktf
3630           ad_from41 = i_start
3631           i = i_end + 1
3632           CALL PUSHINTEGER4(i - 1)
3633           CALL PUSHINTEGER4(ad_from41)
3634         END DO
3635         CALL PUSHCONTROL3B(4)
3636       ELSE
3637         CALL PUSHCONTROL3B(5)
3638       END IF
3639 !  y flux-divergence into tendency
3640 ! Comments on polar boundary conditions
3641 ! No advection over the poles means tendencies (held from jds [S. pole]
3642 ! to jde [N pole], i.e., on v grid) must be zero at poles
3643 ! [tendency(jds) and tendency(jde)=0]
3644       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
3645         DO k=kts,ktf
3646           ad_from42 = i_start
3647           i = i_end + 1
3648           CALL PUSHINTEGER4(i - 1)
3649           CALL PUSHINTEGER4(ad_from42)
3650         END DO
3651         CALL PUSHCONTROL2B(0)
3652       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
3653 ! If j_end were set to jde in a special if statement apart from
3654 ! degrade_ye, then we would hit the next conditional.  But since
3655 ! we want the tendency to be zero anyway, not looping to jde+1
3656 ! will produce the same effect.
3657         DO k=kts,ktf
3658           ad_from43 = i_start
3659           i = i_end + 1
3660           CALL PUSHINTEGER4(i - 1)
3661           CALL PUSHINTEGER4(ad_from43)
3662         END DO
3663         CALL PUSHCONTROL2B(1)
3664       ELSE IF (j .GT. j_start) THEN
3665 ! Normal code
3666         DO k=kts,ktf
3667           ad_from44 = i_start
3668           i = i_end + 1
3669           CALL PUSHINTEGER4(i - 1)
3670           CALL PUSHINTEGER4(ad_from44)
3671         END DO
3672         CALL PUSHCONTROL2B(2)
3673       ELSE
3674         CALL PUSHCONTROL2B(3)
3675       END IF
3676       jtmp = jp1
3677       CALL PUSHINTEGER4(jp1)
3678       jp1 = jp0
3679       CALL PUSHINTEGER4(jp0)
3680       jp0 = jtmp
3681     END DO j_loop_y_flux_6
3682     CALL PUSHINTEGER4(j - 1)
3683     CALL PUSHINTEGER4(ad_from45)
3684 !  next, x - flux divergence
3685     i_start = its
3686     IF (ite .GT. ide - 1) THEN
3687       i_end = ide - 1
3688     ELSE
3689       i_end = ite
3690     END IF
3691     j_start = jts
3692     j_end = jte
3693 ! Polar boundary conditions are like open or specified
3694     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
3695 &    THEN
3696       IF (jds + 1 .LT. jts) THEN
3697         j_start = jts
3698       ELSE
3699         j_start = jds + 1
3700       END IF
3701     END IF
3702     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
3703 &    THEN
3704       IF (jde - 1 .GT. jte) THEN
3705         j_end = jte
3706       ELSE
3707         j_end = jde - 1
3708       END IF
3709     END IF
3710 !  higher order flux has a 5 or 7 point stencil, so compute
3711 !  bounds so we can switch to second order flux close to the boundary
3712     i_start_f = i_start
3713     i_end_f = i_end + 1
3714     IF (degrade_xs) THEN
3715       IF (ids + 1 .LT. its) THEN
3716         i_start = its
3717       ELSE
3718         i_start = ids + 1
3719       END IF
3720       IF (i_start + 2 .GT. ids + 3) THEN
3721         i_start_f = ids + 3
3722       ELSE
3723         i_start_f = i_start + 2
3724       END IF
3725     END IF
3726     IF (degrade_xe) THEN
3727       IF (ide - 2 .GT. ite) THEN
3728         i_end = ite
3729       ELSE
3730         i_end = ide - 2
3731       END IF
3732       i_end_f = ide - 3
3733     END IF
3734     ad_from48 = j_start
3735 !  compute fluxes
3736     DO j=ad_from48,j_end
3737 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3738       IF (degrade_xs) THEN
3739         ad_from46 = i_start
3740         DO i=ad_from46,i_start_f-1
3741           IF (i .EQ. ids + 1) THEN
3742             CALL PUSHCONTROL1B(0)
3743           ELSE
3744             CALL PUSHCONTROL1B(1)
3745           END IF
3746           IF (i .EQ. ids + 2) THEN
3747             CALL PUSHCONTROL1B(1)
3748           ELSE
3749             CALL PUSHCONTROL1B(0)
3750           END IF
3751         END DO
3752         CALL PUSHINTEGER4(ad_from46)
3753         CALL PUSHCONTROL1B(0)
3754       ELSE
3755         CALL PUSHCONTROL1B(1)
3756       END IF
3757       IF (degrade_xe) THEN
3758         DO i=i_end_f+1,i_end+1
3759           IF (i .EQ. ide - 1) THEN
3760             CALL PUSHCONTROL1B(0)
3761           ELSE
3762             CALL PUSHCONTROL1B(1)
3763           END IF
3764           IF (i .EQ. ide - 2) THEN
3765             CALL PUSHCONTROL1B(1)
3766           ELSE
3767             CALL PUSHCONTROL1B(0)
3768           END IF
3769         END DO
3770         CALL PUSHINTEGER4(i - 1)
3771         CALL PUSHCONTROL1B(1)
3772       ELSE
3773         CALL PUSHCONTROL1B(0)
3774       END IF
3775 !  x flux-divergence into tendency
3776       DO k=kts,ktf
3777         ad_from47 = i_start
3778         i = i_end + 1
3779         CALL PUSHINTEGER4(i - 1)
3780         CALL PUSHINTEGER4(ad_from47)
3781       END DO
3782     END DO
3783     CALL PUSHINTEGER4(j - 1)
3784     CALL PUSHINTEGER4(ad_from48)
3785     CALL PUSHCONTROL3B(0)
3786   ELSE IF (horz_order .EQ. 5) THEN
3787 !  5th order horizontal flux calculation
3788 !  This code is EXACTLY the same as the 6th order code
3789 !  EXCEPT the 5th order and 3rd operators are used in
3790 !  place of the 6th and 4th order operators
3791 !  determine boundary mods for flux operators
3792 !  We degrade the flux operators from 3rd/4th order
3793 !   to second order one gridpoint in from the boundaries for
3794 !   all boundary conditions except periodic and symmetry - these
3795 !   conditions have boundary zone data fill for correct application
3796 !   of the higher order flux stencils
3797     degrade_xs = .true.
3798     degrade_xe = .true.
3799     degrade_ys = .true.
3800     degrade_ye = .true.
3801     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
3802 &        its .GT. ids + 3) degrade_xs = .false.
3803     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
3804 &        ite .LT. ide - 3) degrade_xe = .false.
3805     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
3806 &        jts .GT. jds + 3) degrade_ys = .false.
3807     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
3808 &        jte .LT. jde - 3) degrade_ye = .false.
3809 !--------------- y - advection first
3810     i_start = its
3811     IF (ite .GT. ide - 1) THEN
3812       i_end = ide - 1
3813     ELSE
3814       i_end = ite
3815     END IF
3816     j_start = jts
3817     j_end = jte
3818 !  higher order flux has a 5 or 7 point stencil, so compute
3819 !  bounds so we can switch to second order flux close to the boundary
3820     j_start_f = j_start
3821     j_end_f = j_end + 1
3822     IF (degrade_ys) THEN
3823       IF (jts .LT. jds + 1) THEN
3824         j_start = jds + 1
3825       ELSE
3826         j_start = jts
3827       END IF
3828       j_start_f = jds + 3
3829     END IF
3830     IF (degrade_ye) THEN
3831       IF (jte .GT. jde - 1) THEN
3832         j_end = jde - 1
3833       ELSE
3834         j_end = jte
3835       END IF
3836       j_end_f = jde - 2
3837     END IF
3838 !  compute fluxes, 5th or 6th order
3839     jp1 = 2
3840     jp0 = 1
3841     ad_from7 = j_start
3842 j_loop_y_flux_5:DO j=ad_from7,j_end+1
3843       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
3844         DO k=kts,ktf
3845           ad_from = i_start
3846           i = i_end + 1
3847           CALL PUSHINTEGER4(i - 1)
3848           CALL PUSHINTEGER4(ad_from)
3849         END DO
3850         CALL PUSHCONTROL3B(0)
3851       ELSE IF (j .EQ. jds + 1) THEN
3852 !  we must be close to some boundary where we need to reduce the order of the stencil
3853 !  specified uses upstream normal wind at boundaries
3854 ! 2nd order flux next to south boundary
3855         DO k=kts,ktf
3856           ad_from0 = i_start
3857           DO i=ad_from0,i_end
3858             CALL PUSHREAL8(vb)
3859             vb = v(i, k, j-1)
3860             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
3861               vb = v(i, k, j)
3862               CALL PUSHCONTROL1B(0)
3863             ELSE
3864               CALL PUSHCONTROL1B(1)
3865             END IF
3866           END DO
3867           CALL PUSHINTEGER4(i - 1)
3868           CALL PUSHINTEGER4(ad_from0)
3869         END DO
3870         CALL PUSHCONTROL3B(1)
3871       ELSE IF (j .EQ. jds + 2) THEN
3872 ! third of 4th order flux 2 in from south boundary
3873         DO k=kts,ktf
3874           ad_from1 = i_start
3875           i = i_end + 1
3876           CALL PUSHINTEGER4(i - 1)
3877           CALL PUSHINTEGER4(ad_from1)
3878         END DO
3879         CALL PUSHCONTROL3B(2)
3880       ELSE IF (j .EQ. jde) THEN
3881 ! 2nd order flux next to north boundary
3882         DO k=kts,ktf
3883           ad_from2 = i_start
3884           DO i=ad_from2,i_end
3885             CALL PUSHREAL8(vb)
3886             vb = v(i, k, j)
3887             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
3888               vb = v(i, k, j-1)
3889               CALL PUSHCONTROL1B(0)
3890             ELSE
3891               CALL PUSHCONTROL1B(1)
3892             END IF
3893           END DO
3894           CALL PUSHINTEGER4(i - 1)
3895           CALL PUSHINTEGER4(ad_from2)
3896         END DO
3897         CALL PUSHCONTROL3B(3)
3898       ELSE IF (j .EQ. jde - 1) THEN
3899 ! 3rd or 4th order flux 2 in from north boundary
3900         DO k=kts,ktf
3901           ad_from3 = i_start
3902           i = i_end + 1
3903           CALL PUSHINTEGER4(i - 1)
3904           CALL PUSHINTEGER4(ad_from3)
3905         END DO
3906         CALL PUSHCONTROL3B(4)
3907       ELSE
3908         CALL PUSHCONTROL3B(5)
3909       END IF
3910 !  y flux-divergence into tendency
3911 ! Comments on polar boundary conditions
3912 ! No advection over the poles means tendencies (held from jds [S. pole]
3913 ! to jde [N pole], i.e., on v grid) must be zero at poles
3914 ! [tendency(jds) and tendency(jde)=0]
3915       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
3916         DO k=kts,ktf
3917           ad_from4 = i_start
3918           i = i_end + 1
3919           CALL PUSHINTEGER4(i - 1)
3920           CALL PUSHINTEGER4(ad_from4)
3921         END DO
3922         CALL PUSHCONTROL2B(0)
3923       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
3924 ! If j_end were set to jde in a special if statement apart from
3925 ! degrade_ye, then we would hit the next conditional.  But since
3926 ! we want the tendency to be zero anyway, not looping to jde+1
3927 ! will produce the same effect.
3928         DO k=kts,ktf
3929           ad_from5 = i_start
3930           i = i_end + 1
3931           CALL PUSHINTEGER4(i - 1)
3932           CALL PUSHINTEGER4(ad_from5)
3933         END DO
3934         CALL PUSHCONTROL2B(1)
3935       ELSE IF (j .GT. j_start) THEN
3936 ! Normal code
3937         DO k=kts,ktf
3938           ad_from6 = i_start
3939           i = i_end + 1
3940           CALL PUSHINTEGER4(i - 1)
3941           CALL PUSHINTEGER4(ad_from6)
3942         END DO
3943         CALL PUSHCONTROL2B(2)
3944       ELSE
3945         CALL PUSHCONTROL2B(3)
3946       END IF
3947       jtmp = jp1
3948       CALL PUSHINTEGER4(jp1)
3949       jp1 = jp0
3950       CALL PUSHINTEGER4(jp0)
3951       jp0 = jtmp
3952     END DO j_loop_y_flux_5
3953     CALL PUSHINTEGER4(j - 1)
3954     CALL PUSHINTEGER4(ad_from7)
3955 !  next, x - flux divergence
3956     i_start = its
3957     IF (ite .GT. ide - 1) THEN
3958       i_end = ide - 1
3959     ELSE
3960       i_end = ite
3961     END IF
3962     j_start = jts
3963     j_end = jte
3964 ! Polar boundary conditions are like open or specified
3965     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
3966 &    THEN
3967       IF (jds + 1 .LT. jts) THEN
3968         j_start = jts
3969       ELSE
3970         j_start = jds + 1
3971       END IF
3972     END IF
3973     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
3974 &    THEN
3975       IF (jde - 1 .GT. jte) THEN
3976         j_end = jte
3977       ELSE
3978         j_end = jde - 1
3979       END IF
3980     END IF
3981 !  higher order flux has a 5 or 7 point stencil, so compute
3982 !  bounds so we can switch to second order flux close to the boundary
3983     i_start_f = i_start
3984     i_end_f = i_end + 1
3985     IF (degrade_xs) THEN
3986       IF (ids + 1 .LT. its) THEN
3987         i_start = its
3988       ELSE
3989         i_start = ids + 1
3990       END IF
3991       IF (i_start + 2 .GT. ids + 3) THEN
3992         i_start_f = ids + 3
3993       ELSE
3994         i_start_f = i_start + 2
3995       END IF
3996     END IF
3997     IF (degrade_xe) THEN
3998       IF (ide - 2 .GT. ite) THEN
3999         i_end = ite
4000       ELSE
4001         i_end = ide - 2
4002       END IF
4003       i_end_f = ide - 3
4004     END IF
4005     ad_from10 = j_start
4006 !  compute fluxes
4007     DO j=ad_from10,j_end
4008 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4009       IF (degrade_xs) THEN
4010         ad_from8 = i_start
4011         DO i=ad_from8,i_start_f-1
4012           IF (i .EQ. ids + 1) THEN
4013             CALL PUSHCONTROL1B(0)
4014           ELSE
4015             CALL PUSHCONTROL1B(1)
4016           END IF
4017           IF (i .EQ. ids + 2) THEN
4018             CALL PUSHCONTROL1B(1)
4019           ELSE
4020             CALL PUSHCONTROL1B(0)
4021           END IF
4022         END DO
4023         CALL PUSHINTEGER4(ad_from8)
4024         CALL PUSHCONTROL1B(0)
4025       ELSE
4026         CALL PUSHCONTROL1B(1)
4027       END IF
4028       IF (degrade_xe) THEN
4029         DO i=i_end_f+1,i_end+1
4030           IF (i .EQ. ide - 1) THEN
4031             CALL PUSHCONTROL1B(0)
4032           ELSE
4033             CALL PUSHCONTROL1B(1)
4034           END IF
4035           IF (i .EQ. ide - 2) THEN
4036             CALL PUSHCONTROL1B(1)
4037           ELSE
4038             CALL PUSHCONTROL1B(0)
4039           END IF
4040         END DO
4041         CALL PUSHINTEGER4(i - 1)
4042         CALL PUSHCONTROL1B(1)
4043       ELSE
4044         CALL PUSHCONTROL1B(0)
4045       END IF
4046 !  x flux-divergence into tendency
4047       DO k=kts,ktf
4048         ad_from9 = i_start
4049         i = i_end + 1
4050         CALL PUSHINTEGER4(i - 1)
4051         CALL PUSHINTEGER4(ad_from9)
4052       END DO
4053     END DO
4054     CALL PUSHINTEGER4(j - 1)
4055     CALL PUSHINTEGER4(ad_from10)
4056     CALL PUSHCONTROL3B(1)
4057   ELSE IF (horz_order .EQ. 4) THEN
4058 !  determine boundary mods for flux operators
4059 !  We degrade the flux operators from 3rd/4th order
4060 !   to second order one gridpoint in from the boundaries for
4061 !   all boundary conditions except periodic and symmetry - these
4062 !   conditions have boundary zone data fill for correct application
4063 !   of the higher order flux stencils
4064     degrade_xs = .true.
4065     degrade_xe = .true.
4066     degrade_ys = .true.
4067     degrade_ye = .true.
4068     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
4069 &        its .GT. ids + 2) degrade_xs = .false.
4070     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
4071 &        ite .LT. ide - 2) degrade_xe = .false.
4072     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
4073 &        jts .GT. jds + 2) degrade_ys = .false.
4074     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
4075 &        jte .LT. jde - 2) degrade_ye = .false.
4076     IF (kte .GT. kde - 1) THEN
4077       ktf = kde - 1
4078     ELSE
4079       ktf = kte
4080     END IF
4081     i_start = its
4082     IF (ite .GT. ide - 1) THEN
4083       i_end = ide - 1
4084     ELSE
4085       i_end = ite
4086     END IF
4087     j_start = jts
4088     j_end = jte
4089 !  3rd or 4th order flux has a 5 point stencil, so compute
4090 !  bounds so we can switch to second order flux close to the boundary
4091 !CJM May not work with tiling because defined in terms of domain dims
4092     IF (degrade_ys) j_start = jds + 1
4093     IF (degrade_ye) j_end = jde - 1
4094 !  compute fluxes
4095 !  specified uses upstream normal wind at boundaries
4096     jp0 = 1
4097     jp1 = 2
4098     ad_from17 = j_start
4099     DO j=ad_from17,j_end+1
4100       IF (j .EQ. j_start .AND. degrade_ys) THEN
4101         DO k=kts,ktf
4102           ad_from11 = i_start
4103           DO i=ad_from11,i_end
4104             CALL PUSHREAL8(vb)
4105             vb = v(i, k, j-1)
4106             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
4107               vb = v(i, k, j)
4108               CALL PUSHCONTROL1B(0)
4109             ELSE
4110               CALL PUSHCONTROL1B(1)
4111             END IF
4112           END DO
4113           CALL PUSHINTEGER4(i - 1)
4114           CALL PUSHINTEGER4(ad_from11)
4115         END DO
4116         CALL PUSHCONTROL2B(0)
4117       ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN
4118         DO k=kts,ktf
4119           ad_from12 = i_start
4120           DO i=ad_from12,i_end
4121             CALL PUSHREAL8(vb)
4122             vb = v(i, k, j)
4123             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
4124               vb = v(i, k, j-1)
4125               CALL PUSHCONTROL1B(0)
4126             ELSE
4127               CALL PUSHCONTROL1B(1)
4128             END IF
4129           END DO
4130           CALL PUSHINTEGER4(i - 1)
4131           CALL PUSHINTEGER4(ad_from12)
4132         END DO
4133         CALL PUSHCONTROL2B(1)
4134       ELSE
4135         DO k=kts,ktf
4136           ad_from13 = i_start
4137           i = i_end + 1
4138           CALL PUSHINTEGER4(i - 1)
4139           CALL PUSHINTEGER4(ad_from13)
4140         END DO
4141         CALL PUSHCONTROL2B(2)
4142       END IF
4143 ! Comments on polar boundary conditions
4144 ! No advection over the poles means tendencies (held from jds [S. pole]
4145 ! to jde [N pole], i.e., on v grid) must be zero at poles
4146 ! [tendency(jds) and tendency(jde)=0]
4147       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
4148         DO k=kts,ktf
4149           ad_from14 = i_start
4150           i = i_end + 1
4151           CALL PUSHINTEGER4(i - 1)
4152           CALL PUSHINTEGER4(ad_from14)
4153         END DO
4154         CALL PUSHCONTROL2B(0)
4155       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
4156 ! If j_end were set to jde in a special if statement apart from
4157 ! degrade_ye, then we would hit the next conditional.  But since
4158 ! we want the tendency to be zero anyway, not looping to jde+1
4159 ! will produce the same effect.
4160         DO k=kts,ktf
4161           ad_from15 = i_start
4162           i = i_end + 1
4163           CALL PUSHINTEGER4(i - 1)
4164           CALL PUSHINTEGER4(ad_from15)
4165         END DO
4166         CALL PUSHCONTROL2B(1)
4167       ELSE IF (j .GT. j_start) THEN
4168 ! Normal code
4169         DO k=kts,ktf
4170           ad_from16 = i_start
4171           i = i_end + 1
4172           CALL PUSHINTEGER4(i - 1)
4173           CALL PUSHINTEGER4(ad_from16)
4174         END DO
4175         CALL PUSHCONTROL2B(2)
4176       ELSE
4177         CALL PUSHCONTROL2B(3)
4178       END IF
4179       jtmp = jp1
4180       CALL PUSHINTEGER4(jp1)
4181       jp1 = jp0
4182       CALL PUSHINTEGER4(jp0)
4183       jp0 = jtmp
4184     END DO
4185     CALL PUSHINTEGER4(j - 1)
4186     CALL PUSHINTEGER4(ad_from17)
4187 !  next, x - flux divergence
4188     i_start = its
4189     IF (ite .GT. ide - 1) THEN
4190       i_end = ide - 1
4191     ELSE
4192       i_end = ite
4193     END IF
4194     j_start = jts
4195     j_end = jte
4196 ! Polar boundary conditions are like open or specified
4197     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
4198 &    THEN
4199       IF (jds + 1 .LT. jts) THEN
4200         j_start = jts
4201       ELSE
4202         j_start = jds + 1
4203       END IF
4204     END IF
4205     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
4206 &    THEN
4207       IF (jde - 1 .GT. jte) THEN
4208         j_end = jte
4209       ELSE
4210         j_end = jde - 1
4211       END IF
4212     END IF
4213 !  3rd or 4th order flux has a 5 point stencil, so compute
4214 !  bounds so we can switch to second order flux close to the boundary
4215     i_start_f = i_start
4216     i_end_f = i_end + 1
4217     IF (degrade_xs) THEN
4218       i_start = ids + 1
4219       i_start_f = i_start + 1
4220     END IF
4221     IF (degrade_xe) THEN
4222       i_end = ide - 2
4223       i_end_f = ide - 2
4224     END IF
4225     ad_from19 = j_start
4226 !  compute fluxes
4227     DO j=ad_from19,j_end
4228 !  second order flux close to boundaries (if not periodic or symmetric)
4229       IF (degrade_xs) THEN
4230         CALL PUSHCONTROL1B(0)
4231       ELSE
4232         CALL PUSHCONTROL1B(1)
4233       END IF
4234       IF (degrade_xe) THEN
4235         CALL PUSHCONTROL1B(1)
4236       ELSE
4237         CALL PUSHCONTROL1B(0)
4238       END IF
4239 !  x flux-divergence into tendency
4240       DO k=kts,ktf
4241         ad_from18 = i_start
4242         i = i_end + 1
4243         CALL PUSHINTEGER4(i - 1)
4244         CALL PUSHINTEGER4(ad_from18)
4245       END DO
4246     END DO
4247     CALL PUSHINTEGER4(j - 1)
4248     CALL PUSHINTEGER4(ad_from19)
4249     CALL PUSHCONTROL3B(2)
4250   ELSE IF (horz_order .EQ. 3) THEN
4251 !  determine boundary mods for flux operators
4252 !  We degrade the flux operators from 3rd/4th order
4253 !   to second order one gridpoint in from the boundaries for
4254 !   all boundary conditions except periodic and symmetry - these
4255 !   conditions have boundary zone data fill for correct application
4256 !   of the higher order flux stencils
4257     degrade_xs = .true.
4258     degrade_xe = .true.
4259     degrade_ys = .true.
4260     degrade_ye = .true.
4261     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
4262 &        its .GT. ids + 2) degrade_xs = .false.
4263     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
4264 &        ite .LT. ide - 2) degrade_xe = .false.
4265     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
4266 &        jts .GT. jds + 2) degrade_ys = .false.
4267     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
4268 &        jte .LT. jde - 2) degrade_ye = .false.
4269     IF (kte .GT. kde - 1) THEN
4270       ktf = kde - 1
4271     ELSE
4272       ktf = kte
4273     END IF
4274     i_start = its
4275     IF (ite .GT. ide - 1) THEN
4276       i_end = ide - 1
4277     ELSE
4278       i_end = ite
4279     END IF
4280     j_start = jts
4281     j_end = jte
4282 !  3rd or 4th order flux has a 5 point stencil, so compute
4283 !  bounds so we can switch to second order flux close to the boundary
4284 !CJM May not work with tiling because defined in terms of domain dims
4285     IF (degrade_ys) j_start = jds + 1
4286     IF (degrade_ye) j_end = jde - 1
4287 !  compute fluxes
4288 !  specified uses upstream normal wind at boundaries
4289     jp0 = 1
4290     jp1 = 2
4291     ad_from26 = j_start
4292     DO j=ad_from26,j_end+1
4293       IF (j .EQ. j_start .AND. degrade_ys) THEN
4294         DO k=kts,ktf
4295           ad_from20 = i_start
4296           DO i=ad_from20,i_end
4297             CALL PUSHREAL8(vb)
4298             vb = v(i, k, j-1)
4299             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
4300               vb = v(i, k, j)
4301               CALL PUSHCONTROL1B(0)
4302             ELSE
4303               CALL PUSHCONTROL1B(1)
4304             END IF
4305           END DO
4306           CALL PUSHINTEGER4(i - 1)
4307           CALL PUSHINTEGER4(ad_from20)
4308         END DO
4309         CALL PUSHCONTROL2B(0)
4310       ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN
4311         DO k=kts,ktf
4312           ad_from21 = i_start
4313           DO i=ad_from21,i_end
4314             CALL PUSHREAL8(vb)
4315             vb = v(i, k, j)
4316             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
4317               vb = v(i, k, j-1)
4318               CALL PUSHCONTROL1B(0)
4319             ELSE
4320               CALL PUSHCONTROL1B(1)
4321             END IF
4322           END DO
4323           CALL PUSHINTEGER4(i - 1)
4324           CALL PUSHINTEGER4(ad_from21)
4325         END DO
4326         CALL PUSHCONTROL2B(1)
4327       ELSE
4328         DO k=kts,ktf
4329           ad_from22 = i_start
4330           i = i_end + 1
4331           CALL PUSHINTEGER4(i - 1)
4332           CALL PUSHINTEGER4(ad_from22)
4333         END DO
4334         CALL PUSHCONTROL2B(2)
4335       END IF
4336 ! Comments on polar boundary conditions
4337 ! No advection over the poles means tendencies (held from jds [S. pole]
4338 ! to jde [N pole], i.e., on v grid) must be zero at poles
4339 ! [tendency(jds) and tendency(jde)=0]
4340       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
4341         DO k=kts,ktf
4342           ad_from23 = i_start
4343           i = i_end + 1
4344           CALL PUSHINTEGER4(i - 1)
4345           CALL PUSHINTEGER4(ad_from23)
4346         END DO
4347         CALL PUSHCONTROL2B(0)
4348       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
4349 ! If j_end were set to jde in a special if statement apart from
4350 ! degrade_ye, then we would hit the next conditional.  But since
4351 ! we want the tendency to be zero anyway, not looping to jde+1
4352 ! will produce the same effect.
4353         DO k=kts,ktf
4354           ad_from24 = i_start
4355           i = i_end + 1
4356           CALL PUSHINTEGER4(i - 1)
4357           CALL PUSHINTEGER4(ad_from24)
4358         END DO
4359         CALL PUSHCONTROL2B(1)
4360       ELSE IF (j .GT. j_start) THEN
4361 ! Normal code
4362         DO k=kts,ktf
4363           ad_from25 = i_start
4364           i = i_end + 1
4365           CALL PUSHINTEGER4(i - 1)
4366           CALL PUSHINTEGER4(ad_from25)
4367         END DO
4368         CALL PUSHCONTROL2B(2)
4369       ELSE
4370         CALL PUSHCONTROL2B(3)
4371       END IF
4372       jtmp = jp1
4373       CALL PUSHINTEGER4(jp1)
4374       jp1 = jp0
4375       CALL PUSHINTEGER4(jp0)
4376       jp0 = jtmp
4377     END DO
4378     CALL PUSHINTEGER4(j - 1)
4379     CALL PUSHINTEGER4(ad_from26)
4380 !  next, x - flux divergence
4381     i_start = its
4382     IF (ite .GT. ide - 1) THEN
4383       i_end = ide - 1
4384     ELSE
4385       i_end = ite
4386     END IF
4387     j_start = jts
4388     j_end = jte
4389 ! Polar boundary conditions are like open or specified
4390     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
4391 &    THEN
4392       IF (jds + 1 .LT. jts) THEN
4393         j_start = jts
4394       ELSE
4395         j_start = jds + 1
4396       END IF
4397     END IF
4398     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
4399 &    THEN
4400       IF (jde - 1 .GT. jte) THEN
4401         j_end = jte
4402       ELSE
4403         j_end = jde - 1
4404       END IF
4405     END IF
4406 !  3rd or 4th order flux has a 5 point stencil, so compute
4407 !  bounds so we can switch to second order flux close to the boundary
4408     i_start_f = i_start
4409     i_end_f = i_end + 1
4410     IF (degrade_xs) THEN
4411       i_start = ids + 1
4412       i_start_f = i_start + 1
4413     END IF
4414     IF (degrade_xe) THEN
4415       i_end = ide - 2
4416       i_end_f = ide - 2
4417     END IF
4418     ad_from28 = j_start
4419 !  compute fluxes
4420     DO j=ad_from28,j_end
4421 !  second order flux close to boundaries (if not periodic or symmetric)
4422       IF (degrade_xs) THEN
4423         CALL PUSHCONTROL1B(0)
4424       ELSE
4425         CALL PUSHCONTROL1B(1)
4426       END IF
4427       IF (degrade_xe) THEN
4428         CALL PUSHCONTROL1B(1)
4429       ELSE
4430         CALL PUSHCONTROL1B(0)
4431       END IF
4432 !  x flux-divergence into tendency
4433       DO k=kts,ktf
4434         ad_from27 = i_start
4435         i = i_end + 1
4436         CALL PUSHINTEGER4(i - 1)
4437         CALL PUSHINTEGER4(ad_from27)
4438       END DO
4439     END DO
4440     CALL PUSHINTEGER4(j - 1)
4441     CALL PUSHINTEGER4(ad_from28)
4442     CALL PUSHCONTROL3B(3)
4443   ELSE IF (horz_order .EQ. 2) THEN
4444     i_start = its
4445     IF (ite .GT. ide - 1) THEN
4446       i_end = ide - 1
4447     ELSE
4448       i_end = ite
4449     END IF
4450     j_start = jts
4451     j_end = jte
4452     IF (config_flags%open_ys) THEN
4453       IF (jds + 1 .LT. jts) THEN
4454         j_start = jts
4455       ELSE
4456         j_start = jds + 1
4457       END IF
4458     END IF
4459     IF (config_flags%open_ye) THEN
4460       IF (jde - 1 .GT. jte) THEN
4461         j_end = jte
4462       ELSE
4463         j_end = jde - 1
4464       END IF
4465     END IF
4466     IF (specified) THEN
4467       IF (jds + 2 .LT. jts) THEN
4468         j_start = jts
4469       ELSE
4470         j_start = jds + 2
4471       END IF
4472     END IF
4473     IF (specified) THEN
4474       IF (jde - 2 .GT. jte) THEN
4475         j_end = jte
4476       ELSE
4477         j_end = jde - 2
4478       END IF
4479     END IF
4480     IF (config_flags%polar) THEN
4481       IF (jds + 1 .LT. jts) THEN
4482         j_start = jts
4483       ELSE
4484         j_start = jds + 1
4485       END IF
4486     END IF
4487     IF (config_flags%polar) THEN
4488       IF (jde - 1 .GT. jte) THEN
4489         j_end = jte
4490       ELSE
4491         j_end = jde - 1
4492       END IF
4493     END IF
4494     ad_from30 = j_start
4495     DO j=ad_from30,j_end
4496       DO k=kts,ktf
4497         ad_from29 = i_start
4498         i = i_end + 1
4499         CALL PUSHINTEGER4(i - 1)
4500         CALL PUSHINTEGER4(ad_from29)
4501       END DO
4502     END DO
4503     CALL PUSHINTEGER4(j - 1)
4504     CALL PUSHINTEGER4(ad_from30)
4505 ! Comments on polar boundary conditions
4506 ! tendencies = 0 at poles, and polar points do not contribute at points
4507 ! next to poles
4508     IF (config_flags%polar) THEN
4509       IF (jts .EQ. jds) THEN
4510         DO k=kts,ktf
4511           ad_from31 = i_start
4512           i = i_end + 1
4513           CALL PUSHINTEGER4(i - 1)
4514           CALL PUSHINTEGER4(ad_from31)
4515         END DO
4516         CALL PUSHCONTROL1B(0)
4517       ELSE
4518         CALL PUSHCONTROL1B(1)
4519       END IF
4520       IF (jte .EQ. jde) THEN
4521         DO k=kts,ktf
4522           ad_from32 = i_start
4523           i = i_end + 1
4524           CALL PUSHINTEGER4(i - 1)
4525           CALL PUSHINTEGER4(ad_from32)
4526         END DO
4527         CALL PUSHCONTROL2B(0)
4528       ELSE
4529         CALL PUSHCONTROL2B(1)
4530       END IF
4531     ELSE
4532       CALL PUSHCONTROL2B(2)
4533     END IF
4534 !  specified uses upstream normal wind at boundaries
4535     IF (specified .AND. jts .LE. jds + 1) THEN
4536       j = jds + 1
4537       DO k=kts,ktf
4538         ad_from33 = i_start
4539         DO i=ad_from33,i_end
4540           CALL PUSHREAL8(vb)
4541 ! ADT eqn 45, 2nd term on RHS
4542           vb = v(i, k, j-1)
4543           IF (v(i, k, j) .LT. 0.) THEN
4544             vb = v(i, k, j)
4545             CALL PUSHCONTROL1B(0)
4546           ELSE
4547             CALL PUSHCONTROL1B(1)
4548           END IF
4549         END DO
4550         CALL PUSHINTEGER4(i - 1)
4551         CALL PUSHINTEGER4(ad_from33)
4552       END DO
4553       CALL PUSHCONTROL1B(0)
4554     ELSE
4555       CALL PUSHCONTROL1B(1)
4556     END IF
4557     IF (specified .AND. jte .GE. jde - 1) THEN
4558       CALL PUSHINTEGER4(j)
4559       j = jde - 1
4560       DO k=kts,ktf
4561         ad_from34 = i_start
4562         DO i=ad_from34,i_end
4563           CALL PUSHREAL8(vb)
4564 ! ADT eqn 45, 2nd term on RHS
4565           vb = v(i, k, j+1)
4566           IF (v(i, k, j) .GT. 0.) THEN
4567             vb = v(i, k, j)
4568             CALL PUSHCONTROL1B(0)
4569           ELSE
4570             CALL PUSHCONTROL1B(1)
4571           END IF
4572         END DO
4573         CALL PUSHINTEGER4(i - 1)
4574         CALL PUSHINTEGER4(ad_from34)
4575       END DO
4576       CALL PUSHCONTROL1B(0)
4577     ELSE
4578       CALL PUSHCONTROL1B(1)
4579     END IF
4580     IF (.NOT.config_flags%periodic_x) THEN
4581       IF (config_flags%open_xs .OR. specified) THEN
4582         IF (ids + 1 .LT. its) THEN
4583           i_start = its
4584         ELSE
4585           i_start = ids + 1
4586         END IF
4587       END IF
4588       IF (config_flags%open_xe .OR. specified) THEN
4589         IF (ide - 2 .GT. ite) THEN
4590           i_end = ite
4591         ELSE
4592           i_end = ide - 2
4593         END IF
4594       END IF
4595     END IF
4596     IF (config_flags%polar) THEN
4597       IF (jds + 1 .LT. jts) THEN
4598         j_start = jts
4599       ELSE
4600         j_start = jds + 1
4601       END IF
4602     END IF
4603     IF (config_flags%polar) THEN
4604       IF (jde - 1 .GT. jte) THEN
4605         j_end = jte
4606       ELSE
4607         j_end = jde - 1
4608       END IF
4609     END IF
4610     ad_from36 = j_start
4611     CALL PUSHINTEGER4(j)
4612     DO j=ad_from36,j_end
4613       DO k=kts,ktf
4614         ad_from35 = i_start
4615         i = i_end + 1
4616         CALL PUSHINTEGER4(i - 1)
4617         CALL PUSHINTEGER4(ad_from35)
4618       END DO
4619     END DO
4620     CALL PUSHINTEGER4(j - 1)
4621     CALL PUSHINTEGER4(ad_from36)
4622     CALL PUSHCONTROL3B(4)
4623   ELSE
4624     CALL PUSHCONTROL3B(5)
4625   END IF
4626 !  Comments on polar boundary condition
4627 !  Force tendency=0 at NP and SP
4628 !  We keep setting this everywhere, but it can't hurt...
4629   IF (config_flags%polar .AND. jts .EQ. jds) THEN
4630     CALL PUSHCONTROL1B(0)
4631   ELSE
4632     CALL PUSHCONTROL1B(1)
4633   END IF
4634   IF (config_flags%polar .AND. jte .EQ. jde) THEN
4635     CALL PUSHCONTROL1B(0)
4636   ELSE
4637     CALL PUSHCONTROL1B(1)
4638   END IF
4639 !  radiative lateral boundary condition in y for normal velocity (v)
4640   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
4641     CALL PUSHINTEGER4(i_start)
4642     i_start = its
4643     IF (ite .GT. ide - 1) THEN
4644       CALL PUSHINTEGER4(i_end)
4645       i_end = ide - 1
4646       CALL PUSHCONTROL1B(0)
4647     ELSE
4648       CALL PUSHINTEGER4(i_end)
4649       i_end = ite
4650       CALL PUSHCONTROL1B(1)
4651     END IF
4652     ad_from49 = i_start
4653     DO i=ad_from49,i_end
4654       DO k=kts,ktf
4655         IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN
4656           CALL PUSHREAL8(vb)
4657           vb = 0.
4658           CALL PUSHCONTROL1B(0)
4659         ELSE
4660           CALL PUSHREAL8(vb)
4661           vb = rv(i, k, jts) - cb*mut(i, jts)
4662           CALL PUSHCONTROL1B(1)
4663         END IF
4664       END DO
4665     END DO
4666     CALL PUSHINTEGER4(i - 1)
4667     CALL PUSHINTEGER4(ad_from49)
4668     CALL PUSHCONTROL1B(0)
4669   ELSE
4670     CALL PUSHCONTROL1B(1)
4671   END IF
4672   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
4673     CALL PUSHINTEGER4(i_start)
4674     i_start = its
4675     IF (ite .GT. ide - 1) THEN
4676       CALL PUSHINTEGER4(i_end)
4677       i_end = ide - 1
4678       CALL PUSHCONTROL1B(0)
4679     ELSE
4680       CALL PUSHINTEGER4(i_end)
4681       i_end = ite
4682       CALL PUSHCONTROL1B(1)
4683     END IF
4684     ad_from50 = i_start
4685     DO i=ad_from50,i_end
4686       DO k=kts,ktf
4687         IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN
4688           CALL PUSHREAL8(vb)
4689           vb = 0.
4690           CALL PUSHCONTROL1B(0)
4691         ELSE
4692           CALL PUSHREAL8(vb)
4693           vb = rv(i, k, jte) + cb*mut(i, jte-1)
4694           CALL PUSHCONTROL1B(1)
4695         END IF
4696       END DO
4697     END DO
4698     CALL PUSHINTEGER4(i - 1)
4699     CALL PUSHINTEGER4(ad_from50)
4700     CALL PUSHCONTROL1B(1)
4701   ELSE
4702     CALL PUSHCONTROL1B(0)
4703   END IF
4704 !  pick up the rest of the horizontal radiation boundary conditions.
4705 !  (these are the computations that don't require 'cb'.
4706 !  first, set to index ranges
4707   j_start = jts
4708   IF (jte .GT. jde) THEN
4709     j_end = jde
4710   ELSE
4711     j_end = jte
4712   END IF
4713   jmin = jds
4714   jmax = jde - 1
4715   IF (config_flags%open_ys) THEN
4716     IF (jds + 1 .LT. jts) THEN
4717       j_start = jts
4718     ELSE
4719       j_start = jds + 1
4720     END IF
4721     jmin = jds
4722   END IF
4723   IF (config_flags%open_ye) THEN
4724     IF (jte .GT. jde - 1) THEN
4725       j_end = jde - 1
4726     ELSE
4727       j_end = jte
4728     END IF
4729     jmax = jde - 1
4730   END IF
4731 !  compute x (u) conditions for v, w, or scalar
4732   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
4733     ad_from51 = j_start
4734     DO j=ad_from51,j_end
4735       CALL PUSHREAL8(mrdx)
4736 ! ADT eqn 45, 1st term on RHS
4737       mrdx = msfvy(its, j)*rdx
4738       IF (jmax .GT. j) THEN
4739         CALL PUSHINTEGER4(jp)
4740         jp = j
4741         CALL PUSHCONTROL1B(0)
4742       ELSE
4743         CALL PUSHINTEGER4(jp)
4744         jp = jmax
4745         CALL PUSHCONTROL1B(1)
4746       END IF
4747       IF (jmin .LT. j - 1) THEN
4748         CALL PUSHINTEGER4(jm)
4749         jm = j - 1
4750         CALL PUSHCONTROL1B(0)
4751       ELSE
4752         CALL PUSHINTEGER4(jm)
4753         jm = jmin
4754         CALL PUSHCONTROL1B(1)
4755       END IF
4756       DO k=kts,ktf
4757         uw = 0.5*(ru(its, k, jp)+ru(its, k, jm))
4758         IF (uw .GT. 0.) THEN
4759           CALL PUSHREAL8(ub)
4760           ub = 0.
4761           CALL PUSHCONTROL1B(0)
4762         ELSE
4763           CALL PUSHREAL8(ub)
4764           ub = uw
4765           CALL PUSHCONTROL1B(1)
4766         END IF
4767       END DO
4768     END DO
4769     CALL PUSHINTEGER4(j - 1)
4770     CALL PUSHINTEGER4(ad_from51)
4771     CALL PUSHCONTROL1B(0)
4772   ELSE
4773     CALL PUSHCONTROL1B(1)
4774   END IF
4775   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
4776     ad_from52 = j_start
4777     DO j=ad_from52,j_end
4778       CALL PUSHREAL8(mrdx)
4779 ! ADT eqn 45, 1st term on RHS
4780       mrdx = msfvy(ite-1, j)*rdx
4781       IF (jmax .GT. j) THEN
4782         CALL PUSHINTEGER4(jp)
4783         jp = j
4784         CALL PUSHCONTROL1B(0)
4785       ELSE
4786         CALL PUSHINTEGER4(jp)
4787         jp = jmax
4788         CALL PUSHCONTROL1B(1)
4789       END IF
4790       IF (jmin .LT. j - 1) THEN
4791         CALL PUSHINTEGER4(jm)
4792         jm = j - 1
4793         CALL PUSHCONTROL1B(0)
4794       ELSE
4795         CALL PUSHINTEGER4(jm)
4796         jm = jmin
4797         CALL PUSHCONTROL1B(1)
4798       END IF
4799       DO k=kts,ktf
4800         uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm))
4801         IF (uw .LT. 0.) THEN
4802           CALL PUSHREAL8(ub)
4803           ub = 0.
4804           CALL PUSHCONTROL1B(0)
4805         ELSE
4806           CALL PUSHREAL8(ub)
4807           ub = uw
4808           CALL PUSHCONTROL1B(1)
4809         END IF
4810       END DO
4811     END DO
4812     CALL PUSHINTEGER4(j - 1)
4813     CALL PUSHINTEGER4(ad_from52)
4814     CALL PUSHCONTROL1B(1)
4815   ELSE
4816     CALL PUSHCONTROL1B(0)
4817   END IF
4818   CALL PUSHINTEGER4(i_start)
4819 !-------------------- vertical advection
4820 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
4821 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
4822 !     We therefore need to make a correction for advect_v
4823 !     since 'my' (map scale factor in y direction) isn't a function of z,
4824 !     we can do this using *(my/mx) (see eqn. 45 for example)
4825   i_start = its
4826   IF (ite .GT. ide - 1) THEN
4827     CALL PUSHINTEGER4(i_end)
4828     i_end = ide - 1
4829     CALL PUSHCONTROL1B(0)
4830   ELSE
4831     CALL PUSHINTEGER4(i_end)
4832     i_end = ite
4833     CALL PUSHCONTROL1B(1)
4834   END IF
4835   j_start = jts
4836   j_end = jte
4837 ! Polar boundary conditions are like open or specified
4838 ! We don't want to calculate vertical v tendencies at the N or S pole
4839   IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
4840 &  THEN
4841     IF (jds + 1 .LT. jts) THEN
4842       j_start = jts
4843     ELSE
4844       j_start = jds + 1
4845     END IF
4846   END IF
4847   IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
4848 &  THEN
4849     IF (jde - 1 .GT. jte) THEN
4850       j_end = jte
4851     ELSE
4852       j_end = jde - 1
4853     END IF
4854   END IF
4855   IF (vert_order .EQ. 6) THEN
4856     DO j=j_start,j_end
4857       CALL PUSHINTEGER4(k)
4858     END DO
4859     vfluxb = 0.0
4860     DO j=j_end,j_start,-1
4861       DO k=ktf,kts,-1
4862         DO i=i_end,i_start,-1
4863           temp31b50 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, &
4864 &            j))
4865           vfluxb(i, k+1) = vfluxb(i, k+1) + temp31b50
4866           vfluxb(i, k) = vfluxb(i, k) - temp31b50
4867         END DO
4868       END DO
4869       CALL POPINTEGER4(k)
4870       DO i=i_end,i_start,-1
4871         k = ktf
4872         temp31b44 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i&
4873 &          , k)
4874         temp31b45 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
4875         romb(i, k, j) = romb(i, k, j) + temp31b44
4876         romb(i, k, j-1) = romb(i, k, j-1) + temp31b44
4877         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp31b45
4878         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp31b45
4879         vfluxb(i, k) = 0.0
4880         k = ktf - 1
4881         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
4882         temp31b46 = vel*vfluxb(i, k)/12.0
4883         velb = (7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))*&
4884 &          vfluxb(i, k)/12.0
4885         vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b46
4886         vb0(i, k-1, j) = vb0(i, k-1, j) + 7.*temp31b46
4887         vb0(i, k+1, j) = vb0(i, k+1, j) - temp31b46
4888         vb0(i, k-2, j) = vb0(i, k-2, j) - temp31b46
4889         vfluxb(i, k) = 0.0
4890         romb(i, k, j) = romb(i, k, j) + 0.5*velb
4891         romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
4892         k = kts + 2
4893         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
4894         temp31b47 = vel*vfluxb(i, k)/12.0
4895         velb = (7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))*&
4896 &          vfluxb(i, k)/12.0
4897         vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b47
4898         vb0(i, k-1, j) = vb0(i, k-1, j) + 7.*temp31b47
4899         vb0(i, k+1, j) = vb0(i, k+1, j) - temp31b47
4900         vb0(i, k-2, j) = vb0(i, k-2, j) - temp31b47
4901         vfluxb(i, k) = 0.0
4902         romb(i, k, j) = romb(i, k, j) + 0.5*velb
4903         romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
4904         k = kts + 1
4905         temp31b48 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i&
4906 &          , k)
4907         temp31b49 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
4908         romb(i, k, j) = romb(i, k, j) + temp31b48
4909         romb(i, k, j-1) = romb(i, k, j-1) + temp31b48
4910         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp31b49
4911         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp31b49
4912         vfluxb(i, k) = 0.0
4913       END DO
4914       DO k=ktf-2,kts+3,-1
4915         DO i=i_end,i_start,-1
4916           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
4917           temp31b43 = vel*vfluxb(i, k)/60.0
4918           velb = (37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1, j)+v(i, k-&
4919 &            2, j))+v(i, k+2, j)+v(i, k-3, j))*vfluxb(i, k)/60.0
4920           vb0(i, k, j) = vb0(i, k, j) + 37.*temp31b43
4921           vb0(i, k-1, j) = vb0(i, k-1, j) + 37.*temp31b43
4922           vb0(i, k+1, j) = vb0(i, k+1, j) - 8.*temp31b43
4923           vb0(i, k-2, j) = vb0(i, k-2, j) - 8.*temp31b43
4924           vb0(i, k+2, j) = vb0(i, k+2, j) + temp31b43
4925           vb0(i, k-3, j) = vb0(i, k-3, j) + temp31b43
4926           vfluxb(i, k) = 0.0
4927           romb(i, k, j) = romb(i, k, j) + 0.5*velb
4928           romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
4929         END DO
4930       END DO
4931     END DO
4932   ELSE IF (vert_order .EQ. 5) THEN
4933     DO j=j_start,j_end
4934       CALL PUSHINTEGER4(k)
4935     END DO
4936     vfluxb = 0.0
4937     DO j=j_end,j_start,-1
4938       DO k=ktf,kts,-1
4939         DO i=i_end,i_start,-1
4940           temp43b1 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j&
4941 &            ))
4942           vfluxb(i, k+1) = vfluxb(i, k+1) + temp43b1
4943           vfluxb(i, k) = vfluxb(i, k) - temp43b1
4944         END DO
4945       END DO
4946       CALL POPINTEGER4(k)
4947       DO i=i_end,i_start,-1
4948         k = ktf
4949         temp43b = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, &
4950 &          k)
4951         temp43b0 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
4952         romb(i, k, j) = romb(i, k, j) + temp43b
4953         romb(i, k, j-1) = romb(i, k, j-1) + temp43b
4954         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp43b0
4955         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp43b0
4956         vfluxb(i, k) = 0.0
4957         k = ktf - 1
4958         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
4959         temp39 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, &
4960 &          j))
4961         temp42 = SIGN(1., -vel)
4962         temp41 = temp42/12.0
4963         temp40 = SIGN(1, time_step)
4964         temp39b = vel*vfluxb(i, k)
4965         temp39b0 = temp39b/12.0
4966         temp39b1 = temp40*temp41*temp39b
4967         velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))&
4968 &          /12.0+temp40*(temp41*temp39))*vfluxb(i, k)
4969         vb0(i, k, j) = vb0(i, k, j) + 7.*temp39b0 - 3.*temp39b1
4970         vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp39b1 + 7.*temp39b0
4971         vb0(i, k+1, j) = vb0(i, k+1, j) + temp39b1 - temp39b0
4972         vb0(i, k-2, j) = vb0(i, k-2, j) - temp39b1 - temp39b0
4973         vfluxb(i, k) = 0.0
4974         romb(i, k, j) = romb(i, k, j) + 0.5*velb
4975         romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
4976         k = kts + 2
4977         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
4978         temp35 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, &
4979 &          j))
4980         temp38 = SIGN(1., -vel)
4981         temp37 = temp38/12.0
4982         temp36 = SIGN(1, time_step)
4983         temp35b = vel*vfluxb(i, k)
4984         temp35b0 = temp35b/12.0
4985         temp35b1 = temp36*temp37*temp35b
4986         velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))&
4987 &          /12.0+temp36*(temp37*temp35))*vfluxb(i, k)
4988         vb0(i, k, j) = vb0(i, k, j) + 7.*temp35b0 - 3.*temp35b1
4989         vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp35b1 + 7.*temp35b0
4990         vb0(i, k+1, j) = vb0(i, k+1, j) + temp35b1 - temp35b0
4991         vb0(i, k-2, j) = vb0(i, k-2, j) - temp35b1 - temp35b0
4992         vfluxb(i, k) = 0.0
4993         romb(i, k, j) = romb(i, k, j) + 0.5*velb
4994         romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
4995         k = kts + 1
4996         temp35b2 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i&
4997 &          , k)
4998         temp35b3 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
4999         romb(i, k, j) = romb(i, k, j) + temp35b2
5000         romb(i, k, j-1) = romb(i, k, j-1) + temp35b2
5001         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp35b3
5002         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp35b3
5003         vfluxb(i, k) = 0.0
5004       END DO
5005       DO k=ktf-2,kts+3,-1
5006         DO i=i_end,i_start,-1
5007           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
5008           temp31 = v(i, k+2, j) - v(i, k-3, j) + 10.*(v(i, k, j)-v(i, k-&
5009 &            1, j)) - 5.*(v(i, k+1, j)-v(i, k-2, j))
5010           temp34 = SIGN(1., -vel)
5011           temp33 = temp34/60.0
5012           temp32 = SIGN(1, time_step)
5013           temp31b51 = vel*vfluxb(i, k)
5014           temp31b52 = temp31b51/60.0
5015           temp31b53 = -(temp32*temp33*temp31b51)
5016           velb = ((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1, j)+v(i, k&
5017 &            -2, j))+v(i, k+2, j)+v(i, k-3, j))/60.0-temp32*(temp33*&
5018 &            temp31))*vfluxb(i, k)
5019           vb0(i, k, j) = vb0(i, k, j) + 10.*temp31b53 + 37.*temp31b52
5020           vb0(i, k-1, j) = vb0(i, k-1, j) + 37.*temp31b52 - 10.*&
5021 &            temp31b53
5022           vb0(i, k+1, j) = vb0(i, k+1, j) - 5.*temp31b53 - 8.*temp31b52
5023           vb0(i, k-2, j) = vb0(i, k-2, j) + 5.*temp31b53 - 8.*temp31b52
5024           vb0(i, k+2, j) = vb0(i, k+2, j) + temp31b53 + temp31b52
5025           vb0(i, k-3, j) = vb0(i, k-3, j) + temp31b52 - temp31b53
5026           vfluxb(i, k) = 0.0
5027           romb(i, k, j) = romb(i, k, j) + 0.5*velb
5028           romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
5029         END DO
5030       END DO
5031     END DO
5032   ELSE IF (vert_order .EQ. 4) THEN
5033     DO j=j_start,j_end
5034       CALL PUSHINTEGER4(k)
5035     END DO
5036     vfluxb = 0.0
5037     DO j=j_end,j_start,-1
5038       DO k=ktf,kts,-1
5039         DO i=i_end,i_start,-1
5040           temp43b7 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j&
5041 &            ))
5042           vfluxb(i, k+1) = vfluxb(i, k+1) + temp43b7
5043           vfluxb(i, k) = vfluxb(i, k) - temp43b7
5044         END DO
5045       END DO
5046       CALL POPINTEGER4(k)
5047       DO i=i_end,i_start,-1
5048         k = ktf
5049         temp43b3 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i&
5050 &          , k)
5051         temp43b4 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
5052         romb(i, k, j) = romb(i, k, j) + temp43b3
5053         romb(i, k, j-1) = romb(i, k, j-1) + temp43b3
5054         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp43b4
5055         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp43b4
5056         vfluxb(i, k) = 0.0
5057         k = kts + 1
5058         temp43b5 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i&
5059 &          , k)
5060         temp43b6 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
5061         romb(i, k, j) = romb(i, k, j) + temp43b5
5062         romb(i, k, j-1) = romb(i, k, j-1) + temp43b5
5063         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp43b6
5064         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp43b6
5065         vfluxb(i, k) = 0.0
5066       END DO
5067       DO k=ktf-1,kts+2,-1
5068         DO i=i_end,i_start,-1
5069           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
5070           temp43b2 = vel*vfluxb(i, k)/12.0
5071           velb = (7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j)&
5072 &            )*vfluxb(i, k)/12.0
5073           vb0(i, k, j) = vb0(i, k, j) + 7.*temp43b2
5074           vb0(i, k-1, j) = vb0(i, k-1, j) + 7.*temp43b2
5075           vb0(i, k+1, j) = vb0(i, k+1, j) - temp43b2
5076           vb0(i, k-2, j) = vb0(i, k-2, j) - temp43b2
5077           vfluxb(i, k) = 0.0
5078           romb(i, k, j) = romb(i, k, j) + 0.5*velb
5079           romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
5080         END DO
5081       END DO
5082     END DO
5083   ELSE IF (vert_order .EQ. 3) THEN
5084     DO j=j_start,j_end
5085       CALL PUSHINTEGER4(k)
5086     END DO
5087     vfluxb = 0.0
5088     DO j=j_end,j_start,-1
5089       DO k=ktf,kts,-1
5090         DO i=i_end,i_start,-1
5091           temp47b3 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j&
5092 &            ))
5093           vfluxb(i, k+1) = vfluxb(i, k+1) + temp47b3
5094           vfluxb(i, k) = vfluxb(i, k) - temp47b3
5095         END DO
5096       END DO
5097       CALL POPINTEGER4(k)
5098       DO i=i_end,i_start,-1
5099         k = ktf
5100         temp47b = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, &
5101 &          k)
5102         temp47b0 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
5103         romb(i, k, j) = romb(i, k, j) + temp47b
5104         romb(i, k, j-1) = romb(i, k, j-1) + temp47b
5105         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp47b0
5106         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp47b0
5107         vfluxb(i, k) = 0.0
5108         k = kts + 1
5109         temp47b1 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i&
5110 &          , k)
5111         temp47b2 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
5112         romb(i, k, j) = romb(i, k, j) + temp47b1
5113         romb(i, k, j-1) = romb(i, k, j-1) + temp47b1
5114         vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp47b2
5115         vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp47b2
5116         vfluxb(i, k) = 0.0
5117       END DO
5118       DO k=ktf-1,kts+2,-1
5119         DO i=i_end,i_start,-1
5120           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
5121           temp43 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1&
5122 &            , j))
5123           temp46 = SIGN(1., -vel)
5124           temp45 = temp46/12.0
5125           temp44 = SIGN(1, time_step)
5126           temp43b8 = vel*vfluxb(i, k)
5127           temp43b9 = temp43b8/12.0
5128           temp43b10 = temp44*temp45*temp43b8
5129           velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j&
5130 &            ))/12.0+temp44*(temp45*temp43))*vfluxb(i, k)
5131           vb0(i, k, j) = vb0(i, k, j) + 7.*temp43b9 - 3.*temp43b10
5132           vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp43b10 + 7.*temp43b9
5133           vb0(i, k+1, j) = vb0(i, k+1, j) + temp43b10 - temp43b9
5134           vb0(i, k-2, j) = vb0(i, k-2, j) - temp43b10 - temp43b9
5135           vfluxb(i, k) = 0.0
5136           romb(i, k, j) = romb(i, k, j) + 0.5*velb
5137           romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
5138         END DO
5139       END DO
5140     END DO
5141   ELSE IF (vert_order .EQ. 2) THEN
5142     vfluxb = 0.0
5143     DO j=j_end,j_start,-1
5144       DO k=ktf,kts,-1
5145         DO i=i_end,i_start,-1
5146           temp47b6 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j&
5147 &            ))
5148           vfluxb(i, k+1) = vfluxb(i, k+1) + temp47b6
5149           vfluxb(i, k) = vfluxb(i, k) - temp47b6
5150         END DO
5151       END DO
5152       DO k=ktf,kts+1,-1
5153         DO i=i_end,i_start,-1
5154           temp47b4 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(&
5155 &            i, k)
5156           temp47b5 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
5157           romb(i, k, j) = romb(i, k, j) + temp47b4
5158           romb(i, k, j-1) = romb(i, k, j-1) + temp47b4
5159           vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp47b5
5160           vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp47b5
5161           vfluxb(i, k) = 0.0
5162         END DO
5163       END DO
5164     END DO
5165   END IF
5166   CALL POPCONTROL1B(branch)
5167   IF (branch .EQ. 0) THEN
5168     CALL POPINTEGER4(i_end)
5169   ELSE
5170     CALL POPINTEGER4(i_end)
5171   END IF
5172   CALL POPINTEGER4(i_start)
5173   CALL POPCONTROL1B(branch)
5174   IF (branch .NE. 0) THEN
5175     CALL POPINTEGER4(ad_from52)
5176     CALL POPINTEGER4(ad_to52)
5177     DO j=ad_to52,ad_from52,-1
5178       DO k=ktf,kts,-1
5179         dum = ru(ite, k, jm) - ru(ite-1, k, jm)
5180         dup = ru(ite, k, jp) - ru(ite-1, k, jp)
5181         temp31b41 = -(mrdx*tendencyb(ite-1, k, j))
5182         temp31b42 = 0.5*v(ite-1, k, j)*temp31b41
5183         ubb = (v_old(ite-1, k, j)-v_old(ite-2, k, j))*temp31b41
5184         v_oldb(ite-1, k, j) = v_oldb(ite-1, k, j) + ub*temp31b41
5185         v_oldb(ite-2, k, j) = v_oldb(ite-2, k, j) - ub*temp31b41
5186         vb0(ite-1, k, j) = vb0(ite-1, k, j) + 0.5*(dup+dum)*temp31b41
5187         dupb = temp31b42
5188         dumb = temp31b42
5189         rub(ite, k, jm) = rub(ite, k, jm) + dumb
5190         rub(ite-1, k, jm) = rub(ite-1, k, jm) - dumb
5191         rub(ite, k, jp) = rub(ite, k, jp) + dupb
5192         rub(ite-1, k, jp) = rub(ite-1, k, jp) - dupb
5193         CALL POPCONTROL1B(branch)
5194         IF (branch .EQ. 0) THEN
5195           CALL POPREAL8(ub)
5196           uwb = 0.0
5197         ELSE
5198           CALL POPREAL8(ub)
5199           uwb = ubb
5200         END IF
5201         rub(ite, k, jp) = rub(ite, k, jp) + 0.5*uwb
5202         rub(ite, k, jm) = rub(ite, k, jm) + 0.5*uwb
5203       END DO
5204       CALL POPCONTROL1B(branch)
5205       IF (branch .EQ. 0) THEN
5206         CALL POPINTEGER4(jm)
5207       ELSE
5208         CALL POPINTEGER4(jm)
5209       END IF
5210       CALL POPCONTROL1B(branch)
5211       IF (branch .EQ. 0) THEN
5212         CALL POPINTEGER4(jp)
5213       ELSE
5214         CALL POPINTEGER4(jp)
5215       END IF
5216       CALL POPREAL8(mrdx)
5217     END DO
5218   END IF
5219   CALL POPCONTROL1B(branch)
5220   IF (branch .EQ. 0) THEN
5221     CALL POPINTEGER4(ad_from51)
5222     CALL POPINTEGER4(ad_to51)
5223     DO j=ad_to51,ad_from51,-1
5224       DO k=ktf,kts,-1
5225         dum = ru(its+1, k, jm) - ru(its, k, jm)
5226         dup = ru(its+1, k, jp) - ru(its, k, jp)
5227         temp31b39 = -(mrdx*tendencyb(its, k, j))
5228         temp31b40 = 0.5*v(its, k, j)*temp31b39
5229         ubb = (v_old(its+1, k, j)-v_old(its, k, j))*temp31b39
5230         v_oldb(its+1, k, j) = v_oldb(its+1, k, j) + ub*temp31b39
5231         v_oldb(its, k, j) = v_oldb(its, k, j) - ub*temp31b39
5232         vb0(its, k, j) = vb0(its, k, j) + 0.5*(dup+dum)*temp31b39
5233         dupb = temp31b40
5234         dumb = temp31b40
5235         rub(its+1, k, jm) = rub(its+1, k, jm) + dumb
5236         rub(its, k, jm) = rub(its, k, jm) - dumb
5237         rub(its+1, k, jp) = rub(its+1, k, jp) + dupb
5238         rub(its, k, jp) = rub(its, k, jp) - dupb
5239         CALL POPCONTROL1B(branch)
5240         IF (branch .EQ. 0) THEN
5241           CALL POPREAL8(ub)
5242           uwb = 0.0
5243         ELSE
5244           CALL POPREAL8(ub)
5245           uwb = ubb
5246         END IF
5247         rub(its, k, jp) = rub(its, k, jp) + 0.5*uwb
5248         rub(its, k, jm) = rub(its, k, jm) + 0.5*uwb
5249       END DO
5250       CALL POPCONTROL1B(branch)
5251       IF (branch .EQ. 0) THEN
5252         CALL POPINTEGER4(jm)
5253       ELSE
5254         CALL POPINTEGER4(jm)
5255       END IF
5256       CALL POPCONTROL1B(branch)
5257       IF (branch .EQ. 0) THEN
5258         CALL POPINTEGER4(jp)
5259       ELSE
5260         CALL POPINTEGER4(jp)
5261       END IF
5262       CALL POPREAL8(mrdx)
5263     END DO
5264   END IF
5265   CALL POPCONTROL1B(branch)
5266   IF (branch .NE. 0) THEN
5267     CALL POPINTEGER4(ad_from50)
5268     CALL POPINTEGER4(ad_to50)
5269     DO i=ad_to50,ad_from50,-1
5270       DO k=ktf,kts,-1
5271         temp31b38 = -(rdy*tendencyb(i, k, jte))
5272         vbb = (v_old(i, k, jte)-v_old(i, k, jte-1))*temp31b38
5273         v_oldb(i, k, jte) = v_oldb(i, k, jte) + vb*temp31b38
5274         v_oldb(i, k, jte-1) = v_oldb(i, k, jte-1) - vb*temp31b38
5275         CALL POPCONTROL1B(branch)
5276         IF (branch .EQ. 0) THEN
5277           CALL POPREAL8(vb)
5278         ELSE
5279           CALL POPREAL8(vb)
5280           rvb(i, k, jte) = rvb(i, k, jte) + vbb
5281           mutb(i, jte-1) = mutb(i, jte-1) + cb*vbb
5282         END IF
5283       END DO
5284     END DO
5285     CALL POPCONTROL1B(branch)
5286     IF (branch .EQ. 0) THEN
5287       CALL POPINTEGER4(i_end)
5288     ELSE
5289       CALL POPINTEGER4(i_end)
5290     END IF
5291     CALL POPINTEGER4(i_start)
5292   END IF
5293   CALL POPCONTROL1B(branch)
5294   IF (branch .EQ. 0) THEN
5295     CALL POPINTEGER4(ad_from49)
5296     CALL POPINTEGER4(ad_to49)
5297     DO i=ad_to49,ad_from49,-1
5298       DO k=ktf,kts,-1
5299         temp31b37 = -(rdy*tendencyb(i, k, jts))
5300         vbb = (v_old(i, k, jts+1)-v_old(i, k, jts))*temp31b37
5301         v_oldb(i, k, jts+1) = v_oldb(i, k, jts+1) + vb*temp31b37
5302         v_oldb(i, k, jts) = v_oldb(i, k, jts) - vb*temp31b37
5303         CALL POPCONTROL1B(branch)
5304         IF (branch .EQ. 0) THEN
5305           CALL POPREAL8(vb)
5306         ELSE
5307           CALL POPREAL8(vb)
5308           rvb(i, k, jts) = rvb(i, k, jts) + vbb
5309           mutb(i, jts) = mutb(i, jts) - cb*vbb
5310         END IF
5311       END DO
5312     END DO
5313     CALL POPCONTROL1B(branch)
5314     IF (branch .EQ. 0) THEN
5315       CALL POPINTEGER4(i_end)
5316     ELSE
5317       CALL POPINTEGER4(i_end)
5318     END IF
5319     CALL POPINTEGER4(i_start)
5320   END IF
5321   CALL POPCONTROL1B(branch)
5322   IF (branch .EQ. 0) THEN
5323     DO i=ite,its,-1
5324       DO k=ktf,kts,-1
5325         tendencyb(i, k, jte) = 0.0
5326       END DO
5327     END DO
5328   END IF
5329   CALL POPCONTROL1B(branch)
5330   IF (branch .EQ. 0) THEN
5331     DO i=ite,its,-1
5332       DO k=ktf,kts,-1
5333         tendencyb(i, k, jts) = 0.0
5334       END DO
5335     END DO
5336   END IF
5337   CALL POPCONTROL3B(branch)
5338   IF (branch .LT. 3) THEN
5339     IF (branch .EQ. 0) THEN
5340       fqxb = 0.0
5341       CALL POPINTEGER4(ad_from48)
5342       CALL POPINTEGER4(ad_to48)
5343       DO j=ad_to48,ad_from48,-1
5344         DO k=ktf,kts,-1
5345           CALL POPINTEGER4(ad_from47)
5346           CALL POPINTEGER4(ad_to47)
5347           DO i=ad_to47,ad_from47,-1
5348             mrdx = msfvy(i, j)*rdx
5349             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
5350             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
5351           END DO
5352         END DO
5353         CALL POPCONTROL1B(branch)
5354         IF (branch .NE. 0) THEN
5355           CALL POPINTEGER4(ad_to46)
5356           DO i=ad_to46,i_end_f+1,-1
5357             CALL POPCONTROL1B(branch)
5358             IF (branch .NE. 0) THEN
5359               DO k=ktf,kts,-1
5360                 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5361                 temp31b36 = vel*fqxb(i, k)/12.0
5362                 velb = (7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2&
5363 &                  , k, j))*fqxb(i, k)/12.0
5364                 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b36
5365                 vb0(i-1, k, j) = vb0(i-1, k, j) + 7.*temp31b36
5366                 vb0(i+1, k, j) = vb0(i+1, k, j) - temp31b36
5367                 vb0(i-2, k, j) = vb0(i-2, k, j) - temp31b36
5368                 fqxb(i, k) = 0.0
5369                 rub(i, k, j) = rub(i, k, j) + 0.5*velb
5370                 rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5371               END DO
5372             END IF
5373             CALL POPCONTROL1B(branch)
5374             IF (branch .EQ. 0) THEN
5375               DO k=ktf,kts,-1
5376                 temp31b34 = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(&
5377 &                  i, k)
5378                 temp31b35 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))&
5379 &                  *fqxb(i, k)
5380                 rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp31b34
5381                 rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp31b34
5382                 vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp31b35
5383                 vb0(i_end, k, j) = vb0(i_end, k, j) + temp31b35
5384                 fqxb(i, k) = 0.0
5385               END DO
5386             END IF
5387           END DO
5388         END IF
5389         CALL POPCONTROL1B(branch)
5390         IF (branch .EQ. 0) THEN
5391           CALL POPINTEGER4(ad_from46)
5392           DO i=i_start_f-1,ad_from46,-1
5393             CALL POPCONTROL1B(branch)
5394             IF (branch .NE. 0) THEN
5395               DO k=ktf,kts,-1
5396                 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5397                 temp31b33 = vel*fqxb(i, k)/12.0
5398                 velb = (7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2&
5399 &                  , k, j))*fqxb(i, k)/12.0
5400                 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b33
5401                 vb0(i-1, k, j) = vb0(i-1, k, j) + 7.*temp31b33
5402                 vb0(i+1, k, j) = vb0(i+1, k, j) - temp31b33
5403                 vb0(i-2, k, j) = vb0(i-2, k, j) - temp31b33
5404                 fqxb(i, k) = 0.0
5405                 rub(i, k, j) = rub(i, k, j) + 0.5*velb
5406                 rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5407               END DO
5408             END IF
5409             CALL POPCONTROL1B(branch)
5410             IF (branch .EQ. 0) THEN
5411               DO k=ktf,kts,-1
5412                 temp31b31 = 0.25*(v(i, k, j)+v(i-1, k, j))*fqxb(i, k)
5413                 temp31b32 = 0.25*(ru(i, k, j)+ru(i, k, j-1))*fqxb(i, k)
5414                 rub(i, k, j) = rub(i, k, j) + temp31b31
5415                 rub(i, k, j-1) = rub(i, k, j-1) + temp31b31
5416                 vb0(i, k, j) = vb0(i, k, j) + temp31b32
5417                 vb0(i-1, k, j) = vb0(i-1, k, j) + temp31b32
5418                 fqxb(i, k) = 0.0
5419               END DO
5420             END IF
5421           END DO
5422         END IF
5423         DO k=ktf,kts,-1
5424           DO i=i_end_f,i_start_f,-1
5425             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5426             temp31b30 = vel*fqxb(i, k)/60.0
5427             velb = (37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, j)+v(i-2&
5428 &              , k, j))+v(i+2, k, j)+v(i-3, k, j))*fqxb(i, k)/60.0
5429             vb0(i, k, j) = vb0(i, k, j) + 37.*temp31b30
5430             vb0(i-1, k, j) = vb0(i-1, k, j) + 37.*temp31b30
5431             vb0(i+1, k, j) = vb0(i+1, k, j) - 8.*temp31b30
5432             vb0(i-2, k, j) = vb0(i-2, k, j) - 8.*temp31b30
5433             vb0(i+2, k, j) = vb0(i+2, k, j) + temp31b30
5434             vb0(i-3, k, j) = vb0(i-3, k, j) + temp31b30
5435             fqxb(i, k) = 0.0
5436             rub(i, k, j) = rub(i, k, j) + 0.5*velb
5437             rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5438           END DO
5439         END DO
5440       END DO
5441       fqyb = 0.0
5442       CALL POPINTEGER4(ad_from45)
5443       CALL POPINTEGER4(ad_to45)
5444       DO j=ad_to45,ad_from45,-1
5445         CALL POPINTEGER4(jp0)
5446         CALL POPINTEGER4(jp1)
5447         CALL POPCONTROL2B(branch)
5448         IF (branch .LT. 2) THEN
5449           IF (branch .EQ. 0) THEN
5450             DO k=ktf,kts,-1
5451               CALL POPINTEGER4(ad_from42)
5452               CALL POPINTEGER4(ad_to42)
5453               DO i=ad_to42,ad_from42,-1
5454                 tendencyb(i, k, j-1) = 0.0
5455               END DO
5456             END DO
5457           ELSE
5458             DO k=ktf,kts,-1
5459               CALL POPINTEGER4(ad_from43)
5460               CALL POPINTEGER4(ad_to43)
5461               DO i=ad_to43,ad_from43,-1
5462                 tendencyb(i, k, j-1) = 0.0
5463               END DO
5464             END DO
5465           END IF
5466         ELSE IF (branch .EQ. 2) THEN
5467           DO k=ktf,kts,-1
5468             CALL POPINTEGER4(ad_from44)
5469             CALL POPINTEGER4(ad_to44)
5470             DO i=ad_to44,ad_from44,-1
5471               mrdy = msfvy(i, j-1)*rdy
5472               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
5473 &                -1)
5474               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
5475 &                -1)
5476             END DO
5477           END DO
5478         END IF
5479         CALL POPCONTROL3B(branch)
5480         IF (branch .LT. 3) THEN
5481           IF (branch .EQ. 0) THEN
5482             DO k=ktf,kts,-1
5483               CALL POPINTEGER4(ad_from37)
5484               CALL POPINTEGER4(ad_to37)
5485               DO i=ad_to37,ad_from37,-1
5486                 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
5487                 temp31b23 = vel*fqyb(i, k, jp1)/60.0
5488                 velb = (37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i, k, j+1)+v&
5489 &                  (i, k, j-2))+v(i, k, j+2)+v(i, k, j-3))*fqyb(i, k, jp1&
5490 &                  )/60.0
5491                 vb0(i, k, j) = vb0(i, k, j) + 37.*temp31b23
5492                 vb0(i, k, j-1) = vb0(i, k, j-1) + 37.*temp31b23
5493                 vb0(i, k, j+1) = vb0(i, k, j+1) - 8.*temp31b23
5494                 vb0(i, k, j-2) = vb0(i, k, j-2) - 8.*temp31b23
5495                 vb0(i, k, j+2) = vb0(i, k, j+2) + temp31b23
5496                 vb0(i, k, j-3) = vb0(i, k, j-3) + temp31b23
5497                 fqyb(i, k, jp1) = 0.0
5498                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
5499                 rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
5500               END DO
5501             END DO
5502           ELSE IF (branch .EQ. 1) THEN
5503             DO k=ktf,kts,-1
5504               CALL POPINTEGER4(ad_from38)
5505               CALL POPINTEGER4(ad_to38)
5506               DO i=ad_to38,ad_from38,-1
5507                 temp31b24 = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1)
5508                 temp31b25 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, &
5509 &                  jp1)
5510                 rvb(i, k, j) = rvb(i, k, j) + temp31b24
5511                 rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b24
5512                 vb0(i, k, j) = vb0(i, k, j) + temp31b25
5513                 vbb = temp31b25
5514                 fqyb(i, k, jp1) = 0.0
5515                 CALL POPCONTROL1B(branch)
5516                 IF (branch .EQ. 0) THEN
5517                   vb0(i, k, j) = vb0(i, k, j) + vbb
5518                   vbb = 0.0
5519                 END IF
5520                 CALL POPREAL8(vb)
5521                 vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
5522               END DO
5523             END DO
5524           ELSE
5525             DO k=ktf,kts,-1
5526               CALL POPINTEGER4(ad_from39)
5527               CALL POPINTEGER4(ad_to39)
5528               DO i=ad_to39,ad_from39,-1
5529                 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
5530                 temp31b26 = vel*fqyb(i, k, jp1)/12.0
5531                 velb = (7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k&
5532 &                  , j-2))*fqyb(i, k, jp1)/12.0
5533                 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b26
5534                 vb0(i, k, j-1) = vb0(i, k, j-1) + 7.*temp31b26
5535                 vb0(i, k, j+1) = vb0(i, k, j+1) - temp31b26
5536                 vb0(i, k, j-2) = vb0(i, k, j-2) - temp31b26
5537                 fqyb(i, k, jp1) = 0.0
5538                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
5539                 rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
5540               END DO
5541             END DO
5542           END IF
5543         ELSE IF (branch .EQ. 3) THEN
5544           DO k=ktf,kts,-1
5545             CALL POPINTEGER4(ad_from40)
5546             CALL POPINTEGER4(ad_to40)
5547             DO i=ad_to40,ad_from40,-1
5548               temp31b27 = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1)
5549               temp31b28 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, &
5550 &                jp1)
5551               rvb(i, k, j) = rvb(i, k, j) + temp31b27
5552               rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b27
5553               vbb = temp31b28
5554               vb0(i, k, j-1) = vb0(i, k, j-1) + temp31b28
5555               fqyb(i, k, jp1) = 0.0
5556               CALL POPCONTROL1B(branch)
5557               IF (branch .EQ. 0) THEN
5558                 vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
5559                 vbb = 0.0
5560               END IF
5561               CALL POPREAL8(vb)
5562               vb0(i, k, j) = vb0(i, k, j) + vbb
5563             END DO
5564           END DO
5565         ELSE IF (branch .EQ. 4) THEN
5566           DO k=ktf,kts,-1
5567             CALL POPINTEGER4(ad_from41)
5568             CALL POPINTEGER4(ad_to41)
5569             DO i=ad_to41,ad_from41,-1
5570               vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
5571               temp31b29 = vel*fqyb(i, k, jp1)/12.0
5572               velb = (7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, &
5573 &                j-2))*fqyb(i, k, jp1)/12.0
5574               vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b29
5575               vb0(i, k, j-1) = vb0(i, k, j-1) + 7.*temp31b29
5576               vb0(i, k, j+1) = vb0(i, k, j+1) - temp31b29
5577               vb0(i, k, j-2) = vb0(i, k, j-2) - temp31b29
5578               fqyb(i, k, jp1) = 0.0
5579               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
5580               rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
5581             END DO
5582           END DO
5583         END IF
5584       END DO
5585     ELSE IF (branch .EQ. 1) THEN
5586       fqxb = 0.0
5587       CALL POPINTEGER4(ad_from10)
5588       CALL POPINTEGER4(ad_to10)
5589       DO j=ad_to10,ad_from10,-1
5590         DO k=ktf,kts,-1
5591           CALL POPINTEGER4(ad_from9)
5592           CALL POPINTEGER4(ad_to9)
5593           DO i=ad_to9,ad_from9,-1
5594             mrdx = msfvy(i, j)*rdx
5595             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
5596             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
5597           END DO
5598         END DO
5599         CALL POPCONTROL1B(branch)
5600         IF (branch .NE. 0) THEN
5601           CALL POPINTEGER4(ad_to8)
5602           DO i=ad_to8,i_end_f+1,-1
5603             CALL POPCONTROL1B(branch)
5604             IF (branch .NE. 0) THEN
5605               DO k=ktf,kts,-1
5606                 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5607                 temp19 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(&
5608 &                  i-1, k, j))
5609                 temp22 = SIGN(1., vel)
5610                 temp21 = temp22/12.0
5611                 temp20 = SIGN(1, time_step)
5612                 temp19b1 = vel*fqxb(i, k)
5613                 temp19b2 = temp19b1/12.0
5614                 temp19b3 = temp20*temp21*temp19b1
5615                 velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2&
5616 &                  , k, j))/12.0+temp20*(temp21*temp19))*fqxb(i, k)
5617                 vb0(i, k, j) = vb0(i, k, j) + 7.*temp19b2 - 3.*temp19b3
5618                 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp19b3 + 7.*&
5619 &                  temp19b2
5620                 vb0(i+1, k, j) = vb0(i+1, k, j) + temp19b3 - temp19b2
5621                 vb0(i-2, k, j) = vb0(i-2, k, j) - temp19b3 - temp19b2
5622                 fqxb(i, k) = 0.0
5623                 rub(i, k, j) = rub(i, k, j) + 0.5*velb
5624                 rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5625               END DO
5626             END IF
5627             CALL POPCONTROL1B(branch)
5628             IF (branch .EQ. 0) THEN
5629               DO k=ktf,kts,-1
5630                 temp19b = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i&
5631 &                  , k)
5632                 temp19b0 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*&
5633 &                  fqxb(i, k)
5634                 rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp19b
5635                 rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp19b
5636                 vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp19b0
5637                 vb0(i_end, k, j) = vb0(i_end, k, j) + temp19b0
5638                 fqxb(i, k) = 0.0
5639               END DO
5640             END IF
5641           END DO
5642         END IF
5643         CALL POPCONTROL1B(branch)
5644         IF (branch .EQ. 0) THEN
5645           CALL POPINTEGER4(ad_from8)
5646           DO i=i_start_f-1,ad_from8,-1
5647             CALL POPCONTROL1B(branch)
5648             IF (branch .NE. 0) THEN
5649               DO k=ktf,kts,-1
5650                 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5651                 temp15 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(&
5652 &                  i-1, k, j))
5653                 temp18 = SIGN(1., vel)
5654                 temp17 = temp18/12.0
5655                 temp16 = SIGN(1, time_step)
5656                 temp15b1 = vel*fqxb(i, k)
5657                 temp15b2 = temp15b1/12.0
5658                 temp15b3 = temp16*temp17*temp15b1
5659                 velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2&
5660 &                  , k, j))/12.0+temp16*(temp17*temp15))*fqxb(i, k)
5661                 vb0(i, k, j) = vb0(i, k, j) + 7.*temp15b2 - 3.*temp15b3
5662                 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp15b3 + 7.*&
5663 &                  temp15b2
5664                 vb0(i+1, k, j) = vb0(i+1, k, j) + temp15b3 - temp15b2
5665                 vb0(i-2, k, j) = vb0(i-2, k, j) - temp15b3 - temp15b2
5666                 fqxb(i, k) = 0.0
5667                 rub(i, k, j) = rub(i, k, j) + 0.5*velb
5668                 rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5669               END DO
5670             END IF
5671             CALL POPCONTROL1B(branch)
5672             IF (branch .EQ. 0) THEN
5673               DO k=ktf,kts,-1
5674                 temp15b = 0.25*(v(i, k, j)+v(i-1, k, j))*fqxb(i, k)
5675                 temp15b0 = 0.25*(ru(i, k, j)+ru(i, k, j-1))*fqxb(i, k)
5676                 rub(i, k, j) = rub(i, k, j) + temp15b
5677                 rub(i, k, j-1) = rub(i, k, j-1) + temp15b
5678                 vb0(i, k, j) = vb0(i, k, j) + temp15b0
5679                 vb0(i-1, k, j) = vb0(i-1, k, j) + temp15b0
5680                 fqxb(i, k) = 0.0
5681               END DO
5682             END IF
5683           END DO
5684         END IF
5685         DO k=ktf,kts,-1
5686           DO i=i_end_f,i_start_f,-1
5687             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5688             temp11 = v(i+2, k, j) - v(i-3, k, j) + 10.*(v(i, k, j)-v(i-1&
5689 &              , k, j)) - 5.*(v(i+1, k, j)-v(i-2, k, j))
5690             temp14 = SIGN(1., vel)
5691             temp13 = temp14/60.0
5692             temp12 = SIGN(1, time_step)
5693             temp11b = vel*fqxb(i, k)
5694             temp11b0 = temp11b/60.0
5695             temp11b1 = -(temp12*temp13*temp11b)
5696             velb = ((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, j)+v(i-&
5697 &              2, k, j))+v(i+2, k, j)+v(i-3, k, j))/60.0-temp12*(temp13*&
5698 &              temp11))*fqxb(i, k)
5699             vb0(i, k, j) = vb0(i, k, j) + 10.*temp11b1 + 37.*temp11b0
5700             vb0(i-1, k, j) = vb0(i-1, k, j) + 37.*temp11b0 - 10.*&
5701 &              temp11b1
5702             vb0(i+1, k, j) = vb0(i+1, k, j) - 5.*temp11b1 - 8.*temp11b0
5703             vb0(i-2, k, j) = vb0(i-2, k, j) + 5.*temp11b1 - 8.*temp11b0
5704             vb0(i+2, k, j) = vb0(i+2, k, j) + temp11b1 + temp11b0
5705             vb0(i-3, k, j) = vb0(i-3, k, j) + temp11b0 - temp11b1
5706             fqxb(i, k) = 0.0
5707             rub(i, k, j) = rub(i, k, j) + 0.5*velb
5708             rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5709           END DO
5710         END DO
5711       END DO
5712       fqyb = 0.0
5713       CALL POPINTEGER4(ad_from7)
5714       CALL POPINTEGER4(ad_to7)
5715       DO j=ad_to7,ad_from7,-1
5716         CALL POPINTEGER4(jp0)
5717         CALL POPINTEGER4(jp1)
5718         CALL POPCONTROL2B(branch)
5719         IF (branch .LT. 2) THEN
5720           IF (branch .EQ. 0) THEN
5721             DO k=ktf,kts,-1
5722               CALL POPINTEGER4(ad_from4)
5723               CALL POPINTEGER4(ad_to4)
5724               DO i=ad_to4,ad_from4,-1
5725                 tendencyb(i, k, j-1) = 0.0
5726               END DO
5727             END DO
5728           ELSE
5729             DO k=ktf,kts,-1
5730               CALL POPINTEGER4(ad_from5)
5731               CALL POPINTEGER4(ad_to5)
5732               DO i=ad_to5,ad_from5,-1
5733                 tendencyb(i, k, j-1) = 0.0
5734               END DO
5735             END DO
5736           END IF
5737         ELSE IF (branch .EQ. 2) THEN
5738           DO k=ktf,kts,-1
5739             CALL POPINTEGER4(ad_from6)
5740             CALL POPINTEGER4(ad_to6)
5741             DO i=ad_to6,ad_from6,-1
5742               mrdy = msfvy(i, j-1)*rdy
5743               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
5744 &                -1)
5745               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
5746 &                -1)
5747             END DO
5748           END DO
5749         END IF
5750         CALL POPCONTROL3B(branch)
5751         IF (branch .LT. 3) THEN
5752           IF (branch .EQ. 0) THEN
5753             DO k=ktf,kts,-1
5754               CALL POPINTEGER4(ad_from)
5755               CALL POPINTEGER4(ad_to)
5756               DO i=ad_to,ad_from,-1
5757                 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
5758                 temp = v(i, k, j+2) - v(i, k, j-3) + 10.*(v(i, k, j)-v(i&
5759 &                  , k, j-1)) - 5.*(v(i, k, j+1)-v(i, k, j-2))
5760                 temp2 = SIGN(1., vel)
5761                 temp1 = temp2/60.0
5762                 temp0 = SIGN(1, time_step)
5763                 tempb = vel*fqyb(i, k, jp1)
5764                 tempb0 = tempb/60.0
5765                 tempb1 = -(temp0*temp1*tempb)
5766                 velb = ((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i, k, j+1)+&
5767 &                  v(i, k, j-2))+v(i, k, j+2)+v(i, k, j-3))/60.0-temp0*(&
5768 &                  temp1*temp))*fqyb(i, k, jp1)
5769                 vb0(i, k, j) = vb0(i, k, j) + 10.*tempb1 + 37.*tempb0
5770                 vb0(i, k, j-1) = vb0(i, k, j-1) + 37.*tempb0 - 10.*&
5771 &                  tempb1
5772                 vb0(i, k, j+1) = vb0(i, k, j+1) - 5.*tempb1 - 8.*tempb0
5773                 vb0(i, k, j-2) = vb0(i, k, j-2) + 5.*tempb1 - 8.*tempb0
5774                 vb0(i, k, j+2) = vb0(i, k, j+2) + tempb1 + tempb0
5775                 vb0(i, k, j-3) = vb0(i, k, j-3) + tempb0 - tempb1
5776                 fqyb(i, k, jp1) = 0.0
5777                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
5778                 rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
5779               END DO
5780             END DO
5781           ELSE IF (branch .EQ. 1) THEN
5782             DO k=ktf,kts,-1
5783               CALL POPINTEGER4(ad_from0)
5784               CALL POPINTEGER4(ad_to0)
5785               DO i=ad_to0,ad_from0,-1
5786                 temp3b = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1)
5787                 temp3b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, &
5788 &                  jp1)
5789                 rvb(i, k, j) = rvb(i, k, j) + temp3b
5790                 rvb(i, k, j-1) = rvb(i, k, j-1) + temp3b
5791                 vb0(i, k, j) = vb0(i, k, j) + temp3b0
5792                 vbb = temp3b0
5793                 fqyb(i, k, jp1) = 0.0
5794                 CALL POPCONTROL1B(branch)
5795                 IF (branch .EQ. 0) THEN
5796                   vb0(i, k, j) = vb0(i, k, j) + vbb
5797                   vbb = 0.0
5798                 END IF
5799                 CALL POPREAL8(vb)
5800                 vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
5801               END DO
5802             END DO
5803           ELSE
5804             DO k=ktf,kts,-1
5805               CALL POPINTEGER4(ad_from1)
5806               CALL POPINTEGER4(ad_to1)
5807               DO i=ad_to1,ad_from1,-1
5808                 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
5809                 temp3 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i&
5810 &                  , k, j-1))
5811                 temp6 = SIGN(1., vel)
5812                 temp5 = temp6/12.0
5813                 temp4 = SIGN(1, time_step)
5814                 temp3b1 = vel*fqyb(i, k, jp1)
5815                 temp3b2 = temp3b1/12.0
5816                 temp3b3 = temp4*temp5*temp3b1
5817                 velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, &
5818 &                  k, j-2))/12.0+temp4*(temp5*temp3))*fqyb(i, k, jp1)
5819                 vb0(i, k, j) = vb0(i, k, j) + 7.*temp3b2 - 3.*temp3b3
5820                 vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp3b3 + 7.*&
5821 &                  temp3b2
5822                 vb0(i, k, j+1) = vb0(i, k, j+1) + temp3b3 - temp3b2
5823                 vb0(i, k, j-2) = vb0(i, k, j-2) - temp3b3 - temp3b2
5824                 fqyb(i, k, jp1) = 0.0
5825                 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
5826                 rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
5827               END DO
5828             END DO
5829           END IF
5830         ELSE IF (branch .EQ. 3) THEN
5831           DO k=ktf,kts,-1
5832             CALL POPINTEGER4(ad_from2)
5833             CALL POPINTEGER4(ad_to2)
5834             DO i=ad_to2,ad_from2,-1
5835               temp7b = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1)
5836               temp7b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1)
5837               rvb(i, k, j) = rvb(i, k, j) + temp7b
5838               rvb(i, k, j-1) = rvb(i, k, j-1) + temp7b
5839               vbb = temp7b0
5840               vb0(i, k, j-1) = vb0(i, k, j-1) + temp7b0
5841               fqyb(i, k, jp1) = 0.0
5842               CALL POPCONTROL1B(branch)
5843               IF (branch .EQ. 0) THEN
5844                 vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
5845                 vbb = 0.0
5846               END IF
5847               CALL POPREAL8(vb)
5848               vb0(i, k, j) = vb0(i, k, j) + vbb
5849             END DO
5850           END DO
5851         ELSE IF (branch .EQ. 4) THEN
5852           DO k=ktf,kts,-1
5853             CALL POPINTEGER4(ad_from3)
5854             CALL POPINTEGER4(ad_to3)
5855             DO i=ad_to3,ad_from3,-1
5856               vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
5857               temp7 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, &
5858 &                k, j-1))
5859               temp10 = SIGN(1., vel)
5860               temp9 = temp10/12.0
5861               temp8 = SIGN(1, time_step)
5862               temp7b1 = vel*fqyb(i, k, jp1)
5863               temp7b2 = temp7b1/12.0
5864               temp7b3 = temp8*temp9*temp7b1
5865               velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k&
5866 &                , j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, jp1)
5867               vb0(i, k, j) = vb0(i, k, j) + 7.*temp7b2 - 3.*temp7b3
5868               vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp7b3 + 7.*temp7b2
5869               vb0(i, k, j+1) = vb0(i, k, j+1) + temp7b3 - temp7b2
5870               vb0(i, k, j-2) = vb0(i, k, j-2) - temp7b3 - temp7b2
5871               fqyb(i, k, jp1) = 0.0
5872               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
5873               rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
5874             END DO
5875           END DO
5876         END IF
5877       END DO
5878     ELSE
5879       fqxb = 0.0
5880       CALL POPINTEGER4(ad_from19)
5881       CALL POPINTEGER4(ad_to19)
5882       DO j=ad_to19,ad_from19,-1
5883         DO k=ktf,kts,-1
5884           CALL POPINTEGER4(ad_from18)
5885           CALL POPINTEGER4(ad_to18)
5886           DO i=ad_to18,ad_from18,-1
5887             mrdx = msfvy(i, j)*rdx
5888             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
5889             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
5890           END DO
5891         END DO
5892         CALL POPCONTROL1B(branch)
5893         IF (branch .NE. 0) THEN
5894           DO k=ktf,kts,-1
5895             temp23b7 = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i_end&
5896 &              +1, k)
5897             temp23b8 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*fqxb&
5898 &              (i_end+1, k)
5899             rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp23b7
5900             rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp23b7
5901             vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp23b8
5902             vb0(i_end, k, j) = vb0(i_end, k, j) + temp23b8
5903             fqxb(i_end+1, k) = 0.0
5904           END DO
5905         END IF
5906         CALL POPCONTROL1B(branch)
5907         IF (branch .EQ. 0) THEN
5908           DO k=ktf,kts,-1
5909             temp23b5 = 0.25*(v(i_start, k, j)+v(i_start-1, k, j))*fqxb(&
5910 &              i_start, k)
5911             temp23b6 = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))*fqxb&
5912 &              (i_start, k)
5913             rub(i_start, k, j) = rub(i_start, k, j) + temp23b5
5914             rub(i_start, k, j-1) = rub(i_start, k, j-1) + temp23b5
5915             vb0(i_start, k, j) = vb0(i_start, k, j) + temp23b6
5916             vb0(i_start-1, k, j) = vb0(i_start-1, k, j) + temp23b6
5917             fqxb(i_start, k) = 0.0
5918           END DO
5919         END IF
5920         DO k=ktf,kts,-1
5921           DO i=i_end_f,i_start_f,-1
5922             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
5923             temp23b4 = vel*fqxb(i, k)/12.0
5924             velb = (7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k, &
5925 &              j))*fqxb(i, k)/12.0
5926             vb0(i, k, j) = vb0(i, k, j) + 7.*temp23b4
5927             vb0(i-1, k, j) = vb0(i-1, k, j) + 7.*temp23b4
5928             vb0(i+1, k, j) = vb0(i+1, k, j) - temp23b4
5929             vb0(i-2, k, j) = vb0(i-2, k, j) - temp23b4
5930             fqxb(i, k) = 0.0
5931             rub(i, k, j) = rub(i, k, j) + 0.5*velb
5932             rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
5933           END DO
5934         END DO
5935       END DO
5936       fqyb = 0.0
5937       CALL POPINTEGER4(ad_from17)
5938       CALL POPINTEGER4(ad_to17)
5939       DO j=ad_to17,ad_from17,-1
5940         CALL POPINTEGER4(jp0)
5941         CALL POPINTEGER4(jp1)
5942         CALL POPCONTROL2B(branch)
5943         IF (branch .LT. 2) THEN
5944           IF (branch .EQ. 0) THEN
5945             DO k=ktf,kts,-1
5946               CALL POPINTEGER4(ad_from14)
5947               CALL POPINTEGER4(ad_to14)
5948               DO i=ad_to14,ad_from14,-1
5949                 tendencyb(i, k, j-1) = 0.0
5950               END DO
5951             END DO
5952           ELSE
5953             DO k=ktf,kts,-1
5954               CALL POPINTEGER4(ad_from15)
5955               CALL POPINTEGER4(ad_to15)
5956               DO i=ad_to15,ad_from15,-1
5957                 tendencyb(i, k, j-1) = 0.0
5958               END DO
5959             END DO
5960           END IF
5961         ELSE IF (branch .EQ. 2) THEN
5962           DO k=ktf,kts,-1
5963             CALL POPINTEGER4(ad_from16)
5964             CALL POPINTEGER4(ad_to16)
5965             DO i=ad_to16,ad_from16,-1
5966               mrdy = msfvy(i, j-1)*rdy
5967               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
5968 &                -1)
5969               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
5970 &                -1)
5971             END DO
5972           END DO
5973         END IF
5974         CALL POPCONTROL2B(branch)
5975         IF (branch .EQ. 0) THEN
5976           DO k=ktf,kts,-1
5977             CALL POPINTEGER4(ad_from11)
5978             CALL POPINTEGER4(ad_to11)
5979             DO i=ad_to11,ad_from11,-1
5980               temp23b = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1)
5981               temp23b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1&
5982 &                )
5983               rvb(i, k, j) = rvb(i, k, j) + temp23b
5984               rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b
5985               vb0(i, k, j) = vb0(i, k, j) + temp23b0
5986               vbb = temp23b0
5987               fqyb(i, k, jp1) = 0.0
5988               CALL POPCONTROL1B(branch)
5989               IF (branch .EQ. 0) THEN
5990                 vb0(i, k, j) = vb0(i, k, j) + vbb
5991                 vbb = 0.0
5992               END IF
5993               CALL POPREAL8(vb)
5994               vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
5995             END DO
5996           END DO
5997         ELSE IF (branch .EQ. 1) THEN
5998           DO k=ktf,kts,-1
5999             CALL POPINTEGER4(ad_from12)
6000             CALL POPINTEGER4(ad_to12)
6001             DO i=ad_to12,ad_from12,-1
6002               temp23b1 = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1)
6003               temp23b2 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1&
6004 &                )
6005               rvb(i, k, j) = rvb(i, k, j) + temp23b1
6006               rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b1
6007               vbb = temp23b2
6008               vb0(i, k, j-1) = vb0(i, k, j-1) + temp23b2
6009               fqyb(i, k, jp1) = 0.0
6010               CALL POPCONTROL1B(branch)
6011               IF (branch .EQ. 0) THEN
6012                 vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
6013                 vbb = 0.0
6014               END IF
6015               CALL POPREAL8(vb)
6016               vb0(i, k, j) = vb0(i, k, j) + vbb
6017             END DO
6018           END DO
6019         ELSE
6020           DO k=ktf,kts,-1
6021             CALL POPINTEGER4(ad_from13)
6022             CALL POPINTEGER4(ad_to13)
6023             DO i=ad_to13,ad_from13,-1
6024               vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
6025               temp23b3 = vel*fqyb(i, k, jp1)/12.0
6026               velb = (7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, &
6027 &                j-2))*fqyb(i, k, jp1)/12.0
6028               vb0(i, k, j) = vb0(i, k, j) + 7.*temp23b3
6029               vb0(i, k, j-1) = vb0(i, k, j-1) + 7.*temp23b3
6030               vb0(i, k, j+1) = vb0(i, k, j+1) - temp23b3
6031               vb0(i, k, j-2) = vb0(i, k, j-2) - temp23b3
6032               fqyb(i, k, jp1) = 0.0
6033               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
6034               rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
6035             END DO
6036           END DO
6037         END IF
6038       END DO
6039     END IF
6040   ELSE IF (branch .EQ. 3) THEN
6041     fqxb = 0.0
6042     CALL POPINTEGER4(ad_from28)
6043     CALL POPINTEGER4(ad_to28)
6044     DO j=ad_to28,ad_from28,-1
6045       DO k=ktf,kts,-1
6046         CALL POPINTEGER4(ad_from27)
6047         CALL POPINTEGER4(ad_to27)
6048         DO i=ad_to27,ad_from27,-1
6049           mrdx = msfvy(i, j)*rdx
6050           fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
6051           fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
6052         END DO
6053       END DO
6054       CALL POPCONTROL1B(branch)
6055       IF (branch .NE. 0) THEN
6056         DO k=ktf,kts,-1
6057           temp31b1 = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i_end+1&
6058 &            , k)
6059           temp31b2 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*fqxb(&
6060 &            i_end+1, k)
6061           rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp31b1
6062           rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp31b1
6063           vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp31b2
6064           vb0(i_end, k, j) = vb0(i_end, k, j) + temp31b2
6065           fqxb(i_end+1, k) = 0.0
6066         END DO
6067       END IF
6068       CALL POPCONTROL1B(branch)
6069       IF (branch .EQ. 0) THEN
6070         DO k=ktf,kts,-1
6071           temp31b = 0.25*(v(i_start, k, j)+v(i_start-1, k, j))*fqxb(&
6072 &            i_start, k)
6073           temp31b0 = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))*fqxb(&
6074 &            i_start, k)
6075           rub(i_start, k, j) = rub(i_start, k, j) + temp31b
6076           rub(i_start, k, j-1) = rub(i_start, k, j-1) + temp31b
6077           vb0(i_start, k, j) = vb0(i_start, k, j) + temp31b0
6078           vb0(i_start-1, k, j) = vb0(i_start-1, k, j) + temp31b0
6079           fqxb(i_start, k) = 0.0
6080         END DO
6081       END IF
6082       DO k=ktf,kts,-1
6083         DO i=i_end_f,i_start_f,-1
6084           vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
6085           temp27 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(i-1, k&
6086 &            , j))
6087           temp30 = SIGN(1., vel)
6088           temp29 = temp30/12.0
6089           temp28 = SIGN(1, time_step)
6090           temp27b = vel*fqxb(i, k)
6091           temp27b0 = temp27b/12.0
6092           temp27b1 = temp28*temp29*temp27b
6093           velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k, j&
6094 &            ))/12.0+temp28*(temp29*temp27))*fqxb(i, k)
6095           vb0(i, k, j) = vb0(i, k, j) + 7.*temp27b0 - 3.*temp27b1
6096           vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp27b1 + 7.*temp27b0
6097           vb0(i+1, k, j) = vb0(i+1, k, j) + temp27b1 - temp27b0
6098           vb0(i-2, k, j) = vb0(i-2, k, j) - temp27b1 - temp27b0
6099           fqxb(i, k) = 0.0
6100           rub(i, k, j) = rub(i, k, j) + 0.5*velb
6101           rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
6102         END DO
6103       END DO
6104     END DO
6105     fqyb = 0.0
6106     CALL POPINTEGER4(ad_from26)
6107     CALL POPINTEGER4(ad_to26)
6108     DO j=ad_to26,ad_from26,-1
6109       CALL POPINTEGER4(jp0)
6110       CALL POPINTEGER4(jp1)
6111       CALL POPCONTROL2B(branch)
6112       IF (branch .LT. 2) THEN
6113         IF (branch .EQ. 0) THEN
6114           DO k=ktf,kts,-1
6115             CALL POPINTEGER4(ad_from23)
6116             CALL POPINTEGER4(ad_to23)
6117             DO i=ad_to23,ad_from23,-1
6118               tendencyb(i, k, j-1) = 0.0
6119             END DO
6120           END DO
6121         ELSE
6122           DO k=ktf,kts,-1
6123             CALL POPINTEGER4(ad_from24)
6124             CALL POPINTEGER4(ad_to24)
6125             DO i=ad_to24,ad_from24,-1
6126               tendencyb(i, k, j-1) = 0.0
6127             END DO
6128           END DO
6129         END IF
6130       ELSE IF (branch .EQ. 2) THEN
6131         DO k=ktf,kts,-1
6132           CALL POPINTEGER4(ad_from25)
6133           CALL POPINTEGER4(ad_to25)
6134           DO i=ad_to25,ad_from25,-1
6135             mrdy = msfvy(i, j-1)*rdy
6136             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
6137 &              )
6138             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
6139 &              )
6140           END DO
6141         END DO
6142       END IF
6143       CALL POPCONTROL2B(branch)
6144       IF (branch .EQ. 0) THEN
6145         DO k=ktf,kts,-1
6146           CALL POPINTEGER4(ad_from20)
6147           CALL POPINTEGER4(ad_to20)
6148           DO i=ad_to20,ad_from20,-1
6149             temp23b9 = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1)
6150             temp23b10 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1)
6151             rvb(i, k, j) = rvb(i, k, j) + temp23b9
6152             rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b9
6153             vb0(i, k, j) = vb0(i, k, j) + temp23b10
6154             vbb = temp23b10
6155             fqyb(i, k, jp1) = 0.0
6156             CALL POPCONTROL1B(branch)
6157             IF (branch .EQ. 0) THEN
6158               vb0(i, k, j) = vb0(i, k, j) + vbb
6159               vbb = 0.0
6160             END IF
6161             CALL POPREAL8(vb)
6162             vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
6163           END DO
6164         END DO
6165       ELSE IF (branch .EQ. 1) THEN
6166         DO k=ktf,kts,-1
6167           CALL POPINTEGER4(ad_from21)
6168           CALL POPINTEGER4(ad_to21)
6169           DO i=ad_to21,ad_from21,-1
6170             temp23b11 = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1)
6171             temp23b12 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1)
6172             rvb(i, k, j) = rvb(i, k, j) + temp23b11
6173             rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b11
6174             vbb = temp23b12
6175             vb0(i, k, j-1) = vb0(i, k, j-1) + temp23b12
6176             fqyb(i, k, jp1) = 0.0
6177             CALL POPCONTROL1B(branch)
6178             IF (branch .EQ. 0) THEN
6179               vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
6180               vbb = 0.0
6181             END IF
6182             CALL POPREAL8(vb)
6183             vb0(i, k, j) = vb0(i, k, j) + vbb
6184           END DO
6185         END DO
6186       ELSE
6187         DO k=ktf,kts,-1
6188           CALL POPINTEGER4(ad_from22)
6189           CALL POPINTEGER4(ad_to22)
6190           DO i=ad_to22,ad_from22,-1
6191             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
6192             temp23 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, k&
6193 &              , j-1))
6194             temp26 = SIGN(1., vel)
6195             temp25 = temp26/12.0
6196             temp24 = SIGN(1, time_step)
6197             temp23b13 = vel*fqyb(i, k, jp1)
6198             temp23b14 = temp23b13/12.0
6199             temp23b15 = temp24*temp25*temp23b13
6200             velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, j&
6201 &              -2))/12.0+temp24*(temp25*temp23))*fqyb(i, k, jp1)
6202             vb0(i, k, j) = vb0(i, k, j) + 7.*temp23b14 - 3.*temp23b15
6203             vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp23b15 + 7.*&
6204 &              temp23b14
6205             vb0(i, k, j+1) = vb0(i, k, j+1) + temp23b15 - temp23b14
6206             vb0(i, k, j-2) = vb0(i, k, j-2) - temp23b15 - temp23b14
6207             fqyb(i, k, jp1) = 0.0
6208             rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
6209             rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
6210           END DO
6211         END DO
6212       END IF
6213     END DO
6214   ELSE IF (branch .EQ. 4) THEN
6215     CALL POPINTEGER4(ad_from36)
6216     CALL POPINTEGER4(ad_to36)
6217     DO j=ad_to36,ad_from36,-1
6218       DO k=ktf,kts,-1
6219         CALL POPINTEGER4(ad_from35)
6220         CALL POPINTEGER4(ad_to35)
6221         DO i=ad_to35,ad_from35,-1
6222           mrdx = msfvy(i, j)*rdx
6223           temp31b18 = -(mrdx*0.25*tendencyb(i, k, j))
6224           temp31b19 = (v(i+1, k, j)+v(i, k, j))*temp31b18
6225           temp31b20 = (ru(i+1, k, j)+ru(i+1, k, j-1))*temp31b18
6226           temp31b21 = -((v(i, k, j)+v(i-1, k, j))*temp31b18)
6227           temp31b22 = -((ru(i, k, j)+ru(i, k, j-1))*temp31b18)
6228           rub(i+1, k, j) = rub(i+1, k, j) + temp31b19
6229           rub(i+1, k, j-1) = rub(i+1, k, j-1) + temp31b19
6230           vb0(i+1, k, j) = vb0(i+1, k, j) + temp31b20
6231           vb0(i, k, j) = vb0(i, k, j) + temp31b22 + temp31b20
6232           rub(i, k, j) = rub(i, k, j) + temp31b21
6233           rub(i, k, j-1) = rub(i, k, j-1) + temp31b21
6234           vb0(i-1, k, j) = vb0(i-1, k, j) + temp31b22
6235         END DO
6236       END DO
6237     END DO
6238     CALL POPINTEGER4(j)
6239     CALL POPCONTROL1B(branch)
6240     IF (branch .EQ. 0) THEN
6241       DO k=ktf,kts,-1
6242         CALL POPINTEGER4(ad_from34)
6243         CALL POPINTEGER4(ad_to34)
6244         DO i=ad_to34,ad_from34,-1
6245           mrdy = msfvy(i, j)*rdy
6246           temp31b13 = -(mrdy*0.25*tendencyb(i, k, j))
6247           temp31b14 = (vb+v(i, k, j))*temp31b13
6248           temp31b15 = (rv(i, k, j+1)+rv(i, k, j))*temp31b13
6249           temp31b16 = -((v(i, k, j)+v(i, k, j-1))*temp31b13)
6250           temp31b17 = -((rv(i, k, j)+rv(i, k, j-1))*temp31b13)
6251           rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b14
6252           rvb(i, k, j) = rvb(i, k, j) + temp31b16 + temp31b14
6253           vbb = temp31b15
6254           vb0(i, k, j) = vb0(i, k, j) + temp31b17 + temp31b15
6255           rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b16
6256           vb0(i, k, j-1) = vb0(i, k, j-1) + temp31b17
6257           CALL POPCONTROL1B(branch)
6258           IF (branch .EQ. 0) THEN
6259             vb0(i, k, j) = vb0(i, k, j) + vbb
6260             vbb = 0.0
6261           END IF
6262           CALL POPREAL8(vb)
6263           vb0(i, k, j+1) = vb0(i, k, j+1) + vbb
6264         END DO
6265       END DO
6266       CALL POPINTEGER4(j)
6267     END IF
6268     CALL POPCONTROL1B(branch)
6269     IF (branch .EQ. 0) THEN
6270       DO k=ktf,kts,-1
6271         CALL POPINTEGER4(ad_from33)
6272         CALL POPINTEGER4(ad_to33)
6273         DO i=ad_to33,ad_from33,-1
6274           mrdy = msfvy(i, j)*rdy
6275           temp31b8 = -(mrdy*0.25*tendencyb(i, k, j))
6276           temp31b9 = (v(i, k, j+1)+v(i, k, j))*temp31b8
6277           temp31b10 = (rv(i, k, j+1)+rv(i, k, j))*temp31b8
6278           temp31b11 = -((v(i, k, j)+vb)*temp31b8)
6279           temp31b12 = -((rv(i, k, j)+rv(i, k, j-1))*temp31b8)
6280           rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b9
6281           rvb(i, k, j) = rvb(i, k, j) + temp31b11 + temp31b9
6282           vb0(i, k, j+1) = vb0(i, k, j+1) + temp31b10
6283           vb0(i, k, j) = vb0(i, k, j) + temp31b12 + temp31b10
6284           rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b11
6285           vbb = temp31b12
6286           CALL POPCONTROL1B(branch)
6287           IF (branch .EQ. 0) THEN
6288             vb0(i, k, j) = vb0(i, k, j) + vbb
6289             vbb = 0.0
6290           END IF
6291           CALL POPREAL8(vb)
6292           vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
6293         END DO
6294       END DO
6295     END IF
6296     CALL POPCONTROL2B(branch)
6297     IF (branch .EQ. 0) THEN
6298       DO k=ktf,kts,-1
6299         CALL POPINTEGER4(ad_from32)
6300         CALL POPINTEGER4(ad_to32)
6301         DO i=ad_to32,ad_from32,-1
6302           tendencyb(i, k, jde) = 0.0
6303         END DO
6304       END DO
6305     ELSE IF (branch .NE. 1) THEN
6306       GOTO 100
6307     END IF
6308     CALL POPCONTROL1B(branch)
6309     IF (branch .EQ. 0) THEN
6310       DO k=ktf,kts,-1
6311         CALL POPINTEGER4(ad_from31)
6312         CALL POPINTEGER4(ad_to31)
6313         DO i=ad_to31,ad_from31,-1
6314           tendencyb(i, k, jds) = 0.0
6315         END DO
6316       END DO
6317     END IF
6318  100 CALL POPINTEGER4(ad_from30)
6319     CALL POPINTEGER4(ad_to30)
6320     DO j=ad_to30,ad_from30,-1
6321       DO k=ktf,kts,-1
6322         CALL POPINTEGER4(ad_from29)
6323         CALL POPINTEGER4(ad_to29)
6324         DO i=ad_to29,ad_from29,-1
6325           mrdy = msfvy(i, j)*rdy
6326           temp31b3 = -(mrdy*0.25*tendencyb(i, k, j))
6327           temp31b4 = (v(i, k, j+1)+v(i, k, j))*temp31b3
6328           temp31b5 = (rv(i, k, j+1)+rv(i, k, j))*temp31b3
6329           temp31b6 = -((v(i, k, j)+v(i, k, j-1))*temp31b3)
6330           temp31b7 = -((rv(i, k, j)+rv(i, k, j-1))*temp31b3)
6331           rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b4
6332           rvb(i, k, j) = rvb(i, k, j) + temp31b6 + temp31b4
6333           vb0(i, k, j+1) = vb0(i, k, j+1) + temp31b5
6334           vb0(i, k, j) = vb0(i, k, j) + temp31b7 + temp31b5
6335           rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b6
6336           vb0(i, k, j-1) = vb0(i, k, j-1) + temp31b7
6337         END DO
6338       END DO
6339     END DO
6340   END IF
6341 END SUBROUTINE A_ADVECT_V
6342
6343 !        Generated by TAPENADE     (INRIA, Tropics team)
6344 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
6345 !
6346 !  Differentiation of advect_scalar in reverse (adjoint) mode:
6347 !   gradient     of useful results: rom field tendency ru rv field_old
6348 !   with respect to varying inputs: rom field tendency ru rv field_old
6349 !   RW status of diff variables: rom:incr field:incr tendency:in-out
6350 !                ru:incr rv:incr field_old:incr
6351 SUBROUTINE A_ADVECT_SCALAR(field, fieldb, field_old, field_oldb, &
6352 &  tendency, tendencyb, ru, rub, rv, rvb, rom, romb, mut, time_step, &
6353 &  config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx&
6354 &  , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, &
6355 &  kme, its, ite, jts, jte, kts, kte)
6356   IMPLICIT NONE
6357 ! Input data
6358   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
6359   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
6360 &  jme, kms, kme, its, ite, jts, jte, kts, kte
6361   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
6362 &  field_old, ru, rv, rom
6363   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub&
6364 &  , rvb, romb
6365   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
6366   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
6367   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb
6368   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
6369 &  msfvy, msftx, msfty
6370   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
6371   REAL, INTENT(IN) :: rdx, rdy
6372   INTEGER, INTENT(IN) :: time_step
6373 ! Local data
6374   INTEGER :: i, j, k, itf, jtf, ktf
6375   INTEGER :: i_start, i_end, j_start, j_end
6376   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
6377   INTEGER :: jmin, jmax, jp, jm, imin, imax
6378   REAL :: mrdx, mrdy, ub, vb, uw, vw
6379   REAL :: ubb, vbb
6380   REAL, DIMENSION(its:ite, kts:kte) :: vflux
6381   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
6382   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
6383   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb
6384   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
6385   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
6386   INTEGER :: horz_order, vert_order
6387   LOGICAL :: degrade_xs, degrade_ys
6388   LOGICAL :: degrade_xe, degrade_ye
6389   INTEGER :: jp1, jp0, jtmp
6390 ! definition of flux operators, 3rd, 4th, 5th or 6th order
6391   REAL :: flux3, flux4, flux5, flux6
6392   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
6393   REAL :: velb
6394   LOGICAL :: specified
6395   INTEGER :: ad_from
6396   INTEGER :: ad_to
6397   INTEGER :: ad_from0
6398   INTEGER :: ad_to0
6399   INTEGER :: ad_from1
6400   INTEGER :: ad_to1
6401   INTEGER :: ad_from2
6402   INTEGER :: ad_to2
6403   INTEGER :: ad_from3
6404   INTEGER :: ad_to3
6405   INTEGER :: ad_from4
6406   INTEGER :: ad_to4
6407   INTEGER :: ad_from5
6408   INTEGER :: ad_to5
6409   INTEGER :: ad_from6
6410   INTEGER :: ad_to6
6411   INTEGER :: branch
6412   INTEGER :: ad_from7
6413   INTEGER :: ad_to7
6414   INTEGER :: ad_from8
6415   INTEGER :: ad_to8
6416   INTEGER :: ad_from9
6417   INTEGER :: ad_to9
6418   INTEGER :: ad_from10
6419   INTEGER :: ad_to10
6420   INTEGER :: ad_from11
6421   INTEGER :: ad_to11
6422   INTEGER :: ad_from12
6423   INTEGER :: ad_to12
6424   INTEGER :: ad_from13
6425   INTEGER :: ad_to13
6426   INTEGER :: ad_from14
6427   INTEGER :: ad_to14
6428   INTEGER :: ad_from15
6429   INTEGER :: ad_to15
6430   INTEGER :: ad_from16
6431   INTEGER :: ad_to16
6432   INTEGER :: ad_from17
6433   INTEGER :: ad_to17
6434   INTEGER :: ad_from18
6435   INTEGER :: ad_to18
6436   INTEGER :: ad_from19
6437   INTEGER :: ad_to19
6438   INTEGER :: ad_from20
6439   INTEGER :: ad_to20
6440   INTEGER :: ad_from21
6441   INTEGER :: ad_to21
6442   INTEGER :: ad_from22
6443   INTEGER :: ad_to22
6444   INTEGER :: ad_from23
6445   INTEGER :: ad_to23
6446   INTEGER :: ad_from24
6447   INTEGER :: ad_to24
6448   INTEGER :: ad_from25
6449   INTEGER :: ad_to25
6450   INTEGER :: ad_from26
6451   INTEGER :: ad_to26
6452   INTEGER :: ad_from27
6453   INTEGER :: ad_to27
6454   INTEGER :: ad_from28
6455   INTEGER :: ad_to28
6456   INTEGER :: ad_from29
6457   INTEGER :: ad_to29
6458   INTEGER :: ad_from30
6459   INTEGER :: ad_to30
6460   INTEGER :: ad_from31
6461   INTEGER :: ad_to31
6462   INTEGER :: ad_from32
6463   INTEGER :: ad_to32
6464   INTEGER :: ad_from33
6465   INTEGER :: ad_to33
6466   INTEGER :: ad_from34
6467   INTEGER :: ad_to34
6468   INTEGER :: ad_from35
6469   INTEGER :: ad_to35
6470   INTEGER :: ad_from36
6471   INTEGER :: ad_to36
6472   INTEGER :: ad_from37
6473   INTEGER :: ad_to37
6474   INTEGER :: ad_from38
6475   INTEGER :: ad_to38
6476   INTEGER :: ad_from39
6477   INTEGER :: ad_to39
6478   INTEGER :: ad_from40
6479   INTEGER :: ad_to40
6480   INTEGER :: ad_from41
6481   INTEGER :: ad_to41
6482   INTEGER :: ad_from42
6483   INTEGER :: ad_to42
6484   INTEGER :: ad_from43
6485   INTEGER :: ad_to43
6486   INTEGER :: ad_from44
6487   INTEGER :: ad_to44
6488   INTEGER :: ad_from45
6489   INTEGER :: ad_to45
6490   INTEGER :: ad_from46
6491   INTEGER :: ad_to46
6492   INTEGER :: ad_from47
6493   INTEGER :: ad_to47
6494   INTEGER :: ad_from48
6495   INTEGER :: ad_to48
6496   INTEGER :: ad_from49
6497   INTEGER :: ad_to49
6498   INTEGER :: ad_from50
6499   INTEGER :: ad_to50
6500   REAL :: temp3
6501   REAL :: temp29
6502   REAL :: temp2
6503   INTEGER :: temp28
6504   REAL :: temp1
6505   REAL :: temp27
6506   INTEGER :: temp0
6507   REAL :: temp26
6508   REAL :: temp7b
6509   REAL :: temp25
6510   INTEGER :: temp24
6511   REAL :: temp23
6512   REAL :: temp22
6513   REAL :: temp21
6514   INTEGER :: temp20
6515   REAL :: temp35b2
6516   REAL :: temp35b1
6517   REAL :: temp35b0
6518   REAL :: temp19b
6519   REAL :: temp23b7
6520   REAL :: temp23b6
6521   REAL :: temp27b
6522   REAL :: temp23b5
6523   REAL :: temp35b
6524   REAL :: tempb1
6525   REAL :: temp23b4
6526   REAL :: temp43b
6527   REAL :: tempb0
6528   REAL :: temp23b3
6529   REAL :: temp23b2
6530   REAL :: temp23b1
6531   REAL :: temp23b0
6532   REAL :: temp3b
6533   REAL :: temp7b2
6534   REAL :: temp7b1
6535   REAL :: temp7b0
6536   REAL :: temp31b34
6537   REAL :: temp19
6538   REAL :: temp31b33
6539   REAL :: temp18
6540   REAL :: temp31b32
6541   REAL :: temp17
6542   REAL :: temp31b31
6543   INTEGER :: temp16
6544   REAL :: temp31b30
6545   REAL :: temp15
6546   REAL :: temp14
6547   REAL :: temp11b1
6548   REAL :: temp13
6549   REAL :: temp11b0
6550   REAL :: temp43b5
6551   INTEGER :: temp12
6552   REAL :: temp43b4
6553   REAL :: temp11
6554   REAL :: temp43b3
6555   REAL :: temp10
6556   REAL :: temp43b2
6557   REAL :: temp15b
6558   REAL :: temp43b1
6559   REAL :: temp46
6560   REAL :: temp23b
6561   REAL :: temp43b0
6562   REAL :: temp45
6563   REAL :: temp31b
6564   INTEGER :: temp44
6565   REAL :: temp43
6566   REAL :: temp42
6567   REAL :: temp31b9
6568   REAL :: temp41
6569   REAL :: temp19b2
6570   REAL :: temp31b8
6571   INTEGER :: temp40
6572   REAL :: temp19b1
6573   REAL :: temp31b7
6574   REAL :: temp19b0
6575   REAL :: temp31b6
6576   REAL :: temp31b5
6577   REAL :: temp31b4
6578   REAL :: temp31b3
6579   REAL :: tempb
6580   REAL :: temp31b2
6581   REAL :: temp31b1
6582   REAL :: temp31b0
6583   REAL :: temp31b29
6584   REAL :: temp31b28
6585   REAL :: temp31b27
6586   REAL :: temp31b26
6587   REAL :: temp31b25
6588   REAL :: temp31b24
6589   REAL :: temp31b23
6590   REAL :: temp31b22
6591   REAL :: temp31b21
6592   REAL :: temp11b
6593   REAL :: temp31b20
6594   REAL :: temp39b1
6595   REAL :: temp39b0
6596   REAL :: temp39
6597   REAL :: temp38
6598   REAL :: temp37
6599   REAL :: temp3b2
6600   INTEGER :: temp36
6601   REAL :: temp3b1
6602   REAL :: temp35
6603   REAL :: temp3b0
6604   REAL :: temp34
6605   REAL :: temp27b5
6606   REAL :: temp33
6607   REAL :: temp27b4
6608   INTEGER :: temp32
6609   REAL :: temp27b3
6610   REAL :: temp31
6611   REAL :: temp27b2
6612   REAL :: temp30
6613   REAL :: temp27b1
6614   REAL :: temp27b0
6615   INTRINSIC MIN
6616   REAL :: temp31b19
6617   REAL :: temp31b18
6618   REAL :: temp31b17
6619   REAL :: temp31b16
6620   REAL :: temp
6621   REAL :: temp15b2
6622   REAL :: temp31b15
6623   REAL :: temp15b1
6624   REAL :: temp31b14
6625   REAL :: temp15b0
6626   REAL :: temp31b13
6627   REAL :: temp9
6628   REAL :: temp31b12
6629   INTEGER :: temp8
6630   REAL :: temp31b11
6631   REAL :: temp39b
6632   REAL :: temp7
6633   REAL :: temp31b10
6634   REAL :: temp47b
6635   REAL :: temp6
6636   REAL :: temp47b1
6637   REAL :: temp5
6638   REAL :: temp47b0
6639   INTEGER :: temp4
6640   specified = .false.
6641   IF (config_flags%specified .OR. config_flags%nested) specified = &
6642 &      .true.
6643   IF (kte .GT. kde - 1) THEN
6644     ktf = kde - 1
6645   ELSE
6646     ktf = kte
6647   END IF
6648   horz_order = config_flags%h_sca_adv_order
6649   vert_order = config_flags%v_sca_adv_order
6650 !  begin with horizontal flux divergence
6651 !  here is the choice of flux operators
6652   IF (horz_order .EQ. 6) THEN
6653 !  determine boundary mods for flux operators
6654 !  We degrade the flux operators from 3rd/4th order
6655 !   to second order one gridpoint in from the boundaries for
6656 !   all boundary conditions except periodic and symmetry - these
6657 !   conditions have boundary zone data fill for correct application
6658 !   of the higher order flux stencils
6659     degrade_xs = .true.
6660     degrade_xe = .true.
6661     degrade_ys = .true.
6662     degrade_ye = .true.
6663     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
6664 &        its .GT. ids + 3) degrade_xs = .false.
6665     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
6666 &        ite .LT. ide - 3) degrade_xe = .false.
6667     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
6668 &        jts .GT. jds + 3) degrade_ys = .false.
6669     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
6670 &        jte .LT. jde - 4) degrade_ye = .false.
6671     IF (kte .GT. kde - 1) THEN
6672       ktf = kde - 1
6673     ELSE
6674       ktf = kte
6675     END IF
6676     i_start = its
6677     IF (ite .GT. ide - 1) THEN
6678       i_end = ide - 1
6679     ELSE
6680       i_end = ite
6681     END IF
6682     j_start = jts
6683     IF (jte .GT. jde - 1) THEN
6684       j_end = jde - 1
6685     ELSE
6686       j_end = jte
6687     END IF
6688 !  higher order flux has a 5 or 7 point stencil, so compute
6689 !  bounds so we can switch to second order flux close to the boundary
6690     j_start_f = j_start
6691     j_end_f = j_end + 1
6692     IF (degrade_ys) THEN
6693       IF (jts .LT. jds + 1) THEN
6694         j_start = jds + 1
6695       ELSE
6696         j_start = jts
6697       END IF
6698       j_start_f = jds + 3
6699     END IF
6700     IF (degrade_ye) THEN
6701       IF (jte .GT. jde - 2) THEN
6702         j_end = jde - 2
6703       ELSE
6704         j_end = jte
6705       END IF
6706       j_end_f = jde - 3
6707     END IF
6708     IF (config_flags%polar) THEN
6709       IF (jte .GT. jde - 1) THEN
6710         j_end = jde - 1
6711       ELSE
6712         j_end = jte
6713       END IF
6714     END IF
6715 !  compute fluxes, 5th or 6th order
6716     jp1 = 2
6717     jp0 = 1
6718     ad_from43 = j_start
6719 j_loop_y_flux_6:DO j=ad_from43,j_end+1
6720       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
6721 ! use full stencil
6722         DO k=kts,ktf
6723           ad_from35 = i_start
6724           i = i_end + 1
6725           CALL PUSHINTEGER4(i - 1)
6726           CALL PUSHINTEGER4(ad_from35)
6727         END DO
6728         CALL PUSHCONTROL3B(0)
6729       ELSE IF (j .EQ. jds + 1) THEN
6730 ! 2nd order flux next to south boundary
6731         DO k=kts,ktf
6732           ad_from36 = i_start
6733           i = i_end + 1
6734           CALL PUSHINTEGER4(i - 1)
6735           CALL PUSHINTEGER4(ad_from36)
6736         END DO
6737         CALL PUSHCONTROL3B(1)
6738       ELSE IF (j .EQ. jds + 2) THEN
6739 ! 4th order flux 2 in from south boundary
6740         DO k=kts,ktf
6741           ad_from37 = i_start
6742           i = i_end + 1
6743           CALL PUSHINTEGER4(i - 1)
6744           CALL PUSHINTEGER4(ad_from37)
6745         END DO
6746         CALL PUSHCONTROL3B(2)
6747       ELSE IF (j .EQ. jde - 1) THEN
6748 ! 2nd order flux next to north boundary
6749         DO k=kts,ktf
6750           ad_from38 = i_start
6751           i = i_end + 1
6752           CALL PUSHINTEGER4(i - 1)
6753           CALL PUSHINTEGER4(ad_from38)
6754         END DO
6755         CALL PUSHCONTROL3B(3)
6756       ELSE IF (j .EQ. jde - 2) THEN
6757 ! 3rd or 4th order flux 2 in from north boundary
6758         DO k=kts,ktf
6759           ad_from39 = i_start
6760           i = i_end + 1
6761           CALL PUSHINTEGER4(i - 1)
6762           CALL PUSHINTEGER4(ad_from39)
6763         END DO
6764         CALL PUSHCONTROL3B(4)
6765       ELSE
6766         CALL PUSHCONTROL3B(5)
6767       END IF
6768 !  y flux-divergence into tendency
6769 ! Comments on polar boundary conditions
6770 ! Same process as for advect_u - tendencies run from jds to jde-1
6771 ! (latitudes are as for u grid, longitudes are displaced)
6772 ! Therefore: flow is only from one side for points next to poles
6773       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
6774         DO k=kts,ktf
6775           ad_from40 = i_start
6776           i = i_end + 1
6777           CALL PUSHINTEGER4(i - 1)
6778           CALL PUSHINTEGER4(ad_from40)
6779         END DO
6780         CALL PUSHCONTROL2B(0)
6781       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
6782         DO k=kts,ktf
6783           ad_from41 = i_start
6784           i = i_end + 1
6785           CALL PUSHINTEGER4(i - 1)
6786           CALL PUSHINTEGER4(ad_from41)
6787         END DO
6788         CALL PUSHCONTROL2B(1)
6789       ELSE IF (j .GT. j_start) THEN
6790 ! normal code
6791         DO k=kts,ktf
6792           ad_from42 = i_start
6793           i = i_end + 1
6794           CALL PUSHINTEGER4(i - 1)
6795           CALL PUSHINTEGER4(ad_from42)
6796         END DO
6797         CALL PUSHCONTROL2B(2)
6798       ELSE
6799         CALL PUSHCONTROL2B(3)
6800       END IF
6801       jtmp = jp1
6802       CALL PUSHINTEGER4(jp1)
6803       jp1 = jp0
6804       CALL PUSHINTEGER4(jp0)
6805       jp0 = jtmp
6806     END DO j_loop_y_flux_6
6807     CALL PUSHINTEGER4(j - 1)
6808     CALL PUSHINTEGER4(ad_from43)
6809 !  next, x - flux divergence
6810     i_start = its
6811     IF (ite .GT. ide - 1) THEN
6812       i_end = ide - 1
6813     ELSE
6814       i_end = ite
6815     END IF
6816     j_start = jts
6817     IF (jte .GT. jde - 1) THEN
6818       j_end = jde - 1
6819     ELSE
6820       j_end = jte
6821     END IF
6822 !  higher order flux has a 5 or 7 point stencil, so compute
6823 !  bounds so we can switch to second order flux close to the boundary
6824     i_start_f = i_start
6825     i_end_f = i_end + 1
6826     IF (degrade_xs) THEN
6827       IF (ids + 1 .LT. its) THEN
6828         i_start = its
6829       ELSE
6830         i_start = ids + 1
6831       END IF
6832       IF (i_start + 2 .GT. ids + 3) THEN
6833         i_start_f = ids + 3
6834       ELSE
6835         i_start_f = i_start + 2
6836       END IF
6837     END IF
6838     IF (degrade_xe) THEN
6839       IF (ide - 2 .GT. ite) THEN
6840         i_end = ite
6841       ELSE
6842         i_end = ide - 2
6843       END IF
6844       i_end_f = ide - 3
6845     END IF
6846     ad_from46 = j_start
6847 !  compute fluxes
6848     DO j=ad_from46,j_end
6849 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6850       IF (degrade_xs) THEN
6851         ad_from44 = i_start
6852         DO i=ad_from44,i_start_f-1
6853           IF (i .EQ. ids + 1) THEN
6854             CALL PUSHCONTROL1B(0)
6855           ELSE
6856             CALL PUSHCONTROL1B(1)
6857           END IF
6858           IF (i .EQ. ids + 2) THEN
6859             CALL PUSHCONTROL1B(1)
6860           ELSE
6861             CALL PUSHCONTROL1B(0)
6862           END IF
6863         END DO
6864         CALL PUSHINTEGER4(ad_from44)
6865         CALL PUSHCONTROL1B(0)
6866       ELSE
6867         CALL PUSHCONTROL1B(1)
6868       END IF
6869       IF (degrade_xe) THEN
6870         DO i=i_end_f+1,i_end+1
6871           IF (i .EQ. ide - 1) THEN
6872             CALL PUSHCONTROL1B(0)
6873           ELSE
6874             CALL PUSHCONTROL1B(1)
6875           END IF
6876           IF (i .EQ. ide - 2) THEN
6877             CALL PUSHCONTROL1B(1)
6878           ELSE
6879             CALL PUSHCONTROL1B(0)
6880           END IF
6881         END DO
6882         CALL PUSHINTEGER4(i - 1)
6883         CALL PUSHCONTROL1B(1)
6884       ELSE
6885         CALL PUSHCONTROL1B(0)
6886       END IF
6887 !  x flux-divergence into tendency
6888       DO k=kts,ktf
6889         ad_from45 = i_start
6890         i = i_end + 1
6891         CALL PUSHINTEGER4(i - 1)
6892         CALL PUSHINTEGER4(ad_from45)
6893       END DO
6894     END DO
6895     CALL PUSHINTEGER4(j - 1)
6896     CALL PUSHINTEGER4(ad_from46)
6897     CALL PUSHCONTROL3B(7)
6898   ELSE IF (horz_order .EQ. 5) THEN
6899 !  determine boundary mods for flux operators
6900 !  We degrade the flux operators from 3rd/4th order
6901 !   to second order one gridpoint in from the boundaries for
6902 !   all boundary conditions except periodic and symmetry - these
6903 !   conditions have boundary zone data fill for correct application
6904 !   of the higher order flux stencils
6905     degrade_xs = .true.
6906     degrade_xe = .true.
6907     degrade_ys = .true.
6908     degrade_ye = .true.
6909     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
6910 &        its .GT. ids + 3) degrade_xs = .false.
6911     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
6912 &        ite .LT. ide - 3) degrade_xe = .false.
6913     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
6914 &        jts .GT. jds + 3) degrade_ys = .false.
6915     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
6916 &        jte .LT. jde - 4) degrade_ye = .false.
6917     IF (kte .GT. kde - 1) THEN
6918       ktf = kde - 1
6919     ELSE
6920       ktf = kte
6921     END IF
6922     i_start = its
6923     IF (ite .GT. ide - 1) THEN
6924       i_end = ide - 1
6925     ELSE
6926       i_end = ite
6927     END IF
6928     j_start = jts
6929     IF (jte .GT. jde - 1) THEN
6930       j_end = jde - 1
6931     ELSE
6932       j_end = jte
6933     END IF
6934 !  higher order flux has a 5 or 7 point stencil, so compute
6935 !  bounds so we can switch to second order flux close to the boundary
6936     j_start_f = j_start
6937     j_end_f = j_end + 1
6938     IF (degrade_ys) THEN
6939       IF (jts .LT. jds + 1) THEN
6940         j_start = jds + 1
6941       ELSE
6942         j_start = jts
6943       END IF
6944       j_start_f = jds + 3
6945     END IF
6946     IF (degrade_ye) THEN
6947       IF (jte .GT. jde - 2) THEN
6948         j_end = jde - 2
6949       ELSE
6950         j_end = jte
6951       END IF
6952       j_end_f = jde - 3
6953     END IF
6954     IF (config_flags%polar) THEN
6955       IF (jte .GT. jde - 1) THEN
6956         j_end = jde - 1
6957       ELSE
6958         j_end = jte
6959       END IF
6960     END IF
6961 !  compute fluxes, 5th or 6th order
6962     jp1 = 2
6963     jp0 = 1
6964     ad_from7 = j_start
6965 j_loop_y_flux_5:DO j=ad_from7,j_end+1
6966       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
6967 ! use full stencil
6968         DO k=kts,ktf
6969           ad_from = i_start
6970           i = i_end + 1
6971           CALL PUSHINTEGER4(i - 1)
6972           CALL PUSHINTEGER4(ad_from)
6973         END DO
6974         CALL PUSHCONTROL3B(0)
6975       ELSE IF (j .EQ. jds + 1) THEN
6976 ! 2nd order flux next to south boundary
6977         DO k=kts,ktf
6978           ad_from0 = i_start
6979           i = i_end + 1
6980           CALL PUSHINTEGER4(i - 1)
6981           CALL PUSHINTEGER4(ad_from0)
6982         END DO
6983         CALL PUSHCONTROL3B(1)
6984       ELSE IF (j .EQ. jds + 2) THEN
6985 ! third of 4th order flux 2 in from south boundary
6986         DO k=kts,ktf
6987           ad_from1 = i_start
6988           i = i_end + 1
6989           CALL PUSHINTEGER4(i - 1)
6990           CALL PUSHINTEGER4(ad_from1)
6991         END DO
6992         CALL PUSHCONTROL3B(2)
6993       ELSE IF (j .EQ. jde - 1) THEN
6994 ! 2nd order flux next to north boundary
6995         DO k=kts,ktf
6996           ad_from2 = i_start
6997           i = i_end + 1
6998           CALL PUSHINTEGER4(i - 1)
6999           CALL PUSHINTEGER4(ad_from2)
7000         END DO
7001         CALL PUSHCONTROL3B(3)
7002       ELSE IF (j .EQ. jde - 2) THEN
7003 ! 3rd or 4th order flux 2 in from north boundary
7004         DO k=kts,ktf
7005           ad_from3 = i_start
7006           i = i_end + 1
7007           CALL PUSHINTEGER4(i - 1)
7008           CALL PUSHINTEGER4(ad_from3)
7009         END DO
7010         CALL PUSHCONTROL3B(4)
7011       ELSE
7012         CALL PUSHCONTROL3B(5)
7013       END IF
7014 !  y flux-divergence into tendency
7015 ! Comments on polar boundary conditions
7016 ! Same process as for advect_u - tendencies run from jds to jde-1
7017 ! (latitudes are as for u grid, longitudes are displaced)
7018 ! Therefore: flow is only from one side for points next to poles
7019       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
7020         DO k=kts,ktf
7021           ad_from4 = i_start
7022           i = i_end + 1
7023           CALL PUSHINTEGER4(i - 1)
7024           CALL PUSHINTEGER4(ad_from4)
7025         END DO
7026         CALL PUSHCONTROL2B(0)
7027       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
7028         DO k=kts,ktf
7029           ad_from5 = i_start
7030           i = i_end + 1
7031           CALL PUSHINTEGER4(i - 1)
7032           CALL PUSHINTEGER4(ad_from5)
7033         END DO
7034         CALL PUSHCONTROL2B(1)
7035       ELSE IF (j .GT. j_start) THEN
7036 ! normal code
7037         DO k=kts,ktf
7038           ad_from6 = i_start
7039           i = i_end + 1
7040           CALL PUSHINTEGER4(i - 1)
7041           CALL PUSHINTEGER4(ad_from6)
7042         END DO
7043         CALL PUSHCONTROL2B(2)
7044       ELSE
7045         CALL PUSHCONTROL2B(3)
7046       END IF
7047       jtmp = jp1
7048       CALL PUSHINTEGER4(jp1)
7049       jp1 = jp0
7050       CALL PUSHINTEGER4(jp0)
7051       jp0 = jtmp
7052     END DO j_loop_y_flux_5
7053     CALL PUSHINTEGER4(j - 1)
7054     CALL PUSHINTEGER4(ad_from7)
7055 !  next, x - flux divergence
7056     i_start = its
7057     IF (ite .GT. ide - 1) THEN
7058       i_end = ide - 1
7059     ELSE
7060       i_end = ite
7061     END IF
7062     j_start = jts
7063     IF (jte .GT. jde - 1) THEN
7064       j_end = jde - 1
7065     ELSE
7066       j_end = jte
7067     END IF
7068 !  higher order flux has a 5 or 7 point stencil, so compute
7069 !  bounds so we can switch to second order flux close to the boundary
7070     i_start_f = i_start
7071     i_end_f = i_end + 1
7072     IF (degrade_xs) THEN
7073       IF (ids + 1 .LT. its) THEN
7074         i_start = its
7075       ELSE
7076         i_start = ids + 1
7077       END IF
7078       IF (i_start + 2 .GT. ids + 3) THEN
7079         i_start_f = ids + 3
7080       ELSE
7081         i_start_f = i_start + 2
7082       END IF
7083     END IF
7084     IF (degrade_xe) THEN
7085       IF (ide - 2 .GT. ite) THEN
7086         i_end = ite
7087       ELSE
7088         i_end = ide - 2
7089       END IF
7090       i_end_f = ide - 3
7091     END IF
7092     ad_from10 = j_start
7093 !  compute fluxes
7094     DO j=ad_from10,j_end
7095 !  lower order fluxes close to boundaries (if not periodic or symmetric)
7096       IF (degrade_xs) THEN
7097         ad_from8 = i_start
7098         DO i=ad_from8,i_start_f-1
7099           IF (i .EQ. ids + 1) THEN
7100             CALL PUSHCONTROL1B(0)
7101           ELSE
7102             CALL PUSHCONTROL1B(1)
7103           END IF
7104           IF (i .EQ. ids + 2) THEN
7105             CALL PUSHCONTROL1B(1)
7106           ELSE
7107             CALL PUSHCONTROL1B(0)
7108           END IF
7109         END DO
7110         CALL PUSHINTEGER4(ad_from8)
7111         CALL PUSHCONTROL1B(0)
7112       ELSE
7113         CALL PUSHCONTROL1B(1)
7114       END IF
7115       IF (degrade_xe) THEN
7116         DO i=i_end_f+1,i_end+1
7117           IF (i .EQ. ide - 1) THEN
7118             CALL PUSHCONTROL1B(0)
7119           ELSE
7120             CALL PUSHCONTROL1B(1)
7121           END IF
7122           IF (i .EQ. ide - 2) THEN
7123             CALL PUSHCONTROL1B(1)
7124           ELSE
7125             CALL PUSHCONTROL1B(0)
7126           END IF
7127         END DO
7128         CALL PUSHINTEGER4(i - 1)
7129         CALL PUSHCONTROL1B(1)
7130       ELSE
7131         CALL PUSHCONTROL1B(0)
7132       END IF
7133 !  x flux-divergence into tendency
7134       DO k=kts,ktf
7135         ad_from9 = i_start
7136         i = i_end + 1
7137         CALL PUSHINTEGER4(i - 1)
7138         CALL PUSHINTEGER4(ad_from9)
7139       END DO
7140     END DO
7141     CALL PUSHINTEGER4(j - 1)
7142     CALL PUSHINTEGER4(ad_from10)
7143     CALL PUSHCONTROL3B(6)
7144   ELSE IF (horz_order .EQ. 4) THEN
7145     degrade_xs = .true.
7146     degrade_xe = .true.
7147     degrade_ys = .true.
7148     degrade_ye = .true.
7149     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
7150 &        its .GT. ids + 2) degrade_xs = .false.
7151     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
7152 &        ite .LT. ide - 2) degrade_xe = .false.
7153     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
7154 &        jts .GT. jds + 2) degrade_ys = .false.
7155     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
7156 &        jte .LT. jde - 3) degrade_ye = .false.
7157     IF (kte .GT. kde - 1) THEN
7158       ktf = kde - 1
7159     ELSE
7160       ktf = kte
7161     END IF
7162     i_start = its
7163     IF (ite .GT. ide - 1) THEN
7164       i_end = ide - 1
7165     ELSE
7166       i_end = ite
7167     END IF
7168     j_start = jts
7169     IF (jte .GT. jde - 1) THEN
7170       j_end = jde - 1
7171     ELSE
7172       j_end = jte
7173     END IF
7174 !  3rd or 4th order flux has a 5 point stencil, so compute
7175 !  bounds so we can switch to second order flux close to the boundary
7176     i_start_f = i_start
7177     i_end_f = i_end + 1
7178     IF (degrade_xs) THEN
7179       i_start = ids + 1
7180       i_start_f = i_start + 1
7181     END IF
7182     IF (degrade_xe) THEN
7183       i_end = ide - 2
7184       i_end_f = ide - 2
7185     END IF
7186     ad_from12 = j_start
7187 !  compute fluxes
7188     DO j=ad_from12,j_end
7189 !  second order flux close to boundaries (if not periodic or symmetric)
7190       IF (degrade_xs) THEN
7191         CALL PUSHCONTROL1B(0)
7192       ELSE
7193         CALL PUSHCONTROL1B(1)
7194       END IF
7195       IF (degrade_xe) THEN
7196         CALL PUSHCONTROL1B(1)
7197       ELSE
7198         CALL PUSHCONTROL1B(0)
7199       END IF
7200 !  x flux-divergence into tendency
7201       DO k=kts,ktf
7202         ad_from11 = i_start
7203         i = i_end + 1
7204         CALL PUSHINTEGER4(i - 1)
7205         CALL PUSHINTEGER4(ad_from11)
7206       END DO
7207     END DO
7208     CALL PUSHINTEGER4(j - 1)
7209     CALL PUSHINTEGER4(ad_from12)
7210     CALL PUSHINTEGER4(i_start)
7211 !  next -> y flux divergence calculation
7212     i_start = its
7213     IF (ite .GT. ide - 1) THEN
7214       CALL PUSHINTEGER4(i_end)
7215       i_end = ide - 1
7216       CALL PUSHCONTROL1B(0)
7217     ELSE
7218       CALL PUSHINTEGER4(i_end)
7219       i_end = ite
7220       CALL PUSHCONTROL1B(1)
7221     END IF
7222     j_start = jts
7223     IF (jte .GT. jde - 1) THEN
7224       j_end = jde - 1
7225     ELSE
7226       j_end = jte
7227     END IF
7228 !  3rd or 4th order flux has a 5 point stencil, so compute
7229 !  bounds so we can switch to second order flux close to the boundary
7230     j_start_f = j_start
7231     j_end_f = j_end + 1
7232     IF (degrade_ys) THEN
7233       j_start = jds + 1
7234       j_start_f = j_start + 1
7235     END IF
7236     IF (degrade_ye) THEN
7237       j_end = jde - 2
7238       j_end_f = jde - 2
7239     END IF
7240     IF (config_flags%polar) THEN
7241       IF (jte .GT. jde - 1) THEN
7242         j_end = jde - 1
7243       ELSE
7244         j_end = jte
7245       END IF
7246     END IF
7247     jp1 = 2
7248     jp0 = 1
7249     ad_from19 = j_start
7250     DO j=ad_from19,j_end+1
7251       IF (j .LT. j_start_f .AND. degrade_ys) THEN
7252         DO k=kts,ktf
7253           ad_from13 = i_start
7254           i = i_end + 1
7255           CALL PUSHINTEGER4(i - 1)
7256           CALL PUSHINTEGER4(ad_from13)
7257         END DO
7258         CALL PUSHCONTROL2B(0)
7259       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
7260         DO k=kts,ktf
7261           ad_from14 = i_start
7262           i = i_end + 1
7263           CALL PUSHINTEGER4(i - 1)
7264           CALL PUSHINTEGER4(ad_from14)
7265         END DO
7266         CALL PUSHCONTROL2B(1)
7267       ELSE
7268 !  3rd or 4th order flux
7269         DO k=kts,ktf
7270           ad_from15 = i_start
7271           i = i_end + 1
7272           CALL PUSHINTEGER4(i - 1)
7273           CALL PUSHINTEGER4(ad_from15)
7274         END DO
7275         CALL PUSHCONTROL2B(2)
7276       END IF
7277 !  y flux-divergence into tendency
7278 ! Comments on polar boundary conditions
7279 ! Same process as for advect_u - tendencies run from jds to jde-1
7280 ! (latitudes are as for u grid, longitudes are displaced)
7281 ! Therefore: flow is only from one side for points next to poles
7282       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
7283         DO k=kts,ktf
7284           ad_from16 = i_start
7285           i = i_end + 1
7286           CALL PUSHINTEGER4(i - 1)
7287           CALL PUSHINTEGER4(ad_from16)
7288         END DO
7289         CALL PUSHCONTROL2B(0)
7290       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
7291         DO k=kts,ktf
7292           ad_from17 = i_start
7293           i = i_end + 1
7294           CALL PUSHINTEGER4(i - 1)
7295           CALL PUSHINTEGER4(ad_from17)
7296         END DO
7297         CALL PUSHCONTROL2B(1)
7298       ELSE IF (j .GT. j_start) THEN
7299 ! normal code
7300         DO k=kts,ktf
7301           ad_from18 = i_start
7302           i = i_end + 1
7303           CALL PUSHINTEGER4(i - 1)
7304           CALL PUSHINTEGER4(ad_from18)
7305         END DO
7306         CALL PUSHCONTROL2B(2)
7307       ELSE
7308         CALL PUSHCONTROL2B(3)
7309       END IF
7310       jtmp = jp1
7311       CALL PUSHINTEGER4(jp1)
7312       jp1 = jp0
7313       CALL PUSHINTEGER4(jp0)
7314       jp0 = jtmp
7315     END DO
7316     CALL PUSHINTEGER4(j - 1)
7317     CALL PUSHINTEGER4(ad_from19)
7318     CALL PUSHCONTROL3B(5)
7319   ELSE IF (horz_order .EQ. 3) THEN
7320     degrade_xs = .true.
7321     degrade_xe = .true.
7322     degrade_ys = .true.
7323     degrade_ye = .true.
7324     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
7325 &        its .GT. ids + 2) degrade_xs = .false.
7326     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
7327 &        ite .LT. ide - 2) degrade_xe = .false.
7328     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
7329 &        jts .GT. jds + 2) degrade_ys = .false.
7330     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
7331 &        jte .LT. jde - 3) degrade_ye = .false.
7332     IF (kte .GT. kde - 1) THEN
7333       ktf = kde - 1
7334     ELSE
7335       ktf = kte
7336     END IF
7337     i_start = its
7338     IF (ite .GT. ide - 1) THEN
7339       i_end = ide - 1
7340     ELSE
7341       i_end = ite
7342     END IF
7343     j_start = jts
7344     IF (jte .GT. jde - 1) THEN
7345       j_end = jde - 1
7346     ELSE
7347       j_end = jte
7348     END IF
7349 !  3rd or 4th order flux has a 5 point stencil, so compute
7350 !  bounds so we can switch to second order flux close to the boundary
7351     i_start_f = i_start
7352     i_end_f = i_end + 1
7353     IF (degrade_xs) THEN
7354       i_start = ids + 1
7355       i_start_f = i_start + 1
7356     END IF
7357     IF (degrade_xe) THEN
7358       i_end = ide - 2
7359       i_end_f = ide - 2
7360     END IF
7361     ad_from21 = j_start
7362 !  compute fluxes
7363     DO j=ad_from21,j_end
7364 !  second order flux close to boundaries (if not periodic or symmetric)
7365       IF (degrade_xs) THEN
7366         CALL PUSHCONTROL1B(0)
7367       ELSE
7368         CALL PUSHCONTROL1B(1)
7369       END IF
7370       IF (degrade_xe) THEN
7371         CALL PUSHCONTROL1B(1)
7372       ELSE
7373         CALL PUSHCONTROL1B(0)
7374       END IF
7375 !  x flux-divergence into tendency
7376       DO k=kts,ktf
7377         ad_from20 = i_start
7378         i = i_end + 1
7379         CALL PUSHINTEGER4(i - 1)
7380         CALL PUSHINTEGER4(ad_from20)
7381       END DO
7382     END DO
7383     CALL PUSHINTEGER4(j - 1)
7384     CALL PUSHINTEGER4(ad_from21)
7385     CALL PUSHINTEGER4(i_start)
7386 !  next -> y flux divergence calculation
7387     i_start = its
7388     IF (ite .GT. ide - 1) THEN
7389       CALL PUSHINTEGER4(i_end)
7390       i_end = ide - 1
7391       CALL PUSHCONTROL1B(0)
7392     ELSE
7393       CALL PUSHINTEGER4(i_end)
7394       i_end = ite
7395       CALL PUSHCONTROL1B(1)
7396     END IF
7397     j_start = jts
7398     IF (jte .GT. jde - 1) THEN
7399       j_end = jde - 1
7400     ELSE
7401       j_end = jte
7402     END IF
7403 !  3rd or 4th order flux has a 5 point stencil, so compute
7404 !  bounds so we can switch to second order flux close to the boundary
7405     j_start_f = j_start
7406     j_end_f = j_end + 1
7407     IF (degrade_ys) THEN
7408       j_start = jds + 1
7409       j_start_f = j_start + 1
7410     END IF
7411     IF (degrade_ye) THEN
7412       j_end = jde - 2
7413       j_end_f = jde - 2
7414     END IF
7415     IF (config_flags%polar) THEN
7416       IF (jte .GT. jde - 1) THEN
7417         j_end = jde - 1
7418       ELSE
7419         j_end = jte
7420       END IF
7421     END IF
7422     jp1 = 2
7423     jp0 = 1
7424     ad_from28 = j_start
7425     DO j=ad_from28,j_end+1
7426       IF (j .LT. j_start_f .AND. degrade_ys) THEN
7427         DO k=kts,ktf
7428           ad_from22 = i_start
7429           i = i_end + 1
7430           CALL PUSHINTEGER4(i - 1)
7431           CALL PUSHINTEGER4(ad_from22)
7432         END DO
7433         CALL PUSHCONTROL2B(0)
7434       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
7435         DO k=kts,ktf
7436           ad_from23 = i_start
7437           i = i_end + 1
7438           CALL PUSHINTEGER4(i - 1)
7439           CALL PUSHINTEGER4(ad_from23)
7440         END DO
7441         CALL PUSHCONTROL2B(1)
7442       ELSE
7443 !  3rd or 4th order flux
7444         DO k=kts,ktf
7445           ad_from24 = i_start
7446           i = i_end + 1
7447           CALL PUSHINTEGER4(i - 1)
7448           CALL PUSHINTEGER4(ad_from24)
7449         END DO
7450         CALL PUSHCONTROL2B(2)
7451       END IF
7452 !  y flux-divergence into tendency
7453 ! Comments on polar boundary conditions
7454 ! Same process as for advect_u - tendencies run from jds to jde-1
7455 ! (latitudes are as for u grid, longitudes are displaced)
7456 ! Therefore: flow is only from one side for points next to poles
7457       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
7458         DO k=kts,ktf
7459           ad_from25 = i_start
7460           i = i_end + 1
7461           CALL PUSHINTEGER4(i - 1)
7462           CALL PUSHINTEGER4(ad_from25)
7463         END DO
7464         CALL PUSHCONTROL2B(0)
7465       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
7466         DO k=kts,ktf
7467           ad_from26 = i_start
7468           i = i_end + 1
7469           CALL PUSHINTEGER4(i - 1)
7470           CALL PUSHINTEGER4(ad_from26)
7471         END DO
7472         CALL PUSHCONTROL2B(1)
7473       ELSE IF (j .GT. j_start) THEN
7474 ! normal code
7475         DO k=kts,ktf
7476           ad_from27 = i_start
7477           i = i_end + 1
7478           CALL PUSHINTEGER4(i - 1)
7479           CALL PUSHINTEGER4(ad_from27)
7480         END DO
7481         CALL PUSHCONTROL2B(2)
7482       ELSE
7483         CALL PUSHCONTROL2B(3)
7484       END IF
7485       jtmp = jp1
7486       CALL PUSHINTEGER4(jp1)
7487       jp1 = jp0
7488       CALL PUSHINTEGER4(jp0)
7489       jp0 = jtmp
7490     END DO
7491     CALL PUSHINTEGER4(j - 1)
7492     CALL PUSHINTEGER4(ad_from28)
7493     CALL PUSHCONTROL3B(4)
7494   ELSE IF (horz_order .EQ. 2) THEN
7495     i_start = its
7496     IF (ite .GT. ide - 1) THEN
7497       i_end = ide - 1
7498     ELSE
7499       i_end = ite
7500     END IF
7501     j_start = jts
7502     IF (jte .GT. jde - 1) THEN
7503       j_end = jde - 1
7504     ELSE
7505       j_end = jte
7506     END IF
7507     IF (.NOT.config_flags%periodic_x) THEN
7508       IF (config_flags%open_xs .OR. specified) THEN
7509         IF (ids + 1 .LT. its) THEN
7510           i_start = its
7511         ELSE
7512           i_start = ids + 1
7513         END IF
7514       END IF
7515       IF (config_flags%open_xe .OR. specified) THEN
7516         IF (ide - 2 .GT. ite) THEN
7517           i_end = ite
7518         ELSE
7519           i_end = ide - 2
7520         END IF
7521       END IF
7522     END IF
7523     ad_from30 = j_start
7524     DO j=ad_from30,j_end
7525       DO k=kts,ktf
7526         ad_from29 = i_start
7527         i = i_end + 1
7528         CALL PUSHINTEGER4(i - 1)
7529         CALL PUSHINTEGER4(ad_from29)
7530       END DO
7531     END DO
7532     CALL PUSHINTEGER4(j - 1)
7533     CALL PUSHINTEGER4(ad_from30)
7534     i_start = its
7535     IF (ite .GT. ide - 1) THEN
7536       i_end = ide - 1
7537     ELSE
7538       i_end = ite
7539     END IF
7540 ! Polar boundary conditions are like open or specified
7541     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
7542 &    THEN
7543       IF (jds + 1 .LT. jts) THEN
7544         j_start = jts
7545       ELSE
7546         j_start = jds + 1
7547       END IF
7548     END IF
7549     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
7550 &    THEN
7551       IF (jde - 2 .GT. jte) THEN
7552         j_end = jte
7553       ELSE
7554         j_end = jde - 2
7555       END IF
7556     END IF
7557     ad_from32 = j_start
7558     DO j=ad_from32,j_end
7559       DO k=kts,ktf
7560         ad_from31 = i_start
7561         i = i_end + 1
7562         CALL PUSHINTEGER4(i - 1)
7563         CALL PUSHINTEGER4(ad_from31)
7564       END DO
7565     END DO
7566     CALL PUSHINTEGER4(j - 1)
7567     CALL PUSHINTEGER4(ad_from32)
7568 ! Polar boundary condtions
7569 ! These won't be covered in the loop above...
7570     IF (config_flags%polar) THEN
7571       IF (jts .EQ. jds) THEN
7572         DO k=kts,ktf
7573           ad_from33 = i_start
7574           i = i_end + 1
7575           CALL PUSHINTEGER4(i - 1)
7576           CALL PUSHINTEGER4(ad_from33)
7577         END DO
7578         CALL PUSHCONTROL1B(0)
7579       ELSE
7580         CALL PUSHCONTROL1B(1)
7581       END IF
7582       IF (jte .EQ. jde) THEN
7583         DO k=kts,ktf
7584           ad_from34 = i_start
7585           i = i_end + 1
7586           CALL PUSHINTEGER4(i - 1)
7587           CALL PUSHINTEGER4(ad_from34)
7588         END DO
7589         CALL PUSHCONTROL3B(3)
7590       ELSE
7591         CALL PUSHCONTROL3B(2)
7592       END IF
7593     ELSE
7594       CALL PUSHCONTROL3B(1)
7595     END IF
7596   ELSE
7597     CALL PUSHCONTROL3B(0)
7598   END IF
7599 !  pick up the rest of the horizontal radiation boundary conditions.
7600 !  (these are the computations that don't require 'cb'.
7601 !  first, set to index ranges
7602   i_start = its
7603   IF (ite .GT. ide - 1) THEN
7604     i_end = ide - 1
7605   ELSE
7606     i_end = ite
7607   END IF
7608   CALL PUSHINTEGER4(j_start)
7609   j_start = jts
7610   IF (jte .GT. jde - 1) THEN
7611     j_end = jde - 1
7612   ELSE
7613     j_end = jte
7614   END IF
7615 !  compute x (u) conditions for v, w, or scalar
7616   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
7617     ad_from47 = j_start
7618     DO j=ad_from47,j_end
7619       DO k=kts,ktf
7620         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
7621           CALL PUSHREAL8(ub)
7622           ub = 0.
7623           CALL PUSHCONTROL1B(0)
7624         ELSE
7625           CALL PUSHREAL8(ub)
7626           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
7627           CALL PUSHCONTROL1B(1)
7628         END IF
7629       END DO
7630     END DO
7631     CALL PUSHINTEGER4(j - 1)
7632     CALL PUSHINTEGER4(ad_from47)
7633     CALL PUSHCONTROL1B(0)
7634   ELSE
7635     CALL PUSHCONTROL1B(1)
7636   END IF
7637   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
7638     ad_from48 = j_start
7639     DO j=ad_from48,j_end
7640       DO k=kts,ktf
7641         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
7642           CALL PUSHREAL8(ub)
7643           ub = 0.
7644           CALL PUSHCONTROL1B(0)
7645         ELSE
7646           CALL PUSHREAL8(ub)
7647           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
7648           CALL PUSHCONTROL1B(1)
7649         END IF
7650       END DO
7651     END DO
7652     CALL PUSHINTEGER4(j - 1)
7653     CALL PUSHINTEGER4(ad_from48)
7654     CALL PUSHCONTROL1B(0)
7655   ELSE
7656     CALL PUSHCONTROL1B(1)
7657   END IF
7658   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
7659     ad_from49 = i_start
7660     DO i=ad_from49,i_end
7661       DO k=kts,ktf
7662         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
7663           CALL PUSHREAL8(vb)
7664           vb = 0.
7665           CALL PUSHCONTROL1B(0)
7666         ELSE
7667           CALL PUSHREAL8(vb)
7668           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
7669           CALL PUSHCONTROL1B(1)
7670         END IF
7671       END DO
7672     END DO
7673     CALL PUSHINTEGER4(i - 1)
7674     CALL PUSHINTEGER4(ad_from49)
7675     CALL PUSHCONTROL1B(0)
7676   ELSE
7677     CALL PUSHCONTROL1B(1)
7678   END IF
7679   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
7680     ad_from50 = i_start
7681     DO i=ad_from50,i_end
7682       DO k=kts,ktf
7683         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
7684           CALL PUSHREAL8(vb)
7685           vb = 0.
7686           CALL PUSHCONTROL1B(0)
7687         ELSE
7688           CALL PUSHREAL8(vb)
7689           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
7690           CALL PUSHCONTROL1B(1)
7691         END IF
7692       END DO
7693     END DO
7694     CALL PUSHINTEGER4(i - 1)
7695     CALL PUSHINTEGER4(ad_from50)
7696     CALL PUSHCONTROL1B(1)
7697   ELSE
7698     CALL PUSHCONTROL1B(0)
7699   END IF
7700 !-------------------- vertical advection
7701 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
7702 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
7703 !     So we don't need to make a correction for advect_scalar
7704   i_start = its
7705   IF (ite .GT. ide - 1) THEN
7706     CALL PUSHINTEGER4(i_end)
7707     i_end = ide - 1
7708     CALL PUSHCONTROL1B(0)
7709   ELSE
7710     CALL PUSHINTEGER4(i_end)
7711     i_end = ite
7712     CALL PUSHCONTROL1B(1)
7713   END IF
7714   j_start = jts
7715   IF (jte .GT. jde - 1) THEN
7716     CALL PUSHINTEGER4(j_end)
7717     j_end = jde - 1
7718     CALL PUSHCONTROL1B(0)
7719   ELSE
7720     CALL PUSHINTEGER4(j_end)
7721     j_end = jte
7722     CALL PUSHCONTROL1B(1)
7723   END IF
7724   IF (vert_order .EQ. 6) THEN
7725     DO j=j_start,j_end
7726       CALL PUSHINTEGER4(k)
7727     END DO
7728     vfluxb = 0.0
7729     DO j=j_end,j_start,-1
7730       DO k=ktf,kts,-1
7731         DO i=i_end,i_start,-1
7732           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
7733           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
7734         END DO
7735       END DO
7736       CALL POPINTEGER4(k)
7737       DO i=i_end,i_start,-1
7738         k = ktf
7739         temp31b28 = rom(i, k, j)*vfluxb(i, k)
7740         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7741 &          field(i, k-1, j))*vfluxb(i, k)
7742         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b28
7743         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b28
7744         vfluxb(i, k) = 0.0
7745         k = ktf - 1
7746         vel = rom(i, k, j)
7747         temp31b29 = vel*vfluxb(i, k)/12.0
7748         velb = (7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-&
7749 &          field(i, k-2, j))*vfluxb(i, k)/12.0
7750         fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b29
7751         fieldb(i, k-1, j) = fieldb(i, k-1, j) + 7.*temp31b29
7752         fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b29
7753         fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b29
7754         vfluxb(i, k) = 0.0
7755         romb(i, k, j) = romb(i, k, j) + velb
7756         k = kts + 2
7757         vel = rom(i, k, j)
7758         temp31b30 = vel*vfluxb(i, k)/12.0
7759         velb = (7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-&
7760 &          field(i, k-2, j))*vfluxb(i, k)/12.0
7761         fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b30
7762         fieldb(i, k-1, j) = fieldb(i, k-1, j) + 7.*temp31b30
7763         fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b30
7764         fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b30
7765         vfluxb(i, k) = 0.0
7766         romb(i, k, j) = romb(i, k, j) + velb
7767         k = kts + 1
7768         temp31b31 = rom(i, k, j)*vfluxb(i, k)
7769         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7770 &          field(i, k-1, j))*vfluxb(i, k)
7771         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b31
7772         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b31
7773         vfluxb(i, k) = 0.0
7774       END DO
7775       DO k=ktf-2,kts+3,-1
7776         DO i=i_end,i_start,-1
7777           vel = rom(i, k, j)
7778           temp31b27 = vel*vfluxb(i, k)/60.0
7779           velb = (37.*(field(i, k, j)+field(i, k-1, j))-8.*(field(i, k+1&
7780 &            , j)+field(i, k-2, j))+field(i, k+2, j)+field(i, k-3, j))*&
7781 &            vfluxb(i, k)/60.0
7782           fieldb(i, k, j) = fieldb(i, k, j) + 37.*temp31b27
7783           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 37.*temp31b27
7784           fieldb(i, k+1, j) = fieldb(i, k+1, j) - 8.*temp31b27
7785           fieldb(i, k-2, j) = fieldb(i, k-2, j) - 8.*temp31b27
7786           fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b27
7787           fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b27
7788           vfluxb(i, k) = 0.0
7789           romb(i, k, j) = romb(i, k, j) + velb
7790         END DO
7791       END DO
7792     END DO
7793   ELSE IF (vert_order .EQ. 5) THEN
7794     DO j=j_start,j_end
7795       CALL PUSHINTEGER4(k)
7796     END DO
7797     vfluxb = 0.0
7798     DO j=j_end,j_start,-1
7799       DO k=ktf,kts,-1
7800         DO i=i_end,i_start,-1
7801           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
7802           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
7803         END DO
7804       END DO
7805       CALL POPINTEGER4(k)
7806       DO i=i_end,i_start,-1
7807         k = ktf
7808         temp43b = rom(i, k, j)*vfluxb(i, k)
7809         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7810 &          field(i, k-1, j))*vfluxb(i, k)
7811         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b
7812         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b
7813         vfluxb(i, k) = 0.0
7814         k = ktf - 1
7815         vel = rom(i, k, j)
7816         temp39 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j&
7817 &          )-field(i, k-1, j))
7818         temp42 = SIGN(1., -vel)
7819         temp41 = temp42/12.0
7820         temp40 = SIGN(1, time_step)
7821         temp39b = vel*vfluxb(i, k)
7822         temp39b0 = temp39b/12.0
7823         temp39b1 = temp40*temp41*temp39b
7824         velb = ((7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-&
7825 &          field(i, k-2, j))/12.0+temp40*(temp41*temp39))*vfluxb(i, k)
7826         fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp39b0 - 3.*temp39b1
7827         fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp39b1 + 7.*&
7828 &          temp39b0
7829         fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp39b1 - temp39b0
7830         fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp39b1 - temp39b0
7831         vfluxb(i, k) = 0.0
7832         romb(i, k, j) = romb(i, k, j) + velb
7833         k = kts + 2
7834         vel = rom(i, k, j)
7835         temp35 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j&
7836 &          )-field(i, k-1, j))
7837         temp38 = SIGN(1., -vel)
7838         temp37 = temp38/12.0
7839         temp36 = SIGN(1, time_step)
7840         temp35b = vel*vfluxb(i, k)
7841         temp35b0 = temp35b/12.0
7842         temp35b1 = temp36*temp37*temp35b
7843         velb = ((7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-&
7844 &          field(i, k-2, j))/12.0+temp36*(temp37*temp35))*vfluxb(i, k)
7845         fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp35b0 - 3.*temp35b1
7846         fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp35b1 + 7.*&
7847 &          temp35b0
7848         fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp35b1 - temp35b0
7849         fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp35b1 - temp35b0
7850         vfluxb(i, k) = 0.0
7851         romb(i, k, j) = romb(i, k, j) + velb
7852         k = kts + 1
7853         temp35b2 = rom(i, k, j)*vfluxb(i, k)
7854         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7855 &          field(i, k-1, j))*vfluxb(i, k)
7856         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp35b2
7857         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp35b2
7858         vfluxb(i, k) = 0.0
7859       END DO
7860       DO k=ktf-2,kts+3,-1
7861         DO i=i_end,i_start,-1
7862           vel = rom(i, k, j)
7863           temp31 = field(i, k+2, j) - field(i, k-3, j) + 10.*(field(i, k&
7864 &            , j)-field(i, k-1, j)) - 5.*(field(i, k+1, j)-field(i, k-2, &
7865 &            j))
7866           temp34 = SIGN(1., -vel)
7867           temp33 = temp34/60.0
7868           temp32 = SIGN(1, time_step)
7869           temp31b32 = vel*vfluxb(i, k)
7870           temp31b33 = temp31b32/60.0
7871           temp31b34 = -(temp32*temp33*temp31b32)
7872           velb = ((37.*(field(i, k, j)+field(i, k-1, j))-8.*(field(i, k+&
7873 &            1, j)+field(i, k-2, j))+field(i, k+2, j)+field(i, k-3, j))/&
7874 &            60.0-temp32*(temp33*temp31))*vfluxb(i, k)
7875           fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp31b34 + 37.*&
7876 &            temp31b33
7877           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 37.*temp31b33 - 10.*&
7878 &            temp31b34
7879           fieldb(i, k+1, j) = fieldb(i, k+1, j) - 5.*temp31b34 - 8.*&
7880 &            temp31b33
7881           fieldb(i, k-2, j) = fieldb(i, k-2, j) + 5.*temp31b34 - 8.*&
7882 &            temp31b33
7883           fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b34 + temp31b33
7884           fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b33 - temp31b34
7885           vfluxb(i, k) = 0.0
7886           romb(i, k, j) = romb(i, k, j) + velb
7887         END DO
7888       END DO
7889     END DO
7890   ELSE IF (vert_order .EQ. 4) THEN
7891     DO j=j_start,j_end
7892       CALL PUSHINTEGER4(k)
7893     END DO
7894     vfluxb = 0.0
7895     DO j=j_end,j_start,-1
7896       DO k=ktf,kts,-1
7897         DO i=i_end,i_start,-1
7898           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
7899           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
7900         END DO
7901       END DO
7902       CALL POPINTEGER4(k)
7903       DO i=i_end,i_start,-1
7904         k = ktf
7905         temp43b1 = rom(i, k, j)*vfluxb(i, k)
7906         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7907 &          field(i, k-1, j))*vfluxb(i, k)
7908         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b1
7909         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b1
7910         vfluxb(i, k) = 0.0
7911         k = kts + 1
7912         temp43b2 = rom(i, k, j)*vfluxb(i, k)
7913         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7914 &          field(i, k-1, j))*vfluxb(i, k)
7915         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b2
7916         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b2
7917         vfluxb(i, k) = 0.0
7918       END DO
7919       DO k=ktf-1,kts+2,-1
7920         DO i=i_end,i_start,-1
7921           vel = rom(i, k, j)
7922           temp43b0 = vel*vfluxb(i, k)/12.0
7923           velb = (7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-&
7924 &            field(i, k-2, j))*vfluxb(i, k)/12.0
7925           fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp43b0
7926           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 7.*temp43b0
7927           fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp43b0
7928           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b0
7929           vfluxb(i, k) = 0.0
7930           romb(i, k, j) = romb(i, k, j) + velb
7931         END DO
7932       END DO
7933     END DO
7934   ELSE IF (vert_order .EQ. 3) THEN
7935     DO j=j_start,j_end
7936       CALL PUSHINTEGER4(k)
7937     END DO
7938     vfluxb = 0.0
7939     DO j=j_end,j_start,-1
7940       DO k=ktf,kts,-1
7941         DO i=i_end,i_start,-1
7942           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
7943           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
7944         END DO
7945       END DO
7946       CALL POPINTEGER4(k)
7947       DO i=i_end,i_start,-1
7948         k = ktf
7949         temp47b = rom(i, k, j)*vfluxb(i, k)
7950         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7951 &          field(i, k-1, j))*vfluxb(i, k)
7952         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b
7953         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b
7954         vfluxb(i, k) = 0.0
7955         k = kts + 1
7956         temp47b0 = rom(i, k, j)*vfluxb(i, k)
7957         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7958 &          field(i, k-1, j))*vfluxb(i, k)
7959         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b0
7960         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b0
7961         vfluxb(i, k) = 0.0
7962       END DO
7963       DO k=ktf-1,kts+2,-1
7964         DO i=i_end,i_start,-1
7965           vel = rom(i, k, j)
7966           temp43 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k&
7967 &            , j)-field(i, k-1, j))
7968           temp46 = SIGN(1., -vel)
7969           temp45 = temp46/12.0
7970           temp44 = SIGN(1, time_step)
7971           temp43b3 = vel*vfluxb(i, k)
7972           temp43b4 = temp43b3/12.0
7973           temp43b5 = temp44*temp45*temp43b3
7974           velb = ((7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)&
7975 &            -field(i, k-2, j))/12.0+temp44*(temp45*temp43))*vfluxb(i, k)
7976           fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp43b4 - 3.*temp43b5
7977           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp43b5 + 7.*&
7978 &            temp43b4
7979           fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp43b5 - temp43b4
7980           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b5 - temp43b4
7981           vfluxb(i, k) = 0.0
7982           romb(i, k, j) = romb(i, k, j) + velb
7983         END DO
7984       END DO
7985     END DO
7986   ELSE IF (vert_order .EQ. 2) THEN
7987     vfluxb = 0.0
7988     DO j=j_end,j_start,-1
7989       DO k=ktf,kts,-1
7990         DO i=i_end,i_start,-1
7991           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
7992           vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
7993         END DO
7994       END DO
7995       DO k=ktf,kts+1,-1
7996         DO i=i_end,i_start,-1
7997           temp47b1 = rom(i, k, j)*vfluxb(i, k)
7998           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
7999 &            field(i, k-1, j))*vfluxb(i, k)
8000           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b1
8001           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b1
8002           vfluxb(i, k) = 0.0
8003         END DO
8004       END DO
8005     END DO
8006   END IF
8007   CALL POPCONTROL1B(branch)
8008   IF (branch .EQ. 0) THEN
8009     CALL POPINTEGER4(j_end)
8010   ELSE
8011     CALL POPINTEGER4(j_end)
8012   END IF
8013   CALL POPCONTROL1B(branch)
8014   IF (branch .EQ. 0) THEN
8015     CALL POPINTEGER4(i_end)
8016   ELSE
8017     CALL POPINTEGER4(i_end)
8018   END IF
8019   CALL POPCONTROL1B(branch)
8020   IF (branch .NE. 0) THEN
8021     CALL POPINTEGER4(ad_from50)
8022     CALL POPINTEGER4(ad_to50)
8023     DO i=ad_to50,ad_from50,-1
8024       DO k=ktf,kts,-1
8025         temp31b25 = -(rdy*tendencyb(i, k, j_end))
8026         temp31b26 = field(i, k, j_end)*temp31b25
8027         vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*&
8028 &          temp31b25
8029         field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*temp31b25
8030         field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*&
8031 &          temp31b25
8032         fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i&
8033 &          , k, jte-1))*temp31b25
8034         rvb(i, k, jte) = rvb(i, k, jte) + temp31b26
8035         rvb(i, k, jte-1) = rvb(i, k, jte-1) - temp31b26
8036         CALL POPCONTROL1B(branch)
8037         IF (branch .EQ. 0) THEN
8038           CALL POPREAL8(vb)
8039         ELSE
8040           CALL POPREAL8(vb)
8041           rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb
8042           rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb
8043         END IF
8044       END DO
8045     END DO
8046   END IF
8047   CALL POPCONTROL1B(branch)
8048   IF (branch .EQ. 0) THEN
8049     CALL POPINTEGER4(ad_from49)
8050     CALL POPINTEGER4(ad_to49)
8051     DO i=ad_to49,ad_from49,-1
8052       DO k=ktf,kts,-1
8053         temp31b23 = -(rdy*tendencyb(i, k, jts))
8054         temp31b24 = field(i, k, jts)*temp31b23
8055         vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*temp31b23
8056         field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*temp31b23
8057         field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*temp31b23
8058         fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k&
8059 &          , jts))*temp31b23
8060         rvb(i, k, jts+1) = rvb(i, k, jts+1) + temp31b24
8061         rvb(i, k, jts) = rvb(i, k, jts) - temp31b24
8062         CALL POPCONTROL1B(branch)
8063         IF (branch .EQ. 0) THEN
8064           CALL POPREAL8(vb)
8065         ELSE
8066           CALL POPREAL8(vb)
8067           rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb
8068           rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb
8069         END IF
8070       END DO
8071     END DO
8072   END IF
8073   CALL POPCONTROL1B(branch)
8074   IF (branch .EQ. 0) THEN
8075     CALL POPINTEGER4(ad_from48)
8076     CALL POPINTEGER4(ad_to48)
8077     DO j=ad_to48,ad_from48,-1
8078       DO k=ktf,kts,-1
8079         temp31b21 = -(rdx*tendencyb(i_end, k, j))
8080         temp31b22 = field(i_end, k, j)*temp31b21
8081         ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*&
8082 &          temp31b21
8083         field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*temp31b21
8084         field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*&
8085 &          temp31b21
8086         fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(&
8087 &          ite-1, k, j))*temp31b21
8088         rub(ite, k, j) = rub(ite, k, j) + temp31b22
8089         rub(ite-1, k, j) = rub(ite-1, k, j) - temp31b22
8090         CALL POPCONTROL1B(branch)
8091         IF (branch .EQ. 0) THEN
8092           CALL POPREAL8(ub)
8093         ELSE
8094           CALL POPREAL8(ub)
8095           rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb
8096           rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb
8097         END IF
8098       END DO
8099     END DO
8100   END IF
8101   CALL POPCONTROL1B(branch)
8102   IF (branch .EQ. 0) THEN
8103     CALL POPINTEGER4(ad_from47)
8104     CALL POPINTEGER4(ad_to47)
8105     DO j=ad_to47,ad_from47,-1
8106       DO k=ktf,kts,-1
8107         temp31b19 = -(rdx*tendencyb(its, k, j))
8108         temp31b20 = field(its, k, j)*temp31b19
8109         ubb = (field_old(its+1, k, j)-field_old(its, k, j))*temp31b19
8110         field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*temp31b19
8111         field_oldb(its, k, j) = field_oldb(its, k, j) - ub*temp31b19
8112         fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its&
8113 &          , k, j))*temp31b19
8114         rub(its+1, k, j) = rub(its+1, k, j) + temp31b20
8115         rub(its, k, j) = rub(its, k, j) - temp31b20
8116         CALL POPCONTROL1B(branch)
8117         IF (branch .EQ. 0) THEN
8118           CALL POPREAL8(ub)
8119         ELSE
8120           CALL POPREAL8(ub)
8121           rub(its, k, j) = rub(its, k, j) + 0.5*ubb
8122           rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb
8123         END IF
8124       END DO
8125     END DO
8126   END IF
8127   CALL POPINTEGER4(j_start)
8128   CALL POPCONTROL3B(branch)
8129   IF (branch .LT. 4) THEN
8130     IF (branch .LT. 2) THEN
8131       IF (branch .EQ. 0) GOTO 100
8132     ELSE
8133       IF (branch .NE. 2) THEN
8134         DO k=ktf,kts,-1
8135           CALL POPINTEGER4(ad_from34)
8136           CALL POPINTEGER4(ad_to34)
8137           DO i=ad_to34,ad_from34,-1
8138             mrdy = msftx(i, jde-1)*rdy
8139             temp31b7 = mrdy*0.5*tendencyb(i, k, jde-1)
8140             temp31b8 = rv(i, k, jde-1)*temp31b7
8141             rvb(i, k, jde-1) = rvb(i, k, jde-1) + (field(i, k, jde-1)+&
8142 &              field(i, k, jde-2))*temp31b7
8143             fieldb(i, k, jde-1) = fieldb(i, k, jde-1) + temp31b8
8144             fieldb(i, k, jde-2) = fieldb(i, k, jde-2) + temp31b8
8145           END DO
8146         END DO
8147       END IF
8148       CALL POPCONTROL1B(branch)
8149       IF (branch .EQ. 0) THEN
8150         DO k=ktf,kts,-1
8151           CALL POPINTEGER4(ad_from33)
8152           CALL POPINTEGER4(ad_to33)
8153           DO i=ad_to33,ad_from33,-1
8154             mrdy = msftx(i, jds)*rdy
8155             temp31b5 = -(mrdy*0.5*tendencyb(i, k, jds))
8156             temp31b6 = rv(i, k, jds+1)*temp31b5
8157             rvb(i, k, jds+1) = rvb(i, k, jds+1) + (field(i, k, jds+1)+&
8158 &              field(i, k, jds))*temp31b5
8159             fieldb(i, k, jds+1) = fieldb(i, k, jds+1) + temp31b6
8160             fieldb(i, k, jds) = fieldb(i, k, jds) + temp31b6
8161           END DO
8162         END DO
8163       END IF
8164     END IF
8165     CALL POPINTEGER4(ad_from32)
8166     CALL POPINTEGER4(ad_to32)
8167     DO j=ad_to32,ad_from32,-1
8168       DO k=ktf,kts,-1
8169         CALL POPINTEGER4(ad_from31)
8170         CALL POPINTEGER4(ad_to31)
8171         DO i=ad_to31,ad_from31,-1
8172           mrdy = msftx(i, j)*rdy
8173           temp31b2 = -(mrdy*0.5*tendencyb(i, k, j))
8174           temp31b3 = rv(i, k, j+1)*temp31b2
8175           temp31b4 = -(rv(i, k, j)*temp31b2)
8176           rvb(i, k, j+1) = rvb(i, k, j+1) + (field(i, k, j+1)+field(i, k&
8177 &            , j))*temp31b2
8178           fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp31b3
8179           fieldb(i, k, j) = fieldb(i, k, j) + temp31b4 + temp31b3
8180           rvb(i, k, j) = rvb(i, k, j) - (field(i, k, j)+field(i, k, j-1)&
8181 &            )*temp31b2
8182           fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b4
8183         END DO
8184       END DO
8185     END DO
8186     CALL POPINTEGER4(ad_from30)
8187     CALL POPINTEGER4(ad_to30)
8188     DO j=ad_to30,ad_from30,-1
8189       DO k=ktf,kts,-1
8190         CALL POPINTEGER4(ad_from29)
8191         CALL POPINTEGER4(ad_to29)
8192         DO i=ad_to29,ad_from29,-1
8193           mrdx = msftx(i, j)*rdx
8194           temp31b = -(mrdx*0.5*tendencyb(i, k, j))
8195           temp31b0 = ru(i+1, k, j)*temp31b
8196           temp31b1 = -(ru(i, k, j)*temp31b)
8197           rub(i+1, k, j) = rub(i+1, k, j) + (field(i+1, k, j)+field(i, k&
8198 &            , j))*temp31b
8199           fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp31b0
8200           fieldb(i, k, j) = fieldb(i, k, j) + temp31b1 + temp31b0
8201           rub(i, k, j) = rub(i, k, j) - (field(i, k, j)+field(i-1, k, j)&
8202 &            )*temp31b
8203           fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b1
8204         END DO
8205       END DO
8206     END DO
8207   ELSE IF (branch .LT. 6) THEN
8208     IF (branch .EQ. 4) THEN
8209       fqyb = 0.0
8210       CALL POPINTEGER4(ad_from28)
8211       CALL POPINTEGER4(ad_to28)
8212       DO j=ad_to28,ad_from28,-1
8213         CALL POPINTEGER4(jp0)
8214         CALL POPINTEGER4(jp1)
8215         CALL POPCONTROL2B(branch)
8216         IF (branch .LT. 2) THEN
8217           IF (branch .EQ. 0) THEN
8218             DO k=ktf,kts,-1
8219               CALL POPINTEGER4(ad_from25)
8220               CALL POPINTEGER4(ad_to25)
8221               DO i=ad_to25,ad_from25,-1
8222                 mrdy = msftx(i, j-1)*rdy
8223                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
8224 &                  , j-1)
8225               END DO
8226             END DO
8227           ELSE
8228             DO k=ktf,kts,-1
8229               CALL POPINTEGER4(ad_from26)
8230               CALL POPINTEGER4(ad_to26)
8231               DO i=ad_to26,ad_from26,-1
8232                 mrdy = msftx(i, j-1)*rdy
8233                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
8234 &                  , j-1)
8235               END DO
8236             END DO
8237           END IF
8238         ELSE IF (branch .EQ. 2) THEN
8239           DO k=ktf,kts,-1
8240             CALL POPINTEGER4(ad_from27)
8241             CALL POPINTEGER4(ad_to27)
8242             DO i=ad_to27,ad_from27,-1
8243               mrdy = msftx(i, j-1)*rdy
8244               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
8245 &                -1)
8246               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
8247 &                -1)
8248             END DO
8249           END DO
8250         END IF
8251         CALL POPCONTROL2B(branch)
8252         IF (branch .EQ. 0) THEN
8253           DO k=ktf,kts,-1
8254             CALL POPINTEGER4(ad_from22)
8255             CALL POPINTEGER4(ad_to22)
8256             DO i=ad_to22,ad_from22,-1
8257               temp27b1 = 0.5*rv(i, k, j_start)*fqyb(i, k, jp1)
8258               rvb(i, k, j_start) = rvb(i, k, j_start) + 0.5*(field(i, k&
8259 &                , j_start)+field(i, k, j_start-1))*fqyb(i, k, jp1)
8260               fieldb(i, k, j_start) = fieldb(i, k, j_start) + temp27b1
8261               fieldb(i, k, j_start-1) = fieldb(i, k, j_start-1) + &
8262 &                temp27b1
8263               fqyb(i, k, jp1) = 0.0
8264             END DO
8265           END DO
8266         ELSE IF (branch .EQ. 1) THEN
8267           DO k=ktf,kts,-1
8268             CALL POPINTEGER4(ad_from23)
8269             CALL POPINTEGER4(ad_to23)
8270             DO i=ad_to23,ad_from23,-1
8271               temp27b2 = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
8272               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
8273 &                , k, j-1))*fqyb(i, k, jp1)
8274               fieldb(i, k, j) = fieldb(i, k, j) + temp27b2
8275               fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp27b2
8276               fqyb(i, k, jp1) = 0.0
8277             END DO
8278           END DO
8279         ELSE
8280           DO k=ktf,kts,-1
8281             CALL POPINTEGER4(ad_from24)
8282             CALL POPINTEGER4(ad_to24)
8283             DO i=ad_to24,ad_from24,-1
8284               temp27 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i&
8285 &                , k, j)-field(i, k, j-1))
8286               temp30 = SIGN(1., rv(i, k, j))
8287               temp29 = temp30/12.0
8288               temp28 = SIGN(1, time_step)
8289               temp27b3 = rv(i, k, j)*fqyb(i, k, jp1)
8290               temp27b4 = temp27b3/12.0
8291               temp27b5 = temp28*temp29*temp27b3
8292               rvb(i, k, j) = rvb(i, k, j) + ((7.*(field(i, k, j)+field(i&
8293 &                , k, j-1))-field(i, k, j+1)-field(i, k, j-2))/12.0+&
8294 &                temp28*(temp29*temp27))*fqyb(i, k, jp1)
8295               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp27b4 - 3.*&
8296 &                temp27b5
8297               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp27b5 + 7.*&
8298 &                temp27b4
8299               fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp27b5 - &
8300 &                temp27b4
8301               fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp27b5 - &
8302 &                temp27b4
8303               fqyb(i, k, jp1) = 0.0
8304             END DO
8305           END DO
8306         END IF
8307       END DO
8308       CALL POPCONTROL1B(branch)
8309       IF (branch .EQ. 0) THEN
8310         CALL POPINTEGER4(i_end)
8311       ELSE
8312         CALL POPINTEGER4(i_end)
8313       END IF
8314       CALL POPINTEGER4(i_start)
8315       fqxb = 0.0
8316       CALL POPINTEGER4(ad_from21)
8317       CALL POPINTEGER4(ad_to21)
8318       DO j=ad_to21,ad_from21,-1
8319         DO k=ktf,kts,-1
8320           CALL POPINTEGER4(ad_from20)
8321           CALL POPINTEGER4(ad_to20)
8322           DO i=ad_to20,ad_from20,-1
8323             mrdx = msftx(i, j)*rdx
8324             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
8325             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
8326           END DO
8327         END DO
8328         CALL POPCONTROL1B(branch)
8329         IF (branch .NE. 0) THEN
8330           DO k=ktf,kts,-1
8331             temp27b0 = 0.5*ru(i_end+1, k, j)*fqxb(i_end+1, k)
8332             rub(i_end+1, k, j) = rub(i_end+1, k, j) + 0.5*(field(i_end+1&
8333 &              , k, j)+field(i_end, k, j))*fqxb(i_end+1, k)
8334             fieldb(i_end+1, k, j) = fieldb(i_end+1, k, j) + temp27b0
8335             fieldb(i_end, k, j) = fieldb(i_end, k, j) + temp27b0
8336             fqxb(i_end+1, k) = 0.0
8337           END DO
8338         END IF
8339         CALL POPCONTROL1B(branch)
8340         IF (branch .EQ. 0) THEN
8341           DO k=ktf,kts,-1
8342             temp27b = 0.5*ru(i_start, k, j)*fqxb(i_start, k)
8343             rub(i_start, k, j) = rub(i_start, k, j) + 0.5*(field(i_start&
8344 &              , k, j)+field(i_start-1, k, j))*fqxb(i_start, k)
8345             fieldb(i_start, k, j) = fieldb(i_start, k, j) + temp27b
8346             fieldb(i_start-1, k, j) = fieldb(i_start-1, k, j) + temp27b
8347             fqxb(i_start, k) = 0.0
8348           END DO
8349         END IF
8350         DO k=ktf,kts,-1
8351           DO i=i_end_f,i_start_f,-1
8352             temp23 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i, &
8353 &              k, j)-field(i-1, k, j))
8354             temp26 = SIGN(1., ru(i, k, j))
8355             temp25 = temp26/12.0
8356             temp24 = SIGN(1, time_step)
8357             temp23b5 = ru(i, k, j)*fqxb(i, k)
8358             temp23b6 = temp23b5/12.0
8359             temp23b7 = temp24*temp25*temp23b5
8360             rub(i, k, j) = rub(i, k, j) + ((7.*(field(i, k, j)+field(i-1&
8361 &              , k, j))-field(i+1, k, j)-field(i-2, k, j))/12.0+temp24*(&
8362 &              temp25*temp23))*fqxb(i, k)
8363             fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp23b6 - 3.*&
8364 &              temp23b7
8365             fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp23b7 + 7.*&
8366 &              temp23b6
8367             fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp23b7 - temp23b6
8368             fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp23b7 - temp23b6
8369             fqxb(i, k) = 0.0
8370           END DO
8371         END DO
8372       END DO
8373     ELSE
8374       fqyb = 0.0
8375       CALL POPINTEGER4(ad_from19)
8376       CALL POPINTEGER4(ad_to19)
8377       DO j=ad_to19,ad_from19,-1
8378         CALL POPINTEGER4(jp0)
8379         CALL POPINTEGER4(jp1)
8380         CALL POPCONTROL2B(branch)
8381         IF (branch .LT. 2) THEN
8382           IF (branch .EQ. 0) THEN
8383             DO k=ktf,kts,-1
8384               CALL POPINTEGER4(ad_from16)
8385               CALL POPINTEGER4(ad_to16)
8386               DO i=ad_to16,ad_from16,-1
8387                 mrdy = msftx(i, j-1)*rdy
8388                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
8389 &                  , j-1)
8390               END DO
8391             END DO
8392           ELSE
8393             DO k=ktf,kts,-1
8394               CALL POPINTEGER4(ad_from17)
8395               CALL POPINTEGER4(ad_to17)
8396               DO i=ad_to17,ad_from17,-1
8397                 mrdy = msftx(i, j-1)*rdy
8398                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
8399 &                  , j-1)
8400               END DO
8401             END DO
8402           END IF
8403         ELSE IF (branch .EQ. 2) THEN
8404           DO k=ktf,kts,-1
8405             CALL POPINTEGER4(ad_from18)
8406             CALL POPINTEGER4(ad_to18)
8407             DO i=ad_to18,ad_from18,-1
8408               mrdy = msftx(i, j-1)*rdy
8409               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
8410 &                -1)
8411               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
8412 &                -1)
8413             END DO
8414           END DO
8415         END IF
8416         CALL POPCONTROL2B(branch)
8417         IF (branch .EQ. 0) THEN
8418           DO k=ktf,kts,-1
8419             CALL POPINTEGER4(ad_from13)
8420             CALL POPINTEGER4(ad_to13)
8421             DO i=ad_to13,ad_from13,-1
8422               temp23b2 = 0.5*rv(i, k, j_start)*fqyb(i, k, jp1)
8423               rvb(i, k, j_start) = rvb(i, k, j_start) + 0.5*(field(i, k&
8424 &                , j_start)+field(i, k, j_start-1))*fqyb(i, k, jp1)
8425               fieldb(i, k, j_start) = fieldb(i, k, j_start) + temp23b2
8426               fieldb(i, k, j_start-1) = fieldb(i, k, j_start-1) + &
8427 &                temp23b2
8428               fqyb(i, k, jp1) = 0.0
8429             END DO
8430           END DO
8431         ELSE IF (branch .EQ. 1) THEN
8432           DO k=ktf,kts,-1
8433             CALL POPINTEGER4(ad_from14)
8434             CALL POPINTEGER4(ad_to14)
8435             DO i=ad_to14,ad_from14,-1
8436               temp23b3 = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
8437               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
8438 &                , k, j-1))*fqyb(i, k, jp1)
8439               fieldb(i, k, j) = fieldb(i, k, j) + temp23b3
8440               fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b3
8441               fqyb(i, k, jp1) = 0.0
8442             END DO
8443           END DO
8444         ELSE
8445           DO k=ktf,kts,-1
8446             CALL POPINTEGER4(ad_from15)
8447             CALL POPINTEGER4(ad_to15)
8448             DO i=ad_to15,ad_from15,-1
8449               temp23b4 = rv(i, k, j)*fqyb(i, k, jp1)/12.0
8450               rvb(i, k, j) = rvb(i, k, j) + (7.*(field(i, k, j)+field(i&
8451 &                , k, j-1))-field(i, k, j+1)-field(i, k, j-2))*fqyb(i, k&
8452 &                , jp1)/12.0
8453               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp23b4
8454               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 7.*temp23b4
8455               fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp23b4
8456               fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp23b4
8457               fqyb(i, k, jp1) = 0.0
8458             END DO
8459           END DO
8460         END IF
8461       END DO
8462       CALL POPCONTROL1B(branch)
8463       IF (branch .EQ. 0) THEN
8464         CALL POPINTEGER4(i_end)
8465       ELSE
8466         CALL POPINTEGER4(i_end)
8467       END IF
8468       CALL POPINTEGER4(i_start)
8469       fqxb = 0.0
8470       CALL POPINTEGER4(ad_from12)
8471       CALL POPINTEGER4(ad_to12)
8472       DO j=ad_to12,ad_from12,-1
8473         DO k=ktf,kts,-1
8474           CALL POPINTEGER4(ad_from11)
8475           CALL POPINTEGER4(ad_to11)
8476           DO i=ad_to11,ad_from11,-1
8477             mrdx = msftx(i, j)*rdx
8478             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
8479             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
8480           END DO
8481         END DO
8482         CALL POPCONTROL1B(branch)
8483         IF (branch .NE. 0) THEN
8484           DO k=ktf,kts,-1
8485             temp23b1 = 0.5*ru(i_end+1, k, j)*fqxb(i_end+1, k)
8486             rub(i_end+1, k, j) = rub(i_end+1, k, j) + 0.5*(field(i_end+1&
8487 &              , k, j)+field(i_end, k, j))*fqxb(i_end+1, k)
8488             fieldb(i_end+1, k, j) = fieldb(i_end+1, k, j) + temp23b1
8489             fieldb(i_end, k, j) = fieldb(i_end, k, j) + temp23b1
8490             fqxb(i_end+1, k) = 0.0
8491           END DO
8492         END IF
8493         CALL POPCONTROL1B(branch)
8494         IF (branch .EQ. 0) THEN
8495           DO k=ktf,kts,-1
8496             temp23b0 = 0.5*ru(i_start, k, j)*fqxb(i_start, k)
8497             rub(i_start, k, j) = rub(i_start, k, j) + 0.5*(field(i_start&
8498 &              , k, j)+field(i_start-1, k, j))*fqxb(i_start, k)
8499             fieldb(i_start, k, j) = fieldb(i_start, k, j) + temp23b0
8500             fieldb(i_start-1, k, j) = fieldb(i_start-1, k, j) + temp23b0
8501             fqxb(i_start, k) = 0.0
8502           END DO
8503         END IF
8504         DO k=ktf,kts,-1
8505           DO i=i_end_f,i_start_f,-1
8506             temp23b = ru(i, k, j)*fqxb(i, k)/12.0
8507             rub(i, k, j) = rub(i, k, j) + (7.*(field(i, k, j)+field(i-1&
8508 &              , k, j))-field(i+1, k, j)-field(i-2, k, j))*fqxb(i, k)/&
8509 &              12.0
8510             fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp23b
8511             fieldb(i-1, k, j) = fieldb(i-1, k, j) + 7.*temp23b
8512             fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp23b
8513             fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp23b
8514             fqxb(i, k) = 0.0
8515           END DO
8516         END DO
8517       END DO
8518     END IF
8519   ELSE IF (branch .EQ. 6) THEN
8520     fqxb = 0.0
8521     CALL POPINTEGER4(ad_from10)
8522     CALL POPINTEGER4(ad_to10)
8523     DO j=ad_to10,ad_from10,-1
8524       DO k=ktf,kts,-1
8525         CALL POPINTEGER4(ad_from9)
8526         CALL POPINTEGER4(ad_to9)
8527         DO i=ad_to9,ad_from9,-1
8528           mrdx = msftx(i, j)*rdx
8529           fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
8530           fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
8531         END DO
8532       END DO
8533       CALL POPCONTROL1B(branch)
8534       IF (branch .NE. 0) THEN
8535         CALL POPINTEGER4(ad_to8)
8536         DO i=ad_to8,i_end_f+1,-1
8537           CALL POPCONTROL1B(branch)
8538           IF (branch .NE. 0) THEN
8539             DO k=ktf,kts,-1
8540               vel = ru(i, k, j)
8541               temp19 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
8542 &                , k, j)-field(i-1, k, j))
8543               temp22 = SIGN(1., vel)
8544               temp21 = temp22/12.0
8545               temp20 = SIGN(1, time_step)
8546               temp19b0 = vel*fqxb(i, k)
8547               temp19b1 = temp19b0/12.0
8548               temp19b2 = temp20*temp21*temp19b0
8549               velb = ((7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k&
8550 &                , j)-field(i-2, k, j))/12.0+temp20*(temp21*temp19))*fqxb&
8551 &                (i, k)
8552               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp19b1 - 3.*&
8553 &                temp19b2
8554               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp19b2 + 7.*&
8555 &                temp19b1
8556               fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp19b2 - &
8557 &                temp19b1
8558               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp19b2 - &
8559 &                temp19b1
8560               fqxb(i, k) = 0.0
8561               rub(i, k, j) = rub(i, k, j) + velb
8562             END DO
8563           END IF
8564           CALL POPCONTROL1B(branch)
8565           IF (branch .EQ. 0) THEN
8566             DO k=ktf,kts,-1
8567               temp19b = 0.5*ru(i, k, j)*fqxb(i, k)
8568               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
8569 &                1, k, j))*fqxb(i, k)
8570               fieldb(i, k, j) = fieldb(i, k, j) + temp19b
8571               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp19b
8572               fqxb(i, k) = 0.0
8573             END DO
8574           END IF
8575         END DO
8576       END IF
8577       CALL POPCONTROL1B(branch)
8578       IF (branch .EQ. 0) THEN
8579         CALL POPINTEGER4(ad_from8)
8580         DO i=i_start_f-1,ad_from8,-1
8581           CALL POPCONTROL1B(branch)
8582           IF (branch .NE. 0) THEN
8583             DO k=ktf,kts,-1
8584               vel = ru(i, k, j)
8585               temp15 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
8586 &                , k, j)-field(i-1, k, j))
8587               temp18 = SIGN(1., vel)
8588               temp17 = temp18/12.0
8589               temp16 = SIGN(1, time_step)
8590               temp15b0 = vel*fqxb(i, k)
8591               temp15b1 = temp15b0/12.0
8592               temp15b2 = temp16*temp17*temp15b0
8593               velb = ((7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k&
8594 &                , j)-field(i-2, k, j))/12.0+temp16*(temp17*temp15))*fqxb&
8595 &                (i, k)
8596               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp15b1 - 3.*&
8597 &                temp15b2
8598               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp15b2 + 7.*&
8599 &                temp15b1
8600               fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp15b2 - &
8601 &                temp15b1
8602               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp15b2 - &
8603 &                temp15b1
8604               fqxb(i, k) = 0.0
8605               rub(i, k, j) = rub(i, k, j) + velb
8606             END DO
8607           END IF
8608           CALL POPCONTROL1B(branch)
8609           IF (branch .EQ. 0) THEN
8610             DO k=ktf,kts,-1
8611               temp15b = 0.5*ru(i, k, j)*fqxb(i, k)
8612               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
8613 &                1, k, j))*fqxb(i, k)
8614               fieldb(i, k, j) = fieldb(i, k, j) + temp15b
8615               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp15b
8616               fqxb(i, k) = 0.0
8617             END DO
8618           END IF
8619         END DO
8620       END IF
8621       DO k=ktf,kts,-1
8622         DO i=i_end_f,i_start_f,-1
8623           vel = ru(i, k, j)
8624           temp11 = field(i+2, k, j) - field(i-3, k, j) + 10.*(field(i, k&
8625 &            , j)-field(i-1, k, j)) - 5.*(field(i+1, k, j)-field(i-2, k, &
8626 &            j))
8627           temp14 = SIGN(1., vel)
8628           temp13 = temp14/60.0
8629           temp12 = SIGN(1, time_step)
8630           temp11b = vel*fqxb(i, k)
8631           temp11b0 = temp11b/60.0
8632           temp11b1 = -(temp12*temp13*temp11b)
8633           velb = ((37.*(field(i, k, j)+field(i-1, k, j))-8.*(field(i+1, &
8634 &            k, j)+field(i-2, k, j))+field(i+2, k, j)+field(i-3, k, j))/&
8635 &            60.0-temp12*(temp13*temp11))*fqxb(i, k)
8636           fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp11b1 + 37.*&
8637 &            temp11b0
8638           fieldb(i-1, k, j) = fieldb(i-1, k, j) + 37.*temp11b0 - 10.*&
8639 &            temp11b1
8640           fieldb(i+1, k, j) = fieldb(i+1, k, j) - 5.*temp11b1 - 8.*&
8641 &            temp11b0
8642           fieldb(i-2, k, j) = fieldb(i-2, k, j) + 5.*temp11b1 - 8.*&
8643 &            temp11b0
8644           fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp11b1 + temp11b0
8645           fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp11b0 - temp11b1
8646           fqxb(i, k) = 0.0
8647           rub(i, k, j) = rub(i, k, j) + velb
8648         END DO
8649       END DO
8650     END DO
8651     fqyb = 0.0
8652     CALL POPINTEGER4(ad_from7)
8653     CALL POPINTEGER4(ad_to7)
8654     DO j=ad_to7,ad_from7,-1
8655       CALL POPINTEGER4(jp0)
8656       CALL POPINTEGER4(jp1)
8657       CALL POPCONTROL2B(branch)
8658       IF (branch .LT. 2) THEN
8659         IF (branch .EQ. 0) THEN
8660           DO k=ktf,kts,-1
8661             CALL POPINTEGER4(ad_from4)
8662             CALL POPINTEGER4(ad_to4)
8663             DO i=ad_to4,ad_from4,-1
8664               mrdy = msftx(i, j-1)*rdy
8665               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
8666 &                -1)
8667             END DO
8668           END DO
8669         ELSE
8670           DO k=ktf,kts,-1
8671             CALL POPINTEGER4(ad_from5)
8672             CALL POPINTEGER4(ad_to5)
8673             DO i=ad_to5,ad_from5,-1
8674               mrdy = msftx(i, j-1)*rdy
8675               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
8676 &                -1)
8677             END DO
8678           END DO
8679         END IF
8680       ELSE IF (branch .EQ. 2) THEN
8681         DO k=ktf,kts,-1
8682           CALL POPINTEGER4(ad_from6)
8683           CALL POPINTEGER4(ad_to6)
8684           DO i=ad_to6,ad_from6,-1
8685             mrdy = msftx(i, j-1)*rdy
8686             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
8687 &              )
8688             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
8689 &              )
8690           END DO
8691         END DO
8692       END IF
8693       CALL POPCONTROL3B(branch)
8694       IF (branch .LT. 3) THEN
8695         IF (branch .EQ. 0) THEN
8696           DO k=ktf,kts,-1
8697             CALL POPINTEGER4(ad_from)
8698             CALL POPINTEGER4(ad_to)
8699             DO i=ad_to,ad_from,-1
8700               vel = rv(i, k, j)
8701               temp = field(i, k, j+2) - field(i, k, j-3) + 10.*(field(i&
8702 &                , k, j)-field(i, k, j-1)) - 5.*(field(i, k, j+1)-field(i&
8703 &                , k, j-2))
8704               temp2 = SIGN(1., vel)
8705               temp1 = temp2/60.0
8706               temp0 = SIGN(1, time_step)
8707               tempb = vel*fqyb(i, k, jp1)
8708               tempb0 = tempb/60.0
8709               tempb1 = -(temp0*temp1*tempb)
8710               velb = ((37.*(field(i, k, j)+field(i, k, j-1))-8.*(field(i&
8711 &                , k, j+1)+field(i, k, j-2))+field(i, k, j+2)+field(i, k&
8712 &                , j-3))/60.0-temp0*(temp1*temp))*fqyb(i, k, jp1)
8713               fieldb(i, k, j) = fieldb(i, k, j) + 10.*tempb1 + 37.*&
8714 &                tempb0
8715               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 37.*tempb0 - 10.*&
8716 &                tempb1
8717               fieldb(i, k, j+1) = fieldb(i, k, j+1) - 5.*tempb1 - 8.*&
8718 &                tempb0
8719               fieldb(i, k, j-2) = fieldb(i, k, j-2) + 5.*tempb1 - 8.*&
8720 &                tempb0
8721               fieldb(i, k, j+2) = fieldb(i, k, j+2) + tempb1 + tempb0
8722               fieldb(i, k, j-3) = fieldb(i, k, j-3) + tempb0 - tempb1
8723               fqyb(i, k, jp1) = 0.0
8724               rvb(i, k, j) = rvb(i, k, j) + velb
8725             END DO
8726           END DO
8727         ELSE IF (branch .EQ. 1) THEN
8728           DO k=ktf,kts,-1
8729             CALL POPINTEGER4(ad_from0)
8730             CALL POPINTEGER4(ad_to0)
8731             DO i=ad_to0,ad_from0,-1
8732               temp3b = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
8733               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
8734 &                , k, j-1))*fqyb(i, k, jp1)
8735               fieldb(i, k, j) = fieldb(i, k, j) + temp3b
8736               fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp3b
8737               fqyb(i, k, jp1) = 0.0
8738             END DO
8739           END DO
8740         ELSE
8741           DO k=ktf,kts,-1
8742             CALL POPINTEGER4(ad_from1)
8743             CALL POPINTEGER4(ad_to1)
8744             DO i=ad_to1,ad_from1,-1
8745               vel = rv(i, k, j)
8746               temp3 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i&
8747 &                , k, j)-field(i, k, j-1))
8748               temp6 = SIGN(1., vel)
8749               temp5 = temp6/12.0
8750               temp4 = SIGN(1, time_step)
8751               temp3b0 = vel*fqyb(i, k, jp1)
8752               temp3b1 = temp3b0/12.0
8753               temp3b2 = temp4*temp5*temp3b0
8754               velb = ((7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, &
8755 &                j+1)-field(i, k, j-2))/12.0+temp4*(temp5*temp3))*fqyb(i&
8756 &                , k, jp1)
8757               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp3b1 - 3.*&
8758 &                temp3b2
8759               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp3b2 + 7.*&
8760 &                temp3b1
8761               fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp3b2 - temp3b1
8762               fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp3b2 - temp3b1
8763               fqyb(i, k, jp1) = 0.0
8764               rvb(i, k, j) = rvb(i, k, j) + velb
8765             END DO
8766           END DO
8767         END IF
8768       ELSE IF (branch .EQ. 3) THEN
8769         DO k=ktf,kts,-1
8770           CALL POPINTEGER4(ad_from2)
8771           CALL POPINTEGER4(ad_to2)
8772           DO i=ad_to2,ad_from2,-1
8773             temp7b = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
8774             rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k&
8775 &              , j-1))*fqyb(i, k, jp1)
8776             fieldb(i, k, j) = fieldb(i, k, j) + temp7b
8777             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp7b
8778             fqyb(i, k, jp1) = 0.0
8779           END DO
8780         END DO
8781       ELSE IF (branch .EQ. 4) THEN
8782         DO k=ktf,kts,-1
8783           CALL POPINTEGER4(ad_from3)
8784           CALL POPINTEGER4(ad_to3)
8785           DO i=ad_to3,ad_from3,-1
8786             vel = rv(i, k, j)
8787             temp7 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k&
8788 &              , j)-field(i, k, j-1))
8789             temp10 = SIGN(1., vel)
8790             temp9 = temp10/12.0
8791             temp8 = SIGN(1, time_step)
8792             temp7b0 = vel*fqyb(i, k, jp1)
8793             temp7b1 = temp7b0/12.0
8794             temp7b2 = temp8*temp9*temp7b0
8795             velb = ((7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, j+&
8796 &              1)-field(i, k, j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, &
8797 &              jp1)
8798             fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp7b1 - 3.*temp7b2
8799             fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp7b2 + 7.*&
8800 &              temp7b1
8801             fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp7b2 - temp7b1
8802             fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp7b2 - temp7b1
8803             fqyb(i, k, jp1) = 0.0
8804             rvb(i, k, j) = rvb(i, k, j) + velb
8805           END DO
8806         END DO
8807       END IF
8808     END DO
8809   ELSE
8810     fqxb = 0.0
8811     CALL POPINTEGER4(ad_from46)
8812     CALL POPINTEGER4(ad_to46)
8813     DO j=ad_to46,ad_from46,-1
8814       DO k=ktf,kts,-1
8815         CALL POPINTEGER4(ad_from45)
8816         CALL POPINTEGER4(ad_to45)
8817         DO i=ad_to45,ad_from45,-1
8818           mrdx = msftx(i, j)*rdx
8819           fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
8820           fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
8821         END DO
8822       END DO
8823       CALL POPCONTROL1B(branch)
8824       IF (branch .NE. 0) THEN
8825         CALL POPINTEGER4(ad_to44)
8826         DO i=ad_to44,i_end_f+1,-1
8827           CALL POPCONTROL1B(branch)
8828           IF (branch .NE. 0) THEN
8829             DO k=ktf,kts,-1
8830               vel = ru(i, k, j)
8831               temp31b18 = vel*fqxb(i, k)/12.0
8832               velb = (7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k&
8833 &                , j)-field(i-2, k, j))*fqxb(i, k)/12.0
8834               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b18
8835               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 7.*temp31b18
8836               fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b18
8837               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b18
8838               fqxb(i, k) = 0.0
8839               rub(i, k, j) = rub(i, k, j) + velb
8840             END DO
8841           END IF
8842           CALL POPCONTROL1B(branch)
8843           IF (branch .EQ. 0) THEN
8844             DO k=ktf,kts,-1
8845               temp31b17 = 0.5*ru(i, k, j)*fqxb(i, k)
8846               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
8847 &                1, k, j))*fqxb(i, k)
8848               fieldb(i, k, j) = fieldb(i, k, j) + temp31b17
8849               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b17
8850               fqxb(i, k) = 0.0
8851             END DO
8852           END IF
8853         END DO
8854       END IF
8855       CALL POPCONTROL1B(branch)
8856       IF (branch .EQ. 0) THEN
8857         CALL POPINTEGER4(ad_from44)
8858         DO i=i_start_f-1,ad_from44,-1
8859           CALL POPCONTROL1B(branch)
8860           IF (branch .NE. 0) THEN
8861             DO k=ktf,kts,-1
8862               vel = ru(i, k, j)
8863               temp31b16 = vel*fqxb(i, k)/12.0
8864               velb = (7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k&
8865 &                , j)-field(i-2, k, j))*fqxb(i, k)/12.0
8866               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b16
8867               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 7.*temp31b16
8868               fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b16
8869               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b16
8870               fqxb(i, k) = 0.0
8871               rub(i, k, j) = rub(i, k, j) + velb
8872             END DO
8873           END IF
8874           CALL POPCONTROL1B(branch)
8875           IF (branch .EQ. 0) THEN
8876             DO k=ktf,kts,-1
8877               temp31b15 = 0.5*ru(i, k, j)*fqxb(i, k)
8878               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
8879 &                1, k, j))*fqxb(i, k)
8880               fieldb(i, k, j) = fieldb(i, k, j) + temp31b15
8881               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b15
8882               fqxb(i, k) = 0.0
8883             END DO
8884           END IF
8885         END DO
8886       END IF
8887       DO k=ktf,kts,-1
8888         DO i=i_end_f,i_start_f,-1
8889           vel = ru(i, k, j)
8890           temp31b14 = vel*fqxb(i, k)/60.0
8891           velb = (37.*(field(i, k, j)+field(i-1, k, j))-8.*(field(i+1, k&
8892 &            , j)+field(i-2, k, j))+field(i+2, k, j)+field(i-3, k, j))*&
8893 &            fqxb(i, k)/60.0
8894           fieldb(i, k, j) = fieldb(i, k, j) + 37.*temp31b14
8895           fieldb(i-1, k, j) = fieldb(i-1, k, j) + 37.*temp31b14
8896           fieldb(i+1, k, j) = fieldb(i+1, k, j) - 8.*temp31b14
8897           fieldb(i-2, k, j) = fieldb(i-2, k, j) - 8.*temp31b14
8898           fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp31b14
8899           fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp31b14
8900           fqxb(i, k) = 0.0
8901           rub(i, k, j) = rub(i, k, j) + velb
8902         END DO
8903       END DO
8904     END DO
8905     fqyb = 0.0
8906     CALL POPINTEGER4(ad_from43)
8907     CALL POPINTEGER4(ad_to43)
8908     DO j=ad_to43,ad_from43,-1
8909       CALL POPINTEGER4(jp0)
8910       CALL POPINTEGER4(jp1)
8911       CALL POPCONTROL2B(branch)
8912       IF (branch .LT. 2) THEN
8913         IF (branch .EQ. 0) THEN
8914           DO k=ktf,kts,-1
8915             CALL POPINTEGER4(ad_from40)
8916             CALL POPINTEGER4(ad_to40)
8917             DO i=ad_to40,ad_from40,-1
8918               mrdy = msftx(i, j-1)*rdy
8919               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
8920 &                -1)
8921             END DO
8922           END DO
8923         ELSE
8924           DO k=ktf,kts,-1
8925             CALL POPINTEGER4(ad_from41)
8926             CALL POPINTEGER4(ad_to41)
8927             DO i=ad_to41,ad_from41,-1
8928               mrdy = msftx(i, j-1)*rdy
8929               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
8930 &                -1)
8931             END DO
8932           END DO
8933         END IF
8934       ELSE IF (branch .EQ. 2) THEN
8935         DO k=ktf,kts,-1
8936           CALL POPINTEGER4(ad_from42)
8937           CALL POPINTEGER4(ad_to42)
8938           DO i=ad_to42,ad_from42,-1
8939             mrdy = msftx(i, j-1)*rdy
8940             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
8941 &              )
8942             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
8943 &              )
8944           END DO
8945         END DO
8946       END IF
8947       CALL POPCONTROL3B(branch)
8948       IF (branch .LT. 3) THEN
8949         IF (branch .EQ. 0) THEN
8950           DO k=ktf,kts,-1
8951             CALL POPINTEGER4(ad_from35)
8952             CALL POPINTEGER4(ad_to35)
8953             DO i=ad_to35,ad_from35,-1
8954               vel = rv(i, k, j)
8955               temp31b9 = vel*fqyb(i, k, jp1)/60.0
8956               velb = (37.*(field(i, k, j)+field(i, k, j-1))-8.*(field(i&
8957 &                , k, j+1)+field(i, k, j-2))+field(i, k, j+2)+field(i, k&
8958 &                , j-3))*fqyb(i, k, jp1)/60.0
8959               fieldb(i, k, j) = fieldb(i, k, j) + 37.*temp31b9
8960               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 37.*temp31b9
8961               fieldb(i, k, j+1) = fieldb(i, k, j+1) - 8.*temp31b9
8962               fieldb(i, k, j-2) = fieldb(i, k, j-2) - 8.*temp31b9
8963               fieldb(i, k, j+2) = fieldb(i, k, j+2) + temp31b9
8964               fieldb(i, k, j-3) = fieldb(i, k, j-3) + temp31b9
8965               fqyb(i, k, jp1) = 0.0
8966               rvb(i, k, j) = rvb(i, k, j) + velb
8967             END DO
8968           END DO
8969         ELSE IF (branch .EQ. 1) THEN
8970           DO k=ktf,kts,-1
8971             CALL POPINTEGER4(ad_from36)
8972             CALL POPINTEGER4(ad_to36)
8973             DO i=ad_to36,ad_from36,-1
8974               temp31b10 = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
8975               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
8976 &                , k, j-1))*fqyb(i, k, jp1)
8977               fieldb(i, k, j) = fieldb(i, k, j) + temp31b10
8978               fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b10
8979               fqyb(i, k, jp1) = 0.0
8980             END DO
8981           END DO
8982         ELSE
8983           DO k=ktf,kts,-1
8984             CALL POPINTEGER4(ad_from37)
8985             CALL POPINTEGER4(ad_to37)
8986             DO i=ad_to37,ad_from37,-1
8987               vel = rv(i, k, j)
8988               temp31b11 = vel*fqyb(i, k, jp1)/12.0
8989               velb = (7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, j&
8990 &                +1)-field(i, k, j-2))*fqyb(i, k, jp1)/12.0
8991               fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b11
8992               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 7.*temp31b11
8993               fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b11
8994               fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b11
8995               fqyb(i, k, jp1) = 0.0
8996               rvb(i, k, j) = rvb(i, k, j) + velb
8997             END DO
8998           END DO
8999         END IF
9000       ELSE IF (branch .EQ. 3) THEN
9001         DO k=ktf,kts,-1
9002           CALL POPINTEGER4(ad_from38)
9003           CALL POPINTEGER4(ad_to38)
9004           DO i=ad_to38,ad_from38,-1
9005             temp31b12 = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
9006             rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k&
9007 &              , j-1))*fqyb(i, k, jp1)
9008             fieldb(i, k, j) = fieldb(i, k, j) + temp31b12
9009             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b12
9010             fqyb(i, k, jp1) = 0.0
9011           END DO
9012         END DO
9013       ELSE IF (branch .EQ. 4) THEN
9014         DO k=ktf,kts,-1
9015           CALL POPINTEGER4(ad_from39)
9016           CALL POPINTEGER4(ad_to39)
9017           DO i=ad_to39,ad_from39,-1
9018             vel = rv(i, k, j)
9019             temp31b13 = vel*fqyb(i, k, jp1)/12.0
9020             velb = (7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, j+1&
9021 &              )-field(i, k, j-2))*fqyb(i, k, jp1)/12.0
9022             fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b13
9023             fieldb(i, k, j-1) = fieldb(i, k, j-1) + 7.*temp31b13
9024             fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b13
9025             fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b13
9026             fqyb(i, k, jp1) = 0.0
9027             rvb(i, k, j) = rvb(i, k, j) + velb
9028           END DO
9029         END DO
9030       END IF
9031     END DO
9032   END IF
9033  100 CONTINUE
9034 END SUBROUTINE A_ADVECT_SCALAR
9035
9036 !        Generated by TAPENADE     (INRIA, Tropics team)
9037 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
9038 !
9039 !  Differentiation of advect_w in reverse (adjoint) mode:
9040 !   gradient     of useful results: rom tendency w ru rv w_old
9041 !   with respect to varying inputs: rom tendency w ru rv w_old
9042 !   RW status of diff variables: rom:incr tendency:in-out w:incr
9043 !                ru:incr rv:incr w_old:incr
9044 SUBROUTINE A_ADVECT_W(w, wb, w_old, w_oldb, tendency, tendencyb, ru, rub&
9045 &  , rv, rvb, rom, romb, mut, time_step, config_flags, msfux, msfuy, &
9046 &  msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide, jds, &
9047 &  jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
9048 &  kte)
9049   IMPLICIT NONE
9050 ! Input data
9051   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
9052   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
9053 &  jme, kms, kme, its, ite, jts, jte, kts, kte
9054   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru&
9055 &  , rv, rom
9056   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: wb, w_oldb, rub, rvb, &
9057 &  romb
9058   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
9059   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
9060   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb
9061   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
9062 &  msfvy, msftx, msfty
9063   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu
9064   REAL, INTENT(IN) :: rdx, rdy
9065   INTEGER, INTENT(IN) :: time_step
9066 ! Local data
9067   INTEGER :: i, j, k, itf, jtf, ktf
9068   INTEGER :: i_start, i_end, j_start, j_end
9069   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
9070   INTEGER :: jmin, jmax, jp, jm, imin, imax
9071   REAL :: mrdx, mrdy, ub, vb, uw, vw
9072   REAL :: ubb, vbb, uwb, vwb
9073   REAL, DIMENSION(its:ite, kts:kte) :: vflux
9074   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
9075   INTEGER :: horz_order, vert_order
9076   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
9077   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb
9078   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
9079   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
9080   LOGICAL :: degrade_xs, degrade_ys
9081   LOGICAL :: degrade_xe, degrade_ye
9082   INTEGER :: jp1, jp0, jtmp
9083 ! definition of flux operators, 3rd, 4th, 5th or 6th order
9084   REAL :: flux3, flux4, flux5, flux6
9085   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
9086   REAL :: velb
9087   LOGICAL :: specified
9088   EXTERNAL WRF_ERROR_FATAL
9089   INTEGER :: ad_from
9090   INTEGER :: ad_to
9091   INTEGER :: ad_from0
9092   INTEGER :: ad_to0
9093   INTEGER :: ad_from1
9094   INTEGER :: ad_to1
9095   INTEGER :: ad_from2
9096   INTEGER :: ad_to2
9097   INTEGER :: ad_from3
9098   INTEGER :: ad_to3
9099   INTEGER :: ad_from4
9100   INTEGER :: ad_to4
9101   INTEGER :: ad_from5
9102   INTEGER :: ad_to5
9103   INTEGER :: ad_from6
9104   INTEGER :: ad_to6
9105   INTEGER :: ad_from7
9106   INTEGER :: ad_to7
9107   INTEGER :: ad_from8
9108   INTEGER :: ad_to8
9109   INTEGER :: ad_from9
9110   INTEGER :: ad_to9
9111   INTEGER :: ad_from10
9112   INTEGER :: ad_to10
9113   INTEGER :: ad_from11
9114   INTEGER :: ad_to11
9115   INTEGER :: branch
9116   INTEGER :: ad_from12
9117   INTEGER :: ad_to12
9118   INTEGER :: ad_from13
9119   INTEGER :: ad_to13
9120   INTEGER :: ad_from14
9121   INTEGER :: ad_to14
9122   INTEGER :: ad_from15
9123   INTEGER :: ad_to15
9124   INTEGER :: ad_from16
9125   INTEGER :: ad_to16
9126   INTEGER :: ad_from17
9127   INTEGER :: ad_to17
9128   INTEGER :: ad_from18
9129   INTEGER :: ad_to18
9130   INTEGER :: ad_from19
9131   INTEGER :: ad_to19
9132   INTEGER :: ad_from20
9133   INTEGER :: ad_to20
9134   INTEGER :: ad_from21
9135   INTEGER :: ad_to21
9136   INTEGER :: ad_from22
9137   INTEGER :: ad_to22
9138   INTEGER :: ad_from23
9139   INTEGER :: ad_to23
9140   INTEGER :: ad_from24
9141   INTEGER :: ad_to24
9142   INTEGER :: ad_from25
9143   INTEGER :: ad_to25
9144   INTEGER :: ad_from26
9145   INTEGER :: ad_to26
9146   INTEGER :: ad_from27
9147   INTEGER :: ad_to27
9148   INTEGER :: ad_from28
9149   INTEGER :: ad_to28
9150   INTEGER :: ad_from29
9151   INTEGER :: ad_to29
9152   INTEGER :: ad_from30
9153   INTEGER :: ad_to30
9154   INTEGER :: ad_from31
9155   INTEGER :: ad_to31
9156   INTEGER :: ad_from32
9157   INTEGER :: ad_to32
9158   INTEGER :: ad_from33
9159   INTEGER :: ad_to33
9160   INTEGER :: ad_from34
9161   INTEGER :: ad_to34
9162   INTEGER :: ad_from35
9163   INTEGER :: ad_to35
9164   INTEGER :: ad_from36
9165   INTEGER :: ad_to36
9166   INTEGER :: ad_from37
9167   INTEGER :: ad_to37
9168   INTEGER :: ad_from38
9169   INTEGER :: ad_to38
9170   INTEGER :: ad_from39
9171   INTEGER :: ad_to39
9172   INTEGER :: ad_from40
9173   INTEGER :: ad_to40
9174   INTEGER :: ad_from41
9175   INTEGER :: ad_to41
9176   INTEGER :: ad_from42
9177   INTEGER :: ad_to42
9178   INTEGER :: ad_from43
9179   INTEGER :: ad_to43
9180   INTEGER :: ad_from44
9181   INTEGER :: ad_to44
9182   INTEGER :: ad_from45
9183   INTEGER :: ad_to45
9184   INTEGER :: ad_from46
9185   INTEGER :: ad_to46
9186   INTEGER :: ad_from47
9187   INTEGER :: ad_to47
9188   INTEGER :: ad_from48
9189   INTEGER :: ad_to48
9190   INTEGER :: ad_from49
9191   INTEGER :: ad_to49
9192   INTEGER :: ad_from50
9193   INTEGER :: ad_to50
9194   INTEGER :: ad_from51
9195   INTEGER :: ad_to51
9196   INTEGER :: ad_from52
9197   INTEGER :: ad_to52
9198   INTEGER :: ad_from53
9199   INTEGER :: ad_to53
9200   INTEGER :: ad_from54
9201   INTEGER :: ad_to54
9202   INTEGER :: ad_from55
9203   INTEGER :: ad_to55
9204   INTEGER :: ad_from56
9205   INTEGER :: ad_to56
9206   INTEGER :: ad_from57
9207   INTEGER :: ad_to57
9208   INTEGER :: ad_from58
9209   INTEGER :: ad_to58
9210   INTEGER :: ad_from59
9211   INTEGER :: ad_to59
9212   INTEGER :: ad_from60
9213   INTEGER :: ad_to60
9214   INTEGER :: ad_from61
9215   INTEGER :: ad_to61
9216   INTEGER :: ad_from62
9217   INTEGER :: ad_to62
9218   INTEGER :: ad_from63
9219   INTEGER :: ad_to63
9220   INTEGER :: ad_from64
9221   INTEGER :: ad_to64
9222   INTEGER :: ad_from65
9223   INTEGER :: ad_to65
9224   INTEGER :: ad_from66
9225   INTEGER :: ad_to66
9226   INTEGER :: ad_from67
9227   INTEGER :: ad_to67
9228   INTEGER :: ad_from68
9229   INTEGER :: ad_to68
9230   INTEGER :: ad_from69
9231   INTEGER :: ad_to69
9232   INTEGER :: ad_from70
9233   INTEGER :: ad_to70
9234   INTEGER :: ad_from71
9235   INTEGER :: ad_to71
9236   INTEGER :: ad_from72
9237   INTEGER :: ad_to72
9238   INTEGER :: ad_from73
9239   INTEGER :: ad_to73
9240   INTEGER :: ad_from74
9241   INTEGER :: ad_to74
9242   REAL :: temp3
9243   REAL :: temp29
9244   REAL :: temp63b93
9245   REAL :: temp79b3
9246   REAL :: temp2
9247   INTEGER :: temp28
9248   REAL :: temp63b92
9249   REAL :: temp79b2
9250   REAL :: temp1
9251   REAL :: temp27
9252   REAL :: temp63b91
9253   REAL :: temp79b1
9254   INTEGER :: temp0
9255   REAL :: temp26
9256   REAL :: temp63b90
9257   REAL :: temp63b104
9258   REAL :: temp79b0
9259   REAL :: temp7b
9260   REAL :: temp25
9261   REAL :: temp63b103
9262   INTEGER :: temp24
9263   REAL :: temp63b102
9264   REAL :: temp23
9265   REAL :: temp63b101
9266   REAL :: temp22
9267   REAL :: temp59
9268   REAL :: temp63b100
9269   REAL :: temp21
9270   REAL :: temp58
9271   INTEGER :: temp20
9272   REAL :: temp57
9273   REAL :: temp35b1
9274   INTEGER :: temp56
9275   REAL :: temp35b0
9276   REAL :: temp55
9277   REAL :: temp63b29
9278   REAL :: temp54
9279   REAL :: temp63b28
9280   REAL :: temp53
9281   REAL :: temp63b27
9282   REAL :: temp67b3
9283   INTEGER :: temp52
9284   REAL :: temp63b26
9285   REAL :: temp67b2
9286   REAL :: temp51
9287   REAL :: temp63b25
9288   REAL :: temp67b1
9289   REAL :: temp50
9290   REAL :: temp63b24
9291   REAL :: temp67b0
9292   REAL :: temp19b
9293   REAL :: temp63b23
9294   REAL :: temp27b
9295   REAL :: temp63b22
9296   REAL :: temp63b59
9297   REAL :: temp35b
9298   REAL :: temp63b21
9299   REAL :: temp63b58
9300   REAL :: tempb1
9301   REAL :: temp43b
9302   REAL :: temp47b19
9303   REAL :: temp55b9
9304   REAL :: temp63b20
9305   REAL :: temp63b57
9306   REAL :: tempb0
9307   REAL :: temp47b18
9308   REAL :: temp51b
9309   REAL :: temp55b8
9310   REAL :: temp63b56
9311   REAL :: temp47b17
9312   REAL :: temp55b7
9313   REAL :: temp63b55
9314   INTRINSIC MAX
9315   REAL :: temp23b1
9316   REAL :: temp47b16
9317   REAL :: temp55b6
9318   REAL :: temp63b54
9319   REAL :: temp23b0
9320   REAL :: temp47b15
9321   REAL :: temp55b5
9322   REAL :: temp63b53
9323   REAL :: temp7b5
9324   REAL :: temp47b14
9325   REAL :: temp55b4
9326   REAL :: temp63b52
9327   REAL :: temp63b89
9328   INTRINSIC SIGN
9329   REAL :: temp7b4
9330   REAL :: temp47b13
9331   REAL :: temp55b3
9332   REAL :: temp63b51
9333   REAL :: temp63b88
9334   REAL :: temp7b3
9335   REAL :: temp47b12
9336   REAL :: temp55b2
9337   REAL :: temp63b50
9338   REAL :: temp63b87
9339   REAL :: temp3b
9340   REAL :: temp7b2
9341   REAL :: temp47b11
9342   REAL :: temp55b1
9343   REAL :: temp63b86
9344   REAL :: temp7b1
9345   REAL :: temp47b10
9346   REAL :: temp55b0
9347   REAL :: temp63b85
9348   REAL :: temp7b0
9349   REAL :: temp63b84
9350   REAL :: temp19
9351   REAL :: temp63b83
9352   REAL :: temp18
9353   REAL :: temp63b82
9354   REAL :: temp17
9355   REAL :: temp63b81
9356   INTEGER :: temp16
9357   REAL :: temp63b80
9358   REAL :: temp15
9359   REAL :: temp14
9360   REAL :: temp11b1
9361   REAL :: temp13
9362   REAL :: temp11b0
9363   INTEGER :: temp12
9364   REAL :: temp49
9365   REAL :: temp11
9366   INTEGER :: temp48
9367   REAL :: temp75b8
9368   REAL :: temp10
9369   REAL :: temp47
9370   REAL :: temp75b7
9371   REAL :: temp15b
9372   REAL :: temp46
9373   REAL :: temp43b1
9374   REAL :: temp75b6
9375   REAL :: temp23b
9376   REAL :: temp45
9377   REAL :: temp43b0
9378   REAL :: temp63b19
9379   REAL :: temp75b5
9380   REAL :: temp31b
9381   INTEGER :: temp44
9382   REAL :: temp63b18
9383   REAL :: temp75b4
9384   REAL :: temp43
9385   REAL :: temp63b17
9386   REAL :: temp75b3
9387   REAL :: temp42
9388   REAL :: temp63b16
9389   REAL :: temp75b2
9390   REAL :: temp41
9391   REAL :: temp63b15
9392   REAL :: temp75b1
9393   REAL :: temp78
9394   INTEGER :: temp40
9395   REAL :: temp63b14
9396   REAL :: temp75b0
9397   REAL :: temp77
9398   REAL :: temp19b1
9399   REAL :: temp63b13
9400   INTEGER :: temp76
9401   REAL :: temp19b0
9402   REAL :: temp63b12
9403   REAL :: temp63b49
9404   REAL :: temp75
9405   REAL :: temp31b5
9406   REAL :: temp63b11
9407   REAL :: temp63b48
9408   REAL :: temp74
9409   REAL :: temp31b4
9410   REAL :: temp63b9
9411   REAL :: temp63b10
9412   REAL :: temp63b47
9413   REAL :: temp73
9414   REAL :: temp79b
9415   REAL :: temp31b3
9416   REAL :: temp63b8
9417   REAL :: temp63b46
9418   INTEGER :: temp72
9419   REAL :: tempb
9420   REAL :: temp31b2
9421   REAL :: temp63b7
9422   REAL :: temp63b45
9423   REAL :: temp71
9424   REAL :: temp31b1
9425   REAL :: temp63b6
9426   REAL :: temp63b44
9427   REAL :: temp70
9428   REAL :: temp31b0
9429   REAL :: temp63b5
9430   REAL :: temp63b43
9431   REAL :: temp63b4
9432   REAL :: temp63b42
9433   REAL :: temp63b79
9434   REAL :: temp63b3
9435   REAL :: temp63b41
9436   REAL :: temp63b78
9437   REAL :: temp63b2
9438   REAL :: temp63b40
9439   REAL :: temp63b77
9440   REAL :: temp63b1
9441   REAL :: temp63b76
9442   REAL :: temp63b0
9443   REAL :: temp63b75
9444   REAL :: temp63b74
9445   REAL :: temp39b5
9446   REAL :: temp63b73
9447   REAL :: temp39b4
9448   REAL :: temp63b72
9449   REAL :: temp39b3
9450   REAL :: temp63b71
9451   REAL :: temp11b
9452   REAL :: temp39b2
9453   REAL :: temp63b70
9454   REAL :: temp39b1
9455   REAL :: temp39b0
9456   REAL :: temp39
9457   REAL :: temp38
9458   REAL :: temp37
9459   INTEGER :: temp36
9460   REAL :: temp51b1
9461   REAL :: temp3b1
9462   REAL :: temp35
9463   REAL :: temp51b0
9464   REAL :: temp59b
9465   REAL :: temp3b0
9466   REAL :: temp34
9467   REAL :: temp67b
9468   REAL :: temp33
9469   REAL :: temp75b
9470   INTEGER :: temp32
9471   REAL :: temp69
9472   REAL :: temp31
9473   INTEGER :: temp68
9474   REAL :: temp30
9475   REAL :: temp67
9476   REAL :: temp27b1
9477   REAL :: temp66
9478   REAL :: temp27b0
9479   REAL :: temp63b39
9480   REAL :: temp65
9481   REAL :: temp63b38
9482   INTEGER :: temp64
9483   REAL :: temp63b37
9484   REAL :: temp63
9485   REAL :: temp55b17
9486   REAL :: temp62
9487   REAL :: temp63b36
9488   REAL :: temp55b16
9489   REAL :: temp61
9490   REAL :: temp59b1
9491   REAL :: temp63b35
9492   INTRINSIC MIN
9493   REAL :: temp55b15
9494   INTEGER :: temp60
9495   REAL :: temp59b0
9496   REAL :: temp63b34
9497   REAL :: temp55b14
9498   REAL :: temp63b33
9499   REAL :: temp55b13
9500   REAL :: temp63b32
9501   REAL :: temp63b69
9502   REAL :: temp15b5
9503   REAL :: temp55b12
9504   REAL :: temp63b31
9505   REAL :: temp63b68
9506   REAL :: temp15b4
9507   REAL :: temp47b9
9508   REAL :: temp55b11
9509   REAL :: temp63b30
9510   REAL :: temp63b67
9511   REAL :: temp15b3
9512   REAL :: temp47b8
9513   REAL :: temp55b10
9514   REAL :: temp63b66
9515   REAL :: temp71b1
9516   REAL :: temp
9517   REAL :: temp15b2
9518   REAL :: temp47b7
9519   REAL :: temp63b65
9520   REAL :: temp71b0
9521   REAL :: temp15b1
9522   REAL :: temp47b6
9523   REAL :: temp63b64
9524   REAL :: temp15b0
9525   REAL :: temp47b5
9526   REAL :: temp63b63
9527   REAL :: temp9
9528   REAL :: temp47b4
9529   REAL :: temp63b62
9530   REAL :: temp63b99
9531   INTEGER :: temp8
9532   REAL :: temp39b
9533   REAL :: temp47b3
9534   REAL :: temp63b61
9535   REAL :: temp63b98
9536   REAL :: temp7
9537   REAL :: temp47b
9538   REAL :: temp47b2
9539   REAL :: temp63b60
9540   REAL :: temp63b97
9541   REAL :: temp6
9542   REAL :: temp47b1
9543   REAL :: temp47b21
9544   REAL :: temp55b
9545   REAL :: temp63b96
9546   REAL :: temp5
9547   REAL :: temp47b0
9548   REAL :: temp47b20
9549   REAL :: temp63b
9550   REAL :: temp63b95
9551   INTEGER :: temp4
9552   REAL :: temp63b94
9553   REAL :: temp71b
9554   REAL :: temp79b4
9555   specified = .false.
9556   IF (config_flags%specified .OR. config_flags%nested) specified = &
9557 &      .true.
9558   IF (kte .GT. kde - 1) THEN
9559     ktf = kde - 1
9560   ELSE
9561     ktf = kte
9562   END IF
9563   horz_order = config_flags%h_sca_adv_order
9564   vert_order = config_flags%v_sca_adv_order
9565 !  here is the choice of flux operators
9566 !  begin with horizontal flux divergence
9567   IF (horz_order .EQ. 6) THEN
9568 !  determine boundary mods for flux operators
9569 !  We degrade the flux operators from 3rd/4th order
9570 !   to second order one gridpoint in from the boundaries for
9571 !   all boundary conditions except periodic and symmetry - these
9572 !   conditions have boundary zone data fill for correct application
9573 !   of the higher order flux stencils
9574     degrade_xs = .true.
9575     degrade_xe = .true.
9576     degrade_ys = .true.
9577     degrade_ye = .true.
9578     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
9579 &        its .GT. ids + 3) degrade_xs = .false.
9580     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
9581 &        ite .LT. ide - 3) degrade_xe = .false.
9582     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
9583 &        jts .GT. jds + 3) degrade_ys = .false.
9584     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
9585 &        jte .LT. jde - 4) degrade_ye = .false.
9586 !--------------- y - advection first
9587     i_start = its
9588     IF (ite .GT. ide - 1) THEN
9589       i_end = ide - 1
9590     ELSE
9591       i_end = ite
9592     END IF
9593     j_start = jts
9594     IF (jte .GT. jde - 1) THEN
9595       j_end = jde - 1
9596     ELSE
9597       j_end = jte
9598     END IF
9599 !  higher order flux has a 5 or 7 point stencil, so compute
9600 !  bounds so we can switch to second order flux close to the boundary
9601     j_start_f = j_start
9602     j_end_f = j_end + 1
9603     IF (degrade_ys) THEN
9604       IF (jts .LT. jds + 1) THEN
9605         j_start = jds + 1
9606       ELSE
9607         j_start = jts
9608       END IF
9609       j_start_f = jds + 3
9610     END IF
9611     IF (degrade_ye) THEN
9612       IF (jte .GT. jde - 2) THEN
9613         j_end = jde - 2
9614       ELSE
9615         j_end = jte
9616       END IF
9617       j_end_f = jde - 3
9618     END IF
9619     IF (config_flags%polar) THEN
9620       IF (jte .GT. jde - 1) THEN
9621         j_end = jde - 1
9622       ELSE
9623         j_end = jte
9624       END IF
9625     END IF
9626 !  compute fluxes, 5th or 6th order
9627     jp1 = 2
9628     jp0 = 1
9629     ad_from63 = j_start
9630 j_loop_y_flux_6:DO j=ad_from63,j_end+1
9631       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
9632         CALL PUSHINTEGER4(k)
9633         DO k=kts+1,ktf
9634           ad_from50 = i_start
9635           DO i=ad_from50,i_end
9636             CALL PUSHREAL8(vel)
9637           END DO
9638           CALL PUSHINTEGER4(i - 1)
9639           CALL PUSHINTEGER4(ad_from50)
9640         END DO
9641         k = ktf + 1
9642         ad_from51 = i_start
9643         DO i=ad_from51,i_end
9644           CALL PUSHREAL8(vel)
9645           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
9646         END DO
9647         CALL PUSHINTEGER4(i - 1)
9648         CALL PUSHINTEGER4(ad_from51)
9649         CALL PUSHCONTROL3B(0)
9650       ELSE IF (j .EQ. jds + 1) THEN
9651         CALL PUSHINTEGER4(k)
9652 ! 2nd order flux next to south boundary
9653         DO k=kts+1,ktf
9654           ad_from52 = i_start
9655           i = i_end + 1
9656           CALL PUSHINTEGER4(i - 1)
9657           CALL PUSHINTEGER4(ad_from52)
9658         END DO
9659         k = ktf + 1
9660         ad_from53 = i_start
9661         i = i_end + 1
9662         CALL PUSHINTEGER4(i - 1)
9663         CALL PUSHINTEGER4(ad_from53)
9664         CALL PUSHCONTROL3B(1)
9665       ELSE IF (j .EQ. jds + 2) THEN
9666         CALL PUSHINTEGER4(k)
9667 ! third of 4th order flux 2 in from south boundary
9668         DO k=kts+1,ktf
9669           ad_from54 = i_start
9670           DO i=ad_from54,i_end
9671             CALL PUSHREAL8(vel)
9672           END DO
9673           CALL PUSHINTEGER4(i - 1)
9674           CALL PUSHINTEGER4(ad_from54)
9675         END DO
9676         k = ktf + 1
9677         ad_from55 = i_start
9678         DO i=ad_from55,i_end
9679           CALL PUSHREAL8(vel)
9680           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
9681         END DO
9682         CALL PUSHINTEGER4(i - 1)
9683         CALL PUSHINTEGER4(ad_from55)
9684         CALL PUSHCONTROL3B(2)
9685       ELSE IF (j .EQ. jde - 1) THEN
9686         CALL PUSHINTEGER4(k)
9687 ! 2nd order flux next to north boundary
9688         DO k=kts+1,ktf
9689           ad_from56 = i_start
9690           i = i_end + 1
9691           CALL PUSHINTEGER4(i - 1)
9692           CALL PUSHINTEGER4(ad_from56)
9693         END DO
9694         k = ktf + 1
9695         ad_from57 = i_start
9696         i = i_end + 1
9697         CALL PUSHINTEGER4(i - 1)
9698         CALL PUSHINTEGER4(ad_from57)
9699         CALL PUSHCONTROL3B(3)
9700       ELSE IF (j .EQ. jde - 2) THEN
9701         CALL PUSHINTEGER4(k)
9702 ! 3rd or 4th order flux 2 in from north boundary
9703         DO k=kts+1,ktf
9704           ad_from58 = i_start
9705           DO i=ad_from58,i_end
9706             CALL PUSHREAL8(vel)
9707           END DO
9708           CALL PUSHINTEGER4(i - 1)
9709           CALL PUSHINTEGER4(ad_from58)
9710         END DO
9711         k = ktf + 1
9712         ad_from59 = i_start
9713         DO i=ad_from59,i_end
9714           CALL PUSHREAL8(vel)
9715           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
9716         END DO
9717         CALL PUSHINTEGER4(i - 1)
9718         CALL PUSHINTEGER4(ad_from59)
9719         CALL PUSHCONTROL3B(4)
9720       ELSE
9721         CALL PUSHCONTROL3B(5)
9722       END IF
9723 !  y flux-divergence into tendency
9724 ! Comments for polar boundary conditions
9725 ! Same process as for advect_u - tendencies run from jds to jde-1
9726 ! (latitudes are as for u grid, longitudes are displaced)
9727 ! Therefore: flow is only from one side for points next to poles
9728       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
9729         CALL PUSHINTEGER4(k)
9730         DO k=kts,ktf
9731           ad_from60 = i_start
9732           i = i_end + 1
9733           CALL PUSHINTEGER4(i - 1)
9734           CALL PUSHINTEGER4(ad_from60)
9735         END DO
9736         CALL PUSHCONTROL2B(0)
9737       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
9738         CALL PUSHINTEGER4(k)
9739         DO k=kts,ktf
9740           ad_from61 = i_start
9741           i = i_end + 1
9742           CALL PUSHINTEGER4(i - 1)
9743           CALL PUSHINTEGER4(ad_from61)
9744         END DO
9745         CALL PUSHCONTROL2B(1)
9746       ELSE IF (j .GT. j_start) THEN
9747 ! normal code
9748         CALL PUSHINTEGER4(k)
9749         DO k=kts+1,ktf+1
9750           ad_from62 = i_start
9751           i = i_end + 1
9752           CALL PUSHINTEGER4(i - 1)
9753           CALL PUSHINTEGER4(ad_from62)
9754         END DO
9755         CALL PUSHCONTROL2B(2)
9756       ELSE
9757         CALL PUSHCONTROL2B(3)
9758       END IF
9759       jtmp = jp1
9760       CALL PUSHINTEGER4(jp1)
9761       jp1 = jp0
9762       CALL PUSHINTEGER4(jp0)
9763       jp0 = jtmp
9764     END DO j_loop_y_flux_6
9765     CALL PUSHINTEGER4(j - 1)
9766     CALL PUSHINTEGER4(ad_from63)
9767 !  next, x - flux divergence
9768     i_start = its
9769     IF (ite .GT. ide - 1) THEN
9770       i_end = ide - 1
9771     ELSE
9772       i_end = ite
9773     END IF
9774     j_start = jts
9775     IF (jte .GT. jde - 1) THEN
9776       j_end = jde - 1
9777     ELSE
9778       j_end = jte
9779     END IF
9780 !  higher order flux has a 5 or 7 point stencil, so compute
9781 !  bounds so we can switch to second order flux close to the boundary
9782     i_start_f = i_start
9783     i_end_f = i_end + 1
9784     IF (degrade_xs) THEN
9785       IF (ids + 1 .LT. its) THEN
9786         i_start = its
9787       ELSE
9788         i_start = ids + 1
9789       END IF
9790       IF (i_start + 2 .GT. ids + 3) THEN
9791         i_start_f = ids + 3
9792       ELSE
9793         i_start_f = i_start + 2
9794       END IF
9795     END IF
9796     IF (degrade_xe) THEN
9797       IF (ide - 2 .GT. ite) THEN
9798         i_end = ite
9799       ELSE
9800         i_end = ide - 2
9801       END IF
9802       i_end_f = ide - 3
9803     END IF
9804     ad_from66 = j_start
9805 !  compute fluxes
9806     DO j=ad_from66,j_end
9807       CALL PUSHINTEGER4(k)
9808 !  5th or 6th order flux
9809       DO k=kts+1,ktf
9810         DO i=i_start_f,i_end_f
9811           CALL PUSHREAL8(vel)
9812         END DO
9813       END DO
9814       k = ktf + 1
9815       DO i=i_start_f,i_end_f
9816         CALL PUSHREAL8(vel)
9817         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
9818       END DO
9819 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9820       IF (degrade_xs) THEN
9821         ad_from64 = i_start
9822         DO i=ad_from64,i_start_f-1
9823           IF (i .EQ. ids + 1) THEN
9824             CALL PUSHINTEGER4(k)
9825             CALL PUSHCONTROL1B(0)
9826           ELSE
9827             CALL PUSHCONTROL1B(1)
9828           END IF
9829           IF (i .EQ. ids + 2) THEN
9830             CALL PUSHINTEGER4(k)
9831 ! third order
9832             DO k=kts+1,ktf
9833               CALL PUSHREAL8(vel)
9834             END DO
9835             k = ktf + 1
9836             CALL PUSHREAL8(vel)
9837             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
9838             CALL PUSHCONTROL1B(1)
9839           ELSE
9840             CALL PUSHCONTROL1B(0)
9841           END IF
9842         END DO
9843         CALL PUSHINTEGER4(ad_from64)
9844         CALL PUSHCONTROL1B(0)
9845       ELSE
9846         CALL PUSHCONTROL1B(1)
9847       END IF
9848       IF (degrade_xe) THEN
9849         DO i=i_end_f+1,i_end+1
9850           IF (i .EQ. ide - 1) THEN
9851             CALL PUSHINTEGER4(k)
9852             CALL PUSHCONTROL1B(0)
9853           ELSE
9854             CALL PUSHCONTROL1B(1)
9855           END IF
9856           IF (i .EQ. ide - 2) THEN
9857             CALL PUSHINTEGER4(k)
9858 ! third order flux one in from the boundary
9859             DO k=kts+1,ktf
9860               CALL PUSHREAL8(vel)
9861             END DO
9862             k = ktf + 1
9863             CALL PUSHREAL8(vel)
9864             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
9865             CALL PUSHCONTROL1B(1)
9866           ELSE
9867             CALL PUSHCONTROL1B(0)
9868           END IF
9869         END DO
9870         CALL PUSHINTEGER4(i - 1)
9871         CALL PUSHCONTROL1B(1)
9872       ELSE
9873         CALL PUSHCONTROL1B(0)
9874       END IF
9875       CALL PUSHINTEGER4(k)
9876 !  x flux-divergence into tendency
9877       DO k=kts+1,ktf+1
9878         ad_from65 = i_start
9879         i = i_end + 1
9880         CALL PUSHINTEGER4(i - 1)
9881         CALL PUSHINTEGER4(ad_from65)
9882       END DO
9883     END DO
9884     CALL PUSHINTEGER4(j - 1)
9885     CALL PUSHINTEGER4(ad_from66)
9886     CALL PUSHCONTROL3B(7)
9887   ELSE IF (horz_order .EQ. 5) THEN
9888 !  determine boundary mods for flux operators
9889 !  We degrade the flux operators from 3rd/4th order
9890 !   to second order one gridpoint in from the boundaries for
9891 !   all boundary conditions except periodic and symmetry - these
9892 !   conditions have boundary zone data fill for correct application
9893 !   of the higher order flux stencils
9894     degrade_xs = .true.
9895     degrade_xe = .true.
9896     degrade_ys = .true.
9897     degrade_ye = .true.
9898     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
9899 &        its .GT. ids + 3) degrade_xs = .false.
9900     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
9901 &        ite .LT. ide - 3) degrade_xe = .false.
9902     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
9903 &        jts .GT. jds + 3) degrade_ys = .false.
9904     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
9905 &        jte .LT. jde - 4) degrade_ye = .false.
9906 !--------------- y - advection first
9907     i_start = its
9908     IF (ite .GT. ide - 1) THEN
9909       i_end = ide - 1
9910     ELSE
9911       i_end = ite
9912     END IF
9913     j_start = jts
9914     IF (jte .GT. jde - 1) THEN
9915       j_end = jde - 1
9916     ELSE
9917       j_end = jte
9918     END IF
9919 !  higher order flux has a 5 or 7 point stencil, so compute
9920 !  bounds so we can switch to second order flux close to the boundary
9921     j_start_f = j_start
9922     j_end_f = j_end + 1
9923     IF (degrade_ys) THEN
9924       IF (jts .LT. jds + 1) THEN
9925         j_start = jds + 1
9926       ELSE
9927         j_start = jts
9928       END IF
9929       j_start_f = jds + 3
9930     END IF
9931     IF (degrade_ye) THEN
9932       IF (jte .GT. jde - 2) THEN
9933         j_end = jde - 2
9934       ELSE
9935         j_end = jte
9936       END IF
9937       j_end_f = jde - 3
9938     END IF
9939     IF (config_flags%polar) THEN
9940       IF (jte .GT. jde - 1) THEN
9941         j_end = jde - 1
9942       ELSE
9943         j_end = jte
9944       END IF
9945     END IF
9946 !  compute fluxes, 5th or 6th order
9947     jp1 = 2
9948     jp0 = 1
9949     ad_from12 = j_start
9950 j_loop_y_flux_5:DO j=ad_from12,j_end+1
9951       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
9952         CALL PUSHINTEGER4(k)
9953         DO k=kts+1,ktf
9954           ad_from = i_start
9955           DO i=ad_from,i_end
9956             CALL PUSHREAL8(vel)
9957           END DO
9958           CALL PUSHINTEGER4(i - 1)
9959           CALL PUSHINTEGER4(ad_from)
9960         END DO
9961         k = ktf + 1
9962         ad_from0 = i_start
9963         DO i=ad_from0,i_end
9964           CALL PUSHREAL8(vel)
9965           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
9966         END DO
9967         CALL PUSHINTEGER4(i - 1)
9968         CALL PUSHINTEGER4(ad_from0)
9969         CALL PUSHCONTROL3B(0)
9970       ELSE IF (j .EQ. jds + 1) THEN
9971         CALL PUSHINTEGER4(k)
9972 ! 2nd order flux next to south boundary
9973         DO k=kts+1,ktf
9974           ad_from1 = i_start
9975           i = i_end + 1
9976           CALL PUSHINTEGER4(i - 1)
9977           CALL PUSHINTEGER4(ad_from1)
9978         END DO
9979         k = ktf + 1
9980         ad_from2 = i_start
9981         i = i_end + 1
9982         CALL PUSHINTEGER4(i - 1)
9983         CALL PUSHINTEGER4(ad_from2)
9984         CALL PUSHCONTROL3B(1)
9985       ELSE IF (j .EQ. jds + 2) THEN
9986         CALL PUSHINTEGER4(k)
9987 ! third of 4th order flux 2 in from south boundary
9988         DO k=kts+1,ktf
9989           ad_from3 = i_start
9990           DO i=ad_from3,i_end
9991             CALL PUSHREAL8(vel)
9992           END DO
9993           CALL PUSHINTEGER4(i - 1)
9994           CALL PUSHINTEGER4(ad_from3)
9995         END DO
9996         k = ktf + 1
9997         ad_from4 = i_start
9998         DO i=ad_from4,i_end
9999           CALL PUSHREAL8(vel)
10000           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
10001         END DO
10002         CALL PUSHINTEGER4(i - 1)
10003         CALL PUSHINTEGER4(ad_from4)
10004         CALL PUSHCONTROL3B(2)
10005       ELSE IF (j .EQ. jde - 1) THEN
10006         CALL PUSHINTEGER4(k)
10007 ! 2nd order flux next to north boundary
10008         DO k=kts+1,ktf
10009           ad_from5 = i_start
10010           i = i_end + 1
10011           CALL PUSHINTEGER4(i - 1)
10012           CALL PUSHINTEGER4(ad_from5)
10013         END DO
10014         k = ktf + 1
10015         ad_from6 = i_start
10016         i = i_end + 1
10017         CALL PUSHINTEGER4(i - 1)
10018         CALL PUSHINTEGER4(ad_from6)
10019         CALL PUSHCONTROL3B(3)
10020       ELSE IF (j .EQ. jde - 2) THEN
10021         CALL PUSHINTEGER4(k)
10022 ! 3rd or 4th order flux 2 in from north boundary
10023         DO k=kts+1,ktf
10024           ad_from7 = i_start
10025           DO i=ad_from7,i_end
10026             CALL PUSHREAL8(vel)
10027           END DO
10028           CALL PUSHINTEGER4(i - 1)
10029           CALL PUSHINTEGER4(ad_from7)
10030         END DO
10031         k = ktf + 1
10032         ad_from8 = i_start
10033         DO i=ad_from8,i_end
10034           CALL PUSHREAL8(vel)
10035           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
10036         END DO
10037         CALL PUSHINTEGER4(i - 1)
10038         CALL PUSHINTEGER4(ad_from8)
10039         CALL PUSHCONTROL3B(4)
10040       ELSE
10041         CALL PUSHCONTROL3B(5)
10042       END IF
10043 !  y flux-divergence into tendency
10044 ! Comments for polar boundary conditions
10045 ! Same process as for advect_u - tendencies run from jds to jde-1
10046 ! (latitudes are as for u grid, longitudes are displaced)
10047 ! Therefore: flow is only from one side for points next to poles
10048       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
10049         CALL PUSHINTEGER4(k)
10050         DO k=kts,ktf
10051           ad_from9 = i_start
10052           i = i_end + 1
10053           CALL PUSHINTEGER4(i - 1)
10054           CALL PUSHINTEGER4(ad_from9)
10055         END DO
10056         CALL PUSHCONTROL2B(0)
10057       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
10058         CALL PUSHINTEGER4(k)
10059         DO k=kts,ktf
10060           ad_from10 = i_start
10061           i = i_end + 1
10062           CALL PUSHINTEGER4(i - 1)
10063           CALL PUSHINTEGER4(ad_from10)
10064         END DO
10065         CALL PUSHCONTROL2B(1)
10066       ELSE IF (j .GT. j_start) THEN
10067 ! normal code
10068         CALL PUSHINTEGER4(k)
10069         DO k=kts+1,ktf+1
10070           ad_from11 = i_start
10071           i = i_end + 1
10072           CALL PUSHINTEGER4(i - 1)
10073           CALL PUSHINTEGER4(ad_from11)
10074         END DO
10075         CALL PUSHCONTROL2B(2)
10076       ELSE
10077         CALL PUSHCONTROL2B(3)
10078       END IF
10079       jtmp = jp1
10080       CALL PUSHINTEGER4(jp1)
10081       jp1 = jp0
10082       CALL PUSHINTEGER4(jp0)
10083       jp0 = jtmp
10084     END DO j_loop_y_flux_5
10085     CALL PUSHINTEGER4(j - 1)
10086     CALL PUSHINTEGER4(ad_from12)
10087 !  next, x - flux divergence
10088     i_start = its
10089     IF (ite .GT. ide - 1) THEN
10090       i_end = ide - 1
10091     ELSE
10092       i_end = ite
10093     END IF
10094     j_start = jts
10095     IF (jte .GT. jde - 1) THEN
10096       j_end = jde - 1
10097     ELSE
10098       j_end = jte
10099     END IF
10100 !  higher order flux has a 5 or 7 point stencil, so compute
10101 !  bounds so we can switch to second order flux close to the boundary
10102     i_start_f = i_start
10103     i_end_f = i_end + 1
10104     IF (degrade_xs) THEN
10105       IF (ids + 1 .LT. its) THEN
10106         i_start = its
10107       ELSE
10108         i_start = ids + 1
10109       END IF
10110       IF (i_start + 2 .GT. ids + 3) THEN
10111         i_start_f = ids + 3
10112       ELSE
10113         i_start_f = i_start + 2
10114       END IF
10115     END IF
10116     IF (degrade_xe) THEN
10117       IF (ide - 2 .GT. ite) THEN
10118         i_end = ite
10119       ELSE
10120         i_end = ide - 2
10121       END IF
10122       i_end_f = ide - 3
10123     END IF
10124     ad_from15 = j_start
10125 !  compute fluxes
10126     DO j=ad_from15,j_end
10127       CALL PUSHINTEGER4(k)
10128 !  5th or 6th order flux
10129       DO k=kts+1,ktf
10130         DO i=i_start_f,i_end_f
10131           CALL PUSHREAL8(vel)
10132         END DO
10133       END DO
10134       k = ktf + 1
10135       DO i=i_start_f,i_end_f
10136         CALL PUSHREAL8(vel)
10137         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
10138       END DO
10139 !  lower order fluxes close to boundaries (if not periodic or symmetric)
10140       IF (degrade_xs) THEN
10141         ad_from13 = i_start
10142         DO i=ad_from13,i_start_f-1
10143           IF (i .EQ. ids + 1) THEN
10144             CALL PUSHINTEGER4(k)
10145             CALL PUSHCONTROL1B(0)
10146           ELSE
10147             CALL PUSHCONTROL1B(1)
10148           END IF
10149           IF (i .EQ. ids + 2) THEN
10150             CALL PUSHINTEGER4(k)
10151 ! third order
10152             DO k=kts+1,ktf
10153               CALL PUSHREAL8(vel)
10154             END DO
10155             k = ktf + 1
10156             CALL PUSHREAL8(vel)
10157             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
10158             CALL PUSHCONTROL1B(1)
10159           ELSE
10160             CALL PUSHCONTROL1B(0)
10161           END IF
10162         END DO
10163         CALL PUSHINTEGER4(ad_from13)
10164         CALL PUSHCONTROL1B(0)
10165       ELSE
10166         CALL PUSHCONTROL1B(1)
10167       END IF
10168       IF (degrade_xe) THEN
10169         DO i=i_end_f+1,i_end+1
10170           IF (i .EQ. ide - 1) THEN
10171             CALL PUSHINTEGER4(k)
10172             CALL PUSHCONTROL1B(0)
10173           ELSE
10174             CALL PUSHCONTROL1B(1)
10175           END IF
10176           IF (i .EQ. ide - 2) THEN
10177             CALL PUSHINTEGER4(k)
10178 ! third order flux one in from the boundary
10179             DO k=kts+1,ktf
10180               CALL PUSHREAL8(vel)
10181             END DO
10182             k = ktf + 1
10183             CALL PUSHREAL8(vel)
10184             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
10185             CALL PUSHCONTROL1B(1)
10186           ELSE
10187             CALL PUSHCONTROL1B(0)
10188           END IF
10189         END DO
10190         CALL PUSHINTEGER4(i - 1)
10191         CALL PUSHCONTROL1B(1)
10192       ELSE
10193         CALL PUSHCONTROL1B(0)
10194       END IF
10195       CALL PUSHINTEGER4(k)
10196 !  x flux-divergence into tendency
10197       DO k=kts+1,ktf+1
10198         ad_from14 = i_start
10199         i = i_end + 1
10200         CALL PUSHINTEGER4(i - 1)
10201         CALL PUSHINTEGER4(ad_from14)
10202       END DO
10203     END DO
10204     CALL PUSHINTEGER4(j - 1)
10205     CALL PUSHINTEGER4(ad_from15)
10206     CALL PUSHCONTROL3B(6)
10207   ELSE IF (horz_order .EQ. 4) THEN
10208     degrade_xs = .true.
10209     degrade_xe = .true.
10210     degrade_ys = .true.
10211     degrade_ye = .true.
10212     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
10213 &        its .GT. ids + 2) degrade_xs = .false.
10214     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
10215 &        ite .LT. ide - 2) degrade_xe = .false.
10216     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
10217 &        jts .GT. jds + 2) degrade_ys = .false.
10218     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
10219 &        jte .LT. jde - 3) degrade_ye = .false.
10220     IF (kte .GT. kde - 1) THEN
10221       ktf = kde - 1
10222     ELSE
10223       ktf = kte
10224     END IF
10225     i_start = its
10226     IF (ite .GT. ide - 1) THEN
10227       i_end = ide - 1
10228     ELSE
10229       i_end = ite
10230     END IF
10231     j_start = jts
10232     IF (jte .GT. jde - 1) THEN
10233       j_end = jde - 1
10234     ELSE
10235       j_end = jte
10236     END IF
10237 !  3rd or 4th order flux has a 5 point stencil, so compute
10238 !  bounds so we can switch to second order flux close to the boundary
10239     i_start_f = i_start
10240     i_end_f = i_end + 1
10241     IF (degrade_xs) THEN
10242       i_start = ids + 1
10243       i_start_f = i_start + 1
10244     END IF
10245     IF (degrade_xe) THEN
10246       i_end = ide - 2
10247       i_end_f = ide - 2
10248     END IF
10249     ad_from17 = j_start
10250 !  compute fluxes
10251     DO j=ad_from17,j_end
10252       DO k=kts+1,ktf
10253         DO i=i_start_f,i_end_f
10254           CALL PUSHREAL8(vel)
10255         END DO
10256       END DO
10257       k = ktf + 1
10258       DO i=i_start_f,i_end_f
10259         CALL PUSHREAL8(vel)
10260         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
10261       END DO
10262 !  second order flux close to boundaries (if not periodic or symmetric)
10263       IF (degrade_xs) THEN
10264         CALL PUSHINTEGER4(k)
10265         CALL PUSHCONTROL1B(0)
10266       ELSE
10267         CALL PUSHCONTROL1B(1)
10268       END IF
10269       IF (degrade_xe) THEN
10270         CALL PUSHINTEGER4(k)
10271         CALL PUSHCONTROL1B(1)
10272       ELSE
10273         CALL PUSHCONTROL1B(0)
10274       END IF
10275       CALL PUSHINTEGER4(k)
10276 !  x flux-divergence into tendency
10277       DO k=kts+1,ktf+1
10278         ad_from16 = i_start
10279         i = i_end + 1
10280         CALL PUSHINTEGER4(i - 1)
10281         CALL PUSHINTEGER4(ad_from16)
10282       END DO
10283     END DO
10284     CALL PUSHINTEGER4(j - 1)
10285     CALL PUSHINTEGER4(ad_from17)
10286     CALL PUSHINTEGER4(i_start)
10287 !  next -> y flux divergence calculation
10288     i_start = its
10289     IF (ite .GT. ide - 1) THEN
10290       CALL PUSHINTEGER4(i_end)
10291       i_end = ide - 1
10292       CALL PUSHCONTROL1B(0)
10293     ELSE
10294       CALL PUSHINTEGER4(i_end)
10295       i_end = ite
10296       CALL PUSHCONTROL1B(1)
10297     END IF
10298     j_start = jts
10299     IF (jte .GT. jde - 1) THEN
10300       j_end = jde - 1
10301     ELSE
10302       j_end = jte
10303     END IF
10304 !  3rd or 4th order flux has a 5 point stencil, so compute
10305 !  bounds so we can switch to second order flux close to the boundary
10306     j_start_f = j_start
10307     j_end_f = j_end + 1
10308     IF (degrade_ys) THEN
10309       j_start = jds + 1
10310       j_start_f = j_start + 1
10311     END IF
10312     IF (degrade_ye) THEN
10313       j_end = jde - 2
10314       j_end_f = jde - 2
10315     END IF
10316     IF (config_flags%polar) THEN
10317       IF (jte .GT. jde - 1) THEN
10318         j_end = jde - 1
10319       ELSE
10320         j_end = jte
10321       END IF
10322     END IF
10323     jp1 = 2
10324     jp0 = 1
10325     ad_from27 = j_start
10326     DO j=ad_from27,j_end+1
10327       IF (j .LT. j_start_f .AND. degrade_ys) THEN
10328         CALL PUSHINTEGER4(k)
10329         DO k=kts+1,ktf
10330           ad_from18 = i_start
10331           i = i_end + 1
10332           CALL PUSHINTEGER4(i - 1)
10333           CALL PUSHINTEGER4(ad_from18)
10334         END DO
10335         k = ktf + 1
10336         ad_from19 = i_start
10337         i = i_end + 1
10338         CALL PUSHINTEGER4(i - 1)
10339         CALL PUSHINTEGER4(ad_from19)
10340         CALL PUSHCONTROL2B(0)
10341       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
10342         CALL PUSHINTEGER4(k)
10343         DO k=kts+1,ktf
10344           ad_from20 = i_start
10345           i = i_end + 1
10346           CALL PUSHINTEGER4(i - 1)
10347           CALL PUSHINTEGER4(ad_from20)
10348         END DO
10349         k = ktf + 1
10350         ad_from21 = i_start
10351         i = i_end + 1
10352         CALL PUSHINTEGER4(i - 1)
10353         CALL PUSHINTEGER4(ad_from21)
10354         CALL PUSHCONTROL2B(1)
10355       ELSE
10356         CALL PUSHINTEGER4(k)
10357 !  3rd or 4th order flux
10358         DO k=kts+1,ktf
10359           ad_from22 = i_start
10360           DO i=ad_from22,i_end
10361             CALL PUSHREAL8(vel)
10362           END DO
10363           CALL PUSHINTEGER4(i - 1)
10364           CALL PUSHINTEGER4(ad_from22)
10365         END DO
10366         k = ktf + 1
10367         ad_from23 = i_start
10368         DO i=ad_from23,i_end
10369           CALL PUSHREAL8(vel)
10370           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
10371         END DO
10372         CALL PUSHINTEGER4(i - 1)
10373         CALL PUSHINTEGER4(ad_from23)
10374         CALL PUSHCONTROL2B(2)
10375       END IF
10376 !  y flux-divergence into tendency
10377 ! Comments for polar boundary conditions
10378 ! Same process as for advect_u - tendencies run from jds to jde-1
10379 ! (latitudes are as for u grid, longitudes are displaced)
10380 ! Therefore: flow is only from one side for points next to poles
10381       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
10382         CALL PUSHINTEGER4(k)
10383         DO k=kts,ktf
10384           ad_from24 = i_start
10385           i = i_end + 1
10386           CALL PUSHINTEGER4(i - 1)
10387           CALL PUSHINTEGER4(ad_from24)
10388         END DO
10389         CALL PUSHCONTROL2B(0)
10390       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
10391         CALL PUSHINTEGER4(k)
10392         DO k=kts,ktf
10393           ad_from25 = i_start
10394           i = i_end + 1
10395           CALL PUSHINTEGER4(i - 1)
10396           CALL PUSHINTEGER4(ad_from25)
10397         END DO
10398         CALL PUSHCONTROL2B(1)
10399       ELSE IF (j .GT. j_start) THEN
10400 ! normal code
10401         CALL PUSHINTEGER4(k)
10402         DO k=kts+1,ktf+1
10403           ad_from26 = i_start
10404           i = i_end + 1
10405           CALL PUSHINTEGER4(i - 1)
10406           CALL PUSHINTEGER4(ad_from26)
10407         END DO
10408         CALL PUSHCONTROL2B(2)
10409       ELSE
10410         CALL PUSHCONTROL2B(3)
10411       END IF
10412       jtmp = jp1
10413       CALL PUSHINTEGER4(jp1)
10414       jp1 = jp0
10415       CALL PUSHINTEGER4(jp0)
10416       jp0 = jtmp
10417     END DO
10418     CALL PUSHINTEGER4(j - 1)
10419     CALL PUSHINTEGER4(ad_from27)
10420     CALL PUSHCONTROL3B(5)
10421   ELSE IF (horz_order .EQ. 3) THEN
10422     degrade_xs = .true.
10423     degrade_xe = .true.
10424     degrade_ys = .true.
10425     degrade_ye = .true.
10426     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
10427 &        its .GT. ids + 2) degrade_xs = .false.
10428     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
10429 &        ite .LT. ide - 2) degrade_xe = .false.
10430     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
10431 &        jts .GT. jds + 2) degrade_ys = .false.
10432     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
10433 &        jte .LT. jde - 3) degrade_ye = .false.
10434     IF (kte .GT. kde - 1) THEN
10435       ktf = kde - 1
10436     ELSE
10437       ktf = kte
10438     END IF
10439     i_start = its
10440     IF (ite .GT. ide - 1) THEN
10441       i_end = ide - 1
10442     ELSE
10443       i_end = ite
10444     END IF
10445     j_start = jts
10446     IF (jte .GT. jde - 1) THEN
10447       j_end = jde - 1
10448     ELSE
10449       j_end = jte
10450     END IF
10451 !  3rd or 4th order flux has a 5 point stencil, so compute
10452 !  bounds so we can switch to second order flux close to the boundary
10453     i_start_f = i_start
10454     i_end_f = i_end + 1
10455     IF (degrade_xs) THEN
10456       i_start = ids + 1
10457       i_start_f = i_start + 1
10458     END IF
10459     IF (degrade_xe) THEN
10460       i_end = ide - 2
10461       i_end_f = ide - 2
10462     END IF
10463     ad_from29 = j_start
10464 !  compute fluxes
10465     DO j=ad_from29,j_end
10466       DO k=kts+1,ktf
10467         DO i=i_start_f,i_end_f
10468           CALL PUSHREAL8(vel)
10469         END DO
10470       END DO
10471       k = ktf + 1
10472       DO i=i_start_f,i_end_f
10473         CALL PUSHREAL8(vel)
10474         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
10475       END DO
10476 !  second order flux close to boundaries (if not periodic or symmetric)
10477       IF (degrade_xs) THEN
10478         CALL PUSHINTEGER4(k)
10479         CALL PUSHCONTROL1B(0)
10480       ELSE
10481         CALL PUSHCONTROL1B(1)
10482       END IF
10483       IF (degrade_xe) THEN
10484         CALL PUSHINTEGER4(k)
10485         CALL PUSHCONTROL1B(1)
10486       ELSE
10487         CALL PUSHCONTROL1B(0)
10488       END IF
10489       CALL PUSHINTEGER4(k)
10490 !  x flux-divergence into tendency
10491       DO k=kts+1,ktf+1
10492         ad_from28 = i_start
10493         i = i_end + 1
10494         CALL PUSHINTEGER4(i - 1)
10495         CALL PUSHINTEGER4(ad_from28)
10496       END DO
10497     END DO
10498     CALL PUSHINTEGER4(j - 1)
10499     CALL PUSHINTEGER4(ad_from29)
10500     CALL PUSHINTEGER4(i_start)
10501 !  next -> y flux divergence calculation
10502     i_start = its
10503     IF (ite .GT. ide - 1) THEN
10504       CALL PUSHINTEGER4(i_end)
10505       i_end = ide - 1
10506       CALL PUSHCONTROL1B(0)
10507     ELSE
10508       CALL PUSHINTEGER4(i_end)
10509       i_end = ite
10510       CALL PUSHCONTROL1B(1)
10511     END IF
10512     j_start = jts
10513     IF (jte .GT. jde - 1) THEN
10514       j_end = jde - 1
10515     ELSE
10516       j_end = jte
10517     END IF
10518 !  3rd or 4th order flux has a 5 point stencil, so compute
10519 !  bounds so we can switch to second order flux close to the boundary
10520     j_start_f = j_start
10521     j_end_f = j_end + 1
10522     IF (degrade_ys) THEN
10523       j_start = jds + 1
10524       j_start_f = j_start + 1
10525     END IF
10526     IF (degrade_ye) THEN
10527       j_end = jde - 2
10528       j_end_f = jde - 2
10529     END IF
10530     IF (config_flags%polar) THEN
10531       IF (jte .GT. jde - 1) THEN
10532         j_end = jde - 1
10533       ELSE
10534         j_end = jte
10535       END IF
10536     END IF
10537     jp1 = 2
10538     jp0 = 1
10539     ad_from39 = j_start
10540     DO j=ad_from39,j_end+1
10541       IF (j .LT. j_start_f .AND. degrade_ys) THEN
10542         CALL PUSHINTEGER4(k)
10543         DO k=kts+1,ktf
10544           ad_from30 = i_start
10545           i = i_end + 1
10546           CALL PUSHINTEGER4(i - 1)
10547           CALL PUSHINTEGER4(ad_from30)
10548         END DO
10549         k = ktf + 1
10550         ad_from31 = i_start
10551         i = i_end + 1
10552         CALL PUSHINTEGER4(i - 1)
10553         CALL PUSHINTEGER4(ad_from31)
10554         CALL PUSHCONTROL2B(0)
10555       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
10556         CALL PUSHINTEGER4(k)
10557         DO k=kts+1,ktf
10558           ad_from32 = i_start
10559           i = i_end + 1
10560           CALL PUSHINTEGER4(i - 1)
10561           CALL PUSHINTEGER4(ad_from32)
10562         END DO
10563         k = ktf + 1
10564         ad_from33 = i_start
10565         i = i_end + 1
10566         CALL PUSHINTEGER4(i - 1)
10567         CALL PUSHINTEGER4(ad_from33)
10568         CALL PUSHCONTROL2B(1)
10569       ELSE
10570         CALL PUSHINTEGER4(k)
10571 !  3rd or 4th order flux
10572         DO k=kts+1,ktf
10573           ad_from34 = i_start
10574           DO i=ad_from34,i_end
10575             CALL PUSHREAL8(vel)
10576           END DO
10577           CALL PUSHINTEGER4(i - 1)
10578           CALL PUSHINTEGER4(ad_from34)
10579         END DO
10580         k = ktf + 1
10581         ad_from35 = i_start
10582         DO i=ad_from35,i_end
10583           CALL PUSHREAL8(vel)
10584           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
10585         END DO
10586         CALL PUSHINTEGER4(i - 1)
10587         CALL PUSHINTEGER4(ad_from35)
10588         CALL PUSHCONTROL2B(2)
10589       END IF
10590 !  y flux-divergence into tendency
10591 ! Comments for polar boundary conditions
10592 ! Same process as for advect_u - tendencies run from jds to jde-1
10593 ! (latitudes are as for u grid, longitudes are displaced)
10594 ! Therefore: flow is only from one side for points next to poles
10595       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
10596         CALL PUSHINTEGER4(k)
10597         DO k=kts,ktf
10598           ad_from36 = i_start
10599           i = i_end + 1
10600           CALL PUSHINTEGER4(i - 1)
10601           CALL PUSHINTEGER4(ad_from36)
10602         END DO
10603         CALL PUSHCONTROL2B(0)
10604       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
10605         CALL PUSHINTEGER4(k)
10606         DO k=kts,ktf
10607           ad_from37 = i_start
10608           i = i_end + 1
10609           CALL PUSHINTEGER4(i - 1)
10610           CALL PUSHINTEGER4(ad_from37)
10611         END DO
10612         CALL PUSHCONTROL2B(1)
10613       ELSE IF (j .GT. j_start) THEN
10614 ! normal code
10615         CALL PUSHINTEGER4(k)
10616         DO k=kts+1,ktf+1
10617           ad_from38 = i_start
10618           i = i_end + 1
10619           CALL PUSHINTEGER4(i - 1)
10620           CALL PUSHINTEGER4(ad_from38)
10621         END DO
10622         CALL PUSHCONTROL2B(2)
10623       ELSE
10624         CALL PUSHCONTROL2B(3)
10625       END IF
10626       jtmp = jp1
10627       CALL PUSHINTEGER4(jp1)
10628       jp1 = jp0
10629       CALL PUSHINTEGER4(jp0)
10630       jp0 = jtmp
10631     END DO
10632     CALL PUSHINTEGER4(j - 1)
10633     CALL PUSHINTEGER4(ad_from39)
10634     CALL PUSHCONTROL3B(4)
10635   ELSE IF (horz_order .EQ. 2) THEN
10636     i_start = its
10637     IF (ite .GT. ide - 1) THEN
10638       i_end = ide - 1
10639     ELSE
10640       i_end = ite
10641     END IF
10642     j_start = jts
10643     IF (jte .GT. jde - 1) THEN
10644       j_end = jde - 1
10645     ELSE
10646       j_end = jte
10647     END IF
10648     IF (.NOT.config_flags%periodic_x) THEN
10649       IF (config_flags%open_xs .OR. specified) THEN
10650         IF (ids + 1 .LT. its) THEN
10651           i_start = its
10652         ELSE
10653           i_start = ids + 1
10654         END IF
10655       END IF
10656       IF (config_flags%open_xe .OR. specified) THEN
10657         IF (ide - 2 .GT. ite) THEN
10658           i_end = ite
10659         ELSE
10660           i_end = ide - 2
10661         END IF
10662       END IF
10663     END IF
10664     ad_from42 = j_start
10665     DO j=ad_from42,j_end
10666       CALL PUSHINTEGER4(k)
10667       DO k=kts+1,ktf
10668         ad_from40 = i_start
10669         i = i_end + 1
10670         CALL PUSHINTEGER4(i - 1)
10671         CALL PUSHINTEGER4(ad_from40)
10672       END DO
10673       k = ktf + 1
10674       ad_from41 = i_start
10675       i = i_end + 1
10676       CALL PUSHINTEGER4(i - 1)
10677       CALL PUSHINTEGER4(ad_from41)
10678     END DO
10679     CALL PUSHINTEGER4(j - 1)
10680     CALL PUSHINTEGER4(ad_from42)
10681     i_start = its
10682     IF (ite .GT. ide - 1) THEN
10683       i_end = ide - 1
10684     ELSE
10685       i_end = ite
10686     END IF
10687 ! Polar boundary conditions are like open or specified
10688     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
10689 &    THEN
10690       IF (jds + 1 .LT. jts) THEN
10691         j_start = jts
10692       ELSE
10693         j_start = jds + 1
10694       END IF
10695     END IF
10696     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
10697 &    THEN
10698       IF (jde - 2 .GT. jte) THEN
10699         j_end = jte
10700       ELSE
10701         j_end = jde - 2
10702       END IF
10703     END IF
10704     ad_from45 = j_start
10705     DO j=ad_from45,j_end
10706       CALL PUSHINTEGER4(k)
10707       DO k=kts+1,ktf
10708         ad_from43 = i_start
10709         i = i_end + 1
10710         CALL PUSHINTEGER4(i - 1)
10711         CALL PUSHINTEGER4(ad_from43)
10712       END DO
10713       k = ktf + 1
10714       ad_from44 = i_start
10715       i = i_end + 1
10716       CALL PUSHINTEGER4(i - 1)
10717       CALL PUSHINTEGER4(ad_from44)
10718     END DO
10719     CALL PUSHINTEGER4(j - 1)
10720     CALL PUSHINTEGER4(ad_from45)
10721 ! Polar boundary condition ... not covered in above j-loop
10722     IF (config_flags%polar) THEN
10723       IF (jts .EQ. jds) THEN
10724         CALL PUSHINTEGER4(k)
10725         DO k=kts+1,ktf
10726           ad_from46 = i_start
10727           i = i_end + 1
10728           CALL PUSHINTEGER4(i - 1)
10729           CALL PUSHINTEGER4(ad_from46)
10730         END DO
10731         k = ktf + 1
10732         ad_from47 = i_start
10733         i = i_end + 1
10734         CALL PUSHINTEGER4(i - 1)
10735         CALL PUSHINTEGER4(ad_from47)
10736         CALL PUSHCONTROL1B(0)
10737       ELSE
10738         CALL PUSHCONTROL1B(1)
10739       END IF
10740       IF (jte .EQ. jde) THEN
10741         CALL PUSHINTEGER4(k)
10742         DO k=kts+1,ktf
10743           ad_from48 = i_start
10744           i = i_end + 1
10745           CALL PUSHINTEGER4(i - 1)
10746           CALL PUSHINTEGER4(ad_from48)
10747         END DO
10748         k = ktf + 1
10749         ad_from49 = i_start
10750         i = i_end + 1
10751         CALL PUSHINTEGER4(i - 1)
10752         CALL PUSHINTEGER4(ad_from49)
10753         CALL PUSHCONTROL3B(3)
10754       ELSE
10755         CALL PUSHCONTROL3B(2)
10756       END IF
10757     ELSE
10758       CALL PUSHCONTROL3B(1)
10759     END IF
10760   ELSE
10761     CALL PUSHCONTROL3B(0)
10762   END IF
10763 !  pick up the the horizontal radiation boundary conditions.
10764 !  (these are the computations that don't require 'cb'.
10765 !  first, set to index ranges
10766   i_start = its
10767   IF (ite .GT. ide - 1) THEN
10768     i_end = ide - 1
10769   ELSE
10770     i_end = ite
10771   END IF
10772   CALL PUSHINTEGER4(j_start)
10773   j_start = jts
10774   IF (jte .GT. jde - 1) THEN
10775     j_end = jde - 1
10776   ELSE
10777     j_end = jte
10778   END IF
10779   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
10780     ad_from67 = j_start
10781     DO j=ad_from67,j_end
10782       CALL PUSHINTEGER4(k)
10783       DO k=kts+1,ktf
10784         uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its&
10785 &          , k-1, j)+ru(its+1, k-1, j)))
10786         IF (uw .GT. 0.) THEN
10787           CALL PUSHREAL8(ub)
10788           ub = 0.
10789           CALL PUSHCONTROL1B(0)
10790         ELSE
10791           CALL PUSHREAL8(ub)
10792           ub = uw
10793           CALL PUSHCONTROL1B(1)
10794         END IF
10795       END DO
10796     END DO
10797     CALL PUSHINTEGER4(j - 1)
10798     CALL PUSHINTEGER4(ad_from67)
10799     CALL PUSHINTEGER4(k)
10800     k = ktf + 1
10801     ad_from68 = j_start
10802     DO j=ad_from68,j_end
10803       uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-&
10804 &        1)*(ru(its, k-2, j)+ru(its+1, k-2, j)))
10805       IF (uw .GT. 0.) THEN
10806         CALL PUSHREAL8(ub)
10807         ub = 0.
10808         CALL PUSHCONTROL1B(0)
10809       ELSE
10810         CALL PUSHREAL8(ub)
10811         ub = uw
10812         CALL PUSHCONTROL1B(1)
10813       END IF
10814     END DO
10815     CALL PUSHINTEGER4(j - 1)
10816     CALL PUSHINTEGER4(ad_from68)
10817     CALL PUSHCONTROL1B(0)
10818   ELSE
10819     CALL PUSHCONTROL1B(1)
10820   END IF
10821   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
10822     ad_from69 = j_start
10823     DO j=ad_from69,j_end
10824       CALL PUSHINTEGER4(k)
10825       DO k=kts+1,ktf
10826         uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-&
10827 &          1, k-1, j)+ru(ite, k-1, j)))
10828         IF (uw .LT. 0.) THEN
10829           CALL PUSHREAL8(ub)
10830           ub = 0.
10831           CALL PUSHCONTROL1B(0)
10832         ELSE
10833           CALL PUSHREAL8(ub)
10834           ub = uw
10835           CALL PUSHCONTROL1B(1)
10836         END IF
10837       END DO
10838     END DO
10839     CALL PUSHINTEGER4(j - 1)
10840     CALL PUSHINTEGER4(ad_from69)
10841     CALL PUSHINTEGER4(k)
10842     k = ktf + 1
10843     ad_from70 = j_start
10844     DO j=ad_from70,j_end
10845       uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-&
10846 &        1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j)))
10847       IF (uw .LT. 0.) THEN
10848         CALL PUSHREAL8(ub)
10849         ub = 0.
10850         CALL PUSHCONTROL1B(0)
10851       ELSE
10852         CALL PUSHREAL8(ub)
10853         ub = uw
10854         CALL PUSHCONTROL1B(1)
10855       END IF
10856     END DO
10857     CALL PUSHINTEGER4(j - 1)
10858     CALL PUSHINTEGER4(ad_from70)
10859     CALL PUSHCONTROL1B(0)
10860   ELSE
10861     CALL PUSHCONTROL1B(1)
10862   END IF
10863   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
10864     ad_from71 = i_start
10865     DO i=ad_from71,i_end
10866       CALL PUSHINTEGER4(k)
10867       DO k=kts+1,ktf
10868         vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k&
10869 &          -1, jts)+rv(i, k-1, jts+1)))
10870         IF (vw .GT. 0.) THEN
10871           CALL PUSHREAL8(vb)
10872           vb = 0.
10873           CALL PUSHCONTROL1B(0)
10874         ELSE
10875           CALL PUSHREAL8(vb)
10876           vb = vw
10877           CALL PUSHCONTROL1B(1)
10878         END IF
10879       END DO
10880     END DO
10881     CALL PUSHINTEGER4(i - 1)
10882     CALL PUSHINTEGER4(ad_from71)
10883     CALL PUSHINTEGER4(k)
10884     k = ktf + 1
10885     ad_from72 = i_start
10886     DO i=ad_from72,i_end
10887       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-&
10888 &        1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1)))
10889       IF (vw .GT. 0.) THEN
10890         CALL PUSHREAL8(vb)
10891         vb = 0.
10892         CALL PUSHCONTROL1B(0)
10893       ELSE
10894         CALL PUSHREAL8(vb)
10895         vb = vw
10896         CALL PUSHCONTROL1B(1)
10897       END IF
10898     END DO
10899     CALL PUSHINTEGER4(i - 1)
10900     CALL PUSHINTEGER4(ad_from72)
10901     CALL PUSHCONTROL1B(0)
10902   ELSE
10903     CALL PUSHCONTROL1B(1)
10904   END IF
10905   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
10906     ad_from73 = i_start
10907     DO i=ad_from73,i_end
10908       CALL PUSHINTEGER4(k)
10909       DO k=kts+1,ktf
10910         vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k&
10911 &          -1, jte-1)+rv(i, k-1, jte)))
10912         IF (vw .LT. 0.) THEN
10913           CALL PUSHREAL8(vb)
10914           vb = 0.
10915           CALL PUSHCONTROL1B(0)
10916         ELSE
10917           CALL PUSHREAL8(vb)
10918           vb = vw
10919           CALL PUSHCONTROL1B(1)
10920         END IF
10921       END DO
10922     END DO
10923     CALL PUSHINTEGER4(i - 1)
10924     CALL PUSHINTEGER4(ad_from73)
10925     CALL PUSHINTEGER4(k)
10926     k = ktf + 1
10927     ad_from74 = i_start
10928     DO i=ad_from74,i_end
10929       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-&
10930 &        1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte)))
10931       IF (vw .LT. 0.) THEN
10932         CALL PUSHREAL8(vb)
10933         vb = 0.
10934         CALL PUSHCONTROL1B(0)
10935       ELSE
10936         CALL PUSHREAL8(vb)
10937         vb = vw
10938         CALL PUSHCONTROL1B(1)
10939       END IF
10940     END DO
10941     CALL PUSHINTEGER4(i - 1)
10942     CALL PUSHINTEGER4(ad_from74)
10943     CALL PUSHCONTROL1B(1)
10944   ELSE
10945     CALL PUSHCONTROL1B(0)
10946   END IF
10947 !-------------------- vertical advection
10948 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
10949 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
10950 !     Therefore we don't need to make a correction for advect_w
10951   i_start = its
10952   IF (ite .GT. ide - 1) THEN
10953     CALL PUSHINTEGER4(i_end)
10954     i_end = ide - 1
10955     CALL PUSHCONTROL1B(0)
10956   ELSE
10957     CALL PUSHINTEGER4(i_end)
10958     i_end = ite
10959     CALL PUSHCONTROL1B(1)
10960   END IF
10961   j_start = jts
10962   IF (jte .GT. jde - 1) THEN
10963     CALL PUSHINTEGER4(j_end)
10964     j_end = jde - 1
10965     CALL PUSHCONTROL1B(0)
10966   ELSE
10967     CALL PUSHINTEGER4(j_end)
10968     j_end = jte
10969     CALL PUSHCONTROL1B(1)
10970   END IF
10971   IF (vert_order .EQ. 6) THEN
10972     DO j=j_start,j_end
10973       CALL PUSHINTEGER4(k)
10974       DO k=kts+3,ktf-1
10975         DO i=i_start,i_end
10976           CALL PUSHREAL8(vel)
10977         END DO
10978       END DO
10979       DO i=i_start,i_end
10980         CALL PUSHREAL8(vel)
10981       END DO
10982       CALL PUSHINTEGER4(k)
10983 ! pick up flux contribution for w at the lid. wcs, 13 march 2004
10984       k = ktf + 1
10985     END DO
10986     vfluxb = 0.0
10987     DO j=j_end,j_start,-1
10988       DO i=i_end,i_start,-1
10989         vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j)
10990       END DO
10991       DO k=ktf,kts+1,-1
10992         DO i=i_end,i_start,-1
10993           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j)
10994           vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j)
10995         END DO
10996       END DO
10997       CALL POPINTEGER4(k)
10998       DO i=i_end,i_start,-1
10999         k = ktf + 1
11000         temp63b96 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11001         temp63b97 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11002         romb(i, k, j) = romb(i, k, j) + temp63b96
11003         romb(i, k-1, j) = romb(i, k-1, j) + temp63b96
11004         wb(i, k, j) = wb(i, k, j) + temp63b97
11005         wb(i, k-1, j) = wb(i, k-1, j) + temp63b97
11006         vfluxb(i, k) = 0.0
11007         k = ktf
11008         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11009         temp63b98 = vel*vfluxb(i, k)/12.0
11010         velb = (7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))*&
11011 &          vfluxb(i, k)/12.0
11012         wb(i, k, j) = wb(i, k, j) + 7.*temp63b98
11013         wb(i, k-1, j) = wb(i, k-1, j) + 7.*temp63b98
11014         wb(i, k+1, j) = wb(i, k+1, j) - temp63b98
11015         wb(i, k-2, j) = wb(i, k-2, j) - temp63b98
11016         vfluxb(i, k) = 0.0
11017         romb(i, k, j) = romb(i, k, j) + 0.5*velb
11018         romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11019         k = kts + 2
11020         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11021         temp63b99 = vel*vfluxb(i, k)/12.0
11022         velb = (7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))*&
11023 &          vfluxb(i, k)/12.0
11024         wb(i, k, j) = wb(i, k, j) + 7.*temp63b99
11025         wb(i, k-1, j) = wb(i, k-1, j) + 7.*temp63b99
11026         wb(i, k+1, j) = wb(i, k+1, j) - temp63b99
11027         wb(i, k-2, j) = wb(i, k-2, j) - temp63b99
11028         vfluxb(i, k) = 0.0
11029         CALL POPREAL8(vel)
11030         romb(i, k, j) = romb(i, k, j) + 0.5*velb
11031         romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11032         k = kts + 1
11033         temp63b100 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11034         temp63b101 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11035         romb(i, k, j) = romb(i, k, j) + temp63b100
11036         romb(i, k-1, j) = romb(i, k-1, j) + temp63b100
11037         wb(i, k, j) = wb(i, k, j) + temp63b101
11038         wb(i, k-1, j) = wb(i, k-1, j) + temp63b101
11039         vfluxb(i, k) = 0.0
11040       END DO
11041       DO k=ktf-1,kts+3,-1
11042         DO i=i_end,i_start,-1
11043           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11044           temp63b95 = vel*vfluxb(i, k)/60.0
11045           velb = (37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1, j)+w(i, k-&
11046 &            2, j))+w(i, k+2, j)+w(i, k-3, j))*vfluxb(i, k)/60.0
11047           wb(i, k, j) = wb(i, k, j) + 37.*temp63b95
11048           wb(i, k-1, j) = wb(i, k-1, j) + 37.*temp63b95
11049           wb(i, k+1, j) = wb(i, k+1, j) - 8.*temp63b95
11050           wb(i, k-2, j) = wb(i, k-2, j) - 8.*temp63b95
11051           wb(i, k+2, j) = wb(i, k+2, j) + temp63b95
11052           wb(i, k-3, j) = wb(i, k-3, j) + temp63b95
11053           vfluxb(i, k) = 0.0
11054           CALL POPREAL8(vel)
11055           romb(i, k, j) = romb(i, k, j) + 0.5*velb
11056           romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11057         END DO
11058       END DO
11059       CALL POPINTEGER4(k)
11060     END DO
11061   ELSE IF (vert_order .EQ. 5) THEN
11062     DO j=j_start,j_end
11063       CALL PUSHINTEGER4(k)
11064       DO k=kts+3,ktf-1
11065         DO i=i_start,i_end
11066           CALL PUSHREAL8(vel)
11067         END DO
11068       END DO
11069       DO i=i_start,i_end
11070         CALL PUSHREAL8(vel)
11071       END DO
11072       CALL PUSHINTEGER4(k)
11073 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
11074       k = ktf + 1
11075     END DO
11076     vfluxb = 0.0
11077     DO j=j_end,j_start,-1
11078       DO i=i_end,i_start,-1
11079         vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j)
11080       END DO
11081       DO k=ktf,kts+1,-1
11082         DO i=i_end,i_start,-1
11083           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j)
11084           vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j)
11085         END DO
11086       END DO
11087       CALL POPINTEGER4(k)
11088       DO i=i_end,i_start,-1
11089         k = ktf + 1
11090         temp75b = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11091         temp75b0 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11092         romb(i, k, j) = romb(i, k, j) + temp75b
11093         romb(i, k-1, j) = romb(i, k-1, j) + temp75b
11094         wb(i, k, j) = wb(i, k, j) + temp75b0
11095         wb(i, k-1, j) = wb(i, k-1, j) + temp75b0
11096         vfluxb(i, k) = 0.0
11097         k = ktf
11098         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11099         temp71 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, &
11100 &          j))
11101         temp74 = SIGN(1., -vel)
11102         temp73 = temp74/12.0
11103         temp72 = SIGN(1, time_step)
11104         temp71b = vel*vfluxb(i, k)
11105         temp71b0 = temp71b/12.0
11106         temp71b1 = temp72*temp73*temp71b
11107         velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))&
11108 &          /12.0+temp72*(temp73*temp71))*vfluxb(i, k)
11109         wb(i, k, j) = wb(i, k, j) + 7.*temp71b0 - 3.*temp71b1
11110         wb(i, k-1, j) = wb(i, k-1, j) + 3.*temp71b1 + 7.*temp71b0
11111         wb(i, k+1, j) = wb(i, k+1, j) + temp71b1 - temp71b0
11112         wb(i, k-2, j) = wb(i, k-2, j) - temp71b1 - temp71b0
11113         vfluxb(i, k) = 0.0
11114         romb(i, k, j) = romb(i, k, j) + 0.5*velb
11115         romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11116         k = kts + 2
11117         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11118         temp67 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, &
11119 &          j))
11120         temp70 = SIGN(1., -vel)
11121         temp69 = temp70/12.0
11122         temp68 = SIGN(1, time_step)
11123         temp67b = vel*vfluxb(i, k)
11124         temp67b0 = temp67b/12.0
11125         temp67b1 = temp68*temp69*temp67b
11126         velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))&
11127 &          /12.0+temp68*(temp69*temp67))*vfluxb(i, k)
11128         wb(i, k, j) = wb(i, k, j) + 7.*temp67b0 - 3.*temp67b1
11129         wb(i, k-1, j) = wb(i, k-1, j) + 3.*temp67b1 + 7.*temp67b0
11130         wb(i, k+1, j) = wb(i, k+1, j) + temp67b1 - temp67b0
11131         wb(i, k-2, j) = wb(i, k-2, j) - temp67b1 - temp67b0
11132         vfluxb(i, k) = 0.0
11133         CALL POPREAL8(vel)
11134         romb(i, k, j) = romb(i, k, j) + 0.5*velb
11135         romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11136         k = kts + 1
11137         temp67b2 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11138         temp67b3 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11139         romb(i, k, j) = romb(i, k, j) + temp67b2
11140         romb(i, k-1, j) = romb(i, k-1, j) + temp67b2
11141         wb(i, k, j) = wb(i, k, j) + temp67b3
11142         wb(i, k-1, j) = wb(i, k-1, j) + temp67b3
11143         vfluxb(i, k) = 0.0
11144       END DO
11145       DO k=ktf-1,kts+3,-1
11146         DO i=i_end,i_start,-1
11147           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11148           temp63 = w(i, k+2, j) - w(i, k-3, j) + 10.*(w(i, k, j)-w(i, k-&
11149 &            1, j)) - 5.*(w(i, k+1, j)-w(i, k-2, j))
11150           temp66 = SIGN(1., -vel)
11151           temp65 = temp66/60.0
11152           temp64 = SIGN(1, time_step)
11153           temp63b102 = vel*vfluxb(i, k)
11154           temp63b103 = temp63b102/60.0
11155           temp63b104 = -(temp64*temp65*temp63b102)
11156           velb = ((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1, j)+w(i, k&
11157 &            -2, j))+w(i, k+2, j)+w(i, k-3, j))/60.0-temp64*(temp65*&
11158 &            temp63))*vfluxb(i, k)
11159           wb(i, k, j) = wb(i, k, j) + 10.*temp63b104 + 37.*temp63b103
11160           wb(i, k-1, j) = wb(i, k-1, j) + 37.*temp63b103 - 10.*&
11161 &            temp63b104
11162           wb(i, k+1, j) = wb(i, k+1, j) - 5.*temp63b104 - 8.*temp63b103
11163           wb(i, k-2, j) = wb(i, k-2, j) + 5.*temp63b104 - 8.*temp63b103
11164           wb(i, k+2, j) = wb(i, k+2, j) + temp63b104 + temp63b103
11165           wb(i, k-3, j) = wb(i, k-3, j) + temp63b103 - temp63b104
11166           vfluxb(i, k) = 0.0
11167           CALL POPREAL8(vel)
11168           romb(i, k, j) = romb(i, k, j) + 0.5*velb
11169           romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11170         END DO
11171       END DO
11172       CALL POPINTEGER4(k)
11173     END DO
11174   ELSE IF (vert_order .EQ. 4) THEN
11175     DO j=j_start,j_end
11176       CALL PUSHINTEGER4(k)
11177       DO k=kts+2,ktf
11178         DO i=i_start,i_end
11179           CALL PUSHREAL8(vel)
11180         END DO
11181       END DO
11182       CALL PUSHINTEGER4(k)
11183 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
11184       k = ktf + 1
11185     END DO
11186     vfluxb = 0.0
11187     DO j=j_end,j_start,-1
11188       DO i=i_end,i_start,-1
11189         vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j)
11190       END DO
11191       DO k=ktf,kts+1,-1
11192         DO i=i_end,i_start,-1
11193           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j)
11194           vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j)
11195         END DO
11196       END DO
11197       CALL POPINTEGER4(k)
11198       DO i=i_end,i_start,-1
11199         k = ktf + 1
11200         temp75b2 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11201         temp75b3 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11202         romb(i, k, j) = romb(i, k, j) + temp75b2
11203         romb(i, k-1, j) = romb(i, k-1, j) + temp75b2
11204         wb(i, k, j) = wb(i, k, j) + temp75b3
11205         wb(i, k-1, j) = wb(i, k-1, j) + temp75b3
11206         vfluxb(i, k) = 0.0
11207         k = kts + 1
11208         temp75b4 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11209         temp75b5 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11210         romb(i, k, j) = romb(i, k, j) + temp75b4
11211         romb(i, k-1, j) = romb(i, k-1, j) + temp75b4
11212         wb(i, k, j) = wb(i, k, j) + temp75b5
11213         wb(i, k-1, j) = wb(i, k-1, j) + temp75b5
11214         vfluxb(i, k) = 0.0
11215       END DO
11216       DO k=ktf,kts+2,-1
11217         DO i=i_end,i_start,-1
11218           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11219           temp75b1 = vel*vfluxb(i, k)/12.0
11220           velb = (7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j)&
11221 &            )*vfluxb(i, k)/12.0
11222           wb(i, k, j) = wb(i, k, j) + 7.*temp75b1
11223           wb(i, k-1, j) = wb(i, k-1, j) + 7.*temp75b1
11224           wb(i, k+1, j) = wb(i, k+1, j) - temp75b1
11225           wb(i, k-2, j) = wb(i, k-2, j) - temp75b1
11226           vfluxb(i, k) = 0.0
11227           CALL POPREAL8(vel)
11228           romb(i, k, j) = romb(i, k, j) + 0.5*velb
11229           romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11230         END DO
11231       END DO
11232       CALL POPINTEGER4(k)
11233     END DO
11234   ELSE IF (vert_order .EQ. 3) THEN
11235     DO j=j_start,j_end
11236       CALL PUSHINTEGER4(k)
11237       DO k=kts+2,ktf
11238         DO i=i_start,i_end
11239           CALL PUSHREAL8(vel)
11240         END DO
11241       END DO
11242       CALL PUSHINTEGER4(k)
11243 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
11244       k = ktf + 1
11245     END DO
11246     vfluxb = 0.0
11247     DO j=j_end,j_start,-1
11248       DO i=i_end,i_start,-1
11249         vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j)
11250       END DO
11251       DO k=ktf,kts+1,-1
11252         DO i=i_end,i_start,-1
11253           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j)
11254           vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j)
11255         END DO
11256       END DO
11257       CALL POPINTEGER4(k)
11258       DO i=i_end,i_start,-1
11259         k = ktf + 1
11260         temp79b = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11261         temp79b0 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11262         romb(i, k, j) = romb(i, k, j) + temp79b
11263         romb(i, k-1, j) = romb(i, k-1, j) + temp79b
11264         wb(i, k, j) = wb(i, k, j) + temp79b0
11265         wb(i, k-1, j) = wb(i, k-1, j) + temp79b0
11266         vfluxb(i, k) = 0.0
11267         k = kts + 1
11268         temp79b1 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11269         temp79b2 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11270         romb(i, k, j) = romb(i, k, j) + temp79b1
11271         romb(i, k-1, j) = romb(i, k-1, j) + temp79b1
11272         wb(i, k, j) = wb(i, k, j) + temp79b2
11273         wb(i, k-1, j) = wb(i, k-1, j) + temp79b2
11274         vfluxb(i, k) = 0.0
11275       END DO
11276       DO k=ktf,kts+2,-1
11277         DO i=i_end,i_start,-1
11278           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
11279           temp75 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1&
11280 &            , j))
11281           temp78 = SIGN(1., -vel)
11282           temp77 = temp78/12.0
11283           temp76 = SIGN(1, time_step)
11284           temp75b6 = vel*vfluxb(i, k)
11285           temp75b7 = temp75b6/12.0
11286           temp75b8 = temp76*temp77*temp75b6
11287           velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j&
11288 &            ))/12.0+temp76*(temp77*temp75))*vfluxb(i, k)
11289           wb(i, k, j) = wb(i, k, j) + 7.*temp75b7 - 3.*temp75b8
11290           wb(i, k-1, j) = wb(i, k-1, j) + 3.*temp75b8 + 7.*temp75b7
11291           wb(i, k+1, j) = wb(i, k+1, j) + temp75b8 - temp75b7
11292           wb(i, k-2, j) = wb(i, k-2, j) - temp75b8 - temp75b7
11293           vfluxb(i, k) = 0.0
11294           CALL POPREAL8(vel)
11295           romb(i, k, j) = romb(i, k, j) + 0.5*velb
11296           romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
11297         END DO
11298       END DO
11299       CALL POPINTEGER4(k)
11300     END DO
11301   ELSE IF (vert_order .EQ. 2) THEN
11302     DO j=j_start,j_end
11303       CALL PUSHINTEGER4(k)
11304 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
11305       k = ktf + 1
11306     END DO
11307     vfluxb = 0.0
11308     DO j=j_end,j_start,-1
11309       DO i=i_end,i_start,-1
11310         vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j)
11311       END DO
11312       DO k=ktf,kts+1,-1
11313         DO i=i_end,i_start,-1
11314           vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j)
11315           vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j)
11316         END DO
11317       END DO
11318       DO k=ktf+1,kts+1,-1
11319         DO i=i_end,i_start,-1
11320           temp79b3 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
11321           temp79b4 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
11322           romb(i, k, j) = romb(i, k, j) + temp79b3
11323           romb(i, k-1, j) = romb(i, k-1, j) + temp79b3
11324           wb(i, k, j) = wb(i, k, j) + temp79b4
11325           wb(i, k-1, j) = wb(i, k-1, j) + temp79b4
11326           vfluxb(i, k) = 0.0
11327         END DO
11328       END DO
11329       CALL POPINTEGER4(k)
11330     END DO
11331   END IF
11332   CALL POPCONTROL1B(branch)
11333   IF (branch .EQ. 0) THEN
11334     CALL POPINTEGER4(j_end)
11335   ELSE
11336     CALL POPINTEGER4(j_end)
11337   END IF
11338   CALL POPCONTROL1B(branch)
11339   IF (branch .EQ. 0) THEN
11340     CALL POPINTEGER4(i_end)
11341   ELSE
11342     CALL POPINTEGER4(i_end)
11343   END IF
11344   CALL POPCONTROL1B(branch)
11345   IF (branch .NE. 0) THEN
11346     CALL POPINTEGER4(ad_from74)
11347     CALL POPINTEGER4(ad_to74)
11348     DO i=ad_to74,ad_from74,-1
11349       temp63b91 = -(rdy*tendencyb(i, k, j_end))
11350       temp63b92 = w(i, k, j_end)*temp63b91
11351       temp63b93 = (2.-fzm(k-1))*temp63b92
11352       temp63b94 = -(fzp(k-1)*temp63b92)
11353       vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp63b91
11354       w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp63b91
11355       w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp63b91
11356       wb(i, k, j_end) = wb(i, k, j_end) + ((2.-fzm(k-1))*(rv(i, k-1, jte&
11357 &        )-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, jte-1)&
11358 &        ))*temp63b91
11359       rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp63b93
11360       rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - temp63b93
11361       rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp63b94
11362       rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) - temp63b94
11363       CALL POPCONTROL1B(branch)
11364       IF (branch .EQ. 0) THEN
11365         CALL POPREAL8(vb)
11366         vwb = 0.0
11367       ELSE
11368         CALL POPREAL8(vb)
11369         vwb = vbb
11370       END IF
11371       temp63b89 = 0.5*(2.-fzm(k-1))*vwb
11372       temp63b90 = -(0.5*fzp(k-1)*vwb)
11373       rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + temp63b89
11374       rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp63b89
11375       rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) + temp63b90
11376       rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp63b90
11377     END DO
11378     CALL POPINTEGER4(k)
11379     CALL POPINTEGER4(ad_from73)
11380     CALL POPINTEGER4(ad_to73)
11381     DO i=ad_to73,ad_from73,-1
11382       DO k=ktf,kts+1,-1
11383         temp63b87 = -(rdy*tendencyb(i, k, j_end))
11384         temp63b88 = w(i, k, j_end)*temp63b87
11385         vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp63b87
11386         w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp63b87
11387         w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp63b87
11388         wb(i, k, j_end) = wb(i, k, j_end) + (fzm(k)*(rv(i, k, jte)-rv(i&
11389 &          , k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte-1)))*&
11390 &          temp63b87
11391         rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp63b88
11392         rvb(i, k, jte-1) = rvb(i, k, jte-1) - fzm(k)*temp63b88
11393         rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp63b88
11394         rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - fzp(k)*temp63b88
11395         CALL POPCONTROL1B(branch)
11396         IF (branch .EQ. 0) THEN
11397           CALL POPREAL8(vb)
11398           vwb = 0.0
11399         ELSE
11400           CALL POPREAL8(vb)
11401           vwb = vbb
11402         END IF
11403         temp63b86 = 0.5*vwb
11404         rvb(i, k, jte-1) = rvb(i, k, jte-1) + fzm(k)*temp63b86
11405         rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp63b86
11406         rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + fzp(k)*temp63b86
11407         rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp63b86
11408       END DO
11409       CALL POPINTEGER4(k)
11410     END DO
11411   END IF
11412   CALL POPCONTROL1B(branch)
11413   IF (branch .EQ. 0) THEN
11414     CALL POPINTEGER4(ad_from72)
11415     CALL POPINTEGER4(ad_to72)
11416     DO i=ad_to72,ad_from72,-1
11417       temp63b82 = -(rdy*tendencyb(i, k, jts))
11418       temp63b83 = w(i, k, jts)*temp63b82
11419       temp63b84 = (2.-fzm(k-1))*temp63b83
11420       temp63b85 = -(fzp(k-1)*temp63b83)
11421       vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp63b82
11422       w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp63b82
11423       w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp63b82
11424       wb(i, k, jts) = wb(i, k, jts) + ((2.-fzm(k-1))*(rv(i, k-1, jts+1)-&
11425 &        rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))*&
11426 &        temp63b82
11427       rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp63b84
11428       rvb(i, k-1, jts) = rvb(i, k-1, jts) - temp63b84
11429       rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp63b85
11430       rvb(i, k-2, jts) = rvb(i, k-2, jts) - temp63b85
11431       CALL POPCONTROL1B(branch)
11432       IF (branch .EQ. 0) THEN
11433         CALL POPREAL8(vb)
11434         vwb = 0.0
11435       ELSE
11436         CALL POPREAL8(vb)
11437         vwb = vbb
11438       END IF
11439       temp63b80 = 0.5*(2.-fzm(k-1))*vwb
11440       temp63b81 = -(0.5*fzp(k-1)*vwb)
11441       rvb(i, k-1, jts) = rvb(i, k-1, jts) + temp63b80
11442       rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp63b80
11443       rvb(i, k-2, jts) = rvb(i, k-2, jts) + temp63b81
11444       rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp63b81
11445     END DO
11446     CALL POPINTEGER4(k)
11447     CALL POPINTEGER4(ad_from71)
11448     CALL POPINTEGER4(ad_to71)
11449     DO i=ad_to71,ad_from71,-1
11450       DO k=ktf,kts+1,-1
11451         temp63b78 = -(rdy*tendencyb(i, k, jts))
11452         temp63b79 = w(i, k, jts)*temp63b78
11453         vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp63b78
11454         w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp63b78
11455         w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp63b78
11456         wb(i, k, jts) = wb(i, k, jts) + (fzm(k)*(rv(i, k, jts+1)-rv(i, k&
11457 &          , jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))*temp63b78
11458         rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp63b79
11459         rvb(i, k, jts) = rvb(i, k, jts) - fzm(k)*temp63b79
11460         rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp63b79
11461         rvb(i, k-1, jts) = rvb(i, k-1, jts) - fzp(k)*temp63b79
11462         CALL POPCONTROL1B(branch)
11463         IF (branch .EQ. 0) THEN
11464           CALL POPREAL8(vb)
11465           vwb = 0.0
11466         ELSE
11467           CALL POPREAL8(vb)
11468           vwb = vbb
11469         END IF
11470         temp63b77 = 0.5*vwb
11471         rvb(i, k, jts) = rvb(i, k, jts) + fzm(k)*temp63b77
11472         rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp63b77
11473         rvb(i, k-1, jts) = rvb(i, k-1, jts) + fzp(k)*temp63b77
11474         rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp63b77
11475       END DO
11476       CALL POPINTEGER4(k)
11477     END DO
11478   END IF
11479   CALL POPCONTROL1B(branch)
11480   IF (branch .EQ. 0) THEN
11481     CALL POPINTEGER4(ad_from70)
11482     CALL POPINTEGER4(ad_to70)
11483     DO j=ad_to70,ad_from70,-1
11484       temp63b73 = -(rdx*tendencyb(i_end, k, j))
11485       temp63b74 = w(i_end, k, j)*temp63b73
11486       temp63b75 = (2.-fzm(k-1))*temp63b74
11487       temp63b76 = -(fzp(k-1)*temp63b74)
11488       ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp63b73
11489       w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp63b73
11490       w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp63b73
11491       wb(i_end, k, j) = wb(i_end, k, j) + ((2.-fzm(k-1))*(ru(ite, k-1, j&
11492 &        )-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-2, j)&
11493 &        ))*temp63b73
11494       rub(ite, k-1, j) = rub(ite, k-1, j) + temp63b75
11495       rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - temp63b75
11496       rub(ite, k-2, j) = rub(ite, k-2, j) + temp63b76
11497       rub(ite-1, k-2, j) = rub(ite-1, k-2, j) - temp63b76
11498       CALL POPCONTROL1B(branch)
11499       IF (branch .EQ. 0) THEN
11500         CALL POPREAL8(ub)
11501         uwb = 0.0
11502       ELSE
11503         CALL POPREAL8(ub)
11504         uwb = ubb
11505       END IF
11506       temp63b71 = 0.5*(2.-fzm(k-1))*uwb
11507       temp63b72 = -(0.5*fzp(k-1)*uwb)
11508       rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + temp63b71
11509       rub(ite, k-1, j) = rub(ite, k-1, j) + temp63b71
11510       rub(ite-1, k-2, j) = rub(ite-1, k-2, j) + temp63b72
11511       rub(ite, k-2, j) = rub(ite, k-2, j) + temp63b72
11512     END DO
11513     CALL POPINTEGER4(k)
11514     CALL POPINTEGER4(ad_from69)
11515     CALL POPINTEGER4(ad_to69)
11516     DO j=ad_to69,ad_from69,-1
11517       DO k=ktf,kts+1,-1
11518         temp63b69 = -(rdx*tendencyb(i_end, k, j))
11519         temp63b70 = w(i_end, k, j)*temp63b69
11520         ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp63b69
11521         w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp63b69
11522         w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp63b69
11523         wb(i_end, k, j) = wb(i_end, k, j) + (fzm(k)*(ru(ite, k, j)-ru(&
11524 &          ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j)))*&
11525 &          temp63b69
11526         rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp63b70
11527         rub(ite-1, k, j) = rub(ite-1, k, j) - fzm(k)*temp63b70
11528         rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp63b70
11529         rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - fzp(k)*temp63b70
11530         CALL POPCONTROL1B(branch)
11531         IF (branch .EQ. 0) THEN
11532           CALL POPREAL8(ub)
11533           uwb = 0.0
11534         ELSE
11535           CALL POPREAL8(ub)
11536           uwb = ubb
11537         END IF
11538         temp63b68 = 0.5*uwb
11539         rub(ite-1, k, j) = rub(ite-1, k, j) + fzm(k)*temp63b68
11540         rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp63b68
11541         rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + fzp(k)*temp63b68
11542         rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp63b68
11543       END DO
11544       CALL POPINTEGER4(k)
11545     END DO
11546   END IF
11547   CALL POPCONTROL1B(branch)
11548   IF (branch .EQ. 0) THEN
11549     CALL POPINTEGER4(ad_from68)
11550     CALL POPINTEGER4(ad_to68)
11551     DO j=ad_to68,ad_from68,-1
11552       temp63b64 = -(rdx*tendencyb(its, k, j))
11553       temp63b65 = w(its, k, j)*temp63b64
11554       temp63b66 = (2.-fzm(k-1))*temp63b65
11555       temp63b67 = -(fzp(k-1)*temp63b65)
11556       ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp63b64
11557       w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp63b64
11558       w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp63b64
11559       wb(its, k, j) = wb(its, k, j) + ((2.-fzm(k-1))*(ru(its+1, k-1, j)-&
11560 &        ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))*&
11561 &        temp63b64
11562       rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp63b66
11563       rub(its, k-1, j) = rub(its, k-1, j) - temp63b66
11564       rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp63b67
11565       rub(its, k-2, j) = rub(its, k-2, j) - temp63b67
11566       CALL POPCONTROL1B(branch)
11567       IF (branch .EQ. 0) THEN
11568         CALL POPREAL8(ub)
11569         uwb = 0.0
11570       ELSE
11571         CALL POPREAL8(ub)
11572         uwb = ubb
11573       END IF
11574       temp63b62 = 0.5*(2.-fzm(k-1))*uwb
11575       temp63b63 = -(0.5*fzp(k-1)*uwb)
11576       rub(its, k-1, j) = rub(its, k-1, j) + temp63b62
11577       rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp63b62
11578       rub(its, k-2, j) = rub(its, k-2, j) + temp63b63
11579       rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp63b63
11580     END DO
11581     CALL POPINTEGER4(k)
11582     CALL POPINTEGER4(ad_from67)
11583     CALL POPINTEGER4(ad_to67)
11584     DO j=ad_to67,ad_from67,-1
11585       DO k=ktf,kts+1,-1
11586         temp63b60 = -(rdx*tendencyb(its, k, j))
11587         temp63b61 = w(its, k, j)*temp63b60
11588         ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp63b60
11589         w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp63b60
11590         w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp63b60
11591         wb(its, k, j) = wb(its, k, j) + (fzm(k)*(ru(its+1, k, j)-ru(its&
11592 &          , k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))*temp63b60
11593         rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp63b61
11594         rub(its, k, j) = rub(its, k, j) - fzm(k)*temp63b61
11595         rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp63b61
11596         rub(its, k-1, j) = rub(its, k-1, j) - fzp(k)*temp63b61
11597         CALL POPCONTROL1B(branch)
11598         IF (branch .EQ. 0) THEN
11599           CALL POPREAL8(ub)
11600           uwb = 0.0
11601         ELSE
11602           CALL POPREAL8(ub)
11603           uwb = ubb
11604         END IF
11605         temp63b59 = 0.5*uwb
11606         rub(its, k, j) = rub(its, k, j) + fzm(k)*temp63b59
11607         rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp63b59
11608         rub(its, k-1, j) = rub(its, k-1, j) + fzp(k)*temp63b59
11609         rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp63b59
11610       END DO
11611       CALL POPINTEGER4(k)
11612     END DO
11613   END IF
11614   CALL POPINTEGER4(j_start)
11615   CALL POPCONTROL3B(branch)
11616   IF (branch .LT. 4) THEN
11617     IF (branch .LT. 2) THEN
11618       IF (branch .EQ. 0) GOTO 100
11619     ELSE
11620       IF (branch .NE. 2) THEN
11621         CALL POPINTEGER4(ad_from49)
11622         CALL POPINTEGER4(ad_to49)
11623         DO i=ad_to49,ad_from49,-1
11624           mrdy = msftx(i, jde-1)*rdy
11625           temp63b28 = mrdy*0.5*tendencyb(i, k, jde-1)
11626           temp63b29 = (w(i, k, jde-1)+w(i, k, jde-2))*temp63b28
11627           temp63b30 = ((2.-fzm(k-1))*rv(i, k-1, jde-1)-fzp(k-1)*rv(i, k-&
11628 &            2, jde-1))*temp63b28
11629           rvb(i, k-1, jde-1) = rvb(i, k-1, jde-1) + (2.-fzm(k-1))*&
11630 &            temp63b29
11631           rvb(i, k-2, jde-1) = rvb(i, k-2, jde-1) - fzp(k-1)*temp63b29
11632           wb(i, k, jde-1) = wb(i, k, jde-1) + temp63b30
11633           wb(i, k, jde-2) = wb(i, k, jde-2) + temp63b30
11634         END DO
11635         DO k=ktf,kts+1,-1
11636           CALL POPINTEGER4(ad_from48)
11637           CALL POPINTEGER4(ad_to48)
11638           DO i=ad_to48,ad_from48,-1
11639             mrdy = msftx(i, jde-1)*rdy
11640             temp63b25 = mrdy*0.5*tendencyb(i, k, jde-1)
11641             temp63b26 = (w(i, k, jde-1)+w(i, k, jde-2))*temp63b25
11642             temp63b27 = (fzm(k)*rv(i, k, jde-1)+fzp(k)*rv(i, k-1, jde-1)&
11643 &              )*temp63b25
11644             rvb(i, k, jde-1) = rvb(i, k, jde-1) + fzm(k)*temp63b26
11645             rvb(i, k-1, jde-1) = rvb(i, k-1, jde-1) + fzp(k)*temp63b26
11646             wb(i, k, jde-1) = wb(i, k, jde-1) + temp63b27
11647             wb(i, k, jde-2) = wb(i, k, jde-2) + temp63b27
11648           END DO
11649         END DO
11650         CALL POPINTEGER4(k)
11651       END IF
11652       CALL POPCONTROL1B(branch)
11653       IF (branch .EQ. 0) THEN
11654         CALL POPINTEGER4(ad_from47)
11655         CALL POPINTEGER4(ad_to47)
11656         DO i=ad_to47,ad_from47,-1
11657           mrdy = msftx(i, jds)*rdy
11658           temp63b22 = -(mrdy*0.5*tendencyb(i, k, jds))
11659           temp63b23 = (w(i, k, jds+1)+w(i, k, jds))*temp63b22
11660           temp63b24 = ((2.-fzm(k-1))*rv(i, k-1, jds+1)-fzp(k-1)*rv(i, k-&
11661 &            2, jds+1))*temp63b22
11662           rvb(i, k-1, jds+1) = rvb(i, k-1, jds+1) + (2.-fzm(k-1))*&
11663 &            temp63b23
11664           rvb(i, k-2, jds+1) = rvb(i, k-2, jds+1) - fzp(k-1)*temp63b23
11665           wb(i, k, jds+1) = wb(i, k, jds+1) + temp63b24
11666           wb(i, k, jds) = wb(i, k, jds) + temp63b24
11667         END DO
11668         DO k=ktf,kts+1,-1
11669           CALL POPINTEGER4(ad_from46)
11670           CALL POPINTEGER4(ad_to46)
11671           DO i=ad_to46,ad_from46,-1
11672             mrdy = msftx(i, jds)*rdy
11673             temp63b19 = -(mrdy*0.5*tendencyb(i, k, jds))
11674             temp63b20 = (w(i, k, jds+1)+w(i, k, jds))*temp63b19
11675             temp63b21 = (fzm(k)*rv(i, k, jds+1)+fzp(k)*rv(i, k-1, jds+1)&
11676 &              )*temp63b19
11677             rvb(i, k, jds+1) = rvb(i, k, jds+1) + fzm(k)*temp63b20
11678             rvb(i, k-1, jds+1) = rvb(i, k-1, jds+1) + fzp(k)*temp63b20
11679             wb(i, k, jds+1) = wb(i, k, jds+1) + temp63b21
11680             wb(i, k, jds) = wb(i, k, jds) + temp63b21
11681           END DO
11682         END DO
11683         CALL POPINTEGER4(k)
11684       END IF
11685     END IF
11686     CALL POPINTEGER4(ad_from45)
11687     CALL POPINTEGER4(ad_to45)
11688     DO j=ad_to45,ad_from45,-1
11689       CALL POPINTEGER4(ad_from44)
11690       CALL POPINTEGER4(ad_to44)
11691       DO i=ad_to44,ad_from44,-1
11692         mrdy = msftx(i, j)*rdy
11693         temp63b14 = -(mrdy*0.5*tendencyb(i, k, j))
11694         temp63b15 = (w(i, k, j+1)+w(i, k, j))*temp63b14
11695         temp63b16 = ((2.-fzm(k-1))*rv(i, k-1, j+1)-fzp(k-1)*rv(i, k-2, j&
11696 &          +1))*temp63b14
11697         temp63b17 = -((w(i, k, j)+w(i, k, j-1))*temp63b14)
11698         temp63b18 = -(((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, j&
11699 &          ))*temp63b14)
11700         rvb(i, k-1, j+1) = rvb(i, k-1, j+1) + (2.-fzm(k-1))*temp63b15
11701         rvb(i, k-2, j+1) = rvb(i, k-2, j+1) - fzp(k-1)*temp63b15
11702         wb(i, k, j+1) = wb(i, k, j+1) + temp63b16
11703         wb(i, k, j) = wb(i, k, j) + temp63b18 + temp63b16
11704         rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp63b17
11705         rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp63b17
11706         wb(i, k, j-1) = wb(i, k, j-1) + temp63b18
11707       END DO
11708       DO k=ktf,kts+1,-1
11709         CALL POPINTEGER4(ad_from43)
11710         CALL POPINTEGER4(ad_to43)
11711         DO i=ad_to43,ad_from43,-1
11712           mrdy = msftx(i, j)*rdy
11713           temp63b9 = -(mrdy*0.5*tendencyb(i, k, j))
11714           temp63b10 = (w(i, k, j+1)+w(i, k, j))*temp63b9
11715           temp63b11 = (fzm(k)*rv(i, k, j+1)+fzp(k)*rv(i, k-1, j+1))*&
11716 &            temp63b9
11717           temp63b12 = -((w(i, k, j)+w(i, k, j-1))*temp63b9)
11718           temp63b13 = -((fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
11719 &            temp63b9)
11720           rvb(i, k, j+1) = rvb(i, k, j+1) + fzm(k)*temp63b10
11721           rvb(i, k-1, j+1) = rvb(i, k-1, j+1) + fzp(k)*temp63b10
11722           wb(i, k, j+1) = wb(i, k, j+1) + temp63b11
11723           wb(i, k, j) = wb(i, k, j) + temp63b13 + temp63b11
11724           rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp63b12
11725           rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp63b12
11726           wb(i, k, j-1) = wb(i, k, j-1) + temp63b13
11727         END DO
11728       END DO
11729       CALL POPINTEGER4(k)
11730     END DO
11731     CALL POPINTEGER4(ad_from42)
11732     CALL POPINTEGER4(ad_to42)
11733     DO j=ad_to42,ad_from42,-1
11734       CALL POPINTEGER4(ad_from41)
11735       CALL POPINTEGER4(ad_to41)
11736       DO i=ad_to41,ad_from41,-1
11737         mrdx = msftx(i, j)*rdx
11738         temp63b4 = -(mrdx*0.5*tendencyb(i, k, j))
11739         temp63b5 = (w(i+1, k, j)+w(i, k, j))*temp63b4
11740         temp63b6 = ((2.-fzm(k-1))*ru(i+1, k-1, j)-fzp(k-1)*ru(i+1, k-2, &
11741 &          j))*temp63b4
11742         temp63b7 = -((w(i, k, j)+w(i-1, k, j))*temp63b4)
11743         temp63b8 = -(((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2, j)&
11744 &          )*temp63b4)
11745         rub(i+1, k-1, j) = rub(i+1, k-1, j) + (2.-fzm(k-1))*temp63b5
11746         rub(i+1, k-2, j) = rub(i+1, k-2, j) - fzp(k-1)*temp63b5
11747         wb(i+1, k, j) = wb(i+1, k, j) + temp63b6
11748         wb(i, k, j) = wb(i, k, j) + temp63b8 + temp63b6
11749         rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp63b7
11750         rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp63b7
11751         wb(i-1, k, j) = wb(i-1, k, j) + temp63b8
11752       END DO
11753       DO k=ktf,kts+1,-1
11754         CALL POPINTEGER4(ad_from40)
11755         CALL POPINTEGER4(ad_to40)
11756         DO i=ad_to40,ad_from40,-1
11757           mrdx = msftx(i, j)*rdx
11758           temp63b = -(mrdx*0.5*tendencyb(i, k, j))
11759           temp63b0 = (w(i+1, k, j)+w(i, k, j))*temp63b
11760           temp63b1 = (fzm(k)*ru(i+1, k, j)+fzp(k)*ru(i+1, k-1, j))*&
11761 &            temp63b
11762           temp63b2 = -((w(i, k, j)+w(i-1, k, j))*temp63b)
11763           temp63b3 = -((fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*temp63b&
11764 &            )
11765           rub(i+1, k, j) = rub(i+1, k, j) + fzm(k)*temp63b0
11766           rub(i+1, k-1, j) = rub(i+1, k-1, j) + fzp(k)*temp63b0
11767           wb(i+1, k, j) = wb(i+1, k, j) + temp63b1
11768           wb(i, k, j) = wb(i, k, j) + temp63b3 + temp63b1
11769           rub(i, k, j) = rub(i, k, j) + fzm(k)*temp63b2
11770           rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp63b2
11771           wb(i-1, k, j) = wb(i-1, k, j) + temp63b3
11772         END DO
11773       END DO
11774       CALL POPINTEGER4(k)
11775     END DO
11776   ELSE IF (branch .LT. 6) THEN
11777     IF (branch .EQ. 4) THEN
11778       fqyb = 0.0
11779       CALL POPINTEGER4(ad_from39)
11780       CALL POPINTEGER4(ad_to39)
11781       DO j=ad_to39,ad_from39,-1
11782         CALL POPINTEGER4(jp0)
11783         CALL POPINTEGER4(jp1)
11784         CALL POPCONTROL2B(branch)
11785         IF (branch .LT. 2) THEN
11786           IF (branch .EQ. 0) THEN
11787             DO k=ktf,kts,-1
11788               CALL POPINTEGER4(ad_from36)
11789               CALL POPINTEGER4(ad_to36)
11790               DO i=ad_to36,ad_from36,-1
11791                 mrdy = msftx(i, j-1)*rdy
11792                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
11793 &                  , j-1)
11794               END DO
11795             END DO
11796             CALL POPINTEGER4(k)
11797           ELSE
11798             DO k=ktf,kts,-1
11799               CALL POPINTEGER4(ad_from37)
11800               CALL POPINTEGER4(ad_to37)
11801               DO i=ad_to37,ad_from37,-1
11802                 mrdy = msftx(i, j-1)*rdy
11803                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
11804 &                  , j-1)
11805               END DO
11806             END DO
11807             CALL POPINTEGER4(k)
11808           END IF
11809         ELSE IF (branch .EQ. 2) THEN
11810           DO k=ktf+1,kts+1,-1
11811             CALL POPINTEGER4(ad_from38)
11812             CALL POPINTEGER4(ad_to38)
11813             DO i=ad_to38,ad_from38,-1
11814               mrdy = msftx(i, j-1)*rdy
11815               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
11816 &                -1)
11817               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
11818 &                -1)
11819             END DO
11820           END DO
11821           CALL POPINTEGER4(k)
11822         END IF
11823         CALL POPCONTROL2B(branch)
11824         IF (branch .EQ. 0) THEN
11825           CALL POPINTEGER4(ad_from31)
11826           CALL POPINTEGER4(ad_to31)
11827           DO i=ad_to31,ad_from31,-1
11828             temp55b9 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(i&
11829 &              , k, jp1)
11830             temp55b10 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*&
11831 &              rv(i, k-2, j_start))*fqyb(i, k, jp1)
11832             rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + (2.-fzm(k-1))*&
11833 &              temp55b9
11834             rvb(i, k-2, j_start) = rvb(i, k-2, j_start) - fzp(k-1)*&
11835 &              temp55b9
11836             wb(i, k, j_start) = wb(i, k, j_start) + temp55b10
11837             wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp55b10
11838             fqyb(i, k, jp1) = 0.0
11839           END DO
11840           DO k=ktf,kts+1,-1
11841             CALL POPINTEGER4(ad_from30)
11842             CALL POPINTEGER4(ad_to30)
11843             DO i=ad_to30,ad_from30,-1
11844               temp55b7 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(&
11845 &                i, k, jp1)
11846               temp55b8 = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1&
11847 &                , j_start))*fqyb(i, k, jp1)
11848               rvb(i, k, j_start) = rvb(i, k, j_start) + fzm(k)*temp55b7
11849               rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + fzp(k)*&
11850 &                temp55b7
11851               wb(i, k, j_start) = wb(i, k, j_start) + temp55b8
11852               wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp55b8
11853               fqyb(i, k, jp1) = 0.0
11854             END DO
11855           END DO
11856           CALL POPINTEGER4(k)
11857         ELSE IF (branch .EQ. 1) THEN
11858           CALL POPINTEGER4(ad_from33)
11859           CALL POPINTEGER4(ad_to33)
11860           DO i=ad_to33,ad_from33,-1
11861             temp55b13 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
11862             temp55b14 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, &
11863 &              k-2, j))*fqyb(i, k, jp1)
11864             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp55b13
11865             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp55b13
11866             wb(i, k, j) = wb(i, k, j) + temp55b14
11867             wb(i, k, j-1) = wb(i, k, j-1) + temp55b14
11868             fqyb(i, k, jp1) = 0.0
11869           END DO
11870           DO k=ktf,kts+1,-1
11871             CALL POPINTEGER4(ad_from32)
11872             CALL POPINTEGER4(ad_to32)
11873             DO i=ad_to32,ad_from32,-1
11874               temp55b11 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
11875               temp55b12 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
11876 &                fqyb(i, k, jp1)
11877               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp55b11
11878               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp55b11
11879               wb(i, k, j) = wb(i, k, j) + temp55b12
11880               wb(i, k, j-1) = wb(i, k, j-1) + temp55b12
11881               fqyb(i, k, jp1) = 0.0
11882             END DO
11883           END DO
11884           CALL POPINTEGER4(k)
11885         ELSE
11886           CALL POPINTEGER4(ad_from35)
11887           CALL POPINTEGER4(ad_to35)
11888           DO i=ad_to35,ad_from35,-1
11889             temp59 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k&
11890 &              , j-1))
11891             temp62 = SIGN(1., vel)
11892             temp61 = temp62/12.0
11893             temp60 = SIGN(1, time_step)
11894             temp59b = vel*fqyb(i, k, jp1)
11895             temp59b0 = temp59b/12.0
11896             temp59b1 = temp60*temp61*temp59b
11897             velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j&
11898 &              -2))/12.0+temp60*(temp61*temp59))*fqyb(i, k, jp1)
11899             wb(i, k, j) = wb(i, k, j) + 7.*temp59b0 - 3.*temp59b1
11900             wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp59b1 + 7.*temp59b0
11901             wb(i, k, j+1) = wb(i, k, j+1) + temp59b1 - temp59b0
11902             wb(i, k, j-2) = wb(i, k, j-2) - temp59b1 - temp59b0
11903             fqyb(i, k, jp1) = 0.0
11904             CALL POPREAL8(vel)
11905             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
11906             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
11907           END DO
11908           DO k=ktf,kts+1,-1
11909             CALL POPINTEGER4(ad_from34)
11910             CALL POPINTEGER4(ad_to34)
11911             DO i=ad_to34,ad_from34,-1
11912               vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
11913               temp55 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i&
11914 &                , k, j-1))
11915               temp58 = SIGN(1., vel)
11916               temp57 = temp58/12.0
11917               temp56 = SIGN(1, time_step)
11918               temp55b15 = vel*fqyb(i, k, jp1)
11919               temp55b16 = temp55b15/12.0
11920               temp55b17 = temp56*temp57*temp55b15
11921               velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k&
11922 &                , j-2))/12.0+temp56*(temp57*temp55))*fqyb(i, k, jp1)
11923               wb(i, k, j) = wb(i, k, j) + 7.*temp55b16 - 3.*temp55b17
11924               wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp55b17 + 7.*&
11925 &                temp55b16
11926               wb(i, k, j+1) = wb(i, k, j+1) + temp55b17 - temp55b16
11927               wb(i, k, j-2) = wb(i, k, j-2) - temp55b17 - temp55b16
11928               fqyb(i, k, jp1) = 0.0
11929               CALL POPREAL8(vel)
11930               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
11931               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
11932             END DO
11933           END DO
11934           CALL POPINTEGER4(k)
11935         END IF
11936       END DO
11937       CALL POPCONTROL1B(branch)
11938       IF (branch .EQ. 0) THEN
11939         CALL POPINTEGER4(i_end)
11940       ELSE
11941         CALL POPINTEGER4(i_end)
11942       END IF
11943       CALL POPINTEGER4(i_start)
11944       fqxb = 0.0
11945       CALL POPINTEGER4(ad_from29)
11946       CALL POPINTEGER4(ad_to29)
11947       DO j=ad_to29,ad_from29,-1
11948         DO k=ktf+1,kts+1,-1
11949           CALL POPINTEGER4(ad_from28)
11950           CALL POPINTEGER4(ad_to28)
11951           DO i=ad_to28,ad_from28,-1
11952             mrdx = msftx(i, j)*rdx
11953             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
11954             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
11955           END DO
11956         END DO
11957         CALL POPINTEGER4(k)
11958         CALL POPCONTROL1B(branch)
11959         IF (branch .NE. 0) THEN
11960           k = ktf + 1
11961           temp55b5 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+1&
11962 &            , k)
11963           temp55b6 = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(&
11964 &            i_end+1, k-2, j))*fqxb(i_end+1, k)
11965           rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + (2.-fzm(k-1))*&
11966 &            temp55b5
11967           rub(i_end+1, k-2, j) = rub(i_end+1, k-2, j) - fzp(k-1)*&
11968 &            temp55b5
11969           wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp55b6
11970           wb(i_end, k, j) = wb(i_end, k, j) + temp55b6
11971           fqxb(i_end+1, k) = 0.0
11972           DO k=ktf,kts+1,-1
11973             temp55b3 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+&
11974 &              1, k)
11975             temp55b4 = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, &
11976 &              k-1, j))*fqxb(i_end+1, k)
11977             rub(i_end+1, k, j) = rub(i_end+1, k, j) + fzm(k)*temp55b3
11978             rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + fzp(k)*&
11979 &              temp55b3
11980             wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp55b4
11981             wb(i_end, k, j) = wb(i_end, k, j) + temp55b4
11982             fqxb(i_end+1, k) = 0.0
11983           END DO
11984           CALL POPINTEGER4(k)
11985         END IF
11986         CALL POPCONTROL1B(branch)
11987         IF (branch .EQ. 0) THEN
11988           k = ktf + 1
11989           temp55b1 = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(&
11990 &            i_start, k)
11991           temp55b2 = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(&
11992 &            i_start, k-2, j))*fqxb(i_start, k)
11993           rub(i_start, k-1, j) = rub(i_start, k-1, j) + (2.-fzm(k-1))*&
11994 &            temp55b1
11995           rub(i_start, k-2, j) = rub(i_start, k-2, j) - fzp(k-1)*&
11996 &            temp55b1
11997           wb(i_start, k, j) = wb(i_start, k, j) + temp55b2
11998           wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp55b2
11999           fqxb(i_start, k) = 0.0
12000           DO k=ktf,kts+1,-1
12001             temp55b = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(&
12002 &              i_start, k)
12003             temp55b0 = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(i_start, &
12004 &              k-1, j))*fqxb(i_start, k)
12005             rub(i_start, k, j) = rub(i_start, k, j) + fzm(k)*temp55b
12006             rub(i_start, k-1, j) = rub(i_start, k-1, j) + fzp(k)*temp55b
12007             wb(i_start, k, j) = wb(i_start, k, j) + temp55b0
12008             wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp55b0
12009             fqxb(i_start, k) = 0.0
12010           END DO
12011           CALL POPINTEGER4(k)
12012         END IF
12013         k = ktf + 1
12014         DO i=i_end_f,i_start_f,-1
12015           temp51 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1, k&
12016 &            , j))
12017           temp54 = SIGN(1., vel)
12018           temp53 = temp54/12.0
12019           temp52 = SIGN(1, time_step)
12020           temp51b = vel*fqxb(i, k)
12021           temp51b0 = temp51b/12.0
12022           temp51b1 = temp52*temp53*temp51b
12023           velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j&
12024 &            ))/12.0+temp52*(temp53*temp51))*fqxb(i, k)
12025           wb(i, k, j) = wb(i, k, j) + 7.*temp51b0 - 3.*temp51b1
12026           wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp51b1 + 7.*temp51b0
12027           wb(i+1, k, j) = wb(i+1, k, j) + temp51b1 - temp51b0
12028           wb(i-2, k, j) = wb(i-2, k, j) - temp51b1 - temp51b0
12029           fqxb(i, k) = 0.0
12030           CALL POPREAL8(vel)
12031           rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12032           rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12033         END DO
12034         DO k=ktf,kts+1,-1
12035           DO i=i_end_f,i_start_f,-1
12036             vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12037             temp47 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1&
12038 &              , k, j))
12039             temp50 = SIGN(1., vel)
12040             temp49 = temp50/12.0
12041             temp48 = SIGN(1, time_step)
12042             temp47b19 = vel*fqxb(i, k)
12043             temp47b20 = temp47b19/12.0
12044             temp47b21 = temp48*temp49*temp47b19
12045             velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
12046 &              , j))/12.0+temp48*(temp49*temp47))*fqxb(i, k)
12047             wb(i, k, j) = wb(i, k, j) + 7.*temp47b20 - 3.*temp47b21
12048             wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp47b21 + 7.*temp47b20
12049             wb(i+1, k, j) = wb(i+1, k, j) + temp47b21 - temp47b20
12050             wb(i-2, k, j) = wb(i-2, k, j) - temp47b21 - temp47b20
12051             fqxb(i, k) = 0.0
12052             CALL POPREAL8(vel)
12053             rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12054             rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12055           END DO
12056         END DO
12057       END DO
12058     ELSE
12059       fqyb = 0.0
12060       CALL POPINTEGER4(ad_from27)
12061       CALL POPINTEGER4(ad_to27)
12062       DO j=ad_to27,ad_from27,-1
12063         CALL POPINTEGER4(jp0)
12064         CALL POPINTEGER4(jp1)
12065         CALL POPCONTROL2B(branch)
12066         IF (branch .LT. 2) THEN
12067           IF (branch .EQ. 0) THEN
12068             DO k=ktf,kts,-1
12069               CALL POPINTEGER4(ad_from24)
12070               CALL POPINTEGER4(ad_to24)
12071               DO i=ad_to24,ad_from24,-1
12072                 mrdy = msftx(i, j-1)*rdy
12073                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
12074 &                  , j-1)
12075               END DO
12076             END DO
12077             CALL POPINTEGER4(k)
12078           ELSE
12079             DO k=ktf,kts,-1
12080               CALL POPINTEGER4(ad_from25)
12081               CALL POPINTEGER4(ad_to25)
12082               DO i=ad_to25,ad_from25,-1
12083                 mrdy = msftx(i, j-1)*rdy
12084                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
12085 &                  , j-1)
12086               END DO
12087             END DO
12088             CALL POPINTEGER4(k)
12089           END IF
12090         ELSE IF (branch .EQ. 2) THEN
12091           DO k=ktf+1,kts+1,-1
12092             CALL POPINTEGER4(ad_from26)
12093             CALL POPINTEGER4(ad_to26)
12094             DO i=ad_to26,ad_from26,-1
12095               mrdy = msftx(i, j-1)*rdy
12096               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
12097 &                -1)
12098               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
12099 &                -1)
12100             END DO
12101           END DO
12102           CALL POPINTEGER4(k)
12103         END IF
12104         CALL POPCONTROL2B(branch)
12105         IF (branch .EQ. 0) THEN
12106           CALL POPINTEGER4(ad_from19)
12107           CALL POPINTEGER4(ad_to19)
12108           DO i=ad_to19,ad_from19,-1
12109             temp47b11 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(i&
12110 &              , k, jp1)
12111             temp47b12 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*&
12112 &              rv(i, k-2, j_start))*fqyb(i, k, jp1)
12113             rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + (2.-fzm(k-1))*&
12114 &              temp47b11
12115             rvb(i, k-2, j_start) = rvb(i, k-2, j_start) - fzp(k-1)*&
12116 &              temp47b11
12117             wb(i, k, j_start) = wb(i, k, j_start) + temp47b12
12118             wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp47b12
12119             fqyb(i, k, jp1) = 0.0
12120           END DO
12121           DO k=ktf,kts+1,-1
12122             CALL POPINTEGER4(ad_from18)
12123             CALL POPINTEGER4(ad_to18)
12124             DO i=ad_to18,ad_from18,-1
12125               temp47b9 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(&
12126 &                i, k, jp1)
12127               temp47b10 = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1&
12128 &                , j_start))*fqyb(i, k, jp1)
12129               rvb(i, k, j_start) = rvb(i, k, j_start) + fzm(k)*temp47b9
12130               rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + fzp(k)*&
12131 &                temp47b9
12132               wb(i, k, j_start) = wb(i, k, j_start) + temp47b10
12133               wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp47b10
12134               fqyb(i, k, jp1) = 0.0
12135             END DO
12136           END DO
12137           CALL POPINTEGER4(k)
12138         ELSE IF (branch .EQ. 1) THEN
12139           CALL POPINTEGER4(ad_from21)
12140           CALL POPINTEGER4(ad_to21)
12141           DO i=ad_to21,ad_from21,-1
12142             temp47b15 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
12143             temp47b16 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, &
12144 &              k-2, j))*fqyb(i, k, jp1)
12145             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp47b15
12146             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp47b15
12147             wb(i, k, j) = wb(i, k, j) + temp47b16
12148             wb(i, k, j-1) = wb(i, k, j-1) + temp47b16
12149             fqyb(i, k, jp1) = 0.0
12150           END DO
12151           DO k=ktf,kts+1,-1
12152             CALL POPINTEGER4(ad_from20)
12153             CALL POPINTEGER4(ad_to20)
12154             DO i=ad_to20,ad_from20,-1
12155               temp47b13 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
12156               temp47b14 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
12157 &                fqyb(i, k, jp1)
12158               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp47b13
12159               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp47b13
12160               wb(i, k, j) = wb(i, k, j) + temp47b14
12161               wb(i, k, j-1) = wb(i, k, j-1) + temp47b14
12162               fqyb(i, k, jp1) = 0.0
12163             END DO
12164           END DO
12165           CALL POPINTEGER4(k)
12166         ELSE
12167           CALL POPINTEGER4(ad_from23)
12168           CALL POPINTEGER4(ad_to23)
12169           DO i=ad_to23,ad_from23,-1
12170             temp47b18 = vel*fqyb(i, k, jp1)/12.0
12171             velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-&
12172 &              2))*fqyb(i, k, jp1)/12.0
12173             wb(i, k, j) = wb(i, k, j) + 7.*temp47b18
12174             wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp47b18
12175             wb(i, k, j+1) = wb(i, k, j+1) - temp47b18
12176             wb(i, k, j-2) = wb(i, k, j-2) - temp47b18
12177             fqyb(i, k, jp1) = 0.0
12178             CALL POPREAL8(vel)
12179             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
12180             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
12181           END DO
12182           DO k=ktf,kts+1,-1
12183             CALL POPINTEGER4(ad_from22)
12184             CALL POPINTEGER4(ad_to22)
12185             DO i=ad_to22,ad_from22,-1
12186               vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
12187               temp47b17 = vel*fqyb(i, k, jp1)/12.0
12188               velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, &
12189 &                j-2))*fqyb(i, k, jp1)/12.0
12190               wb(i, k, j) = wb(i, k, j) + 7.*temp47b17
12191               wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp47b17
12192               wb(i, k, j+1) = wb(i, k, j+1) - temp47b17
12193               wb(i, k, j-2) = wb(i, k, j-2) - temp47b17
12194               fqyb(i, k, jp1) = 0.0
12195               CALL POPREAL8(vel)
12196               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
12197               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
12198             END DO
12199           END DO
12200           CALL POPINTEGER4(k)
12201         END IF
12202       END DO
12203       CALL POPCONTROL1B(branch)
12204       IF (branch .EQ. 0) THEN
12205         CALL POPINTEGER4(i_end)
12206       ELSE
12207         CALL POPINTEGER4(i_end)
12208       END IF
12209       CALL POPINTEGER4(i_start)
12210       fqxb = 0.0
12211       CALL POPINTEGER4(ad_from17)
12212       CALL POPINTEGER4(ad_to17)
12213       DO j=ad_to17,ad_from17,-1
12214         DO k=ktf+1,kts+1,-1
12215           CALL POPINTEGER4(ad_from16)
12216           CALL POPINTEGER4(ad_to16)
12217           DO i=ad_to16,ad_from16,-1
12218             mrdx = msftx(i, j)*rdx
12219             fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
12220             fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
12221           END DO
12222         END DO
12223         CALL POPINTEGER4(k)
12224         CALL POPCONTROL1B(branch)
12225         IF (branch .NE. 0) THEN
12226           k = ktf + 1
12227           temp47b7 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+1&
12228 &            , k)
12229           temp47b8 = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(&
12230 &            i_end+1, k-2, j))*fqxb(i_end+1, k)
12231           rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + (2.-fzm(k-1))*&
12232 &            temp47b7
12233           rub(i_end+1, k-2, j) = rub(i_end+1, k-2, j) - fzp(k-1)*&
12234 &            temp47b7
12235           wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp47b8
12236           wb(i_end, k, j) = wb(i_end, k, j) + temp47b8
12237           fqxb(i_end+1, k) = 0.0
12238           DO k=ktf,kts+1,-1
12239             temp47b5 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+&
12240 &              1, k)
12241             temp47b6 = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, &
12242 &              k-1, j))*fqxb(i_end+1, k)
12243             rub(i_end+1, k, j) = rub(i_end+1, k, j) + fzm(k)*temp47b5
12244             rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + fzp(k)*&
12245 &              temp47b5
12246             wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp47b6
12247             wb(i_end, k, j) = wb(i_end, k, j) + temp47b6
12248             fqxb(i_end+1, k) = 0.0
12249           END DO
12250           CALL POPINTEGER4(k)
12251         END IF
12252         CALL POPCONTROL1B(branch)
12253         IF (branch .EQ. 0) THEN
12254           k = ktf + 1
12255           temp47b3 = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(&
12256 &            i_start, k)
12257           temp47b4 = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(&
12258 &            i_start, k-2, j))*fqxb(i_start, k)
12259           rub(i_start, k-1, j) = rub(i_start, k-1, j) + (2.-fzm(k-1))*&
12260 &            temp47b3
12261           rub(i_start, k-2, j) = rub(i_start, k-2, j) - fzp(k-1)*&
12262 &            temp47b3
12263           wb(i_start, k, j) = wb(i_start, k, j) + temp47b4
12264           wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp47b4
12265           fqxb(i_start, k) = 0.0
12266           DO k=ktf,kts+1,-1
12267             temp47b1 = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(&
12268 &              i_start, k)
12269             temp47b2 = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(i_start, &
12270 &              k-1, j))*fqxb(i_start, k)
12271             rub(i_start, k, j) = rub(i_start, k, j) + fzm(k)*temp47b1
12272             rub(i_start, k-1, j) = rub(i_start, k-1, j) + fzp(k)*&
12273 &              temp47b1
12274             wb(i_start, k, j) = wb(i_start, k, j) + temp47b2
12275             wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp47b2
12276             fqxb(i_start, k) = 0.0
12277           END DO
12278           CALL POPINTEGER4(k)
12279         END IF
12280         k = ktf + 1
12281         DO i=i_end_f,i_start_f,-1
12282           temp47b0 = vel*fqxb(i, k)/12.0
12283           velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j)&
12284 &            )*fqxb(i, k)/12.0
12285           wb(i, k, j) = wb(i, k, j) + 7.*temp47b0
12286           wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp47b0
12287           wb(i+1, k, j) = wb(i+1, k, j) - temp47b0
12288           wb(i-2, k, j) = wb(i-2, k, j) - temp47b0
12289           fqxb(i, k) = 0.0
12290           CALL POPREAL8(vel)
12291           rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12292           rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12293         END DO
12294         DO k=ktf,kts+1,-1
12295           DO i=i_end_f,i_start_f,-1
12296             vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12297             temp47b = vel*fqxb(i, k)/12.0
12298             velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, &
12299 &              j))*fqxb(i, k)/12.0
12300             wb(i, k, j) = wb(i, k, j) + 7.*temp47b
12301             wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp47b
12302             wb(i+1, k, j) = wb(i+1, k, j) - temp47b
12303             wb(i-2, k, j) = wb(i-2, k, j) - temp47b
12304             fqxb(i, k) = 0.0
12305             CALL POPREAL8(vel)
12306             rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12307             rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12308           END DO
12309         END DO
12310       END DO
12311     END IF
12312   ELSE IF (branch .EQ. 6) THEN
12313     fqxb = 0.0
12314     CALL POPINTEGER4(ad_from15)
12315     CALL POPINTEGER4(ad_to15)
12316     DO j=ad_to15,ad_from15,-1
12317       DO k=ktf+1,kts+1,-1
12318         CALL POPINTEGER4(ad_from14)
12319         CALL POPINTEGER4(ad_to14)
12320         DO i=ad_to14,ad_from14,-1
12321           mrdx = msftx(i, j)*rdx
12322           fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
12323           fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
12324         END DO
12325       END DO
12326       CALL POPINTEGER4(k)
12327       CALL POPCONTROL1B(branch)
12328       IF (branch .NE. 0) THEN
12329         CALL POPINTEGER4(ad_to13)
12330         DO i=ad_to13,i_end_f+1,-1
12331           CALL POPCONTROL1B(branch)
12332           IF (branch .NE. 0) THEN
12333             k = ktf + 1
12334             temp43 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1&
12335 &              , k, j))
12336             temp46 = SIGN(1., vel)
12337             temp45 = temp46/12.0
12338             temp44 = SIGN(1, time_step)
12339             temp43b = vel*fqxb(i, k)
12340             temp43b0 = temp43b/12.0
12341             temp43b1 = temp44*temp45*temp43b
12342             velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
12343 &              , j))/12.0+temp44*(temp45*temp43))*fqxb(i, k)
12344             wb(i, k, j) = wb(i, k, j) + 7.*temp43b0 - 3.*temp43b1
12345             wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp43b1 + 7.*temp43b0
12346             wb(i+1, k, j) = wb(i+1, k, j) + temp43b1 - temp43b0
12347             wb(i-2, k, j) = wb(i-2, k, j) - temp43b1 - temp43b0
12348             fqxb(i, k) = 0.0
12349             CALL POPREAL8(vel)
12350             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12351             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12352             DO k=ktf,kts+1,-1
12353               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12354               temp39 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-&
12355 &                1, k, j))
12356               temp42 = SIGN(1., vel)
12357               temp41 = temp42/12.0
12358               temp40 = SIGN(1, time_step)
12359               temp39b3 = vel*fqxb(i, k)
12360               temp39b4 = temp39b3/12.0
12361               temp39b5 = temp40*temp41*temp39b3
12362               velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, &
12363 &                k, j))/12.0+temp40*(temp41*temp39))*fqxb(i, k)
12364               wb(i, k, j) = wb(i, k, j) + 7.*temp39b4 - 3.*temp39b5
12365               wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp39b5 + 7.*temp39b4
12366               wb(i+1, k, j) = wb(i+1, k, j) + temp39b5 - temp39b4
12367               wb(i-2, k, j) = wb(i-2, k, j) - temp39b5 - temp39b4
12368               fqxb(i, k) = 0.0
12369               CALL POPREAL8(vel)
12370               rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12371               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12372             END DO
12373             CALL POPINTEGER4(k)
12374           END IF
12375           CALL POPCONTROL1B(branch)
12376           IF (branch .EQ. 0) THEN
12377             k = ktf + 1
12378             temp39b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12379             temp39b2 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k&
12380 &              -2, j))*fqxb(i, k)
12381             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp39b1
12382             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp39b1
12383             wb(i, k, j) = wb(i, k, j) + temp39b2
12384             wb(i-1, k, j) = wb(i-1, k, j) + temp39b2
12385             fqxb(i, k) = 0.0
12386             DO k=ktf,kts+1,-1
12387               temp39b = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12388               temp39b0 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
12389 &                fqxb(i, k)
12390               rub(i, k, j) = rub(i, k, j) + fzm(k)*temp39b
12391               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp39b
12392               wb(i, k, j) = wb(i, k, j) + temp39b0
12393               wb(i-1, k, j) = wb(i-1, k, j) + temp39b0
12394               fqxb(i, k) = 0.0
12395             END DO
12396             CALL POPINTEGER4(k)
12397           END IF
12398         END DO
12399       END IF
12400       CALL POPCONTROL1B(branch)
12401       IF (branch .EQ. 0) THEN
12402         CALL POPINTEGER4(ad_from13)
12403         DO i=i_start_f-1,ad_from13,-1
12404           CALL POPCONTROL1B(branch)
12405           IF (branch .NE. 0) THEN
12406             k = ktf + 1
12407             temp35 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1&
12408 &              , k, j))
12409             temp38 = SIGN(1., vel)
12410             temp37 = temp38/12.0
12411             temp36 = SIGN(1, time_step)
12412             temp35b = vel*fqxb(i, k)
12413             temp35b0 = temp35b/12.0
12414             temp35b1 = temp36*temp37*temp35b
12415             velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
12416 &              , j))/12.0+temp36*(temp37*temp35))*fqxb(i, k)
12417             wb(i, k, j) = wb(i, k, j) + 7.*temp35b0 - 3.*temp35b1
12418             wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp35b1 + 7.*temp35b0
12419             wb(i+1, k, j) = wb(i+1, k, j) + temp35b1 - temp35b0
12420             wb(i-2, k, j) = wb(i-2, k, j) - temp35b1 - temp35b0
12421             fqxb(i, k) = 0.0
12422             CALL POPREAL8(vel)
12423             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12424             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12425             DO k=ktf,kts+1,-1
12426               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12427               temp31 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-&
12428 &                1, k, j))
12429               temp34 = SIGN(1., vel)
12430               temp33 = temp34/12.0
12431               temp32 = SIGN(1, time_step)
12432               temp31b3 = vel*fqxb(i, k)
12433               temp31b4 = temp31b3/12.0
12434               temp31b5 = temp32*temp33*temp31b3
12435               velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, &
12436 &                k, j))/12.0+temp32*(temp33*temp31))*fqxb(i, k)
12437               wb(i, k, j) = wb(i, k, j) + 7.*temp31b4 - 3.*temp31b5
12438               wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp31b5 + 7.*temp31b4
12439               wb(i+1, k, j) = wb(i+1, k, j) + temp31b5 - temp31b4
12440               wb(i-2, k, j) = wb(i-2, k, j) - temp31b5 - temp31b4
12441               fqxb(i, k) = 0.0
12442               CALL POPREAL8(vel)
12443               rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12444               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12445             END DO
12446             CALL POPINTEGER4(k)
12447           END IF
12448           CALL POPCONTROL1B(branch)
12449           IF (branch .EQ. 0) THEN
12450             k = ktf + 1
12451             temp31b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12452             temp31b2 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k&
12453 &              -2, j))*fqxb(i, k)
12454             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp31b1
12455             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp31b1
12456             wb(i, k, j) = wb(i, k, j) + temp31b2
12457             wb(i-1, k, j) = wb(i-1, k, j) + temp31b2
12458             fqxb(i, k) = 0.0
12459             DO k=ktf,kts+1,-1
12460               temp31b = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12461               temp31b0 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
12462 &                fqxb(i, k)
12463               rub(i, k, j) = rub(i, k, j) + fzm(k)*temp31b
12464               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp31b
12465               wb(i, k, j) = wb(i, k, j) + temp31b0
12466               wb(i-1, k, j) = wb(i-1, k, j) + temp31b0
12467               fqxb(i, k) = 0.0
12468             END DO
12469             CALL POPINTEGER4(k)
12470           END IF
12471         END DO
12472       END IF
12473       k = ktf + 1
12474       DO i=i_end_f,i_start_f,-1
12475         temp27 = w(i+2, k, j) - w(i-3, k, j) + 10.*(w(i, k, j)-w(i-1, k&
12476 &          , j)) - 5.*(w(i+1, k, j)-w(i-2, k, j))
12477         temp30 = SIGN(1., vel)
12478         temp29 = temp30/60.0
12479         temp28 = SIGN(1, time_step)
12480         temp27b = vel*fqxb(i, k)
12481         temp27b0 = temp27b/60.0
12482         temp27b1 = -(temp28*temp29*temp27b)
12483         velb = ((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2, k&
12484 &          , j))+w(i+2, k, j)+w(i-3, k, j))/60.0-temp28*(temp29*temp27))*&
12485 &          fqxb(i, k)
12486         wb(i, k, j) = wb(i, k, j) + 10.*temp27b1 + 37.*temp27b0
12487         wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp27b0 - 10.*temp27b1
12488         wb(i+1, k, j) = wb(i+1, k, j) - 5.*temp27b1 - 8.*temp27b0
12489         wb(i-2, k, j) = wb(i-2, k, j) + 5.*temp27b1 - 8.*temp27b0
12490         wb(i+2, k, j) = wb(i+2, k, j) + temp27b1 + temp27b0
12491         wb(i-3, k, j) = wb(i-3, k, j) + temp27b0 - temp27b1
12492         fqxb(i, k) = 0.0
12493         CALL POPREAL8(vel)
12494         rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12495         rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12496       END DO
12497       DO k=ktf,kts+1,-1
12498         DO i=i_end_f,i_start_f,-1
12499           vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12500           temp23 = w(i+2, k, j) - w(i-3, k, j) + 10.*(w(i, k, j)-w(i-1, &
12501 &            k, j)) - 5.*(w(i+1, k, j)-w(i-2, k, j))
12502           temp26 = SIGN(1., vel)
12503           temp25 = temp26/60.0
12504           temp24 = SIGN(1, time_step)
12505           temp23b = vel*fqxb(i, k)
12506           temp23b0 = temp23b/60.0
12507           temp23b1 = -(temp24*temp25*temp23b)
12508           velb = ((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2&
12509 &            , k, j))+w(i+2, k, j)+w(i-3, k, j))/60.0-temp24*(temp25*&
12510 &            temp23))*fqxb(i, k)
12511           wb(i, k, j) = wb(i, k, j) + 10.*temp23b1 + 37.*temp23b0
12512           wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp23b0 - 10.*temp23b1
12513           wb(i+1, k, j) = wb(i+1, k, j) - 5.*temp23b1 - 8.*temp23b0
12514           wb(i-2, k, j) = wb(i-2, k, j) + 5.*temp23b1 - 8.*temp23b0
12515           wb(i+2, k, j) = wb(i+2, k, j) + temp23b1 + temp23b0
12516           wb(i-3, k, j) = wb(i-3, k, j) + temp23b0 - temp23b1
12517           fqxb(i, k) = 0.0
12518           CALL POPREAL8(vel)
12519           rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12520           rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12521         END DO
12522       END DO
12523       CALL POPINTEGER4(k)
12524     END DO
12525     fqyb = 0.0
12526     CALL POPINTEGER4(ad_from12)
12527     CALL POPINTEGER4(ad_to12)
12528     DO j=ad_to12,ad_from12,-1
12529       CALL POPINTEGER4(jp0)
12530       CALL POPINTEGER4(jp1)
12531       CALL POPCONTROL2B(branch)
12532       IF (branch .LT. 2) THEN
12533         IF (branch .EQ. 0) THEN
12534           DO k=ktf,kts,-1
12535             CALL POPINTEGER4(ad_from9)
12536             CALL POPINTEGER4(ad_to9)
12537             DO i=ad_to9,ad_from9,-1
12538               mrdy = msftx(i, j-1)*rdy
12539               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
12540 &                -1)
12541             END DO
12542           END DO
12543           CALL POPINTEGER4(k)
12544         ELSE
12545           DO k=ktf,kts,-1
12546             CALL POPINTEGER4(ad_from10)
12547             CALL POPINTEGER4(ad_to10)
12548             DO i=ad_to10,ad_from10,-1
12549               mrdy = msftx(i, j-1)*rdy
12550               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
12551 &                -1)
12552             END DO
12553           END DO
12554           CALL POPINTEGER4(k)
12555         END IF
12556       ELSE IF (branch .EQ. 2) THEN
12557         DO k=ktf+1,kts+1,-1
12558           CALL POPINTEGER4(ad_from11)
12559           CALL POPINTEGER4(ad_to11)
12560           DO i=ad_to11,ad_from11,-1
12561             mrdy = msftx(i, j-1)*rdy
12562             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
12563 &              )
12564             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
12565 &              )
12566           END DO
12567         END DO
12568         CALL POPINTEGER4(k)
12569       END IF
12570       CALL POPCONTROL3B(branch)
12571       IF (branch .LT. 3) THEN
12572         IF (branch .EQ. 0) THEN
12573           CALL POPINTEGER4(ad_from0)
12574           CALL POPINTEGER4(ad_to0)
12575           DO i=ad_to0,ad_from0,-1
12576             temp3 = w(i, k, j+2) - w(i, k, j-3) + 10.*(w(i, k, j)-w(i, k&
12577 &              , j-1)) - 5.*(w(i, k, j+1)-w(i, k, j-2))
12578             temp6 = SIGN(1., vel)
12579             temp5 = temp6/60.0
12580             temp4 = SIGN(1, time_step)
12581             temp3b = vel*fqyb(i, k, jp1)
12582             temp3b0 = temp3b/60.0
12583             temp3b1 = -(temp4*temp5*temp3b)
12584             velb = ((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(i&
12585 &              , k, j-2))+w(i, k, j+2)+w(i, k, j-3))/60.0-temp4*(temp5*&
12586 &              temp3))*fqyb(i, k, jp1)
12587             wb(i, k, j) = wb(i, k, j) + 10.*temp3b1 + 37.*temp3b0
12588             wb(i, k, j-1) = wb(i, k, j-1) + 37.*temp3b0 - 10.*temp3b1
12589             wb(i, k, j+1) = wb(i, k, j+1) - 5.*temp3b1 - 8.*temp3b0
12590             wb(i, k, j-2) = wb(i, k, j-2) + 5.*temp3b1 - 8.*temp3b0
12591             wb(i, k, j+2) = wb(i, k, j+2) + temp3b1 + temp3b0
12592             wb(i, k, j-3) = wb(i, k, j-3) + temp3b0 - temp3b1
12593             fqyb(i, k, jp1) = 0.0
12594             CALL POPREAL8(vel)
12595             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
12596             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
12597           END DO
12598           DO k=ktf,kts+1,-1
12599             CALL POPINTEGER4(ad_from)
12600             CALL POPINTEGER4(ad_to)
12601             DO i=ad_to,ad_from,-1
12602               vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
12603               temp = w(i, k, j+2) - w(i, k, j-3) + 10.*(w(i, k, j)-w(i, &
12604 &                k, j-1)) - 5.*(w(i, k, j+1)-w(i, k, j-2))
12605               temp2 = SIGN(1., vel)
12606               temp1 = temp2/60.0
12607               temp0 = SIGN(1, time_step)
12608               tempb = vel*fqyb(i, k, jp1)
12609               tempb0 = tempb/60.0
12610               tempb1 = -(temp0*temp1*tempb)
12611               velb = ((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(&
12612 &                i, k, j-2))+w(i, k, j+2)+w(i, k, j-3))/60.0-temp0*(temp1&
12613 &                *temp))*fqyb(i, k, jp1)
12614               wb(i, k, j) = wb(i, k, j) + 10.*tempb1 + 37.*tempb0
12615               wb(i, k, j-1) = wb(i, k, j-1) + 37.*tempb0 - 10.*tempb1
12616               wb(i, k, j+1) = wb(i, k, j+1) - 5.*tempb1 - 8.*tempb0
12617               wb(i, k, j-2) = wb(i, k, j-2) + 5.*tempb1 - 8.*tempb0
12618               wb(i, k, j+2) = wb(i, k, j+2) + tempb1 + tempb0
12619               wb(i, k, j-3) = wb(i, k, j-3) + tempb0 - tempb1
12620               fqyb(i, k, jp1) = 0.0
12621               CALL POPREAL8(vel)
12622               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
12623               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
12624             END DO
12625           END DO
12626           CALL POPINTEGER4(k)
12627         ELSE IF (branch .EQ. 1) THEN
12628           CALL POPINTEGER4(ad_from2)
12629           CALL POPINTEGER4(ad_to2)
12630           DO i=ad_to2,ad_from2,-1
12631             temp7b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
12632             temp7b2 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-&
12633 &              2, j))*fqyb(i, k, jp1)
12634             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp7b1
12635             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp7b1
12636             wb(i, k, j) = wb(i, k, j) + temp7b2
12637             wb(i, k, j-1) = wb(i, k, j-1) + temp7b2
12638             fqyb(i, k, jp1) = 0.0
12639           END DO
12640           DO k=ktf,kts+1,-1
12641             CALL POPINTEGER4(ad_from1)
12642             CALL POPINTEGER4(ad_to1)
12643             DO i=ad_to1,ad_from1,-1
12644               temp7b = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
12645               temp7b0 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
12646 &                fqyb(i, k, jp1)
12647               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp7b
12648               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp7b
12649               wb(i, k, j) = wb(i, k, j) + temp7b0
12650               wb(i, k, j-1) = wb(i, k, j-1) + temp7b0
12651               fqyb(i, k, jp1) = 0.0
12652             END DO
12653           END DO
12654           CALL POPINTEGER4(k)
12655         ELSE
12656           CALL POPINTEGER4(ad_from4)
12657           CALL POPINTEGER4(ad_to4)
12658           DO i=ad_to4,ad_from4,-1
12659             temp11 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k&
12660 &              , j-1))
12661             temp14 = SIGN(1., vel)
12662             temp13 = temp14/12.0
12663             temp12 = SIGN(1, time_step)
12664             temp11b = vel*fqyb(i, k, jp1)
12665             temp11b0 = temp11b/12.0
12666             temp11b1 = temp12*temp13*temp11b
12667             velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j&
12668 &              -2))/12.0+temp12*(temp13*temp11))*fqyb(i, k, jp1)
12669             wb(i, k, j) = wb(i, k, j) + 7.*temp11b0 - 3.*temp11b1
12670             wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp11b1 + 7.*temp11b0
12671             wb(i, k, j+1) = wb(i, k, j+1) + temp11b1 - temp11b0
12672             wb(i, k, j-2) = wb(i, k, j-2) - temp11b1 - temp11b0
12673             fqyb(i, k, jp1) = 0.0
12674             CALL POPREAL8(vel)
12675             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
12676             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
12677           END DO
12678           DO k=ktf,kts+1,-1
12679             CALL POPINTEGER4(ad_from3)
12680             CALL POPINTEGER4(ad_to3)
12681             DO i=ad_to3,ad_from3,-1
12682               vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
12683               temp7 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, &
12684 &                k, j-1))
12685               temp10 = SIGN(1., vel)
12686               temp9 = temp10/12.0
12687               temp8 = SIGN(1, time_step)
12688               temp7b3 = vel*fqyb(i, k, jp1)
12689               temp7b4 = temp7b3/12.0
12690               temp7b5 = temp8*temp9*temp7b3
12691               velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k&
12692 &                , j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, jp1)
12693               wb(i, k, j) = wb(i, k, j) + 7.*temp7b4 - 3.*temp7b5
12694               wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp7b5 + 7.*temp7b4
12695               wb(i, k, j+1) = wb(i, k, j+1) + temp7b5 - temp7b4
12696               wb(i, k, j-2) = wb(i, k, j-2) - temp7b5 - temp7b4
12697               fqyb(i, k, jp1) = 0.0
12698               CALL POPREAL8(vel)
12699               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
12700               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
12701             END DO
12702           END DO
12703           CALL POPINTEGER4(k)
12704         END IF
12705       ELSE IF (branch .EQ. 3) THEN
12706         CALL POPINTEGER4(ad_from6)
12707         CALL POPINTEGER4(ad_to6)
12708         DO i=ad_to6,ad_from6,-1
12709           temp15b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
12710           temp15b2 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2&
12711 &            , j))*fqyb(i, k, jp1)
12712           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp15b1
12713           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp15b1
12714           wb(i, k, j) = wb(i, k, j) + temp15b2
12715           wb(i, k, j-1) = wb(i, k, j-1) + temp15b2
12716           fqyb(i, k, jp1) = 0.0
12717         END DO
12718         DO k=ktf,kts+1,-1
12719           CALL POPINTEGER4(ad_from5)
12720           CALL POPINTEGER4(ad_to5)
12721           DO i=ad_to5,ad_from5,-1
12722             temp15b = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
12723             temp15b0 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
12724 &              fqyb(i, k, jp1)
12725             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp15b
12726             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp15b
12727             wb(i, k, j) = wb(i, k, j) + temp15b0
12728             wb(i, k, j-1) = wb(i, k, j-1) + temp15b0
12729             fqyb(i, k, jp1) = 0.0
12730           END DO
12731         END DO
12732         CALL POPINTEGER4(k)
12733       ELSE IF (branch .EQ. 4) THEN
12734         CALL POPINTEGER4(ad_from8)
12735         CALL POPINTEGER4(ad_to8)
12736         DO i=ad_to8,ad_from8,-1
12737           temp19 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, &
12738 &            j-1))
12739           temp22 = SIGN(1., vel)
12740           temp21 = temp22/12.0
12741           temp20 = SIGN(1, time_step)
12742           temp19b = vel*fqyb(i, k, jp1)
12743           temp19b0 = temp19b/12.0
12744           temp19b1 = temp20*temp21*temp19b
12745           velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2&
12746 &            ))/12.0+temp20*(temp21*temp19))*fqyb(i, k, jp1)
12747           wb(i, k, j) = wb(i, k, j) + 7.*temp19b0 - 3.*temp19b1
12748           wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp19b1 + 7.*temp19b0
12749           wb(i, k, j+1) = wb(i, k, j+1) + temp19b1 - temp19b0
12750           wb(i, k, j-2) = wb(i, k, j-2) - temp19b1 - temp19b0
12751           fqyb(i, k, jp1) = 0.0
12752           CALL POPREAL8(vel)
12753           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
12754           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
12755         END DO
12756         DO k=ktf,kts+1,-1
12757           CALL POPINTEGER4(ad_from7)
12758           CALL POPINTEGER4(ad_to7)
12759           DO i=ad_to7,ad_from7,-1
12760             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
12761             temp15 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k&
12762 &              , j-1))
12763             temp18 = SIGN(1., vel)
12764             temp17 = temp18/12.0
12765             temp16 = SIGN(1, time_step)
12766             temp15b3 = vel*fqyb(i, k, jp1)
12767             temp15b4 = temp15b3/12.0
12768             temp15b5 = temp16*temp17*temp15b3
12769             velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j&
12770 &              -2))/12.0+temp16*(temp17*temp15))*fqyb(i, k, jp1)
12771             wb(i, k, j) = wb(i, k, j) + 7.*temp15b4 - 3.*temp15b5
12772             wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp15b5 + 7.*temp15b4
12773             wb(i, k, j+1) = wb(i, k, j+1) + temp15b5 - temp15b4
12774             wb(i, k, j-2) = wb(i, k, j-2) - temp15b5 - temp15b4
12775             fqyb(i, k, jp1) = 0.0
12776             CALL POPREAL8(vel)
12777             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
12778             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
12779           END DO
12780         END DO
12781         CALL POPINTEGER4(k)
12782       END IF
12783     END DO
12784   ELSE
12785     fqxb = 0.0
12786     CALL POPINTEGER4(ad_from66)
12787     CALL POPINTEGER4(ad_to66)
12788     DO j=ad_to66,ad_from66,-1
12789       DO k=ktf+1,kts+1,-1
12790         CALL POPINTEGER4(ad_from65)
12791         CALL POPINTEGER4(ad_to65)
12792         DO i=ad_to65,ad_from65,-1
12793           mrdx = msftx(i, j)*rdx
12794           fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
12795           fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
12796         END DO
12797       END DO
12798       CALL POPINTEGER4(k)
12799       CALL POPCONTROL1B(branch)
12800       IF (branch .NE. 0) THEN
12801         CALL POPINTEGER4(ad_to64)
12802         DO i=ad_to64,i_end_f+1,-1
12803           CALL POPCONTROL1B(branch)
12804           IF (branch .NE. 0) THEN
12805             k = ktf + 1
12806             temp63b58 = vel*fqxb(i, k)/12.0
12807             velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, &
12808 &              j))*fqxb(i, k)/12.0
12809             wb(i, k, j) = wb(i, k, j) + 7.*temp63b58
12810             wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b58
12811             wb(i+1, k, j) = wb(i+1, k, j) - temp63b58
12812             wb(i-2, k, j) = wb(i-2, k, j) - temp63b58
12813             fqxb(i, k) = 0.0
12814             CALL POPREAL8(vel)
12815             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12816             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12817             DO k=ktf,kts+1,-1
12818               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12819               temp63b57 = vel*fqxb(i, k)/12.0
12820               velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
12821 &                , j))*fqxb(i, k)/12.0
12822               wb(i, k, j) = wb(i, k, j) + 7.*temp63b57
12823               wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b57
12824               wb(i+1, k, j) = wb(i+1, k, j) - temp63b57
12825               wb(i-2, k, j) = wb(i-2, k, j) - temp63b57
12826               fqxb(i, k) = 0.0
12827               CALL POPREAL8(vel)
12828               rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12829               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12830             END DO
12831             CALL POPINTEGER4(k)
12832           END IF
12833           CALL POPCONTROL1B(branch)
12834           IF (branch .EQ. 0) THEN
12835             k = ktf + 1
12836             temp63b55 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12837             temp63b56 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
12838 &              k-2, j))*fqxb(i, k)
12839             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp63b55
12840             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp63b55
12841             wb(i, k, j) = wb(i, k, j) + temp63b56
12842             wb(i-1, k, j) = wb(i-1, k, j) + temp63b56
12843             fqxb(i, k) = 0.0
12844             DO k=ktf,kts+1,-1
12845               temp63b53 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12846               temp63b54 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
12847 &                fqxb(i, k)
12848               rub(i, k, j) = rub(i, k, j) + fzm(k)*temp63b53
12849               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp63b53
12850               wb(i, k, j) = wb(i, k, j) + temp63b54
12851               wb(i-1, k, j) = wb(i-1, k, j) + temp63b54
12852               fqxb(i, k) = 0.0
12853             END DO
12854             CALL POPINTEGER4(k)
12855           END IF
12856         END DO
12857       END IF
12858       CALL POPCONTROL1B(branch)
12859       IF (branch .EQ. 0) THEN
12860         CALL POPINTEGER4(ad_from64)
12861         DO i=i_start_f-1,ad_from64,-1
12862           CALL POPCONTROL1B(branch)
12863           IF (branch .NE. 0) THEN
12864             k = ktf + 1
12865             temp63b52 = vel*fqxb(i, k)/12.0
12866             velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, &
12867 &              j))*fqxb(i, k)/12.0
12868             wb(i, k, j) = wb(i, k, j) + 7.*temp63b52
12869             wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b52
12870             wb(i+1, k, j) = wb(i+1, k, j) - temp63b52
12871             wb(i-2, k, j) = wb(i-2, k, j) - temp63b52
12872             fqxb(i, k) = 0.0
12873             CALL POPREAL8(vel)
12874             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12875             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12876             DO k=ktf,kts+1,-1
12877               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12878               temp63b51 = vel*fqxb(i, k)/12.0
12879               velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
12880 &                , j))*fqxb(i, k)/12.0
12881               wb(i, k, j) = wb(i, k, j) + 7.*temp63b51
12882               wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b51
12883               wb(i+1, k, j) = wb(i+1, k, j) - temp63b51
12884               wb(i-2, k, j) = wb(i-2, k, j) - temp63b51
12885               fqxb(i, k) = 0.0
12886               CALL POPREAL8(vel)
12887               rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12888               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12889             END DO
12890             CALL POPINTEGER4(k)
12891           END IF
12892           CALL POPCONTROL1B(branch)
12893           IF (branch .EQ. 0) THEN
12894             k = ktf + 1
12895             temp63b49 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12896             temp63b50 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
12897 &              k-2, j))*fqxb(i, k)
12898             rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp63b49
12899             rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp63b49
12900             wb(i, k, j) = wb(i, k, j) + temp63b50
12901             wb(i-1, k, j) = wb(i-1, k, j) + temp63b50
12902             fqxb(i, k) = 0.0
12903             DO k=ktf,kts+1,-1
12904               temp63b47 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
12905               temp63b48 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
12906 &                fqxb(i, k)
12907               rub(i, k, j) = rub(i, k, j) + fzm(k)*temp63b47
12908               rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp63b47
12909               wb(i, k, j) = wb(i, k, j) + temp63b48
12910               wb(i-1, k, j) = wb(i-1, k, j) + temp63b48
12911               fqxb(i, k) = 0.0
12912             END DO
12913             CALL POPINTEGER4(k)
12914           END IF
12915         END DO
12916       END IF
12917       k = ktf + 1
12918       DO i=i_end_f,i_start_f,-1
12919         temp63b46 = vel*fqxb(i, k)/60.0
12920         velb = (37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2, k&
12921 &          , j))+w(i+2, k, j)+w(i-3, k, j))*fqxb(i, k)/60.0
12922         wb(i, k, j) = wb(i, k, j) + 37.*temp63b46
12923         wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp63b46
12924         wb(i+1, k, j) = wb(i+1, k, j) - 8.*temp63b46
12925         wb(i-2, k, j) = wb(i-2, k, j) - 8.*temp63b46
12926         wb(i+2, k, j) = wb(i+2, k, j) + temp63b46
12927         wb(i-3, k, j) = wb(i-3, k, j) + temp63b46
12928         fqxb(i, k) = 0.0
12929         CALL POPREAL8(vel)
12930         rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
12931         rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
12932       END DO
12933       DO k=ktf,kts+1,-1
12934         DO i=i_end_f,i_start_f,-1
12935           vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
12936           temp63b45 = vel*fqxb(i, k)/60.0
12937           velb = (37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2, &
12938 &            k, j))+w(i+2, k, j)+w(i-3, k, j))*fqxb(i, k)/60.0
12939           wb(i, k, j) = wb(i, k, j) + 37.*temp63b45
12940           wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp63b45
12941           wb(i+1, k, j) = wb(i+1, k, j) - 8.*temp63b45
12942           wb(i-2, k, j) = wb(i-2, k, j) - 8.*temp63b45
12943           wb(i+2, k, j) = wb(i+2, k, j) + temp63b45
12944           wb(i-3, k, j) = wb(i-3, k, j) + temp63b45
12945           fqxb(i, k) = 0.0
12946           CALL POPREAL8(vel)
12947           rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
12948           rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
12949         END DO
12950       END DO
12951       CALL POPINTEGER4(k)
12952     END DO
12953     fqyb = 0.0
12954     CALL POPINTEGER4(ad_from63)
12955     CALL POPINTEGER4(ad_to63)
12956     DO j=ad_to63,ad_from63,-1
12957       CALL POPINTEGER4(jp0)
12958       CALL POPINTEGER4(jp1)
12959       CALL POPCONTROL2B(branch)
12960       IF (branch .LT. 2) THEN
12961         IF (branch .EQ. 0) THEN
12962           DO k=ktf,kts,-1
12963             CALL POPINTEGER4(ad_from60)
12964             CALL POPINTEGER4(ad_to60)
12965             DO i=ad_to60,ad_from60,-1
12966               mrdy = msftx(i, j-1)*rdy
12967               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
12968 &                -1)
12969             END DO
12970           END DO
12971           CALL POPINTEGER4(k)
12972         ELSE
12973           DO k=ktf,kts,-1
12974             CALL POPINTEGER4(ad_from61)
12975             CALL POPINTEGER4(ad_to61)
12976             DO i=ad_to61,ad_from61,-1
12977               mrdy = msftx(i, j-1)*rdy
12978               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
12979 &                -1)
12980             END DO
12981           END DO
12982           CALL POPINTEGER4(k)
12983         END IF
12984       ELSE IF (branch .EQ. 2) THEN
12985         DO k=ktf+1,kts+1,-1
12986           CALL POPINTEGER4(ad_from62)
12987           CALL POPINTEGER4(ad_to62)
12988           DO i=ad_to62,ad_from62,-1
12989             mrdy = msftx(i, j-1)*rdy
12990             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
12991 &              )
12992             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
12993 &              )
12994           END DO
12995         END DO
12996         CALL POPINTEGER4(k)
12997       END IF
12998       CALL POPCONTROL3B(branch)
12999       IF (branch .LT. 3) THEN
13000         IF (branch .EQ. 0) THEN
13001           CALL POPINTEGER4(ad_from51)
13002           CALL POPINTEGER4(ad_to51)
13003           DO i=ad_to51,ad_from51,-1
13004             temp63b32 = vel*fqyb(i, k, jp1)/60.0
13005             velb = (37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(i, &
13006 &              k, j-2))+w(i, k, j+2)+w(i, k, j-3))*fqyb(i, k, jp1)/60.0
13007             wb(i, k, j) = wb(i, k, j) + 37.*temp63b32
13008             wb(i, k, j-1) = wb(i, k, j-1) + 37.*temp63b32
13009             wb(i, k, j+1) = wb(i, k, j+1) - 8.*temp63b32
13010             wb(i, k, j-2) = wb(i, k, j-2) - 8.*temp63b32
13011             wb(i, k, j+2) = wb(i, k, j+2) + temp63b32
13012             wb(i, k, j-3) = wb(i, k, j-3) + temp63b32
13013             fqyb(i, k, jp1) = 0.0
13014             CALL POPREAL8(vel)
13015             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
13016             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
13017           END DO
13018           DO k=ktf,kts+1,-1
13019             CALL POPINTEGER4(ad_from50)
13020             CALL POPINTEGER4(ad_to50)
13021             DO i=ad_to50,ad_from50,-1
13022               vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
13023               temp63b31 = vel*fqyb(i, k, jp1)/60.0
13024               velb = (37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(i&
13025 &                , k, j-2))+w(i, k, j+2)+w(i, k, j-3))*fqyb(i, k, jp1)/&
13026 &                60.0
13027               wb(i, k, j) = wb(i, k, j) + 37.*temp63b31
13028               wb(i, k, j-1) = wb(i, k, j-1) + 37.*temp63b31
13029               wb(i, k, j+1) = wb(i, k, j+1) - 8.*temp63b31
13030               wb(i, k, j-2) = wb(i, k, j-2) - 8.*temp63b31
13031               wb(i, k, j+2) = wb(i, k, j+2) + temp63b31
13032               wb(i, k, j-3) = wb(i, k, j-3) + temp63b31
13033               fqyb(i, k, jp1) = 0.0
13034               CALL POPREAL8(vel)
13035               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
13036               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
13037             END DO
13038           END DO
13039           CALL POPINTEGER4(k)
13040         ELSE IF (branch .EQ. 1) THEN
13041           CALL POPINTEGER4(ad_from53)
13042           CALL POPINTEGER4(ad_to53)
13043           DO i=ad_to53,ad_from53,-1
13044             temp63b35 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
13045             temp63b36 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, &
13046 &              k-2, j))*fqyb(i, k, jp1)
13047             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp63b35
13048             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp63b35
13049             wb(i, k, j) = wb(i, k, j) + temp63b36
13050             wb(i, k, j-1) = wb(i, k, j-1) + temp63b36
13051             fqyb(i, k, jp1) = 0.0
13052           END DO
13053           DO k=ktf,kts+1,-1
13054             CALL POPINTEGER4(ad_from52)
13055             CALL POPINTEGER4(ad_to52)
13056             DO i=ad_to52,ad_from52,-1
13057               temp63b33 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
13058               temp63b34 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
13059 &                fqyb(i, k, jp1)
13060               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp63b33
13061               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp63b33
13062               wb(i, k, j) = wb(i, k, j) + temp63b34
13063               wb(i, k, j-1) = wb(i, k, j-1) + temp63b34
13064               fqyb(i, k, jp1) = 0.0
13065             END DO
13066           END DO
13067           CALL POPINTEGER4(k)
13068         ELSE
13069           CALL POPINTEGER4(ad_from55)
13070           CALL POPINTEGER4(ad_to55)
13071           DO i=ad_to55,ad_from55,-1
13072             temp63b38 = vel*fqyb(i, k, jp1)/12.0
13073             velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-&
13074 &              2))*fqyb(i, k, jp1)/12.0
13075             wb(i, k, j) = wb(i, k, j) + 7.*temp63b38
13076             wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b38
13077             wb(i, k, j+1) = wb(i, k, j+1) - temp63b38
13078             wb(i, k, j-2) = wb(i, k, j-2) - temp63b38
13079             fqyb(i, k, jp1) = 0.0
13080             CALL POPREAL8(vel)
13081             rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
13082             rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
13083           END DO
13084           DO k=ktf,kts+1,-1
13085             CALL POPINTEGER4(ad_from54)
13086             CALL POPINTEGER4(ad_to54)
13087             DO i=ad_to54,ad_from54,-1
13088               vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
13089               temp63b37 = vel*fqyb(i, k, jp1)/12.0
13090               velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, &
13091 &                j-2))*fqyb(i, k, jp1)/12.0
13092               wb(i, k, j) = wb(i, k, j) + 7.*temp63b37
13093               wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b37
13094               wb(i, k, j+1) = wb(i, k, j+1) - temp63b37
13095               wb(i, k, j-2) = wb(i, k, j-2) - temp63b37
13096               fqyb(i, k, jp1) = 0.0
13097               CALL POPREAL8(vel)
13098               rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
13099               rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
13100             END DO
13101           END DO
13102           CALL POPINTEGER4(k)
13103         END IF
13104       ELSE IF (branch .EQ. 3) THEN
13105         CALL POPINTEGER4(ad_from57)
13106         CALL POPINTEGER4(ad_to57)
13107         DO i=ad_to57,ad_from57,-1
13108           temp63b41 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
13109           temp63b42 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-&
13110 &            2, j))*fqyb(i, k, jp1)
13111           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp63b41
13112           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp63b41
13113           wb(i, k, j) = wb(i, k, j) + temp63b42
13114           wb(i, k, j-1) = wb(i, k, j-1) + temp63b42
13115           fqyb(i, k, jp1) = 0.0
13116         END DO
13117         DO k=ktf,kts+1,-1
13118           CALL POPINTEGER4(ad_from56)
13119           CALL POPINTEGER4(ad_to56)
13120           DO i=ad_to56,ad_from56,-1
13121             temp63b39 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
13122             temp63b40 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*&
13123 &              fqyb(i, k, jp1)
13124             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp63b39
13125             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp63b39
13126             wb(i, k, j) = wb(i, k, j) + temp63b40
13127             wb(i, k, j-1) = wb(i, k, j-1) + temp63b40
13128             fqyb(i, k, jp1) = 0.0
13129           END DO
13130         END DO
13131         CALL POPINTEGER4(k)
13132       ELSE IF (branch .EQ. 4) THEN
13133         CALL POPINTEGER4(ad_from59)
13134         CALL POPINTEGER4(ad_to59)
13135         DO i=ad_to59,ad_from59,-1
13136           temp63b44 = vel*fqyb(i, k, jp1)/12.0
13137           velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2)&
13138 &            )*fqyb(i, k, jp1)/12.0
13139           wb(i, k, j) = wb(i, k, j) + 7.*temp63b44
13140           wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b44
13141           wb(i, k, j+1) = wb(i, k, j+1) - temp63b44
13142           wb(i, k, j-2) = wb(i, k, j-2) - temp63b44
13143           fqyb(i, k, jp1) = 0.0
13144           CALL POPREAL8(vel)
13145           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
13146           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
13147         END DO
13148         DO k=ktf,kts+1,-1
13149           CALL POPINTEGER4(ad_from58)
13150           CALL POPINTEGER4(ad_to58)
13151           DO i=ad_to58,ad_from58,-1
13152             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
13153             temp63b43 = vel*fqyb(i, k, jp1)/12.0
13154             velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-&
13155 &              2))*fqyb(i, k, jp1)/12.0
13156             wb(i, k, j) = wb(i, k, j) + 7.*temp63b43
13157             wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b43
13158             wb(i, k, j+1) = wb(i, k, j+1) - temp63b43
13159             wb(i, k, j-2) = wb(i, k, j-2) - temp63b43
13160             fqyb(i, k, jp1) = 0.0
13161             CALL POPREAL8(vel)
13162             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
13163             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
13164           END DO
13165         END DO
13166         CALL POPINTEGER4(k)
13167       END IF
13168     END DO
13169   END IF
13170  100 CONTINUE
13171 END SUBROUTINE A_ADVECT_W
13172
13173 !        Generated by TAPENADE     (INRIA, Tropics team)
13174 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
13175 !
13176 !  Differentiation of advect_scalar_pd in reverse (adjoint) mode:
13177 !   gradient     of useful results: rom field tendency h_tendency
13178 !                z_tendency ru rv mu_old field_old mut
13179 !   with respect to varying inputs: rom field tendency h_tendency
13180 !                z_tendency ru rv mu_old field_old mut
13181 !   RW status of diff variables: rom:incr field:incr tendency:in-out
13182 !                h_tendency:in-out z_tendency:in-out ru:incr rv:incr
13183 !                mu_old:incr field_old:incr mut:incr
13184 SUBROUTINE A_ADVECT_SCALAR_PD(field, fieldb, field_old, field_oldb, &
13185 &  tendency, tendencyb, h_tendency, h_tendencyb, z_tendency, z_tendencyb&
13186 &  , ru, rub, rv, rvb, rom, romb, mut, mutb, mub, mu_old, mu_oldb, &
13187 &  time_step, config_flags, tenddec, msfux, msfuy, msfvx, msfvy, msftx, &
13188 &  msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, kde, ims&
13189 &  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
13190   IMPLICIT NONE
13191 ! Input data
13192   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
13193 ! tendency flag
13194   LOGICAL, INTENT(IN) :: tenddec
13195   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
13196 &  jme, kms, kme, its, ite, jts, jte, kts, kte
13197   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
13198 &  field_old, ru, rv, rom
13199   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub&
13200 &  , rvb, romb
13201   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old
13202   REAL, DIMENSION(ims:ime, jms:jme) :: mutb, mu_oldb
13203   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
13204   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb
13205   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: h_tendency, z_tendency
13206   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: h_tendencyb, z_tendencyb
13207   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
13208 &  msfvy, msftx, msfty
13209   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
13210   REAL, INTENT(IN) :: rdx, rdy, dt
13211   INTEGER, INTENT(IN) :: time_step
13212 ! Local data
13213   INTEGER :: i, j, k, itf, jtf, ktf
13214   INTEGER :: i_start, i_end, j_start, j_end
13215   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
13216   INTEGER :: jmin, jmax, jp, jm, imin, imax
13217   REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
13218   REAL :: ubb, vbb, mub0
13219 !  storage for high and low order fluxes
13220   REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqx, fqy&
13221 &  , fqz
13222   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxb, fqyb, fqzb
13223   REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqxl, &
13224 &  fqyl, fqzl
13225   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxlb, fqylb, &
13226 &  fqzlb
13227   INTEGER :: horz_order, vert_order
13228   LOGICAL :: degrade_xs, degrade_ys
13229   LOGICAL :: degrade_xe, degrade_ye
13230   INTEGER :: jp1, jp0, jtmp
13231   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low
13232   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outb, ph_lowb
13233   REAL :: scale
13234   REAL :: scaleb
13235   REAL, PARAMETER :: eps=1.e-20
13236 ! definition of flux operators, 3rd, 4th, 5th or 6th order
13237   REAL :: flux3, flux4, flux5, flux6, flux_upwind
13238   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
13239   REAL :: velb, crb
13240 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
13241 !                                    +0.5*(1.-sign(1.,cr))*q_i
13242 !      flux_upwind(q_im1, q_i, cr ) = 0.
13243   REAL :: dx, dy, dz
13244   LOGICAL, PARAMETER :: pd_limit=.true.
13245   INTEGER :: branch
13246   INTEGER :: ad_from
13247   INTEGER :: ad_to
13248   INTEGER :: ad_from0
13249   INTEGER :: ad_to0
13250   INTEGER :: ad_from1
13251   INTEGER :: ad_to1
13252   INTEGER :: ad_from2
13253   INTEGER :: ad_to2
13254   INTEGER :: ad_from3
13255   INTEGER :: ad_to3
13256   INTEGER :: ad_from4
13257   INTEGER :: ad_to4
13258   INTEGER :: ad_from5
13259   INTEGER :: ad_to5
13260   INTEGER :: ad_from6
13261   INTEGER :: ad_to6
13262   INTEGER :: ad_from7
13263   INTEGER :: ad_to7
13264   INTEGER :: ad_from8
13265   INTEGER :: ad_to8
13266   INTEGER :: ad_from9
13267   INTEGER :: ad_to9
13268   INTEGER :: ad_from10
13269   INTEGER :: ad_to10
13270   INTEGER :: ad_from11
13271   INTEGER :: ad_to11
13272   INTEGER :: ad_from12
13273   INTEGER :: ad_to12
13274   INTEGER :: ad_from13
13275   INTEGER :: ad_to13
13276   INTEGER :: ad_from14
13277   INTEGER :: ad_to14
13278   INTEGER :: ad_from15
13279   INTEGER :: ad_to15
13280   INTEGER :: ad_from16
13281   INTEGER :: ad_to16
13282   INTEGER :: ad_from17
13283   INTEGER :: ad_to17
13284   INTEGER :: ad_from18
13285   INTEGER :: ad_to18
13286   INTEGER :: ad_from19
13287   INTEGER :: ad_to19
13288   INTEGER :: ad_from20
13289   INTEGER :: ad_to20
13290   INTEGER :: ad_from21
13291   INTEGER :: ad_to21
13292   INTEGER :: ad_from22
13293   INTEGER :: ad_to22
13294   INTEGER :: ad_from23
13295   INTEGER :: ad_to23
13296   INTEGER :: ad_from24
13297   INTEGER :: ad_to24
13298   INTEGER :: ad_from25
13299   INTEGER :: ad_to25
13300   INTEGER :: ad_from26
13301   INTEGER :: ad_to26
13302   INTEGER :: ad_from27
13303   INTEGER :: ad_to27
13304   INTEGER :: ad_from28
13305   INTEGER :: ad_to28
13306   INTEGER :: ad_from29
13307   INTEGER :: ad_to29
13308   INTEGER :: ad_from30
13309   INTEGER :: ad_to30
13310   INTEGER :: ad_from31
13311   INTEGER :: ad_to31
13312   INTEGER :: ad_from32
13313   INTEGER :: ad_to32
13314   INTEGER :: ad_from33
13315   INTEGER :: ad_to33
13316   INTEGER :: ad_from34
13317   INTEGER :: ad_to34
13318   INTEGER :: ad_from35
13319   INTEGER :: ad_to35
13320   INTEGER :: ad_from36
13321   INTEGER :: ad_to36
13322   INTEGER :: ad_from37
13323   INTEGER :: ad_to37
13324   INTEGER :: ad_from38
13325   INTEGER :: ad_to38
13326   INTEGER :: ad_from39
13327   INTEGER :: ad_to39
13328   INTEGER :: ad_from40
13329   INTEGER :: ad_to40
13330   INTEGER :: ad_from41
13331   INTEGER :: ad_to41
13332   INTEGER :: ad_from42
13333   INTEGER :: ad_to42
13334   INTEGER :: ad_from43
13335   INTEGER :: ad_to43
13336   INTEGER :: ad_from44
13337   INTEGER :: ad_to44
13338   INTEGER :: ad_from45
13339   INTEGER :: ad_to45
13340   INTEGER :: ad_from46
13341   INTEGER :: ad_to46
13342   INTEGER :: ad_from47
13343   INTEGER :: ad_to47
13344   INTEGER :: ad_from48
13345   INTEGER :: ad_to48
13346   INTEGER :: ad_from49
13347   INTEGER :: ad_to49
13348   INTEGER :: ad_from50
13349   INTEGER :: ad_to50
13350   INTEGER :: ad_from51
13351   INTEGER :: ad_to51
13352   INTEGER :: ad_from52
13353   INTEGER :: ad_to52
13354   INTEGER :: ad_from53
13355   INTEGER :: ad_to53
13356   INTEGER :: ad_from54
13357   INTEGER :: ad_to54
13358   INTEGER :: ad_from55
13359   INTEGER :: ad_to55
13360   INTEGER :: ad_from56
13361   INTEGER :: ad_to56
13362   INTEGER :: ad_from57
13363   INTEGER :: ad_to57
13364   INTEGER :: ad_from58
13365   INTEGER :: ad_to58
13366   INTEGER :: ad_from59
13367   INTEGER :: ad_to59
13368   INTEGER :: ad_from60
13369   INTEGER :: ad_to60
13370   INTEGER :: ad_from61
13371   INTEGER :: ad_to61
13372   INTEGER :: ad_from62
13373   INTEGER :: ad_to62
13374   INTEGER :: ad_from63
13375   INTEGER :: ad_to63
13376   REAL :: abs30
13377   REAL :: y93
13378   REAL :: max43
13379   REAL :: abs67
13380   REAL :: abs100
13381   REAL :: temp3
13382   REAL :: temp29
13383   REAL :: temp31b43
13384   REAL :: y86b
13385   REAL :: abs92b
13386   REAL :: y92
13387   REAL :: max42
13388   REAL :: abs66
13389   REAL :: temp2
13390   REAL :: min42b
13391   INTEGER :: temp28
13392   REAL :: y1b
13393   REAL :: temp31b42
13394   REAL :: temp31b79
13395   REAL :: y94b
13396   REAL :: y91
13397   REAL :: max41
13398   REAL :: abs65
13399   REAL :: temp1
13400   REAL :: abs18b
13401   REAL :: temp23b22
13402   REAL :: temp27
13403   REAL :: temp31b41
13404   REAL :: temp31b78
13405   REAL :: y90
13406   REAL :: max40
13407   REAL :: abs64
13408   INTEGER :: temp0
13409   REAL :: abs26b
13410   REAL :: temp26
13411   REAL :: temp23b21
13412   REAL :: temp31b40
13413   REAL :: max39b
13414   REAL :: temp31b77
13415   REAL :: abs63
13416   REAL :: temp7b
13417   REAL :: temp25
13418   REAL :: temp23b20
13419   REAL :: y28b
13420   REAL :: abs34b
13421   REAL :: min5b
13422   REAL :: max10b
13423   REAL :: temp31b76
13424   REAL :: max47b
13425   REAL :: abs62
13426   REAL :: abs99
13427   INTEGER :: temp24
13428   REAL :: abs79b
13429   REAL :: y36b
13430   REAL :: temp31b75
13431   REAL :: abs42b
13432   REAL :: temp35b6
13433   REAL :: abs61
13434   REAL :: abs98
13435   REAL :: temp23
13436   REAL :: abs87b
13437   REAL :: temp31b74
13438   REAL :: temp35b5
13439   REAL :: y44b
13440   REAL :: abs50b
13441   INTEGER :: min39
13442   REAL :: abs60
13443   REAL :: abs97
13444   REAL :: temp22
13445   REAL :: min37b
13446   REAL :: y52b
13447   REAL :: y89b
13448   REAL :: temp31b73
13449   REAL :: temp35b4
13450   REAL :: abs95b
13451   INTEGER :: min9
13452   REAL :: min38
13453   REAL :: abs96
13454   REAL :: temp21
13455   REAL :: y4b
13456   REAL :: y60b
13457   REAL :: temp31b72
13458   REAL :: temp35b3
13459   REAL :: y97b
13460   INTEGER :: min8
13461   REAL :: min37
13462   REAL :: abs95
13463   INTEGER :: temp20
13464   REAL :: temp31b71
13465   REAL :: temp35b2
13466   REAL :: min7
13467   REAL :: min36
13468   REAL :: abs94
13469   REAL :: abs29b
13470   REAL :: temp31b70
13471   REAL :: min61b
13472   REAL :: temp35b1
13473   REAL :: abs102b
13474   REAL :: min6
13475   INTEGER :: min35
13476   REAL :: y29
13477   REAL :: abs93
13478   REAL :: max13b
13479   REAL :: abs37b
13480   REAL :: temp35b0
13481   REAL :: min5
13482   INTEGER :: min34
13483   REAL :: y28
13484   REAL :: abs92
13485   REAL :: max21b
13486   REAL :: abs1b
13487   REAL :: y39b
13488   REAL :: abs45b
13489   REAL :: min4
13490   REAL :: min33
13491   REAL :: y27
13492   REAL :: abs91
13493   REAL :: abs53b
13494   REAL :: y10b
13495   REAL :: y47b
13496   REAL :: min3
13497   REAL :: min32
13498   REAL :: y26
13499   REAL :: min69
13500   REAL :: abs90
13501   REAL :: y55b
13502   REAL :: abs61b
13503   REAL :: abs98b
13504   INTEGER :: min2
13505   REAL :: min31
13506   REAL :: y25
13507   REAL :: min68
13508   REAL :: y63b
13509   REAL :: temp23b9
13510   REAL :: min48b
13511   REAL :: max2b
13512   REAL :: y7b
13513   REAL :: min11b
13514   INTEGER :: min1
13515   INTEGER :: min30
13516   REAL :: y24
13517   REAL :: min67
13518   REAL :: y71b
13519   REAL :: temp23b8
13520   REAL :: min56b
13521   REAL :: y23
13522   REAL :: min66
13523   REAL :: tempb4
13524   REAL :: temp19b
13525   REAL :: temp23b7
13526   REAL :: min64b
13527   REAL :: y22
13528   REAL :: min65
13529   REAL :: y59
13530   REAL :: tempb3
13531   REAL :: max16b
13532   REAL :: temp23b6
13533   REAL :: temp27b
13534   REAL :: y21
13535   REAL :: min64
13536   REAL :: y58
13537   REAL :: abs11b
13538   REAL :: tempb2
13539   REAL :: temp23b5
13540   REAL :: max24b
13541   REAL :: abs4b
13542   REAL :: temp35b
13543   REAL :: abs48b
13544   REAL :: y20
13545   REAL :: min63
13546   REAL :: y57
13547   REAL :: tempb1
13548   REAL :: y13b
13549   REAL :: temp23b4
13550   REAL :: max32b
13551   REAL :: abs56b
13552   REAL :: temp43b
13553   REAL :: min62
13554   REAL :: y56
13555   REAL :: tempb0
13556   REAL :: abs64b
13557   REAL :: y21b
13558   REAL :: temp23b3
13559   REAL :: y58b
13560   REAL :: max40b
13561   REAL :: temp47b18
13562   REAL :: min61
13563   REAL :: y55
13564   REAL :: abs29
13565   REAL :: y66b
13566   REAL :: abs72b
13567   REAL :: temp23b2
13568   REAL :: max5b
13569   REAL :: min14b
13570   REAL :: temp47b17
13571   REAL :: min60
13572   REAL :: y54
13573   REAL :: abs28
13574   REAL :: temp23b1
13575   REAL :: y74b
13576   REAL :: abs80b
13577   REAL :: min59b
13578   REAL :: y102b
13579   REAL :: temp47b16
13580   REAL :: y53
13581   REAL :: abs27
13582   REAL :: temp7b6
13583   REAL :: temp23b0
13584   REAL :: y82b
13585   REAL :: min67b
13586   REAL :: temp47b15
13587   REAL :: y52
13588   REAL :: abs26
13589   REAL :: y89
13590   REAL :: max39
13591   REAL :: temp7b5
13592   REAL :: max19b
13593   REAL :: temp31b39
13594   REAL :: y90b
13595   REAL :: min75b
13596   REAL :: temp47b14
13597   REAL :: y51
13598   REAL :: abs25
13599   REAL :: y88
13600   REAL :: max38
13601   REAL :: abs14b
13602   REAL :: temp7b4
13603   REAL :: max27b
13604   REAL :: temp23b19
13605   REAL :: abs7b
13606   REAL :: temp31b38
13607   REAL :: temp47b13
13608   REAL :: y50
13609   REAL :: abs24
13610   REAL :: y87
13611   REAL :: max37
13612   REAL :: temp7b3
13613   REAL :: y16b
13614   REAL :: abs22b
13615   REAL :: temp23b18
13616   REAL :: max35b
13617   REAL :: abs59b
13618   REAL :: temp31b37
13619   REAL :: temp47b12
13620   REAL :: abs23
13621   REAL :: y86
13622   REAL :: max36
13623   REAL :: temp3b
13624   REAL :: temp7b2
13625   REAL :: abs67b
13626   REAL :: y24b
13627   REAL :: temp23b17
13628   REAL :: abs30b
13629   REAL :: temp31b36
13630   REAL :: max43b
13631   REAL :: temp47b11
13632   REAL :: abs22
13633   REAL :: y85
13634   REAL :: max35
13635   REAL :: abs59
13636   REAL :: min17b
13637   REAL :: temp7b1
13638   REAL :: y69b
13639   REAL :: abs75b
13640   REAL :: temp23b16
13641   REAL :: y32b
13642   REAL :: max8b
13643   REAL :: temp31b35
13644   REAL :: max51b
13645   REAL :: temp47b10
13646   REAL :: abs21
13647   REAL :: y84
13648   REAL :: max34
13649   REAL :: abs58
13650   REAL :: temp7b0
13651   REAL :: min25b
13652   REAL :: temp23b15
13653   REAL :: y77b
13654   REAL :: abs83b
13655   REAL :: temp31b34
13656   REAL :: y40b
13657   REAL :: abs20
13658   REAL :: y83
13659   REAL :: max33
13660   REAL :: abs57
13661   REAL :: temp19
13662   REAL :: min33b
13663   REAL :: temp23b14
13664   REAL :: y85b
13665   REAL :: temp31b33
13666   REAL :: abs91b
13667   REAL :: y82
13668   REAL :: max32
13669   REAL :: abs56
13670   REAL :: temp18
13671   REAL :: temp23b13
13672   REAL :: min41b
13673   REAL :: temp31b32
13674   REAL :: temp31b69
13675   REAL :: y93b
13676   REAL :: y81
13677   REAL :: max31
13678   REAL :: abs55
13679   REAL :: temp11b4
13680   REAL :: abs17b
13681   REAL :: temp17
13682   REAL :: temp23b12
13683   REAL :: temp31b31
13684   REAL :: temp31b68
13685   REAL :: temp43b9
13686   REAL :: y80
13687   REAL :: max30
13688   REAL :: abs54
13689   REAL :: temp11b3
13690   INTEGER :: temp16
13691   REAL :: y19b
13692   REAL :: temp23b11
13693   REAL :: abs25b
13694   REAL :: temp31b30
13695   REAL :: max38b
13696   REAL :: temp31b67
13697   REAL :: temp43b8
13698   REAL :: abs53
13699   REAL :: temp11b2
13700   REAL :: temp15
13701   REAL :: temp23b10
13702   REAL :: y27b
13703   REAL :: abs33b
13704   REAL :: min4b
13705   REAL :: temp31b66
13706   REAL :: max46b
13707   REAL :: temp43b7
13708   REAL :: abs52
13709   REAL :: abs89
13710   REAL :: temp14
13711   REAL :: temp11b1
13712   REAL :: abs78b
13713   REAL :: y35b
13714   REAL :: temp31b65
13715   REAL :: abs41b
13716   REAL :: temp43b6
13717   REAL :: max54b
13718   REAL :: abs51
13719   REAL :: abs88
13720   REAL :: temp13
13721   REAL :: temp11b0
13722   REAL :: min28b
13723   REAL :: abs86b
13724   REAL :: temp31b64
13725   REAL :: y43b
13726   REAL :: temp43b5
13727   INTEGER :: min29
13728   REAL :: abs50
13729   REAL :: abs87
13730   INTEGER :: temp12
13731   REAL :: min36b
13732   REAL :: temp31b63
13733   REAL :: y88b
13734   REAL :: abs94b
13735   REAL :: temp43b4
13736   REAL :: y51b
13737   REAL :: min28
13738   REAL :: abs86
13739   REAL :: temp11
13740   REAL :: y3b
13741   REAL :: temp31b62
13742   REAL :: y96b
13743   REAL :: temp43b3
13744   REAL :: min27
13745   REAL :: abs85
13746   REAL :: temp10
13747   REAL :: min52b
13748   REAL :: temp31b61
13749   REAL :: temp43b2
13750   REAL :: min26
13751   REAL :: abs84
13752   REAL :: temp15b
13753   REAL :: abs28b
13754   REAL :: temp31b60
13755   REAL :: min60b
13756   REAL :: temp43b1
13757   REAL :: temp46
13758   REAL :: abs101b
13759   REAL :: min25
13760   REAL :: y19
13761   REAL :: abs83
13762   REAL :: max12b
13763   REAL :: temp23b
13764   REAL :: min7b
13765   REAL :: abs36b
13766   REAL :: temp43b0
13767   REAL :: max49b
13768   REAL :: temp45
13769   REAL :: min24
13770   REAL :: y18
13771   REAL :: abs82
13772   REAL :: max20b
13773   REAL :: temp19b6
13774   REAL :: temp31b
13775   REAL :: y38b
13776   REAL :: abs44b
13777   INTEGER :: temp44
13778   INTEGER :: min23
13779   REAL :: y17
13780   REAL :: abs81
13781   REAL :: temp19b5
13782   REAL :: abs52b
13783   REAL :: abs89b
13784   REAL :: y46b
13785   REAL :: temp43
13786   INTEGER :: min22
13787   REAL :: y16
13788   REAL :: min59
13789   REAL :: abs80
13790   REAL :: temp19b4
13791   REAL :: y54b
13792   REAL :: abs60b
13793   REAL :: temp42
13794   REAL :: abs97b
13795   REAL :: y15
13796   REAL :: min21
13797   REAL :: min58
13798   REAL :: y62b
13799   REAL :: temp19b3
13800   REAL :: min47b
13801   REAL :: temp31b9
13802   REAL :: y6b
13803   REAL :: min10b
13804   REAL :: temp41
13805   REAL :: y99b
13806   REAL :: max1b
13807   REAL :: y14
13808   REAL :: min20
13809   REAL :: min57
13810   REAL :: y70b
13811   REAL :: temp19b2
13812   REAL :: temp31b8
13813   REAL :: min55b
13814   INTEGER :: temp40
13815   REAL :: y13
13816   REAL :: min56
13817   REAL :: temp19b1
13818   REAL :: temp31b7
13819   REAL :: min63b
13820   REAL :: y12
13821   REAL :: min55
13822   REAL :: y49
13823   REAL :: max15b
13824   REAL :: temp19b0
13825   REAL :: temp31b6
13826   REAL :: abs39b
13827   REAL :: min71b
13828   REAL :: y11
13829   INTEGER :: min54
13830   REAL :: y48
13831   REAL :: max23b
13832   REAL :: temp31b5
13833   REAL :: abs3b
13834   REAL :: abs10b
13835   REAL :: abs47b
13836   REAL :: y10
13837   INTEGER :: min53
13838   REAL :: y47
13839   REAL :: y12b
13840   REAL :: max31b
13841   REAL :: temp31b4
13842   REAL :: abs55b
13843   REAL :: y49b
13844   REAL :: min52
13845   REAL :: y46
13846   REAL :: abs63b
13847   REAL :: y20b
13848   REAL :: temp31b3
13849   REAL :: y57b
13850   REAL :: min51
13851   REAL :: y45
13852   REAL :: abs19
13853   REAL :: tempb
13854   REAL :: y65b
13855   REAL :: abs71b
13856   REAL :: temp31b2
13857   REAL :: max4b
13858   REAL :: y9b
13859   REAL :: min13b
13860   INTEGER :: min50
13861   REAL :: y44
13862   REAL :: abs18
13863   REAL :: min21b
13864   REAL :: y73b
13865   REAL :: temp31b1
13866   REAL :: min58b
13867   REAL :: y101b
13868   REAL :: y43
13869   REAL :: abs17
13870   REAL :: y81b
13871   REAL :: temp31b0
13872   REAL :: min66b
13873   REAL :: y42
13874   REAL :: abs16
13875   REAL :: y79
13876   REAL :: max29
13877   REAL :: max18b
13878   REAL :: temp31b29
13879   REAL :: min74b
13880   REAL :: y41
13881   REAL :: abs15
13882   REAL :: y78
13883   REAL :: max28
13884   REAL :: abs13b
13885   REAL :: max26b
13886   REAL :: temp31b28
13887   REAL :: abs6b
13888   REAL :: y40
13889   REAL :: abs14
13890   REAL :: y77
13891   REAL :: max27
13892   REAL :: y15b
13893   REAL :: abs21b
13894   REAL :: max34b
13895   REAL :: temp31b27
13896   REAL :: abs58b
13897   REAL :: abs13
13898   REAL :: y76
13899   REAL :: max26
13900   REAL :: abs66b
13901   REAL :: y23b
13902   REAL :: temp31b26
13903   REAL :: max42b
13904   REAL :: abs12
13905   REAL :: y75
13906   REAL :: max25
13907   REAL :: abs49
13908   REAL :: y68b
13909   REAL :: abs74b
13910   REAL :: y31b
13911   REAL :: temp31b25
13912   REAL :: max7b
13913   REAL :: max50b
13914   REAL :: abs11
13915   REAL :: y74
13916   REAL :: max24
13917   REAL :: abs48
13918   REAL :: y102
13919   REAL :: min24b
13920   REAL :: y76b
13921   REAL :: abs82b
13922   REAL :: temp31b24
13923   REAL :: abs10
13924   REAL :: y73
13925   REAL :: max23
13926   REAL :: abs47
13927   REAL :: y101
13928   REAL :: min32b
13929   REAL :: y84b
13930   REAL :: temp31b23
13931   REAL :: abs90b
13932   REAL :: min69b
13933   REAL :: y72
13934   REAL :: max22
13935   REAL :: abs46
13936   REAL :: y100
13937   REAL :: temp31b22
13938   REAL :: temp31b59
13939   REAL :: y92b
13940   REAL :: y71
13941   REAL :: max21
13942   REAL :: abs45
13943   REAL :: abs16b
13944   REAL :: max29b
13945   REAL :: temp31b21
13946   REAL :: abs9b
13947   REAL :: temp31b58
13948   REAL :: temp39b3
13949   REAL :: y70
13950   REAL :: max20
13951   REAL :: abs44
13952   REAL :: temp11b
13953   REAL :: y18b
13954   REAL :: abs24b
13955   REAL :: temp31b20
13956   REAL :: temp31b57
13957   REAL :: max37b
13958   REAL :: temp39b2
13959   REAL :: abs43
13960   REAL :: abs69b
13961   REAL :: y26b
13962   REAL :: abs32b
13963   REAL :: min3b
13964   REAL :: temp31b56
13965   REAL :: temp39b1
13966   REAL :: max45b
13967   REAL :: abs42
13968   REAL :: abs79
13969   REAL :: min19b
13970   REAL :: abs77b
13971   REAL :: y34b
13972   REAL :: temp31b55
13973   REAL :: abs40b
13974   REAL :: temp39b0
13975   REAL :: max53b
13976   REAL :: abs41
13977   REAL :: abs78
13978   REAL :: max54
13979   REAL :: temp3b6
13980   REAL :: min27b
13981   REAL :: y79b
13982   REAL :: abs85b
13983   REAL :: temp31b54
13984   REAL :: y42b
13985   REAL :: min19
13986   REAL :: abs40
13987   REAL :: abs77
13988   REAL :: max53
13989   REAL :: temp3b5
13990   REAL :: temp31b53
13991   REAL :: y87b
13992   REAL :: abs93b
13993   REAL :: temp39
13994   REAL :: y50b
13995   REAL :: min18
13996   REAL :: max52
13997   REAL :: abs76
13998   REAL :: temp3b4
13999   REAL :: min43b
14000   REAL :: y2b
14001   REAL :: temp31b52
14002   REAL :: temp38
14003   REAL :: y95b
14004   REAL :: min17
14005   REAL :: max51
14006   REAL :: abs75
14007   REAL :: temp3b3
14008   REAL :: abs19b
14009   REAL :: temp27b9
14010   REAL :: min51b
14011   REAL :: temp31b51
14012   REAL :: temp37
14013   INTEGER :: min16
14014   REAL :: abs9
14015   REAL :: max50
14016   REAL :: abs74
14017   REAL :: temp3b2
14018   REAL :: abs27b
14019   REAL :: temp27b8
14020   REAL :: temp31b50
14021   INTEGER :: temp36
14022   REAL :: abs100b
14023   INTEGER :: min15
14024   REAL :: abs8
14025   REAL :: abs73
14026   REAL :: temp3b1
14027   REAL :: y29b
14028   REAL :: temp27b7
14029   REAL :: min6b
14030   REAL :: max11b
14031   REAL :: abs35b
14032   REAL :: temp35
14033   REAL :: max48b
14034   REAL :: min14
14035   REAL :: abs7
14036   REAL :: abs72
14037   REAL :: temp3b0
14038   REAL :: temp27b6
14039   REAL :: y37b
14040   REAL :: temp34
14041   REAL :: abs43b
14042   REAL :: min13
14043   REAL :: abs6
14044   REAL :: abs71
14045   REAL :: temp27b5
14046   REAL :: abs88b
14047   REAL :: temp33
14048   REAL :: y45b
14049   REAL :: abs51b
14050   REAL :: min12
14051   INTEGER :: min49
14052   REAL :: abs5
14053   REAL :: abs70
14054   REAL :: min38b
14055   REAL :: temp27b4
14056   REAL :: y53b
14057   INTEGER :: temp32
14058   REAL :: abs96b
14059   REAL :: min11
14060   REAL :: min48
14061   REAL :: abs4
14062   REAL :: temp27b3
14063   REAL :: min46b
14064   REAL :: y5b
14065   REAL :: y61b
14066   REAL :: temp31
14067   REAL :: y98b
14068   REAL :: min10
14069   REAL :: min47
14070   REAL :: abs3
14071   REAL :: temp27b2
14072   REAL :: temp30
14073   REAL :: temp31b81
14074   REAL :: min46
14075   REAL :: abs2
14076   REAL :: temp27b1
14077   REAL :: temp31b80
14078   REAL :: min62b
14079   INTEGER :: min45
14080   REAL :: y39
14081   REAL :: abs1
14082   REAL :: max14b
14083   REAL :: temp27b0
14084   REAL :: abs38b
14085   REAL :: min70b
14086   INTEGER :: min44
14087   REAL :: y38
14088   REAL :: max22b
14089   REAL :: abs2b
14090   REAL :: abs46b
14091   REAL :: min43
14092   REAL :: y37
14093   REAL :: y11b
14094   REAL :: max30b
14095   REAL :: abs54b
14096   REAL :: y48b
14097   REAL :: min42
14098   REAL :: y36
14099   REAL :: abs62b
14100   REAL :: y56b
14101   REAL :: abs99b
14102   REAL :: min41
14103   REAL :: y35
14104   REAL :: y64b
14105   REAL :: abs70b
14106   REAL :: max3b
14107   REAL :: y8b
14108   REAL :: min12b
14109   INTEGER :: min40
14110   REAL :: y34
14111   REAL :: min20b
14112   REAL :: y72b
14113   REAL :: min57b
14114   REAL :: y100b
14115   REAL :: y33
14116   REAL :: max9
14117   REAL :: min76
14118   REAL :: y80b
14119   REAL :: min65b
14120   REAL :: y32
14121   REAL :: max8
14122   REAL :: y69
14123   REAL :: max19
14124   REAL :: min75
14125   REAL :: max17b
14126   REAL :: temp31b19
14127   REAL :: temp43b16
14128   REAL :: y31
14129   REAL :: max7
14130   REAL :: y68
14131   REAL :: max18
14132   REAL :: min74
14133   REAL :: abs12b
14134   REAL :: temp15b5
14135   REAL :: max25b
14136   REAL :: temp31b18
14137   REAL :: abs5b
14138   REAL :: temp43b15
14139   REAL :: abs49b
14140   REAL :: y30
14141   INTEGER :: min73
14142   REAL :: max6
14143   REAL :: y67
14144   REAL :: max17
14145   REAL :: y14b
14146   REAL :: temp15b4
14147   REAL :: abs20b
14148   REAL :: max33b
14149   REAL :: temp31b17
14150   REAL :: abs57b
14151   REAL :: temp43b14
14152   REAL :: temp47b9
14153   INTEGER :: min72
14154   REAL :: max5
14155   REAL :: y66
14156   REAL :: max16
14157   REAL :: abs65b
14158   REAL :: temp15b3
14159   REAL :: y22b
14160   REAL :: temp31b16
14161   REAL :: y59b
14162   REAL :: max41b
14163   REAL :: temp43b13
14164   REAL :: temp47b8
14165   REAL :: y9
14166   REAL :: min71
14167   REAL :: max4
14168   REAL :: y65
14169   REAL :: max15
14170   REAL :: abs39
14171   REAL :: temp
14172   REAL :: y67b
14173   REAL :: temp15b2
14174   REAL :: abs73b
14175   REAL :: y30b
14176   REAL :: temp31b15
14177   REAL :: max6b
14178   REAL :: temp43b12
14179   REAL :: temp47b7
14180   REAL :: y8
14181   REAL :: min70
14182   REAL :: max3
14183   REAL :: y64
14184   REAL :: max14
14185   REAL :: abs38
14186   REAL :: temp15b1
14187   REAL :: y75b
14188   REAL :: abs81b
14189   REAL :: temp31b14
14190   REAL :: temp43b11
14191   REAL :: temp47b6
14192   REAL :: y7
14193   REAL :: max2
14194   REAL :: y63
14195   REAL :: max13
14196   REAL :: abs37
14197   REAL :: temp15b0
14198   REAL :: min31b
14199   REAL :: y83b
14200   REAL :: temp31b13
14201   REAL :: temp43b10
14202   REAL :: min68b
14203   REAL :: temp47b5
14204   REAL :: y6
14205   REAL :: max1
14206   REAL :: y62
14207   REAL :: max12
14208   REAL :: abs36
14209   REAL :: y99
14210   REAL :: max49
14211   REAL :: temp9
14212   REAL :: temp31b12
14213   REAL :: temp31b49
14214   REAL :: y91b
14215   REAL :: temp47b4
14216   REAL :: min76b
14217   REAL :: y5
14218   REAL :: y61
14219   REAL :: max11
14220   REAL :: abs35
14221   REAL :: y98
14222   REAL :: max48
14223   REAL :: abs15b
14224   INTEGER :: temp8
14225   REAL :: max28b
14226   REAL :: temp31b11
14227   REAL :: abs8b
14228   REAL :: temp31b48
14229   REAL :: temp39b
14230   REAL :: temp47b3
14231   REAL :: y4
14232   REAL :: y60
14233   REAL :: max10
14234   REAL :: abs34
14235   REAL :: y97
14236   REAL :: max47
14237   REAL :: temp7
14238   REAL :: y17b
14239   REAL :: abs23b
14240   REAL :: temp31b10
14241   REAL :: temp31b47
14242   REAL :: max36b
14243   REAL :: temp47b
14244   REAL :: temp47b2
14245   REAL :: y3
14246   REAL :: abs33
14247   REAL :: y96
14248   REAL :: max46
14249   REAL :: temp6
14250   REAL :: abs68b
14251   REAL :: y25b
14252   REAL :: abs31b
14253   REAL :: temp31b46
14254   REAL :: max44b
14255   REAL :: temp47b1
14256   REAL :: y2
14257   REAL :: abs32
14258   REAL :: y95
14259   REAL :: max45
14260   REAL :: abs69
14261   REAL :: abs102
14262   REAL :: min18b
14263   REAL :: temp5
14264   REAL :: abs76b
14265   REAL :: y33b
14266   REAL :: max9b
14267   REAL :: temp31b45
14268   REAL :: temp47b0
14269   REAL :: max52b
14270   REAL :: y1
14271   REAL :: abs31
14272   REAL :: y94
14273   REAL :: max44
14274   REAL :: abs68
14275   REAL :: abs101
14276   INTEGER :: temp4
14277   REAL :: min26b
14278   REAL :: y78b
14279   REAL :: abs84b
14280   REAL :: temp31b44
14281   REAL :: y41b
14282 ! set order for the advection schemes
14283 !  write(6,*) ' in pd advection routine '
14284 ! Empty arrays just in case:
14285   IF (config_flags%polar) THEN
14286     fqx(:, :, :) = 0.
14287     fqy(:, :, :) = 0.
14288     fqz(:, :, :) = 0.
14289     fqxl(:, :, :) = 0.
14290     fqyl(:, :, :) = 0.
14291     fqzl(:, :, :) = 0.
14292   END IF
14293   IF (kte .GT. kde - 1) THEN
14294     ktf = kde - 1
14295   ELSE
14296     ktf = kte
14297   END IF
14298   horz_order = config_flags%h_sca_adv_order
14299   vert_order = config_flags%v_sca_adv_order
14300 !  determine boundary mods for flux operators
14301 !  We degrade the flux operators from 3rd/4th order
14302 !   to second order one gridpoint in from the boundaries for
14303 !   all boundary conditions except periodic and symmetry - these
14304 !   conditions have boundary zone data fill for correct application
14305 !   of the higher order flux stencils
14306   degrade_xs = .true.
14307   degrade_xe = .true.
14308   degrade_ys = .true.
14309   degrade_ye = .true.
14310 !  begin with horizontal flux divergence
14311 !  here is the choice of flux operators
14312   IF (horz_order .EQ. 6) THEN
14313     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
14314 &        its .GT. ids + 3) degrade_xs = .false.
14315     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
14316 &        ite .LT. ide - 4) degrade_xe = .false.
14317     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
14318 &        jts .GT. jds + 3) degrade_ys = .false.
14319     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
14320 &        jte .LT. jde - 4) degrade_ye = .false.
14321     IF (kte .GT. kde - 1) THEN
14322       ktf = kde - 1
14323     ELSE
14324       ktf = kte
14325     END IF
14326     i_start = its - 1
14327     IF (ite .GT. ide - 1) THEN
14328       min1 = ide - 1
14329     ELSE
14330       min1 = ite
14331     END IF
14332     i_end = min1 + 1
14333     j_start = jts - 1
14334     IF (jte .GT. jde - 1) THEN
14335       min2 = jde - 1
14336     ELSE
14337       min2 = jte
14338     END IF
14339     j_end = min2 + 1
14340     j_start_f = j_start
14341     j_end_f = j_end + 1
14342 !--  modify loop bounds if open or specified
14343 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
14344 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
14345     IF (degrade_xs) THEN
14346       IF (its - 1 .LT. ids) THEN
14347         i_start = ids
14348       ELSE
14349         i_start = its - 1
14350       END IF
14351     END IF
14352     IF (degrade_xe) THEN
14353       IF (ite + 1 .GT. ide - 1) THEN
14354         i_end = ide - 1
14355       ELSE
14356         i_end = ite + 1
14357       END IF
14358     END IF
14359     IF (degrade_ys) THEN
14360       IF (jts - 1 .LT. jds + 1) THEN
14361         j_start = jds + 1
14362       ELSE
14363         j_start = jts - 1
14364       END IF
14365       j_start_f = jds + 3
14366     END IF
14367     IF (degrade_ye) THEN
14368       IF (jte + 1 .GT. jde - 2) THEN
14369         j_end = jde - 2
14370       ELSE
14371         j_end = jte + 1
14372       END IF
14373       j_end_f = jde - 3
14374     END IF
14375     ad_from26 = j_start
14376 !  compute fluxes, 6th order
14377 j_loop_y_flux_6:DO j=ad_from26,j_end+1
14378       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
14379 ! use full stencil
14380         DO k=kts,ktf
14381           ad_from21 = i_start
14382           DO i=ad_from21,i_end
14383             CALL PUSHREAL8(dy)
14384 ! ADT eqn 48 d/dy
14385             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
14386             CALL PUSHREAL8(mu)
14387             mu = 0.5*(mut(i, j)+mut(i, j-1))
14388             CALL PUSHREAL8(vel)
14389             vel = rv(i, k, j)
14390             cr = vel*dt/dy/mu
14391             IF (cr .GE. 0.) THEN
14392               abs1 = cr
14393               CALL PUSHCONTROL1B(0)
14394             ELSE
14395               abs1 = -cr
14396               CALL PUSHCONTROL1B(1)
14397             END IF
14398             y1 = cr + abs1
14399             IF (1.0 .GT. y1) THEN
14400               CALL PUSHREAL8(min3)
14401               min3 = y1
14402               CALL PUSHCONTROL1B(0)
14403             ELSE
14404               CALL PUSHREAL8(min3)
14405               min3 = 1.0
14406               CALL PUSHCONTROL1B(1)
14407             END IF
14408             IF (cr .GE. 0.) THEN
14409               abs52 = cr
14410               CALL PUSHCONTROL1B(0)
14411             ELSE
14412               abs52 = -cr
14413               CALL PUSHCONTROL1B(1)
14414             END IF
14415             y52 = cr - abs52
14416             IF (-1.0 .LT. y52) THEN
14417               CALL PUSHREAL8(max2)
14418               max2 = y52
14419               CALL PUSHCONTROL1B(0)
14420             ELSE
14421               CALL PUSHREAL8(max2)
14422               max2 = -1.0
14423               CALL PUSHCONTROL1B(1)
14424             END IF
14425             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+&
14426 &              0.5*max2*field_old(i, k, j))
14427             fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)&
14428 &              )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field&
14429 &              (i, k, j+2)+field(i, k, j-3)))
14430             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
14431           END DO
14432           CALL PUSHINTEGER4(i - 1)
14433           CALL PUSHINTEGER4(ad_from21)
14434         END DO
14435         CALL PUSHCONTROL3B(5)
14436       ELSE IF (j .EQ. jds + 1) THEN
14437 ! 2nd order flux next to south boundary
14438         DO k=kts,ktf
14439           ad_from22 = i_start
14440           DO i=ad_from22,i_end
14441             CALL PUSHREAL8(dy)
14442 ! ADT eqn 48 d/dy
14443             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
14444             CALL PUSHREAL8(mu)
14445             mu = 0.5*(mut(i, j)+mut(i, j-1))
14446             CALL PUSHREAL8(vel)
14447             vel = rv(i, k, j)
14448             cr = vel*dt/dy/mu
14449             IF (cr .GE. 0.) THEN
14450               abs2 = cr
14451               CALL PUSHCONTROL1B(0)
14452             ELSE
14453               abs2 = -cr
14454               CALL PUSHCONTROL1B(1)
14455             END IF
14456             y2 = cr + abs2
14457             IF (1.0 .GT. y2) THEN
14458               CALL PUSHREAL8(min4)
14459               min4 = y2
14460               CALL PUSHCONTROL1B(0)
14461             ELSE
14462               CALL PUSHREAL8(min4)
14463               min4 = 1.0
14464               CALL PUSHCONTROL1B(1)
14465             END IF
14466             IF (cr .GE. 0.) THEN
14467               abs53 = cr
14468               CALL PUSHCONTROL1B(0)
14469             ELSE
14470               abs53 = -cr
14471               CALL PUSHCONTROL1B(1)
14472             END IF
14473             y53 = cr - abs53
14474             IF (-1.0 .LT. y53) THEN
14475               CALL PUSHREAL8(max3)
14476               max3 = y53
14477               CALL PUSHCONTROL1B(0)
14478             ELSE
14479               CALL PUSHREAL8(max3)
14480               max3 = -1.0
14481               CALL PUSHCONTROL1B(1)
14482             END IF
14483             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+&
14484 &              0.5*max3*field_old(i, k, j))
14485             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
14486 &              -1))
14487             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
14488           END DO
14489           CALL PUSHINTEGER4(i - 1)
14490           CALL PUSHINTEGER4(ad_from22)
14491         END DO
14492         CALL PUSHCONTROL3B(4)
14493       ELSE IF (j .EQ. jds + 2) THEN
14494 ! third of 4th order flux 2 in from south boundary
14495         DO k=kts,ktf
14496           ad_from23 = i_start
14497           DO i=ad_from23,i_end
14498             CALL PUSHREAL8(dy)
14499 ! ADT eqn 48 d/dy
14500             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
14501             CALL PUSHREAL8(mu)
14502             mu = 0.5*(mut(i, j)+mut(i, j-1))
14503             CALL PUSHREAL8(vel)
14504             vel = rv(i, k, j)
14505             cr = vel*dt/dy/mu
14506             IF (cr .GE. 0.) THEN
14507               abs3 = cr
14508               CALL PUSHCONTROL1B(0)
14509             ELSE
14510               abs3 = -cr
14511               CALL PUSHCONTROL1B(1)
14512             END IF
14513             y3 = cr + abs3
14514             IF (1.0 .GT. y3) THEN
14515               CALL PUSHREAL8(min5)
14516               min5 = y3
14517               CALL PUSHCONTROL1B(0)
14518             ELSE
14519               CALL PUSHREAL8(min5)
14520               min5 = 1.0
14521               CALL PUSHCONTROL1B(1)
14522             END IF
14523             IF (cr .GE. 0.) THEN
14524               abs54 = cr
14525               CALL PUSHCONTROL1B(0)
14526             ELSE
14527               abs54 = -cr
14528               CALL PUSHCONTROL1B(1)
14529             END IF
14530             y54 = cr - abs54
14531             IF (-1.0 .LT. y54) THEN
14532               CALL PUSHREAL8(max4)
14533               max4 = y54
14534               CALL PUSHCONTROL1B(0)
14535             ELSE
14536               CALL PUSHREAL8(max4)
14537               max4 = -1.0
14538               CALL PUSHCONTROL1B(1)
14539             END IF
14540             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+&
14541 &              0.5*max4*field_old(i, k, j))
14542             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
14543 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
14544             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
14545           END DO
14546           CALL PUSHINTEGER4(i - 1)
14547           CALL PUSHINTEGER4(ad_from23)
14548         END DO
14549         CALL PUSHCONTROL3B(3)
14550       ELSE IF (j .EQ. jde - 1) THEN
14551 ! 2nd order flux next to north boundary
14552         DO k=kts,ktf
14553           ad_from24 = i_start
14554           DO i=ad_from24,i_end
14555             CALL PUSHREAL8(dy)
14556 ! ADT eqn 48 d/dy
14557             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
14558             CALL PUSHREAL8(mu)
14559             mu = 0.5*(mut(i, j)+mut(i, j-1))
14560             CALL PUSHREAL8(vel)
14561             vel = rv(i, k, j)
14562             cr = vel*dt/dy/mu
14563             IF (cr .GE. 0.) THEN
14564               abs4 = cr
14565               CALL PUSHCONTROL1B(0)
14566             ELSE
14567               abs4 = -cr
14568               CALL PUSHCONTROL1B(1)
14569             END IF
14570             y4 = cr + abs4
14571             IF (1.0 .GT. y4) THEN
14572               CALL PUSHREAL8(min6)
14573               min6 = y4
14574               CALL PUSHCONTROL1B(0)
14575             ELSE
14576               CALL PUSHREAL8(min6)
14577               min6 = 1.0
14578               CALL PUSHCONTROL1B(1)
14579             END IF
14580             IF (cr .GE. 0.) THEN
14581               abs55 = cr
14582               CALL PUSHCONTROL1B(0)
14583             ELSE
14584               abs55 = -cr
14585               CALL PUSHCONTROL1B(1)
14586             END IF
14587             y55 = cr - abs55
14588             IF (-1.0 .LT. y55) THEN
14589               CALL PUSHREAL8(max5)
14590               max5 = y55
14591               CALL PUSHCONTROL1B(0)
14592             ELSE
14593               CALL PUSHREAL8(max5)
14594               max5 = -1.0
14595               CALL PUSHCONTROL1B(1)
14596             END IF
14597             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+&
14598 &              0.5*max5*field_old(i, k, j))
14599             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
14600 &              -1))
14601             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
14602           END DO
14603           CALL PUSHINTEGER4(i - 1)
14604           CALL PUSHINTEGER4(ad_from24)
14605         END DO
14606         CALL PUSHCONTROL3B(2)
14607       ELSE IF (j .EQ. jde - 2) THEN
14608 ! 3rd or 4th order flux 2 in from north boundary
14609         DO k=kts,ktf
14610           ad_from25 = i_start
14611           DO i=ad_from25,i_end
14612             CALL PUSHREAL8(dy)
14613 ! ADT eqn 48 d/dy
14614             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
14615             CALL PUSHREAL8(mu)
14616             mu = 0.5*(mut(i, j)+mut(i, j-1))
14617             CALL PUSHREAL8(vel)
14618             vel = rv(i, k, j)
14619             cr = vel*dt/dy/mu
14620             IF (cr .GE. 0.) THEN
14621               abs5 = cr
14622               CALL PUSHCONTROL1B(0)
14623             ELSE
14624               abs5 = -cr
14625               CALL PUSHCONTROL1B(1)
14626             END IF
14627             y5 = cr + abs5
14628             IF (1.0 .GT. y5) THEN
14629               CALL PUSHREAL8(min7)
14630               min7 = y5
14631               CALL PUSHCONTROL1B(0)
14632             ELSE
14633               CALL PUSHREAL8(min7)
14634               min7 = 1.0
14635               CALL PUSHCONTROL1B(1)
14636             END IF
14637             IF (cr .GE. 0.) THEN
14638               abs56 = cr
14639               CALL PUSHCONTROL1B(0)
14640             ELSE
14641               abs56 = -cr
14642               CALL PUSHCONTROL1B(1)
14643             END IF
14644             y56 = cr - abs56
14645             IF (-1.0 .LT. y56) THEN
14646               CALL PUSHREAL8(max6)
14647               max6 = y56
14648               CALL PUSHCONTROL1B(0)
14649             ELSE
14650               CALL PUSHREAL8(max6)
14651               max6 = -1.0
14652               CALL PUSHCONTROL1B(1)
14653             END IF
14654             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+&
14655 &              0.5*max6*field_old(i, k, j))
14656             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
14657 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
14658             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
14659           END DO
14660           CALL PUSHINTEGER4(i - 1)
14661           CALL PUSHINTEGER4(ad_from25)
14662         END DO
14663         CALL PUSHCONTROL3B(1)
14664       ELSE
14665         CALL PUSHCONTROL3B(0)
14666       END IF
14667     END DO j_loop_y_flux_6
14668     CALL PUSHINTEGER4(j - 1)
14669     CALL PUSHINTEGER4(ad_from26)
14670 !  next, x flux
14671 !--  these bounds are for periodic and sym conditions
14672     i_start = its - 1
14673     IF (ite .GT. ide - 1) THEN
14674       min8 = ide - 1
14675     ELSE
14676       min8 = ite
14677     END IF
14678     i_end = min8 + 1
14679     i_start_f = i_start
14680     i_end_f = i_end + 1
14681     j_start = jts - 1
14682     IF (jte .GT. jde - 1) THEN
14683       min9 = jde - 1
14684     ELSE
14685       min9 = jte
14686     END IF
14687     j_end = min9 + 1
14688 !--  modify loop bounds for open and specified b.c
14689 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
14690 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
14691     IF (degrade_ys) THEN
14692       IF (jts - 1 .LT. jds) THEN
14693         j_start = jds
14694       ELSE
14695         j_start = jts - 1
14696       END IF
14697     END IF
14698     IF (degrade_ye) THEN
14699       IF (jte + 1 .GT. jde - 1) THEN
14700         j_end = jde - 1
14701       ELSE
14702         j_end = jte + 1
14703       END IF
14704     END IF
14705     IF (degrade_xs) THEN
14706       IF (ids + 1 .LT. its - 1) THEN
14707         i_start = its - 1
14708       ELSE
14709         i_start = ids + 1
14710       END IF
14711       i_start_f = ids + 3
14712     END IF
14713     IF (degrade_xe) THEN
14714       IF (ide - 2 .GT. ite + 1) THEN
14715         i_end = ite + 1
14716       ELSE
14717         i_end = ide - 2
14718       END IF
14719       i_end_f = ide - 3
14720     END IF
14721     ad_from28 = j_start
14722 !  compute fluxes
14723     DO j=ad_from28,j_end
14724 !  5th order flux
14725       DO k=kts,ktf
14726         DO i=i_start_f,i_end_f
14727           CALL PUSHREAL8(dx)
14728 ! ADT eqn 48 d/dx
14729           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
14730           CALL PUSHREAL8(mu)
14731           mu = 0.5*(mut(i, j)+mut(i-1, j))
14732           CALL PUSHREAL8(vel)
14733           vel = ru(i, k, j)
14734           cr = vel*dt/dx/mu
14735           IF (cr .GE. 0.) THEN
14736             abs6 = cr
14737             CALL PUSHCONTROL1B(0)
14738           ELSE
14739             abs6 = -cr
14740             CALL PUSHCONTROL1B(1)
14741           END IF
14742           y6 = cr + abs6
14743           IF (1.0 .GT. y6) THEN
14744             CALL PUSHREAL8(min10)
14745             min10 = y6
14746             CALL PUSHCONTROL1B(0)
14747           ELSE
14748             CALL PUSHREAL8(min10)
14749             min10 = 1.0
14750             CALL PUSHCONTROL1B(1)
14751           END IF
14752           IF (cr .GE. 0.) THEN
14753             abs57 = cr
14754             CALL PUSHCONTROL1B(0)
14755           ELSE
14756             abs57 = -cr
14757             CALL PUSHCONTROL1B(1)
14758           END IF
14759           y57 = cr - abs57
14760           IF (-1.0 .LT. y57) THEN
14761             CALL PUSHREAL8(max7)
14762             max7 = y57
14763             CALL PUSHCONTROL1B(0)
14764           ELSE
14765             CALL PUSHREAL8(max7)
14766             max7 = -1.0
14767             CALL PUSHCONTROL1B(1)
14768           END IF
14769           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5&
14770 &            *max7*field_old(i, k, j))
14771           fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-&
14772 &            2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2&
14773 &            , k, j)+field(i-3, k, j)))
14774           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
14775         END DO
14776       END DO
14777 !  lower order fluxes close to boundaries (if not periodic or symmetric)
14778       IF (degrade_xs) THEN
14779         ad_from27 = i_start
14780         DO i=ad_from27,i_start_f-1
14781           IF (i .EQ. ids + 1) THEN
14782 ! second order
14783             DO k=kts,ktf
14784               CALL PUSHREAL8(dx)
14785 ! ADT eqn 48 d/dx
14786               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
14787               CALL PUSHREAL8(mu)
14788               mu = 0.5*(mut(i, j)+mut(i-1, j))
14789               CALL PUSHREAL8(vel)
14790               vel = ru(i, k, j)/mu
14791               cr = vel*dt/dx
14792               IF (cr .GE. 0.) THEN
14793                 abs7 = cr
14794                 CALL PUSHCONTROL1B(0)
14795               ELSE
14796                 abs7 = -cr
14797                 CALL PUSHCONTROL1B(1)
14798               END IF
14799               y7 = cr + abs7
14800               IF (1.0 .GT. y7) THEN
14801                 CALL PUSHREAL8(min11)
14802                 min11 = y7
14803                 CALL PUSHCONTROL1B(0)
14804               ELSE
14805                 CALL PUSHREAL8(min11)
14806                 min11 = 1.0
14807                 CALL PUSHCONTROL1B(1)
14808               END IF
14809               IF (cr .GE. 0.) THEN
14810                 abs58 = cr
14811                 CALL PUSHCONTROL1B(0)
14812               ELSE
14813                 abs58 = -cr
14814                 CALL PUSHCONTROL1B(1)
14815               END IF
14816               y58 = cr - abs58
14817               IF (-1.0 .LT. y58) THEN
14818                 CALL PUSHREAL8(max8)
14819                 max8 = y58
14820                 CALL PUSHCONTROL1B(0)
14821               ELSE
14822                 CALL PUSHREAL8(max8)
14823                 max8 = -1.0
14824                 CALL PUSHCONTROL1B(1)
14825               END IF
14826               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)&
14827 &                +0.5*max8*field_old(i, k, j))
14828               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
14829 &                k, j))
14830               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
14831             END DO
14832             CALL PUSHCONTROL1B(0)
14833           ELSE
14834             CALL PUSHCONTROL1B(1)
14835           END IF
14836           IF (i .EQ. ids + 2) THEN
14837 ! fourth order
14838             DO k=kts,ktf
14839               CALL PUSHREAL8(dx)
14840 ! ADT eqn 48 d/dx
14841               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
14842               CALL PUSHREAL8(mu)
14843               mu = 0.5*(mut(i, j)+mut(i-1, j))
14844               CALL PUSHREAL8(vel)
14845               vel = ru(i, k, j)
14846               cr = vel*dt/dx/mu
14847               IF (cr .GE. 0.) THEN
14848                 abs8 = cr
14849                 CALL PUSHCONTROL1B(0)
14850               ELSE
14851                 abs8 = -cr
14852                 CALL PUSHCONTROL1B(1)
14853               END IF
14854               y8 = cr + abs8
14855               IF (1.0 .GT. y8) THEN
14856                 CALL PUSHREAL8(min12)
14857                 min12 = y8
14858                 CALL PUSHCONTROL1B(0)
14859               ELSE
14860                 CALL PUSHREAL8(min12)
14861                 min12 = 1.0
14862                 CALL PUSHCONTROL1B(1)
14863               END IF
14864               IF (cr .GE. 0.) THEN
14865                 abs59 = cr
14866                 CALL PUSHCONTROL1B(0)
14867               ELSE
14868                 abs59 = -cr
14869                 CALL PUSHCONTROL1B(1)
14870               END IF
14871               y59 = cr - abs59
14872               IF (-1.0 .LT. y59) THEN
14873                 CALL PUSHREAL8(max9)
14874                 max9 = y59
14875                 CALL PUSHCONTROL1B(0)
14876               ELSE
14877                 CALL PUSHREAL8(max9)
14878                 max9 = -1.0
14879                 CALL PUSHCONTROL1B(1)
14880               END IF
14881               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)&
14882 &                +0.5*max9*field_old(i, k, j))
14883               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
14884 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j)))
14885               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
14886             END DO
14887             CALL PUSHCONTROL1B(1)
14888           ELSE
14889             CALL PUSHCONTROL1B(0)
14890           END IF
14891         END DO
14892         CALL PUSHINTEGER4(ad_from27)
14893         CALL PUSHCONTROL1B(0)
14894       ELSE
14895         CALL PUSHCONTROL1B(1)
14896       END IF
14897       IF (degrade_xe) THEN
14898         DO i=i_end_f+1,i_end+1
14899           IF (i .EQ. ide - 1) THEN
14900 ! second order flux next to the boundary
14901             DO k=kts,ktf
14902               CALL PUSHREAL8(dx)
14903 ! ADT eqn 48 d/dx
14904               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
14905               CALL PUSHREAL8(mu)
14906               mu = 0.5*(mut(i, j)+mut(i-1, j))
14907               CALL PUSHREAL8(vel)
14908               vel = ru(i, k, j)
14909               cr = vel*dt/dx/mu
14910               IF (cr .GE. 0.) THEN
14911                 abs9 = cr
14912                 CALL PUSHCONTROL1B(0)
14913               ELSE
14914                 abs9 = -cr
14915                 CALL PUSHCONTROL1B(1)
14916               END IF
14917               y9 = cr + abs9
14918               IF (1.0 .GT. y9) THEN
14919                 CALL PUSHREAL8(min13)
14920                 min13 = y9
14921                 CALL PUSHCONTROL1B(0)
14922               ELSE
14923                 CALL PUSHREAL8(min13)
14924                 min13 = 1.0
14925                 CALL PUSHCONTROL1B(1)
14926               END IF
14927               IF (cr .GE. 0.) THEN
14928                 abs60 = cr
14929                 CALL PUSHCONTROL1B(0)
14930               ELSE
14931                 abs60 = -cr
14932                 CALL PUSHCONTROL1B(1)
14933               END IF
14934               y60 = cr - abs60
14935               IF (-1.0 .LT. y60) THEN
14936                 CALL PUSHREAL8(max10)
14937                 max10 = y60
14938                 CALL PUSHCONTROL1B(0)
14939               ELSE
14940                 CALL PUSHREAL8(max10)
14941                 max10 = -1.0
14942                 CALL PUSHCONTROL1B(1)
14943               END IF
14944               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)&
14945 &                +0.5*max10*field_old(i, k, j))
14946               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
14947 &                k, j))
14948               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
14949             END DO
14950             CALL PUSHCONTROL1B(0)
14951           ELSE
14952             CALL PUSHCONTROL1B(1)
14953           END IF
14954           IF (i .EQ. ide - 2) THEN
14955 ! fourth order flux one in from the boundary
14956             DO k=kts,ktf
14957               CALL PUSHREAL8(dx)
14958 ! ADT eqn 48 d/dx
14959               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
14960               CALL PUSHREAL8(mu)
14961               mu = 0.5*(mut(i, j)+mut(i-1, j))
14962               CALL PUSHREAL8(vel)
14963               vel = ru(i, k, j)
14964               cr = vel*dt/dx/mu
14965               IF (cr .GE. 0.) THEN
14966                 abs10 = cr
14967                 CALL PUSHCONTROL1B(0)
14968               ELSE
14969                 abs10 = -cr
14970                 CALL PUSHCONTROL1B(1)
14971               END IF
14972               y10 = cr + abs10
14973               IF (1.0 .GT. y10) THEN
14974                 CALL PUSHREAL8(min14)
14975                 min14 = y10
14976                 CALL PUSHCONTROL1B(0)
14977               ELSE
14978                 CALL PUSHREAL8(min14)
14979                 min14 = 1.0
14980                 CALL PUSHCONTROL1B(1)
14981               END IF
14982               IF (cr .GE. 0.) THEN
14983                 abs61 = cr
14984                 CALL PUSHCONTROL1B(0)
14985               ELSE
14986                 abs61 = -cr
14987                 CALL PUSHCONTROL1B(1)
14988               END IF
14989               y61 = cr - abs61
14990               IF (-1.0 .LT. y61) THEN
14991                 CALL PUSHREAL8(max11)
14992                 max11 = y61
14993                 CALL PUSHCONTROL1B(0)
14994               ELSE
14995                 CALL PUSHREAL8(max11)
14996                 max11 = -1.0
14997                 CALL PUSHCONTROL1B(1)
14998               END IF
14999               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)&
15000 &                +0.5*max11*field_old(i, k, j))
15001               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
15002 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j)))
15003               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
15004             END DO
15005             CALL PUSHCONTROL1B(1)
15006           ELSE
15007             CALL PUSHCONTROL1B(0)
15008           END IF
15009         END DO
15010         CALL PUSHINTEGER4(i - 1)
15011         CALL PUSHCONTROL1B(1)
15012       ELSE
15013         CALL PUSHCONTROL1B(0)
15014       END IF
15015     END DO
15016     CALL PUSHINTEGER4(j - 1)
15017     CALL PUSHINTEGER4(ad_from28)
15018     CALL PUSHCONTROL3B(5)
15019   ELSE IF (horz_order .EQ. 5) THEN
15020 ! enddo for outer J loop
15021 !--- end of 6th order horizontal flux calculation
15022     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
15023 &        its .GT. ids + 3) degrade_xs = .false.
15024     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
15025 &        ite .LT. ide - 4) degrade_xe = .false.
15026     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
15027 &        jts .GT. jds + 3) degrade_ys = .false.
15028     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
15029 &        jte .LT. jde - 4) degrade_ye = .false.
15030     IF (kte .GT. kde - 1) THEN
15031       ktf = kde - 1
15032     ELSE
15033       ktf = kte
15034     END IF
15035     i_start = its - 1
15036     IF (ite .GT. ide - 1) THEN
15037       min15 = ide - 1
15038     ELSE
15039       min15 = ite
15040     END IF
15041     i_end = min15 + 1
15042     j_start = jts - 1
15043     IF (jte .GT. jde - 1) THEN
15044       min16 = jde - 1
15045     ELSE
15046       min16 = jte
15047     END IF
15048     j_end = min16 + 1
15049     j_start_f = j_start
15050     j_end_f = j_end + 1
15051 !--  modify loop bounds if open or specified
15052 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
15053 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
15054     IF (degrade_xs) THEN
15055       IF (its - 1 .LT. ids) THEN
15056         i_start = ids
15057       ELSE
15058         i_start = its - 1
15059       END IF
15060     END IF
15061     IF (degrade_xe) THEN
15062       IF (ite + 1 .GT. ide - 1) THEN
15063         i_end = ide - 1
15064       ELSE
15065         i_end = ite + 1
15066       END IF
15067     END IF
15068     IF (degrade_ys) THEN
15069       IF (jts - 1 .LT. jds + 1) THEN
15070         j_start = jds + 1
15071       ELSE
15072         j_start = jts - 1
15073       END IF
15074       j_start_f = jds + 3
15075     END IF
15076     IF (degrade_ye) THEN
15077       IF (jte + 1 .GT. jde - 2) THEN
15078         j_end = jde - 2
15079       ELSE
15080         j_end = jte + 1
15081       END IF
15082       j_end_f = jde - 3
15083     END IF
15084     ad_from4 = j_start
15085 !  compute fluxes, 5th order
15086 j_loop_y_flux_5:DO j=ad_from4,j_end+1
15087       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
15088 ! use full stencil
15089         DO k=kts,ktf
15090           ad_from = i_start
15091           DO i=ad_from,i_end
15092             CALL PUSHREAL8(dy)
15093 ! ADT eqn 48 d/dy
15094             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15095             CALL PUSHREAL8(mu)
15096             mu = 0.5*(mut(i, j)+mut(i, j-1))
15097             CALL PUSHREAL8(vel)
15098             vel = rv(i, k, j)
15099             cr = vel*dt/dy/mu
15100             IF (cr .GE. 0.) THEN
15101               abs11 = cr
15102               CALL PUSHCONTROL1B(0)
15103             ELSE
15104               abs11 = -cr
15105               CALL PUSHCONTROL1B(1)
15106             END IF
15107             y11 = cr + abs11
15108             IF (1.0 .GT. y11) THEN
15109               CALL PUSHREAL8(min17)
15110               min17 = y11
15111               CALL PUSHCONTROL1B(0)
15112             ELSE
15113               CALL PUSHREAL8(min17)
15114               min17 = 1.0
15115               CALL PUSHCONTROL1B(1)
15116             END IF
15117             IF (cr .GE. 0.) THEN
15118               abs62 = cr
15119               CALL PUSHCONTROL1B(0)
15120             ELSE
15121               abs62 = -cr
15122               CALL PUSHCONTROL1B(1)
15123             END IF
15124             y62 = cr - abs62
15125             IF (-1.0 .LT. y62) THEN
15126               CALL PUSHREAL8(max12)
15127               max12 = y62
15128               CALL PUSHCONTROL1B(0)
15129             ELSE
15130               CALL PUSHREAL8(max12)
15131               max12 = -1.0
15132               CALL PUSHCONTROL1B(1)
15133             END IF
15134             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min17*field_old(i, k, j-1)+&
15135 &              0.5*max12*field_old(i, k, j))
15136             fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)&
15137 &              )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field&
15138 &              (i, k, j+2)+field(i, k, j-3))-SIGN(1, time_step)*SIGN(1., &
15139 &              vel)*(1./60.)*(field(i, k, j+2)-field(i, k, j-3)-5.*(field&
15140 &              (i, k, j+1)-field(i, k, j-2))+10.*(field(i, k, j)-field(i&
15141 &              , k, j-1))))
15142             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15143           END DO
15144           CALL PUSHINTEGER4(i - 1)
15145           CALL PUSHINTEGER4(ad_from)
15146         END DO
15147         CALL PUSHCONTROL3B(5)
15148       ELSE IF (j .EQ. jds + 1) THEN
15149 ! 2nd order flux next to south boundary
15150         DO k=kts,ktf
15151           ad_from0 = i_start
15152           DO i=ad_from0,i_end
15153             CALL PUSHREAL8(dy)
15154 ! ADT eqn 48 d/dy
15155             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15156             CALL PUSHREAL8(mu)
15157             mu = 0.5*(mut(i, j)+mut(i, j-1))
15158             CALL PUSHREAL8(vel)
15159             vel = rv(i, k, j)
15160             cr = vel*dt/dy/mu
15161             IF (cr .GE. 0.) THEN
15162               abs12 = cr
15163               CALL PUSHCONTROL1B(0)
15164             ELSE
15165               abs12 = -cr
15166               CALL PUSHCONTROL1B(1)
15167             END IF
15168             y12 = cr + abs12
15169             IF (1.0 .GT. y12) THEN
15170               CALL PUSHREAL8(min18)
15171               min18 = y12
15172               CALL PUSHCONTROL1B(0)
15173             ELSE
15174               CALL PUSHREAL8(min18)
15175               min18 = 1.0
15176               CALL PUSHCONTROL1B(1)
15177             END IF
15178             IF (cr .GE. 0.) THEN
15179               abs63 = cr
15180               CALL PUSHCONTROL1B(0)
15181             ELSE
15182               abs63 = -cr
15183               CALL PUSHCONTROL1B(1)
15184             END IF
15185             y63 = cr - abs63
15186             IF (-1.0 .LT. y63) THEN
15187               CALL PUSHREAL8(max13)
15188               max13 = y63
15189               CALL PUSHCONTROL1B(0)
15190             ELSE
15191               CALL PUSHREAL8(max13)
15192               max13 = -1.0
15193               CALL PUSHCONTROL1B(1)
15194             END IF
15195             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min18*field_old(i, k, j-1)+&
15196 &              0.5*max13*field_old(i, k, j))
15197             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
15198 &              -1))
15199             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15200           END DO
15201           CALL PUSHINTEGER4(i - 1)
15202           CALL PUSHINTEGER4(ad_from0)
15203         END DO
15204         CALL PUSHCONTROL3B(4)
15205       ELSE IF (j .EQ. jds + 2) THEN
15206 ! third of 4th order flux 2 in from south boundary
15207         DO k=kts,ktf
15208           ad_from1 = i_start
15209           DO i=ad_from1,i_end
15210             CALL PUSHREAL8(dy)
15211 ! ADT eqn 48 d/dy
15212             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15213             CALL PUSHREAL8(mu)
15214             mu = 0.5*(mut(i, j)+mut(i, j-1))
15215             CALL PUSHREAL8(vel)
15216             vel = rv(i, k, j)
15217             cr = vel*dt/dy/mu
15218             IF (cr .GE. 0.) THEN
15219               abs13 = cr
15220               CALL PUSHCONTROL1B(0)
15221             ELSE
15222               abs13 = -cr
15223               CALL PUSHCONTROL1B(1)
15224             END IF
15225             y13 = cr + abs13
15226             IF (1.0 .GT. y13) THEN
15227               CALL PUSHREAL8(min19)
15228               min19 = y13
15229               CALL PUSHCONTROL1B(0)
15230             ELSE
15231               CALL PUSHREAL8(min19)
15232               min19 = 1.0
15233               CALL PUSHCONTROL1B(1)
15234             END IF
15235             IF (cr .GE. 0.) THEN
15236               abs64 = cr
15237               CALL PUSHCONTROL1B(0)
15238             ELSE
15239               abs64 = -cr
15240               CALL PUSHCONTROL1B(1)
15241             END IF
15242             y64 = cr - abs64
15243             IF (-1.0 .LT. y64) THEN
15244               CALL PUSHREAL8(max14)
15245               max14 = y64
15246               CALL PUSHCONTROL1B(0)
15247             ELSE
15248               CALL PUSHREAL8(max14)
15249               max14 = -1.0
15250               CALL PUSHCONTROL1B(1)
15251             END IF
15252             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min19*field_old(i, k, j-1)+&
15253 &              0.5*max14*field_old(i, k, j))
15254             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
15255 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
15256 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
15257 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
15258             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15259           END DO
15260           CALL PUSHINTEGER4(i - 1)
15261           CALL PUSHINTEGER4(ad_from1)
15262         END DO
15263         CALL PUSHCONTROL3B(3)
15264       ELSE IF (j .EQ. jde - 1) THEN
15265 ! 2nd order flux next to north boundary
15266         DO k=kts,ktf
15267           ad_from2 = i_start
15268           DO i=ad_from2,i_end
15269             CALL PUSHREAL8(dy)
15270 ! ADT eqn 48 d/dy
15271             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15272             CALL PUSHREAL8(mu)
15273             mu = 0.5*(mut(i, j)+mut(i, j-1))
15274             CALL PUSHREAL8(vel)
15275             vel = rv(i, k, j)
15276             cr = vel*dt/dy/mu
15277             IF (cr .GE. 0.) THEN
15278               abs14 = cr
15279               CALL PUSHCONTROL1B(0)
15280             ELSE
15281               abs14 = -cr
15282               CALL PUSHCONTROL1B(1)
15283             END IF
15284             y14 = cr + abs14
15285             IF (1.0 .GT. y14) THEN
15286               CALL PUSHREAL8(min20)
15287               min20 = y14
15288               CALL PUSHCONTROL1B(0)
15289             ELSE
15290               CALL PUSHREAL8(min20)
15291               min20 = 1.0
15292               CALL PUSHCONTROL1B(1)
15293             END IF
15294             IF (cr .GE. 0.) THEN
15295               abs65 = cr
15296               CALL PUSHCONTROL1B(0)
15297             ELSE
15298               abs65 = -cr
15299               CALL PUSHCONTROL1B(1)
15300             END IF
15301             y65 = cr - abs65
15302             IF (-1.0 .LT. y65) THEN
15303               CALL PUSHREAL8(max15)
15304               max15 = y65
15305               CALL PUSHCONTROL1B(0)
15306             ELSE
15307               CALL PUSHREAL8(max15)
15308               max15 = -1.0
15309               CALL PUSHCONTROL1B(1)
15310             END IF
15311             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min20*field_old(i, k, j-1)+&
15312 &              0.5*max15*field_old(i, k, j))
15313             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
15314 &              -1))
15315             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15316           END DO
15317           CALL PUSHINTEGER4(i - 1)
15318           CALL PUSHINTEGER4(ad_from2)
15319         END DO
15320         CALL PUSHCONTROL3B(2)
15321       ELSE IF (j .EQ. jde - 2) THEN
15322 ! 3rd or 4th order flux 2 in from north boundary
15323         DO k=kts,ktf
15324           ad_from3 = i_start
15325           DO i=ad_from3,i_end
15326             CALL PUSHREAL8(dy)
15327 ! ADT eqn 48 d/dy
15328             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15329             CALL PUSHREAL8(mu)
15330             mu = 0.5*(mut(i, j)+mut(i, j-1))
15331             CALL PUSHREAL8(vel)
15332             vel = rv(i, k, j)
15333             cr = vel*dt/dy/mu
15334             IF (cr .GE. 0.) THEN
15335               abs15 = cr
15336               CALL PUSHCONTROL1B(0)
15337             ELSE
15338               abs15 = -cr
15339               CALL PUSHCONTROL1B(1)
15340             END IF
15341             y15 = cr + abs15
15342             IF (1.0 .GT. y15) THEN
15343               CALL PUSHREAL8(min21)
15344               min21 = y15
15345               CALL PUSHCONTROL1B(0)
15346             ELSE
15347               CALL PUSHREAL8(min21)
15348               min21 = 1.0
15349               CALL PUSHCONTROL1B(1)
15350             END IF
15351             IF (cr .GE. 0.) THEN
15352               abs66 = cr
15353               CALL PUSHCONTROL1B(0)
15354             ELSE
15355               abs66 = -cr
15356               CALL PUSHCONTROL1B(1)
15357             END IF
15358             y66 = cr - abs66
15359             IF (-1.0 .LT. y66) THEN
15360               CALL PUSHREAL8(max16)
15361               max16 = y66
15362               CALL PUSHCONTROL1B(0)
15363             ELSE
15364               CALL PUSHREAL8(max16)
15365               max16 = -1.0
15366               CALL PUSHCONTROL1B(1)
15367             END IF
15368             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min21*field_old(i, k, j-1)+&
15369 &              0.5*max16*field_old(i, k, j))
15370             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
15371 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
15372 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
15373 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
15374             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15375           END DO
15376           CALL PUSHINTEGER4(i - 1)
15377           CALL PUSHINTEGER4(ad_from3)
15378         END DO
15379         CALL PUSHCONTROL3B(1)
15380       ELSE
15381         CALL PUSHCONTROL3B(0)
15382       END IF
15383     END DO j_loop_y_flux_5
15384     CALL PUSHINTEGER4(j - 1)
15385     CALL PUSHINTEGER4(ad_from4)
15386 !  next, x flux
15387 !--  these bounds are for periodic and sym conditions
15388     i_start = its - 1
15389     IF (ite .GT. ide - 1) THEN
15390       min22 = ide - 1
15391     ELSE
15392       min22 = ite
15393     END IF
15394     i_end = min22 + 1
15395     i_start_f = i_start
15396     i_end_f = i_end + 1
15397     j_start = jts - 1
15398     IF (jte .GT. jde - 1) THEN
15399       min23 = jde - 1
15400     ELSE
15401       min23 = jte
15402     END IF
15403     j_end = min23 + 1
15404 !--  modify loop bounds for open and specified b.c
15405 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
15406 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
15407     IF (degrade_ys) THEN
15408       IF (jts - 1 .LT. jds) THEN
15409         j_start = jds
15410       ELSE
15411         j_start = jts - 1
15412       END IF
15413     END IF
15414     IF (degrade_ye) THEN
15415       IF (jte + 1 .GT. jde - 1) THEN
15416         j_end = jde - 1
15417       ELSE
15418         j_end = jte + 1
15419       END IF
15420     END IF
15421     IF (degrade_xs) THEN
15422       IF (ids + 1 .LT. its - 1) THEN
15423         i_start = its - 1
15424       ELSE
15425         i_start = ids + 1
15426       END IF
15427       i_start_f = ids + 3
15428     END IF
15429     IF (degrade_xe) THEN
15430       IF (ide - 2 .GT. ite + 1) THEN
15431         i_end = ite + 1
15432       ELSE
15433         i_end = ide - 2
15434       END IF
15435       i_end_f = ide - 3
15436     END IF
15437     ad_from6 = j_start
15438 !  compute fluxes
15439     DO j=ad_from6,j_end
15440 !  5th order flux
15441       DO k=kts,ktf
15442         DO i=i_start_f,i_end_f
15443           CALL PUSHREAL8(dx)
15444 ! ADT eqn 48 d/dx
15445           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
15446           CALL PUSHREAL8(mu)
15447           mu = 0.5*(mut(i, j)+mut(i-1, j))
15448           CALL PUSHREAL8(vel)
15449           vel = ru(i, k, j)
15450           cr = vel*dt/dx/mu
15451           IF (cr .GE. 0.) THEN
15452             abs16 = cr
15453             CALL PUSHCONTROL1B(0)
15454           ELSE
15455             abs16 = -cr
15456             CALL PUSHCONTROL1B(1)
15457           END IF
15458           y16 = cr + abs16
15459           IF (1.0 .GT. y16) THEN
15460             CALL PUSHREAL8(min24)
15461             min24 = y16
15462             CALL PUSHCONTROL1B(0)
15463           ELSE
15464             CALL PUSHREAL8(min24)
15465             min24 = 1.0
15466             CALL PUSHCONTROL1B(1)
15467           END IF
15468           IF (cr .GE. 0.) THEN
15469             abs67 = cr
15470             CALL PUSHCONTROL1B(0)
15471           ELSE
15472             abs67 = -cr
15473             CALL PUSHCONTROL1B(1)
15474           END IF
15475           y67 = cr - abs67
15476           IF (-1.0 .LT. y67) THEN
15477             CALL PUSHREAL8(max17)
15478             max17 = y67
15479             CALL PUSHCONTROL1B(0)
15480           ELSE
15481             CALL PUSHREAL8(max17)
15482             max17 = -1.0
15483             CALL PUSHCONTROL1B(1)
15484           END IF
15485           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min24*field_old(i-1, k, j)+0.5&
15486 &            *max17*field_old(i, k, j))
15487           fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-&
15488 &            2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2&
15489 &            , k, j)+field(i-3, k, j))-SIGN(1, time_step)*SIGN(1., vel)*(&
15490 &            1./60.)*(field(i+2, k, j)-field(i-3, k, j)-5.*(field(i+1, k&
15491 &            , j)-field(i-2, k, j))+10.*(field(i, k, j)-field(i-1, k, j))&
15492 &            ))
15493           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
15494         END DO
15495       END DO
15496 !  lower order fluxes close to boundaries (if not periodic or symmetric)
15497       IF (degrade_xs) THEN
15498         ad_from5 = i_start
15499         DO i=ad_from5,i_start_f-1
15500           IF (i .EQ. ids + 1) THEN
15501 ! second order
15502             DO k=kts,ktf
15503               CALL PUSHREAL8(dx)
15504 ! ADT eqn 48 d/dx
15505               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
15506               CALL PUSHREAL8(mu)
15507               mu = 0.5*(mut(i, j)+mut(i-1, j))
15508               CALL PUSHREAL8(vel)
15509               vel = ru(i, k, j)/mu
15510               cr = vel*dt/dx
15511               IF (cr .GE. 0.) THEN
15512                 abs17 = cr
15513                 CALL PUSHCONTROL1B(0)
15514               ELSE
15515                 abs17 = -cr
15516                 CALL PUSHCONTROL1B(1)
15517               END IF
15518               y17 = cr + abs17
15519               IF (1.0 .GT. y17) THEN
15520                 CALL PUSHREAL8(min25)
15521                 min25 = y17
15522                 CALL PUSHCONTROL1B(0)
15523               ELSE
15524                 CALL PUSHREAL8(min25)
15525                 min25 = 1.0
15526                 CALL PUSHCONTROL1B(1)
15527               END IF
15528               IF (cr .GE. 0.) THEN
15529                 abs68 = cr
15530                 CALL PUSHCONTROL1B(0)
15531               ELSE
15532                 abs68 = -cr
15533                 CALL PUSHCONTROL1B(1)
15534               END IF
15535               y68 = cr - abs68
15536               IF (-1.0 .LT. y68) THEN
15537                 CALL PUSHREAL8(max18)
15538                 max18 = y68
15539                 CALL PUSHCONTROL1B(0)
15540               ELSE
15541                 CALL PUSHREAL8(max18)
15542                 max18 = -1.0
15543                 CALL PUSHCONTROL1B(1)
15544               END IF
15545               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min25*field_old(i-1, k, j)&
15546 &                +0.5*max18*field_old(i, k, j))
15547               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
15548 &                k, j))
15549               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
15550             END DO
15551             CALL PUSHCONTROL1B(0)
15552           ELSE
15553             CALL PUSHCONTROL1B(1)
15554           END IF
15555           IF (i .EQ. ids + 2) THEN
15556 ! third order
15557             DO k=kts,ktf
15558               CALL PUSHREAL8(dx)
15559 ! ADT eqn 48 d/dx
15560               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
15561               CALL PUSHREAL8(mu)
15562               mu = 0.5*(mut(i, j)+mut(i-1, j))
15563               CALL PUSHREAL8(vel)
15564               vel = ru(i, k, j)
15565               cr = vel*dt/dx/mu
15566               IF (cr .GE. 0.) THEN
15567                 abs18 = cr
15568                 CALL PUSHCONTROL1B(0)
15569               ELSE
15570                 abs18 = -cr
15571                 CALL PUSHCONTROL1B(1)
15572               END IF
15573               y18 = cr + abs18
15574               IF (1.0 .GT. y18) THEN
15575                 CALL PUSHREAL8(min26)
15576                 min26 = y18
15577                 CALL PUSHCONTROL1B(0)
15578               ELSE
15579                 CALL PUSHREAL8(min26)
15580                 min26 = 1.0
15581                 CALL PUSHCONTROL1B(1)
15582               END IF
15583               IF (cr .GE. 0.) THEN
15584                 abs69 = cr
15585                 CALL PUSHCONTROL1B(0)
15586               ELSE
15587                 abs69 = -cr
15588                 CALL PUSHCONTROL1B(1)
15589               END IF
15590               y69 = cr - abs69
15591               IF (-1.0 .LT. y69) THEN
15592                 CALL PUSHREAL8(max19)
15593                 max19 = y69
15594                 CALL PUSHCONTROL1B(0)
15595               ELSE
15596                 CALL PUSHREAL8(max19)
15597                 max19 = -1.0
15598                 CALL PUSHCONTROL1B(1)
15599               END IF
15600               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min26*field_old(i-1, k, j)&
15601 &                +0.5*max19*field_old(i, k, j))
15602               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
15603 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
15604 &                time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
15605 &                field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
15606               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
15607             END DO
15608             CALL PUSHCONTROL1B(1)
15609           ELSE
15610             CALL PUSHCONTROL1B(0)
15611           END IF
15612         END DO
15613         CALL PUSHINTEGER4(ad_from5)
15614         CALL PUSHCONTROL1B(0)
15615       ELSE
15616         CALL PUSHCONTROL1B(1)
15617       END IF
15618       IF (degrade_xe) THEN
15619         DO i=i_end_f+1,i_end+1
15620           IF (i .EQ. ide - 1) THEN
15621 ! second order flux next to the boundary
15622             DO k=kts,ktf
15623               CALL PUSHREAL8(dx)
15624 ! ADT eqn 48 d/dx
15625               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
15626               CALL PUSHREAL8(mu)
15627               mu = 0.5*(mut(i, j)+mut(i-1, j))
15628               CALL PUSHREAL8(vel)
15629               vel = ru(i, k, j)
15630               cr = vel*dt/dx/mu
15631               IF (cr .GE. 0.) THEN
15632                 abs19 = cr
15633                 CALL PUSHCONTROL1B(0)
15634               ELSE
15635                 abs19 = -cr
15636                 CALL PUSHCONTROL1B(1)
15637               END IF
15638               y19 = cr + abs19
15639               IF (1.0 .GT. y19) THEN
15640                 CALL PUSHREAL8(min27)
15641                 min27 = y19
15642                 CALL PUSHCONTROL1B(0)
15643               ELSE
15644                 CALL PUSHREAL8(min27)
15645                 min27 = 1.0
15646                 CALL PUSHCONTROL1B(1)
15647               END IF
15648               IF (cr .GE. 0.) THEN
15649                 abs70 = cr
15650                 CALL PUSHCONTROL1B(0)
15651               ELSE
15652                 abs70 = -cr
15653                 CALL PUSHCONTROL1B(1)
15654               END IF
15655               y70 = cr - abs70
15656               IF (-1.0 .LT. y70) THEN
15657                 CALL PUSHREAL8(max20)
15658                 max20 = y70
15659                 CALL PUSHCONTROL1B(0)
15660               ELSE
15661                 CALL PUSHREAL8(max20)
15662                 max20 = -1.0
15663                 CALL PUSHCONTROL1B(1)
15664               END IF
15665               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min27*field_old(i-1, k, j)&
15666 &                +0.5*max20*field_old(i, k, j))
15667               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
15668 &                k, j))
15669               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
15670             END DO
15671             CALL PUSHCONTROL1B(0)
15672           ELSE
15673             CALL PUSHCONTROL1B(1)
15674           END IF
15675           IF (i .EQ. ide - 2) THEN
15676 ! third order flux one in from the boundary
15677             DO k=kts,ktf
15678               CALL PUSHREAL8(dx)
15679 ! ADT eqn 48 d/dx
15680               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
15681               CALL PUSHREAL8(mu)
15682               mu = 0.5*(mut(i, j)+mut(i-1, j))
15683               CALL PUSHREAL8(vel)
15684               vel = ru(i, k, j)
15685               cr = vel*dt/dx/mu
15686               IF (cr .GE. 0.) THEN
15687                 abs20 = cr
15688                 CALL PUSHCONTROL1B(0)
15689               ELSE
15690                 abs20 = -cr
15691                 CALL PUSHCONTROL1B(1)
15692               END IF
15693               y20 = cr + abs20
15694               IF (1.0 .GT. y20) THEN
15695                 CALL PUSHREAL8(min28)
15696                 min28 = y20
15697                 CALL PUSHCONTROL1B(0)
15698               ELSE
15699                 CALL PUSHREAL8(min28)
15700                 min28 = 1.0
15701                 CALL PUSHCONTROL1B(1)
15702               END IF
15703               IF (cr .GE. 0.) THEN
15704                 abs71 = cr
15705                 CALL PUSHCONTROL1B(0)
15706               ELSE
15707                 abs71 = -cr
15708                 CALL PUSHCONTROL1B(1)
15709               END IF
15710               y71 = cr - abs71
15711               IF (-1.0 .LT. y71) THEN
15712                 CALL PUSHREAL8(max21)
15713                 max21 = y71
15714                 CALL PUSHCONTROL1B(0)
15715               ELSE
15716                 CALL PUSHREAL8(max21)
15717                 max21 = -1.0
15718                 CALL PUSHCONTROL1B(1)
15719               END IF
15720               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min28*field_old(i-1, k, j)&
15721 &                +0.5*max21*field_old(i, k, j))
15722               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
15723 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
15724 &                time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
15725 &                field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
15726               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
15727             END DO
15728             CALL PUSHCONTROL1B(1)
15729           ELSE
15730             CALL PUSHCONTROL1B(0)
15731           END IF
15732         END DO
15733         CALL PUSHINTEGER4(i - 1)
15734         CALL PUSHCONTROL1B(1)
15735       ELSE
15736         CALL PUSHCONTROL1B(0)
15737       END IF
15738     END DO
15739     CALL PUSHINTEGER4(j - 1)
15740     CALL PUSHINTEGER4(ad_from6)
15741     CALL PUSHCONTROL3B(4)
15742   ELSE IF (horz_order .EQ. 4) THEN
15743 ! enddo for outer J loop
15744 !--- end of 5th order horizontal flux calculation
15745     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
15746 &        its .GT. ids + 1) degrade_xs = .false.
15747     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
15748 &        ite .LT. ide - 2) degrade_xe = .false.
15749     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
15750 &        jts .GT. jds + 1) degrade_ys = .false.
15751     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
15752 &        jte .LT. jde - 2) degrade_ye = .false.
15753     IF (kte .GT. kde - 1) THEN
15754       ktf = kde - 1
15755     ELSE
15756       ktf = kte
15757     END IF
15758     i_start = its - 1
15759     IF (ite .GT. ide - 1) THEN
15760       min29 = ide - 1
15761     ELSE
15762       min29 = ite
15763     END IF
15764     i_end = min29 + 1
15765     j_start = jts - 1
15766     IF (jte .GT. jde - 1) THEN
15767       min30 = jde - 1
15768     ELSE
15769       min30 = jte
15770     END IF
15771     j_end = min30 + 1
15772     j_start_f = j_start
15773     j_end_f = j_end + 1
15774 !--  modify loop bounds if open or specified
15775     IF (degrade_xs) i_start = its
15776     IF (degrade_xe) THEN
15777       IF (ite .GT. ide - 1) THEN
15778         i_end = ide - 1
15779       ELSE
15780         i_end = ite
15781       END IF
15782     END IF
15783     IF (degrade_ys) THEN
15784       IF (jts .LT. jds + 1) THEN
15785         j_start = jds + 1
15786       ELSE
15787         j_start = jts
15788       END IF
15789       j_start_f = jds + 2
15790     END IF
15791     IF (degrade_ye) THEN
15792       IF (jte .GT. jde - 2) THEN
15793         j_end = jde - 2
15794       ELSE
15795         j_end = jte
15796       END IF
15797       j_end_f = jde - 2
15798     END IF
15799     ad_from10 = j_start
15800 !  compute fluxes, 4th order
15801 j_loop_y_flux_4:DO j=ad_from10,j_end+1
15802       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
15803 ! use full stencil
15804         DO k=kts,ktf
15805           ad_from7 = i_start
15806           DO i=ad_from7,i_end
15807             CALL PUSHREAL8(dy)
15808 ! ADT eqn 48 d/dy
15809             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15810             CALL PUSHREAL8(mu)
15811             mu = 0.5*(mut(i, j)+mut(i, j-1))
15812             CALL PUSHREAL8(vel)
15813             vel = rv(i, k, j)
15814             cr = vel*dt/dy/mu
15815             IF (cr .GE. 0.) THEN
15816               abs21 = cr
15817               CALL PUSHCONTROL1B(0)
15818             ELSE
15819               abs21 = -cr
15820               CALL PUSHCONTROL1B(1)
15821             END IF
15822             y21 = cr + abs21
15823             IF (1.0 .GT. y21) THEN
15824               CALL PUSHREAL8(min31)
15825               min31 = y21
15826               CALL PUSHCONTROL1B(0)
15827             ELSE
15828               CALL PUSHREAL8(min31)
15829               min31 = 1.0
15830               CALL PUSHCONTROL1B(1)
15831             END IF
15832             IF (cr .GE. 0.) THEN
15833               abs72 = cr
15834               CALL PUSHCONTROL1B(0)
15835             ELSE
15836               abs72 = -cr
15837               CALL PUSHCONTROL1B(1)
15838             END IF
15839             y72 = cr - abs72
15840             IF (-1.0 .LT. y72) THEN
15841               CALL PUSHREAL8(max22)
15842               max22 = y72
15843               CALL PUSHCONTROL1B(0)
15844             ELSE
15845               CALL PUSHREAL8(max22)
15846               max22 = -1.0
15847               CALL PUSHCONTROL1B(1)
15848             END IF
15849             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min31*field_old(i, k, j-1)+&
15850 &              0.5*max22*field_old(i, k, j))
15851             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
15852 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
15853             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15854           END DO
15855           CALL PUSHINTEGER4(i - 1)
15856           CALL PUSHINTEGER4(ad_from7)
15857         END DO
15858         CALL PUSHCONTROL2B(3)
15859       ELSE IF (j .EQ. jds + 1) THEN
15860 ! 2nd order flux next to south boundary
15861         DO k=kts,ktf
15862           ad_from8 = i_start
15863           DO i=ad_from8,i_end
15864             CALL PUSHREAL8(dy)
15865 ! ADT eqn 48 d/dy
15866             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15867             CALL PUSHREAL8(mu)
15868             mu = 0.5*(mut(i, j)+mut(i, j-1))
15869             CALL PUSHREAL8(vel)
15870             vel = rv(i, k, j)
15871             cr = vel*dt/dy/mu
15872             IF (cr .GE. 0.) THEN
15873               abs22 = cr
15874               CALL PUSHCONTROL1B(0)
15875             ELSE
15876               abs22 = -cr
15877               CALL PUSHCONTROL1B(1)
15878             END IF
15879             y22 = cr + abs22
15880             IF (1.0 .GT. y22) THEN
15881               CALL PUSHREAL8(min32)
15882               min32 = y22
15883               CALL PUSHCONTROL1B(0)
15884             ELSE
15885               CALL PUSHREAL8(min32)
15886               min32 = 1.0
15887               CALL PUSHCONTROL1B(1)
15888             END IF
15889             IF (cr .GE. 0.) THEN
15890               abs73 = cr
15891               CALL PUSHCONTROL1B(0)
15892             ELSE
15893               abs73 = -cr
15894               CALL PUSHCONTROL1B(1)
15895             END IF
15896             y73 = cr - abs73
15897             IF (-1.0 .LT. y73) THEN
15898               CALL PUSHREAL8(max23)
15899               max23 = y73
15900               CALL PUSHCONTROL1B(0)
15901             ELSE
15902               CALL PUSHREAL8(max23)
15903               max23 = -1.0
15904               CALL PUSHCONTROL1B(1)
15905             END IF
15906             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min32*field_old(i, k, j-1)+&
15907 &              0.5*max23*field_old(i, k, j))
15908             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
15909 &              -1))
15910             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15911           END DO
15912           CALL PUSHINTEGER4(i - 1)
15913           CALL PUSHINTEGER4(ad_from8)
15914         END DO
15915         CALL PUSHCONTROL2B(2)
15916       ELSE IF (j .EQ. jde - 1) THEN
15917 ! 2nd order flux next to north boundary
15918         DO k=kts,ktf
15919           ad_from9 = i_start
15920           DO i=ad_from9,i_end
15921             CALL PUSHREAL8(dy)
15922 ! ADT eqn 48 d/dy
15923             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
15924             CALL PUSHREAL8(mu)
15925             mu = 0.5*(mut(i, j)+mut(i, j-1))
15926             CALL PUSHREAL8(vel)
15927             vel = rv(i, k, j)
15928             cr = vel*dt/dy/mu
15929             IF (cr .GE. 0.) THEN
15930               abs23 = cr
15931               CALL PUSHCONTROL1B(0)
15932             ELSE
15933               abs23 = -cr
15934               CALL PUSHCONTROL1B(1)
15935             END IF
15936             y23 = cr + abs23
15937             IF (1.0 .GT. y23) THEN
15938               CALL PUSHREAL8(min33)
15939               min33 = y23
15940               CALL PUSHCONTROL1B(0)
15941             ELSE
15942               CALL PUSHREAL8(min33)
15943               min33 = 1.0
15944               CALL PUSHCONTROL1B(1)
15945             END IF
15946             IF (cr .GE. 0.) THEN
15947               abs74 = cr
15948               CALL PUSHCONTROL1B(0)
15949             ELSE
15950               abs74 = -cr
15951               CALL PUSHCONTROL1B(1)
15952             END IF
15953             y74 = cr - abs74
15954             IF (-1.0 .LT. y74) THEN
15955               CALL PUSHREAL8(max24)
15956               max24 = y74
15957               CALL PUSHCONTROL1B(0)
15958             ELSE
15959               CALL PUSHREAL8(max24)
15960               max24 = -1.0
15961               CALL PUSHCONTROL1B(1)
15962             END IF
15963             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min33*field_old(i, k, j-1)+&
15964 &              0.5*max24*field_old(i, k, j))
15965             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
15966 &              -1))
15967             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
15968           END DO
15969           CALL PUSHINTEGER4(i - 1)
15970           CALL PUSHINTEGER4(ad_from9)
15971         END DO
15972         CALL PUSHCONTROL2B(1)
15973       ELSE
15974         CALL PUSHCONTROL2B(0)
15975       END IF
15976     END DO j_loop_y_flux_4
15977     CALL PUSHINTEGER4(j - 1)
15978     CALL PUSHINTEGER4(ad_from10)
15979 !  next, x flux
15980 !--  these bounds are for periodic and sym conditions
15981     i_start = its - 1
15982     IF (ite .GT. ide - 1) THEN
15983       min34 = ide - 1
15984     ELSE
15985       min34 = ite
15986     END IF
15987     i_end = min34 + 1
15988     i_start_f = i_start
15989     i_end_f = i_end + 1
15990     j_start = jts - 1
15991     IF (jte .GT. jde - 1) THEN
15992       min35 = jde - 1
15993     ELSE
15994       min35 = jte
15995     END IF
15996     j_end = min35 + 1
15997 !--  modify loop bounds for open and specified b.c
15998     IF (degrade_ys) j_start = jts
15999     IF (degrade_ye) THEN
16000       IF (jte .GT. jde - 1) THEN
16001         j_end = jde - 1
16002       ELSE
16003         j_end = jte
16004       END IF
16005     END IF
16006     IF (degrade_xs) THEN
16007       IF (ids + 1 .LT. its) THEN
16008         i_start = its
16009       ELSE
16010         i_start = ids + 1
16011       END IF
16012       i_start_f = i_start + 1
16013     END IF
16014     IF (degrade_xe) THEN
16015       IF (ide - 2 .GT. ite) THEN
16016         i_end = ite
16017       ELSE
16018         i_end = ide - 2
16019       END IF
16020       i_end_f = ide - 2
16021     END IF
16022     ad_from11 = j_start
16023 !  compute fluxes
16024     DO j=ad_from11,j_end
16025 !  4th order flux
16026       DO k=kts,ktf
16027         CALL PUSHINTEGER4(i)
16028         DO i=i_start_f,i_end_f
16029           CALL PUSHREAL8(dx)
16030 ! ADT eqn 48 d/dx
16031           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16032           CALL PUSHREAL8(mu)
16033           mu = 0.5*(mut(i, j)+mut(i-1, j))
16034           CALL PUSHREAL8(vel)
16035           vel = ru(i, k, j)
16036           cr = vel*dt/dx/mu
16037           IF (cr .GE. 0.) THEN
16038             abs24 = cr
16039             CALL PUSHCONTROL1B(0)
16040           ELSE
16041             abs24 = -cr
16042             CALL PUSHCONTROL1B(1)
16043           END IF
16044           y24 = cr + abs24
16045           IF (1.0 .GT. y24) THEN
16046             CALL PUSHREAL8(min36)
16047             min36 = y24
16048             CALL PUSHCONTROL1B(0)
16049           ELSE
16050             CALL PUSHREAL8(min36)
16051             min36 = 1.0
16052             CALL PUSHCONTROL1B(1)
16053           END IF
16054           IF (cr .GE. 0.) THEN
16055             abs75 = cr
16056             CALL PUSHCONTROL1B(0)
16057           ELSE
16058             abs75 = -cr
16059             CALL PUSHCONTROL1B(1)
16060           END IF
16061           y75 = cr - abs75
16062           IF (-1.0 .LT. y75) THEN
16063             CALL PUSHREAL8(max25)
16064             max25 = y75
16065             CALL PUSHCONTROL1B(0)
16066           ELSE
16067             CALL PUSHREAL8(max25)
16068             max25 = -1.0
16069             CALL PUSHCONTROL1B(1)
16070           END IF
16071           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min36*field_old(i-1, k, j)+0.5&
16072 &            *max25*field_old(i, k, j))
16073           fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
16074 &            1./12.*(field(i+1, k, j)+field(i-2, k, j)))
16075           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16076         END DO
16077       END DO
16078 !  lower order fluxes close to boundaries (if not periodic or symmetric)
16079       IF (degrade_xs) THEN
16080         IF (i_start .EQ. ids + 1) THEN
16081           CALL PUSHINTEGER4(i)
16082 ! second order flux next to the boundary
16083           i = ids + 1
16084           DO k=kts,ktf
16085             CALL PUSHREAL8(dx)
16086 ! ADT eqn 48 d/dx
16087             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16088             CALL PUSHREAL8(mu)
16089             mu = 0.5*(mut(i, j)+mut(i-1, j))
16090             CALL PUSHREAL8(vel)
16091             vel = ru(i, k, j)/mu
16092             cr = vel*dt/dx
16093             IF (cr .GE. 0.) THEN
16094               abs25 = cr
16095               CALL PUSHCONTROL1B(0)
16096             ELSE
16097               abs25 = -cr
16098               CALL PUSHCONTROL1B(1)
16099             END IF
16100             y25 = cr + abs25
16101             IF (1.0 .GT. y25) THEN
16102               CALL PUSHREAL8(min37)
16103               min37 = y25
16104               CALL PUSHCONTROL1B(0)
16105             ELSE
16106               CALL PUSHREAL8(min37)
16107               min37 = 1.0
16108               CALL PUSHCONTROL1B(1)
16109             END IF
16110             IF (cr .GE. 0.) THEN
16111               abs76 = cr
16112               CALL PUSHCONTROL1B(0)
16113             ELSE
16114               abs76 = -cr
16115               CALL PUSHCONTROL1B(1)
16116             END IF
16117             y76 = cr - abs76
16118             IF (-1.0 .LT. y76) THEN
16119               CALL PUSHREAL8(max26)
16120               max26 = y76
16121               CALL PUSHCONTROL1B(0)
16122             ELSE
16123               CALL PUSHREAL8(max26)
16124               max26 = -1.0
16125               CALL PUSHCONTROL1B(1)
16126             END IF
16127             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min37*field_old(i-1, k, j)+&
16128 &              0.5*max26*field_old(i, k, j))
16129             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
16130 &              , j))
16131             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16132           END DO
16133           CALL PUSHCONTROL2B(0)
16134         ELSE
16135           CALL PUSHCONTROL2B(1)
16136         END IF
16137       ELSE
16138         CALL PUSHCONTROL2B(2)
16139       END IF
16140       IF (degrade_xe) THEN
16141         IF (i_end .EQ. ide - 2) THEN
16142           CALL PUSHINTEGER4(i)
16143 ! second order flux next to the boundary
16144           i = ide - 1
16145           DO k=kts,ktf
16146             CALL PUSHREAL8(dx)
16147 ! ADT eqn 48 d/dx
16148             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16149             CALL PUSHREAL8(mu)
16150             mu = 0.5*(mut(i, j)+mut(i-1, j))
16151             CALL PUSHREAL8(vel)
16152             vel = ru(i, k, j)
16153             cr = vel*dt/dx/mu
16154             IF (cr .GE. 0.) THEN
16155               abs26 = cr
16156               CALL PUSHCONTROL1B(0)
16157             ELSE
16158               abs26 = -cr
16159               CALL PUSHCONTROL1B(1)
16160             END IF
16161             y26 = cr + abs26
16162             IF (1.0 .GT. y26) THEN
16163               CALL PUSHREAL8(min38)
16164               min38 = y26
16165               CALL PUSHCONTROL1B(0)
16166             ELSE
16167               CALL PUSHREAL8(min38)
16168               min38 = 1.0
16169               CALL PUSHCONTROL1B(1)
16170             END IF
16171             IF (cr .GE. 0.) THEN
16172               abs77 = cr
16173               CALL PUSHCONTROL1B(0)
16174             ELSE
16175               abs77 = -cr
16176               CALL PUSHCONTROL1B(1)
16177             END IF
16178             y77 = cr - abs77
16179             IF (-1.0 .LT. y77) THEN
16180               CALL PUSHREAL8(max27)
16181               max27 = y77
16182               CALL PUSHCONTROL1B(0)
16183             ELSE
16184               CALL PUSHREAL8(max27)
16185               max27 = -1.0
16186               CALL PUSHCONTROL1B(1)
16187             END IF
16188             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min38*field_old(i-1, k, j)+&
16189 &              0.5*max27*field_old(i, k, j))
16190             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
16191 &              , j))
16192             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16193           END DO
16194           CALL PUSHCONTROL2B(2)
16195         ELSE
16196           CALL PUSHCONTROL2B(1)
16197         END IF
16198       ELSE
16199         CALL PUSHCONTROL2B(0)
16200       END IF
16201     END DO
16202     CALL PUSHINTEGER4(j - 1)
16203     CALL PUSHINTEGER4(ad_from11)
16204     CALL PUSHCONTROL3B(3)
16205   ELSE IF (horz_order .EQ. 3) THEN
16206 ! enddo for outer J loop
16207 !--- end of 4th order horizontal flux calculation
16208     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
16209 &        its .GT. ids + 2) degrade_xs = .false.
16210     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
16211 &        ite .LT. ide - 1) degrade_xe = .false.
16212     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
16213 &        jts .GT. jds + 2) degrade_ys = .false.
16214     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
16215 &        jte .LT. jde - 1) degrade_ye = .false.
16216     IF (kte .GT. kde - 1) THEN
16217       ktf = kde - 1
16218     ELSE
16219       ktf = kte
16220     END IF
16221     i_start = its - 1
16222     IF (ite .GT. ide - 1) THEN
16223       min39 = ide - 1
16224     ELSE
16225       min39 = ite
16226     END IF
16227     i_end = min39 + 1
16228     j_start = jts - 1
16229     IF (jte .GT. jde - 1) THEN
16230       min40 = jde - 1
16231     ELSE
16232       min40 = jte
16233     END IF
16234     j_end = min40 + 1
16235     j_start_f = j_start
16236     j_end_f = j_end + 1
16237 !--  modify loop bounds if open or specified
16238     IF (degrade_xs) i_start = its
16239     IF (degrade_xe) THEN
16240       IF (ite .GT. ide - 1) THEN
16241         i_end = ide - 1
16242       ELSE
16243         i_end = ite
16244       END IF
16245     END IF
16246     IF (degrade_ys) THEN
16247       IF (jts .LT. jds + 1) THEN
16248         j_start = jds + 1
16249       ELSE
16250         j_start = jts
16251       END IF
16252       j_start_f = jds + 2
16253     END IF
16254     IF (degrade_ye) THEN
16255       IF (jte .GT. jde - 2) THEN
16256         j_end = jde - 2
16257       ELSE
16258         j_end = jte
16259       END IF
16260       j_end_f = jde - 2
16261     END IF
16262     ad_from15 = j_start
16263 !  compute fluxes, 3rd order
16264 j_loop_y_flux_3:DO j=ad_from15,j_end+1
16265       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
16266 ! use full stencil
16267         DO k=kts,ktf
16268           ad_from12 = i_start
16269           DO i=ad_from12,i_end
16270             CALL PUSHREAL8(dy)
16271 ! ADT eqn 48 d/dy
16272             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
16273             CALL PUSHREAL8(mu)
16274             mu = 0.5*(mut(i, j)+mut(i, j-1))
16275             CALL PUSHREAL8(vel)
16276             vel = rv(i, k, j)
16277             cr = vel*dt/dy/mu
16278             IF (cr .GE. 0.) THEN
16279               abs27 = cr
16280               CALL PUSHCONTROL1B(0)
16281             ELSE
16282               abs27 = -cr
16283               CALL PUSHCONTROL1B(1)
16284             END IF
16285             y27 = cr + abs27
16286             IF (1.0 .GT. y27) THEN
16287               CALL PUSHREAL8(min41)
16288               min41 = y27
16289               CALL PUSHCONTROL1B(0)
16290             ELSE
16291               CALL PUSHREAL8(min41)
16292               min41 = 1.0
16293               CALL PUSHCONTROL1B(1)
16294             END IF
16295             IF (cr .GE. 0.) THEN
16296               abs78 = cr
16297               CALL PUSHCONTROL1B(0)
16298             ELSE
16299               abs78 = -cr
16300               CALL PUSHCONTROL1B(1)
16301             END IF
16302             y78 = cr - abs78
16303             IF (-1.0 .LT. y78) THEN
16304               CALL PUSHREAL8(max28)
16305               max28 = y78
16306               CALL PUSHCONTROL1B(0)
16307             ELSE
16308               CALL PUSHREAL8(max28)
16309               max28 = -1.0
16310               CALL PUSHCONTROL1B(1)
16311             END IF
16312             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min41*field_old(i, k, j-1)+&
16313 &              0.5*max28*field_old(i, k, j))
16314             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
16315 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
16316 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
16317 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
16318             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
16319           END DO
16320           CALL PUSHINTEGER4(i - 1)
16321           CALL PUSHINTEGER4(ad_from12)
16322         END DO
16323         CALL PUSHCONTROL2B(3)
16324       ELSE IF (j .EQ. jds + 1) THEN
16325 ! 2nd order flux next to south boundary
16326         DO k=kts,ktf
16327           ad_from13 = i_start
16328           DO i=ad_from13,i_end
16329             CALL PUSHREAL8(dy)
16330 ! ADT eqn 48 d/dy
16331             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
16332             CALL PUSHREAL8(mu)
16333             mu = 0.5*(mut(i, j)+mut(i, j-1))
16334             CALL PUSHREAL8(vel)
16335             vel = rv(i, k, j)
16336             cr = vel*dt/dy/mu
16337             IF (cr .GE. 0.) THEN
16338               abs28 = cr
16339               CALL PUSHCONTROL1B(0)
16340             ELSE
16341               abs28 = -cr
16342               CALL PUSHCONTROL1B(1)
16343             END IF
16344             y28 = cr + abs28
16345             IF (1.0 .GT. y28) THEN
16346               CALL PUSHREAL8(min42)
16347               min42 = y28
16348               CALL PUSHCONTROL1B(0)
16349             ELSE
16350               CALL PUSHREAL8(min42)
16351               min42 = 1.0
16352               CALL PUSHCONTROL1B(1)
16353             END IF
16354             IF (cr .GE. 0.) THEN
16355               abs79 = cr
16356               CALL PUSHCONTROL1B(0)
16357             ELSE
16358               abs79 = -cr
16359               CALL PUSHCONTROL1B(1)
16360             END IF
16361             y79 = cr - abs79
16362             IF (-1.0 .LT. y79) THEN
16363               CALL PUSHREAL8(max29)
16364               max29 = y79
16365               CALL PUSHCONTROL1B(0)
16366             ELSE
16367               CALL PUSHREAL8(max29)
16368               max29 = -1.0
16369               CALL PUSHCONTROL1B(1)
16370             END IF
16371             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min42*field_old(i, k, j-1)+&
16372 &              0.5*max29*field_old(i, k, j))
16373             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
16374 &              -1))
16375             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
16376           END DO
16377           CALL PUSHINTEGER4(i - 1)
16378           CALL PUSHINTEGER4(ad_from13)
16379         END DO
16380         CALL PUSHCONTROL2B(2)
16381       ELSE IF (j .EQ. jde - 1) THEN
16382 ! 2nd order flux next to north boundary
16383         DO k=kts,ktf
16384           ad_from14 = i_start
16385           DO i=ad_from14,i_end
16386             CALL PUSHREAL8(dy)
16387 ! ADT eqn 48 d/dy
16388             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
16389             CALL PUSHREAL8(mu)
16390             mu = 0.5*(mut(i, j)+mut(i, j-1))
16391             CALL PUSHREAL8(vel)
16392             vel = rv(i, k, j)
16393             cr = vel*dt/dy/mu
16394             IF (cr .GE. 0.) THEN
16395               abs29 = cr
16396               CALL PUSHCONTROL1B(0)
16397             ELSE
16398               abs29 = -cr
16399               CALL PUSHCONTROL1B(1)
16400             END IF
16401             y29 = cr + abs29
16402             IF (1.0 .GT. y29) THEN
16403               CALL PUSHREAL8(min43)
16404               min43 = y29
16405               CALL PUSHCONTROL1B(0)
16406             ELSE
16407               CALL PUSHREAL8(min43)
16408               min43 = 1.0
16409               CALL PUSHCONTROL1B(1)
16410             END IF
16411             IF (cr .GE. 0.) THEN
16412               abs80 = cr
16413               CALL PUSHCONTROL1B(0)
16414             ELSE
16415               abs80 = -cr
16416               CALL PUSHCONTROL1B(1)
16417             END IF
16418             y80 = cr - abs80
16419             IF (-1.0 .LT. y80) THEN
16420               CALL PUSHREAL8(max30)
16421               max30 = y80
16422               CALL PUSHCONTROL1B(0)
16423             ELSE
16424               CALL PUSHREAL8(max30)
16425               max30 = -1.0
16426               CALL PUSHCONTROL1B(1)
16427             END IF
16428             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min43*field_old(i, k, j-1)+&
16429 &              0.5*max30*field_old(i, k, j))
16430             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
16431 &              -1))
16432             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
16433           END DO
16434           CALL PUSHINTEGER4(i - 1)
16435           CALL PUSHINTEGER4(ad_from14)
16436         END DO
16437         CALL PUSHCONTROL2B(1)
16438       ELSE
16439         CALL PUSHCONTROL2B(0)
16440       END IF
16441     END DO j_loop_y_flux_3
16442     CALL PUSHINTEGER4(j - 1)
16443     CALL PUSHINTEGER4(ad_from15)
16444 !  next, x flux
16445 !--  these bounds are for periodic and sym conditions
16446     i_start = its - 1
16447     IF (ite .GT. ide - 1) THEN
16448       min44 = ide - 1
16449     ELSE
16450       min44 = ite
16451     END IF
16452     i_end = min44 + 1
16453     i_start_f = i_start
16454     i_end_f = i_end + 1
16455     j_start = jts - 1
16456     IF (jte .GT. jde - 1) THEN
16457       min45 = jde - 1
16458     ELSE
16459       min45 = jte
16460     END IF
16461     j_end = min45 + 1
16462 !--  modify loop bounds for open and specified b.c
16463     IF (degrade_ys) j_start = jts
16464     IF (degrade_ye) THEN
16465       IF (jte .GT. jde - 1) THEN
16466         j_end = jde - 1
16467       ELSE
16468         j_end = jte
16469       END IF
16470     END IF
16471     IF (degrade_xs) THEN
16472       IF (ids + 1 .LT. its) THEN
16473         i_start = its
16474       ELSE
16475         i_start = ids + 1
16476       END IF
16477       i_start_f = i_start + 1
16478     END IF
16479     IF (degrade_xe) THEN
16480       IF (ide - 2 .GT. ite) THEN
16481         i_end = ite
16482       ELSE
16483         i_end = ide - 2
16484       END IF
16485       i_end_f = ide - 2
16486     END IF
16487     ad_from16 = j_start
16488 !  compute fluxes
16489     DO j=ad_from16,j_end
16490 !  4th order flux
16491       DO k=kts,ktf
16492         CALL PUSHINTEGER4(i)
16493         DO i=i_start_f,i_end_f
16494           CALL PUSHREAL8(dx)
16495 ! ADT eqn 48 d/dx
16496           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16497           CALL PUSHREAL8(mu)
16498           mu = 0.5*(mut(i, j)+mut(i-1, j))
16499           CALL PUSHREAL8(vel)
16500           vel = ru(i, k, j)
16501           cr = vel*dt/dx/mu
16502           IF (cr .GE. 0.) THEN
16503             abs30 = cr
16504             CALL PUSHCONTROL1B(0)
16505           ELSE
16506             abs30 = -cr
16507             CALL PUSHCONTROL1B(1)
16508           END IF
16509           y30 = cr + abs30
16510           IF (1.0 .GT. y30) THEN
16511             CALL PUSHREAL8(min46)
16512             min46 = y30
16513             CALL PUSHCONTROL1B(0)
16514           ELSE
16515             CALL PUSHREAL8(min46)
16516             min46 = 1.0
16517             CALL PUSHCONTROL1B(1)
16518           END IF
16519           IF (cr .GE. 0.) THEN
16520             abs81 = cr
16521             CALL PUSHCONTROL1B(0)
16522           ELSE
16523             abs81 = -cr
16524             CALL PUSHCONTROL1B(1)
16525           END IF
16526           y81 = cr - abs81
16527           IF (-1.0 .LT. y81) THEN
16528             CALL PUSHREAL8(max31)
16529             max31 = y81
16530             CALL PUSHCONTROL1B(0)
16531           ELSE
16532             CALL PUSHREAL8(max31)
16533             max31 = -1.0
16534             CALL PUSHCONTROL1B(1)
16535           END IF
16536           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min46*field_old(i-1, k, j)+0.5&
16537 &            *max31*field_old(i, k, j))
16538           fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
16539 &            1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, time_step&
16540 &            )*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-&
16541 &            3.*(field(i, k, j)-field(i-1, k, j))))
16542           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16543         END DO
16544       END DO
16545 !  lower order fluxes close to boundaries (if not periodic or symmetric)
16546       IF (degrade_xs) THEN
16547         IF (i_start .EQ. ids + 1) THEN
16548           CALL PUSHINTEGER4(i)
16549 ! second order flux next to the boundary
16550           i = ids + 1
16551           DO k=kts,ktf
16552             CALL PUSHREAL8(dx)
16553 ! ADT eqn 48 d/dx
16554             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16555             CALL PUSHREAL8(mu)
16556             mu = 0.5*(mut(i, j)+mut(i-1, j))
16557             CALL PUSHREAL8(vel)
16558             vel = ru(i, k, j)/mu
16559             cr = vel*dt/dx
16560             IF (cr .GE. 0.) THEN
16561               abs31 = cr
16562               CALL PUSHCONTROL1B(0)
16563             ELSE
16564               abs31 = -cr
16565               CALL PUSHCONTROL1B(1)
16566             END IF
16567             y31 = cr + abs31
16568             IF (1.0 .GT. y31) THEN
16569               CALL PUSHREAL8(min47)
16570               min47 = y31
16571               CALL PUSHCONTROL1B(0)
16572             ELSE
16573               CALL PUSHREAL8(min47)
16574               min47 = 1.0
16575               CALL PUSHCONTROL1B(1)
16576             END IF
16577             IF (cr .GE. 0.) THEN
16578               abs82 = cr
16579               CALL PUSHCONTROL1B(0)
16580             ELSE
16581               abs82 = -cr
16582               CALL PUSHCONTROL1B(1)
16583             END IF
16584             y82 = cr - abs82
16585             IF (-1.0 .LT. y82) THEN
16586               CALL PUSHREAL8(max32)
16587               max32 = y82
16588               CALL PUSHCONTROL1B(0)
16589             ELSE
16590               CALL PUSHREAL8(max32)
16591               max32 = -1.0
16592               CALL PUSHCONTROL1B(1)
16593             END IF
16594             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min47*field_old(i-1, k, j)+&
16595 &              0.5*max32*field_old(i, k, j))
16596             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
16597 &              , j))
16598             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16599           END DO
16600           CALL PUSHCONTROL2B(0)
16601         ELSE
16602           CALL PUSHCONTROL2B(1)
16603         END IF
16604       ELSE
16605         CALL PUSHCONTROL2B(2)
16606       END IF
16607       IF (degrade_xe) THEN
16608         IF (i_end .EQ. ide - 2) THEN
16609           CALL PUSHINTEGER4(i)
16610 ! second order flux next to the boundary
16611           i = ide - 1
16612           DO k=kts,ktf
16613             CALL PUSHREAL8(dx)
16614 ! ADT eqn 48 d/dx
16615             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16616             CALL PUSHREAL8(mu)
16617             mu = 0.5*(mut(i, j)+mut(i-1, j))
16618             CALL PUSHREAL8(vel)
16619             vel = ru(i, k, j)
16620             cr = vel*dt/dx/mu
16621             IF (cr .GE. 0.) THEN
16622               abs32 = cr
16623               CALL PUSHCONTROL1B(0)
16624             ELSE
16625               abs32 = -cr
16626               CALL PUSHCONTROL1B(1)
16627             END IF
16628             y32 = cr + abs32
16629             IF (1.0 .GT. y32) THEN
16630               CALL PUSHREAL8(min48)
16631               min48 = y32
16632               CALL PUSHCONTROL1B(0)
16633             ELSE
16634               CALL PUSHREAL8(min48)
16635               min48 = 1.0
16636               CALL PUSHCONTROL1B(1)
16637             END IF
16638             IF (cr .GE. 0.) THEN
16639               abs83 = cr
16640               CALL PUSHCONTROL1B(0)
16641             ELSE
16642               abs83 = -cr
16643               CALL PUSHCONTROL1B(1)
16644             END IF
16645             y83 = cr - abs83
16646             IF (-1.0 .LT. y83) THEN
16647               CALL PUSHREAL8(max33)
16648               max33 = y83
16649               CALL PUSHCONTROL1B(0)
16650             ELSE
16651               CALL PUSHREAL8(max33)
16652               max33 = -1.0
16653               CALL PUSHCONTROL1B(1)
16654             END IF
16655             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min48*field_old(i-1, k, j)+&
16656 &              0.5*max33*field_old(i, k, j))
16657             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
16658 &              , j))
16659             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16660           END DO
16661           CALL PUSHCONTROL2B(2)
16662         ELSE
16663           CALL PUSHCONTROL2B(1)
16664         END IF
16665       ELSE
16666         CALL PUSHCONTROL2B(0)
16667       END IF
16668     END DO
16669     CALL PUSHINTEGER4(j - 1)
16670     CALL PUSHINTEGER4(ad_from16)
16671     CALL PUSHCONTROL3B(2)
16672   ELSE IF (horz_order .EQ. 2) THEN
16673 ! enddo for outer J loop
16674 !--- end of 3rd order horizontal flux calculation
16675     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
16676 &        its .GT. ids + 1) degrade_xs = .false.
16677     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
16678 &        ite .LT. ide - 2) degrade_xe = .false.
16679     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
16680 &        jts .GT. jds + 1) degrade_ys = .false.
16681     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
16682 &        jte .LT. jde - 2) degrade_ye = .false.
16683     IF (kte .GT. kde - 1) THEN
16684       ktf = kde - 1
16685     ELSE
16686       ktf = kte
16687     END IF
16688     i_start = its - 1
16689     IF (ite .GT. ide - 1) THEN
16690       min49 = ide - 1
16691     ELSE
16692       min49 = ite
16693     END IF
16694     i_end = min49 + 1
16695     j_start = jts - 1
16696     IF (jte .GT. jde - 1) THEN
16697       min50 = jde - 1
16698     ELSE
16699       min50 = jte
16700     END IF
16701     j_end = min50 + 1
16702 !--  modify loop bounds if open or specified
16703     IF (degrade_xs) i_start = its
16704     IF (degrade_xe) THEN
16705       IF (ite .GT. ide - 1) THEN
16706         i_end = ide - 1
16707       ELSE
16708         i_end = ite
16709       END IF
16710     END IF
16711     IF (degrade_ys) THEN
16712       IF (jts .LT. jds + 1) THEN
16713         j_start = jds + 1
16714       ELSE
16715         j_start = jts
16716       END IF
16717     END IF
16718     IF (degrade_ye) THEN
16719       IF (jte .GT. jde - 2) THEN
16720         j_end = jde - 2
16721       ELSE
16722         j_end = jte
16723       END IF
16724     END IF
16725     ad_from18 = j_start
16726 !  compute fluxes, 2nd order, y flux
16727     DO j=ad_from18,j_end+1
16728       DO k=kts,ktf
16729         ad_from17 = i_start
16730         DO i=ad_from17,i_end
16731           CALL PUSHREAL8(dy)
16732 ! ADT eqn 48 d/dy
16733           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
16734           CALL PUSHREAL8(mu)
16735           mu = 0.5*(mut(i, j)+mut(i, j-1))
16736           CALL PUSHREAL8(vel)
16737           vel = rv(i, k, j)
16738           cr = vel*dt/dy/mu
16739           IF (cr .GE. 0.) THEN
16740             abs33 = cr
16741             CALL PUSHCONTROL1B(0)
16742           ELSE
16743             abs33 = -cr
16744             CALL PUSHCONTROL1B(1)
16745           END IF
16746           y33 = cr + abs33
16747           IF (1.0 .GT. y33) THEN
16748             CALL PUSHREAL8(min51)
16749             min51 = y33
16750             CALL PUSHCONTROL1B(0)
16751           ELSE
16752             CALL PUSHREAL8(min51)
16753             min51 = 1.0
16754             CALL PUSHCONTROL1B(1)
16755           END IF
16756           IF (cr .GE. 0.) THEN
16757             abs84 = cr
16758             CALL PUSHCONTROL1B(0)
16759           ELSE
16760             abs84 = -cr
16761             CALL PUSHCONTROL1B(1)
16762           END IF
16763           y84 = cr - abs84
16764           IF (-1.0 .LT. y84) THEN
16765             CALL PUSHREAL8(max34)
16766             max34 = y84
16767             CALL PUSHCONTROL1B(0)
16768           ELSE
16769             CALL PUSHREAL8(max34)
16770             max34 = -1.0
16771             CALL PUSHCONTROL1B(1)
16772           END IF
16773           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min51*field_old(i, k, j-1)+0.5&
16774 &            *max34*field_old(i, k, j))
16775           fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
16776 &            ))
16777           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
16778         END DO
16779         CALL PUSHINTEGER4(i - 1)
16780         CALL PUSHINTEGER4(ad_from17)
16781       END DO
16782     END DO
16783     CALL PUSHINTEGER4(j - 1)
16784     CALL PUSHINTEGER4(ad_from18)
16785     ad_from20 = j_start
16786 !  next, x flux
16787     DO j=ad_from20,j_end
16788       DO k=kts,ktf
16789         ad_from19 = i_start
16790         DO i=ad_from19,i_end+1
16791           CALL PUSHREAL8(dx)
16792 ! ADT eqn 48 d/dx
16793           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
16794           CALL PUSHREAL8(mu)
16795           mu = 0.5*(mut(i, j)+mut(i-1, j))
16796           CALL PUSHREAL8(vel)
16797           vel = ru(i, k, j)
16798           cr = vel*dt/dx/mu
16799           IF (cr .GE. 0.) THEN
16800             abs34 = cr
16801             CALL PUSHCONTROL1B(0)
16802           ELSE
16803             abs34 = -cr
16804             CALL PUSHCONTROL1B(1)
16805           END IF
16806           y34 = cr + abs34
16807           IF (1.0 .GT. y34) THEN
16808             CALL PUSHREAL8(min52)
16809             min52 = y34
16810             CALL PUSHCONTROL1B(0)
16811           ELSE
16812             CALL PUSHREAL8(min52)
16813             min52 = 1.0
16814             CALL PUSHCONTROL1B(1)
16815           END IF
16816           IF (cr .GE. 0.) THEN
16817             abs85 = cr
16818             CALL PUSHCONTROL1B(0)
16819           ELSE
16820             abs85 = -cr
16821             CALL PUSHCONTROL1B(1)
16822           END IF
16823           y85 = cr - abs85
16824           IF (-1.0 .LT. y85) THEN
16825             CALL PUSHREAL8(max35)
16826             max35 = y85
16827             CALL PUSHCONTROL1B(0)
16828           ELSE
16829             CALL PUSHREAL8(max35)
16830             max35 = -1.0
16831             CALL PUSHCONTROL1B(1)
16832           END IF
16833           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min52*field_old(i-1, k, j)+0.5&
16834 &            *max35*field_old(i, k, j))
16835           fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, j&
16836 &            ))
16837           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
16838         END DO
16839         CALL PUSHINTEGER4(i - 1)
16840         CALL PUSHINTEGER4(ad_from19)
16841       END DO
16842     END DO
16843     CALL PUSHINTEGER4(j - 1)
16844     CALL PUSHINTEGER4(ad_from20)
16845     CALL PUSHCONTROL3B(1)
16846   ELSE
16847     CALL PUSHCONTROL3B(0)
16848   END IF
16849 !  pick up the rest of the horizontal radiation boundary conditions.
16850 !  (these are the computations that don't require 'cb'.
16851 !  first, set to index ranges
16852   i_start = its
16853   IF (ite .GT. ide - 1) THEN
16854     i_end = ide - 1
16855   ELSE
16856     i_end = ite
16857   END IF
16858   j_start = jts
16859   IF (jte .GT. jde - 1) THEN
16860     j_end = jde - 1
16861   ELSE
16862     j_end = jte
16863   END IF
16864 !  compute x (u) conditions for v, w, or scalar
16865   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
16866     ad_from29 = j_start
16867     DO j=ad_from29,j_end
16868       DO k=kts,ktf
16869         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
16870           CALL PUSHREAL8(ub)
16871           ub = 0.
16872           CALL PUSHCONTROL1B(0)
16873         ELSE
16874           CALL PUSHREAL8(ub)
16875           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
16876           CALL PUSHCONTROL1B(1)
16877         END IF
16878       END DO
16879     END DO
16880     CALL PUSHINTEGER4(j - 1)
16881     CALL PUSHINTEGER4(ad_from29)
16882     CALL PUSHCONTROL1B(0)
16883   ELSE
16884     CALL PUSHCONTROL1B(1)
16885   END IF
16886   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
16887     ad_from30 = j_start
16888     DO j=ad_from30,j_end
16889       DO k=kts,ktf
16890         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
16891           CALL PUSHREAL8(ub)
16892           ub = 0.
16893           CALL PUSHCONTROL1B(0)
16894         ELSE
16895           CALL PUSHREAL8(ub)
16896           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
16897           CALL PUSHCONTROL1B(1)
16898         END IF
16899       END DO
16900     END DO
16901     CALL PUSHINTEGER4(j - 1)
16902     CALL PUSHINTEGER4(ad_from30)
16903     CALL PUSHCONTROL1B(0)
16904   ELSE
16905     CALL PUSHCONTROL1B(1)
16906   END IF
16907   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
16908     ad_from31 = i_start
16909     CALL PUSHINTEGER4(i)
16910     DO i=ad_from31,i_end
16911       DO k=kts,ktf
16912         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
16913           CALL PUSHREAL8(vb)
16914           vb = 0.
16915           CALL PUSHCONTROL1B(0)
16916         ELSE
16917           CALL PUSHREAL8(vb)
16918           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
16919           CALL PUSHCONTROL1B(1)
16920         END IF
16921       END DO
16922     END DO
16923     CALL PUSHINTEGER4(i - 1)
16924     CALL PUSHINTEGER4(ad_from31)
16925     CALL PUSHCONTROL1B(0)
16926   ELSE
16927     CALL PUSHCONTROL1B(1)
16928   END IF
16929   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
16930     ad_from32 = i_start
16931     CALL PUSHINTEGER4(i)
16932     DO i=ad_from32,i_end
16933       DO k=kts,ktf
16934         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
16935           CALL PUSHREAL8(vb)
16936           vb = 0.
16937           CALL PUSHCONTROL1B(0)
16938         ELSE
16939           CALL PUSHREAL8(vb)
16940           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
16941           CALL PUSHCONTROL1B(1)
16942         END IF
16943       END DO
16944     END DO
16945     CALL PUSHINTEGER4(i - 1)
16946     CALL PUSHINTEGER4(ad_from32)
16947     CALL PUSHCONTROL1B(0)
16948   ELSE
16949     CALL PUSHCONTROL1B(1)
16950   END IF
16951   IF (config_flags%polar .AND. jts .EQ. jds) THEN
16952     ad_from33 = i_start
16953     CALL PUSHINTEGER4(i)
16954 ! Assuming rv(i,k,jds) = 0.
16955     DO i=ad_from33,i_end
16956       DO k=kts,ktf
16957         IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN
16958           CALL PUSHREAL8(vb)
16959           vb = 0.
16960           CALL PUSHCONTROL1B(0)
16961         ELSE
16962           CALL PUSHREAL8(vb)
16963           vb = 0.5*rv(i, k, jts+1)
16964           CALL PUSHCONTROL1B(1)
16965         END IF
16966       END DO
16967     END DO
16968     CALL PUSHINTEGER4(i - 1)
16969     CALL PUSHINTEGER4(ad_from33)
16970     CALL PUSHCONTROL1B(0)
16971   ELSE
16972     CALL PUSHCONTROL1B(1)
16973   END IF
16974   IF (config_flags%polar .AND. jte .EQ. jde) THEN
16975     ad_from34 = i_start
16976     CALL PUSHINTEGER4(i)
16977 ! Assuming rv(i,k,jde) = 0.
16978     DO i=ad_from34,i_end
16979       DO k=kts,ktf
16980         IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN
16981           CALL PUSHREAL8(vb)
16982           vb = 0.
16983           CALL PUSHCONTROL1B(0)
16984         ELSE
16985           CALL PUSHREAL8(vb)
16986           vb = 0.5*rv(i, k, jte-1)
16987           CALL PUSHCONTROL1B(1)
16988         END IF
16989       END DO
16990     END DO
16991     CALL PUSHINTEGER4(i - 1)
16992     CALL PUSHINTEGER4(ad_from34)
16993     CALL PUSHCONTROL1B(1)
16994   ELSE
16995     CALL PUSHCONTROL1B(0)
16996   END IF
16997 !-------------------- vertical advection
16998 !-- loop bounds for periodic or sym conditions
16999   i_start = its - 1
17000   IF (ite .GT. ide - 1) THEN
17001     min53 = ide - 1
17002   ELSE
17003     min53 = ite
17004   END IF
17005   CALL PUSHINTEGER4(i_end)
17006   i_end = min53 + 1
17007   j_start = jts - 1
17008   IF (jte .GT. jde - 1) THEN
17009     min54 = jde - 1
17010   ELSE
17011     min54 = jte
17012   END IF
17013   CALL PUSHINTEGER4(j_end)
17014   j_end = min54 + 1
17015 !-- loop bounds for open or specified conditions
17016   IF (degrade_xs) THEN
17017     IF (its - 1 .LT. ids) THEN
17018       i_start = ids
17019     ELSE
17020       i_start = its - 1
17021     END IF
17022   END IF
17023   IF (degrade_xe) THEN
17024     IF (ite + 1 .GT. ide - 1) THEN
17025       i_end = ide - 1
17026     ELSE
17027       i_end = ite + 1
17028     END IF
17029   END IF
17030   IF (degrade_ys) THEN
17031     IF (jts - 1 .LT. jds) THEN
17032       j_start = jds
17033     ELSE
17034       j_start = jts - 1
17035     END IF
17036   END IF
17037   IF (degrade_ye) THEN
17038     IF (jte + 1 .GT. jde - 1) THEN
17039       j_end = jde - 1
17040     ELSE
17041       j_end = jte + 1
17042     END IF
17043   END IF
17044   IF (vert_order .EQ. 6) THEN
17045     ad_from38 = j_start
17046     DO j=ad_from38,j_end
17047       ad_from35 = i_start
17048       CALL PUSHINTEGER4(i)
17049       DO i=ad_from35,i_end
17050         fqz(i, 1, j) = 0.
17051         fqzl(i, 1, j) = 0.
17052         fqz(i, kde, j) = 0.
17053         fqzl(i, kde, j) = 0.
17054       END DO
17055       CALL PUSHINTEGER4(i - 1)
17056       CALL PUSHINTEGER4(ad_from35)
17057       CALL PUSHINTEGER4(k)
17058       DO k=kts+3,ktf-2
17059         ad_from36 = i_start
17060         DO i=ad_from36,i_end
17061           CALL PUSHREAL8(dz)
17062           dz = 2./(rdzw(k)+rdzw(k-1))
17063           CALL PUSHREAL8(mu)
17064           mu = 0.5*(mut(i, j)+mut(i, j))
17065           CALL PUSHREAL8(vel)
17066           vel = rom(i, k, j)
17067           cr = vel*dt/dz/mu
17068           IF (cr .GE. 0.) THEN
17069             abs35 = cr
17070             CALL PUSHCONTROL1B(0)
17071           ELSE
17072             abs35 = -cr
17073             CALL PUSHCONTROL1B(1)
17074           END IF
17075           y35 = cr + abs35
17076           IF (1.0 .GT. y35) THEN
17077             CALL PUSHREAL8(min55)
17078             min55 = y35
17079             CALL PUSHCONTROL1B(0)
17080           ELSE
17081             CALL PUSHREAL8(min55)
17082             min55 = 1.0
17083             CALL PUSHCONTROL1B(1)
17084           END IF
17085           IF (cr .GE. 0.) THEN
17086             abs86 = cr
17087             CALL PUSHCONTROL1B(0)
17088           ELSE
17089             abs86 = -cr
17090             CALL PUSHCONTROL1B(1)
17091           END IF
17092           y86 = cr - abs86
17093           IF (-1.0 .LT. y86) THEN
17094             CALL PUSHREAL8(max36)
17095             max36 = y86
17096             CALL PUSHCONTROL1B(0)
17097           ELSE
17098             CALL PUSHREAL8(max36)
17099             max36 = -1.0
17100             CALL PUSHCONTROL1B(1)
17101           END IF
17102           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min55*field_old(i, k-1, j)+0.5&
17103 &            *max36*field_old(i, k, j))
17104           fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-&
17105 &            2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, &
17106 &            k+2, j)+field(i, k-3, j)))
17107           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17108         END DO
17109         CALL PUSHINTEGER4(i - 1)
17110         CALL PUSHINTEGER4(ad_from36)
17111       END DO
17112       ad_from37 = i_start
17113       DO i=ad_from37,i_end
17114         CALL PUSHINTEGER4(k)
17115         k = kts + 1
17116         CALL PUSHREAL8(dz)
17117         dz = 2./(rdzw(k)+rdzw(k-1))
17118         CALL PUSHREAL8(mu)
17119         mu = 0.5*(mut(i, j)+mut(i, j))
17120         CALL PUSHREAL8(vel)
17121         vel = rom(i, k, j)
17122         cr = vel*dt/dz/mu
17123         IF (cr .GE. 0.) THEN
17124           abs36 = cr
17125           CALL PUSHCONTROL1B(0)
17126         ELSE
17127           abs36 = -cr
17128           CALL PUSHCONTROL1B(1)
17129         END IF
17130         y36 = cr + abs36
17131         IF (1.0 .GT. y36) THEN
17132           CALL PUSHREAL8(min56)
17133           min56 = y36
17134           CALL PUSHCONTROL1B(0)
17135         ELSE
17136           CALL PUSHREAL8(min56)
17137           min56 = 1.0
17138           CALL PUSHCONTROL1B(1)
17139         END IF
17140         IF (cr .GE. 0.) THEN
17141           abs87 = cr
17142           CALL PUSHCONTROL1B(0)
17143         ELSE
17144           abs87 = -cr
17145           CALL PUSHCONTROL1B(1)
17146         END IF
17147         y87 = cr - abs87
17148         IF (-1.0 .LT. y87) THEN
17149           CALL PUSHREAL8(max37)
17150           max37 = y87
17151           CALL PUSHCONTROL1B(0)
17152         ELSE
17153           CALL PUSHREAL8(max37)
17154           max37 = -1.0
17155           CALL PUSHCONTROL1B(1)
17156         END IF
17157         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min56*field_old(i, k-1, j)+0.5*&
17158 &          max37*field_old(i, k, j))
17159         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17160 &          i, k-1, j))
17161         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17162         k = kts + 2
17163         CALL PUSHREAL8(dz)
17164         dz = 2./(rdzw(k)+rdzw(k-1))
17165         mu = 0.5*(mut(i, j)+mut(i, j))
17166         CALL PUSHREAL8(vel)
17167         vel = rom(i, k, j)
17168         cr = vel*dt/dz/mu
17169         IF (cr .GE. 0.) THEN
17170           abs37 = cr
17171           CALL PUSHCONTROL1B(0)
17172         ELSE
17173           abs37 = -cr
17174           CALL PUSHCONTROL1B(1)
17175         END IF
17176         y37 = cr + abs37
17177         IF (1.0 .GT. y37) THEN
17178           CALL PUSHREAL8(min57)
17179           min57 = y37
17180           CALL PUSHCONTROL1B(0)
17181         ELSE
17182           CALL PUSHREAL8(min57)
17183           min57 = 1.0
17184           CALL PUSHCONTROL1B(1)
17185         END IF
17186         IF (cr .GE. 0.) THEN
17187           abs88 = cr
17188           CALL PUSHCONTROL1B(0)
17189         ELSE
17190           abs88 = -cr
17191           CALL PUSHCONTROL1B(1)
17192         END IF
17193         y88 = cr - abs88
17194         IF (-1.0 .LT. y88) THEN
17195           CALL PUSHREAL8(max38)
17196           max38 = y88
17197           CALL PUSHCONTROL1B(0)
17198         ELSE
17199           CALL PUSHREAL8(max38)
17200           max38 = -1.0
17201           CALL PUSHCONTROL1B(1)
17202         END IF
17203         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min57*field_old(i, k-1, j)+0.5*&
17204 &          max38*field_old(i, k, j))
17205         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
17206 &          12.*(field(i, k+1, j)+field(i, k-2, j)))
17207         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17208         k = ktf - 1
17209         CALL PUSHREAL8(dz)
17210         dz = 2./(rdzw(k)+rdzw(k-1))
17211         mu = 0.5*(mut(i, j)+mut(i, j))
17212         CALL PUSHREAL8(vel)
17213         vel = rom(i, k, j)
17214         cr = vel*dt/dz/mu
17215         IF (cr .GE. 0.) THEN
17216           abs38 = cr
17217           CALL PUSHCONTROL1B(0)
17218         ELSE
17219           abs38 = -cr
17220           CALL PUSHCONTROL1B(1)
17221         END IF
17222         y38 = cr + abs38
17223         IF (1.0 .GT. y38) THEN
17224           CALL PUSHREAL8(min58)
17225           min58 = y38
17226           CALL PUSHCONTROL1B(0)
17227         ELSE
17228           CALL PUSHREAL8(min58)
17229           min58 = 1.0
17230           CALL PUSHCONTROL1B(1)
17231         END IF
17232         IF (cr .GE. 0.) THEN
17233           abs89 = cr
17234           CALL PUSHCONTROL1B(0)
17235         ELSE
17236           abs89 = -cr
17237           CALL PUSHCONTROL1B(1)
17238         END IF
17239         y89 = cr - abs89
17240         IF (-1.0 .LT. y89) THEN
17241           CALL PUSHREAL8(max39)
17242           max39 = y89
17243           CALL PUSHCONTROL1B(0)
17244         ELSE
17245           CALL PUSHREAL8(max39)
17246           max39 = -1.0
17247           CALL PUSHCONTROL1B(1)
17248         END IF
17249         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min58*field_old(i, k-1, j)+0.5*&
17250 &          max39*field_old(i, k, j))
17251         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
17252 &          12.*(field(i, k+1, j)+field(i, k-2, j)))
17253         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17254         k = ktf
17255         CALL PUSHREAL8(dz)
17256         dz = 2./(rdzw(k)+rdzw(k-1))
17257         mu = 0.5*(mut(i, j)+mut(i, j))
17258         CALL PUSHREAL8(vel)
17259         vel = rom(i, k, j)
17260         cr = vel*dt/dz/mu
17261         IF (cr .GE. 0.) THEN
17262           abs39 = cr
17263           CALL PUSHCONTROL1B(0)
17264         ELSE
17265           abs39 = -cr
17266           CALL PUSHCONTROL1B(1)
17267         END IF
17268         y39 = cr + abs39
17269         IF (1.0 .GT. y39) THEN
17270           CALL PUSHREAL8(min59)
17271           min59 = y39
17272           CALL PUSHCONTROL1B(0)
17273         ELSE
17274           CALL PUSHREAL8(min59)
17275           min59 = 1.0
17276           CALL PUSHCONTROL1B(1)
17277         END IF
17278         IF (cr .GE. 0.) THEN
17279           abs90 = cr
17280           CALL PUSHCONTROL1B(0)
17281         ELSE
17282           abs90 = -cr
17283           CALL PUSHCONTROL1B(1)
17284         END IF
17285         y90 = cr - abs90
17286         IF (-1.0 .LT. y90) THEN
17287           CALL PUSHREAL8(max40)
17288           max40 = y90
17289           CALL PUSHCONTROL1B(0)
17290         ELSE
17291           CALL PUSHREAL8(max40)
17292           max40 = -1.0
17293           CALL PUSHCONTROL1B(1)
17294         END IF
17295         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min59*field_old(i, k-1, j)+0.5*&
17296 &          max40*field_old(i, k, j))
17297         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17298 &          i, k-1, j))
17299         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17300       END DO
17301       CALL PUSHINTEGER4(i - 1)
17302       CALL PUSHINTEGER4(ad_from37)
17303     END DO
17304     CALL PUSHINTEGER4(j - 1)
17305     CALL PUSHINTEGER4(ad_from38)
17306     CALL PUSHCONTROL3B(0)
17307   ELSE IF (vert_order .EQ. 5) THEN
17308     ad_from42 = j_start
17309     DO j=ad_from42,j_end
17310       ad_from39 = i_start
17311       CALL PUSHINTEGER4(i)
17312       DO i=ad_from39,i_end
17313         fqz(i, 1, j) = 0.
17314         fqzl(i, 1, j) = 0.
17315         fqz(i, kde, j) = 0.
17316         fqzl(i, kde, j) = 0.
17317       END DO
17318       CALL PUSHINTEGER4(i - 1)
17319       CALL PUSHINTEGER4(ad_from39)
17320       CALL PUSHINTEGER4(k)
17321       DO k=kts+3,ktf-2
17322         ad_from40 = i_start
17323         DO i=ad_from40,i_end
17324           CALL PUSHREAL8(dz)
17325           dz = 2./(rdzw(k)+rdzw(k-1))
17326           CALL PUSHREAL8(mu)
17327           mu = 0.5*(mut(i, j)+mut(i, j))
17328           CALL PUSHREAL8(vel)
17329           vel = rom(i, k, j)
17330           cr = vel*dt/dz/mu
17331           IF (cr .GE. 0.) THEN
17332             abs40 = cr
17333             CALL PUSHCONTROL1B(0)
17334           ELSE
17335             abs40 = -cr
17336             CALL PUSHCONTROL1B(1)
17337           END IF
17338           y40 = cr + abs40
17339           IF (1.0 .GT. y40) THEN
17340             CALL PUSHREAL8(min60)
17341             min60 = y40
17342             CALL PUSHCONTROL1B(0)
17343           ELSE
17344             CALL PUSHREAL8(min60)
17345             min60 = 1.0
17346             CALL PUSHCONTROL1B(1)
17347           END IF
17348           IF (cr .GE. 0.) THEN
17349             abs91 = cr
17350             CALL PUSHCONTROL1B(0)
17351           ELSE
17352             abs91 = -cr
17353             CALL PUSHCONTROL1B(1)
17354           END IF
17355           y91 = cr - abs91
17356           IF (-1.0 .LT. y91) THEN
17357             CALL PUSHREAL8(max41)
17358             max41 = y91
17359             CALL PUSHCONTROL1B(0)
17360           ELSE
17361             CALL PUSHREAL8(max41)
17362             max41 = -1.0
17363             CALL PUSHCONTROL1B(1)
17364           END IF
17365           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min60*field_old(i, k-1, j)+0.5&
17366 &            *max41*field_old(i, k, j))
17367           fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-&
17368 &            2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, &
17369 &            k+2, j)+field(i, k-3, j))-SIGN(1, time_step)*SIGN(1., -vel)*&
17370 &            (1./60.)*(field(i, k+2, j)-field(i, k-3, j)-5.*(field(i, k+1&
17371 &            , j)-field(i, k-2, j))+10.*(field(i, k, j)-field(i, k-1, j))&
17372 &            ))
17373           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17374         END DO
17375         CALL PUSHINTEGER4(i - 1)
17376         CALL PUSHINTEGER4(ad_from40)
17377       END DO
17378       ad_from41 = i_start
17379       DO i=ad_from41,i_end
17380         CALL PUSHINTEGER4(k)
17381         k = kts + 1
17382         CALL PUSHREAL8(dz)
17383         dz = 2./(rdzw(k)+rdzw(k-1))
17384         CALL PUSHREAL8(mu)
17385         mu = 0.5*(mut(i, j)+mut(i, j))
17386         CALL PUSHREAL8(vel)
17387         vel = rom(i, k, j)
17388         cr = vel*dt/dz/mu
17389         IF (cr .GE. 0.) THEN
17390           abs41 = cr
17391           CALL PUSHCONTROL1B(0)
17392         ELSE
17393           abs41 = -cr
17394           CALL PUSHCONTROL1B(1)
17395         END IF
17396         y41 = cr + abs41
17397         IF (1.0 .GT. y41) THEN
17398           CALL PUSHREAL8(min61)
17399           min61 = y41
17400           CALL PUSHCONTROL1B(0)
17401         ELSE
17402           CALL PUSHREAL8(min61)
17403           min61 = 1.0
17404           CALL PUSHCONTROL1B(1)
17405         END IF
17406         IF (cr .GE. 0.) THEN
17407           abs92 = cr
17408           CALL PUSHCONTROL1B(0)
17409         ELSE
17410           abs92 = -cr
17411           CALL PUSHCONTROL1B(1)
17412         END IF
17413         y92 = cr - abs92
17414         IF (-1.0 .LT. y92) THEN
17415           CALL PUSHREAL8(max42)
17416           max42 = y92
17417           CALL PUSHCONTROL1B(0)
17418         ELSE
17419           CALL PUSHREAL8(max42)
17420           max42 = -1.0
17421           CALL PUSHCONTROL1B(1)
17422         END IF
17423         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min61*field_old(i, k-1, j)+0.5*&
17424 &          max42*field_old(i, k, j))
17425         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17426 &          i, k-1, j))
17427         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17428         k = kts + 2
17429         CALL PUSHREAL8(dz)
17430         dz = 2./(rdzw(k)+rdzw(k-1))
17431         mu = 0.5*(mut(i, j)+mut(i, j))
17432         CALL PUSHREAL8(vel)
17433         vel = rom(i, k, j)
17434         cr = vel*dt/dz/mu
17435         IF (cr .GE. 0.) THEN
17436           abs42 = cr
17437           CALL PUSHCONTROL1B(0)
17438         ELSE
17439           abs42 = -cr
17440           CALL PUSHCONTROL1B(1)
17441         END IF
17442         y42 = cr + abs42
17443         IF (1.0 .GT. y42) THEN
17444           CALL PUSHREAL8(min62)
17445           min62 = y42
17446           CALL PUSHCONTROL1B(0)
17447         ELSE
17448           CALL PUSHREAL8(min62)
17449           min62 = 1.0
17450           CALL PUSHCONTROL1B(1)
17451         END IF
17452         IF (cr .GE. 0.) THEN
17453           abs93 = cr
17454           CALL PUSHCONTROL1B(0)
17455         ELSE
17456           abs93 = -cr
17457           CALL PUSHCONTROL1B(1)
17458         END IF
17459         y93 = cr - abs93
17460         IF (-1.0 .LT. y93) THEN
17461           CALL PUSHREAL8(max43)
17462           max43 = y93
17463           CALL PUSHCONTROL1B(0)
17464         ELSE
17465           CALL PUSHREAL8(max43)
17466           max43 = -1.0
17467           CALL PUSHCONTROL1B(1)
17468         END IF
17469         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min62*field_old(i, k-1, j)+0.5*&
17470 &          max43*field_old(i, k, j))
17471         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
17472 &          12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
17473 &          SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
17474 &          (field(i, k, j)-field(i, k-1, j))))
17475         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17476         k = ktf - 1
17477         CALL PUSHREAL8(dz)
17478         dz = 2./(rdzw(k)+rdzw(k-1))
17479         mu = 0.5*(mut(i, j)+mut(i, j))
17480         CALL PUSHREAL8(vel)
17481         vel = rom(i, k, j)
17482         cr = vel*dt/dz/mu
17483         IF (cr .GE. 0.) THEN
17484           abs43 = cr
17485           CALL PUSHCONTROL1B(0)
17486         ELSE
17487           abs43 = -cr
17488           CALL PUSHCONTROL1B(1)
17489         END IF
17490         y43 = cr + abs43
17491         IF (1.0 .GT. y43) THEN
17492           CALL PUSHREAL8(min63)
17493           min63 = y43
17494           CALL PUSHCONTROL1B(0)
17495         ELSE
17496           CALL PUSHREAL8(min63)
17497           min63 = 1.0
17498           CALL PUSHCONTROL1B(1)
17499         END IF
17500         IF (cr .GE. 0.) THEN
17501           abs94 = cr
17502           CALL PUSHCONTROL1B(0)
17503         ELSE
17504           abs94 = -cr
17505           CALL PUSHCONTROL1B(1)
17506         END IF
17507         y94 = cr - abs94
17508         IF (-1.0 .LT. y94) THEN
17509           CALL PUSHREAL8(max44)
17510           max44 = y94
17511           CALL PUSHCONTROL1B(0)
17512         ELSE
17513           CALL PUSHREAL8(max44)
17514           max44 = -1.0
17515           CALL PUSHCONTROL1B(1)
17516         END IF
17517         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min63*field_old(i, k-1, j)+0.5*&
17518 &          max44*field_old(i, k, j))
17519         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
17520 &          12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
17521 &          SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
17522 &          (field(i, k, j)-field(i, k-1, j))))
17523         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17524         k = ktf
17525         CALL PUSHREAL8(dz)
17526         dz = 2./(rdzw(k)+rdzw(k-1))
17527         mu = 0.5*(mut(i, j)+mut(i, j))
17528         CALL PUSHREAL8(vel)
17529         vel = rom(i, k, j)
17530         cr = vel*dt/dz/mu
17531         IF (cr .GE. 0.) THEN
17532           abs44 = cr
17533           CALL PUSHCONTROL1B(0)
17534         ELSE
17535           abs44 = -cr
17536           CALL PUSHCONTROL1B(1)
17537         END IF
17538         y44 = cr + abs44
17539         IF (1.0 .GT. y44) THEN
17540           CALL PUSHREAL8(min64)
17541           min64 = y44
17542           CALL PUSHCONTROL1B(0)
17543         ELSE
17544           CALL PUSHREAL8(min64)
17545           min64 = 1.0
17546           CALL PUSHCONTROL1B(1)
17547         END IF
17548         IF (cr .GE. 0.) THEN
17549           abs95 = cr
17550           CALL PUSHCONTROL1B(0)
17551         ELSE
17552           abs95 = -cr
17553           CALL PUSHCONTROL1B(1)
17554         END IF
17555         y95 = cr - abs95
17556         IF (-1.0 .LT. y95) THEN
17557           CALL PUSHREAL8(max45)
17558           max45 = y95
17559           CALL PUSHCONTROL1B(0)
17560         ELSE
17561           CALL PUSHREAL8(max45)
17562           max45 = -1.0
17563           CALL PUSHCONTROL1B(1)
17564         END IF
17565         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min64*field_old(i, k-1, j)+0.5*&
17566 &          max45*field_old(i, k, j))
17567         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17568 &          i, k-1, j))
17569         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17570       END DO
17571       CALL PUSHINTEGER4(i - 1)
17572       CALL PUSHINTEGER4(ad_from41)
17573     END DO
17574     CALL PUSHINTEGER4(j - 1)
17575     CALL PUSHINTEGER4(ad_from42)
17576     CALL PUSHCONTROL3B(1)
17577   ELSE IF (vert_order .EQ. 4) THEN
17578     ad_from46 = j_start
17579     DO j=ad_from46,j_end
17580       ad_from43 = i_start
17581       CALL PUSHINTEGER4(i)
17582       DO i=ad_from43,i_end
17583         fqz(i, 1, j) = 0.
17584         fqzl(i, 1, j) = 0.
17585         fqz(i, kde, j) = 0.
17586         fqzl(i, kde, j) = 0.
17587       END DO
17588       CALL PUSHINTEGER4(i - 1)
17589       CALL PUSHINTEGER4(ad_from43)
17590       CALL PUSHINTEGER4(k)
17591       DO k=kts+2,ktf-1
17592         ad_from44 = i_start
17593         DO i=ad_from44,i_end
17594           CALL PUSHREAL8(dz)
17595           dz = 2./(rdzw(k)+rdzw(k-1))
17596           CALL PUSHREAL8(mu)
17597           mu = 0.5*(mut(i, j)+mut(i, j))
17598           CALL PUSHREAL8(vel)
17599           vel = rom(i, k, j)
17600           cr = vel*dt/dz/mu
17601           IF (cr .GE. 0.) THEN
17602             abs45 = cr
17603             CALL PUSHCONTROL1B(0)
17604           ELSE
17605             abs45 = -cr
17606             CALL PUSHCONTROL1B(1)
17607           END IF
17608           y45 = cr + abs45
17609           IF (1.0 .GT. y45) THEN
17610             CALL PUSHREAL8(min65)
17611             min65 = y45
17612             CALL PUSHCONTROL1B(0)
17613           ELSE
17614             CALL PUSHREAL8(min65)
17615             min65 = 1.0
17616             CALL PUSHCONTROL1B(1)
17617           END IF
17618           IF (cr .GE. 0.) THEN
17619             abs96 = cr
17620             CALL PUSHCONTROL1B(0)
17621           ELSE
17622             abs96 = -cr
17623             CALL PUSHCONTROL1B(1)
17624           END IF
17625           y96 = cr - abs96
17626           IF (-1.0 .LT. y96) THEN
17627             CALL PUSHREAL8(max46)
17628             max46 = y96
17629             CALL PUSHCONTROL1B(0)
17630           ELSE
17631             CALL PUSHREAL8(max46)
17632             max46 = -1.0
17633             CALL PUSHCONTROL1B(1)
17634           END IF
17635           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min65*field_old(i, k-1, j)+0.5&
17636 &            *max46*field_old(i, k, j))
17637           fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
17638 &            1./12.*(field(i, k+1, j)+field(i, k-2, j)))
17639           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17640         END DO
17641         CALL PUSHINTEGER4(i - 1)
17642         CALL PUSHINTEGER4(ad_from44)
17643       END DO
17644       ad_from45 = i_start
17645       DO i=ad_from45,i_end
17646         CALL PUSHINTEGER4(k)
17647         k = kts + 1
17648         CALL PUSHREAL8(dz)
17649         dz = 2./(rdzw(k)+rdzw(k-1))
17650         CALL PUSHREAL8(mu)
17651         mu = 0.5*(mut(i, j)+mut(i, j))
17652         CALL PUSHREAL8(vel)
17653         vel = rom(i, k, j)
17654         cr = vel*dt/dz/mu
17655         IF (cr .GE. 0.) THEN
17656           abs46 = cr
17657           CALL PUSHCONTROL1B(0)
17658         ELSE
17659           abs46 = -cr
17660           CALL PUSHCONTROL1B(1)
17661         END IF
17662         y46 = cr + abs46
17663         IF (1.0 .GT. y46) THEN
17664           CALL PUSHREAL8(min66)
17665           min66 = y46
17666           CALL PUSHCONTROL1B(0)
17667         ELSE
17668           CALL PUSHREAL8(min66)
17669           min66 = 1.0
17670           CALL PUSHCONTROL1B(1)
17671         END IF
17672         IF (cr .GE. 0.) THEN
17673           abs97 = cr
17674           CALL PUSHCONTROL1B(0)
17675         ELSE
17676           abs97 = -cr
17677           CALL PUSHCONTROL1B(1)
17678         END IF
17679         y97 = cr - abs97
17680         IF (-1.0 .LT. y97) THEN
17681           CALL PUSHREAL8(max47)
17682           max47 = y97
17683           CALL PUSHCONTROL1B(0)
17684         ELSE
17685           CALL PUSHREAL8(max47)
17686           max47 = -1.0
17687           CALL PUSHCONTROL1B(1)
17688         END IF
17689         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min66*field_old(i, k-1, j)+0.5*&
17690 &          max47*field_old(i, k, j))
17691         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17692 &          i, k-1, j))
17693         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17694         k = ktf
17695         CALL PUSHREAL8(dz)
17696         dz = 2./(rdzw(k)+rdzw(k-1))
17697         mu = 0.5*(mut(i, j)+mut(i, j))
17698         CALL PUSHREAL8(vel)
17699         vel = rom(i, k, j)
17700         cr = vel*dt/dz/mu
17701         IF (cr .GE. 0.) THEN
17702           abs47 = cr
17703           CALL PUSHCONTROL1B(0)
17704         ELSE
17705           abs47 = -cr
17706           CALL PUSHCONTROL1B(1)
17707         END IF
17708         y47 = cr + abs47
17709         IF (1.0 .GT. y47) THEN
17710           CALL PUSHREAL8(min67)
17711           min67 = y47
17712           CALL PUSHCONTROL1B(0)
17713         ELSE
17714           CALL PUSHREAL8(min67)
17715           min67 = 1.0
17716           CALL PUSHCONTROL1B(1)
17717         END IF
17718         IF (cr .GE. 0.) THEN
17719           abs98 = cr
17720           CALL PUSHCONTROL1B(0)
17721         ELSE
17722           abs98 = -cr
17723           CALL PUSHCONTROL1B(1)
17724         END IF
17725         y98 = cr - abs98
17726         IF (-1.0 .LT. y98) THEN
17727           CALL PUSHREAL8(max48)
17728           max48 = y98
17729           CALL PUSHCONTROL1B(0)
17730         ELSE
17731           CALL PUSHREAL8(max48)
17732           max48 = -1.0
17733           CALL PUSHCONTROL1B(1)
17734         END IF
17735         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min67*field_old(i, k-1, j)+0.5*&
17736 &          max48*field_old(i, k, j))
17737         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17738 &          i, k-1, j))
17739         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17740       END DO
17741       CALL PUSHINTEGER4(i - 1)
17742       CALL PUSHINTEGER4(ad_from45)
17743     END DO
17744     CALL PUSHINTEGER4(j - 1)
17745     CALL PUSHINTEGER4(ad_from46)
17746     CALL PUSHCONTROL3B(2)
17747   ELSE IF (vert_order .EQ. 3) THEN
17748     ad_from50 = j_start
17749     DO j=ad_from50,j_end
17750       ad_from47 = i_start
17751       CALL PUSHINTEGER4(i)
17752       DO i=ad_from47,i_end
17753         fqz(i, 1, j) = 0.
17754         fqzl(i, 1, j) = 0.
17755         fqz(i, kde, j) = 0.
17756         fqzl(i, kde, j) = 0.
17757       END DO
17758       CALL PUSHINTEGER4(i - 1)
17759       CALL PUSHINTEGER4(ad_from47)
17760       CALL PUSHINTEGER4(k)
17761       DO k=kts+2,ktf-1
17762         ad_from48 = i_start
17763         DO i=ad_from48,i_end
17764           CALL PUSHREAL8(dz)
17765           dz = 2./(rdzw(k)+rdzw(k-1))
17766           CALL PUSHREAL8(mu)
17767           mu = 0.5*(mut(i, j)+mut(i, j))
17768           CALL PUSHREAL8(vel)
17769           vel = rom(i, k, j)
17770           cr = vel*dt/dz/mu
17771           IF (cr .GE. 0.) THEN
17772             abs48 = cr
17773             CALL PUSHCONTROL1B(0)
17774           ELSE
17775             abs48 = -cr
17776             CALL PUSHCONTROL1B(1)
17777           END IF
17778           y48 = cr + abs48
17779           IF (1.0 .GT. y48) THEN
17780             CALL PUSHREAL8(min68)
17781             min68 = y48
17782             CALL PUSHCONTROL1B(0)
17783           ELSE
17784             CALL PUSHREAL8(min68)
17785             min68 = 1.0
17786             CALL PUSHCONTROL1B(1)
17787           END IF
17788           IF (cr .GE. 0.) THEN
17789             abs99 = cr
17790             CALL PUSHCONTROL1B(0)
17791           ELSE
17792             abs99 = -cr
17793             CALL PUSHCONTROL1B(1)
17794           END IF
17795           y99 = cr - abs99
17796           IF (-1.0 .LT. y99) THEN
17797             CALL PUSHREAL8(max49)
17798             max49 = y99
17799             CALL PUSHCONTROL1B(0)
17800           ELSE
17801             CALL PUSHREAL8(max49)
17802             max49 = -1.0
17803             CALL PUSHCONTROL1B(1)
17804           END IF
17805           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min68*field_old(i, k-1, j)+0.5&
17806 &            *max49*field_old(i, k, j))
17807           fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
17808 &            1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step&
17809 &            )*SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)&
17810 &            -3.*(field(i, k, j)-field(i, k-1, j))))
17811           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17812         END DO
17813         CALL PUSHINTEGER4(i - 1)
17814         CALL PUSHINTEGER4(ad_from48)
17815       END DO
17816       ad_from49 = i_start
17817       DO i=ad_from49,i_end
17818         CALL PUSHINTEGER4(k)
17819         k = kts + 1
17820         CALL PUSHREAL8(dz)
17821         dz = 2./(rdzw(k)+rdzw(k-1))
17822         CALL PUSHREAL8(mu)
17823         mu = 0.5*(mut(i, j)+mut(i, j))
17824         CALL PUSHREAL8(vel)
17825         vel = rom(i, k, j)
17826         cr = vel*dt/dz/mu
17827         IF (cr .GE. 0.) THEN
17828           abs49 = cr
17829           CALL PUSHCONTROL1B(0)
17830         ELSE
17831           abs49 = -cr
17832           CALL PUSHCONTROL1B(1)
17833         END IF
17834         y49 = cr + abs49
17835         IF (1.0 .GT. y49) THEN
17836           CALL PUSHREAL8(min69)
17837           min69 = y49
17838           CALL PUSHCONTROL1B(0)
17839         ELSE
17840           CALL PUSHREAL8(min69)
17841           min69 = 1.0
17842           CALL PUSHCONTROL1B(1)
17843         END IF
17844         IF (cr .GE. 0.) THEN
17845           abs100 = cr
17846           CALL PUSHCONTROL1B(0)
17847         ELSE
17848           abs100 = -cr
17849           CALL PUSHCONTROL1B(1)
17850         END IF
17851         y100 = cr - abs100
17852         IF (-1.0 .LT. y100) THEN
17853           CALL PUSHREAL8(max50)
17854           max50 = y100
17855           CALL PUSHCONTROL1B(0)
17856         ELSE
17857           CALL PUSHREAL8(max50)
17858           max50 = -1.0
17859           CALL PUSHCONTROL1B(1)
17860         END IF
17861         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min69*field_old(i, k-1, j)+0.5*&
17862 &          max50*field_old(i, k, j))
17863         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17864 &          i, k-1, j))
17865         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17866         k = ktf
17867         CALL PUSHREAL8(dz)
17868         dz = 2./(rdzw(k)+rdzw(k-1))
17869         mu = 0.5*(mut(i, j)+mut(i, j))
17870         CALL PUSHREAL8(vel)
17871         vel = rom(i, k, j)
17872         cr = vel*dt/dz/mu
17873         IF (cr .GE. 0.) THEN
17874           abs50 = cr
17875           CALL PUSHCONTROL1B(0)
17876         ELSE
17877           abs50 = -cr
17878           CALL PUSHCONTROL1B(1)
17879         END IF
17880         y50 = cr + abs50
17881         IF (1.0 .GT. y50) THEN
17882           CALL PUSHREAL8(min70)
17883           min70 = y50
17884           CALL PUSHCONTROL1B(0)
17885         ELSE
17886           CALL PUSHREAL8(min70)
17887           min70 = 1.0
17888           CALL PUSHCONTROL1B(1)
17889         END IF
17890         IF (cr .GE. 0.) THEN
17891           abs101 = cr
17892           CALL PUSHCONTROL1B(0)
17893         ELSE
17894           abs101 = -cr
17895           CALL PUSHCONTROL1B(1)
17896         END IF
17897         y101 = cr - abs101
17898         IF (-1.0 .LT. y101) THEN
17899           CALL PUSHREAL8(max51)
17900           max51 = y101
17901           CALL PUSHCONTROL1B(0)
17902         ELSE
17903           CALL PUSHREAL8(max51)
17904           max51 = -1.0
17905           CALL PUSHCONTROL1B(1)
17906         END IF
17907         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min70*field_old(i, k-1, j)+0.5*&
17908 &          max51*field_old(i, k, j))
17909         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
17910 &          i, k-1, j))
17911         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17912       END DO
17913       CALL PUSHINTEGER4(i - 1)
17914       CALL PUSHINTEGER4(ad_from49)
17915     END DO
17916     CALL PUSHINTEGER4(j - 1)
17917     CALL PUSHINTEGER4(ad_from50)
17918     CALL PUSHCONTROL3B(3)
17919   ELSE IF (vert_order .EQ. 2) THEN
17920     ad_from53 = j_start
17921     DO j=ad_from53,j_end
17922       ad_from51 = i_start
17923       CALL PUSHINTEGER4(i)
17924       DO i=ad_from51,i_end
17925         fqz(i, 1, j) = 0.
17926         fqzl(i, 1, j) = 0.
17927         fqz(i, kde, j) = 0.
17928         fqzl(i, kde, j) = 0.
17929       END DO
17930       CALL PUSHINTEGER4(i - 1)
17931       CALL PUSHINTEGER4(ad_from51)
17932       DO k=kts+1,ktf
17933         ad_from52 = i_start
17934         DO i=ad_from52,i_end
17935           CALL PUSHREAL8(dz)
17936           dz = 2./(rdzw(k)+rdzw(k-1))
17937           CALL PUSHREAL8(mu)
17938           mu = 0.5*(mut(i, j)+mut(i, j))
17939           CALL PUSHREAL8(vel)
17940           vel = rom(i, k, j)
17941           cr = vel*dt/dz/mu
17942           IF (cr .GE. 0.) THEN
17943             abs51 = cr
17944             CALL PUSHCONTROL1B(0)
17945           ELSE
17946             abs51 = -cr
17947             CALL PUSHCONTROL1B(1)
17948           END IF
17949           y51 = cr + abs51
17950           IF (1.0 .GT. y51) THEN
17951             CALL PUSHREAL8(min71)
17952             min71 = y51
17953             CALL PUSHCONTROL1B(0)
17954           ELSE
17955             CALL PUSHREAL8(min71)
17956             min71 = 1.0
17957             CALL PUSHCONTROL1B(1)
17958           END IF
17959           IF (cr .GE. 0.) THEN
17960             abs102 = cr
17961             CALL PUSHCONTROL1B(0)
17962           ELSE
17963             abs102 = -cr
17964             CALL PUSHCONTROL1B(1)
17965           END IF
17966           y102 = cr - abs102
17967           IF (-1.0 .LT. y102) THEN
17968             CALL PUSHREAL8(max52)
17969             max52 = y102
17970             CALL PUSHCONTROL1B(0)
17971           ELSE
17972             CALL PUSHREAL8(max52)
17973             max52 = -1.0
17974             CALL PUSHCONTROL1B(1)
17975           END IF
17976           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min71*field_old(i, k-1, j)+0.5&
17977 &            *max52*field_old(i, k, j))
17978           fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
17979 &            field(i, k-1, j))
17980           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
17981         END DO
17982         CALL PUSHINTEGER4(i - 1)
17983         CALL PUSHINTEGER4(ad_from52)
17984       END DO
17985     END DO
17986     CALL PUSHINTEGER4(j - 1)
17987     CALL PUSHINTEGER4(ad_from53)
17988     CALL PUSHCONTROL3B(4)
17989   ELSE
17990     CALL PUSHCONTROL3B(5)
17991   END IF
17992   IF (pd_limit) THEN
17993 ! positive definite filter
17994     i_start = its - 1
17995     IF (ite .GT. ide - 1) THEN
17996       min72 = ide - 1
17997     ELSE
17998       min72 = ite
17999     END IF
18000     i_end = min72 + 1
18001     j_start = jts - 1
18002     IF (jte .GT. jde - 1) THEN
18003       min73 = jde - 1
18004     ELSE
18005       min73 = jte
18006     END IF
18007     j_end = min73 + 1
18008 !-- loop bounds for open or specified conditions
18009     IF (degrade_xs) THEN
18010       IF (its - 1 .LT. ids) THEN
18011         i_start = ids
18012       ELSE
18013         i_start = its - 1
18014       END IF
18015     END IF
18016     IF (degrade_xe) THEN
18017       IF (ite + 1 .GT. ide - 1) THEN
18018         i_end = ide - 1
18019       ELSE
18020         i_end = ite + 1
18021       END IF
18022     END IF
18023     IF (degrade_ys) THEN
18024       IF (jts - 1 .LT. jds) THEN
18025         j_start = jds
18026       ELSE
18027         j_start = jts - 1
18028       END IF
18029     END IF
18030     IF (degrade_ye) THEN
18031       IF (jte + 1 .GT. jde - 1) THEN
18032         j_end = jde - 1
18033       ELSE
18034         j_end = jte + 1
18035       END IF
18036     END IF
18037     IF (config_flags%specified .OR. config_flags%nested) THEN
18038       IF (degrade_xs) THEN
18039         IF (its - 1 .LT. ids + 1) THEN
18040           i_start = ids + 1
18041         ELSE
18042           i_start = its - 1
18043         END IF
18044       END IF
18045       IF (degrade_xe) THEN
18046         IF (ite + 1 .GT. ide - 2) THEN
18047           i_end = ide - 2
18048         ELSE
18049           i_end = ite + 1
18050         END IF
18051       END IF
18052       IF (degrade_ys) THEN
18053         IF (jts - 1 .LT. jds + 1) THEN
18054           j_start = jds + 1
18055         ELSE
18056           j_start = jts - 1
18057         END IF
18058       END IF
18059       IF (degrade_ye) THEN
18060         IF (jte + 1 .GT. jde - 2) THEN
18061           j_end = jde - 2
18062         ELSE
18063           j_end = jte + 1
18064         END IF
18065       END IF
18066     END IF
18067     IF (config_flags%open_xs) THEN
18068       IF (degrade_xs) THEN
18069         IF (its - 1 .LT. ids + 1) THEN
18070           i_start = ids + 1
18071         ELSE
18072           i_start = its - 1
18073         END IF
18074       END IF
18075     END IF
18076     IF (config_flags%open_xe) THEN
18077       IF (degrade_xe) THEN
18078         IF (ite + 1 .GT. ide - 2) THEN
18079           i_end = ide - 2
18080         ELSE
18081           i_end = ite + 1
18082         END IF
18083       END IF
18084     END IF
18085     IF (config_flags%open_ys) THEN
18086       IF (degrade_ys) THEN
18087         IF (jts - 1 .LT. jds + 1) THEN
18088           j_start = jds + 1
18089         ELSE
18090           j_start = jts - 1
18091         END IF
18092       END IF
18093     END IF
18094     IF (config_flags%open_ye) THEN
18095       IF (degrade_ye) THEN
18096         IF (jte + 1 .GT. jde - 2) THEN
18097           j_end = jde - 2
18098         ELSE
18099           j_end = jte + 1
18100         END IF
18101       END IF
18102     END IF
18103     ad_from55 = j_start
18104 ! ADT note:
18105 ! We don't want to change j_start and j_end
18106 ! for polar BC's since we want to calculate
18107 ! fluxes for directions other than y at the
18108 ! edge
18109 !-- here is the limiter...
18110     DO j=ad_from55,j_end
18111       CALL PUSHINTEGER4(k)
18112       DO k=kts,ktf
18113         ad_from54 = i_start
18114         CALL PUSHINTEGER4(i)
18115         DO i=ad_from54,i_end
18116           CALL PUSHREAL8(ph_low(i,k,j))
18117           ph_low(i,k,j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) - dt*(&
18118 &            msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, k, j))&
18119 &            +rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw(k)*(&
18120 &            fqzl(i, k+1, j)-fqzl(i, k, j)))
18121         ENDDO
18122         CALL PUSHINTEGER4(i - 1)
18123         CALL PUSHINTEGER4(ad_from54)
18124       END DO
18125     ENDDO
18126     CALL PUSHINTEGER4(j - 1)
18127     CALL PUSHINTEGER4(ad_from55)
18128
18129     ad_from55 = j_start
18130     DO j=ad_from55,j_end
18131       CALL PUSHINTEGER4(k)
18132       DO k=kts,ktf
18133         ad_from54 = i_start
18134         CALL PUSHINTEGER4(i)
18135         DO i=ad_from54,i_end
18136           IF (0. .LT. fqx(i+1, k, j)) THEN
18137             max1 = fqx(i+1, k, j)
18138             CALL PUSHCONTROL1B(1)
18139           ELSE
18140             CALL PUSHCONTROL1B(0)
18141             max1 = 0.
18142           END IF
18143           IF (0. .GT. fqx(i, k, j)) THEN
18144             min74 = fqx(i, k, j)
18145             CALL PUSHCONTROL1B(1)
18146           ELSE
18147             CALL PUSHCONTROL1B(0)
18148             min74 = 0.
18149           END IF
18150           IF (0. .LT. fqy(i, k, j+1)) THEN
18151             max53 = fqy(i, k, j+1)
18152             CALL PUSHCONTROL1B(1)
18153           ELSE
18154             CALL PUSHCONTROL1B(0)
18155             max53 = 0.
18156           END IF
18157           IF (0. .GT. fqy(i, k, j)) THEN
18158             min75 = fqy(i, k, j)
18159             CALL PUSHCONTROL1B(1)
18160           ELSE
18161             CALL PUSHCONTROL1B(0)
18162             min75 = 0.
18163           END IF
18164           IF (0. .GT. fqz(i, k+1, j)) THEN
18165             min76 = fqz(i, k+1, j)
18166             CALL PUSHCONTROL1B(1)
18167           ELSE
18168             CALL PUSHCONTROL1B(0)
18169             min76 = 0.
18170           END IF
18171           IF (0. .LT. fqz(i, k, j)) THEN
18172             max54 = fqz(i, k, j)
18173             CALL PUSHCONTROL1B(0)
18174           ELSE
18175             CALL PUSHCONTROL1B(1)
18176             max54 = 0.
18177           END IF
18178           CALL PUSHREAL8(flux_out(i,k,j))
18179           flux_out(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-min74)+rdy*(&
18180 &            max53-min75))+msfty(i, j)*rdzw(k)*(min76-max54))
18181         ENDDO
18182         CALL PUSHINTEGER4(i - 1)
18183         CALL PUSHINTEGER4(ad_from54)
18184       END DO
18185     ENDDO
18186     CALL PUSHINTEGER4(j - 1)
18187     CALL PUSHINTEGER4(ad_from55)
18188
18189     ad_from55 = j_start
18190     DO j=ad_from55,j_end
18191       CALL PUSHINTEGER4(k)
18192       DO k=kts,ktf
18193         ad_from54 = i_start
18194         CALL PUSHINTEGER4(i)
18195         DO i=ad_from54,i_end
18196           IF (flux_out(i,k,j) .GT. ph_low(i,k,j)) THEN
18197             IF (0. .LT. ph_low(i,k,j)/(flux_out(i,k,j)+eps)) THEN
18198               CALL PUSHREAL8(scale)
18199               scale = ph_low(i,k,j)/(flux_out(i,k,j)+eps)
18200               CALL PUSHCONTROL1B(0)
18201             ELSE
18202               CALL PUSHREAL8(scale)
18203               scale = 0.
18204               CALL PUSHCONTROL1B(1)
18205             END IF
18206             IF (fqx(i+1, k, j) .GT. 0.) THEN
18207               CALL PUSHREAL8(fqx(i+1, k, j))
18208               fqx(i+1, k, j) = scale*fqx(i+1, k, j)
18209               CALL PUSHCONTROL1B(0)
18210             ELSE
18211               CALL PUSHCONTROL1B(1)
18212             END IF
18213             IF (fqx(i, k, j) .LT. 0.) THEN
18214               CALL PUSHREAL8(fqx(i, k, j))
18215               fqx(i, k, j) = scale*fqx(i, k, j)
18216               CALL PUSHCONTROL1B(0)
18217             ELSE
18218               CALL PUSHCONTROL1B(1)
18219             END IF
18220             IF (fqy(i, k, j+1) .GT. 0.) THEN
18221               CALL PUSHREAL8(fqy(i, k, j+1))
18222               fqy(i, k, j+1) = scale*fqy(i, k, j+1)
18223               CALL PUSHCONTROL1B(0)
18224             ELSE
18225               CALL PUSHCONTROL1B(1)
18226             END IF
18227             IF (fqy(i, k, j) .LT. 0.) THEN
18228               CALL PUSHREAL8(fqy(i, k, j))
18229               fqy(i, k, j) = scale*fqy(i, k, j)
18230               CALL PUSHCONTROL1B(0)
18231             ELSE
18232               CALL PUSHCONTROL1B(1)
18233             END IF
18234 !  note: z flux is opposite sign in mass coordinate because
18235 !  vertical coordinate decreases with increasing k
18236             IF (fqz(i, k+1, j) .LT. 0.) THEN
18237               CALL PUSHREAL8(fqz(i, k+1, j))
18238               fqz(i, k+1, j) = scale*fqz(i, k+1, j)
18239               CALL PUSHCONTROL1B(0)
18240             ELSE
18241               CALL PUSHCONTROL1B(1)
18242             END IF
18243             IF (fqz(i, k, j) .GT. 0.) THEN
18244               CALL PUSHREAL8(fqz(i, k, j))
18245               fqz(i, k, j) = scale*fqz(i, k, j)
18246               CALL PUSHCONTROL2B(2)
18247             ELSE
18248               CALL PUSHCONTROL2B(1)
18249             END IF
18250           ELSE
18251             CALL PUSHCONTROL2B(0)
18252           END IF
18253         END DO
18254         CALL PUSHINTEGER4(i - 1)
18255         CALL PUSHINTEGER4(ad_from54)
18256       END DO
18257     END DO
18258     CALL PUSHINTEGER4(j - 1)
18259     CALL PUSHINTEGER4(ad_from55)
18260     CALL PUSHCONTROL1B(1)
18261   ELSE
18262     CALL PUSHCONTROL1B(0)
18263   END IF
18264 ! add in the pd-limited flux divergence
18265   i_start = its
18266   IF (ite .GT. ide - 1) THEN
18267     i_end = ide - 1
18268   ELSE
18269     i_end = ite
18270   END IF
18271   j_start = jts
18272   IF (jte .GT. jde - 1) THEN
18273     j_end = jde - 1
18274   ELSE
18275     j_end = jte
18276   END IF
18277   ad_from57 = j_start
18278   DO j=ad_from57,j_end
18279     CALL PUSHINTEGER4(k)
18280     DO k=kts,ktf
18281       ad_from56 = i_start
18282       CALL PUSHINTEGER4(i)
18283       i = i_end + 1
18284       CALL PUSHINTEGER4(i - 1)
18285       CALL PUSHINTEGER4(ad_from56)
18286     END DO
18287   END DO
18288   CALL PUSHINTEGER4(j - 1)
18289   CALL PUSHINTEGER4(ad_from57)
18290   IF (tenddec) THEN
18291     ad_from59 = j_start
18292     DO j=ad_from59,j_end
18293       CALL PUSHINTEGER4(k)
18294       DO k=kts,ktf
18295         ad_from58 = i_start
18296         CALL PUSHINTEGER4(i)
18297         i = i_end + 1
18298         CALL PUSHINTEGER4(i - 1)
18299         CALL PUSHINTEGER4(ad_from58)
18300       END DO
18301     END DO
18302     CALL PUSHINTEGER4(j - 1)
18303     CALL PUSHINTEGER4(ad_from59)
18304     CALL PUSHCONTROL1B(0)
18305   ELSE
18306     CALL PUSHCONTROL1B(1)
18307   END IF
18308 ! x flux divergence
18309 !
18310   IF (degrade_xs) THEN
18311     IF (its .LT. ids + 1) THEN
18312       i_start = ids + 1
18313     ELSE
18314       i_start = its
18315     END IF
18316   END IF
18317   IF (degrade_xe) THEN
18318     IF (ite .GT. ide - 2) THEN
18319       i_end = ide - 2
18320     ELSE
18321       i_end = ite
18322     END IF
18323   END IF
18324   ad_from61 = j_start
18325   DO j=ad_from61,j_end
18326     CALL PUSHINTEGER4(k)
18327     DO k=kts,ktf
18328       ad_from60 = i_start
18329       CALL PUSHINTEGER4(i)
18330       i = i_end + 1
18331       CALL PUSHINTEGER4(i - 1)
18332       CALL PUSHINTEGER4(ad_from60)
18333     END DO
18334   END DO
18335   CALL PUSHINTEGER4(j - 1)
18336   CALL PUSHINTEGER4(ad_from61)
18337   IF (tenddec) THEN
18338     ad_from63 = j_start
18339     DO j=ad_from63,j_end
18340       CALL PUSHINTEGER4(k)
18341       DO k=kts,ktf
18342         ad_from62 = i_start
18343         CALL PUSHINTEGER4(i)
18344         i = i_end + 1
18345         CALL PUSHINTEGER4(i - 1)
18346         CALL PUSHINTEGER4(ad_from62)
18347       END DO
18348     END DO
18349     CALL PUSHINTEGER4(j - 1)
18350     CALL PUSHINTEGER4(ad_from63)
18351     CALL PUSHCONTROL1B(1)
18352   ELSE
18353     CALL PUSHCONTROL1B(0)
18354   END IF
18355 ! y flux divergence
18356 !
18357   i_start = its
18358   IF (ite .GT. ide - 1) THEN
18359     i_end = ide - 1
18360   ELSE
18361     i_end = ite
18362   END IF
18363   IF (degrade_ys) THEN
18364     IF (jts .LT. jds + 1) THEN
18365       j_start = jds + 1
18366     ELSE
18367       j_start = jts
18368     END IF
18369   END IF
18370   IF (degrade_ye) THEN
18371     IF (jte .GT. jde - 2) THEN
18372       j_end = jde - 2
18373     ELSE
18374       j_end = jte
18375     END IF
18376   END IF
18377   DO j=j_start,j_end
18378     CALL PUSHINTEGER4(k)
18379     DO k=kts,ktf
18380       CALL PUSHINTEGER4(i)
18381     END DO
18382   END DO
18383   IF (tenddec) THEN
18384     DO j=j_start,j_end
18385       CALL PUSHINTEGER4(k)
18386       DO k=kts,ktf
18387         CALL PUSHINTEGER4(i)
18388       END DO
18389     END DO
18390     fqylb = 0.0
18391     fqyb = 0.0
18392     DO j=j_end,j_start,-1
18393       DO k=ktf,kts,-1
18394         DO i=i_end,i_start,-1
18395           temp47b18 = -(msftx(i, j)*rdy*h_tendencyb(i, k, j))
18396           fqyb(i, k, j+1) = fqyb(i, k, j+1) + temp47b18
18397           fqyb(i, k, j) = fqyb(i, k, j) - temp47b18
18398           fqylb(i, k, j+1) = fqylb(i, k, j+1) + temp47b18
18399           fqylb(i, k, j) = fqylb(i, k, j) - temp47b18
18400         END DO
18401         CALL POPINTEGER4(i)
18402       END DO
18403       CALL POPINTEGER4(k)
18404     END DO
18405   ELSE
18406     fqylb = 0.0
18407     fqyb = 0.0
18408   END IF
18409   DO j=j_end,j_start,-1
18410     DO k=ktf,kts,-1
18411       DO i=i_end,i_start,-1
18412         temp47b17 = -(msftx(i, j)*rdy*tendencyb(i, k, j))
18413         fqyb(i, k, j+1) = fqyb(i, k, j+1) + temp47b17
18414         fqyb(i, k, j) = fqyb(i, k, j) - temp47b17
18415         fqylb(i, k, j+1) = fqylb(i, k, j+1) + temp47b17
18416         fqylb(i, k, j) = fqylb(i, k, j) - temp47b17
18417       END DO
18418       CALL POPINTEGER4(i)
18419     END DO
18420     CALL POPINTEGER4(k)
18421   END DO
18422   CALL POPCONTROL1B(branch)
18423   IF (branch .EQ. 0) THEN
18424     fqxlb = 0.0
18425     fqxb = 0.0
18426   ELSE
18427     fqxlb = 0.0
18428     fqxb = 0.0
18429     CALL POPINTEGER4(ad_from63)
18430     CALL POPINTEGER4(ad_to63)
18431     DO j=ad_to63,ad_from63,-1
18432       DO k=ktf,kts,-1
18433         CALL POPINTEGER4(ad_from62)
18434         CALL POPINTEGER4(ad_to62)
18435         DO i=ad_to62,ad_from62,-1
18436           temp47b16 = -(msftx(i, j)*rdx*h_tendencyb(i, k, j))
18437           fqxb(i+1, k, j) = fqxb(i+1, k, j) + temp47b16
18438           fqxb(i, k, j) = fqxb(i, k, j) - temp47b16
18439           fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + temp47b16
18440           fqxlb(i, k, j) = fqxlb(i, k, j) - temp47b16
18441           h_tendencyb(i, k, j) = 0.0
18442         END DO
18443         CALL POPINTEGER4(i)
18444       END DO
18445       CALL POPINTEGER4(k)
18446     END DO
18447   END IF
18448   CALL POPINTEGER4(ad_from61)
18449   CALL POPINTEGER4(ad_to61)
18450   DO j=ad_to61,ad_from61,-1
18451     DO k=ktf,kts,-1
18452       CALL POPINTEGER4(ad_from60)
18453       CALL POPINTEGER4(ad_to60)
18454       DO i=ad_to60,ad_from60,-1
18455         temp47b15 = -(msftx(i, j)*rdx*tendencyb(i, k, j))
18456         fqxb(i+1, k, j) = fqxb(i+1, k, j) + temp47b15
18457         fqxb(i, k, j) = fqxb(i, k, j) - temp47b15
18458         fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + temp47b15
18459         fqxlb(i, k, j) = fqxlb(i, k, j) - temp47b15
18460       END DO
18461       CALL POPINTEGER4(i)
18462     END DO
18463     CALL POPINTEGER4(k)
18464   END DO
18465   CALL POPCONTROL1B(branch)
18466   IF (branch .EQ. 0) THEN
18467     fqzb = 0.0
18468     fqzlb = 0.0
18469     CALL POPINTEGER4(ad_from59)
18470     CALL POPINTEGER4(ad_to59)
18471     DO j=ad_to59,ad_from59,-1
18472       DO k=ktf,kts,-1
18473         CALL POPINTEGER4(ad_from58)
18474         CALL POPINTEGER4(ad_to58)
18475         DO i=ad_to58,ad_from58,-1
18476           temp47b14 = -(rdzw(k)*z_tendencyb(i, k, j))
18477           fqzb(i, k+1, j) = fqzb(i, k+1, j) + temp47b14
18478           fqzb(i, k, j) = fqzb(i, k, j) - temp47b14
18479           fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + temp47b14
18480           fqzlb(i, k, j) = fqzlb(i, k, j) - temp47b14
18481           z_tendencyb(i, k, j) = 0.0
18482         END DO
18483         CALL POPINTEGER4(i)
18484       END DO
18485       CALL POPINTEGER4(k)
18486     END DO
18487   ELSE
18488     fqzb = 0.0
18489     fqzlb = 0.0
18490   END IF
18491   CALL POPINTEGER4(ad_from57)
18492   CALL POPINTEGER4(ad_to57)
18493   DO j=ad_to57,ad_from57,-1
18494     DO k=ktf,kts,-1
18495       CALL POPINTEGER4(ad_from56)
18496       CALL POPINTEGER4(ad_to56)
18497       DO i=ad_to56,ad_from56,-1
18498         temp47b13 = -(rdzw(k)*tendencyb(i, k, j))
18499         fqzb(i, k+1, j) = fqzb(i, k+1, j) + temp47b13
18500         fqzb(i, k, j) = fqzb(i, k, j) - temp47b13
18501         fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + temp47b13
18502         fqzlb(i, k, j) = fqzlb(i, k, j) - temp47b13
18503       END DO
18504       CALL POPINTEGER4(i)
18505     END DO
18506     CALL POPINTEGER4(k)
18507   END DO
18508   CALL POPCONTROL1B(branch)
18509   IF (branch .NE. 0) THEN
18510     CALL POPINTEGER4(ad_from55)
18511     CALL POPINTEGER4(ad_to55)
18512     DO j=ad_to55,ad_from55,-1
18513       DO k=ktf,kts,-1
18514         CALL POPINTEGER4(ad_from54)
18515         CALL POPINTEGER4(ad_to54)
18516         DO i=ad_to54,ad_from54,-1
18517           CALL POPCONTROL2B(branch)
18518           IF (branch .EQ. 0) THEN
18519             flux_outb(i,k,j) = 0.0
18520             ph_lowb(i,k,j) = 0.0
18521           ELSE
18522             IF (branch .EQ. 1) THEN
18523               scaleb = 0.0
18524             ELSE
18525               CALL POPREAL8(fqz(i, k, j))
18526               scaleb = fqz(i, k, j)*fqzb(i, k, j)
18527               fqzb(i, k, j) = scale*fqzb(i, k, j)
18528             END IF
18529             CALL POPCONTROL1B(branch)
18530             IF (branch .EQ. 0) THEN
18531               CALL POPREAL8(fqz(i, k+1, j))
18532               scaleb = scaleb + fqz(i, k+1, j)*fqzb(i, k+1, j)
18533               fqzb(i, k+1, j) = scale*fqzb(i, k+1, j)
18534             END IF
18535             CALL POPCONTROL1B(branch)
18536             IF (branch .EQ. 0) THEN
18537               CALL POPREAL8(fqy(i, k, j))
18538               scaleb = scaleb + fqy(i, k, j)*fqyb(i, k, j)
18539               fqyb(i, k, j) = scale*fqyb(i, k, j)
18540             END IF
18541             CALL POPCONTROL1B(branch)
18542             IF (branch .EQ. 0) THEN
18543               CALL POPREAL8(fqy(i, k, j+1))
18544               scaleb = scaleb + fqy(i, k, j+1)*fqyb(i, k, j+1)
18545               fqyb(i, k, j+1) = scale*fqyb(i, k, j+1)
18546             END IF
18547             CALL POPCONTROL1B(branch)
18548             IF (branch .EQ. 0) THEN
18549               CALL POPREAL8(fqx(i, k, j))
18550               scaleb = scaleb + fqx(i, k, j)*fqxb(i, k, j)
18551               fqxb(i, k, j) = scale*fqxb(i, k, j)
18552             END IF
18553             CALL POPCONTROL1B(branch)
18554             IF (branch .EQ. 0) THEN
18555               CALL POPREAL8(fqx(i+1, k, j))
18556               scaleb = scaleb + fqx(i+1, k, j)*fqxb(i+1, k, j)
18557               fqxb(i+1, k, j) = scale*fqxb(i+1, k, j)
18558             END IF
18559             CALL POPCONTROL1B(branch)
18560             IF (branch .EQ. 0) THEN
18561               CALL POPREAL8(scale)
18562               temp47b12 = scaleb/(eps+flux_out(i,k,j))
18563               ph_lowb(i,k,j) = temp47b12
18564               flux_outb(i,k,j) = -(ph_low(i,k,j)*temp47b12/(eps+flux_out(i,k,j)))
18565             ELSE
18566               CALL POPREAL8(scale)
18567               flux_outb(i,k,j) = 0.0
18568               ph_lowb(i,k,j) = 0.0
18569             END IF
18570           END IF
18571         END DO
18572         CALL POPINTEGER4(i)
18573       END DO
18574       CALL POPINTEGER4(k)
18575     END DO
18576     CALL POPINTEGER4(ad_from55)
18577     CALL POPINTEGER4(ad_to55)
18578     DO j=ad_to55,ad_from55,-1
18579       DO k=ktf,kts,-1
18580         CALL POPINTEGER4(ad_from54)
18581         CALL POPINTEGER4(ad_to54)
18582         DO i=ad_to54,ad_from54,-1
18583           CALL POPREAL8(flux_out(i,k,j))
18584           temp47b10 = dt*msftx(i, j)*msfty(i, j)*flux_outb(i,k,j)
18585           temp47b11 = msfty(i, j)*dt*rdzw(k)*flux_outb(i,k,j)
18586           max1b = rdx*temp47b10
18587           min74b = -(rdx*temp47b10)
18588           max53b = rdy*temp47b10
18589           min75b = -(rdy*temp47b10)
18590           min76b = temp47b11
18591           max54b = -temp47b11
18592           CALL POPCONTROL1B(branch)
18593           IF (branch .EQ. 0) fqzb(i, k, j) = fqzb(i, k, j) + max54b
18594           CALL POPCONTROL1B(branch)
18595           IF (branch .NE. 0) fqzb(i, k+1, j) = fqzb(i, k+1, j) + min76b
18596           CALL POPCONTROL1B(branch)
18597           IF (branch .NE. 0) fqyb(i, k, j) = fqyb(i, k, j) + min75b
18598           CALL POPCONTROL1B(branch)
18599           IF (branch .NE. 0) fqyb(i, k, j+1) = fqyb(i, k, j+1) + max53b
18600           CALL POPCONTROL1B(branch)
18601           IF (branch .NE. 0) fqxb(i, k, j) = fqxb(i, k, j) + min74b
18602           CALL POPCONTROL1B(branch)
18603           IF (branch .NE. 0) fqxb(i+1, k, j) = fqxb(i+1, k, j) + max1b
18604         END DO
18605         CALL POPINTEGER4(i)
18606       END DO
18607       CALL POPINTEGER4(k)
18608     END DO
18609     CALL POPINTEGER4(ad_from55)
18610     CALL POPINTEGER4(ad_to55)
18611     DO j=ad_to55,ad_from55,-1
18612       DO k=ktf,kts,-1
18613         CALL POPINTEGER4(ad_from54)
18614         CALL POPINTEGER4(ad_to54)
18615         DO i=ad_to54,ad_from54,-1
18616           CALL POPREAL8(ph_low(i,k,j))
18617           temp47b8 = -(dt*msftx(i, j)*msfty(i, j)*ph_lowb(i,k,j))
18618           temp47b9 = -(dt*msfty(i, j)*rdzw(k)*ph_lowb(i,k,j))
18619           mu_oldb(i, j) = mu_oldb(i, j) + field_old(i, k, j)*ph_lowb(i,k,j)
18620           field_oldb(i, k, j) = field_oldb(i, k, j) + (mub(i, j)+mu_old(&
18621 &            i, j))*ph_lowb(i,k,j)
18622           fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + rdx*temp47b8
18623           fqxlb(i, k, j) = fqxlb(i, k, j) - rdx*temp47b8
18624           fqylb(i, k, j+1) = fqylb(i, k, j+1) + rdy*temp47b8
18625           fqylb(i, k, j) = fqylb(i, k, j) - rdy*temp47b8
18626           fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + temp47b9
18627           fqzlb(i, k, j) = fqzlb(i, k, j) - temp47b9
18628         END DO
18629         CALL POPINTEGER4(i)
18630       END DO
18631       CALL POPINTEGER4(k)
18632     END DO
18633   END IF
18634   CALL POPCONTROL3B(branch)
18635   IF (branch .LT. 3) THEN
18636     IF (branch .EQ. 0) THEN
18637       CALL POPINTEGER4(ad_from38)
18638       CALL POPINTEGER4(ad_to38)
18639       DO j=ad_to38,ad_from38,-1
18640         CALL POPINTEGER4(ad_from37)
18641         CALL POPINTEGER4(ad_to37)
18642         DO i=ad_to37,ad_from37,-1
18643           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
18644           temp31b74 = rom(i, k, j)*fqzb(i, k, j)
18645           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
18646 &            field(i, k-1, j))*fqzb(i, k, j)
18647           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b74
18648           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b74
18649           fqzb(i, k, j) = 0.0
18650           temp31b75 = dz*mu*fqzlb(i, k, j)/dt
18651           min59b = 0.5*field_old(i, k-1, j)*temp31b75
18652           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min59*&
18653 &            temp31b75
18654           max40b = 0.5*field_old(i, k, j)*temp31b75
18655           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max40*&
18656 &            temp31b75
18657           mub0 = (0.5*(min59*field_old(i, k-1, j))+0.5*(max40*field_old(&
18658 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
18659           fqzlb(i, k, j) = 0.0
18660           CALL POPCONTROL1B(branch)
18661           IF (branch .EQ. 0) THEN
18662             CALL POPREAL8(max40)
18663             y90b = max40b
18664           ELSE
18665             CALL POPREAL8(max40)
18666             y90b = 0.0
18667           END IF
18668           crb = y90b
18669           abs90b = -y90b
18670           CALL POPCONTROL1B(branch)
18671           IF (branch .EQ. 0) THEN
18672             crb = crb + abs90b
18673           ELSE
18674             crb = crb - abs90b
18675           END IF
18676           CALL POPCONTROL1B(branch)
18677           IF (branch .EQ. 0) THEN
18678             CALL POPREAL8(min59)
18679             y39b = min59b
18680           ELSE
18681             CALL POPREAL8(min59)
18682             y39b = 0.0
18683           END IF
18684           crb = crb + y39b
18685           abs39b = y39b
18686           CALL POPCONTROL1B(branch)
18687           IF (branch .EQ. 0) THEN
18688             crb = crb + abs39b
18689           ELSE
18690             crb = crb - abs39b
18691           END IF
18692           temp31b70 = dt*crb/(dz*mu)
18693           velb = temp31b70
18694           mub0 = mub0 - vel*temp31b70/mu
18695           CALL POPREAL8(vel)
18696           romb(i, k, j) = romb(i, k, j) + velb
18697           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
18698           mu = 0.5*(mut(i, j)+mut(i, j))
18699           CALL POPREAL8(dz)
18700           k = ktf - 1
18701           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
18702           temp31b71 = vel*fqzb(i, k, j)
18703           temp31b72 = 7.*temp31b71/12.
18704           velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k&
18705 &            +1, j)+field(i, k-2, j))/12.)*fqzb(i, k, j)
18706           fieldb(i, k, j) = fieldb(i, k, j) + temp31b72
18707           fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b72
18708           fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b71/12.
18709           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b71/12.
18710           fqzb(i, k, j) = 0.0
18711           temp31b73 = dz*mu*fqzlb(i, k, j)/dt
18712           min58b = 0.5*field_old(i, k-1, j)*temp31b73
18713           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min58*&
18714 &            temp31b73
18715           max39b = 0.5*field_old(i, k, j)*temp31b73
18716           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max39*&
18717 &            temp31b73
18718           mub0 = (0.5*(min58*field_old(i, k-1, j))+0.5*(max39*field_old(&
18719 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
18720           fqzlb(i, k, j) = 0.0
18721           CALL POPCONTROL1B(branch)
18722           IF (branch .EQ. 0) THEN
18723             CALL POPREAL8(max39)
18724             y89b = max39b
18725           ELSE
18726             CALL POPREAL8(max39)
18727             y89b = 0.0
18728           END IF
18729           crb = y89b
18730           abs89b = -y89b
18731           CALL POPCONTROL1B(branch)
18732           IF (branch .EQ. 0) THEN
18733             crb = crb + abs89b
18734           ELSE
18735             crb = crb - abs89b
18736           END IF
18737           CALL POPCONTROL1B(branch)
18738           IF (branch .EQ. 0) THEN
18739             CALL POPREAL8(min58)
18740             y38b = min58b
18741           ELSE
18742             CALL POPREAL8(min58)
18743             y38b = 0.0
18744           END IF
18745           crb = crb + y38b
18746           abs38b = y38b
18747           CALL POPCONTROL1B(branch)
18748           IF (branch .EQ. 0) THEN
18749             crb = crb + abs38b
18750           ELSE
18751             crb = crb - abs38b
18752           END IF
18753           temp31b66 = dt*crb/(dz*mu)
18754           velb = velb + temp31b66
18755           mub0 = mub0 - vel*temp31b66/mu
18756           CALL POPREAL8(vel)
18757           romb(i, k, j) = romb(i, k, j) + velb
18758           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
18759           mu = 0.5*(mut(i, j)+mut(i, j))
18760           CALL POPREAL8(dz)
18761           k = kts + 2
18762           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
18763           temp31b67 = vel*fqzb(i, k, j)
18764           temp31b68 = 7.*temp31b67/12.
18765           velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k&
18766 &            +1, j)+field(i, k-2, j))/12.)*fqzb(i, k, j)
18767           fieldb(i, k, j) = fieldb(i, k, j) + temp31b68
18768           fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b68
18769           fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b67/12.
18770           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b67/12.
18771           fqzb(i, k, j) = 0.0
18772           temp31b69 = dz*mu*fqzlb(i, k, j)/dt
18773           min57b = 0.5*field_old(i, k-1, j)*temp31b69
18774           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min57*&
18775 &            temp31b69
18776           max38b = 0.5*field_old(i, k, j)*temp31b69
18777           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max38*&
18778 &            temp31b69
18779           mub0 = (0.5*(min57*field_old(i, k-1, j))+0.5*(max38*field_old(&
18780 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
18781           fqzlb(i, k, j) = 0.0
18782           CALL POPCONTROL1B(branch)
18783           IF (branch .EQ. 0) THEN
18784             CALL POPREAL8(max38)
18785             y88b = max38b
18786           ELSE
18787             CALL POPREAL8(max38)
18788             y88b = 0.0
18789           END IF
18790           crb = y88b
18791           abs88b = -y88b
18792           CALL POPCONTROL1B(branch)
18793           IF (branch .EQ. 0) THEN
18794             crb = crb + abs88b
18795           ELSE
18796             crb = crb - abs88b
18797           END IF
18798           CALL POPCONTROL1B(branch)
18799           IF (branch .EQ. 0) THEN
18800             CALL POPREAL8(min57)
18801             y37b = min57b
18802           ELSE
18803             CALL POPREAL8(min57)
18804             y37b = 0.0
18805           END IF
18806           crb = crb + y37b
18807           abs37b = y37b
18808           CALL POPCONTROL1B(branch)
18809           IF (branch .EQ. 0) THEN
18810             crb = crb + abs37b
18811           ELSE
18812             crb = crb - abs37b
18813           END IF
18814           temp31b63 = dt*crb/(dz*mu)
18815           velb = velb + temp31b63
18816           mub0 = mub0 - vel*temp31b63/mu
18817           CALL POPREAL8(vel)
18818           romb(i, k, j) = romb(i, k, j) + velb
18819           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
18820           mu = 0.5*(mut(i, j)+mut(i, j))
18821           CALL POPREAL8(dz)
18822           k = kts + 1
18823           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
18824           temp31b64 = rom(i, k, j)*fqzb(i, k, j)
18825           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
18826 &            field(i, k-1, j))*fqzb(i, k, j)
18827           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b64
18828           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b64
18829           fqzb(i, k, j) = 0.0
18830           temp31b65 = dz*mu*fqzlb(i, k, j)/dt
18831           min56b = 0.5*field_old(i, k-1, j)*temp31b65
18832           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min56*&
18833 &            temp31b65
18834           max37b = 0.5*field_old(i, k, j)*temp31b65
18835           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max37*&
18836 &            temp31b65
18837           mub0 = (0.5*(min56*field_old(i, k-1, j))+0.5*(max37*field_old(&
18838 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
18839           fqzlb(i, k, j) = 0.0
18840           CALL POPCONTROL1B(branch)
18841           IF (branch .EQ. 0) THEN
18842             CALL POPREAL8(max37)
18843             y87b = max37b
18844           ELSE
18845             CALL POPREAL8(max37)
18846             y87b = 0.0
18847           END IF
18848           crb = y87b
18849           abs87b = -y87b
18850           CALL POPCONTROL1B(branch)
18851           IF (branch .EQ. 0) THEN
18852             crb = crb + abs87b
18853           ELSE
18854             crb = crb - abs87b
18855           END IF
18856           CALL POPCONTROL1B(branch)
18857           IF (branch .EQ. 0) THEN
18858             CALL POPREAL8(min56)
18859             y36b = min56b
18860           ELSE
18861             CALL POPREAL8(min56)
18862             y36b = 0.0
18863           END IF
18864           crb = crb + y36b
18865           abs36b = y36b
18866           CALL POPCONTROL1B(branch)
18867           IF (branch .EQ. 0) THEN
18868             crb = crb + abs36b
18869           ELSE
18870             crb = crb - abs36b
18871           END IF
18872           temp31b62 = dt*crb/(dz*mu)
18873           velb = temp31b62
18874           mub0 = mub0 - vel*temp31b62/mu
18875           CALL POPREAL8(vel)
18876           romb(i, k, j) = romb(i, k, j) + velb
18877           CALL POPREAL8(mu)
18878           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
18879           CALL POPREAL8(dz)
18880           CALL POPINTEGER4(k)
18881         END DO
18882         DO k=ktf-2,kts+3,-1
18883           CALL POPINTEGER4(ad_from36)
18884           CALL POPINTEGER4(ad_to36)
18885           DO i=ad_to36,ad_from36,-1
18886             fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
18887             temp31b58 = vel*fqzb(i, k, j)
18888             temp31b59 = 37.*temp31b58/60.
18889             temp31b60 = -(2.*temp31b58/15.)
18890             velb = (37.*((field(i, k, j)+field(i, k-1, j))/60.)-2.*((&
18891 &              field(i, k+1, j)+field(i, k-2, j))/15.)+(field(i, k+2, j)+&
18892 &              field(i, k-3, j))/60.)*fqzb(i, k, j)
18893             fieldb(i, k, j) = fieldb(i, k, j) + temp31b59
18894             fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b59
18895             fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp31b60
18896             fieldb(i, k-2, j) = fieldb(i, k-2, j) + temp31b60
18897             fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b58/60.
18898             fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b58/60.
18899             fqzb(i, k, j) = 0.0
18900             temp31b61 = dz*mu*fqzlb(i, k, j)/dt
18901             min55b = 0.5*field_old(i, k-1, j)*temp31b61
18902             field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min55*&
18903 &              temp31b61
18904             max36b = 0.5*field_old(i, k, j)*temp31b61
18905             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max36*&
18906 &              temp31b61
18907             mub0 = (0.5*(min55*field_old(i, k-1, j))+0.5*(max36*&
18908 &              field_old(i, k, j)))*dz*fqzlb(i, k, j)/dt
18909             fqzlb(i, k, j) = 0.0
18910             CALL POPCONTROL1B(branch)
18911             IF (branch .EQ. 0) THEN
18912               CALL POPREAL8(max36)
18913               y86b = max36b
18914             ELSE
18915               CALL POPREAL8(max36)
18916               y86b = 0.0
18917             END IF
18918             crb = y86b
18919             abs86b = -y86b
18920             CALL POPCONTROL1B(branch)
18921             IF (branch .EQ. 0) THEN
18922               crb = crb + abs86b
18923             ELSE
18924               crb = crb - abs86b
18925             END IF
18926             CALL POPCONTROL1B(branch)
18927             IF (branch .EQ. 0) THEN
18928               CALL POPREAL8(min55)
18929               y35b = min55b
18930             ELSE
18931               CALL POPREAL8(min55)
18932               y35b = 0.0
18933             END IF
18934             crb = crb + y35b
18935             abs35b = y35b
18936             CALL POPCONTROL1B(branch)
18937             IF (branch .EQ. 0) THEN
18938               crb = crb + abs35b
18939             ELSE
18940               crb = crb - abs35b
18941             END IF
18942             temp31b57 = dt*crb/(dz*mu)
18943             velb = velb + temp31b57
18944             mub0 = mub0 - vel*temp31b57/mu
18945             CALL POPREAL8(vel)
18946             romb(i, k, j) = romb(i, k, j) + velb
18947             CALL POPREAL8(mu)
18948             mutb(i, j) = mutb(i, j) + 0.5*2*mub0
18949             CALL POPREAL8(dz)
18950           END DO
18951         END DO
18952         CALL POPINTEGER4(k)
18953         CALL POPINTEGER4(ad_from35)
18954         CALL POPINTEGER4(ad_to35)
18955         DO i=ad_to35,ad_from35,-1
18956           fqzlb(i, kde, j) = 0.0
18957           fqzb(i, kde, j) = 0.0
18958           fqzlb(i, 1, j) = 0.0
18959           fqzb(i, 1, j) = 0.0
18960         END DO
18961         CALL POPINTEGER4(i)
18962       END DO
18963     ELSE IF (branch .EQ. 1) THEN
18964       CALL POPINTEGER4(ad_from42)
18965       CALL POPINTEGER4(ad_to42)
18966       DO j=ad_to42,ad_from42,-1
18967         CALL POPINTEGER4(ad_from41)
18968         CALL POPINTEGER4(ad_to41)
18969         DO i=ad_to41,ad_from41,-1
18970           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
18971           temp43b0 = rom(i, k, j)*fqzb(i, k, j)
18972           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
18973 &            field(i, k-1, j))*fqzb(i, k, j)
18974           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b0
18975           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b0
18976           fqzb(i, k, j) = 0.0
18977           temp43b1 = dz*mu*fqzlb(i, k, j)/dt
18978           min64b = 0.5*field_old(i, k-1, j)*temp43b1
18979           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min64*&
18980 &            temp43b1
18981           max45b = 0.5*field_old(i, k, j)*temp43b1
18982           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max45*temp43b1
18983           mub0 = (0.5*(min64*field_old(i, k-1, j))+0.5*(max45*field_old(&
18984 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
18985           fqzlb(i, k, j) = 0.0
18986           CALL POPCONTROL1B(branch)
18987           IF (branch .EQ. 0) THEN
18988             CALL POPREAL8(max45)
18989             y95b = max45b
18990           ELSE
18991             CALL POPREAL8(max45)
18992             y95b = 0.0
18993           END IF
18994           crb = y95b
18995           abs95b = -y95b
18996           CALL POPCONTROL1B(branch)
18997           IF (branch .EQ. 0) THEN
18998             crb = crb + abs95b
18999           ELSE
19000             crb = crb - abs95b
19001           END IF
19002           CALL POPCONTROL1B(branch)
19003           IF (branch .EQ. 0) THEN
19004             CALL POPREAL8(min64)
19005             y44b = min64b
19006           ELSE
19007             CALL POPREAL8(min64)
19008             y44b = 0.0
19009           END IF
19010           crb = crb + y44b
19011           abs44b = y44b
19012           CALL POPCONTROL1B(branch)
19013           IF (branch .EQ. 0) THEN
19014             crb = crb + abs44b
19015           ELSE
19016             crb = crb - abs44b
19017           END IF
19018           temp43b = dt*crb/(dz*mu)
19019           velb = temp43b
19020           mub0 = mub0 - vel*temp43b/mu
19021           CALL POPREAL8(vel)
19022           romb(i, k, j) = romb(i, k, j) + velb
19023           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19024           mu = 0.5*(mut(i, j)+mut(i, j))
19025           CALL POPREAL8(dz)
19026           k = ktf - 1
19027           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19028           temp39 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k&
19029 &            , j)-field(i, k-1, j))
19030           temp42 = SIGN(1., -vel)
19031           temp41 = temp42/12.
19032           temp40 = SIGN(1, time_step)
19033           temp39b0 = vel*fqzb(i, k, j)
19034           temp39b1 = 7.*temp39b0/12.
19035           temp39b2 = temp40*temp41*temp39b0
19036           velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k&
19037 &            +1, j)+field(i, k-2, j))/12.+temp40*(temp41*temp39))*fqzb(i&
19038 &            , k, j)
19039           fieldb(i, k, j) = fieldb(i, k, j) + temp39b1 - 3.*temp39b2
19040           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp39b2 + temp39b1
19041           fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp39b2 - temp39b0/&
19042 &            12.
19043           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp39b2 - temp39b0/&
19044 &            12.
19045           fqzb(i, k, j) = 0.0
19046           temp39b3 = dz*mu*fqzlb(i, k, j)/dt
19047           min63b = 0.5*field_old(i, k-1, j)*temp39b3
19048           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min63*&
19049 &            temp39b3
19050           max44b = 0.5*field_old(i, k, j)*temp39b3
19051           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max44*temp39b3
19052           mub0 = (0.5*(min63*field_old(i, k-1, j))+0.5*(max44*field_old(&
19053 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19054           fqzlb(i, k, j) = 0.0
19055           CALL POPCONTROL1B(branch)
19056           IF (branch .EQ. 0) THEN
19057             CALL POPREAL8(max44)
19058             y94b = max44b
19059           ELSE
19060             CALL POPREAL8(max44)
19061             y94b = 0.0
19062           END IF
19063           crb = y94b
19064           abs94b = -y94b
19065           CALL POPCONTROL1B(branch)
19066           IF (branch .EQ. 0) THEN
19067             crb = crb + abs94b
19068           ELSE
19069             crb = crb - abs94b
19070           END IF
19071           CALL POPCONTROL1B(branch)
19072           IF (branch .EQ. 0) THEN
19073             CALL POPREAL8(min63)
19074             y43b = min63b
19075           ELSE
19076             CALL POPREAL8(min63)
19077             y43b = 0.0
19078           END IF
19079           crb = crb + y43b
19080           abs43b = y43b
19081           CALL POPCONTROL1B(branch)
19082           IF (branch .EQ. 0) THEN
19083             crb = crb + abs43b
19084           ELSE
19085             crb = crb - abs43b
19086           END IF
19087           temp39b = dt*crb/(dz*mu)
19088           velb = velb + temp39b
19089           mub0 = mub0 - vel*temp39b/mu
19090           CALL POPREAL8(vel)
19091           romb(i, k, j) = romb(i, k, j) + velb
19092           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19093           mu = 0.5*(mut(i, j)+mut(i, j))
19094           CALL POPREAL8(dz)
19095           k = kts + 2
19096           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19097           temp35 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k&
19098 &            , j)-field(i, k-1, j))
19099           temp38 = SIGN(1., -vel)
19100           temp37 = temp38/12.
19101           temp36 = SIGN(1, time_step)
19102           temp35b3 = vel*fqzb(i, k, j)
19103           temp35b4 = 7.*temp35b3/12.
19104           temp35b5 = temp36*temp37*temp35b3
19105           velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k&
19106 &            +1, j)+field(i, k-2, j))/12.+temp36*(temp37*temp35))*fqzb(i&
19107 &            , k, j)
19108           fieldb(i, k, j) = fieldb(i, k, j) + temp35b4 - 3.*temp35b5
19109           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp35b5 + temp35b4
19110           fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp35b5 - temp35b3/&
19111 &            12.
19112           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp35b5 - temp35b3/&
19113 &            12.
19114           fqzb(i, k, j) = 0.0
19115           temp35b6 = dz*mu*fqzlb(i, k, j)/dt
19116           min62b = 0.5*field_old(i, k-1, j)*temp35b6
19117           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min62*&
19118 &            temp35b6
19119           max43b = 0.5*field_old(i, k, j)*temp35b6
19120           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max43*temp35b6
19121           mub0 = (0.5*(min62*field_old(i, k-1, j))+0.5*(max43*field_old(&
19122 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19123           fqzlb(i, k, j) = 0.0
19124           CALL POPCONTROL1B(branch)
19125           IF (branch .EQ. 0) THEN
19126             CALL POPREAL8(max43)
19127             y93b = max43b
19128           ELSE
19129             CALL POPREAL8(max43)
19130             y93b = 0.0
19131           END IF
19132           crb = y93b
19133           abs93b = -y93b
19134           CALL POPCONTROL1B(branch)
19135           IF (branch .EQ. 0) THEN
19136             crb = crb + abs93b
19137           ELSE
19138             crb = crb - abs93b
19139           END IF
19140           CALL POPCONTROL1B(branch)
19141           IF (branch .EQ. 0) THEN
19142             CALL POPREAL8(min62)
19143             y42b = min62b
19144           ELSE
19145             CALL POPREAL8(min62)
19146             y42b = 0.0
19147           END IF
19148           crb = crb + y42b
19149           abs42b = y42b
19150           CALL POPCONTROL1B(branch)
19151           IF (branch .EQ. 0) THEN
19152             crb = crb + abs42b
19153           ELSE
19154             crb = crb - abs42b
19155           END IF
19156           temp35b0 = dt*crb/(dz*mu)
19157           velb = velb + temp35b0
19158           mub0 = mub0 - vel*temp35b0/mu
19159           CALL POPREAL8(vel)
19160           romb(i, k, j) = romb(i, k, j) + velb
19161           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19162           mu = 0.5*(mut(i, j)+mut(i, j))
19163           CALL POPREAL8(dz)
19164           k = kts + 1
19165           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19166           temp35b1 = rom(i, k, j)*fqzb(i, k, j)
19167           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
19168 &            field(i, k-1, j))*fqzb(i, k, j)
19169           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp35b1
19170           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp35b1
19171           fqzb(i, k, j) = 0.0
19172           temp35b2 = dz*mu*fqzlb(i, k, j)/dt
19173           min61b = 0.5*field_old(i, k-1, j)*temp35b2
19174           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min61*&
19175 &            temp35b2
19176           max42b = 0.5*field_old(i, k, j)*temp35b2
19177           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max42*temp35b2
19178           mub0 = (0.5*(min61*field_old(i, k-1, j))+0.5*(max42*field_old(&
19179 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19180           fqzlb(i, k, j) = 0.0
19181           CALL POPCONTROL1B(branch)
19182           IF (branch .EQ. 0) THEN
19183             CALL POPREAL8(max42)
19184             y92b = max42b
19185           ELSE
19186             CALL POPREAL8(max42)
19187             y92b = 0.0
19188           END IF
19189           crb = y92b
19190           abs92b = -y92b
19191           CALL POPCONTROL1B(branch)
19192           IF (branch .EQ. 0) THEN
19193             crb = crb + abs92b
19194           ELSE
19195             crb = crb - abs92b
19196           END IF
19197           CALL POPCONTROL1B(branch)
19198           IF (branch .EQ. 0) THEN
19199             CALL POPREAL8(min61)
19200             y41b = min61b
19201           ELSE
19202             CALL POPREAL8(min61)
19203             y41b = 0.0
19204           END IF
19205           crb = crb + y41b
19206           abs41b = y41b
19207           CALL POPCONTROL1B(branch)
19208           IF (branch .EQ. 0) THEN
19209             crb = crb + abs41b
19210           ELSE
19211             crb = crb - abs41b
19212           END IF
19213           temp35b = dt*crb/(dz*mu)
19214           velb = temp35b
19215           mub0 = mub0 - vel*temp35b/mu
19216           CALL POPREAL8(vel)
19217           romb(i, k, j) = romb(i, k, j) + velb
19218           CALL POPREAL8(mu)
19219           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19220           CALL POPREAL8(dz)
19221           CALL POPINTEGER4(k)
19222         END DO
19223         DO k=ktf-2,kts+3,-1
19224           CALL POPINTEGER4(ad_from40)
19225           CALL POPINTEGER4(ad_to40)
19226           DO i=ad_to40,ad_from40,-1
19227             fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19228             temp31 = field(i, k+2, j) - field(i, k-3, j) + 10.*(field(i&
19229 &              , k, j)-field(i, k-1, j)) - 5.*(field(i, k+1, j)-field(i, &
19230 &              k-2, j))
19231             temp34 = SIGN(1., -vel)
19232             temp33 = temp34/60.
19233             temp32 = SIGN(1, time_step)
19234             temp31b77 = vel*fqzb(i, k, j)
19235             temp31b78 = 37.*temp31b77/60.
19236             temp31b79 = -(2.*temp31b77/15.)
19237             temp31b80 = -(temp32*temp33*temp31b77)
19238             velb = (37.*((field(i, k, j)+field(i, k-1, j))/60.)-2.*((&
19239 &              field(i, k+1, j)+field(i, k-2, j))/15.)+(field(i, k+2, j)+&
19240 &              field(i, k-3, j))/60.-temp32*(temp33*temp31))*fqzb(i, k, j&
19241 &              )
19242             fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp31b80 + &
19243 &              temp31b78
19244             fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b78 - 10.*&
19245 &              temp31b80
19246             fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp31b79 - 5.*&
19247 &              temp31b80
19248             fieldb(i, k-2, j) = fieldb(i, k-2, j) + 5.*temp31b80 + &
19249 &              temp31b79
19250             fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b80 + &
19251 &              temp31b77/60.
19252             fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b77/60. - &
19253 &              temp31b80
19254             fqzb(i, k, j) = 0.0
19255             temp31b81 = dz*mu*fqzlb(i, k, j)/dt
19256             min60b = 0.5*field_old(i, k-1, j)*temp31b81
19257             field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min60*&
19258 &              temp31b81
19259             max41b = 0.5*field_old(i, k, j)*temp31b81
19260             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max41*&
19261 &              temp31b81
19262             mub0 = (0.5*(min60*field_old(i, k-1, j))+0.5*(max41*&
19263 &              field_old(i, k, j)))*dz*fqzlb(i, k, j)/dt
19264             fqzlb(i, k, j) = 0.0
19265             CALL POPCONTROL1B(branch)
19266             IF (branch .EQ. 0) THEN
19267               CALL POPREAL8(max41)
19268               y91b = max41b
19269             ELSE
19270               CALL POPREAL8(max41)
19271               y91b = 0.0
19272             END IF
19273             crb = y91b
19274             abs91b = -y91b
19275             CALL POPCONTROL1B(branch)
19276             IF (branch .EQ. 0) THEN
19277               crb = crb + abs91b
19278             ELSE
19279               crb = crb - abs91b
19280             END IF
19281             CALL POPCONTROL1B(branch)
19282             IF (branch .EQ. 0) THEN
19283               CALL POPREAL8(min60)
19284               y40b = min60b
19285             ELSE
19286               CALL POPREAL8(min60)
19287               y40b = 0.0
19288             END IF
19289             crb = crb + y40b
19290             abs40b = y40b
19291             CALL POPCONTROL1B(branch)
19292             IF (branch .EQ. 0) THEN
19293               crb = crb + abs40b
19294             ELSE
19295               crb = crb - abs40b
19296             END IF
19297             temp31b76 = dt*crb/(dz*mu)
19298             velb = velb + temp31b76
19299             mub0 = mub0 - vel*temp31b76/mu
19300             CALL POPREAL8(vel)
19301             romb(i, k, j) = romb(i, k, j) + velb
19302             CALL POPREAL8(mu)
19303             mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19304             CALL POPREAL8(dz)
19305           END DO
19306         END DO
19307         CALL POPINTEGER4(k)
19308         CALL POPINTEGER4(ad_from39)
19309         CALL POPINTEGER4(ad_to39)
19310         DO i=ad_to39,ad_from39,-1
19311           fqzlb(i, kde, j) = 0.0
19312           fqzb(i, kde, j) = 0.0
19313           fqzlb(i, 1, j) = 0.0
19314           fqzb(i, 1, j) = 0.0
19315         END DO
19316         CALL POPINTEGER4(i)
19317       END DO
19318     ELSE
19319       CALL POPINTEGER4(ad_from46)
19320       CALL POPINTEGER4(ad_to46)
19321       DO j=ad_to46,ad_from46,-1
19322         CALL POPINTEGER4(ad_from45)
19323         CALL POPINTEGER4(ad_to45)
19324         DO i=ad_to45,ad_from45,-1
19325           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19326           temp43b10 = rom(i, k, j)*fqzb(i, k, j)
19327           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
19328 &            field(i, k-1, j))*fqzb(i, k, j)
19329           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b10
19330           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b10
19331           fqzb(i, k, j) = 0.0
19332           temp43b11 = dz*mu*fqzlb(i, k, j)/dt
19333           min67b = 0.5*field_old(i, k-1, j)*temp43b11
19334           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min67*&
19335 &            temp43b11
19336           max48b = 0.5*field_old(i, k, j)*temp43b11
19337           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max48*&
19338 &            temp43b11
19339           mub0 = (0.5*(min67*field_old(i, k-1, j))+0.5*(max48*field_old(&
19340 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19341           fqzlb(i, k, j) = 0.0
19342           CALL POPCONTROL1B(branch)
19343           IF (branch .EQ. 0) THEN
19344             CALL POPREAL8(max48)
19345             y98b = max48b
19346           ELSE
19347             CALL POPREAL8(max48)
19348             y98b = 0.0
19349           END IF
19350           crb = y98b
19351           abs98b = -y98b
19352           CALL POPCONTROL1B(branch)
19353           IF (branch .EQ. 0) THEN
19354             crb = crb + abs98b
19355           ELSE
19356             crb = crb - abs98b
19357           END IF
19358           CALL POPCONTROL1B(branch)
19359           IF (branch .EQ. 0) THEN
19360             CALL POPREAL8(min67)
19361             y47b = min67b
19362           ELSE
19363             CALL POPREAL8(min67)
19364             y47b = 0.0
19365           END IF
19366           crb = crb + y47b
19367           abs47b = y47b
19368           CALL POPCONTROL1B(branch)
19369           IF (branch .EQ. 0) THEN
19370             crb = crb + abs47b
19371           ELSE
19372             crb = crb - abs47b
19373           END IF
19374           temp43b7 = dt*crb/(dz*mu)
19375           velb = temp43b7
19376           mub0 = mub0 - vel*temp43b7/mu
19377           CALL POPREAL8(vel)
19378           romb(i, k, j) = romb(i, k, j) + velb
19379           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19380           mu = 0.5*(mut(i, j)+mut(i, j))
19381           CALL POPREAL8(dz)
19382           k = kts + 1
19383           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19384           temp43b8 = rom(i, k, j)*fqzb(i, k, j)
19385           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
19386 &            field(i, k-1, j))*fqzb(i, k, j)
19387           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b8
19388           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b8
19389           fqzb(i, k, j) = 0.0
19390           temp43b9 = dz*mu*fqzlb(i, k, j)/dt
19391           min66b = 0.5*field_old(i, k-1, j)*temp43b9
19392           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min66*&
19393 &            temp43b9
19394           max47b = 0.5*field_old(i, k, j)*temp43b9
19395           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max47*temp43b9
19396           mub0 = (0.5*(min66*field_old(i, k-1, j))+0.5*(max47*field_old(&
19397 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19398           fqzlb(i, k, j) = 0.0
19399           CALL POPCONTROL1B(branch)
19400           IF (branch .EQ. 0) THEN
19401             CALL POPREAL8(max47)
19402             y97b = max47b
19403           ELSE
19404             CALL POPREAL8(max47)
19405             y97b = 0.0
19406           END IF
19407           crb = y97b
19408           abs97b = -y97b
19409           CALL POPCONTROL1B(branch)
19410           IF (branch .EQ. 0) THEN
19411             crb = crb + abs97b
19412           ELSE
19413             crb = crb - abs97b
19414           END IF
19415           CALL POPCONTROL1B(branch)
19416           IF (branch .EQ. 0) THEN
19417             CALL POPREAL8(min66)
19418             y46b = min66b
19419           ELSE
19420             CALL POPREAL8(min66)
19421             y46b = 0.0
19422           END IF
19423           crb = crb + y46b
19424           abs46b = y46b
19425           CALL POPCONTROL1B(branch)
19426           IF (branch .EQ. 0) THEN
19427             crb = crb + abs46b
19428           ELSE
19429             crb = crb - abs46b
19430           END IF
19431           temp43b6 = dt*crb/(dz*mu)
19432           velb = temp43b6
19433           mub0 = mub0 - vel*temp43b6/mu
19434           CALL POPREAL8(vel)
19435           romb(i, k, j) = romb(i, k, j) + velb
19436           CALL POPREAL8(mu)
19437           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19438           CALL POPREAL8(dz)
19439           CALL POPINTEGER4(k)
19440         END DO
19441         DO k=ktf-1,kts+2,-1
19442           CALL POPINTEGER4(ad_from44)
19443           CALL POPINTEGER4(ad_to44)
19444           DO i=ad_to44,ad_from44,-1
19445             fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19446             temp43b3 = vel*fqzb(i, k, j)
19447             temp43b4 = 7.*temp43b3/12.
19448             velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i&
19449 &              , k+1, j)+field(i, k-2, j))/12.)*fqzb(i, k, j)
19450             fieldb(i, k, j) = fieldb(i, k, j) + temp43b4
19451             fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp43b4
19452             fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp43b3/12.
19453             fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b3/12.
19454             fqzb(i, k, j) = 0.0
19455             temp43b5 = dz*mu*fqzlb(i, k, j)/dt
19456             min65b = 0.5*field_old(i, k-1, j)*temp43b5
19457             field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min65*&
19458 &              temp43b5
19459             max46b = 0.5*field_old(i, k, j)*temp43b5
19460             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max46*&
19461 &              temp43b5
19462             mub0 = (0.5*(min65*field_old(i, k-1, j))+0.5*(max46*&
19463 &              field_old(i, k, j)))*dz*fqzlb(i, k, j)/dt
19464             fqzlb(i, k, j) = 0.0
19465             CALL POPCONTROL1B(branch)
19466             IF (branch .EQ. 0) THEN
19467               CALL POPREAL8(max46)
19468               y96b = max46b
19469             ELSE
19470               CALL POPREAL8(max46)
19471               y96b = 0.0
19472             END IF
19473             crb = y96b
19474             abs96b = -y96b
19475             CALL POPCONTROL1B(branch)
19476             IF (branch .EQ. 0) THEN
19477               crb = crb + abs96b
19478             ELSE
19479               crb = crb - abs96b
19480             END IF
19481             CALL POPCONTROL1B(branch)
19482             IF (branch .EQ. 0) THEN
19483               CALL POPREAL8(min65)
19484               y45b = min65b
19485             ELSE
19486               CALL POPREAL8(min65)
19487               y45b = 0.0
19488             END IF
19489             crb = crb + y45b
19490             abs45b = y45b
19491             CALL POPCONTROL1B(branch)
19492             IF (branch .EQ. 0) THEN
19493               crb = crb + abs45b
19494             ELSE
19495               crb = crb - abs45b
19496             END IF
19497             temp43b2 = dt*crb/(dz*mu)
19498             velb = velb + temp43b2
19499             mub0 = mub0 - vel*temp43b2/mu
19500             CALL POPREAL8(vel)
19501             romb(i, k, j) = romb(i, k, j) + velb
19502             CALL POPREAL8(mu)
19503             mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19504             CALL POPREAL8(dz)
19505           END DO
19506         END DO
19507         CALL POPINTEGER4(k)
19508         CALL POPINTEGER4(ad_from43)
19509         CALL POPINTEGER4(ad_to43)
19510         DO i=ad_to43,ad_from43,-1
19511           fqzlb(i, kde, j) = 0.0
19512           fqzb(i, kde, j) = 0.0
19513           fqzlb(i, 1, j) = 0.0
19514           fqzb(i, 1, j) = 0.0
19515         END DO
19516         CALL POPINTEGER4(i)
19517       END DO
19518     END IF
19519   ELSE IF (branch .EQ. 3) THEN
19520     CALL POPINTEGER4(ad_from50)
19521     CALL POPINTEGER4(ad_to50)
19522     DO j=ad_to50,ad_from50,-1
19523       CALL POPINTEGER4(ad_from49)
19524       CALL POPINTEGER4(ad_to49)
19525       DO i=ad_to49,ad_from49,-1
19526         fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19527         temp47b3 = rom(i, k, j)*fqzb(i, k, j)
19528         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
19529 &          field(i, k-1, j))*fqzb(i, k, j)
19530         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b3
19531         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b3
19532         fqzb(i, k, j) = 0.0
19533         temp47b4 = dz*mu*fqzlb(i, k, j)/dt
19534         min70b = 0.5*field_old(i, k-1, j)*temp47b4
19535         field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min70*&
19536 &          temp47b4
19537         max51b = 0.5*field_old(i, k, j)*temp47b4
19538         field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max51*temp47b4
19539         mub0 = (0.5*(min70*field_old(i, k-1, j))+0.5*(max51*field_old(i&
19540 &          , k, j)))*dz*fqzlb(i, k, j)/dt
19541         fqzlb(i, k, j) = 0.0
19542         CALL POPCONTROL1B(branch)
19543         IF (branch .EQ. 0) THEN
19544           CALL POPREAL8(max51)
19545           y101b = max51b
19546         ELSE
19547           CALL POPREAL8(max51)
19548           y101b = 0.0
19549         END IF
19550         crb = y101b
19551         abs101b = -y101b
19552         CALL POPCONTROL1B(branch)
19553         IF (branch .EQ. 0) THEN
19554           crb = crb + abs101b
19555         ELSE
19556           crb = crb - abs101b
19557         END IF
19558         CALL POPCONTROL1B(branch)
19559         IF (branch .EQ. 0) THEN
19560           CALL POPREAL8(min70)
19561           y50b = min70b
19562         ELSE
19563           CALL POPREAL8(min70)
19564           y50b = 0.0
19565         END IF
19566         crb = crb + y50b
19567         abs50b = y50b
19568         CALL POPCONTROL1B(branch)
19569         IF (branch .EQ. 0) THEN
19570           crb = crb + abs50b
19571         ELSE
19572           crb = crb - abs50b
19573         END IF
19574         temp47b0 = dt*crb/(dz*mu)
19575         velb = temp47b0
19576         mub0 = mub0 - vel*temp47b0/mu
19577         CALL POPREAL8(vel)
19578         romb(i, k, j) = romb(i, k, j) + velb
19579         mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19580         mu = 0.5*(mut(i, j)+mut(i, j))
19581         CALL POPREAL8(dz)
19582         k = kts + 1
19583         fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19584         temp47b1 = rom(i, k, j)*fqzb(i, k, j)
19585         romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
19586 &          field(i, k-1, j))*fqzb(i, k, j)
19587         fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b1
19588         fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b1
19589         fqzb(i, k, j) = 0.0
19590         temp47b2 = dz*mu*fqzlb(i, k, j)/dt
19591         min69b = 0.5*field_old(i, k-1, j)*temp47b2
19592         field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min69*&
19593 &          temp47b2
19594         max50b = 0.5*field_old(i, k, j)*temp47b2
19595         field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max50*temp47b2
19596         mub0 = (0.5*(min69*field_old(i, k-1, j))+0.5*(max50*field_old(i&
19597 &          , k, j)))*dz*fqzlb(i, k, j)/dt
19598         fqzlb(i, k, j) = 0.0
19599         CALL POPCONTROL1B(branch)
19600         IF (branch .EQ. 0) THEN
19601           CALL POPREAL8(max50)
19602           y100b = max50b
19603         ELSE
19604           CALL POPREAL8(max50)
19605           y100b = 0.0
19606         END IF
19607         crb = y100b
19608         abs100b = -y100b
19609         CALL POPCONTROL1B(branch)
19610         IF (branch .EQ. 0) THEN
19611           crb = crb + abs100b
19612         ELSE
19613           crb = crb - abs100b
19614         END IF
19615         CALL POPCONTROL1B(branch)
19616         IF (branch .EQ. 0) THEN
19617           CALL POPREAL8(min69)
19618           y49b = min69b
19619         ELSE
19620           CALL POPREAL8(min69)
19621           y49b = 0.0
19622         END IF
19623         crb = crb + y49b
19624         abs49b = y49b
19625         CALL POPCONTROL1B(branch)
19626         IF (branch .EQ. 0) THEN
19627           crb = crb + abs49b
19628         ELSE
19629           crb = crb - abs49b
19630         END IF
19631         temp47b = dt*crb/(dz*mu)
19632         velb = temp47b
19633         mub0 = mub0 - vel*temp47b/mu
19634         CALL POPREAL8(vel)
19635         romb(i, k, j) = romb(i, k, j) + velb
19636         CALL POPREAL8(mu)
19637         mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19638         CALL POPREAL8(dz)
19639         CALL POPINTEGER4(k)
19640       END DO
19641       DO k=ktf-1,kts+2,-1
19642         CALL POPINTEGER4(ad_from48)
19643         CALL POPINTEGER4(ad_to48)
19644         DO i=ad_to48,ad_from48,-1
19645           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19646           temp43 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k&
19647 &            , j)-field(i, k-1, j))
19648           temp46 = SIGN(1., -vel)
19649           temp45 = temp46/12.
19650           temp44 = SIGN(1, time_step)
19651           temp43b13 = vel*fqzb(i, k, j)
19652           temp43b14 = 7.*temp43b13/12.
19653           temp43b15 = temp44*temp45*temp43b13
19654           velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k&
19655 &            +1, j)+field(i, k-2, j))/12.+temp44*(temp45*temp43))*fqzb(i&
19656 &            , k, j)
19657           fieldb(i, k, j) = fieldb(i, k, j) + temp43b14 - 3.*temp43b15
19658           fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp43b15 + &
19659 &            temp43b14
19660           fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp43b15 - temp43b13/&
19661 &            12.
19662           fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b15 - temp43b13/&
19663 &            12.
19664           fqzb(i, k, j) = 0.0
19665           temp43b16 = dz*mu*fqzlb(i, k, j)/dt
19666           min68b = 0.5*field_old(i, k-1, j)*temp43b16
19667           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min68*&
19668 &            temp43b16
19669           max49b = 0.5*field_old(i, k, j)*temp43b16
19670           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max49*&
19671 &            temp43b16
19672           mub0 = (0.5*(min68*field_old(i, k-1, j))+0.5*(max49*field_old(&
19673 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19674           fqzlb(i, k, j) = 0.0
19675           CALL POPCONTROL1B(branch)
19676           IF (branch .EQ. 0) THEN
19677             CALL POPREAL8(max49)
19678             y99b = max49b
19679           ELSE
19680             CALL POPREAL8(max49)
19681             y99b = 0.0
19682           END IF
19683           crb = y99b
19684           abs99b = -y99b
19685           CALL POPCONTROL1B(branch)
19686           IF (branch .EQ. 0) THEN
19687             crb = crb + abs99b
19688           ELSE
19689             crb = crb - abs99b
19690           END IF
19691           CALL POPCONTROL1B(branch)
19692           IF (branch .EQ. 0) THEN
19693             CALL POPREAL8(min68)
19694             y48b = min68b
19695           ELSE
19696             CALL POPREAL8(min68)
19697             y48b = 0.0
19698           END IF
19699           crb = crb + y48b
19700           abs48b = y48b
19701           CALL POPCONTROL1B(branch)
19702           IF (branch .EQ. 0) THEN
19703             crb = crb + abs48b
19704           ELSE
19705             crb = crb - abs48b
19706           END IF
19707           temp43b12 = dt*crb/(dz*mu)
19708           velb = velb + temp43b12
19709           mub0 = mub0 - vel*temp43b12/mu
19710           CALL POPREAL8(vel)
19711           romb(i, k, j) = romb(i, k, j) + velb
19712           CALL POPREAL8(mu)
19713           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19714           CALL POPREAL8(dz)
19715         END DO
19716       END DO
19717       CALL POPINTEGER4(k)
19718       CALL POPINTEGER4(ad_from47)
19719       CALL POPINTEGER4(ad_to47)
19720       DO i=ad_to47,ad_from47,-1
19721         fqzlb(i, kde, j) = 0.0
19722         fqzb(i, kde, j) = 0.0
19723         fqzlb(i, 1, j) = 0.0
19724         fqzb(i, 1, j) = 0.0
19725       END DO
19726       CALL POPINTEGER4(i)
19727     END DO
19728   ELSE IF (branch .EQ. 4) THEN
19729     CALL POPINTEGER4(ad_from53)
19730     CALL POPINTEGER4(ad_to53)
19731     DO j=ad_to53,ad_from53,-1
19732       DO k=ktf,kts+1,-1
19733         CALL POPINTEGER4(ad_from52)
19734         CALL POPINTEGER4(ad_to52)
19735         DO i=ad_to52,ad_from52,-1
19736           fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
19737           temp47b6 = rom(i, k, j)*fqzb(i, k, j)
19738           romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
19739 &            field(i, k-1, j))*fqzb(i, k, j)
19740           fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b6
19741           fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b6
19742           fqzb(i, k, j) = 0.0
19743           temp47b7 = dz*mu*fqzlb(i, k, j)/dt
19744           min71b = 0.5*field_old(i, k-1, j)*temp47b7
19745           field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min71*&
19746 &            temp47b7
19747           max52b = 0.5*field_old(i, k, j)*temp47b7
19748           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max52*temp47b7
19749           mub0 = (0.5*(min71*field_old(i, k-1, j))+0.5*(max52*field_old(&
19750 &            i, k, j)))*dz*fqzlb(i, k, j)/dt
19751           fqzlb(i, k, j) = 0.0
19752           CALL POPCONTROL1B(branch)
19753           IF (branch .EQ. 0) THEN
19754             CALL POPREAL8(max52)
19755             y102b = max52b
19756           ELSE
19757             CALL POPREAL8(max52)
19758             y102b = 0.0
19759           END IF
19760           crb = y102b
19761           abs102b = -y102b
19762           CALL POPCONTROL1B(branch)
19763           IF (branch .EQ. 0) THEN
19764             crb = crb + abs102b
19765           ELSE
19766             crb = crb - abs102b
19767           END IF
19768           CALL POPCONTROL1B(branch)
19769           IF (branch .EQ. 0) THEN
19770             CALL POPREAL8(min71)
19771             y51b = min71b
19772           ELSE
19773             CALL POPREAL8(min71)
19774             y51b = 0.0
19775           END IF
19776           crb = crb + y51b
19777           abs51b = y51b
19778           CALL POPCONTROL1B(branch)
19779           IF (branch .EQ. 0) THEN
19780             crb = crb + abs51b
19781           ELSE
19782             crb = crb - abs51b
19783           END IF
19784           temp47b5 = dt*crb/(dz*mu)
19785           velb = temp47b5
19786           mub0 = mub0 - vel*temp47b5/mu
19787           CALL POPREAL8(vel)
19788           romb(i, k, j) = romb(i, k, j) + velb
19789           CALL POPREAL8(mu)
19790           mutb(i, j) = mutb(i, j) + 0.5*2*mub0
19791           CALL POPREAL8(dz)
19792         END DO
19793       END DO
19794       CALL POPINTEGER4(ad_from51)
19795       CALL POPINTEGER4(ad_to51)
19796       DO i=ad_to51,ad_from51,-1
19797         fqzlb(i, kde, j) = 0.0
19798         fqzb(i, kde, j) = 0.0
19799         fqzlb(i, 1, j) = 0.0
19800         fqzb(i, 1, j) = 0.0
19801       END DO
19802       CALL POPINTEGER4(i)
19803     END DO
19804   END IF
19805   CALL POPINTEGER4(j_end)
19806   CALL POPINTEGER4(i_end)
19807   CALL POPCONTROL1B(branch)
19808   IF (branch .NE. 0) THEN
19809     CALL POPINTEGER4(ad_from34)
19810     CALL POPINTEGER4(ad_to34)
19811     DO i=ad_to34,ad_from34,-1
19812       DO k=ktf,kts,-1
19813         temp31b56 = -(rdy*tendencyb(i, k, j_end))
19814         vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*&
19815 &          temp31b56
19816         field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*temp31b56
19817         field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*&
19818 &          temp31b56
19819         fieldb(i, k, j_end) = fieldb(i, k, j_end) - rv(i, k, jte-1)*&
19820 &          temp31b56
19821         rvb(i, k, jte-1) = rvb(i, k, jte-1) - field(i, k, j_end)*&
19822 &          temp31b56
19823         CALL POPCONTROL1B(branch)
19824         IF (branch .EQ. 0) THEN
19825           CALL POPREAL8(vb)
19826         ELSE
19827           CALL POPREAL8(vb)
19828           rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb
19829         END IF
19830       END DO
19831     END DO
19832     CALL POPINTEGER4(i)
19833   END IF
19834   CALL POPCONTROL1B(branch)
19835   IF (branch .EQ. 0) THEN
19836     CALL POPINTEGER4(ad_from33)
19837     CALL POPINTEGER4(ad_to33)
19838     DO i=ad_to33,ad_from33,-1
19839       DO k=ktf,kts,-1
19840         temp31b55 = -(rdy*tendencyb(i, k, jts))
19841         vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*temp31b55
19842         field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*temp31b55
19843         field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*temp31b55
19844         fieldb(i, k, jts) = fieldb(i, k, jts) + rv(i, k, jts+1)*&
19845 &          temp31b55
19846         rvb(i, k, jts+1) = rvb(i, k, jts+1) + field(i, k, jts)*temp31b55
19847         CALL POPCONTROL1B(branch)
19848         IF (branch .EQ. 0) THEN
19849           CALL POPREAL8(vb)
19850         ELSE
19851           CALL POPREAL8(vb)
19852           rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb
19853         END IF
19854       END DO
19855     END DO
19856     CALL POPINTEGER4(i)
19857   END IF
19858   CALL POPCONTROL1B(branch)
19859   IF (branch .EQ. 0) THEN
19860     CALL POPINTEGER4(ad_from32)
19861     CALL POPINTEGER4(ad_to32)
19862     DO i=ad_to32,ad_from32,-1
19863       DO k=ktf,kts,-1
19864         temp31b53 = -(rdy*tendencyb(i, k, j_end))
19865         temp31b54 = field(i, k, j_end)*temp31b53
19866         vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*&
19867 &          temp31b53
19868         field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*temp31b53
19869         field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*&
19870 &          temp31b53
19871         fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i&
19872 &          , k, jte-1))*temp31b53
19873         rvb(i, k, jte) = rvb(i, k, jte) + temp31b54
19874         rvb(i, k, jte-1) = rvb(i, k, jte-1) - temp31b54
19875         CALL POPCONTROL1B(branch)
19876         IF (branch .EQ. 0) THEN
19877           CALL POPREAL8(vb)
19878         ELSE
19879           CALL POPREAL8(vb)
19880           rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb
19881           rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb
19882         END IF
19883       END DO
19884     END DO
19885     CALL POPINTEGER4(i)
19886   END IF
19887   CALL POPCONTROL1B(branch)
19888   IF (branch .EQ. 0) THEN
19889     CALL POPINTEGER4(ad_from31)
19890     CALL POPINTEGER4(ad_to31)
19891     DO i=ad_to31,ad_from31,-1
19892       DO k=ktf,kts,-1
19893         temp31b51 = -(rdy*tendencyb(i, k, jts))
19894         temp31b52 = field(i, k, jts)*temp31b51
19895         vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*temp31b51
19896         field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*temp31b51
19897         field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*temp31b51
19898         fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k&
19899 &          , jts))*temp31b51
19900         rvb(i, k, jts+1) = rvb(i, k, jts+1) + temp31b52
19901         rvb(i, k, jts) = rvb(i, k, jts) - temp31b52
19902         CALL POPCONTROL1B(branch)
19903         IF (branch .EQ. 0) THEN
19904           CALL POPREAL8(vb)
19905         ELSE
19906           CALL POPREAL8(vb)
19907           rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb
19908           rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb
19909         END IF
19910       END DO
19911     END DO
19912     CALL POPINTEGER4(i)
19913   END IF
19914   CALL POPCONTROL1B(branch)
19915   IF (branch .EQ. 0) THEN
19916     CALL POPINTEGER4(ad_from30)
19917     CALL POPINTEGER4(ad_to30)
19918     DO j=ad_to30,ad_from30,-1
19919       DO k=ktf,kts,-1
19920         temp31b49 = -(rdx*tendencyb(i_end, k, j))
19921         temp31b50 = field(i_end, k, j)*temp31b49
19922         ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*&
19923 &          temp31b49
19924         field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*temp31b49
19925         field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*&
19926 &          temp31b49
19927         fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(&
19928 &          ite-1, k, j))*temp31b49
19929         rub(ite, k, j) = rub(ite, k, j) + temp31b50
19930         rub(ite-1, k, j) = rub(ite-1, k, j) - temp31b50
19931         CALL POPCONTROL1B(branch)
19932         IF (branch .EQ. 0) THEN
19933           CALL POPREAL8(ub)
19934         ELSE
19935           CALL POPREAL8(ub)
19936           rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb
19937           rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb
19938         END IF
19939       END DO
19940     END DO
19941   END IF
19942   CALL POPCONTROL1B(branch)
19943   IF (branch .EQ. 0) THEN
19944     CALL POPINTEGER4(ad_from29)
19945     CALL POPINTEGER4(ad_to29)
19946     DO j=ad_to29,ad_from29,-1
19947       DO k=ktf,kts,-1
19948         temp31b47 = -(rdx*tendencyb(its, k, j))
19949         temp31b48 = field(its, k, j)*temp31b47
19950         ubb = (field_old(its+1, k, j)-field_old(its, k, j))*temp31b47
19951         field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*temp31b47
19952         field_oldb(its, k, j) = field_oldb(its, k, j) - ub*temp31b47
19953         fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its&
19954 &          , k, j))*temp31b47
19955         rub(its+1, k, j) = rub(its+1, k, j) + temp31b48
19956         rub(its, k, j) = rub(its, k, j) - temp31b48
19957         CALL POPCONTROL1B(branch)
19958         IF (branch .EQ. 0) THEN
19959           CALL POPREAL8(ub)
19960         ELSE
19961           CALL POPREAL8(ub)
19962           rub(its, k, j) = rub(its, k, j) + 0.5*ubb
19963           rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb
19964         END IF
19965       END DO
19966     END DO
19967   END IF
19968   CALL POPCONTROL3B(branch)
19969   IF (branch .LT. 3) THEN
19970     IF (branch .NE. 0) THEN
19971       IF (branch .EQ. 1) THEN
19972         CALL POPINTEGER4(ad_from20)
19973         CALL POPINTEGER4(ad_to20)
19974         DO j=ad_to20,ad_from20,-1
19975           DO k=ktf,kts,-1
19976             CALL POPINTEGER4(ad_from19)
19977             CALL POPINTEGER4(ad_to19)
19978             DO i=ad_to19,ad_from19,-1
19979               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
19980               temp31b8 = 0.5*ru(i, k, j)*fqxb(i, k, j)
19981               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
19982 &                1, k, j))*fqxb(i, k, j)
19983               fieldb(i, k, j) = fieldb(i, k, j) + temp31b8
19984               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b8
19985               fqxb(i, k, j) = 0.0
19986               temp31b9 = dx*mu*fqxlb(i, k, j)/dt
19987               min52b = 0.5*field_old(i-1, k, j)*temp31b9
19988               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min52*&
19989 &                temp31b9
19990               max35b = 0.5*field_old(i, k, j)*temp31b9
19991               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max35*&
19992 &                temp31b9
19993               mub0 = (0.5*(min52*field_old(i-1, k, j))+0.5*(max35*&
19994 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
19995               fqxlb(i, k, j) = 0.0
19996               CALL POPCONTROL1B(branch)
19997               IF (branch .EQ. 0) THEN
19998                 CALL POPREAL8(max35)
19999                 y85b = max35b
20000               ELSE
20001                 CALL POPREAL8(max35)
20002                 y85b = 0.0
20003               END IF
20004               crb = y85b
20005               abs85b = -y85b
20006               CALL POPCONTROL1B(branch)
20007               IF (branch .EQ. 0) THEN
20008                 crb = crb + abs85b
20009               ELSE
20010                 crb = crb - abs85b
20011               END IF
20012               CALL POPCONTROL1B(branch)
20013               IF (branch .EQ. 0) THEN
20014                 CALL POPREAL8(min52)
20015                 y34b = min52b
20016               ELSE
20017                 CALL POPREAL8(min52)
20018                 y34b = 0.0
20019               END IF
20020               crb = crb + y34b
20021               abs34b = y34b
20022               CALL POPCONTROL1B(branch)
20023               IF (branch .EQ. 0) THEN
20024                 crb = crb + abs34b
20025               ELSE
20026                 crb = crb - abs34b
20027               END IF
20028               temp31b7 = dt*crb/(dx*mu)
20029               velb = temp31b7
20030               mub0 = mub0 - vel*temp31b7/mu
20031               CALL POPREAL8(vel)
20032               rub(i, k, j) = rub(i, k, j) + velb
20033               CALL POPREAL8(mu)
20034               mutb(i, j) = mutb(i, j) + 0.5*mub0
20035               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20036               CALL POPREAL8(dx)
20037             END DO
20038           END DO
20039         END DO
20040         CALL POPINTEGER4(ad_from18)
20041         CALL POPINTEGER4(ad_to18)
20042         DO j=ad_to18,ad_from18,-1
20043           DO k=ktf,kts,-1
20044             CALL POPINTEGER4(ad_from17)
20045             CALL POPINTEGER4(ad_to17)
20046             DO i=ad_to17,ad_from17,-1
20047               fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20048               temp31b5 = 0.5*rv(i, k, j)*fqyb(i, k, j)
20049               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
20050 &                , k, j-1))*fqyb(i, k, j)
20051               fieldb(i, k, j) = fieldb(i, k, j) + temp31b5
20052               fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b5
20053               fqyb(i, k, j) = 0.0
20054               temp31b6 = dy*mu*fqylb(i, k, j)/dt
20055               min51b = 0.5*field_old(i, k, j-1)*temp31b6
20056               field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min51*&
20057 &                temp31b6
20058               max34b = 0.5*field_old(i, k, j)*temp31b6
20059               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max34*&
20060 &                temp31b6
20061               mub0 = (0.5*(min51*field_old(i, k, j-1))+0.5*(max34*&
20062 &                field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20063               fqylb(i, k, j) = 0.0
20064               CALL POPCONTROL1B(branch)
20065               IF (branch .EQ. 0) THEN
20066                 CALL POPREAL8(max34)
20067                 y84b = max34b
20068               ELSE
20069                 CALL POPREAL8(max34)
20070                 y84b = 0.0
20071               END IF
20072               crb = y84b
20073               abs84b = -y84b
20074               CALL POPCONTROL1B(branch)
20075               IF (branch .EQ. 0) THEN
20076                 crb = crb + abs84b
20077               ELSE
20078                 crb = crb - abs84b
20079               END IF
20080               CALL POPCONTROL1B(branch)
20081               IF (branch .EQ. 0) THEN
20082                 CALL POPREAL8(min51)
20083                 y33b = min51b
20084               ELSE
20085                 CALL POPREAL8(min51)
20086                 y33b = 0.0
20087               END IF
20088               crb = crb + y33b
20089               abs33b = y33b
20090               CALL POPCONTROL1B(branch)
20091               IF (branch .EQ. 0) THEN
20092                 crb = crb + abs33b
20093               ELSE
20094                 crb = crb - abs33b
20095               END IF
20096               temp31b4 = dt*crb/(dy*mu)
20097               velb = temp31b4
20098               mub0 = mub0 - vel*temp31b4/mu
20099               CALL POPREAL8(vel)
20100               rvb(i, k, j) = rvb(i, k, j) + velb
20101               CALL POPREAL8(mu)
20102               mutb(i, j) = mutb(i, j) + 0.5*mub0
20103               mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20104               CALL POPREAL8(dy)
20105             END DO
20106           END DO
20107         END DO
20108       ELSE
20109         CALL POPINTEGER4(ad_from16)
20110         CALL POPINTEGER4(ad_to16)
20111         DO j=ad_to16,ad_from16,-1
20112           CALL POPCONTROL2B(branch)
20113           IF (branch .NE. 0) THEN
20114             IF (branch .NE. 1) THEN
20115               DO k=ktf,kts,-1
20116                 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20117                 temp31b2 = 0.5*ru(i, k, j)*fqxb(i, k, j)
20118                 rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(&
20119 &                  i-1, k, j))*fqxb(i, k, j)
20120                 fieldb(i, k, j) = fieldb(i, k, j) + temp31b2
20121                 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b2
20122                 fqxb(i, k, j) = 0.0
20123                 temp31b3 = dx*mu*fqxlb(i, k, j)/dt
20124                 min48b = 0.5*field_old(i-1, k, j)*temp31b3
20125                 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*&
20126 &                  min48*temp31b3
20127                 max33b = 0.5*field_old(i, k, j)*temp31b3
20128                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max33*&
20129 &                  temp31b3
20130                 mub0 = (0.5*(min48*field_old(i-1, k, j))+0.5*(max33*&
20131 &                  field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
20132                 fqxlb(i, k, j) = 0.0
20133                 CALL POPCONTROL1B(branch)
20134                 IF (branch .EQ. 0) THEN
20135                   CALL POPREAL8(max33)
20136                   y83b = max33b
20137                 ELSE
20138                   CALL POPREAL8(max33)
20139                   y83b = 0.0
20140                 END IF
20141                 crb = y83b
20142                 abs83b = -y83b
20143                 CALL POPCONTROL1B(branch)
20144                 IF (branch .EQ. 0) THEN
20145                   crb = crb + abs83b
20146                 ELSE
20147                   crb = crb - abs83b
20148                 END IF
20149                 CALL POPCONTROL1B(branch)
20150                 IF (branch .EQ. 0) THEN
20151                   CALL POPREAL8(min48)
20152                   y32b = min48b
20153                 ELSE
20154                   CALL POPREAL8(min48)
20155                   y32b = 0.0
20156                 END IF
20157                 crb = crb + y32b
20158                 abs32b = y32b
20159                 CALL POPCONTROL1B(branch)
20160                 IF (branch .EQ. 0) THEN
20161                   crb = crb + abs32b
20162                 ELSE
20163                   crb = crb - abs32b
20164                 END IF
20165                 temp31b1 = dt*crb/(dx*mu)
20166                 velb = temp31b1
20167                 mub0 = mub0 - vel*temp31b1/mu
20168                 CALL POPREAL8(vel)
20169                 rub(i, k, j) = rub(i, k, j) + velb
20170                 CALL POPREAL8(mu)
20171                 mutb(i, j) = mutb(i, j) + 0.5*mub0
20172                 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20173                 CALL POPREAL8(dx)
20174               END DO
20175               CALL POPINTEGER4(i)
20176             END IF
20177           END IF
20178           CALL POPCONTROL2B(branch)
20179           IF (branch .EQ. 0) THEN
20180             DO k=ktf,kts,-1
20181               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20182               temp31b = 0.5*ru(i, k, j)*fqxb(i, k, j)
20183               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
20184 &                1, k, j))*fqxb(i, k, j)
20185               fieldb(i, k, j) = fieldb(i, k, j) + temp31b
20186               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b
20187               fqxb(i, k, j) = 0.0
20188               temp31b0 = dx*mu*fqxlb(i, k, j)/dt
20189               min47b = 0.5*field_old(i-1, k, j)*temp31b0
20190               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min47*&
20191 &                temp31b0
20192               max32b = 0.5*field_old(i, k, j)*temp31b0
20193               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max32*&
20194 &                temp31b0
20195               mub0 = (0.5*(min47*field_old(i-1, k, j))+0.5*(max32*&
20196 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
20197               fqxlb(i, k, j) = 0.0
20198               CALL POPCONTROL1B(branch)
20199               IF (branch .EQ. 0) THEN
20200                 CALL POPREAL8(max32)
20201                 y82b = max32b
20202               ELSE
20203                 CALL POPREAL8(max32)
20204                 y82b = 0.0
20205               END IF
20206               crb = y82b
20207               abs82b = -y82b
20208               CALL POPCONTROL1B(branch)
20209               IF (branch .EQ. 0) THEN
20210                 crb = crb + abs82b
20211               ELSE
20212                 crb = crb - abs82b
20213               END IF
20214               CALL POPCONTROL1B(branch)
20215               IF (branch .EQ. 0) THEN
20216                 CALL POPREAL8(min47)
20217                 y31b = min47b
20218               ELSE
20219                 CALL POPREAL8(min47)
20220                 y31b = 0.0
20221               END IF
20222               crb = crb + y31b
20223               abs31b = y31b
20224               CALL POPCONTROL1B(branch)
20225               IF (branch .EQ. 0) THEN
20226                 crb = crb + abs31b
20227               ELSE
20228                 crb = crb - abs31b
20229               END IF
20230               velb = dt*crb/dx
20231               CALL POPREAL8(vel)
20232               rub(i, k, j) = rub(i, k, j) + velb/mu
20233               mub0 = mub0 - ru(i, k, j)*velb/mu**2
20234               CALL POPREAL8(mu)
20235               mutb(i, j) = mutb(i, j) + 0.5*mub0
20236               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20237               CALL POPREAL8(dx)
20238             END DO
20239             CALL POPINTEGER4(i)
20240           END IF
20241           DO k=ktf,kts,-1
20242             DO i=i_end_f,i_start_f,-1
20243               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20244               temp27 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
20245 &                , k, j)-field(i-1, k, j))
20246               temp30 = SIGN(1., vel)
20247               temp29 = temp30/12.
20248               temp28 = SIGN(1, time_step)
20249               temp27b6 = vel*fqxb(i, k, j)
20250               temp27b7 = 7.*temp27b6/12.
20251               temp27b8 = temp28*temp29*temp27b6
20252               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
20253 &                i+1, k, j)+field(i-2, k, j))/12.+temp28*(temp29*temp27))&
20254 &                *fqxb(i, k, j)
20255               fieldb(i, k, j) = fieldb(i, k, j) + temp27b7 - 3.*temp27b8
20256               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp27b8 + &
20257 &                temp27b7
20258               fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp27b8 - &
20259 &                temp27b6/12.
20260               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp27b8 - &
20261 &                temp27b6/12.
20262               fqxb(i, k, j) = 0.0
20263               temp27b9 = dx*mu*fqxlb(i, k, j)/dt
20264               min46b = 0.5*field_old(i-1, k, j)*temp27b9
20265               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min46*&
20266 &                temp27b9
20267               max31b = 0.5*field_old(i, k, j)*temp27b9
20268               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max31*&
20269 &                temp27b9
20270               mub0 = (0.5*(min46*field_old(i-1, k, j))+0.5*(max31*&
20271 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
20272               fqxlb(i, k, j) = 0.0
20273               CALL POPCONTROL1B(branch)
20274               IF (branch .EQ. 0) THEN
20275                 CALL POPREAL8(max31)
20276                 y81b = max31b
20277               ELSE
20278                 CALL POPREAL8(max31)
20279                 y81b = 0.0
20280               END IF
20281               crb = y81b
20282               abs81b = -y81b
20283               CALL POPCONTROL1B(branch)
20284               IF (branch .EQ. 0) THEN
20285                 crb = crb + abs81b
20286               ELSE
20287                 crb = crb - abs81b
20288               END IF
20289               CALL POPCONTROL1B(branch)
20290               IF (branch .EQ. 0) THEN
20291                 CALL POPREAL8(min46)
20292                 y30b = min46b
20293               ELSE
20294                 CALL POPREAL8(min46)
20295                 y30b = 0.0
20296               END IF
20297               crb = crb + y30b
20298               abs30b = y30b
20299               CALL POPCONTROL1B(branch)
20300               IF (branch .EQ. 0) THEN
20301                 crb = crb + abs30b
20302               ELSE
20303                 crb = crb - abs30b
20304               END IF
20305               temp27b5 = dt*crb/(dx*mu)
20306               velb = velb + temp27b5
20307               mub0 = mub0 - vel*temp27b5/mu
20308               CALL POPREAL8(vel)
20309               rub(i, k, j) = rub(i, k, j) + velb
20310               CALL POPREAL8(mu)
20311               mutb(i, j) = mutb(i, j) + 0.5*mub0
20312               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20313               CALL POPREAL8(dx)
20314             END DO
20315             CALL POPINTEGER4(i)
20316           END DO
20317         END DO
20318         CALL POPINTEGER4(ad_from15)
20319         CALL POPINTEGER4(ad_to15)
20320         DO j=ad_to15,ad_from15,-1
20321           CALL POPCONTROL2B(branch)
20322           IF (branch .LT. 2) THEN
20323             IF (branch .NE. 0) THEN
20324               DO k=ktf,kts,-1
20325                 CALL POPINTEGER4(ad_from14)
20326                 CALL POPINTEGER4(ad_to14)
20327                 DO i=ad_to14,ad_from14,-1
20328                   fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20329                   temp27b3 = 0.5*rv(i, k, j)*fqyb(i, k, j)
20330                   rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+&
20331 &                    field(i, k, j-1))*fqyb(i, k, j)
20332                   fieldb(i, k, j) = fieldb(i, k, j) + temp27b3
20333                   fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp27b3
20334                   fqyb(i, k, j) = 0.0
20335                   temp27b4 = dy*mu*fqylb(i, k, j)/dt
20336                   min43b = 0.5*field_old(i, k, j-1)*temp27b4
20337                   field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*&
20338 &                    min43*temp27b4
20339                   max30b = 0.5*field_old(i, k, j)*temp27b4
20340                   field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max30*&
20341 &                    temp27b4
20342                   mub0 = (0.5*(min43*field_old(i, k, j-1))+0.5*(max30*&
20343 &                    field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20344                   fqylb(i, k, j) = 0.0
20345                   CALL POPCONTROL1B(branch)
20346                   IF (branch .EQ. 0) THEN
20347                     CALL POPREAL8(max30)
20348                     y80b = max30b
20349                   ELSE
20350                     CALL POPREAL8(max30)
20351                     y80b = 0.0
20352                   END IF
20353                   crb = y80b
20354                   abs80b = -y80b
20355                   CALL POPCONTROL1B(branch)
20356                   IF (branch .EQ. 0) THEN
20357                     crb = crb + abs80b
20358                   ELSE
20359                     crb = crb - abs80b
20360                   END IF
20361                   CALL POPCONTROL1B(branch)
20362                   IF (branch .EQ. 0) THEN
20363                     CALL POPREAL8(min43)
20364                     y29b = min43b
20365                   ELSE
20366                     CALL POPREAL8(min43)
20367                     y29b = 0.0
20368                   END IF
20369                   crb = crb + y29b
20370                   abs29b = y29b
20371                   CALL POPCONTROL1B(branch)
20372                   IF (branch .EQ. 0) THEN
20373                     crb = crb + abs29b
20374                   ELSE
20375                     crb = crb - abs29b
20376                   END IF
20377                   temp27b2 = dt*crb/(dy*mu)
20378                   velb = temp27b2
20379                   mub0 = mub0 - vel*temp27b2/mu
20380                   CALL POPREAL8(vel)
20381                   rvb(i, k, j) = rvb(i, k, j) + velb
20382                   CALL POPREAL8(mu)
20383                   mutb(i, j) = mutb(i, j) + 0.5*mub0
20384                   mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20385                   CALL POPREAL8(dy)
20386                 END DO
20387               END DO
20388             END IF
20389           ELSE IF (branch .EQ. 2) THEN
20390             DO k=ktf,kts,-1
20391               CALL POPINTEGER4(ad_from13)
20392               CALL POPINTEGER4(ad_to13)
20393               DO i=ad_to13,ad_from13,-1
20394                 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20395                 temp27b0 = 0.5*rv(i, k, j)*fqyb(i, k, j)
20396                 rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(&
20397 &                  i, k, j-1))*fqyb(i, k, j)
20398                 fieldb(i, k, j) = fieldb(i, k, j) + temp27b0
20399                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp27b0
20400                 fqyb(i, k, j) = 0.0
20401                 temp27b1 = dy*mu*fqylb(i, k, j)/dt
20402                 min42b = 0.5*field_old(i, k, j-1)*temp27b1
20403                 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*&
20404 &                  min42*temp27b1
20405                 max29b = 0.5*field_old(i, k, j)*temp27b1
20406                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max29*&
20407 &                  temp27b1
20408                 mub0 = (0.5*(min42*field_old(i, k, j-1))+0.5*(max29*&
20409 &                  field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20410                 fqylb(i, k, j) = 0.0
20411                 CALL POPCONTROL1B(branch)
20412                 IF (branch .EQ. 0) THEN
20413                   CALL POPREAL8(max29)
20414                   y79b = max29b
20415                 ELSE
20416                   CALL POPREAL8(max29)
20417                   y79b = 0.0
20418                 END IF
20419                 crb = y79b
20420                 abs79b = -y79b
20421                 CALL POPCONTROL1B(branch)
20422                 IF (branch .EQ. 0) THEN
20423                   crb = crb + abs79b
20424                 ELSE
20425                   crb = crb - abs79b
20426                 END IF
20427                 CALL POPCONTROL1B(branch)
20428                 IF (branch .EQ. 0) THEN
20429                   CALL POPREAL8(min42)
20430                   y28b = min42b
20431                 ELSE
20432                   CALL POPREAL8(min42)
20433                   y28b = 0.0
20434                 END IF
20435                 crb = crb + y28b
20436                 abs28b = y28b
20437                 CALL POPCONTROL1B(branch)
20438                 IF (branch .EQ. 0) THEN
20439                   crb = crb + abs28b
20440                 ELSE
20441                   crb = crb - abs28b
20442                 END IF
20443                 temp27b = dt*crb/(dy*mu)
20444                 velb = temp27b
20445                 mub0 = mub0 - vel*temp27b/mu
20446                 CALL POPREAL8(vel)
20447                 rvb(i, k, j) = rvb(i, k, j) + velb
20448                 CALL POPREAL8(mu)
20449                 mutb(i, j) = mutb(i, j) + 0.5*mub0
20450                 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20451                 CALL POPREAL8(dy)
20452               END DO
20453             END DO
20454           ELSE
20455             DO k=ktf,kts,-1
20456               CALL POPINTEGER4(ad_from12)
20457               CALL POPINTEGER4(ad_to12)
20458               DO i=ad_to12,ad_from12,-1
20459                 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20460                 temp23 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field&
20461 &                  (i, k, j)-field(i, k, j-1))
20462                 temp26 = SIGN(1., vel)
20463                 temp25 = temp26/12.
20464                 temp24 = SIGN(1, time_step)
20465                 temp23b19 = vel*fqyb(i, k, j)
20466                 temp23b20 = 7.*temp23b19/12.
20467                 temp23b21 = temp24*temp25*temp23b19
20468                 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(&
20469 &                  field(i, k, j+1)+field(i, k, j-2))/12.+temp24*(temp25*&
20470 &                  temp23))*fqyb(i, k, j)
20471                 fieldb(i, k, j) = fieldb(i, k, j) + temp23b20 - 3.*&
20472 &                  temp23b21
20473                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp23b21 + &
20474 &                  temp23b20
20475                 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp23b21 - &
20476 &                  temp23b19/12.
20477                 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp23b21 - &
20478 &                  temp23b19/12.
20479                 fqyb(i, k, j) = 0.0
20480                 temp23b22 = dy*mu*fqylb(i, k, j)/dt
20481                 min41b = 0.5*field_old(i, k, j-1)*temp23b22
20482                 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*&
20483 &                  min41*temp23b22
20484                 max28b = 0.5*field_old(i, k, j)*temp23b22
20485                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max28*&
20486 &                  temp23b22
20487                 mub0 = (0.5*(min41*field_old(i, k, j-1))+0.5*(max28*&
20488 &                  field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20489                 fqylb(i, k, j) = 0.0
20490                 CALL POPCONTROL1B(branch)
20491                 IF (branch .EQ. 0) THEN
20492                   CALL POPREAL8(max28)
20493                   y78b = max28b
20494                 ELSE
20495                   CALL POPREAL8(max28)
20496                   y78b = 0.0
20497                 END IF
20498                 crb = y78b
20499                 abs78b = -y78b
20500                 CALL POPCONTROL1B(branch)
20501                 IF (branch .EQ. 0) THEN
20502                   crb = crb + abs78b
20503                 ELSE
20504                   crb = crb - abs78b
20505                 END IF
20506                 CALL POPCONTROL1B(branch)
20507                 IF (branch .EQ. 0) THEN
20508                   CALL POPREAL8(min41)
20509                   y27b = min41b
20510                 ELSE
20511                   CALL POPREAL8(min41)
20512                   y27b = 0.0
20513                 END IF
20514                 crb = crb + y27b
20515                 abs27b = y27b
20516                 CALL POPCONTROL1B(branch)
20517                 IF (branch .EQ. 0) THEN
20518                   crb = crb + abs27b
20519                 ELSE
20520                   crb = crb - abs27b
20521                 END IF
20522                 temp23b18 = dt*crb/(dy*mu)
20523                 velb = velb + temp23b18
20524                 mub0 = mub0 - vel*temp23b18/mu
20525                 CALL POPREAL8(vel)
20526                 rvb(i, k, j) = rvb(i, k, j) + velb
20527                 CALL POPREAL8(mu)
20528                 mutb(i, j) = mutb(i, j) + 0.5*mub0
20529                 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20530                 CALL POPREAL8(dy)
20531               END DO
20532             END DO
20533           END IF
20534         END DO
20535       END IF
20536     END IF
20537   ELSE IF (branch .EQ. 3) THEN
20538     CALL POPINTEGER4(ad_from11)
20539     CALL POPINTEGER4(ad_to11)
20540     DO j=ad_to11,ad_from11,-1
20541       CALL POPCONTROL2B(branch)
20542       IF (branch .NE. 0) THEN
20543         IF (branch .NE. 1) THEN
20544           DO k=ktf,kts,-1
20545             fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20546             temp23b16 = 0.5*ru(i, k, j)*fqxb(i, k, j)
20547             rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1&
20548 &              , k, j))*fqxb(i, k, j)
20549             fieldb(i, k, j) = fieldb(i, k, j) + temp23b16
20550             fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp23b16
20551             fqxb(i, k, j) = 0.0
20552             temp23b17 = dx*mu*fqxlb(i, k, j)/dt
20553             min38b = 0.5*field_old(i-1, k, j)*temp23b17
20554             field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min38*&
20555 &              temp23b17
20556             max27b = 0.5*field_old(i, k, j)*temp23b17
20557             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max27*&
20558 &              temp23b17
20559             mub0 = (0.5*(min38*field_old(i-1, k, j))+0.5*(max27*&
20560 &              field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
20561             fqxlb(i, k, j) = 0.0
20562             CALL POPCONTROL1B(branch)
20563             IF (branch .EQ. 0) THEN
20564               CALL POPREAL8(max27)
20565               y77b = max27b
20566             ELSE
20567               CALL POPREAL8(max27)
20568               y77b = 0.0
20569             END IF
20570             crb = y77b
20571             abs77b = -y77b
20572             CALL POPCONTROL1B(branch)
20573             IF (branch .EQ. 0) THEN
20574               crb = crb + abs77b
20575             ELSE
20576               crb = crb - abs77b
20577             END IF
20578             CALL POPCONTROL1B(branch)
20579             IF (branch .EQ. 0) THEN
20580               CALL POPREAL8(min38)
20581               y26b = min38b
20582             ELSE
20583               CALL POPREAL8(min38)
20584               y26b = 0.0
20585             END IF
20586             crb = crb + y26b
20587             abs26b = y26b
20588             CALL POPCONTROL1B(branch)
20589             IF (branch .EQ. 0) THEN
20590               crb = crb + abs26b
20591             ELSE
20592               crb = crb - abs26b
20593             END IF
20594             temp23b15 = dt*crb/(dx*mu)
20595             velb = temp23b15
20596             mub0 = mub0 - vel*temp23b15/mu
20597             CALL POPREAL8(vel)
20598             rub(i, k, j) = rub(i, k, j) + velb
20599             CALL POPREAL8(mu)
20600             mutb(i, j) = mutb(i, j) + 0.5*mub0
20601             mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20602             CALL POPREAL8(dx)
20603           END DO
20604           CALL POPINTEGER4(i)
20605         END IF
20606       END IF
20607       CALL POPCONTROL2B(branch)
20608       IF (branch .EQ. 0) THEN
20609         DO k=ktf,kts,-1
20610           fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20611           temp23b13 = 0.5*ru(i, k, j)*fqxb(i, k, j)
20612           rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1, k&
20613 &            , j))*fqxb(i, k, j)
20614           fieldb(i, k, j) = fieldb(i, k, j) + temp23b13
20615           fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp23b13
20616           fqxb(i, k, j) = 0.0
20617           temp23b14 = dx*mu*fqxlb(i, k, j)/dt
20618           min37b = 0.5*field_old(i-1, k, j)*temp23b14
20619           field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min37*&
20620 &            temp23b14
20621           max26b = 0.5*field_old(i, k, j)*temp23b14
20622           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max26*&
20623 &            temp23b14
20624           mub0 = (0.5*(min37*field_old(i-1, k, j))+0.5*(max26*field_old(&
20625 &            i, k, j)))*dx*fqxlb(i, k, j)/dt
20626           fqxlb(i, k, j) = 0.0
20627           CALL POPCONTROL1B(branch)
20628           IF (branch .EQ. 0) THEN
20629             CALL POPREAL8(max26)
20630             y76b = max26b
20631           ELSE
20632             CALL POPREAL8(max26)
20633             y76b = 0.0
20634           END IF
20635           crb = y76b
20636           abs76b = -y76b
20637           CALL POPCONTROL1B(branch)
20638           IF (branch .EQ. 0) THEN
20639             crb = crb + abs76b
20640           ELSE
20641             crb = crb - abs76b
20642           END IF
20643           CALL POPCONTROL1B(branch)
20644           IF (branch .EQ. 0) THEN
20645             CALL POPREAL8(min37)
20646             y25b = min37b
20647           ELSE
20648             CALL POPREAL8(min37)
20649             y25b = 0.0
20650           END IF
20651           crb = crb + y25b
20652           abs25b = y25b
20653           CALL POPCONTROL1B(branch)
20654           IF (branch .EQ. 0) THEN
20655             crb = crb + abs25b
20656           ELSE
20657             crb = crb - abs25b
20658           END IF
20659           velb = dt*crb/dx
20660           CALL POPREAL8(vel)
20661           rub(i, k, j) = rub(i, k, j) + velb/mu
20662           mub0 = mub0 - ru(i, k, j)*velb/mu**2
20663           CALL POPREAL8(mu)
20664           mutb(i, j) = mutb(i, j) + 0.5*mub0
20665           mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20666           CALL POPREAL8(dx)
20667         END DO
20668         CALL POPINTEGER4(i)
20669       END IF
20670       DO k=ktf,kts,-1
20671         DO i=i_end_f,i_start_f,-1
20672           fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20673           temp23b10 = vel*fqxb(i, k, j)
20674           temp23b11 = 7.*temp23b10/12.
20675           velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(i+1&
20676 &            , k, j)+field(i-2, k, j))/12.)*fqxb(i, k, j)
20677           fieldb(i, k, j) = fieldb(i, k, j) + temp23b11
20678           fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp23b11
20679           fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp23b10/12.
20680           fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp23b10/12.
20681           fqxb(i, k, j) = 0.0
20682           temp23b12 = dx*mu*fqxlb(i, k, j)/dt
20683           min36b = 0.5*field_old(i-1, k, j)*temp23b12
20684           field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min36*&
20685 &            temp23b12
20686           max25b = 0.5*field_old(i, k, j)*temp23b12
20687           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max25*&
20688 &            temp23b12
20689           mub0 = (0.5*(min36*field_old(i-1, k, j))+0.5*(max25*field_old(&
20690 &            i, k, j)))*dx*fqxlb(i, k, j)/dt
20691           fqxlb(i, k, j) = 0.0
20692           CALL POPCONTROL1B(branch)
20693           IF (branch .EQ. 0) THEN
20694             CALL POPREAL8(max25)
20695             y75b = max25b
20696           ELSE
20697             CALL POPREAL8(max25)
20698             y75b = 0.0
20699           END IF
20700           crb = y75b
20701           abs75b = -y75b
20702           CALL POPCONTROL1B(branch)
20703           IF (branch .EQ. 0) THEN
20704             crb = crb + abs75b
20705           ELSE
20706             crb = crb - abs75b
20707           END IF
20708           CALL POPCONTROL1B(branch)
20709           IF (branch .EQ. 0) THEN
20710             CALL POPREAL8(min36)
20711             y24b = min36b
20712           ELSE
20713             CALL POPREAL8(min36)
20714             y24b = 0.0
20715           END IF
20716           crb = crb + y24b
20717           abs24b = y24b
20718           CALL POPCONTROL1B(branch)
20719           IF (branch .EQ. 0) THEN
20720             crb = crb + abs24b
20721           ELSE
20722             crb = crb - abs24b
20723           END IF
20724           temp23b9 = dt*crb/(dx*mu)
20725           velb = velb + temp23b9
20726           mub0 = mub0 - vel*temp23b9/mu
20727           CALL POPREAL8(vel)
20728           rub(i, k, j) = rub(i, k, j) + velb
20729           CALL POPREAL8(mu)
20730           mutb(i, j) = mutb(i, j) + 0.5*mub0
20731           mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
20732           CALL POPREAL8(dx)
20733         END DO
20734         CALL POPINTEGER4(i)
20735       END DO
20736     END DO
20737     CALL POPINTEGER4(ad_from10)
20738     CALL POPINTEGER4(ad_to10)
20739     DO j=ad_to10,ad_from10,-1
20740       CALL POPCONTROL2B(branch)
20741       IF (branch .LT. 2) THEN
20742         IF (branch .NE. 0) THEN
20743           DO k=ktf,kts,-1
20744             CALL POPINTEGER4(ad_from9)
20745             CALL POPINTEGER4(ad_to9)
20746             DO i=ad_to9,ad_from9,-1
20747               fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20748               temp23b7 = 0.5*rv(i, k, j)*fqyb(i, k, j)
20749               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
20750 &                , k, j-1))*fqyb(i, k, j)
20751               fieldb(i, k, j) = fieldb(i, k, j) + temp23b7
20752               fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b7
20753               fqyb(i, k, j) = 0.0
20754               temp23b8 = dy*mu*fqylb(i, k, j)/dt
20755               min33b = 0.5*field_old(i, k, j-1)*temp23b8
20756               field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min33*&
20757 &                temp23b8
20758               max24b = 0.5*field_old(i, k, j)*temp23b8
20759               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max24*&
20760 &                temp23b8
20761               mub0 = (0.5*(min33*field_old(i, k, j-1))+0.5*(max24*&
20762 &                field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20763               fqylb(i, k, j) = 0.0
20764               CALL POPCONTROL1B(branch)
20765               IF (branch .EQ. 0) THEN
20766                 CALL POPREAL8(max24)
20767                 y74b = max24b
20768               ELSE
20769                 CALL POPREAL8(max24)
20770                 y74b = 0.0
20771               END IF
20772               crb = y74b
20773               abs74b = -y74b
20774               CALL POPCONTROL1B(branch)
20775               IF (branch .EQ. 0) THEN
20776                 crb = crb + abs74b
20777               ELSE
20778                 crb = crb - abs74b
20779               END IF
20780               CALL POPCONTROL1B(branch)
20781               IF (branch .EQ. 0) THEN
20782                 CALL POPREAL8(min33)
20783                 y23b = min33b
20784               ELSE
20785                 CALL POPREAL8(min33)
20786                 y23b = 0.0
20787               END IF
20788               crb = crb + y23b
20789               abs23b = y23b
20790               CALL POPCONTROL1B(branch)
20791               IF (branch .EQ. 0) THEN
20792                 crb = crb + abs23b
20793               ELSE
20794                 crb = crb - abs23b
20795               END IF
20796               temp23b6 = dt*crb/(dy*mu)
20797               velb = temp23b6
20798               mub0 = mub0 - vel*temp23b6/mu
20799               CALL POPREAL8(vel)
20800               rvb(i, k, j) = rvb(i, k, j) + velb
20801               CALL POPREAL8(mu)
20802               mutb(i, j) = mutb(i, j) + 0.5*mub0
20803               mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20804               CALL POPREAL8(dy)
20805             END DO
20806           END DO
20807         END IF
20808       ELSE IF (branch .EQ. 2) THEN
20809         DO k=ktf,kts,-1
20810           CALL POPINTEGER4(ad_from8)
20811           CALL POPINTEGER4(ad_to8)
20812           DO i=ad_to8,ad_from8,-1
20813             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20814             temp23b4 = 0.5*rv(i, k, j)*fqyb(i, k, j)
20815             rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k&
20816 &              , j-1))*fqyb(i, k, j)
20817             fieldb(i, k, j) = fieldb(i, k, j) + temp23b4
20818             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b4
20819             fqyb(i, k, j) = 0.0
20820             temp23b5 = dy*mu*fqylb(i, k, j)/dt
20821             min32b = 0.5*field_old(i, k, j-1)*temp23b5
20822             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min32*&
20823 &              temp23b5
20824             max23b = 0.5*field_old(i, k, j)*temp23b5
20825             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max23*&
20826 &              temp23b5
20827             mub0 = (0.5*(min32*field_old(i, k, j-1))+0.5*(max23*&
20828 &              field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20829             fqylb(i, k, j) = 0.0
20830             CALL POPCONTROL1B(branch)
20831             IF (branch .EQ. 0) THEN
20832               CALL POPREAL8(max23)
20833               y73b = max23b
20834             ELSE
20835               CALL POPREAL8(max23)
20836               y73b = 0.0
20837             END IF
20838             crb = y73b
20839             abs73b = -y73b
20840             CALL POPCONTROL1B(branch)
20841             IF (branch .EQ. 0) THEN
20842               crb = crb + abs73b
20843             ELSE
20844               crb = crb - abs73b
20845             END IF
20846             CALL POPCONTROL1B(branch)
20847             IF (branch .EQ. 0) THEN
20848               CALL POPREAL8(min32)
20849               y22b = min32b
20850             ELSE
20851               CALL POPREAL8(min32)
20852               y22b = 0.0
20853             END IF
20854             crb = crb + y22b
20855             abs22b = y22b
20856             CALL POPCONTROL1B(branch)
20857             IF (branch .EQ. 0) THEN
20858               crb = crb + abs22b
20859             ELSE
20860               crb = crb - abs22b
20861             END IF
20862             temp23b3 = dt*crb/(dy*mu)
20863             velb = temp23b3
20864             mub0 = mub0 - vel*temp23b3/mu
20865             CALL POPREAL8(vel)
20866             rvb(i, k, j) = rvb(i, k, j) + velb
20867             CALL POPREAL8(mu)
20868             mutb(i, j) = mutb(i, j) + 0.5*mub0
20869             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20870             CALL POPREAL8(dy)
20871           END DO
20872         END DO
20873       ELSE
20874         DO k=ktf,kts,-1
20875           CALL POPINTEGER4(ad_from7)
20876           CALL POPINTEGER4(ad_to7)
20877           DO i=ad_to7,ad_from7,-1
20878             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
20879             temp23b0 = vel*fqyb(i, k, j)
20880             temp23b1 = 7.*temp23b0/12.
20881             velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i&
20882 &              , k, j+1)+field(i, k, j-2))/12.)*fqyb(i, k, j)
20883             fieldb(i, k, j) = fieldb(i, k, j) + temp23b1
20884             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b1
20885             fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp23b0/12.
20886             fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp23b0/12.
20887             fqyb(i, k, j) = 0.0
20888             temp23b2 = dy*mu*fqylb(i, k, j)/dt
20889             min31b = 0.5*field_old(i, k, j-1)*temp23b2
20890             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min31*&
20891 &              temp23b2
20892             max22b = 0.5*field_old(i, k, j)*temp23b2
20893             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max22*&
20894 &              temp23b2
20895             mub0 = (0.5*(min31*field_old(i, k, j-1))+0.5*(max22*&
20896 &              field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
20897             fqylb(i, k, j) = 0.0
20898             CALL POPCONTROL1B(branch)
20899             IF (branch .EQ. 0) THEN
20900               CALL POPREAL8(max22)
20901               y72b = max22b
20902             ELSE
20903               CALL POPREAL8(max22)
20904               y72b = 0.0
20905             END IF
20906             crb = y72b
20907             abs72b = -y72b
20908             CALL POPCONTROL1B(branch)
20909             IF (branch .EQ. 0) THEN
20910               crb = crb + abs72b
20911             ELSE
20912               crb = crb - abs72b
20913             END IF
20914             CALL POPCONTROL1B(branch)
20915             IF (branch .EQ. 0) THEN
20916               CALL POPREAL8(min31)
20917               y21b = min31b
20918             ELSE
20919               CALL POPREAL8(min31)
20920               y21b = 0.0
20921             END IF
20922             crb = crb + y21b
20923             abs21b = y21b
20924             CALL POPCONTROL1B(branch)
20925             IF (branch .EQ. 0) THEN
20926               crb = crb + abs21b
20927             ELSE
20928               crb = crb - abs21b
20929             END IF
20930             temp23b = dt*crb/(dy*mu)
20931             velb = velb + temp23b
20932             mub0 = mub0 - vel*temp23b/mu
20933             CALL POPREAL8(vel)
20934             rvb(i, k, j) = rvb(i, k, j) + velb
20935             CALL POPREAL8(mu)
20936             mutb(i, j) = mutb(i, j) + 0.5*mub0
20937             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
20938             CALL POPREAL8(dy)
20939           END DO
20940         END DO
20941       END IF
20942     END DO
20943   ELSE IF (branch .EQ. 4) THEN
20944     CALL POPINTEGER4(ad_from6)
20945     CALL POPINTEGER4(ad_to6)
20946     DO j=ad_to6,ad_from6,-1
20947       CALL POPCONTROL1B(branch)
20948       IF (branch .NE. 0) THEN
20949         CALL POPINTEGER4(ad_to5)
20950         DO i=ad_to5,i_end_f+1,-1
20951           CALL POPCONTROL1B(branch)
20952           IF (branch .NE. 0) THEN
20953             DO k=ktf,kts,-1
20954               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
20955               temp19 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
20956 &                , k, j)-field(i-1, k, j))
20957               temp22 = SIGN(1., vel)
20958               temp21 = temp22/12.
20959               temp20 = SIGN(1, time_step)
20960               temp19b3 = vel*fqxb(i, k, j)
20961               temp19b4 = 7.*temp19b3/12.
20962               temp19b5 = temp20*temp21*temp19b3
20963               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
20964 &                i+1, k, j)+field(i-2, k, j))/12.+temp20*(temp21*temp19))&
20965 &                *fqxb(i, k, j)
20966               fieldb(i, k, j) = fieldb(i, k, j) + temp19b4 - 3.*temp19b5
20967               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp19b5 + &
20968 &                temp19b4
20969               fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp19b5 - &
20970 &                temp19b3/12.
20971               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp19b5 - &
20972 &                temp19b3/12.
20973               fqxb(i, k, j) = 0.0
20974               temp19b6 = dx*mu*fqxlb(i, k, j)/dt
20975               min28b = 0.5*field_old(i-1, k, j)*temp19b6
20976               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min28*&
20977 &                temp19b6
20978               max21b = 0.5*field_old(i, k, j)*temp19b6
20979               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max21*&
20980 &                temp19b6
20981               mub0 = (0.5*(min28*field_old(i-1, k, j))+0.5*(max21*&
20982 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
20983               fqxlb(i, k, j) = 0.0
20984               CALL POPCONTROL1B(branch)
20985               IF (branch .EQ. 0) THEN
20986                 CALL POPREAL8(max21)
20987                 y71b = max21b
20988               ELSE
20989                 CALL POPREAL8(max21)
20990                 y71b = 0.0
20991               END IF
20992               crb = y71b
20993               abs71b = -y71b
20994               CALL POPCONTROL1B(branch)
20995               IF (branch .EQ. 0) THEN
20996                 crb = crb + abs71b
20997               ELSE
20998                 crb = crb - abs71b
20999               END IF
21000               CALL POPCONTROL1B(branch)
21001               IF (branch .EQ. 0) THEN
21002                 CALL POPREAL8(min28)
21003                 y20b = min28b
21004               ELSE
21005                 CALL POPREAL8(min28)
21006                 y20b = 0.0
21007               END IF
21008               crb = crb + y20b
21009               abs20b = y20b
21010               CALL POPCONTROL1B(branch)
21011               IF (branch .EQ. 0) THEN
21012                 crb = crb + abs20b
21013               ELSE
21014                 crb = crb - abs20b
21015               END IF
21016               temp19b2 = dt*crb/(dx*mu)
21017               velb = velb + temp19b2
21018               mub0 = mub0 - vel*temp19b2/mu
21019               CALL POPREAL8(vel)
21020               rub(i, k, j) = rub(i, k, j) + velb
21021               CALL POPREAL8(mu)
21022               mutb(i, j) = mutb(i, j) + 0.5*mub0
21023               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21024               CALL POPREAL8(dx)
21025             END DO
21026           END IF
21027           CALL POPCONTROL1B(branch)
21028           IF (branch .EQ. 0) THEN
21029             DO k=ktf,kts,-1
21030               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21031               temp19b0 = 0.5*ru(i, k, j)*fqxb(i, k, j)
21032               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
21033 &                1, k, j))*fqxb(i, k, j)
21034               fieldb(i, k, j) = fieldb(i, k, j) + temp19b0
21035               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp19b0
21036               fqxb(i, k, j) = 0.0
21037               temp19b1 = dx*mu*fqxlb(i, k, j)/dt
21038               min27b = 0.5*field_old(i-1, k, j)*temp19b1
21039               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min27*&
21040 &                temp19b1
21041               max20b = 0.5*field_old(i, k, j)*temp19b1
21042               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max20*&
21043 &                temp19b1
21044               mub0 = (0.5*(min27*field_old(i-1, k, j))+0.5*(max20*&
21045 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21046               fqxlb(i, k, j) = 0.0
21047               CALL POPCONTROL1B(branch)
21048               IF (branch .EQ. 0) THEN
21049                 CALL POPREAL8(max20)
21050                 y70b = max20b
21051               ELSE
21052                 CALL POPREAL8(max20)
21053                 y70b = 0.0
21054               END IF
21055               crb = y70b
21056               abs70b = -y70b
21057               CALL POPCONTROL1B(branch)
21058               IF (branch .EQ. 0) THEN
21059                 crb = crb + abs70b
21060               ELSE
21061                 crb = crb - abs70b
21062               END IF
21063               CALL POPCONTROL1B(branch)
21064               IF (branch .EQ. 0) THEN
21065                 CALL POPREAL8(min27)
21066                 y19b = min27b
21067               ELSE
21068                 CALL POPREAL8(min27)
21069                 y19b = 0.0
21070               END IF
21071               crb = crb + y19b
21072               abs19b = y19b
21073               CALL POPCONTROL1B(branch)
21074               IF (branch .EQ. 0) THEN
21075                 crb = crb + abs19b
21076               ELSE
21077                 crb = crb - abs19b
21078               END IF
21079               temp19b = dt*crb/(dx*mu)
21080               velb = temp19b
21081               mub0 = mub0 - vel*temp19b/mu
21082               CALL POPREAL8(vel)
21083               rub(i, k, j) = rub(i, k, j) + velb
21084               CALL POPREAL8(mu)
21085               mutb(i, j) = mutb(i, j) + 0.5*mub0
21086               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21087               CALL POPREAL8(dx)
21088             END DO
21089           END IF
21090         END DO
21091       END IF
21092       CALL POPCONTROL1B(branch)
21093       IF (branch .EQ. 0) THEN
21094         CALL POPINTEGER4(ad_from5)
21095         DO i=i_start_f-1,ad_from5,-1
21096           CALL POPCONTROL1B(branch)
21097           IF (branch .NE. 0) THEN
21098             DO k=ktf,kts,-1
21099               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21100               temp15 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
21101 &                , k, j)-field(i-1, k, j))
21102               temp18 = SIGN(1., vel)
21103               temp17 = temp18/12.
21104               temp16 = SIGN(1, time_step)
21105               temp15b2 = vel*fqxb(i, k, j)
21106               temp15b3 = 7.*temp15b2/12.
21107               temp15b4 = temp16*temp17*temp15b2
21108               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
21109 &                i+1, k, j)+field(i-2, k, j))/12.+temp16*(temp17*temp15))&
21110 &                *fqxb(i, k, j)
21111               fieldb(i, k, j) = fieldb(i, k, j) + temp15b3 - 3.*temp15b4
21112               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp15b4 + &
21113 &                temp15b3
21114               fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp15b4 - &
21115 &                temp15b2/12.
21116               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp15b4 - &
21117 &                temp15b2/12.
21118               fqxb(i, k, j) = 0.0
21119               temp15b5 = dx*mu*fqxlb(i, k, j)/dt
21120               min26b = 0.5*field_old(i-1, k, j)*temp15b5
21121               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min26*&
21122 &                temp15b5
21123               max19b = 0.5*field_old(i, k, j)*temp15b5
21124               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max19*&
21125 &                temp15b5
21126               mub0 = (0.5*(min26*field_old(i-1, k, j))+0.5*(max19*&
21127 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21128               fqxlb(i, k, j) = 0.0
21129               CALL POPCONTROL1B(branch)
21130               IF (branch .EQ. 0) THEN
21131                 CALL POPREAL8(max19)
21132                 y69b = max19b
21133               ELSE
21134                 CALL POPREAL8(max19)
21135                 y69b = 0.0
21136               END IF
21137               crb = y69b
21138               abs69b = -y69b
21139               CALL POPCONTROL1B(branch)
21140               IF (branch .EQ. 0) THEN
21141                 crb = crb + abs69b
21142               ELSE
21143                 crb = crb - abs69b
21144               END IF
21145               CALL POPCONTROL1B(branch)
21146               IF (branch .EQ. 0) THEN
21147                 CALL POPREAL8(min26)
21148                 y18b = min26b
21149               ELSE
21150                 CALL POPREAL8(min26)
21151                 y18b = 0.0
21152               END IF
21153               crb = crb + y18b
21154               abs18b = y18b
21155               CALL POPCONTROL1B(branch)
21156               IF (branch .EQ. 0) THEN
21157                 crb = crb + abs18b
21158               ELSE
21159                 crb = crb - abs18b
21160               END IF
21161               temp15b1 = dt*crb/(dx*mu)
21162               velb = velb + temp15b1
21163               mub0 = mub0 - vel*temp15b1/mu
21164               CALL POPREAL8(vel)
21165               rub(i, k, j) = rub(i, k, j) + velb
21166               CALL POPREAL8(mu)
21167               mutb(i, j) = mutb(i, j) + 0.5*mub0
21168               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21169               CALL POPREAL8(dx)
21170             END DO
21171           END IF
21172           CALL POPCONTROL1B(branch)
21173           IF (branch .EQ. 0) THEN
21174             DO k=ktf,kts,-1
21175               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21176               temp15b = 0.5*ru(i, k, j)*fqxb(i, k, j)
21177               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
21178 &                1, k, j))*fqxb(i, k, j)
21179               fieldb(i, k, j) = fieldb(i, k, j) + temp15b
21180               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp15b
21181               fqxb(i, k, j) = 0.0
21182               temp15b0 = dx*mu*fqxlb(i, k, j)/dt
21183               min25b = 0.5*field_old(i-1, k, j)*temp15b0
21184               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min25*&
21185 &                temp15b0
21186               max18b = 0.5*field_old(i, k, j)*temp15b0
21187               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max18*&
21188 &                temp15b0
21189               mub0 = (0.5*(min25*field_old(i-1, k, j))+0.5*(max18*&
21190 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21191               fqxlb(i, k, j) = 0.0
21192               CALL POPCONTROL1B(branch)
21193               IF (branch .EQ. 0) THEN
21194                 CALL POPREAL8(max18)
21195                 y68b = max18b
21196               ELSE
21197                 CALL POPREAL8(max18)
21198                 y68b = 0.0
21199               END IF
21200               crb = y68b
21201               abs68b = -y68b
21202               CALL POPCONTROL1B(branch)
21203               IF (branch .EQ. 0) THEN
21204                 crb = crb + abs68b
21205               ELSE
21206                 crb = crb - abs68b
21207               END IF
21208               CALL POPCONTROL1B(branch)
21209               IF (branch .EQ. 0) THEN
21210                 CALL POPREAL8(min25)
21211                 y17b = min25b
21212               ELSE
21213                 CALL POPREAL8(min25)
21214                 y17b = 0.0
21215               END IF
21216               crb = crb + y17b
21217               abs17b = y17b
21218               CALL POPCONTROL1B(branch)
21219               IF (branch .EQ. 0) THEN
21220                 crb = crb + abs17b
21221               ELSE
21222                 crb = crb - abs17b
21223               END IF
21224               velb = dt*crb/dx
21225               CALL POPREAL8(vel)
21226               rub(i, k, j) = rub(i, k, j) + velb/mu
21227               mub0 = mub0 - ru(i, k, j)*velb/mu**2
21228               CALL POPREAL8(mu)
21229               mutb(i, j) = mutb(i, j) + 0.5*mub0
21230               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21231               CALL POPREAL8(dx)
21232             END DO
21233           END IF
21234         END DO
21235       END IF
21236       DO k=ktf,kts,-1
21237         DO i=i_end_f,i_start_f,-1
21238           fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21239           temp11 = field(i+2, k, j) - field(i-3, k, j) + 10.*(field(i, k&
21240 &            , j)-field(i-1, k, j)) - 5.*(field(i+1, k, j)-field(i-2, k, &
21241 &            j))
21242           temp14 = SIGN(1., vel)
21243           temp13 = temp14/60.
21244           temp12 = SIGN(1, time_step)
21245           temp11b0 = vel*fqxb(i, k, j)
21246           temp11b1 = 37.*temp11b0/60.
21247           temp11b2 = -(2.*temp11b0/15.)
21248           temp11b3 = -(temp12*temp13*temp11b0)
21249           velb = (37.*((field(i, k, j)+field(i-1, k, j))/60.)-2.*((field&
21250 &            (i+1, k, j)+field(i-2, k, j))/15.)+(field(i+2, k, j)+field(i&
21251 &            -3, k, j))/60.-temp12*(temp13*temp11))*fqxb(i, k, j)
21252           fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp11b3 + temp11b1
21253           fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp11b1 - 10.*&
21254 &            temp11b3
21255           fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp11b2 - 5.*temp11b3
21256           fieldb(i-2, k, j) = fieldb(i-2, k, j) + 5.*temp11b3 + temp11b2
21257           fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp11b3 + temp11b0/&
21258 &            60.
21259           fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp11b0/60. - &
21260 &            temp11b3
21261           fqxb(i, k, j) = 0.0
21262           temp11b4 = dx*mu*fqxlb(i, k, j)/dt
21263           min24b = 0.5*field_old(i-1, k, j)*temp11b4
21264           field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min24*&
21265 &            temp11b4
21266           max17b = 0.5*field_old(i, k, j)*temp11b4
21267           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max17*temp11b4
21268           mub0 = (0.5*(min24*field_old(i-1, k, j))+0.5*(max17*field_old(&
21269 &            i, k, j)))*dx*fqxlb(i, k, j)/dt
21270           fqxlb(i, k, j) = 0.0
21271           CALL POPCONTROL1B(branch)
21272           IF (branch .EQ. 0) THEN
21273             CALL POPREAL8(max17)
21274             y67b = max17b
21275           ELSE
21276             CALL POPREAL8(max17)
21277             y67b = 0.0
21278           END IF
21279           crb = y67b
21280           abs67b = -y67b
21281           CALL POPCONTROL1B(branch)
21282           IF (branch .EQ. 0) THEN
21283             crb = crb + abs67b
21284           ELSE
21285             crb = crb - abs67b
21286           END IF
21287           CALL POPCONTROL1B(branch)
21288           IF (branch .EQ. 0) THEN
21289             CALL POPREAL8(min24)
21290             y16b = min24b
21291           ELSE
21292             CALL POPREAL8(min24)
21293             y16b = 0.0
21294           END IF
21295           crb = crb + y16b
21296           abs16b = y16b
21297           CALL POPCONTROL1B(branch)
21298           IF (branch .EQ. 0) THEN
21299             crb = crb + abs16b
21300           ELSE
21301             crb = crb - abs16b
21302           END IF
21303           temp11b = dt*crb/(dx*mu)
21304           velb = velb + temp11b
21305           mub0 = mub0 - vel*temp11b/mu
21306           CALL POPREAL8(vel)
21307           rub(i, k, j) = rub(i, k, j) + velb
21308           CALL POPREAL8(mu)
21309           mutb(i, j) = mutb(i, j) + 0.5*mub0
21310           mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21311           CALL POPREAL8(dx)
21312         END DO
21313       END DO
21314     END DO
21315     CALL POPINTEGER4(ad_from4)
21316     CALL POPINTEGER4(ad_to4)
21317     DO j=ad_to4,ad_from4,-1
21318       CALL POPCONTROL3B(branch)
21319       IF (branch .LT. 3) THEN
21320         IF (branch .NE. 0) THEN
21321           IF (branch .EQ. 1) THEN
21322             DO k=ktf,kts,-1
21323               CALL POPINTEGER4(ad_from3)
21324               CALL POPINTEGER4(ad_to3)
21325               DO i=ad_to3,ad_from3,-1
21326                 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
21327                 temp7 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(&
21328 &                  i, k, j)-field(i, k, j-1))
21329                 temp10 = SIGN(1., vel)
21330                 temp9 = temp10/12.
21331                 temp8 = SIGN(1, time_step)
21332                 temp7b3 = vel*fqyb(i, k, j)
21333                 temp7b4 = 7.*temp7b3/12.
21334                 temp7b5 = temp8*temp9*temp7b3
21335                 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(&
21336 &                  field(i, k, j+1)+field(i, k, j-2))/12.+temp8*(temp9*&
21337 &                  temp7))*fqyb(i, k, j)
21338                 fieldb(i, k, j) = fieldb(i, k, j) + temp7b4 - 3.*temp7b5
21339                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp7b5 + &
21340 &                  temp7b4
21341                 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp7b5 - &
21342 &                  temp7b3/12.
21343                 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp7b5 - &
21344 &                  temp7b3/12.
21345                 fqyb(i, k, j) = 0.0
21346                 temp7b6 = dy*mu*fqylb(i, k, j)/dt
21347                 min21b = 0.5*field_old(i, k, j-1)*temp7b6
21348                 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*&
21349 &                  min21*temp7b6
21350                 max16b = 0.5*field_old(i, k, j)*temp7b6
21351                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max16*&
21352 &                  temp7b6
21353                 mub0 = (0.5*(min21*field_old(i, k, j-1))+0.5*(max16*&
21354 &                  field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
21355                 fqylb(i, k, j) = 0.0
21356                 CALL POPCONTROL1B(branch)
21357                 IF (branch .EQ. 0) THEN
21358                   CALL POPREAL8(max16)
21359                   y66b = max16b
21360                 ELSE
21361                   CALL POPREAL8(max16)
21362                   y66b = 0.0
21363                 END IF
21364                 crb = y66b
21365                 abs66b = -y66b
21366                 CALL POPCONTROL1B(branch)
21367                 IF (branch .EQ. 0) THEN
21368                   crb = crb + abs66b
21369                 ELSE
21370                   crb = crb - abs66b
21371                 END IF
21372                 CALL POPCONTROL1B(branch)
21373                 IF (branch .EQ. 0) THEN
21374                   CALL POPREAL8(min21)
21375                   y15b = min21b
21376                 ELSE
21377                   CALL POPREAL8(min21)
21378                   y15b = 0.0
21379                 END IF
21380                 crb = crb + y15b
21381                 abs15b = y15b
21382                 CALL POPCONTROL1B(branch)
21383                 IF (branch .EQ. 0) THEN
21384                   crb = crb + abs15b
21385                 ELSE
21386                   crb = crb - abs15b
21387                 END IF
21388                 temp7b2 = dt*crb/(dy*mu)
21389                 velb = velb + temp7b2
21390                 mub0 = mub0 - vel*temp7b2/mu
21391                 CALL POPREAL8(vel)
21392                 rvb(i, k, j) = rvb(i, k, j) + velb
21393                 CALL POPREAL8(mu)
21394                 mutb(i, j) = mutb(i, j) + 0.5*mub0
21395                 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
21396                 CALL POPREAL8(dy)
21397               END DO
21398             END DO
21399           ELSE
21400             DO k=ktf,kts,-1
21401               CALL POPINTEGER4(ad_from2)
21402               CALL POPINTEGER4(ad_to2)
21403               DO i=ad_to2,ad_from2,-1
21404                 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
21405                 temp7b0 = 0.5*rv(i, k, j)*fqyb(i, k, j)
21406                 rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(&
21407 &                  i, k, j-1))*fqyb(i, k, j)
21408                 fieldb(i, k, j) = fieldb(i, k, j) + temp7b0
21409                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp7b0
21410                 fqyb(i, k, j) = 0.0
21411                 temp7b1 = dy*mu*fqylb(i, k, j)/dt
21412                 min20b = 0.5*field_old(i, k, j-1)*temp7b1
21413                 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*&
21414 &                  min20*temp7b1
21415                 max15b = 0.5*field_old(i, k, j)*temp7b1
21416                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max15*&
21417 &                  temp7b1
21418                 mub0 = (0.5*(min20*field_old(i, k, j-1))+0.5*(max15*&
21419 &                  field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
21420                 fqylb(i, k, j) = 0.0
21421                 CALL POPCONTROL1B(branch)
21422                 IF (branch .EQ. 0) THEN
21423                   CALL POPREAL8(max15)
21424                   y65b = max15b
21425                 ELSE
21426                   CALL POPREAL8(max15)
21427                   y65b = 0.0
21428                 END IF
21429                 crb = y65b
21430                 abs65b = -y65b
21431                 CALL POPCONTROL1B(branch)
21432                 IF (branch .EQ. 0) THEN
21433                   crb = crb + abs65b
21434                 ELSE
21435                   crb = crb - abs65b
21436                 END IF
21437                 CALL POPCONTROL1B(branch)
21438                 IF (branch .EQ. 0) THEN
21439                   CALL POPREAL8(min20)
21440                   y14b = min20b
21441                 ELSE
21442                   CALL POPREAL8(min20)
21443                   y14b = 0.0
21444                 END IF
21445                 crb = crb + y14b
21446                 abs14b = y14b
21447                 CALL POPCONTROL1B(branch)
21448                 IF (branch .EQ. 0) THEN
21449                   crb = crb + abs14b
21450                 ELSE
21451                   crb = crb - abs14b
21452                 END IF
21453                 temp7b = dt*crb/(dy*mu)
21454                 velb = temp7b
21455                 mub0 = mub0 - vel*temp7b/mu
21456                 CALL POPREAL8(vel)
21457                 rvb(i, k, j) = rvb(i, k, j) + velb
21458                 CALL POPREAL8(mu)
21459                 mutb(i, j) = mutb(i, j) + 0.5*mub0
21460                 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
21461                 CALL POPREAL8(dy)
21462               END DO
21463             END DO
21464           END IF
21465         END IF
21466       ELSE IF (branch .EQ. 3) THEN
21467         DO k=ktf,kts,-1
21468           CALL POPINTEGER4(ad_from1)
21469           CALL POPINTEGER4(ad_to1)
21470           DO i=ad_to1,ad_from1,-1
21471             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
21472             temp3 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k&
21473 &              , j)-field(i, k, j-1))
21474             temp6 = SIGN(1., vel)
21475             temp5 = temp6/12.
21476             temp4 = SIGN(1, time_step)
21477             temp3b3 = vel*fqyb(i, k, j)
21478             temp3b4 = 7.*temp3b3/12.
21479             temp3b5 = temp4*temp5*temp3b3
21480             velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i&
21481 &              , k, j+1)+field(i, k, j-2))/12.+temp4*(temp5*temp3))*fqyb(&
21482 &              i, k, j)
21483             fieldb(i, k, j) = fieldb(i, k, j) + temp3b4 - 3.*temp3b5
21484             fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp3b5 + temp3b4
21485             fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp3b5 - temp3b3/&
21486 &              12.
21487             fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp3b5 - temp3b3/&
21488 &              12.
21489             fqyb(i, k, j) = 0.0
21490             temp3b6 = dy*mu*fqylb(i, k, j)/dt
21491             min19b = 0.5*field_old(i, k, j-1)*temp3b6
21492             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min19*&
21493 &              temp3b6
21494             max14b = 0.5*field_old(i, k, j)*temp3b6
21495             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max14*&
21496 &              temp3b6
21497             mub0 = (0.5*(min19*field_old(i, k, j-1))+0.5*(max14*&
21498 &              field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
21499             fqylb(i, k, j) = 0.0
21500             CALL POPCONTROL1B(branch)
21501             IF (branch .EQ. 0) THEN
21502               CALL POPREAL8(max14)
21503               y64b = max14b
21504             ELSE
21505               CALL POPREAL8(max14)
21506               y64b = 0.0
21507             END IF
21508             crb = y64b
21509             abs64b = -y64b
21510             CALL POPCONTROL1B(branch)
21511             IF (branch .EQ. 0) THEN
21512               crb = crb + abs64b
21513             ELSE
21514               crb = crb - abs64b
21515             END IF
21516             CALL POPCONTROL1B(branch)
21517             IF (branch .EQ. 0) THEN
21518               CALL POPREAL8(min19)
21519               y13b = min19b
21520             ELSE
21521               CALL POPREAL8(min19)
21522               y13b = 0.0
21523             END IF
21524             crb = crb + y13b
21525             abs13b = y13b
21526             CALL POPCONTROL1B(branch)
21527             IF (branch .EQ. 0) THEN
21528               crb = crb + abs13b
21529             ELSE
21530               crb = crb - abs13b
21531             END IF
21532             temp3b2 = dt*crb/(dy*mu)
21533             velb = velb + temp3b2
21534             mub0 = mub0 - vel*temp3b2/mu
21535             CALL POPREAL8(vel)
21536             rvb(i, k, j) = rvb(i, k, j) + velb
21537             CALL POPREAL8(mu)
21538             mutb(i, j) = mutb(i, j) + 0.5*mub0
21539             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
21540             CALL POPREAL8(dy)
21541           END DO
21542         END DO
21543       ELSE IF (branch .EQ. 4) THEN
21544         DO k=ktf,kts,-1
21545           CALL POPINTEGER4(ad_from0)
21546           CALL POPINTEGER4(ad_to0)
21547           DO i=ad_to0,ad_from0,-1
21548             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
21549             temp3b0 = 0.5*rv(i, k, j)*fqyb(i, k, j)
21550             rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k&
21551 &              , j-1))*fqyb(i, k, j)
21552             fieldb(i, k, j) = fieldb(i, k, j) + temp3b0
21553             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp3b0
21554             fqyb(i, k, j) = 0.0
21555             temp3b1 = dy*mu*fqylb(i, k, j)/dt
21556             min18b = 0.5*field_old(i, k, j-1)*temp3b1
21557             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min18*&
21558 &              temp3b1
21559             max13b = 0.5*field_old(i, k, j)*temp3b1
21560             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max13*&
21561 &              temp3b1
21562             mub0 = (0.5*(min18*field_old(i, k, j-1))+0.5*(max13*&
21563 &              field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
21564             fqylb(i, k, j) = 0.0
21565             CALL POPCONTROL1B(branch)
21566             IF (branch .EQ. 0) THEN
21567               CALL POPREAL8(max13)
21568               y63b = max13b
21569             ELSE
21570               CALL POPREAL8(max13)
21571               y63b = 0.0
21572             END IF
21573             crb = y63b
21574             abs63b = -y63b
21575             CALL POPCONTROL1B(branch)
21576             IF (branch .EQ. 0) THEN
21577               crb = crb + abs63b
21578             ELSE
21579               crb = crb - abs63b
21580             END IF
21581             CALL POPCONTROL1B(branch)
21582             IF (branch .EQ. 0) THEN
21583               CALL POPREAL8(min18)
21584               y12b = min18b
21585             ELSE
21586               CALL POPREAL8(min18)
21587               y12b = 0.0
21588             END IF
21589             crb = crb + y12b
21590             abs12b = y12b
21591             CALL POPCONTROL1B(branch)
21592             IF (branch .EQ. 0) THEN
21593               crb = crb + abs12b
21594             ELSE
21595               crb = crb - abs12b
21596             END IF
21597             temp3b = dt*crb/(dy*mu)
21598             velb = temp3b
21599             mub0 = mub0 - vel*temp3b/mu
21600             CALL POPREAL8(vel)
21601             rvb(i, k, j) = rvb(i, k, j) + velb
21602             CALL POPREAL8(mu)
21603             mutb(i, j) = mutb(i, j) + 0.5*mub0
21604             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
21605             CALL POPREAL8(dy)
21606           END DO
21607         END DO
21608       ELSE
21609         DO k=ktf,kts,-1
21610           CALL POPINTEGER4(ad_from)
21611           CALL POPINTEGER4(ad_to)
21612           DO i=ad_to,ad_from,-1
21613             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
21614             temp = field(i, k, j+2) - field(i, k, j-3) + 10.*(field(i, k&
21615 &              , j)-field(i, k, j-1)) - 5.*(field(i, k, j+1)-field(i, k, &
21616 &              j-2))
21617             temp2 = SIGN(1., vel)
21618             temp1 = temp2/60.
21619             temp0 = SIGN(1, time_step)
21620             tempb0 = vel*fqyb(i, k, j)
21621             tempb1 = 37.*tempb0/60.
21622             tempb2 = -(2.*tempb0/15.)
21623             tempb3 = -(temp0*temp1*tempb0)
21624             velb = (37.*((field(i, k, j)+field(i, k, j-1))/60.)-2.*((&
21625 &              field(i, k, j+1)+field(i, k, j-2))/15.)+(field(i, k, j+2)+&
21626 &              field(i, k, j-3))/60.-temp0*(temp1*temp))*fqyb(i, k, j)
21627             fieldb(i, k, j) = fieldb(i, k, j) + 10.*tempb3 + tempb1
21628             fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb1 - 10.*tempb3
21629             fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb2 - 5.*tempb3
21630             fieldb(i, k, j-2) = fieldb(i, k, j-2) + 5.*tempb3 + tempb2
21631             fieldb(i, k, j+2) = fieldb(i, k, j+2) + tempb3 + tempb0/60.
21632             fieldb(i, k, j-3) = fieldb(i, k, j-3) + tempb0/60. - tempb3
21633             fqyb(i, k, j) = 0.0
21634             tempb4 = dy*mu*fqylb(i, k, j)/dt
21635             min17b = 0.5*field_old(i, k, j-1)*tempb4
21636             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min17*&
21637 &              tempb4
21638             max12b = 0.5*field_old(i, k, j)*tempb4
21639             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max12*tempb4
21640             mub0 = (0.5*(min17*field_old(i, k, j-1))+0.5*(max12*&
21641 &              field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
21642             fqylb(i, k, j) = 0.0
21643             CALL POPCONTROL1B(branch)
21644             IF (branch .EQ. 0) THEN
21645               CALL POPREAL8(max12)
21646               y62b = max12b
21647             ELSE
21648               CALL POPREAL8(max12)
21649               y62b = 0.0
21650             END IF
21651             crb = y62b
21652             abs62b = -y62b
21653             CALL POPCONTROL1B(branch)
21654             IF (branch .EQ. 0) THEN
21655               crb = crb + abs62b
21656             ELSE
21657               crb = crb - abs62b
21658             END IF
21659             CALL POPCONTROL1B(branch)
21660             IF (branch .EQ. 0) THEN
21661               CALL POPREAL8(min17)
21662               y11b = min17b
21663             ELSE
21664               CALL POPREAL8(min17)
21665               y11b = 0.0
21666             END IF
21667             crb = crb + y11b
21668             abs11b = y11b
21669             CALL POPCONTROL1B(branch)
21670             IF (branch .EQ. 0) THEN
21671               crb = crb + abs11b
21672             ELSE
21673               crb = crb - abs11b
21674             END IF
21675             tempb = dt*crb/(dy*mu)
21676             velb = velb + tempb
21677             mub0 = mub0 - vel*tempb/mu
21678             CALL POPREAL8(vel)
21679             rvb(i, k, j) = rvb(i, k, j) + velb
21680             CALL POPREAL8(mu)
21681             mutb(i, j) = mutb(i, j) + 0.5*mub0
21682             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
21683             CALL POPREAL8(dy)
21684           END DO
21685         END DO
21686       END IF
21687     END DO
21688   ELSE
21689     CALL POPINTEGER4(ad_from28)
21690     CALL POPINTEGER4(ad_to28)
21691     DO j=ad_to28,ad_from28,-1
21692       CALL POPCONTROL1B(branch)
21693       IF (branch .NE. 0) THEN
21694         CALL POPINTEGER4(ad_to27)
21695         DO i=ad_to27,i_end_f+1,-1
21696           CALL POPCONTROL1B(branch)
21697           IF (branch .NE. 0) THEN
21698             DO k=ktf,kts,-1
21699               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21700               temp31b44 = vel*fqxb(i, k, j)
21701               temp31b45 = 7.*temp31b44/12.
21702               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
21703 &                i+1, k, j)+field(i-2, k, j))/12.)*fqxb(i, k, j)
21704               fieldb(i, k, j) = fieldb(i, k, j) + temp31b45
21705               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b45
21706               fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b44/12.
21707               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b44/12.
21708               fqxb(i, k, j) = 0.0
21709               temp31b46 = dx*mu*fqxlb(i, k, j)/dt
21710               min14b = 0.5*field_old(i-1, k, j)*temp31b46
21711               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min14*&
21712 &                temp31b46
21713               max11b = 0.5*field_old(i, k, j)*temp31b46
21714               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max11*&
21715 &                temp31b46
21716               mub0 = (0.5*(min14*field_old(i-1, k, j))+0.5*(max11*&
21717 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21718               fqxlb(i, k, j) = 0.0
21719               CALL POPCONTROL1B(branch)
21720               IF (branch .EQ. 0) THEN
21721                 CALL POPREAL8(max11)
21722                 y61b = max11b
21723               ELSE
21724                 CALL POPREAL8(max11)
21725                 y61b = 0.0
21726               END IF
21727               crb = y61b
21728               abs61b = -y61b
21729               CALL POPCONTROL1B(branch)
21730               IF (branch .EQ. 0) THEN
21731                 crb = crb + abs61b
21732               ELSE
21733                 crb = crb - abs61b
21734               END IF
21735               CALL POPCONTROL1B(branch)
21736               IF (branch .EQ. 0) THEN
21737                 CALL POPREAL8(min14)
21738                 y10b = min14b
21739               ELSE
21740                 CALL POPREAL8(min14)
21741                 y10b = 0.0
21742               END IF
21743               crb = crb + y10b
21744               abs10b = y10b
21745               CALL POPCONTROL1B(branch)
21746               IF (branch .EQ. 0) THEN
21747                 crb = crb + abs10b
21748               ELSE
21749                 crb = crb - abs10b
21750               END IF
21751               temp31b43 = dt*crb/(dx*mu)
21752               velb = velb + temp31b43
21753               mub0 = mub0 - vel*temp31b43/mu
21754               CALL POPREAL8(vel)
21755               rub(i, k, j) = rub(i, k, j) + velb
21756               CALL POPREAL8(mu)
21757               mutb(i, j) = mutb(i, j) + 0.5*mub0
21758               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21759               CALL POPREAL8(dx)
21760             END DO
21761           END IF
21762           CALL POPCONTROL1B(branch)
21763           IF (branch .EQ. 0) THEN
21764             DO k=ktf,kts,-1
21765               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21766               temp31b41 = 0.5*ru(i, k, j)*fqxb(i, k, j)
21767               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
21768 &                1, k, j))*fqxb(i, k, j)
21769               fieldb(i, k, j) = fieldb(i, k, j) + temp31b41
21770               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b41
21771               fqxb(i, k, j) = 0.0
21772               temp31b42 = dx*mu*fqxlb(i, k, j)/dt
21773               min13b = 0.5*field_old(i-1, k, j)*temp31b42
21774               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min13*&
21775 &                temp31b42
21776               max10b = 0.5*field_old(i, k, j)*temp31b42
21777               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max10*&
21778 &                temp31b42
21779               mub0 = (0.5*(min13*field_old(i-1, k, j))+0.5*(max10*&
21780 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21781               fqxlb(i, k, j) = 0.0
21782               CALL POPCONTROL1B(branch)
21783               IF (branch .EQ. 0) THEN
21784                 CALL POPREAL8(max10)
21785                 y60b = max10b
21786               ELSE
21787                 CALL POPREAL8(max10)
21788                 y60b = 0.0
21789               END IF
21790               crb = y60b
21791               abs60b = -y60b
21792               CALL POPCONTROL1B(branch)
21793               IF (branch .EQ. 0) THEN
21794                 crb = crb + abs60b
21795               ELSE
21796                 crb = crb - abs60b
21797               END IF
21798               CALL POPCONTROL1B(branch)
21799               IF (branch .EQ. 0) THEN
21800                 CALL POPREAL8(min13)
21801                 y9b = min13b
21802               ELSE
21803                 CALL POPREAL8(min13)
21804                 y9b = 0.0
21805               END IF
21806               crb = crb + y9b
21807               abs9b = y9b
21808               CALL POPCONTROL1B(branch)
21809               IF (branch .EQ. 0) THEN
21810                 crb = crb + abs9b
21811               ELSE
21812                 crb = crb - abs9b
21813               END IF
21814               temp31b40 = dt*crb/(dx*mu)
21815               velb = temp31b40
21816               mub0 = mub0 - vel*temp31b40/mu
21817               CALL POPREAL8(vel)
21818               rub(i, k, j) = rub(i, k, j) + velb
21819               CALL POPREAL8(mu)
21820               mutb(i, j) = mutb(i, j) + 0.5*mub0
21821               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21822               CALL POPREAL8(dx)
21823             END DO
21824           END IF
21825         END DO
21826       END IF
21827       CALL POPCONTROL1B(branch)
21828       IF (branch .EQ. 0) THEN
21829         CALL POPINTEGER4(ad_from27)
21830         DO i=i_start_f-1,ad_from27,-1
21831           CALL POPCONTROL1B(branch)
21832           IF (branch .NE. 0) THEN
21833             DO k=ktf,kts,-1
21834               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21835               temp31b37 = vel*fqxb(i, k, j)
21836               temp31b38 = 7.*temp31b37/12.
21837               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
21838 &                i+1, k, j)+field(i-2, k, j))/12.)*fqxb(i, k, j)
21839               fieldb(i, k, j) = fieldb(i, k, j) + temp31b38
21840               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b38
21841               fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b37/12.
21842               fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b37/12.
21843               fqxb(i, k, j) = 0.0
21844               temp31b39 = dx*mu*fqxlb(i, k, j)/dt
21845               min12b = 0.5*field_old(i-1, k, j)*temp31b39
21846               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min12*&
21847 &                temp31b39
21848               max9b = 0.5*field_old(i, k, j)*temp31b39
21849               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max9*&
21850 &                temp31b39
21851               mub0 = (0.5*(min12*field_old(i-1, k, j))+0.5*(max9*&
21852 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21853               fqxlb(i, k, j) = 0.0
21854               CALL POPCONTROL1B(branch)
21855               IF (branch .EQ. 0) THEN
21856                 CALL POPREAL8(max9)
21857                 y59b = max9b
21858               ELSE
21859                 CALL POPREAL8(max9)
21860                 y59b = 0.0
21861               END IF
21862               crb = y59b
21863               abs59b = -y59b
21864               CALL POPCONTROL1B(branch)
21865               IF (branch .EQ. 0) THEN
21866                 crb = crb + abs59b
21867               ELSE
21868                 crb = crb - abs59b
21869               END IF
21870               CALL POPCONTROL1B(branch)
21871               IF (branch .EQ. 0) THEN
21872                 CALL POPREAL8(min12)
21873                 y8b = min12b
21874               ELSE
21875                 CALL POPREAL8(min12)
21876                 y8b = 0.0
21877               END IF
21878               crb = crb + y8b
21879               abs8b = y8b
21880               CALL POPCONTROL1B(branch)
21881               IF (branch .EQ. 0) THEN
21882                 crb = crb + abs8b
21883               ELSE
21884                 crb = crb - abs8b
21885               END IF
21886               temp31b36 = dt*crb/(dx*mu)
21887               velb = velb + temp31b36
21888               mub0 = mub0 - vel*temp31b36/mu
21889               CALL POPREAL8(vel)
21890               rub(i, k, j) = rub(i, k, j) + velb
21891               CALL POPREAL8(mu)
21892               mutb(i, j) = mutb(i, j) + 0.5*mub0
21893               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21894               CALL POPREAL8(dx)
21895             END DO
21896           END IF
21897           CALL POPCONTROL1B(branch)
21898           IF (branch .EQ. 0) THEN
21899             DO k=ktf,kts,-1
21900               fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21901               temp31b34 = 0.5*ru(i, k, j)*fqxb(i, k, j)
21902               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
21903 &                1, k, j))*fqxb(i, k, j)
21904               fieldb(i, k, j) = fieldb(i, k, j) + temp31b34
21905               fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b34
21906               fqxb(i, k, j) = 0.0
21907               temp31b35 = dx*mu*fqxlb(i, k, j)/dt
21908               min11b = 0.5*field_old(i-1, k, j)*temp31b35
21909               field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min11*&
21910 &                temp31b35
21911               max8b = 0.5*field_old(i, k, j)*temp31b35
21912               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max8*&
21913 &                temp31b35
21914               mub0 = (0.5*(min11*field_old(i-1, k, j))+0.5*(max8*&
21915 &                field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
21916               fqxlb(i, k, j) = 0.0
21917               CALL POPCONTROL1B(branch)
21918               IF (branch .EQ. 0) THEN
21919                 CALL POPREAL8(max8)
21920                 y58b = max8b
21921               ELSE
21922                 CALL POPREAL8(max8)
21923                 y58b = 0.0
21924               END IF
21925               crb = y58b
21926               abs58b = -y58b
21927               CALL POPCONTROL1B(branch)
21928               IF (branch .EQ. 0) THEN
21929                 crb = crb + abs58b
21930               ELSE
21931                 crb = crb - abs58b
21932               END IF
21933               CALL POPCONTROL1B(branch)
21934               IF (branch .EQ. 0) THEN
21935                 CALL POPREAL8(min11)
21936                 y7b = min11b
21937               ELSE
21938                 CALL POPREAL8(min11)
21939                 y7b = 0.0
21940               END IF
21941               crb = crb + y7b
21942               abs7b = y7b
21943               CALL POPCONTROL1B(branch)
21944               IF (branch .EQ. 0) THEN
21945                 crb = crb + abs7b
21946               ELSE
21947                 crb = crb - abs7b
21948               END IF
21949               velb = dt*crb/dx
21950               CALL POPREAL8(vel)
21951               rub(i, k, j) = rub(i, k, j) + velb/mu
21952               mub0 = mub0 - ru(i, k, j)*velb/mu**2
21953               CALL POPREAL8(mu)
21954               mutb(i, j) = mutb(i, j) + 0.5*mub0
21955               mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
21956               CALL POPREAL8(dx)
21957             END DO
21958           END IF
21959         END DO
21960       END IF
21961       DO k=ktf,kts,-1
21962         DO i=i_end_f,i_start_f,-1
21963           fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
21964           temp31b30 = vel*fqxb(i, k, j)
21965           temp31b31 = 37.*temp31b30/60.
21966           temp31b32 = -(2.*temp31b30/15.)
21967           velb = (37.*((field(i, k, j)+field(i-1, k, j))/60.)-2.*((field&
21968 &            (i+1, k, j)+field(i-2, k, j))/15.)+(field(i+2, k, j)+field(i&
21969 &            -3, k, j))/60.)*fqxb(i, k, j)
21970           fieldb(i, k, j) = fieldb(i, k, j) + temp31b31
21971           fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b31
21972           fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp31b32
21973           fieldb(i-2, k, j) = fieldb(i-2, k, j) + temp31b32
21974           fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp31b30/60.
21975           fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp31b30/60.
21976           fqxb(i, k, j) = 0.0
21977           temp31b33 = dx*mu*fqxlb(i, k, j)/dt
21978           min10b = 0.5*field_old(i-1, k, j)*temp31b33
21979           field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min10*&
21980 &            temp31b33
21981           max7b = 0.5*field_old(i, k, j)*temp31b33
21982           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max7*temp31b33
21983           mub0 = (0.5*(min10*field_old(i-1, k, j))+0.5*(max7*field_old(i&
21984 &            , k, j)))*dx*fqxlb(i, k, j)/dt
21985           fqxlb(i, k, j) = 0.0
21986           CALL POPCONTROL1B(branch)
21987           IF (branch .EQ. 0) THEN
21988             CALL POPREAL8(max7)
21989             y57b = max7b
21990           ELSE
21991             CALL POPREAL8(max7)
21992             y57b = 0.0
21993           END IF
21994           crb = y57b
21995           abs57b = -y57b
21996           CALL POPCONTROL1B(branch)
21997           IF (branch .EQ. 0) THEN
21998             crb = crb + abs57b
21999           ELSE
22000             crb = crb - abs57b
22001           END IF
22002           CALL POPCONTROL1B(branch)
22003           IF (branch .EQ. 0) THEN
22004             CALL POPREAL8(min10)
22005             y6b = min10b
22006           ELSE
22007             CALL POPREAL8(min10)
22008             y6b = 0.0
22009           END IF
22010           crb = crb + y6b
22011           abs6b = y6b
22012           CALL POPCONTROL1B(branch)
22013           IF (branch .EQ. 0) THEN
22014             crb = crb + abs6b
22015           ELSE
22016             crb = crb - abs6b
22017           END IF
22018           temp31b29 = dt*crb/(dx*mu)
22019           velb = velb + temp31b29
22020           mub0 = mub0 - vel*temp31b29/mu
22021           CALL POPREAL8(vel)
22022           rub(i, k, j) = rub(i, k, j) + velb
22023           CALL POPREAL8(mu)
22024           mutb(i, j) = mutb(i, j) + 0.5*mub0
22025           mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
22026           CALL POPREAL8(dx)
22027         END DO
22028       END DO
22029     END DO
22030     CALL POPINTEGER4(ad_from26)
22031     CALL POPINTEGER4(ad_to26)
22032     DO j=ad_to26,ad_from26,-1
22033       CALL POPCONTROL3B(branch)
22034       IF (branch .LT. 3) THEN
22035         IF (branch .NE. 0) THEN
22036           IF (branch .EQ. 1) THEN
22037             DO k=ktf,kts,-1
22038               CALL POPINTEGER4(ad_from25)
22039               CALL POPINTEGER4(ad_to25)
22040               DO i=ad_to25,ad_from25,-1
22041                 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
22042                 temp31b26 = vel*fqyb(i, k, j)
22043                 temp31b27 = 7.*temp31b26/12.
22044                 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(&
22045 &                  field(i, k, j+1)+field(i, k, j-2))/12.)*fqyb(i, k, j)
22046                 fieldb(i, k, j) = fieldb(i, k, j) + temp31b27
22047                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b27
22048                 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b26/12.
22049                 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b26/12.
22050                 fqyb(i, k, j) = 0.0
22051                 temp31b28 = dy*mu*fqylb(i, k, j)/dt
22052                 min7b = 0.5*field_old(i, k, j-1)*temp31b28
22053                 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min7&
22054 &                  *temp31b28
22055                 max6b = 0.5*field_old(i, k, j)*temp31b28
22056                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max6*&
22057 &                  temp31b28
22058                 mub0 = (0.5*(min7*field_old(i, k, j-1))+0.5*(max6*&
22059 &                  field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
22060                 fqylb(i, k, j) = 0.0
22061                 CALL POPCONTROL1B(branch)
22062                 IF (branch .EQ. 0) THEN
22063                   CALL POPREAL8(max6)
22064                   y56b = max6b
22065                 ELSE
22066                   CALL POPREAL8(max6)
22067                   y56b = 0.0
22068                 END IF
22069                 crb = y56b
22070                 abs56b = -y56b
22071                 CALL POPCONTROL1B(branch)
22072                 IF (branch .EQ. 0) THEN
22073                   crb = crb + abs56b
22074                 ELSE
22075                   crb = crb - abs56b
22076                 END IF
22077                 CALL POPCONTROL1B(branch)
22078                 IF (branch .EQ. 0) THEN
22079                   CALL POPREAL8(min7)
22080                   y5b = min7b
22081                 ELSE
22082                   CALL POPREAL8(min7)
22083                   y5b = 0.0
22084                 END IF
22085                 crb = crb + y5b
22086                 abs5b = y5b
22087                 CALL POPCONTROL1B(branch)
22088                 IF (branch .EQ. 0) THEN
22089                   crb = crb + abs5b
22090                 ELSE
22091                   crb = crb - abs5b
22092                 END IF
22093                 temp31b25 = dt*crb/(dy*mu)
22094                 velb = velb + temp31b25
22095                 mub0 = mub0 - vel*temp31b25/mu
22096                 CALL POPREAL8(vel)
22097                 rvb(i, k, j) = rvb(i, k, j) + velb
22098                 CALL POPREAL8(mu)
22099                 mutb(i, j) = mutb(i, j) + 0.5*mub0
22100                 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
22101                 CALL POPREAL8(dy)
22102               END DO
22103             END DO
22104           ELSE
22105             DO k=ktf,kts,-1
22106               CALL POPINTEGER4(ad_from24)
22107               CALL POPINTEGER4(ad_to24)
22108               DO i=ad_to24,ad_from24,-1
22109                 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
22110                 temp31b23 = 0.5*rv(i, k, j)*fqyb(i, k, j)
22111                 rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(&
22112 &                  i, k, j-1))*fqyb(i, k, j)
22113                 fieldb(i, k, j) = fieldb(i, k, j) + temp31b23
22114                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b23
22115                 fqyb(i, k, j) = 0.0
22116                 temp31b24 = dy*mu*fqylb(i, k, j)/dt
22117                 min6b = 0.5*field_old(i, k, j-1)*temp31b24
22118                 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min6&
22119 &                  *temp31b24
22120                 max5b = 0.5*field_old(i, k, j)*temp31b24
22121                 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max5*&
22122 &                  temp31b24
22123                 mub0 = (0.5*(min6*field_old(i, k, j-1))+0.5*(max5*&
22124 &                  field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
22125                 fqylb(i, k, j) = 0.0
22126                 CALL POPCONTROL1B(branch)
22127                 IF (branch .EQ. 0) THEN
22128                   CALL POPREAL8(max5)
22129                   y55b = max5b
22130                 ELSE
22131                   CALL POPREAL8(max5)
22132                   y55b = 0.0
22133                 END IF
22134                 crb = y55b
22135                 abs55b = -y55b
22136                 CALL POPCONTROL1B(branch)
22137                 IF (branch .EQ. 0) THEN
22138                   crb = crb + abs55b
22139                 ELSE
22140                   crb = crb - abs55b
22141                 END IF
22142                 CALL POPCONTROL1B(branch)
22143                 IF (branch .EQ. 0) THEN
22144                   CALL POPREAL8(min6)
22145                   y4b = min6b
22146                 ELSE
22147                   CALL POPREAL8(min6)
22148                   y4b = 0.0
22149                 END IF
22150                 crb = crb + y4b
22151                 abs4b = y4b
22152                 CALL POPCONTROL1B(branch)
22153                 IF (branch .EQ. 0) THEN
22154                   crb = crb + abs4b
22155                 ELSE
22156                   crb = crb - abs4b
22157                 END IF
22158                 temp31b22 = dt*crb/(dy*mu)
22159                 velb = temp31b22
22160                 mub0 = mub0 - vel*temp31b22/mu
22161                 CALL POPREAL8(vel)
22162                 rvb(i, k, j) = rvb(i, k, j) + velb
22163                 CALL POPREAL8(mu)
22164                 mutb(i, j) = mutb(i, j) + 0.5*mub0
22165                 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
22166                 CALL POPREAL8(dy)
22167               END DO
22168             END DO
22169           END IF
22170         END IF
22171       ELSE IF (branch .EQ. 3) THEN
22172         DO k=ktf,kts,-1
22173           CALL POPINTEGER4(ad_from23)
22174           CALL POPINTEGER4(ad_to23)
22175           DO i=ad_to23,ad_from23,-1
22176             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
22177             temp31b19 = vel*fqyb(i, k, j)
22178             temp31b20 = 7.*temp31b19/12.
22179             velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i&
22180 &              , k, j+1)+field(i, k, j-2))/12.)*fqyb(i, k, j)
22181             fieldb(i, k, j) = fieldb(i, k, j) + temp31b20
22182             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b20
22183             fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b19/12.
22184             fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b19/12.
22185             fqyb(i, k, j) = 0.0
22186             temp31b21 = dy*mu*fqylb(i, k, j)/dt
22187             min5b = 0.5*field_old(i, k, j-1)*temp31b21
22188             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min5*&
22189 &              temp31b21
22190             max4b = 0.5*field_old(i, k, j)*temp31b21
22191             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max4*&
22192 &              temp31b21
22193             mub0 = (0.5*(min5*field_old(i, k, j-1))+0.5*(max4*field_old(&
22194 &              i, k, j)))*dy*fqylb(i, k, j)/dt
22195             fqylb(i, k, j) = 0.0
22196             CALL POPCONTROL1B(branch)
22197             IF (branch .EQ. 0) THEN
22198               CALL POPREAL8(max4)
22199               y54b = max4b
22200             ELSE
22201               CALL POPREAL8(max4)
22202               y54b = 0.0
22203             END IF
22204             crb = y54b
22205             abs54b = -y54b
22206             CALL POPCONTROL1B(branch)
22207             IF (branch .EQ. 0) THEN
22208               crb = crb + abs54b
22209             ELSE
22210               crb = crb - abs54b
22211             END IF
22212             CALL POPCONTROL1B(branch)
22213             IF (branch .EQ. 0) THEN
22214               CALL POPREAL8(min5)
22215               y3b = min5b
22216             ELSE
22217               CALL POPREAL8(min5)
22218               y3b = 0.0
22219             END IF
22220             crb = crb + y3b
22221             abs3b = y3b
22222             CALL POPCONTROL1B(branch)
22223             IF (branch .EQ. 0) THEN
22224               crb = crb + abs3b
22225             ELSE
22226               crb = crb - abs3b
22227             END IF
22228             temp31b18 = dt*crb/(dy*mu)
22229             velb = velb + temp31b18
22230             mub0 = mub0 - vel*temp31b18/mu
22231             CALL POPREAL8(vel)
22232             rvb(i, k, j) = rvb(i, k, j) + velb
22233             CALL POPREAL8(mu)
22234             mutb(i, j) = mutb(i, j) + 0.5*mub0
22235             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
22236             CALL POPREAL8(dy)
22237           END DO
22238         END DO
22239       ELSE IF (branch .EQ. 4) THEN
22240         DO k=ktf,kts,-1
22241           CALL POPINTEGER4(ad_from22)
22242           CALL POPINTEGER4(ad_to22)
22243           DO i=ad_to22,ad_from22,-1
22244             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
22245             temp31b16 = 0.5*rv(i, k, j)*fqyb(i, k, j)
22246             rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k&
22247 &              , j-1))*fqyb(i, k, j)
22248             fieldb(i, k, j) = fieldb(i, k, j) + temp31b16
22249             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b16
22250             fqyb(i, k, j) = 0.0
22251             temp31b17 = dy*mu*fqylb(i, k, j)/dt
22252             min4b = 0.5*field_old(i, k, j-1)*temp31b17
22253             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min4*&
22254 &              temp31b17
22255             max3b = 0.5*field_old(i, k, j)*temp31b17
22256             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max3*&
22257 &              temp31b17
22258             mub0 = (0.5*(min4*field_old(i, k, j-1))+0.5*(max3*field_old(&
22259 &              i, k, j)))*dy*fqylb(i, k, j)/dt
22260             fqylb(i, k, j) = 0.0
22261             CALL POPCONTROL1B(branch)
22262             IF (branch .EQ. 0) THEN
22263               CALL POPREAL8(max3)
22264               y53b = max3b
22265             ELSE
22266               CALL POPREAL8(max3)
22267               y53b = 0.0
22268             END IF
22269             crb = y53b
22270             abs53b = -y53b
22271             CALL POPCONTROL1B(branch)
22272             IF (branch .EQ. 0) THEN
22273               crb = crb + abs53b
22274             ELSE
22275               crb = crb - abs53b
22276             END IF
22277             CALL POPCONTROL1B(branch)
22278             IF (branch .EQ. 0) THEN
22279               CALL POPREAL8(min4)
22280               y2b = min4b
22281             ELSE
22282               CALL POPREAL8(min4)
22283               y2b = 0.0
22284             END IF
22285             crb = crb + y2b
22286             abs2b = y2b
22287             CALL POPCONTROL1B(branch)
22288             IF (branch .EQ. 0) THEN
22289               crb = crb + abs2b
22290             ELSE
22291               crb = crb - abs2b
22292             END IF
22293             temp31b15 = dt*crb/(dy*mu)
22294             velb = temp31b15
22295             mub0 = mub0 - vel*temp31b15/mu
22296             CALL POPREAL8(vel)
22297             rvb(i, k, j) = rvb(i, k, j) + velb
22298             CALL POPREAL8(mu)
22299             mutb(i, j) = mutb(i, j) + 0.5*mub0
22300             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
22301             CALL POPREAL8(dy)
22302           END DO
22303         END DO
22304       ELSE
22305         DO k=ktf,kts,-1
22306           CALL POPINTEGER4(ad_from21)
22307           CALL POPINTEGER4(ad_to21)
22308           DO i=ad_to21,ad_from21,-1
22309             fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
22310             temp31b11 = vel*fqyb(i, k, j)
22311             temp31b12 = 37.*temp31b11/60.
22312             temp31b13 = -(2.*temp31b11/15.)
22313             velb = (37.*((field(i, k, j)+field(i, k, j-1))/60.)-2.*((&
22314 &              field(i, k, j+1)+field(i, k, j-2))/15.)+(field(i, k, j+2)+&
22315 &              field(i, k, j-3))/60.)*fqyb(i, k, j)
22316             fieldb(i, k, j) = fieldb(i, k, j) + temp31b12
22317             fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b12
22318             fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp31b13
22319             fieldb(i, k, j-2) = fieldb(i, k, j-2) + temp31b13
22320             fieldb(i, k, j+2) = fieldb(i, k, j+2) + temp31b11/60.
22321             fieldb(i, k, j-3) = fieldb(i, k, j-3) + temp31b11/60.
22322             fqyb(i, k, j) = 0.0
22323             temp31b14 = dy*mu*fqylb(i, k, j)/dt
22324             min3b = 0.5*field_old(i, k, j-1)*temp31b14
22325             field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min3*&
22326 &              temp31b14
22327             max2b = 0.5*field_old(i, k, j)*temp31b14
22328             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max2*&
22329 &              temp31b14
22330             mub0 = (0.5*(min3*field_old(i, k, j-1))+0.5*(max2*field_old(&
22331 &              i, k, j)))*dy*fqylb(i, k, j)/dt
22332             fqylb(i, k, j) = 0.0
22333             CALL POPCONTROL1B(branch)
22334             IF (branch .EQ. 0) THEN
22335               CALL POPREAL8(max2)
22336               y52b = max2b
22337             ELSE
22338               CALL POPREAL8(max2)
22339               y52b = 0.0
22340             END IF
22341             crb = y52b
22342             abs52b = -y52b
22343             CALL POPCONTROL1B(branch)
22344             IF (branch .EQ. 0) THEN
22345               crb = crb + abs52b
22346             ELSE
22347               crb = crb - abs52b
22348             END IF
22349             CALL POPCONTROL1B(branch)
22350             IF (branch .EQ. 0) THEN
22351               CALL POPREAL8(min3)
22352               y1b = min3b
22353             ELSE
22354               CALL POPREAL8(min3)
22355               y1b = 0.0
22356             END IF
22357             crb = crb + y1b
22358             abs1b = y1b
22359             CALL POPCONTROL1B(branch)
22360             IF (branch .EQ. 0) THEN
22361               crb = crb + abs1b
22362             ELSE
22363               crb = crb - abs1b
22364             END IF
22365             temp31b10 = dt*crb/(dy*mu)
22366             velb = velb + temp31b10
22367             mub0 = mub0 - vel*temp31b10/mu
22368             CALL POPREAL8(vel)
22369             rvb(i, k, j) = rvb(i, k, j) + velb
22370             CALL POPREAL8(mu)
22371             mutb(i, j) = mutb(i, j) + 0.5*mub0
22372             mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
22373             CALL POPREAL8(dy)
22374           END DO
22375         END DO
22376       END IF
22377     END DO
22378   END IF
22379 END SUBROUTINE A_ADVECT_SCALAR_PD
22380
22381 !        Generated by TAPENADE     (INRIA, Ecuador team)
22382 !  Tapenade 3.12 (r6213) - 13 Oct 2016 10:54
22383 !
22384 !  Differentiation of advect_scalar_wenopd in reverse (adjoint) mode:
22385 !   gradient     of useful results: rom field tendency ru rv mu_old
22386 !                field_old mut
22387 !   with respect to varying inputs: rom field tendency ru rv mu_old
22388 !                field_old mut
22389 !   RW status of diff variables: rom:incr field:incr tendency:in-out
22390 !                ru:incr rv:incr mu_old:incr field_old:incr mut:incr
22391 SUBROUTINE A_ADVECT_SCALAR_WENOPD(field, fieldb, field_old, field_oldb, &
22392 & tendency, tendencyb, ru, rub, rv, rvb, rom, romb, mut, mutb, mub, &
22393 & mu_old, mu_oldb, time_step, config_flags, msfux, msfuy, msfvx, msfvy, &
22394 & msftx, msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, &
22395 & kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
22396   IMPLICIT NONE
22397 ! Input data
22398   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
22399   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
22400 & jme, kms, kme, its, ite, jts, jte, kts, kte
22401   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
22402 & field_old, ru, rv, rom
22403   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub&
22404 & , rvb, romb
22405   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old
22406   REAL, DIMENSION(ims:ime, jms:jme) :: mutb, mu_oldb
22407   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
22408   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb
22409   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
22410 & msfvy, msftx, msfty
22411   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
22412   REAL, INTENT(IN) :: rdx, rdy, dt
22413   INTEGER, INTENT(IN) :: time_step
22414 ! Local data
22415   INTEGER :: i, j, k, itf, jtf, ktf
22416   INTEGER :: i_start, i_end, j_start, j_end
22417   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
22418   INTEGER :: jmin, jmax, jp, jm, imin, imax
22419   REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
22420   REAL :: ubb, vbb, mub0
22421 !  storage for high and low order fluxes
22422   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqx, fqy, fqz
22423   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxb, fqyb, fqzb
22424   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxl, fqyl, fqzl
22425   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxlb, fqylb, &
22426 & fqzlb
22427   INTEGER :: horz_order, vert_order
22428   LOGICAL :: degrade_xs, degrade_ys
22429   LOGICAL :: degrade_xe, degrade_ye
22430   INTEGER :: jp1, jp0, jtmp
22431   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low
22432   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outb, &
22433 & ph_lowb
22434   REAL :: scale
22435   REAL :: scaleb
22436   REAL, PARAMETER :: eps=1.e-20
22437   REAL :: dir, vv
22438   REAL :: ue, vs, vn, wb, wt
22439   REAL, PARAMETER :: f30=7./12., f31=1./12.
22440   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
22441   REAL :: qim2, qim1, qi, qip1, qip2
22442   REAL :: qim2b, qim1b, qib, qip1b, qip2b
22443   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
22444 & sumwk
22445   DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b&
22446 & , wi2b, sumwkb
22447   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
22448 &   3.d0/10.d0, eps1=1.0d-28
22449   INTEGER, PARAMETER :: pw=2
22450 ! definition of flux operators, 3rd, 4th, 5th or 6th order
22451   REAL :: flux3, flux4, flux5, flux6, flux_upwind
22452   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
22453   REAL :: velb, crb
22454 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
22455 !                                    +0.5*(1.-sign(1.,cr))*q_i
22456 !      flux_upwind(q_im1, q_i, cr ) = 0.
22457   REAL :: dx, dy, dz
22458   LOGICAL, PARAMETER :: pd_limit=.true.
22459   INTEGER :: min1
22460   INTEGER :: min2
22461   REAL :: min3
22462   REAL :: min3b
22463   REAL :: min4
22464   REAL :: min4b
22465   REAL :: min5
22466   REAL :: min5b
22467   REAL :: min6
22468   REAL :: min6b
22469   REAL :: min7
22470   REAL :: min7b
22471   INTEGER :: min8
22472   INTEGER :: min9
22473   REAL :: min10
22474   REAL :: min10b
22475   REAL :: min11
22476   REAL :: min11b
22477   REAL :: min12
22478   REAL :: min12b
22479   REAL :: min13
22480   REAL :: min13b
22481   REAL :: min14
22482   REAL :: min14b
22483   INTEGER :: min15
22484   INTEGER :: min16
22485   REAL :: min17
22486   REAL :: min17b
22487   REAL :: min18
22488   REAL :: min18b
22489   REAL :: min19
22490   REAL :: min19b
22491   REAL :: min20
22492   REAL :: min20b
22493   REAL :: min21
22494   REAL :: min21b
22495   INTEGER :: min22
22496   INTEGER :: min23
22497   REAL :: max1
22498   REAL :: max1b
22499   REAL :: abs0
22500   REAL :: abs0b
22501   REAL :: max2
22502   REAL :: max2b
22503   REAL :: abs1
22504   REAL :: abs1b
22505   REAL :: max3
22506   REAL :: max3b
22507   REAL :: abs2
22508   REAL :: abs2b
22509   REAL :: max4
22510   REAL :: max4b
22511   REAL :: abs3
22512   REAL :: abs3b
22513   REAL :: max5
22514   REAL :: max5b
22515   REAL :: abs4
22516   REAL :: abs4b
22517   REAL :: max6
22518   REAL :: max6b
22519   REAL :: abs5
22520   REAL :: abs5b
22521   REAL :: max7
22522   REAL :: max7b
22523   REAL :: abs6
22524   REAL :: abs6b
22525   REAL :: max8
22526   REAL :: max8b
22527   REAL :: abs7
22528   REAL :: abs7b
22529   REAL :: max9
22530   REAL :: max9b
22531   REAL :: abs8
22532   REAL :: abs8b
22533   REAL :: max10
22534   REAL :: max10b
22535   REAL :: abs9
22536   REAL :: abs9b
22537   REAL :: max11
22538   REAL :: max11b
22539   REAL :: abs10
22540   REAL :: abs10b
22541   REAL :: max12
22542   REAL :: max12b
22543   REAL :: abs11
22544   REAL :: abs11b
22545   REAL :: max13
22546   REAL :: max13b
22547   REAL :: abs12
22548   REAL :: abs12b
22549   REAL :: max14
22550   REAL :: max14b
22551   REAL :: abs13
22552   REAL :: abs13b
22553   REAL :: max15
22554   REAL :: max15b
22555   REAL :: abs14
22556   REAL :: abs14b
22557   REAL :: max16
22558   REAL :: max16b
22559   REAL :: min24
22560   REAL :: min24b
22561   REAL :: abs15
22562   REAL :: abs15b
22563   REAL :: abs16
22564   REAL :: abs16b
22565   REAL :: abs17
22566   REAL :: abs17b
22567   REAL :: abs18
22568   REAL :: abs18b
22569   REAL :: abs19
22570   REAL :: abs19b
22571   REAL :: abs20
22572   REAL :: abs20b
22573   REAL :: abs21
22574   REAL :: abs21b
22575   REAL :: abs22
22576   REAL :: abs22b
22577   REAL :: abs23
22578   REAL :: abs23b
22579   REAL :: abs24
22580   REAL :: abs24b
22581   REAL :: abs25
22582   REAL :: abs25b
22583   REAL :: abs26
22584   REAL :: abs26b
22585   REAL :: abs27
22586   REAL :: abs27b
22587   REAL :: abs28
22588   REAL :: abs28b
22589   REAL :: abs29
22590   REAL :: abs29b
22591   REAL :: max17
22592   REAL :: max17b
22593   REAL :: min25
22594   REAL :: min25b
22595   REAL :: min26
22596   REAL :: min26b
22597   REAL :: max18
22598   REAL :: max18b
22599   REAL :: tempb
22600   REAL :: y1b
22601   REAL :: y17b
22602   REAL :: tempb0
22603   DOUBLE PRECISION :: temp
22604   DOUBLE PRECISION :: temp0
22605   DOUBLE PRECISION :: temp1
22606   DOUBLE PRECISION :: tempb1
22607   DOUBLE PRECISION :: tempb2
22608   REAL :: tempb3
22609   REAL :: tempb4
22610   REAL :: tempb5
22611   REAL :: tempb6
22612   REAL :: tempb7
22613   REAL :: tempb8
22614   REAL :: tempb9
22615   REAL :: y2b
22616   REAL :: y18b
22617   REAL :: tempb10
22618   REAL :: tempb11
22619   REAL :: tempb12
22620   REAL :: y3b
22621   REAL :: y19b
22622   REAL :: temp2
22623   REAL :: temp3
22624   REAL :: temp4
22625   REAL :: temp5
22626   REAL :: tempb13
22627   REAL :: tempb14
22628   REAL :: tempb15
22629   REAL :: tempb16
22630   REAL :: tempb17
22631   REAL :: y4b
22632   REAL :: y20b
22633   REAL :: tempb18
22634   REAL :: tempb19
22635   REAL :: tempb20
22636   REAL :: y5b
22637   REAL :: y21b
22638   REAL :: temp6
22639   REAL :: temp7
22640   REAL :: temp8
22641   REAL :: temp9
22642   REAL :: tempb21
22643   REAL :: tempb22
22644   REAL :: tempb23
22645   REAL :: tempb24
22646   REAL :: tempb25
22647   REAL :: y6b
22648   REAL :: y22b
22649   REAL :: tempb26
22650   DOUBLE PRECISION :: temp10
22651   DOUBLE PRECISION :: temp11
22652   DOUBLE PRECISION :: temp12
22653   DOUBLE PRECISION :: tempb27
22654   DOUBLE PRECISION :: tempb28
22655   REAL :: tempb29
22656   REAL :: tempb30
22657   REAL :: tempb31
22658   REAL :: tempb32
22659   REAL :: tempb33
22660   REAL :: tempb34
22661   REAL :: y7b
22662   REAL :: y23b
22663   REAL :: tempb35
22664   REAL :: tempb36
22665   REAL :: tempb37
22666   REAL :: y8b
22667   REAL :: y24b
22668   REAL :: temp13
22669   REAL :: temp14
22670   REAL :: temp15
22671   REAL :: temp16
22672   REAL :: tempb38
22673   REAL :: tempb39
22674   REAL :: tempb40
22675   REAL :: tempb41
22676   REAL :: tempb42
22677   REAL :: y9b
22678   REAL :: y25b
22679   REAL :: tempb43
22680   REAL :: tempb44
22681   REAL :: tempb45
22682   REAL :: y10b
22683   REAL :: y26b
22684   REAL :: temp17
22685   REAL :: temp18
22686   REAL :: temp19
22687   REAL :: temp20
22688   REAL :: tempb46
22689   REAL :: tempb47
22690   REAL :: tempb48
22691   REAL :: tempb49
22692   REAL :: tempb50
22693   REAL :: tempb51
22694   REAL :: tempb52
22695   REAL :: tempb53
22696   REAL :: tempb54
22697   REAL :: tempb55
22698   REAL :: tempb56
22699   REAL :: tempb57
22700   REAL :: tempb58
22701   REAL :: tempb59
22702   REAL :: tempb60
22703   REAL :: y11b
22704   REAL :: y27b
22705   REAL :: tempb61
22706   DOUBLE PRECISION :: temp21
22707   DOUBLE PRECISION :: temp22
22708   DOUBLE PRECISION :: temp23
22709   DOUBLE PRECISION :: tempb62
22710   DOUBLE PRECISION :: tempb63
22711   REAL :: tempb64
22712   REAL :: tempb65
22713   REAL :: tempb66
22714   REAL :: tempb67
22715   REAL :: tempb68
22716   REAL :: tempb69
22717   REAL :: tempb70
22718   REAL :: y12b
22719   REAL :: y28b
22720   REAL :: tempb71
22721   REAL :: tempb72
22722   REAL :: tempb73
22723   REAL :: y13b
22724   REAL :: y29b
22725   REAL :: temp24
22726   REAL :: temp25
22727   REAL :: temp26
22728   REAL :: temp27
22729   REAL :: tempb74
22730   REAL :: tempb75
22731   REAL :: tempb76
22732   REAL :: tempb77
22733   REAL :: tempb78
22734   REAL :: y14b
22735   REAL :: y30b
22736   REAL :: temp28
22737   REAL :: temp29
22738   REAL :: temp30
22739   REAL :: temp31
22740   REAL :: tempb79
22741   REAL :: tempb80
22742   REAL :: tempb81
22743   REAL :: tempb82
22744   REAL :: tempb83
22745   REAL :: y15b
22746   REAL :: y31b
22747   REAL :: tempb84
22748   REAL :: tempb85
22749   REAL :: tempb86
22750   REAL :: tempb87
22751   REAL :: tempb88
22752   REAL :: tempb89
22753   REAL :: temp32
22754   REAL :: y16b
22755   REAL :: tempb90
22756   REAL :: tempb91
22757   REAL :: tempb92
22758   INTEGER :: branch
22759   INTEGER :: ad_from
22760   INTEGER :: ad_to
22761   INTEGER :: ad_from0
22762   INTEGER :: ad_to0
22763   INTEGER :: ad_from1
22764   INTEGER :: ad_to1
22765   INTEGER :: ad_from2
22766   INTEGER :: ad_to2
22767   INTEGER :: ad_from3
22768   INTEGER :: ad_to3
22769   INTEGER :: ad_from4
22770   INTEGER :: ad_to4
22771   INTEGER :: ad_from5
22772   INTEGER :: ad_to5
22773   INTEGER :: ad_from6
22774   INTEGER :: ad_to6
22775   INTEGER :: ad_from7
22776   INTEGER :: ad_to7
22777   INTEGER :: ad_from8
22778   INTEGER :: ad_to8
22779   INTEGER :: ad_from9
22780   INTEGER :: ad_to9
22781   INTEGER :: ad_from10
22782   INTEGER :: ad_to10
22783   INTEGER :: ad_from11
22784   INTEGER :: ad_to11
22785   INTEGER :: ad_from12
22786   INTEGER :: ad_to12
22787   INTEGER :: ad_from13
22788   INTEGER :: ad_to13
22789   INTEGER :: ad_from14
22790   INTEGER :: ad_to14
22791   INTEGER :: ad_from15
22792   INTEGER :: ad_to15
22793   INTEGER :: ad_from16
22794   INTEGER :: ad_to16
22795   INTEGER :: ad_from17
22796   INTEGER :: ad_to17
22797   INTEGER :: ad_from18
22798   INTEGER :: ad_to18
22799   INTEGER :: ad_from19
22800   INTEGER :: ad_to19
22801   INTEGER :: ad_from20
22802   INTEGER :: ad_to20
22803   INTEGER :: ad_from21
22804   INTEGER :: ad_to21
22805   INTEGER :: ad_from22
22806   INTEGER :: ad_to22
22807   INTEGER :: ad_from23
22808   INTEGER :: ad_to23
22809   INTEGER :: ad_from24
22810   INTEGER :: ad_to24
22811   INTEGER :: ad_from25
22812   INTEGER :: ad_to25
22813   INTEGER :: ad_from26
22814   INTEGER :: ad_to26
22815   REAL :: y29
22816   REAL :: y28
22817   REAL :: y27
22818   REAL :: y26
22819   REAL :: y25
22820   REAL :: y24
22821   REAL :: y23
22822   REAL :: y22
22823   REAL :: y21
22824   REAL :: y20
22825   REAL :: y19
22826   REAL :: y18
22827   REAL :: y17
22828   REAL :: y16
22829   REAL :: y15
22830   REAL :: y14
22831   REAL :: y13
22832   REAL :: y12
22833   REAL :: y11
22834   REAL :: y10
22835   REAL :: y31
22836   REAL :: y30
22837   REAL :: y9
22838   REAL :: y8
22839   REAL :: y7
22840   REAL :: y6
22841   REAL :: y5
22842   REAL :: y4
22843   REAL :: y3
22844   REAL :: y2
22845   REAL :: y1
22846 ! set order for the advection schemes
22847 !  write(6,*) ' in pd advection routine '
22848 ! Empty arrays just in case:
22849   IF (config_flags%polar) THEN
22850     fqx(:, :, :) = 0.
22851     fqy(:, :, :) = 0.
22852     fqz(:, :, :) = 0.
22853     fqxl(:, :, :) = 0.
22854     fqyl(:, :, :) = 0.
22855     fqzl(:, :, :) = 0.
22856   END IF
22857 !  determine boundary mods for flux operators
22858 !  We degrade the flux operators from 3rd/4th order
22859 !   to second order one gridpoint in from the boundaries for
22860 !   all boundary conditions except periodic and symmetry - these
22861 !   conditions have boundary zone data fill for correct application
22862 !   of the higher order flux stencils
22863   degrade_xs = .true.
22864   degrade_xe = .true.
22865   degrade_ys = .true.
22866   degrade_ye = .true.
22867 !  begin with horizontal flux divergence
22868 !  here is the choice of flux operators
22869 !  horizontal_order_test : IF( horz_order == 6 ) THEN
22870 !    ELSE IF( horz_order == 5 ) THEN
22871   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
22872 &     .GT. ids + 3) degrade_xs = .false.
22873   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
22874 &     .LT. ide - 4) degrade_xe = .false.
22875   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
22876 &     .GT. jds + 3) degrade_ys = .false.
22877   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
22878 &     .LT. jde - 4) degrade_ye = .false.
22879   IF (kte .GT. kde - 1) THEN
22880     ktf = kde - 1
22881   ELSE
22882     ktf = kte
22883   END IF
22884   i_start = its - 1
22885   IF (ite .GT. ide - 1) THEN
22886     min1 = ide - 1
22887   ELSE
22888     min1 = ite
22889   END IF
22890   i_end = min1 + 1
22891   j_start = jts - 1
22892   IF (jte .GT. jde - 1) THEN
22893     min2 = jde - 1
22894   ELSE
22895     min2 = jte
22896   END IF
22897   j_end = min2 + 1
22898   j_start_f = j_start
22899   j_end_f = j_end + 1
22900 !--  modify loop bounds if open or specified
22901 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
22902 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
22903   IF (degrade_xs) THEN
22904     IF (its - 1 .LT. ids) THEN
22905       CALL PUSHCONTROL1B(1)
22906       i_start = ids
22907     ELSE
22908       CALL PUSHCONTROL1B(1)
22909       i_start = its - 1
22910     END IF
22911   ELSE
22912     CALL PUSHCONTROL1B(0)
22913   END IF
22914   IF (degrade_xe) THEN
22915     IF (ite + 1 .GT. ide - 1) THEN
22916       CALL PUSHCONTROL1B(1)
22917       i_end = ide - 1
22918     ELSE
22919       CALL PUSHCONTROL1B(1)
22920       i_end = ite + 1
22921     END IF
22922   ELSE
22923     CALL PUSHCONTROL1B(0)
22924   END IF
22925   IF (degrade_ys) THEN
22926     IF (jts - 1 .LT. jds + 1) THEN
22927       CALL PUSHCONTROL1B(0)
22928       j_start = jds + 1
22929     ELSE
22930       CALL PUSHCONTROL1B(0)
22931       j_start = jts - 1
22932     END IF
22933     j_start_f = jds + 3
22934   ELSE
22935     CALL PUSHCONTROL1B(1)
22936   END IF
22937   IF (degrade_ye) THEN
22938     IF (jte + 1 .GT. jde - 2) THEN
22939       CALL PUSHCONTROL1B(1)
22940       j_end = jde - 2
22941     ELSE
22942       CALL PUSHCONTROL1B(1)
22943       j_end = jte + 1
22944     END IF
22945     j_end_f = jde - 3
22946   ELSE
22947     CALL PUSHCONTROL1B(0)
22948   END IF
22949   ad_from4 = j_start
22950 !  compute fluxes, 5th order
22951 j_loop_y_flux_5:DO j=ad_from4,j_end+1
22952     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
22953 ! use full stencil
22954       DO k=kts,ktf
22955         ad_from = i_start
22956         DO i=ad_from,i_end
22957 ! ADT eqn 48 d/dy
22958           CALL PUSHREAL8(dy)
22959           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
22960           CALL PUSHREAL8(mu)
22961           mu = 0.5*(mut(i, j)+mut(i, j-1))
22962           CALL PUSHREAL8(vel)
22963           vel = rv(i, k, j)
22964           cr = vel*dt/dy/mu
22965           IF (cr .GE. 0.) THEN
22966             abs0 = cr
22967             CALL PUSHCONTROL1B(0)
22968           ELSE
22969             abs0 = -cr
22970             CALL PUSHCONTROL1B(1)
22971           END IF
22972           y1 = cr + abs0
22973           IF (1.0 .GT. y1) THEN
22974             CALL PUSHREAL8(min3)
22975             min3 = y1
22976             CALL PUSHCONTROL1B(0)
22977           ELSE
22978             CALL PUSHREAL8(min3)
22979             min3 = 1.0
22980             CALL PUSHCONTROL1B(1)
22981           END IF
22982           IF (cr .GE. 0.) THEN
22983             abs15 = cr
22984             CALL PUSHCONTROL1B(0)
22985           ELSE
22986             abs15 = -cr
22987             CALL PUSHCONTROL1B(1)
22988           END IF
22989           y17 = cr - abs15
22990           IF (-1.0 .LT. y17) THEN
22991             CALL PUSHREAL8(max2)
22992             max2 = y17
22993             CALL PUSHCONTROL1B(0)
22994           ELSE
22995             CALL PUSHREAL8(max2)
22996             max2 = -1.0
22997             CALL PUSHCONTROL1B(1)
22998           END IF
22999           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+0.5*&
23000 &           max2*field_old(i, k, j))
23001           IF (vel*SIGN(1, time_step) .GE. 0.0) THEN
23002             CALL PUSHREAL8(qip2)
23003             qip2 = field(i, k, j+1)
23004             CALL PUSHREAL8(qip1)
23005             qip1 = field(i, k, j)
23006             CALL PUSHREAL8(qi)
23007             qi = field(i, k, j-1)
23008             CALL PUSHREAL8(qim1)
23009             qim1 = field(i, k, j-2)
23010             CALL PUSHREAL8(qim2)
23011             qim2 = field(i, k, j-3)
23012             CALL PUSHCONTROL1B(0)
23013           ELSE
23014             CALL PUSHREAL8(qip2)
23015             qip2 = field(i, k, j-2)
23016             CALL PUSHREAL8(qip1)
23017             qip1 = field(i, k, j-1)
23018             CALL PUSHREAL8(qi)
23019             qi = field(i, k, j)
23020             CALL PUSHREAL8(qim1)
23021             qim1 = field(i, k, j+1)
23022             CALL PUSHREAL8(qim2)
23023             qim2 = field(i, k, j+2)
23024             CALL PUSHCONTROL1B(1)
23025           END IF
23026           CALL PUSHREAL8(f0)
23027           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
23028           CALL PUSHREAL8(f1)
23029           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
23030           CALL PUSHREAL8(f2)
23031           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
23032           CALL PUSHREAL8(beta0)
23033           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
23034 &           qi)**2
23035           CALL PUSHREAL8(beta1)
23036           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
23037           CALL PUSHREAL8(beta2)
23038           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
23039 &           qi)**2
23040           wi0 = gi0/(eps1+beta0)**pw
23041           wi1 = gi1/(eps1+beta1)**pw
23042           wi2 = gi2/(eps1+beta2)**pw
23043           sumwk = wi0 + wi1 + wi2
23044           fqy(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
23045 !          fqy( i, k, j  ) = vel*flux5(                                  &
23046 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
23047 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
23048           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
23049         END DO
23050         CALL PUSHINTEGER4(i - 1)
23051         CALL PUSHINTEGER4(ad_from)
23052       END DO
23053       CALL PUSHCONTROL3B(5)
23054     ELSE IF (j .EQ. jds + 1) THEN
23055 ! 2nd order flux next to south boundary
23056       DO k=kts,ktf
23057         ad_from0 = i_start
23058         DO i=ad_from0,i_end
23059 ! ADT eqn 48 d/dy
23060           CALL PUSHREAL8(dy)
23061           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
23062           CALL PUSHREAL8(mu)
23063           mu = 0.5*(mut(i, j)+mut(i, j-1))
23064           CALL PUSHREAL8(vel)
23065           vel = rv(i, k, j)
23066           cr = vel*dt/dy/mu
23067           IF (cr .GE. 0.) THEN
23068             abs1 = cr
23069             CALL PUSHCONTROL1B(0)
23070           ELSE
23071             abs1 = -cr
23072             CALL PUSHCONTROL1B(1)
23073           END IF
23074           y2 = cr + abs1
23075           IF (1.0 .GT. y2) THEN
23076             CALL PUSHREAL8(min4)
23077             min4 = y2
23078             CALL PUSHCONTROL1B(0)
23079           ELSE
23080             CALL PUSHREAL8(min4)
23081             min4 = 1.0
23082             CALL PUSHCONTROL1B(1)
23083           END IF
23084           IF (cr .GE. 0.) THEN
23085             abs16 = cr
23086             CALL PUSHCONTROL1B(0)
23087           ELSE
23088             abs16 = -cr
23089             CALL PUSHCONTROL1B(1)
23090           END IF
23091           y18 = cr - abs16
23092           IF (-1.0 .LT. y18) THEN
23093             CALL PUSHREAL8(max3)
23094             max3 = y18
23095             CALL PUSHCONTROL1B(0)
23096           ELSE
23097             CALL PUSHREAL8(max3)
23098             max3 = -1.0
23099             CALL PUSHCONTROL1B(1)
23100           END IF
23101           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+0.5*&
23102 &           max3*field_old(i, k, j))
23103           fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
23104 &           ))
23105           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
23106         END DO
23107         CALL PUSHINTEGER4(i - 1)
23108         CALL PUSHINTEGER4(ad_from0)
23109       END DO
23110       CALL PUSHCONTROL3B(4)
23111     ELSE IF (j .EQ. jds + 2) THEN
23112 ! third of 4th order flux 2 in from south boundary
23113       DO k=kts,ktf
23114         ad_from1 = i_start
23115         DO i=ad_from1,i_end
23116 ! ADT eqn 48 d/dy
23117           CALL PUSHREAL8(dy)
23118           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
23119           CALL PUSHREAL8(mu)
23120           mu = 0.5*(mut(i, j)+mut(i, j-1))
23121           CALL PUSHREAL8(vel)
23122           vel = rv(i, k, j)
23123           cr = vel*dt/dy/mu
23124           IF (cr .GE. 0.) THEN
23125             abs2 = cr
23126             CALL PUSHCONTROL1B(0)
23127           ELSE
23128             abs2 = -cr
23129             CALL PUSHCONTROL1B(1)
23130           END IF
23131           y3 = cr + abs2
23132           IF (1.0 .GT. y3) THEN
23133             CALL PUSHREAL8(min5)
23134             min5 = y3
23135             CALL PUSHCONTROL1B(0)
23136           ELSE
23137             CALL PUSHREAL8(min5)
23138             min5 = 1.0
23139             CALL PUSHCONTROL1B(1)
23140           END IF
23141           IF (cr .GE. 0.) THEN
23142             abs17 = cr
23143             CALL PUSHCONTROL1B(0)
23144           ELSE
23145             abs17 = -cr
23146             CALL PUSHCONTROL1B(1)
23147           END IF
23148           y19 = cr - abs17
23149           IF (-1.0 .LT. y19) THEN
23150             CALL PUSHREAL8(max4)
23151             max4 = y19
23152             CALL PUSHCONTROL1B(0)
23153           ELSE
23154             CALL PUSHREAL8(max4)
23155             max4 = -1.0
23156             CALL PUSHCONTROL1B(1)
23157           END IF
23158           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+0.5*&
23159 &           max4*field_old(i, k, j))
23160           fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-&
23161 &           1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step&
23162 &           )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-&
23163 &           3.*(field(i, k, j)-field(i, k, j-1))))
23164           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
23165         END DO
23166         CALL PUSHINTEGER4(i - 1)
23167         CALL PUSHINTEGER4(ad_from1)
23168       END DO
23169       CALL PUSHCONTROL3B(3)
23170     ELSE IF (j .EQ. jde - 1) THEN
23171 ! 2nd order flux next to north boundary
23172       DO k=kts,ktf
23173         ad_from2 = i_start
23174         DO i=ad_from2,i_end
23175 ! ADT eqn 48 d/dy
23176           CALL PUSHREAL8(dy)
23177           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
23178           CALL PUSHREAL8(mu)
23179           mu = 0.5*(mut(i, j)+mut(i, j-1))
23180           CALL PUSHREAL8(vel)
23181           vel = rv(i, k, j)
23182           cr = vel*dt/dy/mu
23183           IF (cr .GE. 0.) THEN
23184             abs3 = cr
23185             CALL PUSHCONTROL1B(0)
23186           ELSE
23187             abs3 = -cr
23188             CALL PUSHCONTROL1B(1)
23189           END IF
23190           y4 = cr + abs3
23191           IF (1.0 .GT. y4) THEN
23192             CALL PUSHREAL8(min6)
23193             min6 = y4
23194             CALL PUSHCONTROL1B(0)
23195           ELSE
23196             CALL PUSHREAL8(min6)
23197             min6 = 1.0
23198             CALL PUSHCONTROL1B(1)
23199           END IF
23200           IF (cr .GE. 0.) THEN
23201             abs18 = cr
23202             CALL PUSHCONTROL1B(0)
23203           ELSE
23204             abs18 = -cr
23205             CALL PUSHCONTROL1B(1)
23206           END IF
23207           y20 = cr - abs18
23208           IF (-1.0 .LT. y20) THEN
23209             CALL PUSHREAL8(max5)
23210             max5 = y20
23211             CALL PUSHCONTROL1B(0)
23212           ELSE
23213             CALL PUSHREAL8(max5)
23214             max5 = -1.0
23215             CALL PUSHCONTROL1B(1)
23216           END IF
23217           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+0.5*&
23218 &           max5*field_old(i, k, j))
23219           fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
23220 &           ))
23221           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
23222         END DO
23223         CALL PUSHINTEGER4(i - 1)
23224         CALL PUSHINTEGER4(ad_from2)
23225       END DO
23226       CALL PUSHCONTROL3B(2)
23227     ELSE IF (j .EQ. jde - 2) THEN
23228 ! 3rd or 4th order flux 2 in from north boundary
23229       DO k=kts,ktf
23230         ad_from3 = i_start
23231         DO i=ad_from3,i_end
23232 ! ADT eqn 48 d/dy
23233           CALL PUSHREAL8(dy)
23234           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
23235           CALL PUSHREAL8(mu)
23236           mu = 0.5*(mut(i, j)+mut(i, j-1))
23237           CALL PUSHREAL8(vel)
23238           vel = rv(i, k, j)
23239           cr = vel*dt/dy/mu
23240           IF (cr .GE. 0.) THEN
23241             abs4 = cr
23242             CALL PUSHCONTROL1B(0)
23243           ELSE
23244             abs4 = -cr
23245             CALL PUSHCONTROL1B(1)
23246           END IF
23247           y5 = cr + abs4
23248           IF (1.0 .GT. y5) THEN
23249             CALL PUSHREAL8(min7)
23250             min7 = y5
23251             CALL PUSHCONTROL1B(0)
23252           ELSE
23253             CALL PUSHREAL8(min7)
23254             min7 = 1.0
23255             CALL PUSHCONTROL1B(1)
23256           END IF
23257           IF (cr .GE. 0.) THEN
23258             abs19 = cr
23259             CALL PUSHCONTROL1B(0)
23260           ELSE
23261             abs19 = -cr
23262             CALL PUSHCONTROL1B(1)
23263           END IF
23264           y21 = cr - abs19
23265           IF (-1.0 .LT. y21) THEN
23266             CALL PUSHREAL8(max6)
23267             max6 = y21
23268             CALL PUSHCONTROL1B(0)
23269           ELSE
23270             CALL PUSHREAL8(max6)
23271             max6 = -1.0
23272             CALL PUSHCONTROL1B(1)
23273           END IF
23274           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+0.5*&
23275 &           max6*field_old(i, k, j))
23276           fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-&
23277 &           1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step&
23278 &           )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-&
23279 &           3.*(field(i, k, j)-field(i, k, j-1))))
23280           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
23281         END DO
23282         CALL PUSHINTEGER4(i - 1)
23283         CALL PUSHINTEGER4(ad_from3)
23284       END DO
23285       CALL PUSHCONTROL3B(1)
23286     ELSE
23287       CALL PUSHCONTROL3B(0)
23288     END IF
23289   END DO j_loop_y_flux_5
23290   CALL PUSHINTEGER4(j - 1)
23291   CALL PUSHINTEGER4(ad_from4)
23292 !  next, x flux
23293 !--  these bounds are for periodic and sym conditions
23294   i_start = its - 1
23295   IF (ite .GT. ide - 1) THEN
23296     min8 = ide - 1
23297   ELSE
23298     min8 = ite
23299   END IF
23300   i_end = min8 + 1
23301   i_start_f = i_start
23302   i_end_f = i_end + 1
23303   j_start = jts - 1
23304   IF (jte .GT. jde - 1) THEN
23305     min9 = jde - 1
23306   ELSE
23307     min9 = jte
23308   END IF
23309   j_end = min9 + 1
23310 !--  modify loop bounds for open and specified b.c
23311 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
23312 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
23313   IF (degrade_ys) THEN
23314     IF (jts - 1 .LT. jds) THEN
23315       CALL PUSHCONTROL1B(1)
23316       j_start = jds
23317     ELSE
23318       CALL PUSHCONTROL1B(1)
23319       j_start = jts - 1
23320     END IF
23321   ELSE
23322     CALL PUSHCONTROL1B(0)
23323   END IF
23324   IF (degrade_ye) THEN
23325     IF (jte + 1 .GT. jde - 1) THEN
23326       CALL PUSHCONTROL1B(1)
23327       j_end = jde - 1
23328     ELSE
23329       CALL PUSHCONTROL1B(1)
23330       j_end = jte + 1
23331     END IF
23332   ELSE
23333     CALL PUSHCONTROL1B(0)
23334   END IF
23335   IF (degrade_xs) THEN
23336     IF (ids + 1 .LT. its - 1) THEN
23337       CALL PUSHCONTROL1B(0)
23338       i_start = its - 1
23339     ELSE
23340       CALL PUSHCONTROL1B(0)
23341       i_start = ids + 1
23342     END IF
23343     i_start_f = ids + 3
23344   ELSE
23345     CALL PUSHCONTROL1B(1)
23346   END IF
23347   IF (degrade_xe) THEN
23348     IF (ide - 2 .GT. ite + 1) THEN
23349       CALL PUSHCONTROL1B(1)
23350       i_end = ite + 1
23351     ELSE
23352       CALL PUSHCONTROL1B(1)
23353       i_end = ide - 2
23354     END IF
23355     i_end_f = ide - 3
23356   ELSE
23357     CALL PUSHCONTROL1B(0)
23358   END IF
23359   ad_from6 = j_start
23360 !  compute fluxes
23361   DO j=ad_from6,j_end
23362 !  5th order flux
23363     DO k=kts,ktf
23364       DO i=i_start_f,i_end_f
23365 ! ADT eqn 48 d/dx
23366         CALL PUSHREAL8(dx)
23367         dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
23368         CALL PUSHREAL8(mu)
23369         mu = 0.5*(mut(i, j)+mut(i-1, j))
23370         CALL PUSHREAL8(vel)
23371         vel = ru(i, k, j)
23372         cr = vel*dt/dx/mu
23373         IF (cr .GE. 0.) THEN
23374           abs5 = cr
23375           CALL PUSHCONTROL1B(0)
23376         ELSE
23377           abs5 = -cr
23378           CALL PUSHCONTROL1B(1)
23379         END IF
23380         y6 = cr + abs5
23381         IF (1.0 .GT. y6) THEN
23382           CALL PUSHREAL8(min10)
23383           min10 = y6
23384           CALL PUSHCONTROL1B(0)
23385         ELSE
23386           CALL PUSHREAL8(min10)
23387           min10 = 1.0
23388           CALL PUSHCONTROL1B(1)
23389         END IF
23390         IF (cr .GE. 0.) THEN
23391           abs20 = cr
23392           CALL PUSHCONTROL1B(0)
23393         ELSE
23394           abs20 = -cr
23395           CALL PUSHCONTROL1B(1)
23396         END IF
23397         y22 = cr - abs20
23398         IF (-1.0 .LT. y22) THEN
23399           CALL PUSHREAL8(max7)
23400           max7 = y22
23401           CALL PUSHCONTROL1B(0)
23402         ELSE
23403           CALL PUSHREAL8(max7)
23404           max7 = -1.0
23405           CALL PUSHCONTROL1B(1)
23406         END IF
23407         fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5*&
23408 &         max7*field_old(i, k, j))
23409         IF (vel*SIGN(1, time_step) .GE. 0.0) THEN
23410           CALL PUSHREAL8(qip2)
23411           qip2 = field(i+1, k, j)
23412           CALL PUSHREAL8(qip1)
23413           qip1 = field(i, k, j)
23414           CALL PUSHREAL8(qi)
23415           qi = field(i-1, k, j)
23416           CALL PUSHREAL8(qim1)
23417           qim1 = field(i-2, k, j)
23418           CALL PUSHREAL8(qim2)
23419           qim2 = field(i-3, k, j)
23420           CALL PUSHCONTROL1B(0)
23421         ELSE
23422           CALL PUSHREAL8(qip2)
23423           qip2 = field(i-2, k, j)
23424           CALL PUSHREAL8(qip1)
23425           qip1 = field(i-1, k, j)
23426           CALL PUSHREAL8(qi)
23427           qi = field(i, k, j)
23428           CALL PUSHREAL8(qim1)
23429           qim1 = field(i+1, k, j)
23430           CALL PUSHREAL8(qim2)
23431           qim2 = field(i+2, k, j)
23432           CALL PUSHCONTROL1B(1)
23433         END IF
23434         CALL PUSHREAL8(f0)
23435         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
23436         CALL PUSHREAL8(f1)
23437         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
23438         CALL PUSHREAL8(f2)
23439         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
23440         CALL PUSHREAL8(beta0)
23441         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
23442 &         )**2
23443         CALL PUSHREAL8(beta1)
23444         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
23445         CALL PUSHREAL8(beta2)
23446         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
23447 &         )**2
23448         wi0 = gi0/(eps1+beta0)**pw
23449         wi1 = gi1/(eps1+beta1)**pw
23450         wi2 = gi2/(eps1+beta2)**pw
23451         sumwk = wi0 + wi1 + wi2
23452         fqx(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
23453 !          fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
23454 !                                         field(i-1,k,j), field(i  ,k,j),  &
23455 !                                         field(i+1,k,j), field(i+2,k,j),  &
23456 !                                         vel                             )
23457         fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
23458       END DO
23459     END DO
23460 !  lower order fluxes close to boundaries (if not periodic or symmetric)
23461     IF (degrade_xs) THEN
23462       ad_from5 = i_start
23463       DO i=ad_from5,i_start_f-1
23464         IF (i .EQ. ids + 1) THEN
23465 ! second order
23466           DO k=kts,ktf
23467 ! ADT eqn 48 d/dx
23468             CALL PUSHREAL8(dx)
23469             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
23470             CALL PUSHREAL8(mu)
23471             mu = 0.5*(mut(i, j)+mut(i-1, j))
23472             CALL PUSHREAL8(vel)
23473             vel = ru(i, k, j)/mu
23474             cr = vel*dt/dx
23475             IF (cr .GE. 0.) THEN
23476               abs6 = cr
23477               CALL PUSHCONTROL1B(0)
23478             ELSE
23479               abs6 = -cr
23480               CALL PUSHCONTROL1B(1)
23481             END IF
23482             y7 = cr + abs6
23483             IF (1.0 .GT. y7) THEN
23484               CALL PUSHREAL8(min11)
23485               min11 = y7
23486               CALL PUSHCONTROL1B(0)
23487             ELSE
23488               CALL PUSHREAL8(min11)
23489               min11 = 1.0
23490               CALL PUSHCONTROL1B(1)
23491             END IF
23492             IF (cr .GE. 0.) THEN
23493               abs21 = cr
23494               CALL PUSHCONTROL1B(0)
23495             ELSE
23496               abs21 = -cr
23497               CALL PUSHCONTROL1B(1)
23498             END IF
23499             y23 = cr - abs21
23500             IF (-1.0 .LT. y23) THEN
23501               CALL PUSHREAL8(max8)
23502               max8 = y23
23503               CALL PUSHCONTROL1B(0)
23504             ELSE
23505               CALL PUSHREAL8(max8)
23506               max8 = -1.0
23507               CALL PUSHCONTROL1B(1)
23508             END IF
23509             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)+&
23510 &             0.5*max8*field_old(i, k, j))
23511             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
23512 &             , j))
23513             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
23514           END DO
23515           CALL PUSHCONTROL1B(0)
23516         ELSE
23517           CALL PUSHCONTROL1B(1)
23518         END IF
23519         IF (i .EQ. ids + 2) THEN
23520 ! third order
23521           DO k=kts,ktf
23522 ! ADT eqn 48 d/dx
23523             CALL PUSHREAL8(dx)
23524             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
23525             CALL PUSHREAL8(mu)
23526             mu = 0.5*(mut(i, j)+mut(i-1, j))
23527             CALL PUSHREAL8(vel)
23528             vel = ru(i, k, j)
23529             cr = vel*dt/dx/mu
23530             IF (cr .GE. 0.) THEN
23531               abs7 = cr
23532               CALL PUSHCONTROL1B(0)
23533             ELSE
23534               abs7 = -cr
23535               CALL PUSHCONTROL1B(1)
23536             END IF
23537             y8 = cr + abs7
23538             IF (1.0 .GT. y8) THEN
23539               CALL PUSHREAL8(min12)
23540               min12 = y8
23541               CALL PUSHCONTROL1B(0)
23542             ELSE
23543               CALL PUSHREAL8(min12)
23544               min12 = 1.0
23545               CALL PUSHCONTROL1B(1)
23546             END IF
23547             IF (cr .GE. 0.) THEN
23548               abs22 = cr
23549               CALL PUSHCONTROL1B(0)
23550             ELSE
23551               abs22 = -cr
23552               CALL PUSHCONTROL1B(1)
23553             END IF
23554             y24 = cr - abs22
23555             IF (-1.0 .LT. y24) THEN
23556               CALL PUSHREAL8(max9)
23557               max9 = y24
23558               CALL PUSHCONTROL1B(0)
23559             ELSE
23560               CALL PUSHREAL8(max9)
23561               max9 = -1.0
23562               CALL PUSHCONTROL1B(1)
23563             END IF
23564             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)+&
23565 &             0.5*max9*field_old(i, k, j))
23566             fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))&
23567 &             -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
23568 &             time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
23569 &             i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
23570             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
23571           END DO
23572           CALL PUSHCONTROL1B(1)
23573         ELSE
23574           CALL PUSHCONTROL1B(0)
23575         END IF
23576       END DO
23577       CALL PUSHINTEGER4(ad_from5)
23578       CALL PUSHCONTROL1B(0)
23579     ELSE
23580       CALL PUSHCONTROL1B(1)
23581     END IF
23582     IF (degrade_xe) THEN
23583       DO i=i_end_f+1,i_end+1
23584         IF (i .EQ. ide - 1) THEN
23585 ! second order flux next to the boundary
23586           DO k=kts,ktf
23587 ! ADT eqn 48 d/dx
23588             CALL PUSHREAL8(dx)
23589             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
23590             CALL PUSHREAL8(mu)
23591             mu = 0.5*(mut(i, j)+mut(i-1, j))
23592             CALL PUSHREAL8(vel)
23593             vel = ru(i, k, j)
23594             cr = vel*dt/dx/mu
23595             IF (cr .GE. 0.) THEN
23596               abs8 = cr
23597               CALL PUSHCONTROL1B(0)
23598             ELSE
23599               abs8 = -cr
23600               CALL PUSHCONTROL1B(1)
23601             END IF
23602             y9 = cr + abs8
23603             IF (1.0 .GT. y9) THEN
23604               CALL PUSHREAL8(min13)
23605               min13 = y9
23606               CALL PUSHCONTROL1B(0)
23607             ELSE
23608               CALL PUSHREAL8(min13)
23609               min13 = 1.0
23610               CALL PUSHCONTROL1B(1)
23611             END IF
23612             IF (cr .GE. 0.) THEN
23613               abs23 = cr
23614               CALL PUSHCONTROL1B(0)
23615             ELSE
23616               abs23 = -cr
23617               CALL PUSHCONTROL1B(1)
23618             END IF
23619             y25 = cr - abs23
23620             IF (-1.0 .LT. y25) THEN
23621               CALL PUSHREAL8(max10)
23622               max10 = y25
23623               CALL PUSHCONTROL1B(0)
23624             ELSE
23625               CALL PUSHREAL8(max10)
23626               max10 = -1.0
23627               CALL PUSHCONTROL1B(1)
23628             END IF
23629             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)+&
23630 &             0.5*max10*field_old(i, k, j))
23631             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
23632 &             , j))
23633             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
23634           END DO
23635           CALL PUSHCONTROL1B(0)
23636         ELSE
23637           CALL PUSHCONTROL1B(1)
23638         END IF
23639         IF (i .EQ. ide - 2) THEN
23640 ! third order flux one in from the boundary
23641           DO k=kts,ktf
23642 ! ADT eqn 48 d/dx
23643             CALL PUSHREAL8(dx)
23644             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
23645             CALL PUSHREAL8(mu)
23646             mu = 0.5*(mut(i, j)+mut(i-1, j))
23647             CALL PUSHREAL8(vel)
23648             vel = ru(i, k, j)
23649             cr = vel*dt/dx/mu
23650             IF (cr .GE. 0.) THEN
23651               abs9 = cr
23652               CALL PUSHCONTROL1B(0)
23653             ELSE
23654               abs9 = -cr
23655               CALL PUSHCONTROL1B(1)
23656             END IF
23657             y10 = cr + abs9
23658             IF (1.0 .GT. y10) THEN
23659               CALL PUSHREAL8(min14)
23660               min14 = y10
23661               CALL PUSHCONTROL1B(0)
23662             ELSE
23663               CALL PUSHREAL8(min14)
23664               min14 = 1.0
23665               CALL PUSHCONTROL1B(1)
23666             END IF
23667             IF (cr .GE. 0.) THEN
23668               abs24 = cr
23669               CALL PUSHCONTROL1B(0)
23670             ELSE
23671               abs24 = -cr
23672               CALL PUSHCONTROL1B(1)
23673             END IF
23674             y26 = cr - abs24
23675             IF (-1.0 .LT. y26) THEN
23676               CALL PUSHREAL8(max11)
23677               max11 = y26
23678               CALL PUSHCONTROL1B(0)
23679             ELSE
23680               CALL PUSHREAL8(max11)
23681               max11 = -1.0
23682               CALL PUSHCONTROL1B(1)
23683             END IF
23684             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)+&
23685 &             0.5*max11*field_old(i, k, j))
23686             fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))&
23687 &             -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
23688 &             time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
23689 &             i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
23690             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
23691           END DO
23692           CALL PUSHCONTROL1B(1)
23693         ELSE
23694           CALL PUSHCONTROL1B(0)
23695         END IF
23696       END DO
23697       CALL PUSHINTEGER4(i - 1)
23698       CALL PUSHCONTROL1B(1)
23699     ELSE
23700       CALL PUSHCONTROL1B(0)
23701     END IF
23702   END DO
23703   CALL PUSHINTEGER4(j - 1)
23704   CALL PUSHINTEGER4(ad_from6)
23705 ! enddo for outer J loop
23706 !--- end of 5th order horizontal flux calculation
23707 !   ELSE
23708 !      WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
23709 !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
23710 !   ENDIF horizontal_order_test
23711 !  pick up the rest of the horizontal radiation boundary conditions.
23712 !  (these are the computations that don't require 'cb'.
23713 !  first, set to index ranges
23714   i_start = its
23715   IF (ite .GT. ide - 1) THEN
23716     i_end = ide - 1
23717   ELSE
23718     i_end = ite
23719   END IF
23720   j_start = jts
23721   IF (jte .GT. jde - 1) THEN
23722     j_end = jde - 1
23723   ELSE
23724     j_end = jte
23725   END IF
23726 !  compute x (u) conditions for v, w, or scalar
23727   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
23728     ad_from7 = j_start
23729     DO j=ad_from7,j_end
23730       DO k=kts,ktf
23731         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
23732           CALL PUSHREAL8(ub)
23733           ub = 0.
23734           CALL PUSHCONTROL1B(0)
23735         ELSE
23736           CALL PUSHREAL8(ub)
23737           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
23738           CALL PUSHCONTROL1B(1)
23739         END IF
23740       END DO
23741     END DO
23742     CALL PUSHINTEGER4(j - 1)
23743     CALL PUSHINTEGER4(ad_from7)
23744     CALL PUSHCONTROL1B(0)
23745   ELSE
23746     CALL PUSHCONTROL1B(1)
23747   END IF
23748   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
23749     ad_from8 = j_start
23750     DO j=ad_from8,j_end
23751       DO k=kts,ktf
23752         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
23753           CALL PUSHREAL8(ub)
23754           ub = 0.
23755           CALL PUSHCONTROL1B(0)
23756         ELSE
23757           CALL PUSHREAL8(ub)
23758           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
23759           CALL PUSHCONTROL1B(1)
23760         END IF
23761       END DO
23762     END DO
23763     CALL PUSHINTEGER4(j - 1)
23764     CALL PUSHINTEGER4(ad_from8)
23765     CALL PUSHCONTROL1B(0)
23766   ELSE
23767     CALL PUSHCONTROL1B(1)
23768   END IF
23769   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
23770     ad_from9 = i_start
23771     DO i=ad_from9,i_end
23772       DO k=kts,ktf
23773         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
23774           CALL PUSHREAL8(vb)
23775           vb = 0.
23776           CALL PUSHCONTROL1B(0)
23777         ELSE
23778           CALL PUSHREAL8(vb)
23779           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
23780           CALL PUSHCONTROL1B(1)
23781         END IF
23782       END DO
23783     END DO
23784     CALL PUSHINTEGER4(i - 1)
23785     CALL PUSHINTEGER4(ad_from9)
23786     CALL PUSHCONTROL1B(0)
23787   ELSE
23788     CALL PUSHCONTROL1B(1)
23789   END IF
23790   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
23791     ad_from10 = i_start
23792     DO i=ad_from10,i_end
23793       DO k=kts,ktf
23794         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
23795           CALL PUSHREAL8(vb)
23796           vb = 0.
23797           CALL PUSHCONTROL1B(0)
23798         ELSE
23799           CALL PUSHREAL8(vb)
23800           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
23801           CALL PUSHCONTROL1B(1)
23802         END IF
23803       END DO
23804     END DO
23805     CALL PUSHINTEGER4(i - 1)
23806     CALL PUSHINTEGER4(ad_from10)
23807     CALL PUSHCONTROL1B(0)
23808   ELSE
23809     CALL PUSHCONTROL1B(1)
23810   END IF
23811   IF (config_flags%polar .AND. jts .EQ. jds) THEN
23812     ad_from11 = i_start
23813 ! Assuming rv(i,k,jds) = 0.
23814     DO i=ad_from11,i_end
23815       DO k=kts,ktf
23816         IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN
23817           CALL PUSHREAL8(vb)
23818           vb = 0.
23819           CALL PUSHCONTROL1B(0)
23820         ELSE
23821           CALL PUSHREAL8(vb)
23822           vb = 0.5*rv(i, k, jts+1)
23823           CALL PUSHCONTROL1B(1)
23824         END IF
23825       END DO
23826     END DO
23827     CALL PUSHINTEGER4(i - 1)
23828     CALL PUSHINTEGER4(ad_from11)
23829     CALL PUSHCONTROL1B(0)
23830   ELSE
23831     CALL PUSHCONTROL1B(1)
23832   END IF
23833   IF (config_flags%polar .AND. jte .EQ. jde) THEN
23834     ad_from12 = i_start
23835 ! Assuming rv(i,k,jde) = 0.
23836     DO i=ad_from12,i_end
23837       DO k=kts,ktf
23838         IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN
23839           CALL PUSHREAL8(vb)
23840           vb = 0.
23841           CALL PUSHCONTROL1B(0)
23842         ELSE
23843           CALL PUSHREAL8(vb)
23844           vb = 0.5*rv(i, k, jte-1)
23845           CALL PUSHCONTROL1B(1)
23846         END IF
23847       END DO
23848     END DO
23849     CALL PUSHINTEGER4(i - 1)
23850     CALL PUSHINTEGER4(ad_from12)
23851     CALL PUSHCONTROL1B(1)
23852   ELSE
23853     CALL PUSHCONTROL1B(0)
23854   END IF
23855 !-------------------- vertical advection
23856 !-- loop bounds for periodic or sym conditions
23857   i_start = its - 1
23858   IF (ite .GT. ide - 1) THEN
23859     min15 = ide - 1
23860   ELSE
23861     min15 = ite
23862   END IF
23863   CALL PUSHINTEGER4(i_end)
23864   i_end = min15 + 1
23865   j_start = jts - 1
23866   IF (jte .GT. jde - 1) THEN
23867     min16 = jde - 1
23868   ELSE
23869     min16 = jte
23870   END IF
23871   CALL PUSHINTEGER4(j_end)
23872   j_end = min16 + 1
23873 !-- loop bounds for open or specified conditions
23874   IF (degrade_xs) THEN
23875     IF (its - 1 .LT. ids) THEN
23876       CALL PUSHCONTROL1B(1)
23877       i_start = ids
23878     ELSE
23879       CALL PUSHCONTROL1B(1)
23880       i_start = its - 1
23881     END IF
23882   ELSE
23883     CALL PUSHCONTROL1B(0)
23884   END IF
23885   IF (degrade_xe) THEN
23886     IF (ite + 1 .GT. ide - 1) THEN
23887       CALL PUSHCONTROL1B(1)
23888       i_end = ide - 1
23889     ELSE
23890       CALL PUSHCONTROL1B(1)
23891       i_end = ite + 1
23892     END IF
23893   ELSE
23894     CALL PUSHCONTROL1B(0)
23895   END IF
23896   IF (degrade_ys) THEN
23897     IF (jts - 1 .LT. jds) THEN
23898       CALL PUSHCONTROL1B(1)
23899       j_start = jds
23900     ELSE
23901       CALL PUSHCONTROL1B(1)
23902       j_start = jts - 1
23903     END IF
23904   ELSE
23905     CALL PUSHCONTROL1B(0)
23906   END IF
23907   IF (degrade_ye) THEN
23908     IF (jte + 1 .GT. jde - 1) THEN
23909       CALL PUSHCONTROL1B(1)
23910       j_end = jde - 1
23911     ELSE
23912       CALL PUSHCONTROL1B(1)
23913       j_end = jte + 1
23914     END IF
23915   ELSE
23916     CALL PUSHCONTROL1B(0)
23917   END IF
23918   ad_from16 = j_start
23919 !    vert_order_test : IF (vert_order == 6) THEN
23920 !    ELSE IF (vert_order == 5) THEN
23921   DO j=ad_from16,j_end
23922     ad_from13 = i_start
23923     DO i=ad_from13,i_end
23924       fqz(i, 1, j) = 0.
23925       fqzl(i, 1, j) = 0.
23926       fqz(i, kde, j) = 0.
23927       fqzl(i, kde, j) = 0.
23928     END DO
23929     CALL PUSHINTEGER4(i - 1)
23930     CALL PUSHINTEGER4(ad_from13)
23931     CALL PUSHINTEGER4(k)
23932     DO k=kts+3,ktf-2
23933       ad_from14 = i_start
23934       DO i=ad_from14,i_end
23935         CALL PUSHREAL8(dz)
23936         dz = 2./(rdzw(k)+rdzw(k-1))
23937         CALL PUSHREAL8(mu)
23938         mu = 0.5*(mut(i, j)+mut(i, j))
23939         CALL PUSHREAL8(vel)
23940         vel = rom(i, k, j)
23941         cr = vel*dt/dz/mu
23942         IF (cr .GE. 0.) THEN
23943           abs10 = cr
23944           CALL PUSHCONTROL1B(0)
23945         ELSE
23946           abs10 = -cr
23947           CALL PUSHCONTROL1B(1)
23948         END IF
23949         y11 = cr + abs10
23950         IF (1.0 .GT. y11) THEN
23951           CALL PUSHREAL8(min17)
23952           min17 = y11
23953           CALL PUSHCONTROL1B(0)
23954         ELSE
23955           CALL PUSHREAL8(min17)
23956           min17 = 1.0
23957           CALL PUSHCONTROL1B(1)
23958         END IF
23959         IF (cr .GE. 0.) THEN
23960           abs25 = cr
23961           CALL PUSHCONTROL1B(0)
23962         ELSE
23963           abs25 = -cr
23964           CALL PUSHCONTROL1B(1)
23965         END IF
23966         y27 = cr - abs25
23967         IF (-1.0 .LT. y27) THEN
23968           CALL PUSHREAL8(max12)
23969           max12 = y27
23970           CALL PUSHCONTROL1B(0)
23971         ELSE
23972           CALL PUSHREAL8(max12)
23973           max12 = -1.0
23974           CALL PUSHCONTROL1B(1)
23975         END IF
23976         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min17*field_old(i, k-1, j)+0.5*&
23977 &         max12*field_old(i, k, j))
23978         IF (-(vel*SIGN(1, time_step)) .GE. 0.0) THEN
23979           CALL PUSHREAL8(qip2)
23980           qip2 = field(i, k+1, j)
23981           CALL PUSHREAL8(qip1)
23982           qip1 = field(i, k, j)
23983           CALL PUSHREAL8(qi)
23984           qi = field(i, k-1, j)
23985           CALL PUSHREAL8(qim1)
23986           qim1 = field(i, k-2, j)
23987           CALL PUSHREAL8(qim2)
23988           qim2 = field(i, k-3, j)
23989           CALL PUSHCONTROL1B(0)
23990         ELSE
23991           CALL PUSHREAL8(qip2)
23992           qip2 = field(i, k-2, j)
23993           CALL PUSHREAL8(qip1)
23994           qip1 = field(i, k-1, j)
23995           CALL PUSHREAL8(qi)
23996           qi = field(i, k, j)
23997           CALL PUSHREAL8(qim1)
23998           qim1 = field(i, k+1, j)
23999           CALL PUSHREAL8(qim2)
24000           qim2 = field(i, k+2, j)
24001           CALL PUSHCONTROL1B(1)
24002         END IF
24003         CALL PUSHREAL8(f0)
24004         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
24005         CALL PUSHREAL8(f1)
24006         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
24007         CALL PUSHREAL8(f2)
24008         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
24009         CALL PUSHREAL8(beta0)
24010         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
24011 &         )**2
24012         CALL PUSHREAL8(beta1)
24013         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
24014         CALL PUSHREAL8(beta2)
24015         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
24016 &         )**2
24017         wi0 = gi0/(eps1+beta0)**pw
24018         wi1 = gi1/(eps1+beta1)**pw
24019         wi2 = gi2/(eps1+beta2)**pw
24020         sumwk = wi0 + wi1 + wi2
24021         fqz(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
24022 !           fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
24023 !                                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
24024         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
24025       END DO
24026       CALL PUSHINTEGER4(i - 1)
24027       CALL PUSHINTEGER4(ad_from14)
24028     END DO
24029     ad_from15 = i_start
24030     DO i=ad_from15,i_end
24031       CALL PUSHINTEGER4(k)
24032       k = kts + 1
24033       CALL PUSHREAL8(dz)
24034       dz = 2./(rdzw(k)+rdzw(k-1))
24035       CALL PUSHREAL8(mu)
24036       mu = 0.5*(mut(i, j)+mut(i, j))
24037       CALL PUSHREAL8(vel)
24038       vel = rom(i, k, j)
24039       cr = vel*dt/dz/mu
24040       IF (cr .GE. 0.) THEN
24041         abs11 = cr
24042         CALL PUSHCONTROL1B(0)
24043       ELSE
24044         abs11 = -cr
24045         CALL PUSHCONTROL1B(1)
24046       END IF
24047       y12 = cr + abs11
24048       IF (1.0 .GT. y12) THEN
24049         CALL PUSHREAL8(min18)
24050         min18 = y12
24051         CALL PUSHCONTROL1B(0)
24052       ELSE
24053         CALL PUSHREAL8(min18)
24054         min18 = 1.0
24055         CALL PUSHCONTROL1B(1)
24056       END IF
24057       IF (cr .GE. 0.) THEN
24058         abs26 = cr
24059         CALL PUSHCONTROL1B(0)
24060       ELSE
24061         abs26 = -cr
24062         CALL PUSHCONTROL1B(1)
24063       END IF
24064       y28 = cr - abs26
24065       IF (-1.0 .LT. y28) THEN
24066         CALL PUSHREAL8(max13)
24067         max13 = y28
24068         CALL PUSHCONTROL1B(0)
24069       ELSE
24070         CALL PUSHREAL8(max13)
24071         max13 = -1.0
24072         CALL PUSHCONTROL1B(1)
24073       END IF
24074       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min18*field_old(i, k-1, j)+0.5*&
24075 &       max13*field_old(i, k, j))
24076       fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
24077 &       , k-1, j))
24078       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
24079       k = kts + 2
24080       CALL PUSHREAL8(dz)
24081       dz = 2./(rdzw(k)+rdzw(k-1))
24082       mu = 0.5*(mut(i, j)+mut(i, j))
24083       CALL PUSHREAL8(vel)
24084       vel = rom(i, k, j)
24085       cr = vel*dt/dz/mu
24086       IF (cr .GE. 0.) THEN
24087         abs12 = cr
24088         CALL PUSHCONTROL1B(0)
24089       ELSE
24090         abs12 = -cr
24091         CALL PUSHCONTROL1B(1)
24092       END IF
24093       y13 = cr + abs12
24094       IF (1.0 .GT. y13) THEN
24095         CALL PUSHREAL8(min19)
24096         min19 = y13
24097         CALL PUSHCONTROL1B(0)
24098       ELSE
24099         CALL PUSHREAL8(min19)
24100         min19 = 1.0
24101         CALL PUSHCONTROL1B(1)
24102       END IF
24103       IF (cr .GE. 0.) THEN
24104         abs27 = cr
24105         CALL PUSHCONTROL1B(0)
24106       ELSE
24107         abs27 = -cr
24108         CALL PUSHCONTROL1B(1)
24109       END IF
24110       y29 = cr - abs27
24111       IF (-1.0 .LT. y29) THEN
24112         CALL PUSHREAL8(max14)
24113         max14 = y29
24114         CALL PUSHCONTROL1B(0)
24115       ELSE
24116         CALL PUSHREAL8(max14)
24117         max14 = -1.0
24118         CALL PUSHCONTROL1B(1)
24119       END IF
24120       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min19*field_old(i, k-1, j)+0.5*&
24121 &       max14*field_old(i, k, j))
24122       fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
24123 &       12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
24124 &       1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
24125 &       i, k, j)-field(i, k-1, j))))
24126       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
24127       k = ktf - 1
24128       CALL PUSHREAL8(dz)
24129       dz = 2./(rdzw(k)+rdzw(k-1))
24130       mu = 0.5*(mut(i, j)+mut(i, j))
24131       CALL PUSHREAL8(vel)
24132       vel = rom(i, k, j)
24133       cr = vel*dt/dz/mu
24134       IF (cr .GE. 0.) THEN
24135         abs13 = cr
24136         CALL PUSHCONTROL1B(0)
24137       ELSE
24138         abs13 = -cr
24139         CALL PUSHCONTROL1B(1)
24140       END IF
24141       y14 = cr + abs13
24142       IF (1.0 .GT. y14) THEN
24143         CALL PUSHREAL8(min20)
24144         min20 = y14
24145         CALL PUSHCONTROL1B(0)
24146       ELSE
24147         CALL PUSHREAL8(min20)
24148         min20 = 1.0
24149         CALL PUSHCONTROL1B(1)
24150       END IF
24151       IF (cr .GE. 0.) THEN
24152         abs28 = cr
24153         CALL PUSHCONTROL1B(0)
24154       ELSE
24155         abs28 = -cr
24156         CALL PUSHCONTROL1B(1)
24157       END IF
24158       y30 = cr - abs28
24159       IF (-1.0 .LT. y30) THEN
24160         CALL PUSHREAL8(max15)
24161         max15 = y30
24162         CALL PUSHCONTROL1B(0)
24163       ELSE
24164         CALL PUSHREAL8(max15)
24165         max15 = -1.0
24166         CALL PUSHCONTROL1B(1)
24167       END IF
24168       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min20*field_old(i, k-1, j)+0.5*&
24169 &       max15*field_old(i, k, j))
24170       fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
24171 &       12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
24172 &       1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
24173 &       i, k, j)-field(i, k-1, j))))
24174       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
24175       k = ktf
24176       CALL PUSHREAL8(dz)
24177       dz = 2./(rdzw(k)+rdzw(k-1))
24178       mu = 0.5*(mut(i, j)+mut(i, j))
24179       CALL PUSHREAL8(vel)
24180       vel = rom(i, k, j)
24181       cr = vel*dt/dz/mu
24182       IF (cr .GE. 0.) THEN
24183         abs14 = cr
24184         CALL PUSHCONTROL1B(0)
24185       ELSE
24186         abs14 = -cr
24187         CALL PUSHCONTROL1B(1)
24188       END IF
24189       y15 = cr + abs14
24190       IF (1.0 .GT. y15) THEN
24191         CALL PUSHREAL8(min21)
24192         min21 = y15
24193         CALL PUSHCONTROL1B(0)
24194       ELSE
24195         CALL PUSHREAL8(min21)
24196         min21 = 1.0
24197         CALL PUSHCONTROL1B(1)
24198       END IF
24199       IF (cr .GE. 0.) THEN
24200         abs29 = cr
24201         CALL PUSHCONTROL1B(0)
24202       ELSE
24203         abs29 = -cr
24204         CALL PUSHCONTROL1B(1)
24205       END IF
24206       y31 = cr - abs29
24207       IF (-1.0 .LT. y31) THEN
24208         CALL PUSHREAL8(max16)
24209         max16 = y31
24210         CALL PUSHCONTROL1B(0)
24211       ELSE
24212         CALL PUSHREAL8(max16)
24213         max16 = -1.0
24214         CALL PUSHCONTROL1B(1)
24215       END IF
24216       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min21*field_old(i, k-1, j)+0.5*&
24217 &       max16*field_old(i, k, j))
24218       fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
24219 &       , k-1, j))
24220       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
24221     END DO
24222     CALL PUSHINTEGER4(i - 1)
24223     CALL PUSHINTEGER4(ad_from15)
24224   END DO
24225   CALL PUSHINTEGER4(j - 1)
24226   CALL PUSHINTEGER4(ad_from16)
24227 !   ELSE
24228 !      WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
24229 !      CALL wrf_error_fatal ( wrf_err_message )
24230 !   ENDIF vert_order_test
24231   IF (pd_limit) THEN
24232 ! positive definite filter
24233     i_start = its - 1
24234     IF (ite .GT. ide - 1) THEN
24235       min22 = ide - 1
24236     ELSE
24237       min22 = ite
24238     END IF
24239     i_end = min22 + 1
24240     j_start = jts - 1
24241     IF (jte .GT. jde - 1) THEN
24242       min23 = jde - 1
24243     ELSE
24244       min23 = jte
24245     END IF
24246     j_end = min23 + 1
24247 !-- loop bounds for open or specified conditions
24248     IF (degrade_xs) THEN
24249       IF (its - 1 .LT. ids) THEN
24250         CALL PUSHCONTROL1B(1)
24251         i_start = ids
24252       ELSE
24253         CALL PUSHCONTROL1B(1)
24254         i_start = its - 1
24255       END IF
24256     ELSE
24257       CALL PUSHCONTROL1B(0)
24258     END IF
24259     IF (degrade_xe) THEN
24260       IF (ite + 1 .GT. ide - 1) THEN
24261         CALL PUSHCONTROL1B(1)
24262         i_end = ide - 1
24263       ELSE
24264         CALL PUSHCONTROL1B(1)
24265         i_end = ite + 1
24266       END IF
24267     ELSE
24268       CALL PUSHCONTROL1B(0)
24269     END IF
24270     IF (degrade_ys) THEN
24271       IF (jts - 1 .LT. jds) THEN
24272         CALL PUSHCONTROL1B(1)
24273         j_start = jds
24274       ELSE
24275         CALL PUSHCONTROL1B(1)
24276         j_start = jts - 1
24277       END IF
24278     ELSE
24279       CALL PUSHCONTROL1B(0)
24280     END IF
24281     IF (degrade_ye) THEN
24282       IF (jte + 1 .GT. jde - 1) THEN
24283         CALL PUSHCONTROL1B(1)
24284         j_end = jde - 1
24285       ELSE
24286         CALL PUSHCONTROL1B(1)
24287         j_end = jte + 1
24288       END IF
24289     ELSE
24290       CALL PUSHCONTROL1B(0)
24291     END IF
24292     IF (config_flags%specified .OR. config_flags%nested) THEN
24293       IF (degrade_xs) THEN
24294         IF (its - 1 .LT. ids + 1) THEN
24295           CALL PUSHCONTROL1B(1)
24296           i_start = ids + 1
24297         ELSE
24298           CALL PUSHCONTROL1B(1)
24299           i_start = its - 1
24300         END IF
24301       ELSE
24302         CALL PUSHCONTROL1B(0)
24303       END IF
24304       IF (degrade_xe) THEN
24305         IF (ite + 1 .GT. ide - 2) THEN
24306           CALL PUSHCONTROL1B(1)
24307           i_end = ide - 2
24308         ELSE
24309           CALL PUSHCONTROL1B(1)
24310           i_end = ite + 1
24311         END IF
24312       ELSE
24313         CALL PUSHCONTROL1B(0)
24314       END IF
24315       IF (degrade_ys) THEN
24316         IF (jts - 1 .LT. jds + 1) THEN
24317           CALL PUSHCONTROL1B(1)
24318           j_start = jds + 1
24319         ELSE
24320           CALL PUSHCONTROL1B(1)
24321           j_start = jts - 1
24322         END IF
24323       ELSE
24324         CALL PUSHCONTROL1B(0)
24325       END IF
24326       IF (degrade_ye) THEN
24327         IF (jte + 1 .GT. jde - 2) THEN
24328           CALL PUSHCONTROL2B(2)
24329           j_end = jde - 2
24330         ELSE
24331           CALL PUSHCONTROL2B(2)
24332           j_end = jte + 1
24333         END IF
24334       ELSE
24335         CALL PUSHCONTROL2B(0)
24336       END IF
24337     ELSE
24338       CALL PUSHCONTROL2B(1)
24339     END IF
24340     IF (config_flags%open_xs) THEN
24341       IF (degrade_xs) THEN
24342         IF (its - 1 .LT. ids + 1) THEN
24343           CALL PUSHCONTROL2B(2)
24344           i_start = ids + 1
24345         ELSE
24346           CALL PUSHCONTROL2B(2)
24347           i_start = its - 1
24348         END IF
24349       ELSE
24350         CALL PUSHCONTROL2B(0)
24351       END IF
24352     ELSE
24353       CALL PUSHCONTROL2B(1)
24354     END IF
24355     IF (config_flags%open_xe) THEN
24356       IF (degrade_xe) THEN
24357         IF (ite + 1 .GT. ide - 2) THEN
24358           CALL PUSHCONTROL2B(2)
24359           i_end = ide - 2
24360         ELSE
24361           CALL PUSHCONTROL2B(2)
24362           i_end = ite + 1
24363         END IF
24364       ELSE
24365         CALL PUSHCONTROL2B(0)
24366       END IF
24367     ELSE
24368       CALL PUSHCONTROL2B(1)
24369     END IF
24370     IF (config_flags%open_ys) THEN
24371       IF (degrade_ys) THEN
24372         IF (jts - 1 .LT. jds + 1) THEN
24373           CALL PUSHCONTROL2B(2)
24374           j_start = jds + 1
24375         ELSE
24376           CALL PUSHCONTROL2B(2)
24377           j_start = jts - 1
24378         END IF
24379       ELSE
24380         CALL PUSHCONTROL2B(0)
24381       END IF
24382     ELSE
24383       CALL PUSHCONTROL2B(1)
24384     END IF
24385     IF (config_flags%open_ye) THEN
24386       IF (degrade_ye) THEN
24387         IF (jte + 1 .GT. jde - 2) THEN
24388           CALL PUSHCONTROL2B(2)
24389           j_end = jde - 2
24390         ELSE
24391           CALL PUSHCONTROL2B(2)
24392           j_end = jte + 1
24393         END IF
24394       ELSE
24395         CALL PUSHCONTROL2B(1)
24396       END IF
24397     ELSE
24398       CALL PUSHCONTROL2B(0)
24399     END IF
24400     ad_from18 = j_start
24401 ! ADT note:
24402 ! We don't want to change j_start and j_end
24403 ! for polar BC's since we want to calculate
24404 ! fluxes for directions other than y at the
24405 ! edge
24406 !-- here is the limiter...
24407     DO j=ad_from18,j_end
24408       CALL PUSHINTEGER4(k)
24409       DO k=kts,ktf
24410         ad_from17 = i_start
24411         DO i=ad_from17,i_end
24412           ph_low(i, k, j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) &
24413 &           - dt*(msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, &
24414 &           k, j))+rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw&
24415 &           (k)*(fqzl(i, k+1, j)-fqzl(i, k, j)))
24416         END DO
24417         CALL PUSHINTEGER4(i - 1)
24418         CALL PUSHINTEGER4(ad_from17)
24419       END DO
24420     END DO
24421     CALL PUSHINTEGER4(j - 1)
24422     CALL PUSHINTEGER4(ad_from18)
24423     ad_from20 = j_start
24424     DO j=ad_from20,j_end
24425       CALL PUSHINTEGER4(k)
24426       DO k=kts,ktf
24427         ad_from19 = i_start
24428 !DIR$ vector always
24429         DO i=ad_from19,i_end
24430           IF (0. .LT. fqx(i+1, k, j)) THEN
24431             max1 = fqx(i+1, k, j)
24432             CALL PUSHCONTROL1B(1)
24433           ELSE
24434             CALL PUSHCONTROL1B(0)
24435             max1 = 0.
24436           END IF
24437           IF (0. .GT. fqx(i, k, j)) THEN
24438             min24 = fqx(i, k, j)
24439             CALL PUSHCONTROL1B(1)
24440           ELSE
24441             CALL PUSHCONTROL1B(0)
24442             min24 = 0.
24443           END IF
24444           IF (0. .LT. fqy(i, k, j+1)) THEN
24445             max17 = fqy(i, k, j+1)
24446             CALL PUSHCONTROL1B(1)
24447           ELSE
24448             CALL PUSHCONTROL1B(0)
24449             max17 = 0.
24450           END IF
24451           IF (0. .GT. fqy(i, k, j)) THEN
24452             min25 = fqy(i, k, j)
24453             CALL PUSHCONTROL1B(1)
24454           ELSE
24455             CALL PUSHCONTROL1B(0)
24456             min25 = 0.
24457           END IF
24458           IF (0. .GT. fqz(i, k+1, j)) THEN
24459             min26 = fqz(i, k+1, j)
24460             CALL PUSHCONTROL1B(1)
24461           ELSE
24462             CALL PUSHCONTROL1B(0)
24463             min26 = 0.
24464           END IF
24465           IF (0. .LT. fqz(i, k, j)) THEN
24466             max18 = fqz(i, k, j)
24467             CALL PUSHCONTROL1B(0)
24468           ELSE
24469             CALL PUSHCONTROL1B(1)
24470             max18 = 0.
24471           END IF
24472           flux_out(i, k, j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-&
24473 &           min24)+rdy*(max17-min25))+msfty(i, j)*rdzw(k)*(min26-max18))
24474         END DO
24475         CALL PUSHINTEGER4(i - 1)
24476         CALL PUSHINTEGER4(ad_from19)
24477       END DO
24478     END DO
24479     CALL PUSHINTEGER4(j - 1)
24480     CALL PUSHINTEGER4(ad_from20)
24481     ad_from22 = j_start
24482     DO j=ad_from22,j_end
24483       CALL PUSHINTEGER4(k)
24484       DO k=kts,ktf
24485         ad_from21 = i_start
24486 !DIR$ vector always
24487         DO i=ad_from21,i_end
24488           IF (flux_out(i, k, j) .GT. ph_low(i, k, j)) THEN
24489             y16 = ph_low(i, k, j)/(flux_out(i, k, j)+eps)
24490             IF (0. .LT. y16) THEN
24491               CALL PUSHREAL8(scale)
24492               scale = y16
24493               CALL PUSHCONTROL1B(0)
24494             ELSE
24495               CALL PUSHREAL8(scale)
24496               scale = 0.
24497               CALL PUSHCONTROL1B(1)
24498             END IF
24499             IF (fqx(i+1, k, j) .GT. 0.) THEN
24500               CALL PUSHREAL8(fqx(i+1, k, j))
24501               fqx(i+1, k, j) = scale*fqx(i+1, k, j)
24502               CALL PUSHCONTROL1B(0)
24503             ELSE
24504               CALL PUSHCONTROL1B(1)
24505             END IF
24506             IF (fqx(i, k, j) .LT. 0.) THEN
24507               CALL PUSHREAL8(fqx(i, k, j))
24508               fqx(i, k, j) = scale*fqx(i, k, j)
24509               CALL PUSHCONTROL1B(0)
24510             ELSE
24511               CALL PUSHCONTROL1B(1)
24512             END IF
24513             IF (fqy(i, k, j+1) .GT. 0.) THEN
24514               CALL PUSHREAL8(fqy(i, k, j+1))
24515               fqy(i, k, j+1) = scale*fqy(i, k, j+1)
24516               CALL PUSHCONTROL1B(0)
24517             ELSE
24518               CALL PUSHCONTROL1B(1)
24519             END IF
24520             IF (fqy(i, k, j) .LT. 0.) THEN
24521               CALL PUSHREAL8(fqy(i, k, j))
24522               fqy(i, k, j) = scale*fqy(i, k, j)
24523               CALL PUSHCONTROL1B(0)
24524             ELSE
24525               CALL PUSHCONTROL1B(1)
24526             END IF
24527 !  note: z flux is opposite sign in mass coordinate because
24528 !  vertical coordinate decreases with increasing k
24529             IF (fqz(i, k+1, j) .LT. 0.) THEN
24530               CALL PUSHREAL8(fqz(i, k+1, j))
24531               fqz(i, k+1, j) = scale*fqz(i, k+1, j)
24532               CALL PUSHCONTROL1B(0)
24533             ELSE
24534               CALL PUSHCONTROL1B(1)
24535             END IF
24536             IF (fqz(i, k, j) .GT. 0.) THEN
24537               CALL PUSHREAL8(fqz(i, k, j))
24538               fqz(i, k, j) = scale*fqz(i, k, j)
24539               CALL PUSHCONTROL2B(2)
24540             ELSE
24541               CALL PUSHCONTROL2B(1)
24542             END IF
24543           ELSE
24544             CALL PUSHCONTROL2B(0)
24545           END IF
24546         END DO
24547         CALL PUSHINTEGER4(i - 1)
24548         CALL PUSHINTEGER4(ad_from21)
24549       END DO
24550     END DO
24551     CALL PUSHINTEGER4(j - 1)
24552     CALL PUSHINTEGER4(ad_from22)
24553     CALL PUSHCONTROL1B(1)
24554   ELSE
24555     CALL PUSHCONTROL1B(0)
24556   END IF
24557 ! add in the pd-limited flux divergence
24558   i_start = its
24559   IF (ite .GT. ide - 1) THEN
24560     i_end = ide - 1
24561   ELSE
24562     i_end = ite
24563   END IF
24564   j_start = jts
24565   IF (jte .GT. jde - 1) THEN
24566     j_end = jde - 1
24567   ELSE
24568     j_end = jte
24569   END IF
24570   ad_from24 = j_start
24571   DO j=ad_from24,j_end
24572     CALL PUSHINTEGER4(k)
24573     DO k=kts,ktf
24574       ad_from23 = i_start
24575       i = i_end + 1
24576       CALL PUSHINTEGER4(i - 1)
24577       CALL PUSHINTEGER4(ad_from23)
24578     END DO
24579   END DO
24580   CALL PUSHINTEGER4(j - 1)
24581   CALL PUSHINTEGER4(ad_from24)
24582 ! x flux divergence
24583 !
24584   IF (degrade_xs) THEN
24585     IF (its .LT. ids + 1) THEN
24586       CALL PUSHCONTROL1B(1)
24587       i_start = ids + 1
24588     ELSE
24589       CALL PUSHCONTROL1B(1)
24590       i_start = its
24591     END IF
24592   ELSE
24593     CALL PUSHCONTROL1B(0)
24594   END IF
24595   IF (degrade_xe) THEN
24596     IF (ite .GT. ide - 2) THEN
24597       CALL PUSHCONTROL1B(1)
24598       i_end = ide - 2
24599     ELSE
24600       CALL PUSHCONTROL1B(1)
24601       i_end = ite
24602     END IF
24603   ELSE
24604     CALL PUSHCONTROL1B(0)
24605   END IF
24606   ad_from26 = j_start
24607   DO j=ad_from26,j_end
24608     CALL PUSHINTEGER4(k)
24609     DO k=kts,ktf
24610       ad_from25 = i_start
24611       i = i_end + 1
24612       CALL PUSHINTEGER4(i - 1)
24613       CALL PUSHINTEGER4(ad_from25)
24614     END DO
24615   END DO
24616   CALL PUSHINTEGER4(j - 1)
24617   CALL PUSHINTEGER4(ad_from26)
24618 ! y flux divergence
24619 !
24620   i_start = its
24621   IF (ite .GT. ide - 1) THEN
24622     i_end = ide - 1
24623   ELSE
24624     i_end = ite
24625   END IF
24626   IF (degrade_ys) THEN
24627     IF (jts .LT. jds + 1) THEN
24628       CALL PUSHCONTROL1B(1)
24629       j_start = jds + 1
24630     ELSE
24631       CALL PUSHCONTROL1B(1)
24632       j_start = jts
24633     END IF
24634   ELSE
24635     CALL PUSHCONTROL1B(0)
24636   END IF
24637   IF (degrade_ye) THEN
24638     IF (jte .GT. jde - 2) THEN
24639       CALL PUSHCONTROL1B(1)
24640       j_end = jde - 2
24641     ELSE
24642       CALL PUSHCONTROL1B(1)
24643       j_end = jte
24644     END IF
24645   ELSE
24646     CALL PUSHCONTROL1B(0)
24647   END IF
24648   DO j=j_start,j_end
24649     CALL PUSHINTEGER4(k)
24650   END DO
24651   fqylb = 0.0
24652   fqyb = 0.0
24653   DO j=j_end,j_start,-1
24654     DO k=ktf,kts,-1
24655       DO i=i_end,i_start,-1
24656         tempb92 = -(msftx(i, j)*rdy*tendencyb(i, k, j))
24657         fqyb(i, k, j+1) = fqyb(i, k, j+1) + tempb92
24658         fqyb(i, k, j) = fqyb(i, k, j) - tempb92
24659         fqylb(i, k, j+1) = fqylb(i, k, j+1) + tempb92
24660         fqylb(i, k, j) = fqylb(i, k, j) - tempb92
24661       END DO
24662     END DO
24663     CALL POPINTEGER4(k)
24664   END DO
24665   CALL POPCONTROL1B(branch)
24666   CALL POPCONTROL1B(branch)
24667   fqxlb = 0.0
24668   fqxb = 0.0
24669   CALL POPINTEGER4(ad_from26)
24670   CALL POPINTEGER4(ad_to26)
24671   DO j=ad_to26,ad_from26,-1
24672     DO k=ktf,kts,-1
24673       CALL POPINTEGER4(ad_from25)
24674       CALL POPINTEGER4(ad_to25)
24675       DO i=ad_to25,ad_from25,-1
24676         tempb91 = -(msftx(i, j)*rdx*tendencyb(i, k, j))
24677         fqxb(i+1, k, j) = fqxb(i+1, k, j) + tempb91
24678         fqxb(i, k, j) = fqxb(i, k, j) - tempb91
24679         fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + tempb91
24680         fqxlb(i, k, j) = fqxlb(i, k, j) - tempb91
24681       END DO
24682     END DO
24683     CALL POPINTEGER4(k)
24684   END DO
24685   CALL POPCONTROL1B(branch)
24686   CALL POPCONTROL1B(branch)
24687   fqzb = 0.0
24688   fqzlb = 0.0
24689   CALL POPINTEGER4(ad_from24)
24690   CALL POPINTEGER4(ad_to24)
24691   DO j=ad_to24,ad_from24,-1
24692     DO k=ktf,kts,-1
24693       CALL POPINTEGER4(ad_from23)
24694       CALL POPINTEGER4(ad_to23)
24695       DO i=ad_to23,ad_from23,-1
24696         tempb90 = -(rdzw(k)*tendencyb(i, k, j))
24697         fqzb(i, k+1, j) = fqzb(i, k+1, j) + tempb90
24698         fqzb(i, k, j) = fqzb(i, k, j) - tempb90
24699         fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + tempb90
24700         fqzlb(i, k, j) = fqzlb(i, k, j) - tempb90
24701       END DO
24702     END DO
24703     CALL POPINTEGER4(k)
24704   END DO
24705   CALL POPCONTROL1B(branch)
24706   IF (branch .NE. 0) THEN
24707     flux_outb = 0.0
24708     ph_lowb = 0.0
24709     CALL POPINTEGER4(ad_from22)
24710     CALL POPINTEGER4(ad_to22)
24711     DO j=ad_to22,ad_from22,-1
24712       DO k=ktf,kts,-1
24713         CALL POPINTEGER4(ad_from21)
24714         CALL POPINTEGER4(ad_to21)
24715         DO i=ad_to21,ad_from21,-1
24716           CALL POPCONTROL2B(branch)
24717           IF (branch .NE. 0) THEN
24718             IF (branch .EQ. 1) THEN
24719               scaleb = 0.0
24720             ELSE
24721               CALL POPREAL8(fqz(i, k, j))
24722               scaleb = fqz(i, k, j)*fqzb(i, k, j)
24723               fqzb(i, k, j) = scale*fqzb(i, k, j)
24724             END IF
24725             CALL POPCONTROL1B(branch)
24726             IF (branch .EQ. 0) THEN
24727               CALL POPREAL8(fqz(i, k+1, j))
24728               scaleb = scaleb + fqz(i, k+1, j)*fqzb(i, k+1, j)
24729               fqzb(i, k+1, j) = scale*fqzb(i, k+1, j)
24730             END IF
24731             CALL POPCONTROL1B(branch)
24732             IF (branch .EQ. 0) THEN
24733               CALL POPREAL8(fqy(i, k, j))
24734               scaleb = scaleb + fqy(i, k, j)*fqyb(i, k, j)
24735               fqyb(i, k, j) = scale*fqyb(i, k, j)
24736             END IF
24737             CALL POPCONTROL1B(branch)
24738             IF (branch .EQ. 0) THEN
24739               CALL POPREAL8(fqy(i, k, j+1))
24740               scaleb = scaleb + fqy(i, k, j+1)*fqyb(i, k, j+1)
24741               fqyb(i, k, j+1) = scale*fqyb(i, k, j+1)
24742             END IF
24743             CALL POPCONTROL1B(branch)
24744             IF (branch .EQ. 0) THEN
24745               CALL POPREAL8(fqx(i, k, j))
24746               scaleb = scaleb + fqx(i, k, j)*fqxb(i, k, j)
24747               fqxb(i, k, j) = scale*fqxb(i, k, j)
24748             END IF
24749             CALL POPCONTROL1B(branch)
24750             IF (branch .EQ. 0) THEN
24751               CALL POPREAL8(fqx(i+1, k, j))
24752               scaleb = scaleb + fqx(i+1, k, j)*fqxb(i+1, k, j)
24753               fqxb(i+1, k, j) = scale*fqxb(i+1, k, j)
24754             END IF
24755             CALL POPCONTROL1B(branch)
24756             IF (branch .EQ. 0) THEN
24757               CALL POPREAL8(scale)
24758               y16b = scaleb
24759             ELSE
24760               CALL POPREAL8(scale)
24761               y16b = 0.0
24762             END IF
24763             temp32 = eps + flux_out(i, k, j)
24764             ph_lowb(i, k, j) = ph_lowb(i, k, j) + y16b/temp32
24765             flux_outb(i, k, j) = flux_outb(i, k, j) - ph_low(i, k, j)*&
24766 &             y16b/temp32**2
24767           END IF
24768         END DO
24769       END DO
24770       CALL POPINTEGER4(k)
24771     END DO
24772     CALL POPINTEGER4(ad_from20)
24773     CALL POPINTEGER4(ad_to20)
24774     DO j=ad_to20,ad_from20,-1
24775       DO k=ktf,kts,-1
24776         CALL POPINTEGER4(ad_from19)
24777         CALL POPINTEGER4(ad_to19)
24778         DO i=ad_to19,ad_from19,-1
24779           tempb88 = dt*msftx(i, j)*msfty(i, j)*flux_outb(i, k, j)
24780           tempb89 = msfty(i, j)*dt*rdzw(k)*flux_outb(i, k, j)
24781           max1b = rdx*tempb88
24782           min24b = -(rdx*tempb88)
24783           max17b = rdy*tempb88
24784           min25b = -(rdy*tempb88)
24785           min26b = tempb89
24786           max18b = -tempb89
24787           flux_outb(i, k, j) = 0.0
24788           CALL POPCONTROL1B(branch)
24789           IF (branch .EQ. 0) fqzb(i, k, j) = fqzb(i, k, j) + max18b
24790           CALL POPCONTROL1B(branch)
24791           IF (branch .NE. 0) fqzb(i, k+1, j) = fqzb(i, k+1, j) + min26b
24792           CALL POPCONTROL1B(branch)
24793           IF (branch .NE. 0) fqyb(i, k, j) = fqyb(i, k, j) + min25b
24794           CALL POPCONTROL1B(branch)
24795           IF (branch .NE. 0) fqyb(i, k, j+1) = fqyb(i, k, j+1) + max17b
24796           CALL POPCONTROL1B(branch)
24797           IF (branch .NE. 0) fqxb(i, k, j) = fqxb(i, k, j) + min24b
24798           CALL POPCONTROL1B(branch)
24799           IF (branch .NE. 0) fqxb(i+1, k, j) = fqxb(i+1, k, j) + max1b
24800         END DO
24801       END DO
24802       CALL POPINTEGER4(k)
24803     END DO
24804     CALL POPINTEGER4(ad_from18)
24805     CALL POPINTEGER4(ad_to18)
24806     DO j=ad_to18,ad_from18,-1
24807       DO k=ktf,kts,-1
24808         CALL POPINTEGER4(ad_from17)
24809         CALL POPINTEGER4(ad_to17)
24810         DO i=ad_to17,ad_from17,-1
24811           tempb86 = -(dt*msftx(i, j)*msfty(i, j)*ph_lowb(i, k, j))
24812           tempb87 = -(dt*msfty(i, j)*rdzw(k)*ph_lowb(i, k, j))
24813           mu_oldb(i, j) = mu_oldb(i, j) + field_old(i, k, j)*ph_lowb(i, &
24814 &           k, j)
24815           field_oldb(i, k, j) = field_oldb(i, k, j) + (mub(i, j)+mu_old(&
24816 &           i, j))*ph_lowb(i, k, j)
24817           fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + rdx*tempb86
24818           fqxlb(i, k, j) = fqxlb(i, k, j) - rdx*tempb86
24819           fqylb(i, k, j+1) = fqylb(i, k, j+1) + rdy*tempb86
24820           fqylb(i, k, j) = fqylb(i, k, j) - rdy*tempb86
24821           fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + tempb87
24822           fqzlb(i, k, j) = fqzlb(i, k, j) - tempb87
24823           ph_lowb(i, k, j) = 0.0
24824         END DO
24825       END DO
24826       CALL POPINTEGER4(k)
24827     END DO
24828     CALL POPCONTROL2B(branch)
24829     CALL POPCONTROL2B(branch)
24830     CALL POPCONTROL2B(branch)
24831     CALL POPCONTROL2B(branch)
24832     CALL POPCONTROL2B(branch)
24833     IF (branch .NE. 0) THEN
24834       IF (branch .EQ. 1) GOTO 100
24835     END IF
24836     CALL POPCONTROL1B(branch)
24837     CALL POPCONTROL1B(branch)
24838     CALL POPCONTROL1B(branch)
24839  100 CALL POPCONTROL1B(branch)
24840     CALL POPCONTROL1B(branch)
24841     CALL POPCONTROL1B(branch)
24842     CALL POPCONTROL1B(branch)
24843   END IF
24844   CALL POPINTEGER4(ad_from16)
24845   CALL POPINTEGER4(ad_to16)
24846   DO j=ad_to16,ad_from16,-1
24847     CALL POPINTEGER4(ad_from15)
24848     CALL POPINTEGER4(ad_to15)
24849     DO i=ad_to15,ad_from15,-1
24850       fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
24851       tempb84 = rom(i, k, j)*fqzb(i, k, j)
24852       romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
24853 &       field(i, k-1, j))*fqzb(i, k, j)
24854       fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb84
24855       fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb84
24856       fqzb(i, k, j) = 0.0
24857       tempb85 = dz*mu*fqzlb(i, k, j)/dt
24858       min21b = 0.5*field_old(i, k-1, j)*tempb85
24859       field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min21*tempb85
24860       max16b = 0.5*field_old(i, k, j)*tempb85
24861       field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max16*tempb85
24862       mub0 = (0.5*(min21*field_old(i, k-1, j))+0.5*(max16*field_old(i, k&
24863 &       , j)))*dz*fqzlb(i, k, j)/dt
24864       fqzlb(i, k, j) = 0.0
24865       CALL POPCONTROL1B(branch)
24866       IF (branch .EQ. 0) THEN
24867         CALL POPREAL8(max16)
24868         y31b = max16b
24869       ELSE
24870         CALL POPREAL8(max16)
24871         y31b = 0.0
24872       END IF
24873       crb = y31b
24874       abs29b = -y31b
24875       CALL POPCONTROL1B(branch)
24876       IF (branch .EQ. 0) THEN
24877         crb = crb + abs29b
24878       ELSE
24879         crb = crb - abs29b
24880       END IF
24881       CALL POPCONTROL1B(branch)
24882       IF (branch .EQ. 0) THEN
24883         CALL POPREAL8(min21)
24884         y15b = min21b
24885       ELSE
24886         CALL POPREAL8(min21)
24887         y15b = 0.0
24888       END IF
24889       crb = crb + y15b
24890       abs14b = y15b
24891       CALL POPCONTROL1B(branch)
24892       IF (branch .EQ. 0) THEN
24893         crb = crb + abs14b
24894       ELSE
24895         crb = crb - abs14b
24896       END IF
24897       tempb79 = dt*crb/(dz*mu)
24898       velb = tempb79
24899       mub0 = mub0 - vel*tempb79/mu
24900       CALL POPREAL8(vel)
24901       romb(i, k, j) = romb(i, k, j) + velb
24902       mutb(i, j) = mutb(i, j) + 0.5*2*mub0
24903       mu = 0.5*(mut(i, j)+mut(i, j))
24904       CALL POPREAL8(dz)
24905       k = ktf - 1
24906       fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
24907       temp28 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-&
24908 &       field(i, k-1, j))
24909       temp31 = SIGN(1., -vel)
24910       temp30 = temp31/12.
24911       temp29 = SIGN(1, time_step)
24912       tempb80 = vel*fqzb(i, k, j)
24913       tempb81 = 7.*tempb80/12.
24914       tempb82 = temp29*temp30*tempb80
24915       velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, &
24916 &       j)+field(i, k-2, j))/12.+temp29*(temp30*temp28))*fqzb(i, k, j)
24917       fieldb(i, k, j) = fieldb(i, k, j) + tempb81 - 3.*tempb82
24918       fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb82 + tempb81
24919       fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb82 - tempb80/12.
24920       fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb82 - tempb80/12.
24921       fqzb(i, k, j) = 0.0
24922       tempb83 = dz*mu*fqzlb(i, k, j)/dt
24923       min20b = 0.5*field_old(i, k-1, j)*tempb83
24924       field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min20*tempb83
24925       max15b = 0.5*field_old(i, k, j)*tempb83
24926       field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max15*tempb83
24927       mub0 = (0.5*(min20*field_old(i, k-1, j))+0.5*(max15*field_old(i, k&
24928 &       , j)))*dz*fqzlb(i, k, j)/dt
24929       fqzlb(i, k, j) = 0.0
24930       CALL POPCONTROL1B(branch)
24931       IF (branch .EQ. 0) THEN
24932         CALL POPREAL8(max15)
24933         y30b = max15b
24934       ELSE
24935         CALL POPREAL8(max15)
24936         y30b = 0.0
24937       END IF
24938       crb = y30b
24939       abs28b = -y30b
24940       CALL POPCONTROL1B(branch)
24941       IF (branch .EQ. 0) THEN
24942         crb = crb + abs28b
24943       ELSE
24944         crb = crb - abs28b
24945       END IF
24946       CALL POPCONTROL1B(branch)
24947       IF (branch .EQ. 0) THEN
24948         CALL POPREAL8(min20)
24949         y14b = min20b
24950       ELSE
24951         CALL POPREAL8(min20)
24952         y14b = 0.0
24953       END IF
24954       crb = crb + y14b
24955       abs13b = y14b
24956       CALL POPCONTROL1B(branch)
24957       IF (branch .EQ. 0) THEN
24958         crb = crb + abs13b
24959       ELSE
24960         crb = crb - abs13b
24961       END IF
24962       tempb74 = dt*crb/(dz*mu)
24963       velb = velb + tempb74
24964       mub0 = mub0 - vel*tempb74/mu
24965       CALL POPREAL8(vel)
24966       romb(i, k, j) = romb(i, k, j) + velb
24967       mutb(i, j) = mutb(i, j) + 0.5*2*mub0
24968       mu = 0.5*(mut(i, j)+mut(i, j))
24969       CALL POPREAL8(dz)
24970       k = kts + 2
24971       fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
24972       temp24 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-&
24973 &       field(i, k-1, j))
24974       temp27 = SIGN(1., -vel)
24975       temp26 = temp27/12.
24976       temp25 = SIGN(1, time_step)
24977       tempb75 = vel*fqzb(i, k, j)
24978       tempb76 = 7.*tempb75/12.
24979       tempb77 = temp25*temp26*tempb75
24980       velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, &
24981 &       j)+field(i, k-2, j))/12.+temp25*(temp26*temp24))*fqzb(i, k, j)
24982       fieldb(i, k, j) = fieldb(i, k, j) + tempb76 - 3.*tempb77
24983       fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb77 + tempb76
24984       fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb77 - tempb75/12.
24985       fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb77 - tempb75/12.
24986       fqzb(i, k, j) = 0.0
24987       tempb78 = dz*mu*fqzlb(i, k, j)/dt
24988       min19b = 0.5*field_old(i, k-1, j)*tempb78
24989       field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min19*tempb78
24990       max14b = 0.5*field_old(i, k, j)*tempb78
24991       field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max14*tempb78
24992       mub0 = (0.5*(min19*field_old(i, k-1, j))+0.5*(max14*field_old(i, k&
24993 &       , j)))*dz*fqzlb(i, k, j)/dt
24994       fqzlb(i, k, j) = 0.0
24995       CALL POPCONTROL1B(branch)
24996       IF (branch .EQ. 0) THEN
24997         CALL POPREAL8(max14)
24998         y29b = max14b
24999       ELSE
25000         CALL POPREAL8(max14)
25001         y29b = 0.0
25002       END IF
25003       crb = y29b
25004       abs27b = -y29b
25005       CALL POPCONTROL1B(branch)
25006       IF (branch .EQ. 0) THEN
25007         crb = crb + abs27b
25008       ELSE
25009         crb = crb - abs27b
25010       END IF
25011       CALL POPCONTROL1B(branch)
25012       IF (branch .EQ. 0) THEN
25013         CALL POPREAL8(min19)
25014         y13b = min19b
25015       ELSE
25016         CALL POPREAL8(min19)
25017         y13b = 0.0
25018       END IF
25019       crb = crb + y13b
25020       abs12b = y13b
25021       CALL POPCONTROL1B(branch)
25022       IF (branch .EQ. 0) THEN
25023         crb = crb + abs12b
25024       ELSE
25025         crb = crb - abs12b
25026       END IF
25027       tempb71 = dt*crb/(dz*mu)
25028       velb = velb + tempb71
25029       mub0 = mub0 - vel*tempb71/mu
25030       CALL POPREAL8(vel)
25031       romb(i, k, j) = romb(i, k, j) + velb
25032       mutb(i, j) = mutb(i, j) + 0.5*2*mub0
25033       mu = 0.5*(mut(i, j)+mut(i, j))
25034       CALL POPREAL8(dz)
25035       k = kts + 1
25036       fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
25037       tempb72 = rom(i, k, j)*fqzb(i, k, j)
25038       romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
25039 &       field(i, k-1, j))*fqzb(i, k, j)
25040       fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb72
25041       fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb72
25042       fqzb(i, k, j) = 0.0
25043       tempb73 = dz*mu*fqzlb(i, k, j)/dt
25044       min18b = 0.5*field_old(i, k-1, j)*tempb73
25045       field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min18*tempb73
25046       max13b = 0.5*field_old(i, k, j)*tempb73
25047       field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max13*tempb73
25048       mub0 = (0.5*(min18*field_old(i, k-1, j))+0.5*(max13*field_old(i, k&
25049 &       , j)))*dz*fqzlb(i, k, j)/dt
25050       fqzlb(i, k, j) = 0.0
25051       CALL POPCONTROL1B(branch)
25052       IF (branch .EQ. 0) THEN
25053         CALL POPREAL8(max13)
25054         y28b = max13b
25055       ELSE
25056         CALL POPREAL8(max13)
25057         y28b = 0.0
25058       END IF
25059       crb = y28b
25060       abs26b = -y28b
25061       CALL POPCONTROL1B(branch)
25062       IF (branch .EQ. 0) THEN
25063         crb = crb + abs26b
25064       ELSE
25065         crb = crb - abs26b
25066       END IF
25067       CALL POPCONTROL1B(branch)
25068       IF (branch .EQ. 0) THEN
25069         CALL POPREAL8(min18)
25070         y12b = min18b
25071       ELSE
25072         CALL POPREAL8(min18)
25073         y12b = 0.0
25074       END IF
25075       crb = crb + y12b
25076       abs11b = y12b
25077       CALL POPCONTROL1B(branch)
25078       IF (branch .EQ. 0) THEN
25079         crb = crb + abs11b
25080       ELSE
25081         crb = crb - abs11b
25082       END IF
25083       tempb70 = dt*crb/(dz*mu)
25084       velb = tempb70
25085       mub0 = mub0 - vel*tempb70/mu
25086       CALL POPREAL8(vel)
25087       romb(i, k, j) = romb(i, k, j) + velb
25088       CALL POPREAL8(mu)
25089       mutb(i, j) = mutb(i, j) + 0.5*2*mub0
25090       CALL POPREAL8(dz)
25091       CALL POPINTEGER4(k)
25092     END DO
25093     DO k=ktf-2,kts+3,-1
25094       CALL POPINTEGER4(ad_from14)
25095       CALL POPINTEGER4(ad_to14)
25096       DO i=ad_to14,ad_from14,-1
25097         fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j)
25098         wi0 = gi0/(eps1+beta0)**pw
25099         wi1 = gi1/(eps1+beta1)**pw
25100         wi2 = gi2/(eps1+beta2)**pw
25101         sumwk = wi0 + wi1 + wi2
25102         tempb62 = vel*fqzb(i, k, j)/sumwk
25103         tempb63 = (wi0*f0+wi1*f1+wi2*f2)*fqzb(i, k, j)/sumwk
25104         f0b = wi0*tempb62
25105         f1b = wi1*tempb62
25106         f2b = wi2*tempb62
25107         velb = tempb63
25108         sumwkb = -(vel*tempb63/sumwk)
25109         wi0b = sumwkb + f0*tempb62
25110         wi1b = sumwkb + f1*tempb62
25111         wi2b = sumwkb + f2*tempb62
25112         fqzb(i, k, j) = 0.0
25113         temp23 = (eps1+beta2)**pw
25114         IF (eps1 + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw&
25115 &           ))) THEN
25116           beta2b = 0.0
25117         ELSE
25118           beta2b = -(gi2*pw*(eps1+beta2)**(pw-1)*wi2b/temp23**2)
25119         END IF
25120         temp22 = (eps1+beta1)**pw
25121         IF (eps1 + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw&
25122 &           ))) THEN
25123           beta1b = 0.0
25124         ELSE
25125           beta1b = -(gi1*pw*(eps1+beta1)**(pw-1)*wi1b/temp22**2)
25126         END IF
25127         temp21 = (eps1+beta0)**pw
25128         IF (eps1 + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw&
25129 &           ))) THEN
25130           beta0b = 0.0
25131         ELSE
25132           beta0b = -(gi0*pw*(eps1+beta0)**(pw-1)*wi0b/temp21**2)
25133         END IF
25134         CALL POPREAL8(beta2)
25135         tempb64 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
25136         tempb65 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
25137         qip2b = tempb65 - f2b/6. + tempb64
25138         CALL POPREAL8(beta1)
25139         tempb66 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
25140         tempb69 = 2*(qim1-qip1)*beta1b/4.
25141         qip1b = tempb66 - tempb69 + f1b/3. + 5.*f2b/6. - 4.*tempb65 - 2.&
25142 &         *tempb64
25143         CALL POPREAL8(beta0)
25144         tempb68 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
25145         tempb67 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
25146         qib = f2b/3. - 2.*tempb66 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb67 &
25147 &         + tempb68 + 3.*tempb65 + tempb64
25148         qim1b = tempb69 - 4.*tempb67 - 7.*f0b/6. - f1b/6. - 2.*tempb68 +&
25149 &         tempb66
25150         qim2b = f0b/3. + tempb67 + tempb68
25151         CALL POPREAL8(f2)
25152         CALL POPREAL8(f1)
25153         CALL POPREAL8(f0)
25154         CALL POPCONTROL1B(branch)
25155         IF (branch .EQ. 0) THEN
25156           CALL POPREAL8(qim2)
25157           fieldb(i, k-3, j) = fieldb(i, k-3, j) + qim2b
25158           CALL POPREAL8(qim1)
25159           fieldb(i, k-2, j) = fieldb(i, k-2, j) + qim1b
25160           CALL POPREAL8(qi)
25161           fieldb(i, k-1, j) = fieldb(i, k-1, j) + qib
25162           CALL POPREAL8(qip1)
25163           fieldb(i, k, j) = fieldb(i, k, j) + qip1b
25164           CALL POPREAL8(qip2)
25165           fieldb(i, k+1, j) = fieldb(i, k+1, j) + qip2b
25166         ELSE
25167           CALL POPREAL8(qim2)
25168           fieldb(i, k+2, j) = fieldb(i, k+2, j) + qim2b
25169           CALL POPREAL8(qim1)
25170           fieldb(i, k+1, j) = fieldb(i, k+1, j) + qim1b
25171           CALL POPREAL8(qi)
25172           fieldb(i, k, j) = fieldb(i, k, j) + qib
25173           CALL POPREAL8(qip1)
25174           fieldb(i, k-1, j) = fieldb(i, k-1, j) + qip1b
25175           CALL POPREAL8(qip2)
25176           fieldb(i, k-2, j) = fieldb(i, k-2, j) + qip2b
25177         END IF
25178         tempb61 = dz*mu*fqzlb(i, k, j)/dt
25179         min17b = 0.5*field_old(i, k-1, j)*tempb61
25180         field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min17*&
25181 &         tempb61
25182         max12b = 0.5*field_old(i, k, j)*tempb61
25183         field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max12*tempb61
25184         mub0 = (0.5*(min17*field_old(i, k-1, j))+0.5*(max12*field_old(i&
25185 &         , k, j)))*dz*fqzlb(i, k, j)/dt
25186         fqzlb(i, k, j) = 0.0
25187         CALL POPCONTROL1B(branch)
25188         IF (branch .EQ. 0) THEN
25189           CALL POPREAL8(max12)
25190           y27b = max12b
25191         ELSE
25192           CALL POPREAL8(max12)
25193           y27b = 0.0
25194         END IF
25195         crb = y27b
25196         abs25b = -y27b
25197         CALL POPCONTROL1B(branch)
25198         IF (branch .EQ. 0) THEN
25199           crb = crb + abs25b
25200         ELSE
25201           crb = crb - abs25b
25202         END IF
25203         CALL POPCONTROL1B(branch)
25204         IF (branch .EQ. 0) THEN
25205           CALL POPREAL8(min17)
25206           y11b = min17b
25207         ELSE
25208           CALL POPREAL8(min17)
25209           y11b = 0.0
25210         END IF
25211         crb = crb + y11b
25212         abs10b = y11b
25213         CALL POPCONTROL1B(branch)
25214         IF (branch .EQ. 0) THEN
25215           crb = crb + abs10b
25216         ELSE
25217           crb = crb - abs10b
25218         END IF
25219         tempb60 = dt*crb/(dz*mu)
25220         velb = velb + tempb60
25221         mub0 = mub0 - vel*tempb60/mu
25222         CALL POPREAL8(vel)
25223         romb(i, k, j) = romb(i, k, j) + velb
25224         CALL POPREAL8(mu)
25225         mutb(i, j) = mutb(i, j) + 0.5*2*mub0
25226         CALL POPREAL8(dz)
25227       END DO
25228     END DO
25229     CALL POPINTEGER4(k)
25230     CALL POPINTEGER4(ad_from13)
25231     CALL POPINTEGER4(ad_to13)
25232     DO i=ad_to13,ad_from13,-1
25233       fqzlb(i, kde, j) = 0.0
25234       fqzb(i, kde, j) = 0.0
25235       fqzlb(i, 1, j) = 0.0
25236       fqzb(i, 1, j) = 0.0
25237     END DO
25238   END DO
25239   CALL POPCONTROL1B(branch)
25240   CALL POPCONTROL1B(branch)
25241   CALL POPCONTROL1B(branch)
25242   CALL POPCONTROL1B(branch)
25243   CALL POPINTEGER4(j_end)
25244   CALL POPINTEGER4(i_end)
25245   CALL POPCONTROL1B(branch)
25246   IF (branch .NE. 0) THEN
25247     CALL POPINTEGER4(ad_from12)
25248     CALL POPINTEGER4(ad_to12)
25249     DO i=ad_to12,ad_from12,-1
25250       DO k=ktf,kts,-1
25251         tempb59 = -(rdy*tendencyb(i, k, j_end))
25252         vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*tempb59
25253         field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*tempb59
25254         field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*&
25255 &         tempb59
25256         fieldb(i, k, j_end) = fieldb(i, k, j_end) - rv(i, k, jte-1)*&
25257 &         tempb59
25258         rvb(i, k, jte-1) = rvb(i, k, jte-1) - field(i, k, j_end)*tempb59
25259         CALL POPCONTROL1B(branch)
25260         IF (branch .EQ. 0) THEN
25261           CALL POPREAL8(vb)
25262         ELSE
25263           CALL POPREAL8(vb)
25264           rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb
25265         END IF
25266       END DO
25267     END DO
25268   END IF
25269   CALL POPCONTROL1B(branch)
25270   IF (branch .EQ. 0) THEN
25271     CALL POPINTEGER4(ad_from11)
25272     CALL POPINTEGER4(ad_to11)
25273     DO i=ad_to11,ad_from11,-1
25274       DO k=ktf,kts,-1
25275         tempb58 = -(rdy*tendencyb(i, k, jts))
25276         vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*tempb58
25277         field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*tempb58
25278         field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*tempb58
25279         fieldb(i, k, jts) = fieldb(i, k, jts) + rv(i, k, jts+1)*tempb58
25280         rvb(i, k, jts+1) = rvb(i, k, jts+1) + field(i, k, jts)*tempb58
25281         CALL POPCONTROL1B(branch)
25282         IF (branch .EQ. 0) THEN
25283           CALL POPREAL8(vb)
25284         ELSE
25285           CALL POPREAL8(vb)
25286           rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb
25287         END IF
25288       END DO
25289     END DO
25290   END IF
25291   CALL POPCONTROL1B(branch)
25292   IF (branch .EQ. 0) THEN
25293     CALL POPINTEGER4(ad_from10)
25294     CALL POPINTEGER4(ad_to10)
25295     DO i=ad_to10,ad_from10,-1
25296       DO k=ktf,kts,-1
25297         tempb56 = -(rdy*tendencyb(i, k, j_end))
25298         tempb57 = field(i, k, j_end)*tempb56
25299         vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*tempb56
25300         field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*tempb56
25301         field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*&
25302 &         tempb56
25303         fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i&
25304 &         , k, jte-1))*tempb56
25305         rvb(i, k, jte) = rvb(i, k, jte) + tempb57
25306         rvb(i, k, jte-1) = rvb(i, k, jte-1) - tempb57
25307         CALL POPCONTROL1B(branch)
25308         IF (branch .EQ. 0) THEN
25309           CALL POPREAL8(vb)
25310         ELSE
25311           CALL POPREAL8(vb)
25312           rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb
25313           rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb
25314         END IF
25315       END DO
25316     END DO
25317   END IF
25318   CALL POPCONTROL1B(branch)
25319   IF (branch .EQ. 0) THEN
25320     CALL POPINTEGER4(ad_from9)
25321     CALL POPINTEGER4(ad_to9)
25322     DO i=ad_to9,ad_from9,-1
25323       DO k=ktf,kts,-1
25324         tempb54 = -(rdy*tendencyb(i, k, jts))
25325         tempb55 = field(i, k, jts)*tempb54
25326         vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*tempb54
25327         field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*tempb54
25328         field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*tempb54
25329         fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k&
25330 &         , jts))*tempb54
25331         rvb(i, k, jts+1) = rvb(i, k, jts+1) + tempb55
25332         rvb(i, k, jts) = rvb(i, k, jts) - tempb55
25333         CALL POPCONTROL1B(branch)
25334         IF (branch .EQ. 0) THEN
25335           CALL POPREAL8(vb)
25336         ELSE
25337           CALL POPREAL8(vb)
25338           rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb
25339           rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb
25340         END IF
25341       END DO
25342     END DO
25343   END IF
25344   CALL POPCONTROL1B(branch)
25345   IF (branch .EQ. 0) THEN
25346     CALL POPINTEGER4(ad_from8)
25347     CALL POPINTEGER4(ad_to8)
25348     DO j=ad_to8,ad_from8,-1
25349       DO k=ktf,kts,-1
25350         tempb52 = -(rdx*tendencyb(i_end, k, j))
25351         tempb53 = field(i_end, k, j)*tempb52
25352         ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*tempb52
25353         field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*tempb52
25354         field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*&
25355 &         tempb52
25356         fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(&
25357 &         ite-1, k, j))*tempb52
25358         rub(ite, k, j) = rub(ite, k, j) + tempb53
25359         rub(ite-1, k, j) = rub(ite-1, k, j) - tempb53
25360         CALL POPCONTROL1B(branch)
25361         IF (branch .EQ. 0) THEN
25362           CALL POPREAL8(ub)
25363         ELSE
25364           CALL POPREAL8(ub)
25365           rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb
25366           rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb
25367         END IF
25368       END DO
25369     END DO
25370   END IF
25371   CALL POPCONTROL1B(branch)
25372   IF (branch .EQ. 0) THEN
25373     CALL POPINTEGER4(ad_from7)
25374     CALL POPINTEGER4(ad_to7)
25375     DO j=ad_to7,ad_from7,-1
25376       DO k=ktf,kts,-1
25377         tempb50 = -(rdx*tendencyb(its, k, j))
25378         tempb51 = field(its, k, j)*tempb50
25379         ubb = (field_old(its+1, k, j)-field_old(its, k, j))*tempb50
25380         field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*tempb50
25381         field_oldb(its, k, j) = field_oldb(its, k, j) - ub*tempb50
25382         fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its&
25383 &         , k, j))*tempb50
25384         rub(its+1, k, j) = rub(its+1, k, j) + tempb51
25385         rub(its, k, j) = rub(its, k, j) - tempb51
25386         CALL POPCONTROL1B(branch)
25387         IF (branch .EQ. 0) THEN
25388           CALL POPREAL8(ub)
25389         ELSE
25390           CALL POPREAL8(ub)
25391           rub(its, k, j) = rub(its, k, j) + 0.5*ubb
25392           rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb
25393         END IF
25394       END DO
25395     END DO
25396   END IF
25397   CALL POPINTEGER4(ad_from6)
25398   CALL POPINTEGER4(ad_to6)
25399   DO j=ad_to6,ad_from6,-1
25400     CALL POPCONTROL1B(branch)
25401     IF (branch .NE. 0) THEN
25402       CALL POPINTEGER4(ad_to5)
25403       DO i=ad_to5,i_end_f+1,-1
25404         CALL POPCONTROL1B(branch)
25405         IF (branch .NE. 0) THEN
25406           DO k=ktf,kts,-1
25407             fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
25408             temp17 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i, &
25409 &             k, j)-field(i-1, k, j))
25410             temp20 = SIGN(1., vel)
25411             temp19 = temp20/12.
25412             temp18 = SIGN(1, time_step)
25413             tempb46 = vel*fqxb(i, k, j)
25414             tempb47 = 7.*tempb46/12.
25415             tempb48 = temp18*temp19*tempb46
25416             velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(i+&
25417 &             1, k, j)+field(i-2, k, j))/12.+temp18*(temp19*temp17))*&
25418 &             fqxb(i, k, j)
25419             fieldb(i, k, j) = fieldb(i, k, j) + tempb47 - 3.*tempb48
25420             fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb48 + tempb47
25421             fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb48 - tempb46/&
25422 &             12.
25423             fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb48 - tempb46/&
25424 &             12.
25425             fqxb(i, k, j) = 0.0
25426             tempb49 = dx*mu*fqxlb(i, k, j)/dt
25427             min14b = 0.5*field_old(i-1, k, j)*tempb49
25428             field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min14*&
25429 &             tempb49
25430             max11b = 0.5*field_old(i, k, j)*tempb49
25431             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max11*&
25432 &             tempb49
25433             mub0 = (0.5*(min14*field_old(i-1, k, j))+0.5*(max11*&
25434 &             field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
25435             fqxlb(i, k, j) = 0.0
25436             CALL POPCONTROL1B(branch)
25437             IF (branch .EQ. 0) THEN
25438               CALL POPREAL8(max11)
25439               y26b = max11b
25440             ELSE
25441               CALL POPREAL8(max11)
25442               y26b = 0.0
25443             END IF
25444             crb = y26b
25445             abs24b = -y26b
25446             CALL POPCONTROL1B(branch)
25447             IF (branch .EQ. 0) THEN
25448               crb = crb + abs24b
25449             ELSE
25450               crb = crb - abs24b
25451             END IF
25452             CALL POPCONTROL1B(branch)
25453             IF (branch .EQ. 0) THEN
25454               CALL POPREAL8(min14)
25455               y10b = min14b
25456             ELSE
25457               CALL POPREAL8(min14)
25458               y10b = 0.0
25459             END IF
25460             crb = crb + y10b
25461             abs9b = y10b
25462             CALL POPCONTROL1B(branch)
25463             IF (branch .EQ. 0) THEN
25464               crb = crb + abs9b
25465             ELSE
25466               crb = crb - abs9b
25467             END IF
25468             tempb45 = dt*crb/(dx*mu)
25469             velb = velb + tempb45
25470             mub0 = mub0 - vel*tempb45/mu
25471             CALL POPREAL8(vel)
25472             rub(i, k, j) = rub(i, k, j) + velb
25473             CALL POPREAL8(mu)
25474             mutb(i, j) = mutb(i, j) + 0.5*mub0
25475             mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
25476             CALL POPREAL8(dx)
25477           END DO
25478         END IF
25479         CALL POPCONTROL1B(branch)
25480         IF (branch .EQ. 0) THEN
25481           DO k=ktf,kts,-1
25482             fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
25483             tempb43 = 0.5*ru(i, k, j)*fqxb(i, k, j)
25484             rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1&
25485 &             , k, j))*fqxb(i, k, j)
25486             fieldb(i, k, j) = fieldb(i, k, j) + tempb43
25487             fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb43
25488             fqxb(i, k, j) = 0.0
25489             tempb44 = dx*mu*fqxlb(i, k, j)/dt
25490             min13b = 0.5*field_old(i-1, k, j)*tempb44
25491             field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min13*&
25492 &             tempb44
25493             max10b = 0.5*field_old(i, k, j)*tempb44
25494             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max10*&
25495 &             tempb44
25496             mub0 = (0.5*(min13*field_old(i-1, k, j))+0.5*(max10*&
25497 &             field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt
25498             fqxlb(i, k, j) = 0.0
25499             CALL POPCONTROL1B(branch)
25500             IF (branch .EQ. 0) THEN
25501               CALL POPREAL8(max10)
25502               y25b = max10b
25503             ELSE
25504               CALL POPREAL8(max10)
25505               y25b = 0.0
25506             END IF
25507             crb = y25b
25508             abs23b = -y25b
25509             CALL POPCONTROL1B(branch)
25510             IF (branch .EQ. 0) THEN
25511               crb = crb + abs23b
25512             ELSE
25513               crb = crb - abs23b
25514             END IF
25515             CALL POPCONTROL1B(branch)
25516             IF (branch .EQ. 0) THEN
25517               CALL POPREAL8(min13)
25518               y9b = min13b
25519             ELSE
25520               CALL POPREAL8(min13)
25521               y9b = 0.0
25522             END IF
25523             crb = crb + y9b
25524             abs8b = y9b
25525             CALL POPCONTROL1B(branch)
25526             IF (branch .EQ. 0) THEN
25527               crb = crb + abs8b
25528             ELSE
25529               crb = crb - abs8b
25530             END IF
25531             tempb42 = dt*crb/(dx*mu)
25532             velb = tempb42
25533             mub0 = mub0 - vel*tempb42/mu
25534             CALL POPREAL8(vel)
25535             rub(i, k, j) = rub(i, k, j) + velb
25536             CALL POPREAL8(mu)
25537             mutb(i, j) = mutb(i, j) + 0.5*mub0
25538             mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
25539             CALL POPREAL8(dx)
25540           END DO
25541         END IF
25542       END DO
25543     END IF
25544     CALL POPCONTROL1B(branch)
25545     IF (branch .EQ. 0) THEN
25546       CALL POPINTEGER4(ad_from5)
25547       DO i=i_start_f-1,ad_from5,-1
25548         CALL POPCONTROL1B(branch)
25549         IF (branch .NE. 0) THEN
25550           DO k=ktf,kts,-1
25551             fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
25552             temp13 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i, &
25553 &             k, j)-field(i-1, k, j))
25554             temp16 = SIGN(1., vel)
25555             temp15 = temp16/12.
25556             temp14 = SIGN(1, time_step)
25557             tempb38 = vel*fqxb(i, k, j)
25558             tempb39 = 7.*tempb38/12.
25559             tempb40 = temp14*temp15*tempb38
25560             velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(i+&
25561 &             1, k, j)+field(i-2, k, j))/12.+temp14*(temp15*temp13))*&
25562 &             fqxb(i, k, j)
25563             fieldb(i, k, j) = fieldb(i, k, j) + tempb39 - 3.*tempb40
25564             fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb40 + tempb39
25565             fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb40 - tempb38/&
25566 &             12.
25567             fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb40 - tempb38/&
25568 &             12.
25569             fqxb(i, k, j) = 0.0
25570             tempb41 = dx*mu*fqxlb(i, k, j)/dt
25571             min12b = 0.5*field_old(i-1, k, j)*tempb41
25572             field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min12*&
25573 &             tempb41
25574             max9b = 0.5*field_old(i, k, j)*tempb41
25575             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max9*tempb41
25576             mub0 = (0.5*(min12*field_old(i-1, k, j))+0.5*(max9*field_old&
25577 &             (i, k, j)))*dx*fqxlb(i, k, j)/dt
25578             fqxlb(i, k, j) = 0.0
25579             CALL POPCONTROL1B(branch)
25580             IF (branch .EQ. 0) THEN
25581               CALL POPREAL8(max9)
25582               y24b = max9b
25583             ELSE
25584               CALL POPREAL8(max9)
25585               y24b = 0.0
25586             END IF
25587             crb = y24b
25588             abs22b = -y24b
25589             CALL POPCONTROL1B(branch)
25590             IF (branch .EQ. 0) THEN
25591               crb = crb + abs22b
25592             ELSE
25593               crb = crb - abs22b
25594             END IF
25595             CALL POPCONTROL1B(branch)
25596             IF (branch .EQ. 0) THEN
25597               CALL POPREAL8(min12)
25598               y8b = min12b
25599             ELSE
25600               CALL POPREAL8(min12)
25601               y8b = 0.0
25602             END IF
25603             crb = crb + y8b
25604             abs7b = y8b
25605             CALL POPCONTROL1B(branch)
25606             IF (branch .EQ. 0) THEN
25607               crb = crb + abs7b
25608             ELSE
25609               crb = crb - abs7b
25610             END IF
25611             tempb37 = dt*crb/(dx*mu)
25612             velb = velb + tempb37
25613             mub0 = mub0 - vel*tempb37/mu
25614             CALL POPREAL8(vel)
25615             rub(i, k, j) = rub(i, k, j) + velb
25616             CALL POPREAL8(mu)
25617             mutb(i, j) = mutb(i, j) + 0.5*mub0
25618             mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
25619             CALL POPREAL8(dx)
25620           END DO
25621         END IF
25622         CALL POPCONTROL1B(branch)
25623         IF (branch .EQ. 0) THEN
25624           DO k=ktf,kts,-1
25625             fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
25626             tempb35 = 0.5*ru(i, k, j)*fqxb(i, k, j)
25627             rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1&
25628 &             , k, j))*fqxb(i, k, j)
25629             fieldb(i, k, j) = fieldb(i, k, j) + tempb35
25630             fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb35
25631             fqxb(i, k, j) = 0.0
25632             tempb36 = dx*mu*fqxlb(i, k, j)/dt
25633             min11b = 0.5*field_old(i-1, k, j)*tempb36
25634             field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min11*&
25635 &             tempb36
25636             max8b = 0.5*field_old(i, k, j)*tempb36
25637             field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max8*tempb36
25638             mub0 = (0.5*(min11*field_old(i-1, k, j))+0.5*(max8*field_old&
25639 &             (i, k, j)))*dx*fqxlb(i, k, j)/dt
25640             fqxlb(i, k, j) = 0.0
25641             CALL POPCONTROL1B(branch)
25642             IF (branch .EQ. 0) THEN
25643               CALL POPREAL8(max8)
25644               y23b = max8b
25645             ELSE
25646               CALL POPREAL8(max8)
25647               y23b = 0.0
25648             END IF
25649             crb = y23b
25650             abs21b = -y23b
25651             CALL POPCONTROL1B(branch)
25652             IF (branch .EQ. 0) THEN
25653               crb = crb + abs21b
25654             ELSE
25655               crb = crb - abs21b
25656             END IF
25657             CALL POPCONTROL1B(branch)
25658             IF (branch .EQ. 0) THEN
25659               CALL POPREAL8(min11)
25660               y7b = min11b
25661             ELSE
25662               CALL POPREAL8(min11)
25663               y7b = 0.0
25664             END IF
25665             crb = crb + y7b
25666             abs6b = y7b
25667             CALL POPCONTROL1B(branch)
25668             IF (branch .EQ. 0) THEN
25669               crb = crb + abs6b
25670             ELSE
25671               crb = crb - abs6b
25672             END IF
25673             velb = dt*crb/dx
25674             CALL POPREAL8(vel)
25675             rub(i, k, j) = rub(i, k, j) + velb/mu
25676             mub0 = mub0 - ru(i, k, j)*velb/mu**2
25677             CALL POPREAL8(mu)
25678             mutb(i, j) = mutb(i, j) + 0.5*mub0
25679             mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
25680             CALL POPREAL8(dx)
25681           END DO
25682         END IF
25683       END DO
25684     END IF
25685     DO k=ktf,kts,-1
25686       DO i=i_end_f,i_start_f,-1
25687         fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j)
25688         wi0 = gi0/(eps1+beta0)**pw
25689         wi1 = gi1/(eps1+beta1)**pw
25690         wi2 = gi2/(eps1+beta2)**pw
25691         sumwk = wi0 + wi1 + wi2
25692         tempb27 = vel*fqxb(i, k, j)/sumwk
25693         tempb28 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k, j)/sumwk
25694         f0b = wi0*tempb27
25695         f1b = wi1*tempb27
25696         f2b = wi2*tempb27
25697         velb = tempb28
25698         sumwkb = -(vel*tempb28/sumwk)
25699         wi0b = sumwkb + f0*tempb27
25700         wi1b = sumwkb + f1*tempb27
25701         wi2b = sumwkb + f2*tempb27
25702         fqxb(i, k, j) = 0.0
25703         temp12 = (eps1+beta2)**pw
25704         IF (eps1 + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw&
25705 &           ))) THEN
25706           beta2b = 0.0
25707         ELSE
25708           beta2b = -(gi2*pw*(eps1+beta2)**(pw-1)*wi2b/temp12**2)
25709         END IF
25710         temp11 = (eps1+beta1)**pw
25711         IF (eps1 + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw&
25712 &           ))) THEN
25713           beta1b = 0.0
25714         ELSE
25715           beta1b = -(gi1*pw*(eps1+beta1)**(pw-1)*wi1b/temp11**2)
25716         END IF
25717         temp10 = (eps1+beta0)**pw
25718         IF (eps1 + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw&
25719 &           ))) THEN
25720           beta0b = 0.0
25721         ELSE
25722           beta0b = -(gi0*pw*(eps1+beta0)**(pw-1)*wi0b/temp10**2)
25723         END IF
25724         CALL POPREAL8(beta2)
25725         tempb29 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
25726         tempb30 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
25727         qip2b = tempb30 - f2b/6. + tempb29
25728         CALL POPREAL8(beta1)
25729         tempb31 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
25730         tempb34 = 2*(qim1-qip1)*beta1b/4.
25731         qip1b = tempb31 - tempb34 + f1b/3. + 5.*f2b/6. - 4.*tempb30 - 2.&
25732 &         *tempb29
25733         CALL POPREAL8(beta0)
25734         tempb33 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
25735         tempb32 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
25736         qib = f2b/3. - 2.*tempb31 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb32 &
25737 &         + tempb33 + 3.*tempb30 + tempb29
25738         qim1b = tempb34 - 4.*tempb32 - 7.*f0b/6. - f1b/6. - 2.*tempb33 +&
25739 &         tempb31
25740         qim2b = f0b/3. + tempb32 + tempb33
25741         CALL POPREAL8(f2)
25742         CALL POPREAL8(f1)
25743         CALL POPREAL8(f0)
25744         CALL POPCONTROL1B(branch)
25745         IF (branch .EQ. 0) THEN
25746           CALL POPREAL8(qim2)
25747           fieldb(i-3, k, j) = fieldb(i-3, k, j) + qim2b
25748           CALL POPREAL8(qim1)
25749           fieldb(i-2, k, j) = fieldb(i-2, k, j) + qim1b
25750           CALL POPREAL8(qi)
25751           fieldb(i-1, k, j) = fieldb(i-1, k, j) + qib
25752           CALL POPREAL8(qip1)
25753           fieldb(i, k, j) = fieldb(i, k, j) + qip1b
25754           CALL POPREAL8(qip2)
25755           fieldb(i+1, k, j) = fieldb(i+1, k, j) + qip2b
25756         ELSE
25757           CALL POPREAL8(qim2)
25758           fieldb(i+2, k, j) = fieldb(i+2, k, j) + qim2b
25759           CALL POPREAL8(qim1)
25760           fieldb(i+1, k, j) = fieldb(i+1, k, j) + qim1b
25761           CALL POPREAL8(qi)
25762           fieldb(i, k, j) = fieldb(i, k, j) + qib
25763           CALL POPREAL8(qip1)
25764           fieldb(i-1, k, j) = fieldb(i-1, k, j) + qip1b
25765           CALL POPREAL8(qip2)
25766           fieldb(i-2, k, j) = fieldb(i-2, k, j) + qip2b
25767         END IF
25768         tempb26 = dx*mu*fqxlb(i, k, j)/dt
25769         min10b = 0.5*field_old(i-1, k, j)*tempb26
25770         field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min10*&
25771 &         tempb26
25772         max7b = 0.5*field_old(i, k, j)*tempb26
25773         field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max7*tempb26
25774         mub0 = (0.5*(min10*field_old(i-1, k, j))+0.5*(max7*field_old(i, &
25775 &         k, j)))*dx*fqxlb(i, k, j)/dt
25776         fqxlb(i, k, j) = 0.0
25777         CALL POPCONTROL1B(branch)
25778         IF (branch .EQ. 0) THEN
25779           CALL POPREAL8(max7)
25780           y22b = max7b
25781         ELSE
25782           CALL POPREAL8(max7)
25783           y22b = 0.0
25784         END IF
25785         crb = y22b
25786         abs20b = -y22b
25787         CALL POPCONTROL1B(branch)
25788         IF (branch .EQ. 0) THEN
25789           crb = crb + abs20b
25790         ELSE
25791           crb = crb - abs20b
25792         END IF
25793         CALL POPCONTROL1B(branch)
25794         IF (branch .EQ. 0) THEN
25795           CALL POPREAL8(min10)
25796           y6b = min10b
25797         ELSE
25798           CALL POPREAL8(min10)
25799           y6b = 0.0
25800         END IF
25801         crb = crb + y6b
25802         abs5b = y6b
25803         CALL POPCONTROL1B(branch)
25804         IF (branch .EQ. 0) THEN
25805           crb = crb + abs5b
25806         ELSE
25807           crb = crb - abs5b
25808         END IF
25809         tempb25 = dt*crb/(dx*mu)
25810         velb = velb + tempb25
25811         mub0 = mub0 - vel*tempb25/mu
25812         CALL POPREAL8(vel)
25813         rub(i, k, j) = rub(i, k, j) + velb
25814         CALL POPREAL8(mu)
25815         mutb(i, j) = mutb(i, j) + 0.5*mub0
25816         mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0
25817         CALL POPREAL8(dx)
25818       END DO
25819     END DO
25820   END DO
25821   CALL POPCONTROL1B(branch)
25822   CALL POPCONTROL1B(branch)
25823   CALL POPCONTROL1B(branch)
25824   CALL POPCONTROL1B(branch)
25825   CALL POPINTEGER4(ad_from4)
25826   CALL POPINTEGER4(ad_to4)
25827   DO j=ad_to4,ad_from4,-1
25828     CALL POPCONTROL3B(branch)
25829     IF (branch .LT. 3) THEN
25830       IF (branch .NE. 0) THEN
25831         IF (branch .EQ. 1) THEN
25832           DO k=ktf,kts,-1
25833             CALL POPINTEGER4(ad_from3)
25834             CALL POPINTEGER4(ad_to3)
25835             DO i=ad_to3,ad_from3,-1
25836               fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
25837               temp6 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i&
25838 &               , k, j)-field(i, k, j-1))
25839               temp9 = SIGN(1., vel)
25840               temp8 = temp9/12.
25841               temp7 = SIGN(1, time_step)
25842               tempb21 = vel*fqyb(i, k, j)
25843               tempb22 = 7.*tempb21/12.
25844               tempb23 = temp7*temp8*tempb21
25845               velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(&
25846 &               i, k, j+1)+field(i, k, j-2))/12.+temp7*(temp8*temp6))*&
25847 &               fqyb(i, k, j)
25848               fieldb(i, k, j) = fieldb(i, k, j) + tempb22 - 3.*tempb23
25849               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb23 + &
25850 &               tempb22
25851               fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb23 - tempb21/&
25852 &               12.
25853               fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb23 - tempb21/&
25854 &               12.
25855               fqyb(i, k, j) = 0.0
25856               tempb24 = dy*mu*fqylb(i, k, j)/dt
25857               min7b = 0.5*field_old(i, k, j-1)*tempb24
25858               field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min7*&
25859 &               tempb24
25860               max6b = 0.5*field_old(i, k, j)*tempb24
25861               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max6*&
25862 &               tempb24
25863               mub0 = (0.5*(min7*field_old(i, k, j-1))+0.5*(max6*&
25864 &               field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
25865               fqylb(i, k, j) = 0.0
25866               CALL POPCONTROL1B(branch)
25867               IF (branch .EQ. 0) THEN
25868                 CALL POPREAL8(max6)
25869                 y21b = max6b
25870               ELSE
25871                 CALL POPREAL8(max6)
25872                 y21b = 0.0
25873               END IF
25874               crb = y21b
25875               abs19b = -y21b
25876               CALL POPCONTROL1B(branch)
25877               IF (branch .EQ. 0) THEN
25878                 crb = crb + abs19b
25879               ELSE
25880                 crb = crb - abs19b
25881               END IF
25882               CALL POPCONTROL1B(branch)
25883               IF (branch .EQ. 0) THEN
25884                 CALL POPREAL8(min7)
25885                 y5b = min7b
25886               ELSE
25887                 CALL POPREAL8(min7)
25888                 y5b = 0.0
25889               END IF
25890               crb = crb + y5b
25891               abs4b = y5b
25892               CALL POPCONTROL1B(branch)
25893               IF (branch .EQ. 0) THEN
25894                 crb = crb + abs4b
25895               ELSE
25896                 crb = crb - abs4b
25897               END IF
25898               tempb20 = dt*crb/(dy*mu)
25899               velb = velb + tempb20
25900               mub0 = mub0 - vel*tempb20/mu
25901               CALL POPREAL8(vel)
25902               rvb(i, k, j) = rvb(i, k, j) + velb
25903               CALL POPREAL8(mu)
25904               mutb(i, j) = mutb(i, j) + 0.5*mub0
25905               mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
25906               CALL POPREAL8(dy)
25907             END DO
25908           END DO
25909         ELSE
25910           DO k=ktf,kts,-1
25911             CALL POPINTEGER4(ad_from2)
25912             CALL POPINTEGER4(ad_to2)
25913             DO i=ad_to2,ad_from2,-1
25914               fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
25915               tempb18 = 0.5*rv(i, k, j)*fqyb(i, k, j)
25916               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
25917 &               , k, j-1))*fqyb(i, k, j)
25918               fieldb(i, k, j) = fieldb(i, k, j) + tempb18
25919               fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb18
25920               fqyb(i, k, j) = 0.0
25921               tempb19 = dy*mu*fqylb(i, k, j)/dt
25922               min6b = 0.5*field_old(i, k, j-1)*tempb19
25923               field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min6*&
25924 &               tempb19
25925               max5b = 0.5*field_old(i, k, j)*tempb19
25926               field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max5*&
25927 &               tempb19
25928               mub0 = (0.5*(min6*field_old(i, k, j-1))+0.5*(max5*&
25929 &               field_old(i, k, j)))*dy*fqylb(i, k, j)/dt
25930               fqylb(i, k, j) = 0.0
25931               CALL POPCONTROL1B(branch)
25932               IF (branch .EQ. 0) THEN
25933                 CALL POPREAL8(max5)
25934                 y20b = max5b
25935               ELSE
25936                 CALL POPREAL8(max5)
25937                 y20b = 0.0
25938               END IF
25939               crb = y20b
25940               abs18b = -y20b
25941               CALL POPCONTROL1B(branch)
25942               IF (branch .EQ. 0) THEN
25943                 crb = crb + abs18b
25944               ELSE
25945                 crb = crb - abs18b
25946               END IF
25947               CALL POPCONTROL1B(branch)
25948               IF (branch .EQ. 0) THEN
25949                 CALL POPREAL8(min6)
25950                 y4b = min6b
25951               ELSE
25952                 CALL POPREAL8(min6)
25953                 y4b = 0.0
25954               END IF
25955               crb = crb + y4b
25956               abs3b = y4b
25957               CALL POPCONTROL1B(branch)
25958               IF (branch .EQ. 0) THEN
25959                 crb = crb + abs3b
25960               ELSE
25961                 crb = crb - abs3b
25962               END IF
25963               tempb17 = dt*crb/(dy*mu)
25964               velb = tempb17
25965               mub0 = mub0 - vel*tempb17/mu
25966               CALL POPREAL8(vel)
25967               rvb(i, k, j) = rvb(i, k, j) + velb
25968               CALL POPREAL8(mu)
25969               mutb(i, j) = mutb(i, j) + 0.5*mub0
25970               mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
25971               CALL POPREAL8(dy)
25972             END DO
25973           END DO
25974         END IF
25975       END IF
25976     ELSE IF (branch .EQ. 3) THEN
25977       DO k=ktf,kts,-1
25978         CALL POPINTEGER4(ad_from1)
25979         CALL POPINTEGER4(ad_to1)
25980         DO i=ad_to1,ad_from1,-1
25981           fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
25982           temp2 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k, &
25983 &           j)-field(i, k, j-1))
25984           temp5 = SIGN(1., vel)
25985           temp4 = temp5/12.
25986           temp3 = SIGN(1, time_step)
25987           tempb13 = vel*fqyb(i, k, j)
25988           tempb14 = 7.*tempb13/12.
25989           tempb15 = temp3*temp4*tempb13
25990           velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i, k&
25991 &           , j+1)+field(i, k, j-2))/12.+temp3*(temp4*temp2))*fqyb(i, k&
25992 &           , j)
25993           fieldb(i, k, j) = fieldb(i, k, j) + tempb14 - 3.*tempb15
25994           fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb15 + tempb14
25995           fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb15 - tempb13/12.
25996           fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb15 - tempb13/12.
25997           fqyb(i, k, j) = 0.0
25998           tempb16 = dy*mu*fqylb(i, k, j)/dt
25999           min5b = 0.5*field_old(i, k, j-1)*tempb16
26000           field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min5*&
26001 &           tempb16
26002           max4b = 0.5*field_old(i, k, j)*tempb16
26003           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max4*tempb16
26004           mub0 = (0.5*(min5*field_old(i, k, j-1))+0.5*(max4*field_old(i&
26005 &           , k, j)))*dy*fqylb(i, k, j)/dt
26006           fqylb(i, k, j) = 0.0
26007           CALL POPCONTROL1B(branch)
26008           IF (branch .EQ. 0) THEN
26009             CALL POPREAL8(max4)
26010             y19b = max4b
26011           ELSE
26012             CALL POPREAL8(max4)
26013             y19b = 0.0
26014           END IF
26015           crb = y19b
26016           abs17b = -y19b
26017           CALL POPCONTROL1B(branch)
26018           IF (branch .EQ. 0) THEN
26019             crb = crb + abs17b
26020           ELSE
26021             crb = crb - abs17b
26022           END IF
26023           CALL POPCONTROL1B(branch)
26024           IF (branch .EQ. 0) THEN
26025             CALL POPREAL8(min5)
26026             y3b = min5b
26027           ELSE
26028             CALL POPREAL8(min5)
26029             y3b = 0.0
26030           END IF
26031           crb = crb + y3b
26032           abs2b = y3b
26033           CALL POPCONTROL1B(branch)
26034           IF (branch .EQ. 0) THEN
26035             crb = crb + abs2b
26036           ELSE
26037             crb = crb - abs2b
26038           END IF
26039           tempb12 = dt*crb/(dy*mu)
26040           velb = velb + tempb12
26041           mub0 = mub0 - vel*tempb12/mu
26042           CALL POPREAL8(vel)
26043           rvb(i, k, j) = rvb(i, k, j) + velb
26044           CALL POPREAL8(mu)
26045           mutb(i, j) = mutb(i, j) + 0.5*mub0
26046           mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
26047           CALL POPREAL8(dy)
26048         END DO
26049       END DO
26050     ELSE IF (branch .EQ. 4) THEN
26051       DO k=ktf,kts,-1
26052         CALL POPINTEGER4(ad_from0)
26053         CALL POPINTEGER4(ad_to0)
26054         DO i=ad_to0,ad_from0,-1
26055           fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
26056           tempb10 = 0.5*rv(i, k, j)*fqyb(i, k, j)
26057           rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k, &
26058 &           j-1))*fqyb(i, k, j)
26059           fieldb(i, k, j) = fieldb(i, k, j) + tempb10
26060           fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb10
26061           fqyb(i, k, j) = 0.0
26062           tempb11 = dy*mu*fqylb(i, k, j)/dt
26063           min4b = 0.5*field_old(i, k, j-1)*tempb11
26064           field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min4*&
26065 &           tempb11
26066           max3b = 0.5*field_old(i, k, j)*tempb11
26067           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max3*tempb11
26068           mub0 = (0.5*(min4*field_old(i, k, j-1))+0.5*(max3*field_old(i&
26069 &           , k, j)))*dy*fqylb(i, k, j)/dt
26070           fqylb(i, k, j) = 0.0
26071           CALL POPCONTROL1B(branch)
26072           IF (branch .EQ. 0) THEN
26073             CALL POPREAL8(max3)
26074             y18b = max3b
26075           ELSE
26076             CALL POPREAL8(max3)
26077             y18b = 0.0
26078           END IF
26079           crb = y18b
26080           abs16b = -y18b
26081           CALL POPCONTROL1B(branch)
26082           IF (branch .EQ. 0) THEN
26083             crb = crb + abs16b
26084           ELSE
26085             crb = crb - abs16b
26086           END IF
26087           CALL POPCONTROL1B(branch)
26088           IF (branch .EQ. 0) THEN
26089             CALL POPREAL8(min4)
26090             y2b = min4b
26091           ELSE
26092             CALL POPREAL8(min4)
26093             y2b = 0.0
26094           END IF
26095           crb = crb + y2b
26096           abs1b = y2b
26097           CALL POPCONTROL1B(branch)
26098           IF (branch .EQ. 0) THEN
26099             crb = crb + abs1b
26100           ELSE
26101             crb = crb - abs1b
26102           END IF
26103           tempb9 = dt*crb/(dy*mu)
26104           velb = tempb9
26105           mub0 = mub0 - vel*tempb9/mu
26106           CALL POPREAL8(vel)
26107           rvb(i, k, j) = rvb(i, k, j) + velb
26108           CALL POPREAL8(mu)
26109           mutb(i, j) = mutb(i, j) + 0.5*mub0
26110           mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
26111           CALL POPREAL8(dy)
26112         END DO
26113       END DO
26114     ELSE
26115       DO k=ktf,kts,-1
26116         CALL POPINTEGER4(ad_from)
26117         CALL POPINTEGER4(ad_to)
26118         DO i=ad_to,ad_from,-1
26119           fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j)
26120           wi0 = gi0/(eps1+beta0)**pw
26121           wi1 = gi1/(eps1+beta1)**pw
26122           wi2 = gi2/(eps1+beta2)**pw
26123           sumwk = wi0 + wi1 + wi2
26124           tempb1 = vel*fqyb(i, k, j)/sumwk
26125           tempb2 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, j)/sumwk
26126           f0b = wi0*tempb1
26127           f1b = wi1*tempb1
26128           f2b = wi2*tempb1
26129           velb = tempb2
26130           sumwkb = -(vel*tempb2/sumwk)
26131           wi0b = sumwkb + f0*tempb1
26132           wi1b = sumwkb + f1*tempb1
26133           wi2b = sumwkb + f2*tempb1
26134           fqyb(i, k, j) = 0.0
26135           temp1 = (eps1+beta2)**pw
26136           IF (eps1 + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
26137 &             pw))) THEN
26138             beta2b = 0.0
26139           ELSE
26140             beta2b = -(gi2*pw*(eps1+beta2)**(pw-1)*wi2b/temp1**2)
26141           END IF
26142           temp0 = (eps1+beta1)**pw
26143           IF (eps1 + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
26144 &             pw))) THEN
26145             beta1b = 0.0
26146           ELSE
26147             beta1b = -(gi1*pw*(eps1+beta1)**(pw-1)*wi1b/temp0**2)
26148           END IF
26149           temp = (eps1+beta0)**pw
26150           IF (eps1 + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
26151 &             pw))) THEN
26152             beta0b = 0.0
26153           ELSE
26154             beta0b = -(gi0*pw*(eps1+beta0)**(pw-1)*wi0b/temp**2)
26155           END IF
26156           CALL POPREAL8(beta2)
26157           tempb3 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
26158           tempb4 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
26159           qip2b = tempb4 - f2b/6. + tempb3
26160           CALL POPREAL8(beta1)
26161           tempb5 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
26162           tempb8 = 2*(qim1-qip1)*beta1b/4.
26163           qip1b = tempb5 - tempb8 + f1b/3. + 5.*f2b/6. - 4.*tempb4 - 2.*&
26164 &           tempb3
26165           CALL POPREAL8(beta0)
26166           tempb7 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
26167           tempb6 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
26168           qib = f2b/3. - 2.*tempb5 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb6 &
26169 &           + tempb7 + 3.*tempb4 + tempb3
26170           qim1b = tempb8 - 4.*tempb6 - 7.*f0b/6. - f1b/6. - 2.*tempb7 + &
26171 &           tempb5
26172           qim2b = f0b/3. + tempb6 + tempb7
26173           CALL POPREAL8(f2)
26174           CALL POPREAL8(f1)
26175           CALL POPREAL8(f0)
26176           CALL POPCONTROL1B(branch)
26177           IF (branch .EQ. 0) THEN
26178             CALL POPREAL8(qim2)
26179             fieldb(i, k, j-3) = fieldb(i, k, j-3) + qim2b
26180             CALL POPREAL8(qim1)
26181             fieldb(i, k, j-2) = fieldb(i, k, j-2) + qim1b
26182             CALL POPREAL8(qi)
26183             fieldb(i, k, j-1) = fieldb(i, k, j-1) + qib
26184             CALL POPREAL8(qip1)
26185             fieldb(i, k, j) = fieldb(i, k, j) + qip1b
26186             CALL POPREAL8(qip2)
26187             fieldb(i, k, j+1) = fieldb(i, k, j+1) + qip2b
26188           ELSE
26189             CALL POPREAL8(qim2)
26190             fieldb(i, k, j+2) = fieldb(i, k, j+2) + qim2b
26191             CALL POPREAL8(qim1)
26192             fieldb(i, k, j+1) = fieldb(i, k, j+1) + qim1b
26193             CALL POPREAL8(qi)
26194             fieldb(i, k, j) = fieldb(i, k, j) + qib
26195             CALL POPREAL8(qip1)
26196             fieldb(i, k, j-1) = fieldb(i, k, j-1) + qip1b
26197             CALL POPREAL8(qip2)
26198             fieldb(i, k, j-2) = fieldb(i, k, j-2) + qip2b
26199           END IF
26200           tempb0 = dy*mu*fqylb(i, k, j)/dt
26201           min3b = 0.5*field_old(i, k, j-1)*tempb0
26202           field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min3*&
26203 &           tempb0
26204           max2b = 0.5*field_old(i, k, j)*tempb0
26205           field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max2*tempb0
26206           mub0 = (0.5*(min3*field_old(i, k, j-1))+0.5*(max2*field_old(i&
26207 &           , k, j)))*dy*fqylb(i, k, j)/dt
26208           fqylb(i, k, j) = 0.0
26209           CALL POPCONTROL1B(branch)
26210           IF (branch .EQ. 0) THEN
26211             CALL POPREAL8(max2)
26212             y17b = max2b
26213           ELSE
26214             CALL POPREAL8(max2)
26215             y17b = 0.0
26216           END IF
26217           crb = y17b
26218           abs15b = -y17b
26219           CALL POPCONTROL1B(branch)
26220           IF (branch .EQ. 0) THEN
26221             crb = crb + abs15b
26222           ELSE
26223             crb = crb - abs15b
26224           END IF
26225           CALL POPCONTROL1B(branch)
26226           IF (branch .EQ. 0) THEN
26227             CALL POPREAL8(min3)
26228             y1b = min3b
26229           ELSE
26230             CALL POPREAL8(min3)
26231             y1b = 0.0
26232           END IF
26233           crb = crb + y1b
26234           abs0b = y1b
26235           CALL POPCONTROL1B(branch)
26236           IF (branch .EQ. 0) THEN
26237             crb = crb + abs0b
26238           ELSE
26239             crb = crb - abs0b
26240           END IF
26241           tempb = dt*crb/(dy*mu)
26242           velb = velb + tempb
26243           mub0 = mub0 - vel*tempb/mu
26244           CALL POPREAL8(vel)
26245           rvb(i, k, j) = rvb(i, k, j) + velb
26246           CALL POPREAL8(mu)
26247           mutb(i, j) = mutb(i, j) + 0.5*mub0
26248           mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0
26249           CALL POPREAL8(dy)
26250         END DO
26251       END DO
26252     END IF
26253   END DO
26254   CALL POPCONTROL1B(branch)
26255   CALL POPCONTROL1B(branch)
26256   CALL POPCONTROL1B(branch)
26257   CALL POPCONTROL1B(branch)
26258 END SUBROUTINE A_ADVECT_SCALAR_WENOPD
26259
26260    SUBROUTINE a_advect_scalar_mono(field,a_field,field_old,a_field_old,tendency, &
26261    a_tendency,h_tendency,a_h_tendency,z_tendency,a_z_tendency,ru,a_ru,rv,a_rv,rom,a_rom,mut,a_mut,mub,mu_old,a_mu_old, &
26262    config_flags,tenddec,msfux,msfuy,msfvx,msfvy,msftx,msfty,fzm,fzp,rdx,rdy,rdzw,dt,ids,ide,jds, &
26263    jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
26264
26265 !PART I: DECLARATION OF VARIABLES
26266
26267    IMPLICIT NONE
26268
26269    INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ
26270    TYPE(grid_config_rec_type) :: config_flags
26271    LOGICAL :: tenddec
26272    INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
26273    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,field_old,a_field_old, &
26274    ru,a_ru,rv,a_rv,rom,a_rom
26275    REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut,mub,mu_old,a_mu_old
26276    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
26277    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: h_tendency, z_tendency
26278    REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_h_tendency, a_z_tendency
26279    REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
26280    REAL,DIMENSION(kms:kme) :: fzm,fzp,rdzw
26281    REAL :: rdx,rdy,dt
26282    INTEGER :: i,j,k,itf,jtf,ktf
26283    INTEGER :: i_start,i_end,j_start,j_end
26284    INTEGER :: i_start_f,i_end_f,j_start_f,j_end_f
26285    INTEGER :: jmin,jmax,jp,jm,imin,imax
26286    REAL :: ub,a_ub,vb,a_vb
26287    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqx,a_fqx,fqy,a_fqy,fqz,a_fqz
26288    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqxl,a_fqxl,fqyl,a_fqyl,fqzl,a_fqzl
26289    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: qmin,a_qmin,qmax,a_qmax
26290    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: scale_in,a_scale_in,scale_out,a_scale_out
26291    REAL :: ph_upwind,a_ph_upwind
26292    INTEGER :: horz_order,vert_order
26293    LOGICAL :: degrade_xs,degrade_ys
26294    LOGICAL :: degrade_xe,degrade_ye
26295    INTEGER :: jp1,jp0,jtmp
26296    REAL :: flux_out,a_flux_out,ph_low,a_ph_low,flux_in,a_flux_in,ph_hi,a_ph_hi,scale,a_scale
26297    REAL,PARAMETER :: eps =1.e-20
26298    REAL :: flux3,Diff_flux3,flux4,Diff_flux4,flux5,Diff_flux5,flux6,Diff_flux6,flux_upwind, &
26299    Diff_flux_upwind
26300    REAL :: q_im3,Diff_q_im3,q_im2,Diff_q_im2,q_im1,Diff_q_im1,q_i,Diff_q_i,q_ip1,Diff_q_ip1, &
26301    q_ip2,Diff_q_ip2,ua,Diff_ua,vel,a_vel,cr,Diff_cr,a_cr
26302
26303    Diff_flux4(q_im2, Diff_q_im2,q_im1, Diff_q_im1,q_i, Diff_q_i,q_ip1, Diff_q_ip1, &
26304    ua, Diff_ua) =(7./12.)*(Diff_q_i +Diff_q_im1) -(1./12.)*(Diff_q_ip1 +Diff_q_im2)
26305    flux4(q_im2,q_im1,q_i,q_ip1,ua) =(7./12.)*(q_i +q_im1) -(1./12.)*(q_ip1 +q_im2)
26306
26307    Diff_flux3(q_im2, Diff_q_im2,q_im1, Diff_q_im1,q_i, Diff_q_i,q_ip1, Diff_q_ip1, &
26308    ua, Diff_ua) =Diff_flux4(q_im2,Diff_q_im2,q_im1,Diff_q_im1,q_i,Diff_q_i,q_ip1, &
26309    Diff_q_ip1,ua,Diff_ua) +sign(1., ua) *(1./12.)*((Diff_q_ip1 -Diff_q_im2) &
26310    -3.*(Diff_q_i -Diff_q_im1))
26311    flux3(q_im2,q_im1,q_i,q_ip1,ua) =flux4(q_im2,q_im1,q_i,q_ip1,ua) +sign(1., ua) &
26312    *(1./12.)*((q_ip1 -q_im2) -3.*(q_i -q_im1))
26313
26314    Diff_flux6(q_im3, Diff_q_im3,q_im2, Diff_q_im2,q_im1, Diff_q_im1,q_i, Diff_q_i, &
26315    q_ip1, Diff_q_ip1,q_ip2, Diff_q_ip2,ua, Diff_ua) =(37./60.)*(Diff_q_i +Diff_q_im1) &
26316    -(2./15.)*(Diff_q_ip1 +Diff_q_im2) +(1./60.)*(Diff_q_ip2 +Diff_q_im3)
26317    flux6(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2,ua) =(37./60.)*(q_i +q_im1) -(2./15.) &
26318   *(q_ip1 +q_im2) +(1./60.)*(q_ip2 +q_im3)
26319
26320    Diff_flux5(q_im3, Diff_q_im3,q_im2, Diff_q_im2,q_im1, Diff_q_im1,q_i, Diff_q_i, &
26321    q_ip1, Diff_q_ip1,q_ip2, Diff_q_ip2,ua, Diff_ua) =Diff_flux6(q_im3,Diff_q_im3,q_im2, &
26322    Diff_q_im2,q_im1,Diff_q_im1,q_i,Diff_q_i,q_ip1,Diff_q_ip1,q_ip2,Diff_q_ip2,ua, &
26323    Diff_ua) -sign(1., ua) *(1./60.)*((Diff_q_ip2 -Diff_q_im3) -5.*(Diff_q_ip1 - &
26324    Diff_q_im2) +10.*(Diff_q_i -Diff_q_im1))
26325    flux5(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2,ua) =flux6(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2, &
26326    ua) -sign(1., ua) *(1./60.)*((q_ip2 -q_im3) -5.*(q_ip1 -q_im2) +10.*(q_i -q_im1))
26327
26328    Diff_flux_upwind(q_im1, Diff_q_im1,q_i, Diff_q_i,cr, Diff_cr) =0.5 *(1.+sign(1., cr)) &
26329   *Diff_q_im1 +0.5 *(1.-sign(1., cr))*Diff_q_i
26330    flux_upwind(q_im1,q_i,cr) =0.5 *(1.+sign(1., cr))*q_im1 +0.5 *(1.-sign(1., cr))*q_i
26331
26332    LOGICAL,PARAMETER :: mono_limit =.true.
26333
26334    REAL :: Keep_Lpb3_cr
26335    REAL :: Keep_Lpb7_ub
26336    REAL :: Keep_Lpb11_vb
26337    REAL :: Keep_Lpb21_vel
26338    REAL :: Keep_Lpb21_cr
26339    INTEGER :: IX1,IX2,IX3
26340
26341    REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
26342    a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, &
26343    Tmpv009,a_Tmpv10,Tmpv010,a_Tmpv11,Tmpv011,a_Tmpv12,Tmpv012,gwalls
26344
26345    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv2400,Tmpv2401,Tmpv2402,Tmpv2403,Tmpv2404,Tmpv2405
26346    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv600,Tmpv601,Tmpv602,Tmpv603
26347    REAL,DIMENSION(its-2:ite+2,kts:kte) :: Tmpv604,Tmpv605,Tmpv606,Tmpv607,Tmpv608, &
26348        Tmpv609,Tmpv6010,Tmpv6011,Tmpv6012,Tmpv6013,Tmpv6014,Tmpv6015,Tmpv6016, &
26349        Tmpv6017,Tmpv6018,Tmpv6019
26350    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv700,Tmpv701,Tmpv702,Tmpv703
26351    REAL,DIMENSION(kts:kte,jts-2:jte+2) :: Tmpv704,Tmpv705,Tmpv706,Tmpv707,Tmpv708, &
26352        Tmpv709,Tmpv710,Tmpv711,Tmpv712,Tmpv713,Tmpv714,Tmpv715,Tmpv716, &
26353        Tmpv717,Tmpv718,Tmpv719
26354    REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv800,Tmpv801,Tmpv802,Tmpv803
26355    REAL,DIMENSION(its-2:ite+2,jts-2:jte+2) :: Tmpv804,Tmpv805,Tmpv806,Tmpv807,Tmpv808, &
26356        Tmpv809,Tmpv810,Tmpv811
26357
26358 !PART II: CALCULATIONS OF B. S. TRAJECTORY
26359
26360 !LPB[0]
26361      ktf=MIN(kte,kde-1)
26362      horz_order = config_flags%h_sca_adv_order
26363      vert_order = config_flags%v_sca_adv_order
26364
26365      degrade_xs = .true.
26366      degrade_xe = .true.
26367      degrade_ys = .true.
26368      degrade_ye = .true.
26369
26370      IF( config_flags%periodic_x   .or. &
26371          config_flags%symmetric_xs .or. &
26372          (its > ids+3)                ) degrade_xs = .false.
26373      IF( config_flags%periodic_x   .or. &
26374          config_flags%symmetric_xe .or. &
26375          (ite < ide-4)                ) degrade_xe = .false.
26376      IF( config_flags%periodic_y   .or. &
26377          config_flags%symmetric_ys .or. &
26378          (jts > jds+3)                ) degrade_ys = .false.
26379      IF( config_flags%periodic_y   .or. &
26380          config_flags%symmetric_ye .or. &
26381          (jte < jde-4)                ) degrade_ye = .false.
26382
26383 !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
26384
26385    a_ub =0.0
26386    a_vb =0.0
26387
26388    Do K2_ADJ =jts-2, jte+2
26389    Do K1_ADJ =kts, kte
26390    Do K0_ADJ =its-2, ite+2
26391    a_fqx(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26392    End Do
26393    End Do
26394    End Do
26395
26396    Do K2_ADJ =jts-2, jte+2
26397    Do K1_ADJ =kts, kte
26398    Do K0_ADJ =its-2, ite+2
26399    a_fqy(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26400    End Do
26401    End Do
26402    End Do
26403
26404    Do K2_ADJ =jts-2, jte+2
26405    Do K1_ADJ =kts, kte
26406    Do K0_ADJ =its-2, ite+2
26407    a_fqz(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26408    End Do
26409    End Do
26410    End Do
26411
26412    Do K2_ADJ =jts-2, jte+2
26413    Do K1_ADJ =kts, kte
26414    Do K0_ADJ =its-2, ite+2
26415    a_fqxl(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26416    End Do
26417    End Do
26418    End Do
26419
26420    Do K2_ADJ =jts-2, jte+2
26421    Do K1_ADJ =kts, kte
26422    Do K0_ADJ =its-2, ite+2
26423    a_fqyl(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26424    End Do
26425    End Do
26426    End Do
26427
26428    Do K2_ADJ =jts-2, jte+2
26429    Do K1_ADJ =kts, kte
26430    Do K0_ADJ =its-2, ite+2
26431    a_fqzl(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26432    End Do
26433    End Do
26434    End Do
26435
26436    Do K2_ADJ =jts-2, jte+2
26437    Do K1_ADJ =kts, kte
26438    Do K0_ADJ =its-2, ite+2
26439    a_qmin(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26440    End Do
26441    End Do
26442    End Do
26443
26444    Do K2_ADJ =jts-2, jte+2
26445    Do K1_ADJ =kts, kte
26446    Do K0_ADJ =its-2, ite+2
26447    a_qmax(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26448    End Do
26449    End Do
26450    End Do
26451
26452    Do K2_ADJ =jts-2, jte+2
26453    Do K1_ADJ =kts, kte
26454    Do K0_ADJ =its-2, ite+2
26455    a_scale_in(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26456    End Do
26457    End Do
26458    End Do
26459
26460    Do K2_ADJ =jts-2, jte+2
26461    Do K1_ADJ =kts, kte
26462    Do K0_ADJ =its-2, ite+2
26463    a_scale_out(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
26464    End Do
26465    End Do
26466    End Do
26467
26468    a_ph_upwind =0.0
26469    a_flux_out =0.0
26470    a_ph_low =0.0
26471    a_flux_in =0.0
26472    a_ph_hi =0.0
26473    a_scale =0.0
26474    a_vel =0.0
26475    a_cr =0.0
26476
26477 !PART IV: REVERSE/BACKWARD ACCUMULATIONS
26478
26479 !LPB[35]
26480    i_start = its
26481    i_end   = MIN(ite,ide-1)
26482    j_start = jts
26483    j_end   = MIN(jte,jde-1)
26484
26485    IF(degrade_ys) j_start = MAX(jts,jds+1)
26486    IF(degrade_ye) j_end   = MIN(jte,jde-2)
26487
26488    IF(tenddec) THEN
26489    DO j =j_end, j_start, -1
26490    DO k =ktf, kts, -1
26491    DO i =i_end, i_start, -1
26492    a_Tmpv1 =-rdy*msftx(i,j)*a_h_tendency(i,k,j)
26493    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_Tmpv1
26494    a_fqyl(i,k,j+1) =a_fqyl(i,k,j+1) +a_Tmpv1
26495    a_fqy(i,k,j+1) =a_fqy(i,k,j+1) +a_Tmpv1
26496    a_fqy(i,k,j) =a_fqy(i,k,j) -a_Tmpv1
26497    ENDDO
26498    ENDDO
26499    ENDDO
26500    ENDIF
26501
26502    DO j =j_end, j_start, -1
26503    DO k =ktf, kts, -1
26504    DO i =i_end, i_start, -1
26505    a_Tmpv1 =-rdy*msftx(i,j)*a_tendency(i,k,j)
26506    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_Tmpv1
26507    a_fqyl(i,k,j+1) =a_fqyl(i,k,j+1) +a_Tmpv1
26508    a_fqy(i,k,j+1) =a_fqy(i,k,j+1) +a_Tmpv1
26509    a_fqy(i,k,j) =a_fqy(i,k,j) -a_Tmpv1
26510    ENDDO
26511    ENDDO
26512    ENDDO
26513
26514 !LPB[30]
26515    i_start = its
26516    i_end   = MIN(ite,ide-1)
26517    j_start = jts
26518    j_end   = MIN(jte,jde-1)
26519    IF(degrade_xs) i_start = MAX(its,ids+1)
26520    IF(degrade_xe) i_end   = MIN(ite,ide-2)
26521
26522    IF(tenddec) THEN
26523    DO j =j_end, j_start, -1
26524    DO k =ktf, kts, -1
26525    DO i =i_end, i_start, -1
26526    a_Tmpv1 =-rdx*msftx(i,j)*a_h_tendency(i,k,j)
26527    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_Tmpv1
26528    a_fqxl(i+1,k,j) =a_fqxl(i+1,k,j) +a_Tmpv1
26529    a_fqx(i+1,k,j) =a_fqx(i+1,k,j) +a_Tmpv1
26530    a_fqx(i,k,j) =a_fqx(i,k,j) -a_Tmpv1
26531    a_h_tendency(i,k,j) = 0.0
26532    ENDDO
26533    ENDDO
26534    ENDDO
26535    ENDIF
26536
26537    DO j =j_end, j_start, -1
26538    DO k =ktf, kts, -1
26539    DO i =i_end, i_start, -1
26540    a_Tmpv1 =-rdx*msftx(i,j)*a_tendency(i,k,j)
26541    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_Tmpv1
26542    a_fqxl(i+1,k,j) =a_fqxl(i+1,k,j) +a_Tmpv1
26543    a_fqx(i+1,k,j) =a_fqx(i+1,k,j) +a_Tmpv1
26544    a_fqx(i,k,j) =a_fqx(i,k,j) -a_Tmpv1
26545    ENDDO
26546    ENDDO
26547    ENDDO
26548
26549 !LPB[25]
26550    i_start = its
26551    i_end   = MIN(ite,ide-1)
26552    j_start = jts
26553    j_end   = MIN(jte,jde-1)
26554
26555    IF(tenddec) THEN
26556    DO j =j_end, j_start, -1
26557    DO k =ktf, kts, -1
26558    gwalls=-rdzw(k)
26559    DO i =i_end, i_start, -1
26560    a_Tmpv1 =gwalls*a_z_tendency(i,k,j)
26561    a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1
26562    a_fqzl(i,k+1,j) =a_fqzl(i,k+1,j) +a_Tmpv1
26563    a_fqz(i,k+1,j) =a_fqz(i,k+1,j) +a_Tmpv1
26564    a_fqz(i,k,j) =a_fqz(i,k,j) -a_Tmpv1
26565    a_z_tendency(i,k,j) = 0.0
26566    ENDDO
26567    ENDDO
26568    ENDDO
26569    ENDIF
26570
26571    DO j =j_end, j_start, -1
26572    DO k =ktf, kts, -1
26573    gwalls=-rdzw(k)
26574    DO i =i_end, i_start, -1
26575    a_Tmpv1 =gwalls*a_tendency(i,k,j)
26576    a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1
26577    a_fqzl(i,k+1,j) =a_fqzl(i,k+1,j) +a_Tmpv1
26578    a_fqz(i,k+1,j) =a_fqz(i,k+1,j) +a_Tmpv1
26579    a_fqz(i,k,j) =a_fqz(i,k,j) -a_Tmpv1
26580    ENDDO
26581    ENDDO
26582    ENDDO
26583
26584 !LPB[1]
26585    qmin(its-2:ite+2,kts:kte,jts-2:jte+2) =field_old(its-2:ite+2,kts:kte,jts-2:jte+2)
26586    qmax(its-2:ite+2,kts:kte,jts-2:jte+2) =field_old(its-2:ite+2,kts:kte,jts-2:jte+2)
26587    scale_in(its-2:ite+2,kts:kte,jts-2:jte+2) =1.
26588    scale_out(its-2:ite+2,kts:kte,jts-2:jte+2) =1.
26589    fqx(its-2:ite+2,kts:kte,jts-2:jte+2) =0.
26590    fqy(its-2:ite+2,kts:kte,jts-2:jte+2) =0.
26591    fqz(its-2:ite+2,kts:kte,jts-2:jte+2) =0.
26592    fqxl(its-2:ite+2,kts:kte,jts-2:jte+2) =0.
26593    fqyl(its-2:ite+2,kts:kte,jts-2:jte+2) =0.
26594    fqzl(its-2:ite+2,kts:kte,jts-2:jte+2) =0.
26595
26596 !LPB[3]
26597    IF( horz_order == 5 ) THEN
26598    ktf =min(kte, kde-1)
26599    i_start =its-1
26600    i_end =min(ite, ide-1) +1
26601    j_start =jts-1
26602    j_end =min(jte, jde-1) +1
26603    j_start_f =j_start
26604    j_end_f =j_end+1
26605    IF(degrade_xs) i_start =max(its-1, ids)
26606    IF(degrade_xe) i_end =min(ite+1, ide-1)
26607    IF(degrade_ys) THEN
26608    j_start =max(jts-1, jds+1)
26609    j_start_f =jds+3
26610    ENDIF
26611    IF(degrade_ye) THEN
26612    j_end =min(jte+1, jde-2)
26613    j_end_f =jde-3
26614    ENDIF
26615
26616    DO j =j_start, j_end+1
26617    IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
26618
26619    DO k =kts, ktf
26620    DO i =i_start, i_end
26621    vel =rv(i,k,j)
26622    cr =vel
26623
26624    fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),vel)
26625    fqy(i,k,j) =vel*flux5(field(i,k,j-3),field(i,k,j-2),field(i,k,j-1),field(i,k,j)  &
26626    ,field(i,k,j+1),field(i,k,j+2),vel)
26627
26628    fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
26629
26630    IF(cr.gt. 0) THEN
26631    Tmpv600(i,k,j) = qmax(i,k,j)
26632    qmax(i,k,j) =amax1(qmax(i,k,j), field_old(i,k,j-1))
26633
26634    Tmpv601(i,k,j) = qmin(i,k,j)
26635    qmin(i,k,j) =amin1(qmin(i,k,j), field_old(i,k,j-1))
26636
26637    else
26638
26639    Tmpv602(i,k,j-1) = qmax(i,k,j-1)
26640    qmax(i,k,j-1) =amax1(qmax(i,k,j-1), field_old(i,k,j))
26641
26642    Tmpv603(i,k,j-1) = qmin(i,k,j-1)
26643    qmin(i,k,j-1) =amin1(qmin(i,k,j-1), field_old(i,k,j))
26644
26645    end IF
26646    ENDDO
26647    ENDDO
26648
26649    ELSE IF( j == jds+1 ) THEN
26650
26651    DO k =kts, ktf
26652    DO i =i_start, i_end
26653    vel =rv(i,k,j)
26654    cr =vel
26655
26656    fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
26657    fqy(i,k,j) =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1))
26658    fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
26659
26660    IF(cr.gt. 0) THEN
26661    Tmpv604(i,k) = qmax(i,k,j)
26662    qmax(i,k,j) =amax1(qmax(i,k,j), field_old(i,k,j-1))
26663
26664    Tmpv605(i,k) = qmin(i,k,j)
26665    qmin(i,k,j) =amin1(qmin(i,k,j), field_old(i,k,j-1))
26666
26667    else
26668
26669    Tmpv606(i,k) = qmax(i,k,j-1)
26670    qmax(i,k,j-1) =amax1(qmax(i,k,j-1), field_old(i,k,j))
26671
26672    Tmpv607(i,k) = qmin(i,k,j-1)
26673    qmin(i,k,j-1) =amin1(qmin(i,k,j-1), field_old(i,k,j))
26674
26675    end IF
26676    ENDDO
26677    ENDDO
26678
26679    ELSE IF( j == jds+2 ) THEN
26680
26681    DO k =kts, ktf
26682    DO i =i_start, i_end
26683    vel =rv(i,k,j)
26684    cr =vel
26685
26686    fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
26687    fqy(i,k,j) =vel*flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)
26688    fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
26689
26690    IF(cr.gt. 0) THEN
26691    Tmpv608(i,k) = qmax(i,k,j)
26692    qmax(i,k,j) =max(qmax(i,k,j), field_old(i,k,j-1))
26693
26694    Tmpv609(i,k) = qmin(i,k,j)
26695    qmin(i,k,j) =min(qmin(i,k,j), field_old(i,k,j-1))
26696
26697    else
26698
26699    Tmpv6010(i,k) = qmax(i,k,j-1)
26700    qmax(i,k,j-1) =max(qmax(i,k,j-1), field_old(i,k,j))
26701
26702    Tmpv6011(i,k) = qmin(i,k,j-1)
26703    qmin(i,k,j-1) =min(qmin(i,k,j-1), field_old(i,k,j))
26704
26705    end IF
26706    ENDDO
26707    ENDDO
26708
26709    ELSE IF( j == jde-1 ) THEN
26710
26711    DO k =kts, ktf
26712    DO i =i_start, i_end
26713    vel =rv(i,k,j)
26714    cr =vel
26715
26716    fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
26717    fqy(i,k,j) =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1))
26718    fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
26719
26720    IF(cr.gt. 0) THEN
26721    Tmpv6012(i,k) = qmax(i,k,j)
26722    qmax(i,k,j) =max(qmax(i,k,j), field_old(i,k,j-1))
26723
26724    Tmpv6013(i,k) = qmin(i,k,j)
26725    qmin(i,k,j) =min(qmin(i,k,j), field_old(i,k,j-1))
26726
26727    else
26728
26729    Tmpv6014(i,k) = qmax(i,k,j-1)
26730    qmax(i,k,j-1) =max(qmax(i,k,j-1), field_old(i,k,j))
26731
26732    Tmpv6015(i,k) = qmin(i,k,j-1)
26733    qmin(i,k,j-1) =min(qmin(i,k,j-1), field_old(i,k,j))
26734
26735    end IF
26736    ENDDO
26737    ENDDO
26738    ELSE IF( j == jde-2 ) THEN
26739
26740    DO k =kts, ktf
26741    DO i =i_start, i_end
26742    vel =rv(i,k,j)
26743    cr =vel
26744
26745    fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
26746    fqy(i,k,j) =vel*flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)
26747    fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
26748
26749    IF(cr.gt. 0) THEN
26750    Tmpv6016(i,k) = qmax(i,k,j)
26751    Tmpv001 =max(qmax(i,k,j), field_old(i,k,j-1))
26752    qmax(i,k,j) =Tmpv001
26753
26754    Tmpv6017(i,k) = qmin(i,k,j)
26755    Tmpv001 =min(qmin(i,k,j), field_old(i,k,j-1))
26756    qmin(i,k,j) =Tmpv001
26757
26758    else
26759
26760    Tmpv6018(i,k) = qmax(i,k,j-1)
26761    qmax(i,k,j-1) =max(qmax(i,k,j-1), field_old(i,k,j))
26762
26763    Tmpv6019(i,k) = qmin(i,k,j-1)
26764    qmin(i,k,j-1) =min(qmin(i,k,j-1), field_old(i,k,j))
26765
26766    end IF
26767    ENDDO
26768    ENDDO
26769    ENDIF
26770    ENDDO
26771
26772    i_start =its-1
26773    i_end =min(ite, ide-1) +1
26774    i_start_f =i_start
26775    i_end_f =i_end+1
26776    j_start =jts-1
26777    j_end =min(jte, jde-1) +1
26778    IF(degrade_ys) j_start =max(jts-1, jds)
26779    IF(degrade_ye) j_end =min(jte+1, jde-1)
26780    IF(degrade_xs) THEN
26781    i_start =max(ids+1, its-1)
26782    i_start_f =ids+3
26783    ENDIF
26784    IF(degrade_xe) THEN
26785    i_end =min(ide-2, ite+1)
26786    i_end_f =ide-3
26787    ENDIF
26788
26789    DO j =j_start, j_end
26790
26791    DO k =kts, ktf
26792    DO i =i_start_f, i_end_f
26793    vel =ru(i,k,j)
26794    cr =vel
26795
26796    fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
26797
26798    fqx(i,k,j) =vel*flux5(field(i-3,k,j),field(i-2,k,j),field(i-1,k,j),field(i,k,j)  &
26799    ,field(i+1,k,j),field(i+2,k,j),vel)
26800
26801    fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
26802
26803    IF(cr.gt. 0) THEN
26804    Tmpv700(i,k,j) = qmax(i,k,j)
26805    qmax(i,k,j) =max(qmax(i,k,j), field_old(i-1,k,j))
26806
26807    Tmpv701(i,k,j) = qmin(i,k,j)
26808    qmin(i,k,j) =min(qmin(i,k,j), field_old(i-1,k,j))
26809
26810    else
26811    Tmpv702(i-1,k,j) = qmax(i-1,k,j)
26812    qmax(i-1,k,j) =max(qmax(i-1,k,j), field_old(i,k,j))
26813
26814    Tmpv703(i-1,k,j) = qmin(i-1,k,j)
26815    qmin(i-1,k,j) =min(qmin(i-1,k,j), field_old(i,k,j))
26816
26817    end IF
26818    ENDDO
26819    ENDDO
26820
26821    IF( degrade_xs ) THEN
26822
26823    DO i =i_start, i_start_f-1
26824    IF(i == ids+1) THEN
26825
26826    DO k =kts, ktf
26827    vel =ru(i,k,j)
26828    cr =vel
26829
26830    fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
26831    fqx(i,k,j) =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j))
26832
26833    Tmpv001 =fqx(i,k,j) -fqxl(i,k,j)
26834    fqx(i,k,j) =Tmpv001
26835
26836    IF(cr.gt. 0) THEN
26837    Tmpv704(k,j) = qmax(i,k,j)
26838    Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j))
26839    qmax(i,k,j) =Tmpv001
26840
26841    Tmpv705(k,j) = qmin(i,k,j)
26842    Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j))
26843    qmin(i,k,j) =Tmpv001
26844
26845    else
26846    Tmpv706(k,j) = qmax(i-1,k,j)
26847    Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j))
26848    qmax(i-1,k,j) =Tmpv001
26849
26850    Tmpv707(k,j) = qmin(i-1,k,j)
26851    Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j))
26852    qmin(i-1,k,j) =Tmpv001
26853
26854    end IF
26855    ENDDO
26856    ENDIF
26857    IF(i == ids+2) THEN
26858
26859    DO k =kts, ktf
26860    vel =ru(i,k,j)
26861    cr =vel
26862
26863    fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
26864    fqx(i,k,j) =vel*flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)
26865    fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
26866
26867    IF(cr.gt. 0) THEN
26868    Tmpv708(k,j) = qmax(i,k,j)
26869    Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j))
26870    qmax(i,k,j) =Tmpv001
26871
26872    Tmpv709(k,j) = qmin(i,k,j)
26873    Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j))
26874    qmin(i,k,j) =Tmpv001
26875
26876    else
26877    Tmpv710(k,j) = qmax(i-1,k,j)
26878    Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j))
26879    qmax(i-1,k,j) =Tmpv001
26880
26881    Tmpv711(k,j) = qmin(i-1,k,j)
26882    Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j))
26883    qmin(i-1,k,j) =Tmpv001
26884
26885    end IF
26886    ENDDO
26887    ENDIF
26888    ENDDO
26889    ENDIF
26890
26891    IF( degrade_xe ) THEN
26892    DO i =i_end_f+1, i_end+1
26893    IF( i == ide-1 ) THEN
26894
26895    DO k =kts, ktf
26896    vel =ru(i,k,j)
26897    cr =vel
26898
26899    fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
26900    fqx(i,k,j) =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j))
26901    fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
26902
26903    IF(cr.gt. 0) THEN
26904    Tmpv712(k,j) = qmax(i,k,j)
26905    Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j))
26906    qmax(i,k,j) =Tmpv001
26907
26908    Tmpv713(k,j) = qmin(i,k,j)
26909    Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j))
26910    qmin(i,k,j) =Tmpv001
26911
26912    else
26913    Tmpv714(k,j) = qmax(i-1,k,j)
26914    Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j))
26915    qmax(i-1,k,j) =Tmpv001
26916
26917    Tmpv715(k,j) = qmin(i-1,k,j)
26918    Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j))
26919    qmin(i-1,k,j) =Tmpv001
26920
26921    end IF
26922    ENDDO
26923    ENDIF
26924    IF( i == ide-2 ) THEN
26925
26926    DO k =kts, ktf
26927    vel =ru(i,k,j)
26928    cr =vel
26929
26930    Tmpv001 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
26931    Tmpv002 =vel*Tmpv001
26932    fqxl(i,k,j) =Tmpv002
26933
26934    Tmpv001 =flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)
26935    Tmpv002 =vel*Tmpv001
26936    fqx(i,k,j) =Tmpv002
26937
26938    Tmpv001 =fqx(i,k,j) -fqxl(i,k,j)
26939    fqx(i,k,j) =Tmpv001
26940
26941    IF(cr.gt. 0) THEN
26942    Tmpv716(k,j) = qmax(i,k,j)
26943    Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j))
26944    qmax(i,k,j) =Tmpv001
26945
26946    Tmpv717(k,j) = qmin(i,k,j)
26947    Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j))
26948    qmin(i,k,j) =Tmpv001
26949
26950    else
26951    Tmpv718(k,j) = qmax(i-1,k,j)
26952    Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j))
26953    qmax(i-1,k,j) =Tmpv001
26954
26955    Tmpv719(k,j) = qmin(i-1,k,j)
26956    Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j))
26957    qmin(i-1,k,j) =Tmpv001
26958
26959    end IF
26960    ENDDO
26961    ENDIF
26962    ENDDO
26963    ENDIF
26964    ENDDO
26965
26966    ELSE
26967
26968    ENDIF
26969
26970    i_start = its-1
26971    i_end   = MIN(ite,ide-1)+1
26972    j_start = jts-1
26973    j_end   = MIN(jte,jde-1)+1
26974    IF(degrade_xs) i_start = MAX(its-1,ids)
26975    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
26976    IF(degrade_ys) j_start = MAX(jts-1,jds)
26977    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
26978
26979 !LPB[22]
26980
26981    IF(vert_order == 3) THEN
26982    DO j =j_start, j_end
26983    DO i =i_start, i_end
26984    fqz(i,1,j) =0.
26985    fqzl(i,1,j) =0.
26986    fqz(i,kde,j) =0.
26987    fqzl(i,kde,j) =0.
26988    ENDDO
26989
26990    DO k =kts+2, ktf-1
26991    DO i =i_start, i_end
26992    vel =rom(i,k,j)
26993    cr =-vel
26994
26995    fqzl(i,k,j) =vel*flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
26996    fqz(i,k,j) =vel*flux3(field(i,k-2,j),field(i,k-1,j),field(i,k,j),field(i,k+1,j),-vel)
26997    fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
26998
26999    IF(cr.gt. 0) THEN
27000    Tmpv800(i,k,j) = qmax(i,k,j)
27001    qmax(i,k,j) =max(qmax(i,k,j), field_old(i,k-1,j))
27002
27003    Tmpv801(i,k,j) = qmin(i,k,j)
27004    qmin(i,k,j) =min(qmin(i,k,j), field_old(i,k-1,j))
27005
27006    else
27007
27008    Tmpv802(i,k-1,j) = qmax(i,k-1,j)
27009    qmax(i,k-1,j) =max(qmax(i,k-1,j), field_old(i,k,j))
27010
27011    Tmpv803(i,k-1,j) = qmin(i,k-1,j)
27012    qmin(i,k-1,j) =min(qmin(i,k-1,j), field_old(i,k,j))
27013    end IF
27014    ENDDO
27015    ENDDO
27016
27017    DO i =i_start, i_end
27018    k =kts+1
27019    vel =rom(i,k,j)
27020    cr =-vel
27021
27022    fqzl(i,k,j) =vel*flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
27023    fqz(i,k,j) =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
27024
27025    Tmpv001 =fqz(i,k,j) -fqzl(i,k,j)
27026    fqz(i,k,j) =Tmpv001
27027
27028    IF(cr.gt. 0) THEN
27029    Tmpv804(i,j) = qmax(i,k,j)
27030    Tmpv001 =max(qmax(i,k,j), field_old(i,k-1,j))
27031    qmax(i,k,j) =Tmpv001
27032
27033    Tmpv805(i,j) = qmin(i,k,j)
27034    Tmpv001 =min(qmin(i,k,j), field_old(i,k-1,j))
27035    qmin(i,k,j) =Tmpv001
27036
27037    else
27038    Tmpv806(i,j) = qmax(i,k-1,j)
27039    Tmpv001 =max(qmax(i,k-1,j), field_old(i,k,j))
27040    qmax(i,k-1,j) =Tmpv001
27041
27042    Tmpv807(i,j) = qmin(i,k-1,j)
27043    Tmpv001 =min(qmin(i,k-1,j), field_old(i,k,j))
27044    qmin(i,k-1,j) =Tmpv001
27045
27046    end IF
27047    k =ktf
27048    vel =rom(i,k,j)
27049    cr =-vel
27050
27051    fqzl(i,k,j) =vel*flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
27052    fqz(i,k,j) =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
27053    fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
27054
27055    IF(cr.gt. 0) THEN
27056    Tmpv808(i,j) = qmax(i,k,j)
27057    Tmpv001 =max(qmax(i,k,j), field_old(i,k-1,j))
27058    qmax(i,k,j) =Tmpv001
27059
27060    Tmpv809(i,j) = qmin(i,k,j)
27061    Tmpv001 =min(qmin(i,k,j), field_old(i,k-1,j))
27062    qmin(i,k,j) =Tmpv001
27063
27064    else
27065
27066    Tmpv810(i,j) = qmax(i,k-1,j)
27067    qmax(i,k-1,j) =max(qmax(i,k-1,j), field_old(i,k,j))
27068
27069    Tmpv811(i,j) = qmin(i,k-1,j)
27070    qmin(i,k-1,j) =min(qmin(i,k-1,j), field_old(i,k,j))
27071
27072    end IF
27073    ENDDO
27074    ENDDO
27075
27076    ELSE
27077
27078    ENDIF
27079
27080 !LPB[23]
27081    IF(mono_limit) THEN
27082    i_start =its-1
27083    Tmpv001 =min(ite, ide-1) +1
27084    i_end =Tmpv001
27085    j_start =jts-1
27086    Tmpv001 =min(jte, jde-1) +1
27087    j_end =Tmpv001
27088    IF(degrade_xs) THEN
27089    i_start =max(its-1, ids)
27090    END IF
27091    IF(degrade_xe) THEN
27092    i_end =min(ite+1, ide-1)
27093    END IF
27094    IF(degrade_ys) THEN
27095    j_start =max(jts-1, jds)
27096    END IF
27097    IF(degrade_ye) THEN
27098    j_end =min(jte+1, jde-1)
27099    END IF
27100    IF(config_flags%specified .or. config_flags%nested) THEN
27101    IF(degrade_xs) THEN
27102    i_start =max(its-1, ids+1)
27103    END IF
27104    IF(degrade_xe) THEN
27105    i_end =min(ite+1, ide-2)
27106    END IF
27107    IF(degrade_ys) THEN
27108    j_start =max(jts-1, jds+1)
27109    END IF
27110    IF(degrade_ye) THEN
27111    j_end =min(jte+1, jde-2)
27112    END IF
27113    END IF
27114    IF(config_flags%open_xs) THEN
27115    IF(degrade_xs) THEN
27116    i_start =max(its-1, ids+1)
27117    END IF
27118    END IF
27119    IF(config_flags%open_xe) THEN
27120    IF(degrade_xe) THEN
27121    i_end =min(ite+1, ide-2)
27122    END IF
27123    END IF
27124    IF(config_flags%open_ys) THEN
27125    IF(degrade_ys) THEN
27126    j_start =max(jts-1, jds+1)
27127    END IF
27128    END IF
27129    IF(config_flags%open_ye) THEN
27130    IF(degrade_ye) THEN
27131    j_end =min(jte+1, jde-2)
27132    END IF
27133    END IF
27134
27135    DO j =j_start, j_end
27136    DO k =kts, ktf
27137    DO i =i_start, i_end
27138    Tmpv001 =(mub(i,j) +mu_old(i,j))*field_old(i,k,j)
27139    Tmpv002 =fqxl(i+1,k,j) -fqxl(i,k,j)
27140    Tmpv003 =rdx*Tmpv002
27141    Tmpv004 =fqyl(i,k,j+1) -fqyl(i,k,j)
27142    Tmpv005 =rdy*Tmpv004
27143    Tmpv006 =Tmpv003 +Tmpv005
27144    Tmpv007 =msftx(i,j)*msfty(i,j)*Tmpv006
27145    Tmpv008 =fqzl(i,k+1,j) -fqzl(i,k,j)
27146    Tmpv009 =msfty(i,j)*rdzw(k)*Tmpv008
27147    ph_upwind =Tmpv001 -dt*(Tmpv007 +Tmpv009)
27148
27149    Tmpv001 =min(0., fqx(i+1,k,j)) -max(0., fqx(i,k,j))
27150    Tmpv002 =rdx*Tmpv001
27151    Tmpv003 =min(0., fqy(i,k,j+1)) -max(0., fqy(i,k,j))
27152    Tmpv004 =rdy*Tmpv003
27153    Tmpv005 =Tmpv002 +Tmpv004
27154    Tmpv006 =(msftx(i,j)*msfty(i,j))*Tmpv005
27155    Tmpv007 =max(0., fqz(i,k+1,j)) -min(0., fqz(i,k,j))
27156    Tmpv008 =msfty(i,j)*rdzw(k)*Tmpv007
27157    Tmpv009 =Tmpv006 +Tmpv008
27158    Tmpv010 =-dt*Tmpv009
27159    flux_in =Tmpv010
27160    Tmpv2400(i,k,j) =flux_in
27161
27162    Tmpv001 =mut(i,j)*qmax(i,k,j)
27163    Tmpv002 =Tmpv001 -ph_upwind
27164    ph_hi =Tmpv002
27165    Tmpv2401(i,k,j) =ph_hi
27166
27167    IF( flux_in .gt. ph_hi ) THEN
27168    Tmpv001 =ph_hi/(flux_in +eps)
27169    Tmpv2402(i,k,j) =Tmpv001
27170    scale_in(i,k,j) =max(0., Tmpv2402(i,k,j))
27171    END IF
27172
27173    Tmpv001 =max(0., fqx(i+1,k,j)) -min(0., fqx(i,k,j))
27174    Tmpv002 =rdx*Tmpv001
27175    Tmpv003 =max(0., fqy(i,k,j+1)) -min(0., fqy(i,k,j))
27176    Tmpv004 =rdy*Tmpv003
27177    Tmpv005 =Tmpv002 +Tmpv004
27178    Tmpv006 =(msftx(i,j)*msfty(i,j))*Tmpv005
27179    Tmpv007 =min(0., fqz(i,k+1,j)) -max(0., fqz(i,k,j))
27180    Tmpv008 =msfty(i,j)*rdzw(k)*Tmpv007
27181    Tmpv009 =Tmpv006 +Tmpv008
27182    Tmpv010 =dt*Tmpv009
27183    flux_out =Tmpv010
27184    Tmpv2403(i,k,j) =flux_out
27185
27186    Tmpv001 =mut(i,j)*qmin(i,k,j)
27187    Tmpv002 =ph_upwind -Tmpv001
27188    ph_low =Tmpv002
27189    Tmpv2404(i,k,j) =ph_low
27190
27191    IF( flux_out .gt. ph_low ) THEN
27192    Tmpv001 =ph_low/(flux_out +eps)
27193    Tmpv2405(i,k,j) =Tmpv001
27194    scale_out(i,k,j) =max(0., Tmpv2405(i,k,j))
27195    END IF
27196
27197    ENDDO
27198    ENDDO
27199    ENDDO
27200
27201    DO j =j_end, j_start, -1
27202    DO k =ktf, kts+1, -1
27203    DO i =i_end, i_start, -1
27204
27205    IF( fqz (i,k,j) .lt. 0.) THEN
27206
27207    a_Tmpv2 =a_fqz(i,k,j)
27208    a_fqz(i,k,j) =0.0
27209    a_Tmpv1 =fqz(i,k,j)*a_Tmpv2
27210    a_fqz(i,k,j) =a_fqz(i,k,j) +min(scale_in(i,k,j), scale_out(i,k-1,j))*a_Tmpv2
27211    a_scale_in(i,k,j) =a_scale_in(i,k,j)  +(1.0 -sign(1.0, scale_in(i,k,j)  &
27212    -scale_out(i,k-1,j)))*0.5*1.0*a_Tmpv1
27213    a_scale_out(i,k-1,j) =a_scale_out(i,k-1,j)  +(1.0 +sign(1.0, scale_in(i,k,j)  &
27214    -scale_out(i,k-1,j)))*0.5*1.0*a_Tmpv1
27215
27216    ELSE
27217
27218    a_Tmpv2 =a_fqz(i,k,j)
27219    a_fqz(i,k,j) =0.0
27220    a_Tmpv1 =fqz(i,k,j)*a_Tmpv2
27221    a_fqz(i,k,j) =a_fqz(i,k,j) +min(scale_out(i,k,j), scale_in(i,k-1,j))*a_Tmpv2
27222    a_scale_out(i,k,j) =a_scale_out(i,k,j)  +(1.0 -sign(1.0, scale_out(i,k,j)  &
27223    -scale_in(i,k-1,j)))*0.5*1.0*a_Tmpv1
27224    a_scale_in(i,k-1,j) =a_scale_in(i,k-1,j)  +(1.0 +sign(1.0, scale_out(i,k,j)  &
27225    -scale_in(i,k-1,j)))*0.5*1.0*a_Tmpv1
27226
27227    ENDIF
27228    ENDDO
27229    ENDDO
27230    ENDDO
27231
27232    DO j =j_end+1, j_start, -1
27233    DO k =ktf, kts, -1
27234    DO i =i_end, i_start, -1
27235
27236    IF( fqy (i,k,j) .gt. 0.) THEN
27237
27238    a_Tmpv2 =a_fqy(i,k,j)
27239    a_fqy(i,k,j) =0.0
27240    a_Tmpv1 =fqy(i,k,j)*a_Tmpv2
27241    a_fqy(i,k,j) =a_fqy(i,k,j) +min(scale_in(i,k,j), scale_out(i,k,j-1))*a_Tmpv2
27242    a_scale_in(i,k,j) =a_scale_in(i,k,j)  +(1.0 -sign(1.0, scale_in(i,k,j)  &
27243    -scale_out(i,k,j-1)))*0.5*1.0*a_Tmpv1
27244    a_scale_out(i,k,j-1) =a_scale_out(i,k,j-1)  +(1.0 +sign(1.0, scale_in(i,k,j)  &
27245    -scale_out(i,k,j-1)))*0.5*1.0*a_Tmpv1
27246
27247    ELSE
27248
27249    a_Tmpv2 =a_fqy(i,k,j)
27250    a_fqy(i,k,j) =0.0
27251    a_Tmpv1 =fqy(i,k,j)*a_Tmpv2
27252    a_fqy(i,k,j) =a_fqy(i,k,j) +min(scale_out(i,k,j), scale_in(i,k,j-1))*a_Tmpv2
27253    a_scale_out(i,k,j) =a_scale_out(i,k,j)  +(1.0 -sign(1.0, scale_out(i,k,j)  &
27254    -scale_in(i,k,j-1)))*0.5*1.0*a_Tmpv1
27255    a_scale_in(i,k,j-1) =a_scale_in(i,k,j-1)  +(1.0 +sign(1.0, scale_out(i,k,j)  &
27256    -scale_in(i,k,j-1)))*0.5*1.0*a_Tmpv1
27257
27258    ENDIF
27259    ENDDO
27260    ENDDO
27261    ENDDO
27262
27263    DO j =j_end, j_start, -1
27264    DO k =ktf, kts, -1
27265    DO i =i_end+1, i_start, -1
27266
27267    IF( fqx (i,k,j) .gt. 0.) THEN
27268
27269    a_Tmpv2 =a_fqx(i,k,j)
27270    a_fqx(i,k,j) =0.0
27271    a_Tmpv1 =fqx(i,k,j)*a_Tmpv2
27272    a_fqx(i,k,j) =a_fqx(i,k,j) +min(scale_in(i,k,j), scale_out(i-1,k,j))*a_Tmpv2
27273    a_scale_in(i,k,j) =a_scale_in(i,k,j)  +(1.0 -sign(1.0, scale_in(i,k,j)  &
27274    -scale_out(i-1,k,j)))*0.5*1.0*a_Tmpv1
27275    a_scale_out(i-1,k,j) =a_scale_out(i-1,k,j)  +(1.0 +sign(1.0, scale_in(i,k,j)  &
27276    -scale_out(i-1,k,j)))*0.5*1.0*a_Tmpv1
27277
27278    ELSE
27279
27280    a_Tmpv2 =a_fqx(i,k,j)
27281    a_fqx(i,k,j) =0.0
27282    a_Tmpv1 =fqx(i,k,j)*a_Tmpv2
27283    a_fqx(i,k,j) =a_fqx(i,k,j) +min(scale_out(i,k,j), scale_in(i-1,k,j))*a_Tmpv2
27284    a_scale_out(i,k,j) =a_scale_out(i,k,j)  +(1.0 -sign(1.0, scale_out(i,k,j)  &
27285    -scale_in(i-1,k,j)))*0.5*1.0*a_Tmpv1
27286    a_scale_in(i-1,k,j) =a_scale_in(i-1,k,j)  +(1.0 +sign(1.0, scale_out(i,k,j)  &
27287    -scale_in(i-1,k,j)))*0.5*1.0*a_Tmpv1
27288
27289    ENDIF
27290
27291    ENDDO
27292    ENDDO
27293    ENDDO
27294
27295    DO j =j_end, j_start, -1
27296    DO k =ktf, kts, -1
27297    DO i =i_end, i_start, -1
27298    flux_out = Tmpv2403(i,k,j)
27299    ph_low = Tmpv2404(i,k,j)
27300
27301    IF( flux_out .gt. ph_low ) THEN
27302    a_Tmpv1 = (1.0 +(-1.0)*sign(1.0, 0. -Tmpv2405(i,k,j)))*0.5*a_scale_out(i,k,j)
27303    a_scale_out(i,k,j) =0.0
27304    a_ph_low =a_ph_low +a_Tmpv1/(flux_out +eps)
27305    a_flux_out =a_flux_out -ph_low/((flux_out +eps)*(flux_out +eps))*a_Tmpv1
27306    END IF
27307
27308    a_Tmpv2 =a_ph_low
27309    a_ph_low =0.0
27310    a_ph_upwind =a_ph_upwind +a_Tmpv2
27311    a_Tmpv1 =-a_Tmpv2
27312    a_mut(i,j) =a_mut(i,j) +qmin(i,k,j)*a_Tmpv1
27313    a_qmin(i,k,j) =a_qmin(i,k,j) +mut(i,j)*a_Tmpv1
27314
27315    a_Tmpv10 =a_flux_out
27316    a_flux_out =0.0
27317    a_Tmpv9 =dt*a_Tmpv10
27318    a_Tmpv6 =a_Tmpv9
27319    a_Tmpv8 =a_Tmpv9
27320    a_Tmpv7 =msfty(i,j)*rdzw(k)*a_Tmpv8
27321    a_fqz(i,k+1,j) =a_fqz(i,k+1,j) +(1.0 -(-1.0)*sign(1.0, 0. -fqz(i,k+1,j)))*0.5*a_Tmpv7
27322    a_fqz(i,k,j) =a_fqz(i,k,j) -(1.0 +(-1.0)*sign(1.0, 0. -fqz(i,k,j)))*0.5*a_Tmpv7
27323    a_Tmpv5 =(msftx(i,j)*msfty(i,j))*a_Tmpv6
27324    a_Tmpv2 =a_Tmpv5
27325    a_Tmpv4 =a_Tmpv5
27326    a_Tmpv3 =rdy*a_Tmpv4
27327    a_fqy(i,k,j+1) =a_fqy(i,k,j+1) +(1.0 +(-1.0)*sign(1.0, 0. -fqy(i,k,j+1)))*0.5*a_Tmpv3
27328    a_fqy(i,k,j) =a_fqy(i,k,j) -(1.0 -(-1.0)*sign(1.0, 0. -fqy(i,k,j)))*0.5*a_Tmpv3
27329    a_Tmpv1 =rdx*a_Tmpv2
27330    a_fqx(i+1,k,j) =a_fqx(i+1,k,j) +(1.0 +(-1.0)*sign(1.0, 0. -fqx(i+1,k,j)))*0.5*a_Tmpv1
27331    a_fqx(i,k,j) =a_fqx(i,k,j) -(1.0 -(-1.0)*sign(1.0, 0. -fqx(i,k,j)))*0.5*a_Tmpv1
27332
27333    flux_in =Tmpv2400(i,k,j)
27334    ph_hi =Tmpv2401(i,k,j)
27335
27336    IF( flux_in .gt. ph_hi ) THEN
27337
27338    a_Tmpv1 = (1.0 +(-1.0)*sign(1.0, 0. -Tmpv2402(i,k,j)))*0.5*a_scale_in(i,k,j)
27339    a_scale_in(i,k,j) =0.0
27340    a_ph_hi =a_ph_hi +a_Tmpv1/(flux_in +eps)
27341    a_flux_in =a_flux_in -ph_hi/((flux_in +eps)*(flux_in +eps))*a_Tmpv1
27342    END IF
27343
27344    a_Tmpv2 =a_ph_hi
27345    a_ph_hi =0.0
27346    a_Tmpv1 =a_Tmpv2
27347    a_ph_upwind =a_ph_upwind -a_Tmpv2
27348    a_mut(i,j) =a_mut(i,j) +qmax(i,k,j)*a_Tmpv1
27349    a_qmax(i,k,j) =a_qmax(i,k,j) +mut(i,j)*a_Tmpv1
27350
27351    a_Tmpv10 =a_flux_in
27352    a_flux_in =0.0
27353    a_Tmpv9 =-dt*a_Tmpv10
27354    a_Tmpv6 =a_Tmpv9
27355    a_Tmpv8 =a_Tmpv9
27356    a_Tmpv7 =msfty(i,j)*rdzw(k)*a_Tmpv8
27357    a_fqz(i,k+1,j) =a_fqz(i,k+1,j) +(1.0 +(-1.0)*sign(1.0, 0. -fqz(i,k+1,j)))*0.5*a_Tmpv7
27358    a_fqz(i,k,j) =a_fqz(i,k,j) -(1.0 -(-1.0)*sign(1.0, 0. -fqz(i,k,j)))*0.5*a_Tmpv7
27359    a_Tmpv5 =(msftx(i,j)*msfty(i,j))*a_Tmpv6
27360    a_Tmpv2 =a_Tmpv5
27361    a_Tmpv4 =a_Tmpv5
27362    a_Tmpv3 =rdy*a_Tmpv4
27363    a_fqy(i,k,j+1) =a_fqy(i,k,j+1) +(1.0 -(-1.0)*sign(1.0, 0. -fqy(i,k,j+1)))*0.5*a_Tmpv3
27364    a_fqy(i,k,j) =a_fqy(i,k,j) -(1.0 +(-1.0)*sign(1.0, 0. -fqy(i,k,j)))*0.5*a_Tmpv3
27365    a_Tmpv1 =rdx*a_Tmpv2
27366    a_fqx(i+1,k,j) =a_fqx(i+1,k,j) +(1.0 -(-1.0)*sign(1.0, 0. -fqx(i+1,k,j)))*0.5*a_Tmpv1
27367    a_fqx(i,k,j) =a_fqx(i,k,j) -(1.0 +(-1.0)*sign(1.0, 0. -fqx(i,k,j)))*0.5*a_Tmpv1
27368    a_Tmpv12 =a_ph_upwind
27369    a_ph_upwind =0.0
27370    a_Tmpv1 =a_Tmpv12
27371    a_Tmpv11 =-a_Tmpv12
27372    a_Tmpv10 =dt*a_Tmpv11
27373    a_Tmpv7 =a_Tmpv10
27374    a_Tmpv9 =a_Tmpv10
27375    a_Tmpv8 =msfty(i,j)*rdzw(k)*a_Tmpv9
27376    a_fqzl(i,k+1,j) =a_fqzl(i,k+1,j) +a_Tmpv8
27377    a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv8
27378    a_Tmpv6 =msftx(i,j)*msfty(i,j)*a_Tmpv7
27379    a_Tmpv3 =a_Tmpv6
27380    a_Tmpv5 =a_Tmpv6
27381    a_Tmpv4 =rdy*a_Tmpv5
27382    a_fqyl(i,k,j+1) =a_fqyl(i,k,j+1) +a_Tmpv4
27383    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_Tmpv4
27384    a_Tmpv2 =rdx*a_Tmpv3
27385    a_fqxl(i+1,k,j) =a_fqxl(i+1,k,j) +a_Tmpv2
27386    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_Tmpv2
27387    a_mu_old(i,j) =a_mu_old(i,j) +field_old(i,k,j)*a_Tmpv1
27388    a_field_old(i,k,j) =a_field_old(i,k,j) +(mub(i,j) +mu_old(i,j))*a_Tmpv1
27389    ENDDO
27390    ENDDO
27391    ENDDO
27392
27393    END IF
27394
27395 !LPB[22]
27396
27397    i_start = its-1
27398    i_end   = MIN(ite,ide-1)+1
27399    j_start = jts-1
27400    j_end   = MIN(jte,jde-1)+1
27401    IF(degrade_xs) i_start = MAX(its-1,ids)
27402    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
27403    IF(degrade_ys) j_start = MAX(jts-1,jds)
27404    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
27405
27406    IF(vert_order == 3) THEN
27407
27408    DO j =j_end, j_start, -1
27409    DO i =i_end, i_start, -1
27410    k =ktf
27411
27412    vel = rom(i,k,j)
27413    cr = -vel
27414
27415    IF(cr.gt. 0) THEN
27416    qmax(i,k,j) = Tmpv808(i,j)
27417    qmin(i,k,j) = Tmpv809(i,j)
27418
27419    a_Tmpv1 =a_qmin(i,k,j)
27420    a_qmin(i,k,j) =0.0
27421    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k-1,j)  &
27422    ))*0.5*1.0*a_Tmpv1
27423    a_field_old(i,k-1,j) =a_field_old(i,k-1,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
27424     -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1
27425
27426    a_Tmpv1 =a_qmax(i,k,j)
27427    a_qmax(i,k,j) =0.0
27428    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k-1,j)  &
27429    ))*0.5*1.0*a_Tmpv1
27430    a_field_old(i,k-1,j) =a_field_old(i,k-1,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
27431     -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1
27432    else
27433    qmax(i,k-1,j) = Tmpv810(i,j)
27434    qmin(i,k-1,j) = Tmpv811(i,j)
27435
27436    a_Tmpv1 =a_qmin(i,k-1,j)
27437    a_qmin(i,k-1,j) =0.0
27438    a_qmin(i,k-1,j) =a_qmin(i,k-1,j)  +(1.0 -sign(1.0, qmin(i,k-1,j)  &
27439     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27440    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k-1,j)  &
27441     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27442    a_Tmpv1 =a_qmax(i,k-1,j)
27443    a_qmax(i,k-1,j) =0.0
27444    a_qmax(i,k-1,j) =a_qmax(i,k-1,j)  +(1.0 +sign(1.0, qmax(i,k-1,j)  &
27445     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27446    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k-1,j)  &
27447     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27448
27449    end IF
27450
27451    a_Tmpv1 =a_fqz(i,k,j)
27452    a_fqz(i,k,j) =0.0
27453    a_fqz(i,k,j) =a_fqz(i,k,j) +a_Tmpv1
27454    a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1
27455    a_Tmpv2 =a_fqz(i,k,j)
27456    a_fqz(i,k,j) =0.0
27457    a_rom(i,k,j) =a_rom(i,k,j) +(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))*a_Tmpv2
27458    a_Tmpv1 =rom(i,k,j)*a_Tmpv2
27459    a_field(i,k,j) =a_field(i,k,j) +fzm(k)*a_Tmpv1
27460    a_field(i,k-1,j) =a_field(i,k-1,j) +fzp(k)*a_Tmpv1
27461    a_Tmpv2 =a_fqzl(i,k,j)
27462    a_fqzl(i,k,j) =0.0
27463    a_vel =a_vel +flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)*a_Tmpv2
27464    a_Tmpv1 =vel*a_Tmpv2
27465    a_cr =a_cr +Diff_flux_upwind(field_old(i,k-1,j),0.0,field_old(i,k,j)  &
27466    ,0.0,cr,1.0)*a_Tmpv1
27467    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k-1,j)  &
27468    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
27469    a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +Diff_flux_upwind(field_old(i,k-1,j)  &
27470    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
27471
27472    a_vel =a_vel -a_cr
27473    a_cr =0.0
27474
27475    a_rom(i,k,j) =a_rom(i,k,j) +a_vel
27476    a_vel =0.0
27477
27478    k =kts+1
27479
27480    vel = rom(i,k,j)
27481    cr = -vel
27482
27483    IF(cr.gt. 0) THEN
27484    qmax(i,k,j) = Tmpv804(i,j)
27485    qmin(i,k,j) = Tmpv805(i,j)
27486
27487    a_Tmpv1 =a_qmax(i,k,j)
27488    a_qmax(i,k,j) =0.0
27489    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k-1,j)  &
27490    ))*0.5*1.0*a_Tmpv1
27491    a_field_old(i,k-1,j) =a_field_old(i,k-1,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
27492     -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1
27493    a_Tmpv1 =a_qmin(i,k,j)
27494    a_qmin(i,k,j) =0.0
27495    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k-1,j)  &
27496    ))*0.5*1.0*a_Tmpv1
27497    a_field_old(i,k-1,j) =a_field_old(i,k-1,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
27498     -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1
27499
27500    else
27501
27502    qmax(i,k-1,j) = Tmpv806(i,j)
27503    qmin(i,k-1,j) = Tmpv807(i,j)
27504
27505    a_Tmpv1 =a_qmin(i,k-1,j)
27506    a_qmin(i,k-1,j) =0.0
27507    a_qmin(i,k-1,j) =a_qmin(i,k-1,j)  +(1.0 -sign(1.0, qmin(i,k-1,j)  &
27508     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27509    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k-1,j)  &
27510     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27511    a_Tmpv1 =a_qmax(i,k-1,j)
27512    a_qmax(i,k-1,j) =0.0
27513    a_qmax(i,k-1,j) =a_qmax(i,k-1,j)  +(1.0 +sign(1.0, qmax(i,k-1,j)  &
27514     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27515    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k-1,j)  &
27516     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27517
27518    end IF
27519    a_Tmpv1 =a_fqz(i,k,j)
27520    a_fqz(i,k,j) =0.0
27521    a_fqz(i,k,j) =a_fqz(i,k,j) +a_Tmpv1
27522    a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1
27523    a_Tmpv2 =a_fqz(i,k,j)
27524    a_fqz(i,k,j) =0.0
27525    a_rom(i,k,j) =a_rom(i,k,j) +(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))*a_Tmpv2
27526    a_Tmpv1 =rom(i,k,j)*a_Tmpv2
27527    a_field(i,k,j) =a_field(i,k,j) +fzm(k)*a_Tmpv1
27528    a_field(i,k-1,j) =a_field(i,k-1,j) +fzp(k)*a_Tmpv1
27529    a_Tmpv2 =a_fqzl(i,k,j)
27530    a_fqzl(i,k,j) =0.0
27531    a_vel =a_vel +flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)*a_Tmpv2
27532    a_Tmpv1 =vel*a_Tmpv2
27533    a_cr =a_cr +Diff_flux_upwind(field_old(i,k-1,j),0.0,field_old(i,k,j)  &
27534    ,0.0,cr,1.0)*a_Tmpv1
27535    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k-1,j)  &
27536    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
27537    a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +Diff_flux_upwind(field_old(i,k-1,j)  &
27538    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
27539
27540    a_vel =a_vel -a_cr
27541    a_cr =0.0
27542
27543    a_rom(i,k,j) =a_rom(i,k,j) +a_vel
27544    a_vel =0.0
27545    ENDDO
27546
27547    DO k =ktf-1, kts+2, -1
27548    DO i =i_end, i_start, -1
27549    vel = rom(i,k,j)
27550    cr = -vel
27551
27552    IF(cr.gt. 0) THEN
27553    qmax(i,k,j) = Tmpv800(i,k,j)
27554    qmin(i,k,j) = Tmpv801(i,k,j)
27555
27556    a_Tmpv1 =a_qmax(i,k,j)
27557    a_qmax(i,k,j) =0.0
27558    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k-1,j)  &
27559    ))*0.5*1.0*a_Tmpv1
27560    a_field_old(i,k-1,j) =a_field_old(i,k-1,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
27561     -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1
27562    a_Tmpv1 =a_qmin(i,k,j)
27563    a_qmin(i,k,j) =0.0
27564    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k-1,j)  &
27565    ))*0.5*1.0*a_Tmpv1
27566    a_field_old(i,k-1,j) =a_field_old(i,k-1,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
27567     -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1
27568
27569    else
27570
27571    qmax(i,k-1,j) = Tmpv802(i,k-1,j)
27572    qmin(i,k-1,j) = Tmpv803(i,k-1,j)
27573
27574    a_Tmpv1 =a_qmin(i,k-1,j)
27575    a_qmin(i,k-1,j) =0.0
27576    a_qmin(i,k-1,j) =a_qmin(i,k-1,j)  +(1.0 -sign(1.0, qmin(i,k-1,j)  &
27577     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27578    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k-1,j)  &
27579     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27580    a_Tmpv1 =a_qmax(i,k-1,j)
27581    a_qmax(i,k-1,j) =0.0
27582    a_qmax(i,k-1,j) =a_qmax(i,k-1,j)  +(1.0 +sign(1.0, qmax(i,k-1,j)  &
27583     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27584    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k-1,j)  &
27585     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27586
27587    end IF
27588
27589    a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_fqz(i,k,j)
27590    a_Tmpv2 =a_fqz(i,k,j)
27591    a_fqz(i,k,j) =0.0
27592    a_vel =a_vel +flux3(field(i,k-2,j),field(i,k-1,j),field(i,k,j),field(i,k+1,j),-vel)*a_Tmpv2
27593    a_Tmpv1 =vel*a_Tmpv2
27594    a_vel =a_vel -Diff_flux3(field(i,k-2,j),0.0,field(i,k-1,j),0.0,field(i,k,j)  &
27595    ,0.0,field(i,k+1,j),0.0,-vel,1.0)*a_Tmpv1
27596    a_field(i,k+1,j) =a_field(i,k+1,j) +Diff_flux3(field(i,k-2,j),0.0,field(i,k-1,  &
27597    j),0.0,field(i,k,j),0.0,field(i,k+1,j),1.0,-vel,0.0)*a_Tmpv1
27598    a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i,k-2,j),0.0,field(i,k-1,j)  &
27599    ,0.0,field(i,k,j),1.0,field(i,k+1,j),0.0,-vel,0.0)*a_Tmpv1
27600    a_field(i,k-1,j) =a_field(i,k-1,j) +Diff_flux3(field(i,k-2,j),0.0,field(i,k-1,  &
27601    j),1.0,field(i,k,j),0.0,field(i,k+1,j),0.0,-vel,0.0)*a_Tmpv1
27602    a_field(i,k-2,j) =a_field(i,k-2,j) +Diff_flux3(field(i,k-2,j),1.0,field(i,k-1,  &
27603    j),0.0,field(i,k,j),0.0,field(i,k+1,j),0.0,-vel,0.0)*a_Tmpv1
27604
27605    a_Tmpv2 =a_fqzl(i,k,j)
27606    a_fqzl(i,k,j) =0.0
27607    a_vel =a_vel +flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)*a_Tmpv2
27608    a_Tmpv1 =vel*a_Tmpv2
27609    a_cr =a_cr +Diff_flux_upwind(field_old(i,k-1,j),0.0,field_old(i,k,j)  &
27610    ,0.0,cr,1.0)*a_Tmpv1
27611    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k-1,j)  &
27612    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
27613    a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +Diff_flux_upwind(field_old(i,k-1,j)  &
27614    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
27615
27616    a_vel =a_vel -a_cr
27617    a_cr =0.0
27618
27619    a_rom(i,k,j) =a_rom(i,k,j) +a_vel
27620    a_vel =0.0
27621    ENDDO
27622    ENDDO
27623
27624    DO i =i_end, i_start, -1
27625    a_fqzl(i,kde,j) =0.0
27626    a_fqz(i,kde,j) =0.0
27627    a_fqzl(i,1,j) =0.0
27628    a_fqz(i,1,j) =0.0
27629    ENDDO
27630
27631    ENDDO
27632
27633    ELSE
27634    ENDIF
27635
27636 !LPB[12]
27637
27638    i_start =its
27639    i_end =min(ite, ide-1)
27640    j_start =jts
27641    j_end =min(jte, jde-1)
27642
27643 !LPB[11]
27644
27645    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
27646
27647    DO i =i_end, i_start, -1
27648    DO k =ktf, kts, -1
27649    gwalls =0.5*(rv(i,k,jte-1) +rv(i,k,jte))
27650    vb =max(gwalls, 0.)
27651    a_Tmpv7 =a_tendency(i,k,j_end)
27652    a_tendency(i,k,j_end) =0.0
27653    a_tendency(i,k,j_end) =a_tendency(i,k,j_end) +a_Tmpv7
27654    a_Tmpv6 =-a_Tmpv7
27655    a_Tmpv5 =rdy*a_Tmpv6
27656    a_field(i,k,j_end) =a_field(i,k,j_end) +(rv(i,k,jte) -rv(i,k,jte-1))*a_Tmpv5
27657    a_Tmpv3 =field(i,k,j_end)*a_Tmpv5
27658    a_rv(i,k,jte) =a_rv(i,k,jte) +a_Tmpv3
27659    a_rv(i,k,jte-1) =a_rv(i,k,jte-1) -a_Tmpv3
27660    a_vb =a_vb +(field_old(i,k,j_end) -field_old(i,k,j_end-1))*a_Tmpv5
27661    a_Tmpv1 =vb*a_Tmpv5
27662    a_field_old(i,k,j_end) =a_field_old(i,k,j_end) +a_Tmpv1
27663    a_field_old(i,k,j_end-1) =a_field_old(i,k,j_end-1) -a_Tmpv1
27664
27665    a_Tmpv2 = (1.0 +(1.0)*sign(1.0, gwalls-0.))*0.5*a_vb
27666    a_vb =0.0
27667    a_Tmpv1 =0.5*a_Tmpv2
27668    a_rv(i,k,jte-1) =a_rv(i,k,jte-1) +a_Tmpv1
27669    a_rv(i,k,jte) =a_rv(i,k,jte) +a_Tmpv1
27670    ENDDO
27671    ENDDO
27672
27673    ENDIF
27674
27675 !LPB[9]
27676
27677    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
27678
27679    DO i =i_end, i_start, -1
27680    DO k =ktf, kts, -1
27681    gwalls =0.5*(rv(i,k,jts) +rv(i,k,jts+1))
27682    vb =min(gwalls, 0.)
27683    a_Tmpv7 =a_tendency(i,k,jts)
27684    a_tendency(i,k,jts) =0.0
27685    a_tendency(i,k,jts) =a_tendency(i,k,jts) +a_Tmpv7
27686    a_Tmpv5 =-rdy*a_Tmpv7
27687    a_field(i,k,jts) =a_field(i,k,jts) +(rv(i,k,jts+1) -rv(i,k,jts))*a_Tmpv5
27688    a_Tmpv3 =field(i,k,jts)*a_Tmpv5
27689    a_rv(i,k,jts+1) =a_rv(i,k,jts+1) +a_Tmpv3
27690    a_rv(i,k,jts) =a_rv(i,k,jts) -a_Tmpv3
27691    a_vb =a_vb +(field_old(i,k,jts+1) -field_old(i,k,jts))*a_Tmpv5
27692    a_Tmpv1 =vb*a_Tmpv5
27693    a_field_old(i,k,jts+1) =a_field_old(i,k,jts+1) +a_Tmpv1
27694    a_field_old(i,k,jts) =a_field_old(i,k,jts) -a_Tmpv1
27695
27696    a_Tmpv2 = (1.0 -(1.0)*sign(1.0, gwalls-0.))*0.5*a_vb
27697    a_vb =0.0
27698    a_Tmpv1 =0.5*a_Tmpv2
27699    a_rv(i,k,jts) =a_rv(i,k,jts) +a_Tmpv1
27700    a_rv(i,k,jts+1) =a_rv(i,k,jts+1) +a_Tmpv1
27701    ENDDO
27702    ENDDO
27703
27704    ENDIF
27705
27706 !LPB[7]
27707
27708    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
27709
27710    DO j =j_end, j_start, -1
27711    DO k =ktf, kts, -1
27712    gwalls=0.5*(ru(ite-1,k,j) +ru(ite,k,j))
27713    ub =max(gwalls, 0.)
27714    a_Tmpv7 =a_tendency(i_end,k,j)
27715    a_tendency(i_end,k,j) =0.0
27716    a_tendency(i_end,k,j) =a_tendency(i_end,k,j) +a_Tmpv7
27717    a_Tmpv6 =-a_Tmpv7
27718    a_Tmpv5 =rdx*a_Tmpv6
27719    a_Tmpv2 =a_Tmpv5
27720    a_Tmpv4 =a_Tmpv5
27721    a_field(i_end,k,j) =a_field(i_end,k,j) +(ru(ite,k,j) -ru(ite-1,k,j))*a_Tmpv4
27722    a_Tmpv3 =field(i_end,k,j)*a_Tmpv4
27723    a_ru(ite,k,j) =a_ru(ite,k,j) +a_Tmpv3
27724    a_ru(ite-1,k,j) =a_ru(ite-1,k,j) -a_Tmpv3
27725    a_ub =a_ub +(field_old(i_end,k,j) -field_old(i_end-1,k,j))*a_Tmpv2
27726    a_Tmpv1 =ub*a_Tmpv2
27727    a_field_old(i_end,k,j) =a_field_old(i_end,k,j) +a_Tmpv1
27728    a_field_old(i_end-1,k,j) =a_field_old(i_end-1,k,j) -a_Tmpv1
27729
27730    a_Tmpv2 = (1.0 +(1.0)*sign(1.0, gwalls-0.))*0.5*a_ub
27731    a_ub =0.0
27732    a_Tmpv1 =0.5*a_Tmpv2
27733    a_ru(ite-1,k,j) =a_ru(ite-1,k,j) +a_Tmpv1
27734    a_ru(ite,k,j) =a_ru(ite,k,j) +a_Tmpv1
27735    ENDDO
27736    ENDDO
27737
27738    ENDIF
27739
27740 !LPB[5]
27741
27742    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
27743
27744    DO j =j_end, j_start, -1
27745    DO k =ktf, kts, -1
27746    gwalls =0.5*(ru(its,k,j) +ru(its+1,k,j))
27747    ub =min(gwalls, 0.)
27748    a_Tmpv7 =a_tendency(its,k,j)
27749    a_tendency(its,k,j) =0.0
27750    a_tendency(its,k,j) =a_tendency(its,k,j) +a_Tmpv7
27751    a_Tmpv6 =-a_Tmpv7
27752    a_Tmpv5 =rdx*a_Tmpv6
27753    a_Tmpv2 =a_Tmpv5
27754    a_Tmpv4 =a_Tmpv5
27755    a_field(its,k,j) =a_field(its,k,j) +(ru(its+1,k,j) -ru(its,k,j))*a_Tmpv4
27756    a_Tmpv3 =field(its,k,j)*a_Tmpv4
27757    a_ru(its+1,k,j) =a_ru(its+1,k,j) +a_Tmpv3
27758    a_ru(its,k,j) =a_ru(its,k,j) -a_Tmpv3
27759    a_ub =a_ub +(field_old(its+1,k,j) -field_old(its,k,j))*a_Tmpv2
27760    a_Tmpv1 =ub*a_Tmpv2
27761    a_field_old(its+1,k,j) =a_field_old(its+1,k,j) +a_Tmpv1
27762    a_field_old(its,k,j) =a_field_old(its,k,j) -a_Tmpv1
27763
27764    a_Tmpv2 = (1.0 -(1.0)*sign(1.0, gwalls -0.))*0.5*a_ub
27765    a_ub =0.0
27766    a_Tmpv1 =0.5*a_Tmpv2
27767    a_ru(its,k,j) =a_ru(its,k,j) +a_Tmpv1
27768    a_ru(its+1,k,j) =a_ru(its+1,k,j) +a_Tmpv1
27769    ENDDO
27770    ENDDO
27771
27772    ENDIF
27773
27774 !LPB[3]
27775
27776    IF( horz_order == 5 ) THEN
27777    ktf=MIN(kte,kde-1)
27778
27779    i_start = its-1
27780    i_end   = MIN(ite,ide-1)+1
27781    i_start_f = i_start
27782    i_end_f   = i_end+1
27783    j_start = jts-1
27784    j_end   = MIN(jte,jde-1)+1
27785    IF(degrade_ys) j_start = MAX(jts-1,jds)
27786    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
27787    IF(degrade_xs) then
27788      i_start = MAX(ids+1,its-1)
27789      i_start_f = ids+3
27790    ENDIF
27791    IF(degrade_xe) then
27792      i_end = MIN(ide-2,ite+1)
27793      i_end_f = ide-3
27794    ENDIF
27795
27796    DO j =j_end, j_start, -1
27797
27798    IF( degrade_xe ) THEN
27799
27800    DO i =i_end+1, i_end_f+1, -1
27801
27802    IF( i == ide-2 ) THEN
27803
27804    DO k =ktf, kts, -1
27805    vel =ru(i,k,j)
27806    cr =vel
27807
27808    IF(cr.gt. 0) THEN
27809    qmax(i,k,j) = Tmpv716(k,j)
27810    qmin(i,k,j) = Tmpv717(k,j)
27811
27812    a_Tmpv1 =a_qmax(i,k,j)
27813    a_qmax(i,k,j) =0.0
27814    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i-1,k,j)  &
27815    ))*0.5*1.0*a_Tmpv1
27816    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
27817     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
27818    a_Tmpv1 =a_qmin(i,k,j)
27819    a_qmin(i,k,j) =0.0
27820    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i-1,k,j)  &
27821    ))*0.5*1.0*a_Tmpv1
27822    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
27823     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
27824
27825    ELSE
27826
27827    qmax(i-1,k,j) = Tmpv718(k,j)
27828    qmin(i-1,k,j) = Tmpv719(k,j)
27829
27830    a_Tmpv1 =a_qmin(i-1,k,j)
27831    a_qmin(i-1,k,j) =0.0
27832    a_qmin(i-1,k,j) =a_qmin(i-1,k,j)  +(1.0 -sign(1.0, qmin(i-1,k,j)  &
27833     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27834    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i-1,k,j)  &
27835     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27836    a_Tmpv1 =a_qmax(i-1,k,j)
27837    a_qmax(i-1,k,j) =0.0
27838    a_qmax(i-1,k,j) =a_qmax(i-1,k,j)  +(1.0 +sign(1.0, qmax(i-1,k,j)  &
27839     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27840    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i-1,k,j)  &
27841     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27842    END IF
27843
27844    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j)
27845    a_Tmpv2 =a_fqx(i,k,j)
27846    a_fqx(i,k,j) =0.0
27847    a_vel =a_vel +flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)*a_Tmpv2
27848    a_Tmpv1 =vel*a_Tmpv2
27849    a_vel =a_vel +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j),0.0,field(i,k,j)  &
27850    ,0.0,field(i+1,k,j),0.0,vel,1.0)*a_Tmpv1
27851    a_field(i+1,k,j) =a_field(i+1,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,  &
27852    j),0.0,field(i,k,j),0.0,field(i+1,k,j),1.0,vel,0.0)*a_Tmpv1
27853    a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j)  &
27854    ,0.0,field(i,k,j),1.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1
27855    a_field(i-1,k,j) =a_field(i-1,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,  &
27856    j),1.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1
27857    a_field(i-2,k,j) =a_field(i-2,k,j) +Diff_flux3(field(i-2,k,j),1.0,field(i-1,k,  &
27858    j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1
27859
27860    a_Tmpv2 =a_fqxl(i,k,j)
27861    a_fqxl(i,k,j) =0.0
27862    a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2
27863    a_Tmpv1 =vel*a_Tmpv2
27864    a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j)  &
27865    ,0.0,cr,1.0)*a_Tmpv1
27866    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
27867    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
27868    a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
27869    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
27870
27871    a_vel =a_vel +a_cr
27872    a_cr =0.0
27873
27874    a_ru(i,k,j) =a_ru(i,k,j) +a_vel
27875    a_vel =0.0
27876    ENDDO
27877
27878    ENDIF
27879
27880    IF( i == ide-1 ) THEN
27881
27882    DO k =ktf, kts, -1
27883    vel =ru(i,k,j)
27884    cr =vel
27885
27886    IF(cr.gt. 0) THEN
27887    qmax(i,k,j) = Tmpv712(k,j)
27888    qmin(i,k,j) = Tmpv713(k,j)
27889
27890    a_Tmpv1 =a_qmax(i,k,j)
27891    a_qmax(i,k,j) =0.0
27892    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i-1,k,j)  &
27893    ))*0.5*1.0*a_Tmpv1
27894    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
27895     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
27896    a_Tmpv1 =a_qmin(i,k,j)
27897    a_qmin(i,k,j) =0.0
27898    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i-1,k,j)  &
27899    ))*0.5*1.0*a_Tmpv1
27900    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
27901     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
27902
27903    else
27904
27905    qmax(i-1,k,j) = Tmpv714(k,j)
27906    qmin(i-1,k,j) = Tmpv715(k,j)
27907
27908    a_Tmpv1 =a_qmin(i-1,k,j)
27909    a_qmin(i-1,k,j) =0.0
27910    a_qmin(i-1,k,j) =a_qmin(i-1,k,j)  +(1.0 -sign(1.0, qmin(i-1,k,j)  &
27911     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27912    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i-1,k,j)  &
27913     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27914    a_Tmpv1 =a_qmax(i-1,k,j)
27915    a_qmax(i-1,k,j) =0.0
27916    a_qmax(i-1,k,j) =a_qmax(i-1,k,j)  +(1.0 +sign(1.0, qmax(i-1,k,j)  &
27917     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27918    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i-1,k,j)  &
27919     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27920
27921    end IF
27922
27923    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j)
27924    a_Tmpv2 =a_fqx(i,k,j)
27925    a_fqx(i,k,j) =0.0
27926    a_ru(i,k,j) =a_ru(i,k,j) +0.5*(field(i,k,j) +field(i-1,k,j))*a_Tmpv2
27927    a_Tmpv1 =0.5*(ru(i,k,j))*a_Tmpv2
27928    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1
27929    a_field(i-1,k,j) =a_field(i-1,k,j) +a_Tmpv1
27930    a_Tmpv2 =a_fqxl(i,k,j)
27931    a_fqxl(i,k,j) =0.0
27932    a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2
27933    a_Tmpv1 =vel*a_Tmpv2
27934    a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j)  &
27935    ,0.0,cr,1.0)*a_Tmpv1
27936    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
27937    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
27938    a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
27939    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
27940
27941    a_vel =a_vel +a_cr
27942    a_cr =0.0
27943
27944    a_ru(i,k,j) =a_ru(i,k,j) +a_vel
27945    a_vel =0.0
27946    ENDDO
27947
27948    ENDIF
27949    ENDDO
27950
27951    ENDIF
27952
27953    IF( degrade_xs ) THEN
27954
27955    DO i =i_start_f-1, i_start, -1
27956
27957    IF(i == ids+2) THEN
27958
27959    DO k =ktf, kts, -1
27960    vel =ru(i,k,j)
27961    cr =vel
27962
27963    IF(cr.gt. 0) THEN
27964    qmax(i,k,j) = Tmpv708(k,j)
27965    qmin(i,k,j) = Tmpv709(k,j)
27966
27967    a_Tmpv1 =a_qmax(i,k,j)
27968    a_qmax(i,k,j) =0.0
27969    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i-1,k,j)  &
27970    ))*0.5*1.0*a_Tmpv1
27971    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
27972     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
27973    a_Tmpv1 =a_qmin(i,k,j)
27974    a_qmin(i,k,j) =0.0
27975    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i-1,k,j)  &
27976    ))*0.5*1.0*a_Tmpv1
27977    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
27978     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
27979
27980    else
27981
27982    qmax(i-1,k,j) = Tmpv710(k,j)
27983    qmin(i-1,k,j) = Tmpv711(k,j)
27984
27985    a_Tmpv1 =a_qmin(i-1,k,j)
27986    a_qmin(i-1,k,j) =0.0
27987    a_qmin(i-1,k,j) =a_qmin(i-1,k,j)  +(1.0 -sign(1.0, qmin(i-1,k,j)  &
27988     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27989    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i-1,k,j)  &
27990     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27991    a_Tmpv1 =a_qmax(i-1,k,j)
27992    a_qmax(i-1,k,j) =0.0
27993    a_qmax(i-1,k,j) =a_qmax(i-1,k,j)  +(1.0 +sign(1.0, qmax(i-1,k,j)  &
27994     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27995    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i-1,k,j)  &
27996     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
27997
27998    end IF
27999
28000    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j)
28001    a_Tmpv2 =a_fqx(i,k,j)
28002    a_fqx(i,k,j) =0.0
28003    a_vel =a_vel +flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)*a_Tmpv2
28004    a_Tmpv1 =vel*a_Tmpv2
28005    a_vel =a_vel +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j),0.0,field(i,k,j)  &
28006    ,0.0,field(i+1,k,j),0.0,vel,1.0)*a_Tmpv1
28007    a_field(i+1,k,j) =a_field(i+1,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,  &
28008    j),0.0,field(i,k,j),0.0,field(i+1,k,j),1.0,vel,0.0)*a_Tmpv1
28009    a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j)  &
28010    ,0.0,field(i,k,j),1.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1
28011    a_field(i-1,k,j) =a_field(i-1,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,  &
28012    j),1.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1
28013    a_field(i-2,k,j) =a_field(i-2,k,j) +Diff_flux3(field(i-2,k,j),1.0,field(i-1,k,  &
28014    j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1
28015
28016    a_Tmpv2 =a_fqxl(i,k,j)
28017    a_fqxl(i,k,j) =0.0
28018    a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2
28019    a_Tmpv1 =vel*a_Tmpv2
28020    a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j)  &
28021    ,0.0,cr,1.0)*a_Tmpv1
28022    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
28023    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28024    a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
28025    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28026
28027    a_vel =a_vel +a_cr
28028    a_cr =0.0
28029
28030    a_ru(i,k,j) =a_ru(i,k,j) +a_vel
28031    a_vel =0.0
28032    ENDDO
28033
28034    ENDIF
28035
28036    IF(i == ids+1) THEN
28037
28038    DO k =ktf, kts, -1
28039    vel =ru(i,k,j)
28040    cr =vel
28041
28042    IF(cr.gt. 0) THEN
28043    qmax(i,k,j) = Tmpv704(k,j)
28044    qmin(i,k,j) = Tmpv705(k,j)
28045
28046    a_Tmpv1 =a_qmax(i,k,j)
28047    a_qmax(i,k,j) =0.0
28048    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i-1,k,j)  &
28049    ))*0.5*1.0*a_Tmpv1
28050    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28051     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
28052    a_Tmpv1 =a_qmin(i,k,j)
28053    a_qmin(i,k,j) =0.0
28054    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i-1,k,j)  &
28055    ))*0.5*1.0*a_Tmpv1
28056    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28057     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
28058
28059    else
28060
28061    qmax(i-1,k,j) = Tmpv706(k,j)
28062    qmin(i-1,k,j) = Tmpv707(k,j)
28063
28064    a_Tmpv1 =a_qmin(i-1,k,j)
28065    a_qmin(i-1,k,j) =0.0
28066    a_qmin(i-1,k,j) =a_qmin(i-1,k,j)  +(1.0 -sign(1.0, qmin(i-1,k,j)  &
28067     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28068    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i-1,k,j)  &
28069     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28070    a_Tmpv1 =a_qmax(i-1,k,j)
28071    a_qmax(i-1,k,j) =0.0
28072    a_qmax(i-1,k,j) =a_qmax(i-1,k,j)  +(1.0 +sign(1.0, qmax(i-1,k,j)  &
28073     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28074    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i-1,k,j)  &
28075     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28076
28077    end IF
28078
28079    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j)
28080    a_Tmpv2 =a_fqx(i,k,j)
28081    a_fqx(i,k,j) =0.0
28082    a_ru(i,k,j) =a_ru(i,k,j) +0.5*(field(i,k,j)+field(i-1,k,j))*a_Tmpv2
28083    a_Tmpv1 =0.5*(ru(i,k,j))*a_Tmpv2
28084    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1
28085    a_field(i-1,k,j) =a_field(i-1,k,j) +a_Tmpv1
28086    a_Tmpv2 =a_fqxl(i,k,j)
28087    a_fqxl(i,k,j) =0.0
28088    a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2
28089    a_Tmpv1 =vel*a_Tmpv2
28090    a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j)  &
28091    ,0.0,cr,1.0)*a_Tmpv1
28092    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
28093    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28094    a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
28095    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28096
28097    a_vel =a_vel +a_cr
28098    a_cr =0.0
28099
28100    a_ru(i,k,j) =a_ru(i,k,j) +a_vel
28101    a_vel =0.0
28102    ENDDO
28103
28104    ENDIF
28105    ENDDO
28106
28107    ENDIF
28108
28109    DO k =ktf, kts, -1
28110    DO i =i_end_f, i_start_f, -1
28111    vel =ru(i,k,j)
28112    cr =vel
28113
28114    IF(cr.gt. 0) THEN
28115    qmax(i,k,j) = Tmpv700(i,k,j)
28116    qmin(i,k,j) = Tmpv701(i,k,j)
28117
28118    a_Tmpv1 =a_qmax(i,k,j)
28119    a_qmax(i,k,j) =0.0
28120    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i-1,k,j)  &
28121    ))*0.5*1.0*a_Tmpv1
28122    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28123     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
28124    a_Tmpv1 =a_qmin(i,k,j)
28125    a_qmin(i,k,j) =0.0
28126    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i-1,k,j)  &
28127    ))*0.5*1.0*a_Tmpv1
28128    a_field_old(i-1,k,j) =a_field_old(i-1,k,j)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28129     -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1
28130
28131    else
28132
28133    qmax(i-1,k,j) = Tmpv702(i-1,k,j)
28134    qmin(i-1,k,j) = Tmpv703(i-1,k,j)
28135
28136    a_Tmpv1 =a_qmin(i-1,k,j)
28137    a_qmin(i-1,k,j) =0.0
28138    a_qmin(i-1,k,j) =a_qmin(i-1,k,j)  +(1.0 -sign(1.0, qmin(i-1,k,j)  &
28139     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28140    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i-1,k,j)  &
28141     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28142    a_Tmpv1 =a_qmax(i-1,k,j)
28143    a_qmax(i-1,k,j) =0.0
28144    a_qmax(i-1,k,j) =a_qmax(i-1,k,j)  +(1.0 +sign(1.0, qmax(i-1,k,j)  &
28145     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28146    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i-1,k,j)  &
28147     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28148
28149    end IF
28150
28151    a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j)
28152    a_Tmpv2 =a_fqx(i,k,j)
28153    a_fqx(i,k,j) =0.0
28154    a_vel =a_vel +flux5(field(i-3,k,j),field(i-2,k,j),field(i-1,k,j),field(i,k,j)  &
28155    ,field(i+1,k,j),field(i+2,k,j),vel)*a_Tmpv2
28156    a_Tmpv1 =vel*a_Tmpv2
28157    a_vel =a_vel +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,j),0.0,field(i-1,k,j)  &
28158    ,0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,field(i+2,k,j),0.0,vel,1.0)*a_Tmpv1
28159    a_field(i+2,k,j) =a_field(i+2,k,j) +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,  &
28160    j),0.0,field(i-1,k,j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,field(i+2,k,j)  &
28161    ,1.0,vel,0.0)*a_Tmpv1
28162    a_field(i+1,k,j) =a_field(i+1,k,j) +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,  &
28163    j),0.0,field(i-1,k,j),0.0,field(i,k,j),0.0,field(i+1,k,j),1.0,field(i+2,k,j)  &
28164    ,0.0,vel,0.0)*a_Tmpv1
28165    a_field(i,k,j) =a_field(i,k,j) +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,j)  &
28166    ,0.0,field(i-1,k,j),0.0,field(i,k,j),1.0,field(i+1,k,j),0.0,field(i+2,k,j)  &
28167    ,0.0,vel,0.0)*a_Tmpv1
28168    a_field(i-1,k,j) =a_field(i-1,k,j) +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,  &
28169    j),0.0,field(i-1,k,j),1.0,field(i,k,j),0.0,field(i+1,k,j),0.0,field(i+2,k,j)  &
28170    ,0.0,vel,0.0)*a_Tmpv1
28171    a_field(i-2,k,j) =a_field(i-2,k,j) +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,  &
28172    j),1.0,field(i-1,k,j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,field(i+2,k,j)  &
28173    ,0.0,vel,0.0)*a_Tmpv1
28174    a_field(i-3,k,j) =a_field(i-3,k,j) +Diff_flux5(field(i-3,k,j),1.0,field(i-2,k,  &
28175    j),0.0,field(i-1,k,j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,field(i+2,k,j)  &
28176    ,0.0,vel,0.0)*a_Tmpv1
28177
28178    a_Tmpv2 =a_fqxl(i,k,j)
28179    a_fqxl(i,k,j) =0.0
28180    a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2
28181    a_Tmpv1 =vel*a_Tmpv2
28182    a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j)  &
28183    ,0.0,cr,1.0)*a_Tmpv1
28184    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
28185    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28186    a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j)  &
28187    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28188
28189    a_vel =a_vel +a_cr
28190    a_cr =0.0
28191
28192    a_ru(i,k,j) =a_ru(i,k,j) +a_vel
28193    a_vel =0.0
28194    ENDDO
28195    ENDDO
28196    ENDDO
28197
28198    ktf=MIN(kte,kde-1)
28199
28200    i_start = its-1
28201    i_end   = MIN(ite,ide-1)+1
28202    j_start = jts-1
28203    j_end   = MIN(jte,jde-1)+1
28204    j_start_f = j_start
28205    j_end_f   = j_end+1
28206    IF(degrade_xs) i_start = MAX(its-1,ids)
28207    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
28208    IF(degrade_ys) then
28209      j_start = MAX(jts-1,jds+1)
28210      j_start_f = jds+3
28211    ENDIF
28212    IF(degrade_ye) then
28213      j_end = MIN(jte+1,jde-2)
28214      j_end_f = jde-3
28215    ENDIF
28216
28217    DO j =j_end+1, j_start, -1
28218
28219    IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
28220
28221    DO k =ktf, kts, -1
28222    DO i =i_end, i_start, -1
28223    vel =rv(i,k,j)
28224    cr =vel
28225
28226    IF(cr.gt. 0) THEN
28227    qmax(i,k,j) = Tmpv600(i,k,j)
28228    qmin(i,k,j) = Tmpv601(i,k,j)
28229
28230    a_Tmpv1 =a_qmax(i,k,j)
28231    a_qmax(i,k,j) =0.0
28232    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k,j-1)  &
28233    ))*0.5*1.0*a_Tmpv1
28234    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28235     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28236    a_Tmpv1 =a_qmin(i,k,j)
28237    a_qmin(i,k,j) =0.0
28238    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k,j-1)  &
28239    ))*0.5*1.0*a_Tmpv1
28240    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28241     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28242
28243    else
28244
28245    qmax(i,k,j-1) = Tmpv602(i,k,j-1)
28246    qmin(i,k,j-1) = Tmpv603(i,k,j-1)
28247
28248    a_Tmpv1 =a_qmin(i,k,j-1)
28249    a_qmin(i,k,j-1) =0.0
28250    a_qmin(i,k,j-1) =a_qmin(i,k,j-1)  +(1.0 -sign(1.0, qmin(i,k,j-1)  &
28251     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28252    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k,j-1)  &
28253     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28254    a_Tmpv1 =a_qmax(i,k,j-1)
28255    a_qmax(i,k,j-1) =0.0
28256    a_qmax(i,k,j-1) =a_qmax(i,k,j-1)  +(1.0 +sign(1.0, qmax(i,k,j-1)  &
28257     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28258    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k,j-1)  &
28259     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28260
28261    end IF
28262
28263    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j)
28264    a_Tmpv2 =a_fqy(i,k,j)
28265    a_fqy(i,k,j) =0.0
28266    a_vel =a_vel +flux5(field(i,k,j-3),field(i,k,j-2),field(i,k,j-1),field(i,k,j)  &
28267    ,field(i,k,j+1),field(i,k,j+2),vel)*a_Tmpv2
28268    a_Tmpv1 =vel*a_Tmpv2
28269    a_vel =a_vel +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-2),0.0,field(i,k,j-1)  &
28270    ,0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,field(i,k,j+2),0.0,vel,1.0)*a_Tmpv1
28271    a_field(i,k,j+2) =a_field(i,k,j+2) +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-  &
28272    2),0.0,field(i,k,j-1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,field(i,k,j+2)  &
28273    ,1.0,vel,0.0)*a_Tmpv1
28274    a_field(i,k,j+1) =a_field(i,k,j+1) +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-  &
28275    2),0.0,field(i,k,j-1),0.0,field(i,k,j),0.0,field(i,k,j+1),1.0,field(i,k,j+2)  &
28276    ,0.0,vel,0.0)*a_Tmpv1
28277    a_field(i,k,j) =a_field(i,k,j) +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-2)  &
28278    ,0.0,field(i,k,j-1),0.0,field(i,k,j),1.0,field(i,k,j+1),0.0,field(i,k,j+2)  &
28279    ,0.0,vel,0.0)*a_Tmpv1
28280    a_field(i,k,j-1) =a_field(i,k,j-1) +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-  &
28281    2),0.0,field(i,k,j-1),1.0,field(i,k,j),0.0,field(i,k,j+1),0.0,field(i,k,j+2)  &
28282    ,0.0,vel,0.0)*a_Tmpv1
28283    a_field(i,k,j-2) =a_field(i,k,j-2) +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-  &
28284    2),1.0,field(i,k,j-1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,field(i,k,j+2)  &
28285    ,0.0,vel,0.0)*a_Tmpv1
28286    a_field(i,k,j-3) =a_field(i,k,j-3) +Diff_flux5(field(i,k,j-3),1.0,field(i,k,j-  &
28287    2),0.0,field(i,k,j-1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,field(i,k,j+2)  &
28288    ,0.0,vel,0.0)*a_Tmpv1
28289
28290    a_Tmpv2 =a_fqyl(i,k,j)
28291    a_fqyl(i,k,j) =0.0
28292    a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),vel)*a_Tmpv2
28293    a_Tmpv1 =vel*a_Tmpv2
28294    a_vel =a_vel +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j)  &
28295    ,0.0,vel,1.0)*a_Tmpv1
28296    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1)  &
28297    ,0.0,field_old(i,k,j),1.0,vel,0.0)*a_Tmpv1
28298    a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1)  &
28299    ,1.0,field_old(i,k,j),0.0,vel,0.0)*a_Tmpv1
28300
28301    a_vel =a_vel +a_cr
28302    a_cr =0.0
28303
28304    a_rv(i,k,j) =a_rv(i,k,j) +a_vel
28305    a_vel =0.0
28306    ENDDO
28307    ENDDO
28308
28309    ELSE IF( j == jds+1 ) THEN
28310
28311    DO k =ktf, kts, -1
28312    DO i =i_end, i_start, -1
28313    vel =rv(i,k,j)
28314    cr =vel
28315
28316    IF(cr.gt. 0) THEN
28317    qmax(i,k,j) = Tmpv604(i,k)
28318    qmin(i,k,j) = Tmpv605(i,k)
28319
28320    a_Tmpv1 =a_qmax(i,k,j)
28321    a_qmax(i,k,j) =0.0
28322    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k,j-1)  &
28323    ))*0.5*1.0*a_Tmpv1
28324    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28325     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28326    a_Tmpv1 =a_qmin(i,k,j)
28327    a_qmin(i,k,j) =0.0
28328    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k,j-1)  &
28329    ))*0.5*1.0*a_Tmpv1
28330    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28331     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28332
28333    else
28334
28335    qmax(i,k,j-1) = Tmpv606(i,k)
28336    qmin(i,k,j-1) = Tmpv607(i,k)
28337
28338    a_Tmpv1 =a_qmin(i,k,j-1)
28339    a_qmin(i,k,j-1) =0.0
28340    a_qmin(i,k,j-1) =a_qmin(i,k,j-1)  +(1.0 -sign(1.0, qmin(i,k,j-1)  &
28341     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28342    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k,j-1)  &
28343     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28344    a_Tmpv1 =a_qmax(i,k,j-1)
28345    a_qmax(i,k,j-1) =0.0
28346    a_qmax(i,k,j-1) =a_qmax(i,k,j-1)  +(1.0 +sign(1.0, qmax(i,k,j-1)  &
28347     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28348    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k,j-1)  &
28349     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28350
28351    end IF
28352
28353    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j)
28354    a_Tmpv2 =a_fqy(i,k,j)
28355    a_fqy(i,k,j) =0.0
28356    a_rv(i,k,j) =a_rv(i,k,j) +0.5*(field(i,k,j) +field(i,k,j-1))*a_Tmpv2
28357    a_Tmpv1 =0.5*rv(i,k,j)*a_Tmpv2
28358    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1
28359    a_field(i,k,j-1) =a_field(i,k,j-1) +a_Tmpv1
28360    a_Tmpv2 =a_fqyl(i,k,j)
28361    a_fqyl(i,k,j) =0.0
28362    a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2
28363    a_Tmpv1 =vel*a_Tmpv2
28364    a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j)  &
28365    ,0.0,cr,1.0)*a_Tmpv1
28366    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1)  &
28367    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28368    a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1)  &
28369    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28370
28371    a_vel =a_vel +a_cr
28372    a_cr =0.0
28373
28374    a_rv(i,k,j) =a_rv(i,k,j) +a_vel
28375    a_vel =0.0
28376    ENDDO
28377    ENDDO
28378
28379    ELSE IF( j == jds+2 ) THEN
28380
28381    DO k =ktf, kts, -1
28382    DO i =i_end, i_start, -1
28383    vel =rv(i,k,j)
28384    cr =vel
28385
28386    IF(cr.gt. 0) THEN
28387    qmax(i,k,j) = Tmpv608(i,k)
28388    qmin(i,k,j) = Tmpv609(i,k)
28389
28390    a_Tmpv1 =a_qmax(i,k,j)
28391    a_qmax(i,k,j) =0.0
28392    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k,j-1)  &
28393    ))*0.5*1.0*a_Tmpv1
28394    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28395     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28396    a_Tmpv1 =a_qmin(i,k,j)
28397    a_qmin(i,k,j) =0.0
28398    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k,j-1)  &
28399    ))*0.5*1.0*a_Tmpv1
28400    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28401     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28402
28403    else
28404
28405    qmax(i,k,j-1) = Tmpv6010(i,k)
28406    qmin(i,k,j-1) = Tmpv6011(i,k)
28407
28408    a_Tmpv1 =a_qmin(i,k,j-1)
28409    a_qmin(i,k,j-1) =0.0
28410    a_qmin(i,k,j-1) =a_qmin(i,k,j-1)  +(1.0 -sign(1.0, qmin(i,k,j-1)  &
28411     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28412    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k,j-1)  &
28413     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28414    a_Tmpv1 =a_qmax(i,k,j-1)
28415    a_qmax(i,k,j-1) =0.0
28416    a_qmax(i,k,j-1) =a_qmax(i,k,j-1)  +(1.0 +sign(1.0, qmax(i,k,j-1)  &
28417     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28418    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k,j-1)  &
28419     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28420
28421    end IF
28422
28423    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j)
28424    a_Tmpv2 =a_fqy(i,k,j)
28425    a_fqy(i,k,j) =0.0
28426    a_vel =a_vel +flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)*a_Tmpv2
28427    a_Tmpv1 =vel*a_Tmpv2
28428    a_vel =a_vel +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1),0.0,field(i,k,j)  &
28429    ,0.0,field(i,k,j+1),0.0,vel,1.0)*a_Tmpv1
28430    a_field(i,k,j+1) =a_field(i,k,j+1) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-  &
28431    1),0.0,field(i,k,j),0.0,field(i,k,j+1),1.0,vel,0.0)*a_Tmpv1
28432    a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1)  &
28433    ,0.0,field(i,k,j),1.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1
28434    a_field(i,k,j-1) =a_field(i,k,j-1) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-  &
28435    1),1.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1
28436    a_field(i,k,j-2) =a_field(i,k,j-2) +Diff_flux3(field(i,k,j-2),1.0,field(i,k,j-  &
28437    1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1
28438
28439    a_Tmpv2 =a_fqyl(i,k,j)
28440    a_fqyl(i,k,j) =0.0
28441    a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2
28442    a_Tmpv1 =vel*a_Tmpv2
28443    a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j)  &
28444    ,0.0,cr,1.0)*a_Tmpv1
28445    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1)  &
28446    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28447    a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1)  &
28448    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28449
28450    a_vel =a_vel +a_cr
28451    a_cr =0.0
28452
28453    a_rv(i,k,j) =a_rv(i,k,j) +a_vel
28454    a_vel =0.0
28455    ENDDO
28456    ENDDO
28457
28458    ELSE IF( j == jde-1 ) THEN
28459
28460    DO k =ktf, kts, -1
28461    DO i =i_end, i_start, -1
28462    vel =rv(i,k,j)
28463    cr =vel
28464
28465    IF(cr.gt. 0) THEN
28466    qmax(i,k,j) = Tmpv6012(i,k)
28467    qmin(i,k,j) = Tmpv6013(i,k)
28468
28469    a_Tmpv1 =a_qmax(i,k,j)
28470    a_qmax(i,k,j) =0.0
28471    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k,j-1)  &
28472    ))*0.5*1.0*a_Tmpv1
28473    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28474     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28475    a_Tmpv1 =a_qmin(i,k,j)
28476    a_qmin(i,k,j) =0.0
28477    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k,j-1)  &
28478    ))*0.5*1.0*a_Tmpv1
28479    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28480     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28481
28482    else
28483
28484    qmax(i,k,j-1) = Tmpv6014(i,k)
28485    qmin(i,k,j-1) = Tmpv6015(i,k)
28486
28487    a_Tmpv1 =a_qmin(i,k,j-1)
28488    a_qmin(i,k,j-1) =0.0
28489    a_qmin(i,k,j-1) =a_qmin(i,k,j-1)  +(1.0 -sign(1.0, qmin(i,k,j-1)  &
28490     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28491    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k,j-1)  &
28492     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28493    a_Tmpv1 =a_qmax(i,k,j-1)
28494    a_qmax(i,k,j-1) =0.0
28495    a_qmax(i,k,j-1) =a_qmax(i,k,j-1)  +(1.0 +sign(1.0, qmax(i,k,j-1)  &
28496     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28497    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k,j-1)  &
28498     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28499
28500    end IF
28501
28502    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j)
28503    a_Tmpv2 =a_fqy(i,k,j)
28504    a_fqy(i,k,j) =0.0
28505    a_rv(i,k,j) =a_rv(i,k,j) +0.5*(field(i,k,j) +field(i,k,j-1))*a_Tmpv2
28506    a_Tmpv1 =0.5*rv(i,k,j)*a_Tmpv2
28507    a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1
28508    a_field(i,k,j-1) =a_field(i,k,j-1) +a_Tmpv1
28509    a_Tmpv2 =a_fqyl(i,k,j)
28510    a_fqyl(i,k,j) =0.0
28511    a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2
28512    a_Tmpv1 =vel*a_Tmpv2
28513    a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j)  &
28514    ,0.0,cr,1.0)*a_Tmpv1
28515    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1)  &
28516    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28517    a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1)  &
28518    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28519
28520    a_vel =a_vel +a_cr
28521    a_cr =0.0
28522
28523    a_rv(i,k,j) =a_rv(i,k,j) +a_vel
28524    a_vel =0.0
28525
28526    ENDDO
28527    ENDDO
28528
28529    ELSE IF( j == jde-2 ) THEN
28530
28531    DO k =ktf, kts, -1
28532    DO i =i_end, i_start, -1
28533    vel =rv(i,k,j)
28534    cr =vel
28535
28536    IF(cr.gt. 0) THEN
28537    qmax(i,k,j) = Tmpv6016(i,k)
28538    qmin(i,k,j) = Tmpv6017(i,k)
28539
28540    a_Tmpv1 =a_qmax(i,k,j)
28541    a_qmax(i,k,j) =0.0
28542    a_qmax(i,k,j) =a_qmax(i,k,j)  +(1.0 +sign(1.0, qmax(i,k,j) -field_old(i,k,j-1)  &
28543    ))*0.5*1.0*a_Tmpv1
28544    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 -sign(1.0, qmax(i,k,j)  &
28545     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28546    a_Tmpv1 =a_qmin(i,k,j)
28547    a_qmin(i,k,j) =0.0
28548    a_qmin(i,k,j) =a_qmin(i,k,j)  +(1.0 -sign(1.0, qmin(i,k,j) -field_old(i,k,j-1)  &
28549    ))*0.5*1.0*a_Tmpv1
28550    a_field_old(i,k,j-1) =a_field_old(i,k,j-1)  +(1.0 +sign(1.0, qmin(i,k,j)  &
28551     -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1
28552
28553    else
28554
28555    qmax(i,k,j-1) = Tmpv6018(i,k)
28556    qmin(i,k,j-1) = Tmpv6019(i,k)
28557
28558    a_Tmpv1 =a_qmin(i,k,j-1)
28559    a_qmin(i,k,j-1) =0.0
28560    a_qmin(i,k,j-1) =a_qmin(i,k,j-1)  +(1.0 -sign(1.0, qmin(i,k,j-1)  &
28561     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28562    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 +sign(1.0, qmin(i,k,j-1)  &
28563     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28564    a_Tmpv1 =a_qmax(i,k,j-1)
28565    a_qmax(i,k,j-1) =0.0
28566    a_qmax(i,k,j-1) =a_qmax(i,k,j-1)  +(1.0 +sign(1.0, qmax(i,k,j-1)  &
28567     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28568    a_field_old(i,k,j) =a_field_old(i,k,j)  +(1.0 -sign(1.0, qmax(i,k,j-1)  &
28569     -field_old(i,k,j)))*0.5*1.0*a_Tmpv1
28570
28571    end IF
28572
28573    a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j)
28574    a_Tmpv2 =a_fqy(i,k,j)
28575    a_fqy(i,k,j) =0.0
28576    a_vel =a_vel +flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)*a_Tmpv2
28577    a_Tmpv1 =vel*a_Tmpv2
28578    a_vel =a_vel +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1),0.0,field(i,k,j)  &
28579    ,0.0,field(i,k,j+1),0.0,vel,1.0)*a_Tmpv1
28580    a_field(i,k,j+1) =a_field(i,k,j+1) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-  &
28581    1),0.0,field(i,k,j),0.0,field(i,k,j+1),1.0,vel,0.0)*a_Tmpv1
28582    a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1)  &
28583    ,0.0,field(i,k,j),1.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1
28584    a_field(i,k,j-1) =a_field(i,k,j-1) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-  &
28585    1),1.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1
28586    a_field(i,k,j-2) =a_field(i,k,j-2) +Diff_flux3(field(i,k,j-2),1.0,field(i,k,j-  &
28587    1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1
28588
28589    a_Tmpv2 =a_fqyl(i,k,j)
28590    a_fqyl(i,k,j) =0.0
28591    a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2
28592    a_Tmpv1 =vel*a_Tmpv2
28593    a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j)  &
28594    ,0.0,cr,1.0)*a_Tmpv1
28595    a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1)  &
28596    ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1
28597    a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1)  &
28598    ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1
28599
28600    a_vel =a_vel +a_cr
28601    a_cr =0.0
28602
28603    a_rv(i,k,j) =a_rv(i,k,j) +a_vel
28604    a_vel =0.0
28605    ENDDO
28606    ENDDO
28607
28608    ENDIF
28609    ENDDO
28610
28611    ENDIF
28612
28613 !LPB[1]
28614
28615    DO j =jte+2, jts-2, -1
28616    DO k =kte, kts, -1
28617    DO i =ite+2, its-2, -1
28618    a_field_old(i,k,j) =a_field_old(i,k,j) +a_qmax(i,k,j)
28619    a_field_old(i,k,j) =a_field_old(i,k,j) +a_qmin(i,k,j)
28620    ENDDO
28621    ENDDO
28622    ENDDO
28623
28624    END SUBROUTINE a_advect_scalar_mono
28625
28626 !        Generated by TAPENADE     (INRIA, Ecuador team)
28627 !  Tapenade 3.12 (r6213) - 13 Oct 2016 10:54
28628 !
28629 !  Differentiation of advect_scalar_weno in reverse (adjoint) mode:
28630 !   gradient     of useful results: rom field tendency ru rv field_old
28631 !   with respect to varying inputs: rom field tendency ru rv field_old
28632 !   RW status of diff variables: rom:incr field:incr tendency:in-out
28633 !                ru:incr rv:incr field_old:incr
28634 SUBROUTINE A_ADVECT_SCALAR_WENO(field, fieldb, field_old, field_oldb, &
28635 & tendency, tendencyb, ru, rub, rv, rvb, rom, romb, mut, time_step, &
28636 & config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx&
28637 & , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, &
28638 & kme, its, ite, jts, jte, kts, kte)
28639   IMPLICIT NONE
28640 ! Input data
28641   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
28642   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
28643 & jme, kms, kme, its, ite, jts, jte, kts, kte
28644   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
28645 & field_old, ru, rv, rom
28646   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub&
28647 & , rvb, romb
28648   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
28649   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
28650   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb
28651   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
28652 & msfvy, msftx, msfty
28653   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
28654   REAL, INTENT(IN) :: rdx, rdy
28655   INTEGER, INTENT(IN) :: time_step
28656 ! Local data
28657   INTEGER :: i, j, k, itf, jtf, ktf
28658   INTEGER :: i_start, i_end, j_start, j_end
28659   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
28660   INTEGER :: jmin, jmax, jp, jm, imin, imax
28661   INTEGER, PARAMETER :: is=0, js=0, ks=0
28662   REAL :: mrdx, mrdy, ub, vb, vw
28663   REAL :: ubb, vbb
28664   REAL, DIMENSION(its:ite, kts:kte) :: vflux
28665   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
28666   REAL, DIMENSION(its-is:ite+1, kts:kte) :: fqx
28667   REAL, DIMENSION(its-is:ite+1, kts:kte) :: fqxb
28668 !   REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
28669   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
28670   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
28671   INTEGER :: horz_order, vert_order
28672   LOGICAL :: degrade_xs, degrade_ys
28673   LOGICAL :: degrade_xe, degrade_ye
28674   INTEGER :: jp1, jp0, jtmp
28675   REAL :: dir, vv
28676   REAL :: ue, uw, vs, vn, wb, wt
28677   REAL, PARAMETER :: f30=7./12., f31=1./12.
28678   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
28679   INTEGER :: kt, kb
28680   REAL :: qim2, qim1, qi, qip1, qip2
28681   REAL :: qim2b, qim1b, qib, qip1b, qip2b
28682   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
28683 & sumwk
28684   DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b&
28685 & , wi2b, sumwkb
28686   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
28687 &   3.d0/10.d0, eps=1.0d-28
28688   INTEGER, PARAMETER :: pw=2
28689 ! definition of flux operators, 3rd, 4th, 5th or 6th order
28690   REAL :: flux3, flux4, flux5, flux6
28691   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
28692   REAL :: velb
28693   LOGICAL :: specified
28694   DOUBLE PRECISION :: temp
28695   DOUBLE PRECISION :: temp0
28696   DOUBLE PRECISION :: temp1
28697   DOUBLE PRECISION :: tempb
28698   DOUBLE PRECISION :: tempb0
28699   REAL :: tempb1
28700   REAL :: tempb2
28701   REAL :: tempb3
28702   REAL :: tempb4
28703   REAL :: tempb5
28704   REAL :: tempb6
28705   REAL :: tempb7
28706   REAL :: temp2
28707   REAL :: temp3
28708   REAL :: temp4
28709   REAL :: tempb8
28710   REAL :: tempb9
28711   REAL :: tempb10
28712   REAL :: tempb11
28713   REAL :: temp5
28714   REAL :: temp6
28715   REAL :: temp7
28716   REAL :: tempb12
28717   REAL :: tempb13
28718   REAL :: tempb14
28719   DOUBLE PRECISION :: temp8
28720   DOUBLE PRECISION :: temp9
28721   DOUBLE PRECISION :: temp10
28722   DOUBLE PRECISION :: tempb15
28723   DOUBLE PRECISION :: tempb16
28724   REAL :: tempb17
28725   REAL :: tempb18
28726   REAL :: tempb19
28727   REAL :: tempb20
28728   REAL :: tempb21
28729   REAL :: tempb22
28730   REAL :: tempb23
28731   REAL :: temp11
28732   REAL :: temp12
28733   REAL :: temp13
28734   REAL :: tempb24
28735   REAL :: tempb25
28736   REAL :: tempb26
28737   REAL :: tempb27
28738   REAL :: temp14
28739   REAL :: temp15
28740   REAL :: temp16
28741   REAL :: tempb28
28742   REAL :: tempb29
28743   REAL :: tempb30
28744   REAL :: tempb31
28745   REAL :: tempb32
28746   REAL :: tempb33
28747   REAL :: tempb34
28748   REAL :: tempb35
28749   REAL :: tempb36
28750   REAL :: tempb37
28751   REAL :: tempb38
28752   DOUBLE PRECISION :: temp17
28753   DOUBLE PRECISION :: temp18
28754   DOUBLE PRECISION :: temp19
28755   DOUBLE PRECISION :: tempb39
28756   DOUBLE PRECISION :: tempb40
28757   REAL :: tempb41
28758   REAL :: tempb42
28759   REAL :: tempb43
28760   REAL :: tempb44
28761   REAL :: tempb45
28762   REAL :: tempb46
28763   REAL :: temp20
28764   REAL :: temp21
28765   REAL :: temp22
28766   REAL :: temp23
28767   REAL :: temp24
28768   REAL :: temp25
28769   REAL :: tempb47
28770   REAL :: tempb48
28771   REAL :: tempb49
28772   REAL :: tempb50
28773   REAL :: tempb51
28774   REAL :: tempb52
28775   REAL :: tempb53
28776   REAL :: tempb54
28777   INTEGER :: branch
28778   INTEGER :: ad_from
28779   INTEGER :: ad_to
28780   INTEGER :: ad_from0
28781   INTEGER :: ad_to0
28782   INTEGER :: ad_from1
28783   INTEGER :: ad_to1
28784   INTEGER :: ad_from2
28785   INTEGER :: ad_to2
28786   INTEGER :: ad_from3
28787   INTEGER :: ad_to3
28788   INTEGER :: ad_from4
28789   INTEGER :: ad_to4
28790   INTEGER :: ad_from5
28791   INTEGER :: ad_to5
28792   INTEGER :: ad_from6
28793   INTEGER :: ad_to6
28794   INTEGER :: ad_from7
28795   INTEGER :: ad_to7
28796   INTEGER :: ad_from8
28797   INTEGER :: ad_to8
28798   INTEGER :: ad_from9
28799   INTEGER :: ad_to9
28800   INTEGER :: ad_from10
28801   INTEGER :: ad_to10
28802   INTEGER :: ad_from11
28803   INTEGER :: ad_to11
28804   INTEGER :: ad_from12
28805   INTEGER :: ad_to12
28806   INTEGER :: ad_from13
28807   INTEGER :: ad_to13
28808   INTEGER :: ad_from14
28809   INTEGER :: ad_to14
28810   INTEGER :: ad_from15
28811   INTEGER :: ad_to15
28812   INTEGER :: ad_from16
28813   INTEGER :: ad_to16
28814   INTEGER :: ad_from17
28815   INTEGER :: ad_to17
28816   INTEGER :: ad_from18
28817   INTEGER :: ad_to18
28818   specified = .false.
28819   IF (config_flags%specified .OR. config_flags%nested) specified = &
28820 &     .true.
28821   IF (kte .GT. kde - 1) THEN
28822     ktf = kde - 1
28823   ELSE
28824     ktf = kte
28825   END IF
28826 ! config_flags%h_sca_adv_order
28827   horz_order = 5
28828 ! config_flags%v_sca_adv_order
28829 !  begin with horizontal flux divergence
28830 !  here is the choice of flux operators
28831   IF (horz_order .EQ. 5) THEN
28832 !  determine boundary mods for flux operators
28833 !  We degrade the flux operators from 3rd/4th order
28834 !   to second order one gridpoint in from the boundaries for
28835 !   all boundary conditions except periodic and symmetry - these
28836 !   conditions have boundary zone data fill for correct application
28837 !   of the higher order flux stencils
28838     degrade_xs = .true.
28839     degrade_xe = .true.
28840     degrade_ys = .true.
28841     degrade_ye = .true.
28842     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
28843 &       its .GT. ids + 3) degrade_xs = .false.
28844     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
28845 &       ite .LT. ide - 3) degrade_xe = .false.
28846     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
28847 &       jts .GT. jds + 3) degrade_ys = .false.
28848     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
28849 &       jte .LT. jde - 4) degrade_ye = .false.
28850     IF (kte .GT. kde - 1) THEN
28851       ktf = kde - 1
28852     ELSE
28853       ktf = kte
28854     END IF
28855     i_start = its
28856     IF (ite .GT. ide - 1) THEN
28857       i_end = ide - 1
28858     ELSE
28859       i_end = ite
28860     END IF
28861 ! check for U
28862     IF (is .EQ. 1) THEN
28863       i_start = its
28864       i_end = ite
28865       IF (config_flags%open_xs .OR. specified) THEN
28866         IF (ids + 1 .LT. its) THEN
28867           CALL PUSHCONTROL1B(1)
28868           i_start = its
28869         ELSE
28870           CALL PUSHCONTROL1B(1)
28871           i_start = ids + 1
28872         END IF
28873       ELSE
28874         CALL PUSHCONTROL1B(0)
28875       END IF
28876       IF (config_flags%open_xe .OR. specified) THEN
28877         IF (ide - 1 .GT. ite) THEN
28878           CALL PUSHCONTROL1B(1)
28879           i_end = ite
28880         ELSE
28881           CALL PUSHCONTROL1B(1)
28882           i_end = ide - 1
28883         END IF
28884       ELSE
28885         CALL PUSHCONTROL1B(0)
28886       END IF
28887       IF (config_flags%periodic_x) i_start = its
28888       IF (config_flags%periodic_x) THEN
28889         CALL PUSHCONTROL1B(1)
28890         i_end = ite
28891       ELSE
28892         CALL PUSHCONTROL1B(1)
28893       END IF
28894     ELSE
28895       CALL PUSHCONTROL1B(0)
28896     END IF
28897     j_start = jts
28898     IF (jte .GT. jde - 1) THEN
28899       j_end = jde - 1
28900     ELSE
28901       j_end = jte
28902     END IF
28903 !  higher order flux has a 5 or 7 point stencil, so compute
28904 !  bounds so we can switch to second order flux close to the boundary
28905     j_start_f = j_start
28906     j_end_f = j_end + 1
28907     IF (degrade_ys) THEN
28908       IF (jts .LT. jds + 1) THEN
28909         CALL PUSHCONTROL1B(0)
28910         j_start = jds + 1
28911       ELSE
28912         CALL PUSHCONTROL1B(0)
28913         j_start = jts
28914       END IF
28915       j_start_f = jds + 3
28916     ELSE
28917       CALL PUSHCONTROL1B(1)
28918     END IF
28919     IF (degrade_ye) THEN
28920       IF (jte .GT. jde - 2) THEN
28921         CALL PUSHCONTROL1B(0)
28922         j_end = jde - 2
28923       ELSE
28924         CALL PUSHCONTROL1B(0)
28925         j_end = jte
28926       END IF
28927       j_end_f = jde - 3
28928     ELSE
28929       CALL PUSHCONTROL1B(1)
28930     END IF
28931     IF (config_flags%polar) THEN
28932       IF (jte .GT. jde - 1) THEN
28933         CALL PUSHCONTROL1B(1)
28934         j_end = jde - 1
28935       ELSE
28936         CALL PUSHCONTROL1B(1)
28937         j_end = jte
28938       END IF
28939     ELSE
28940       CALL PUSHCONTROL1B(0)
28941     END IF
28942 !  compute fluxes, 5th or 6th order
28943     jp1 = 2
28944     jp0 = 1
28945     ad_from10 = j_start
28946 j_loop_y_flux_5:DO j=ad_from10,j_end+1
28947       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
28948 ! use full stencil
28949         DO k=kts,ktf
28950           ad_from = i_start
28951           DO i=ad_from,i_end
28952 !          vel = rv(i,k,j)
28953             vel = 0.5*(rv(i, k, j)+rv(i-is, k-ks, j-js))
28954             IF (vel*SIGN(1, time_step) .GE. 0.0) THEN
28955               CALL PUSHREAL8(qip2)
28956               qip2 = field(i, k, j+1)
28957               CALL PUSHREAL8(qip1)
28958               qip1 = field(i, k, j)
28959               CALL PUSHREAL8(qi)
28960               qi = field(i, k, j-1)
28961               CALL PUSHREAL8(qim1)
28962               qim1 = field(i, k, j-2)
28963               CALL PUSHREAL8(qim2)
28964               qim2 = field(i, k, j-3)
28965               CALL PUSHCONTROL1B(0)
28966             ELSE
28967               CALL PUSHREAL8(qip2)
28968               qip2 = field(i, k, j-2)
28969               CALL PUSHREAL8(qip1)
28970               qip1 = field(i, k, j-1)
28971               CALL PUSHREAL8(qi)
28972               qi = field(i, k, j)
28973               CALL PUSHREAL8(qim1)
28974               qim1 = field(i, k, j+1)
28975               CALL PUSHREAL8(qim2)
28976               qim2 = field(i, k, j+2)
28977               CALL PUSHCONTROL1B(1)
28978             END IF
28979             CALL PUSHREAL8(f0)
28980             f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
28981             CALL PUSHREAL8(f1)
28982             f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
28983             CALL PUSHREAL8(f2)
28984             f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
28985             CALL PUSHREAL8(beta0)
28986             beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+&
28987 &             3.*qi)**2
28988             CALL PUSHREAL8(beta1)
28989             beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
28990             CALL PUSHREAL8(beta2)
28991             beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+&
28992 &             3.*qi)**2
28993           END DO
28994           CALL PUSHINTEGER4(i - 1)
28995           CALL PUSHINTEGER4(ad_from)
28996         END DO
28997         CALL PUSHCONTROL3B(0)
28998       ELSE IF (j .EQ. jds + 1) THEN
28999 !          fqy( i, k, jp1 ) = vel*flux5(                                &
29000 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
29001 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
29002 ! 2nd order flux next to south boundary
29003         DO k=kts,ktf
29004           ad_from0 = i_start
29005           i = i_end + 1
29006           CALL PUSHINTEGER4(i - 1)
29007           CALL PUSHINTEGER4(ad_from0)
29008         END DO
29009         CALL PUSHCONTROL3B(1)
29010       ELSE IF (j .EQ. jds + 2) THEN
29011 ! third of 4th order flux 2 in from south boundary
29012         DO k=kts,ktf
29013           ad_from1 = i_start
29014           i = i_end + 1
29015           CALL PUSHINTEGER4(i - 1)
29016           CALL PUSHINTEGER4(ad_from1)
29017         END DO
29018         CALL PUSHCONTROL3B(2)
29019       ELSE IF (j .EQ. jde - 1) THEN
29020 ! 2nd order flux next to north boundary
29021         DO k=kts,ktf
29022           ad_from2 = i_start
29023           i = i_end + 1
29024           CALL PUSHINTEGER4(i - 1)
29025           CALL PUSHINTEGER4(ad_from2)
29026         END DO
29027         CALL PUSHCONTROL3B(3)
29028       ELSE IF (j .EQ. jde - 2) THEN
29029 ! 3rd or 4th order flux 2 in from north boundary
29030         DO k=kts,ktf
29031           ad_from3 = i_start
29032           i = i_end + 1
29033           CALL PUSHINTEGER4(i - 1)
29034           CALL PUSHINTEGER4(ad_from3)
29035         END DO
29036         CALL PUSHCONTROL3B(4)
29037       ELSE
29038         CALL PUSHCONTROL3B(5)
29039       END IF
29040 !  y flux-divergence into tendency
29041       IF (is .EQ. 0) THEN
29042 ! Comments on polar boundary conditions
29043 ! Same process as for advect_u - tendencies run from jds to jde-1
29044 ! (latitudes are as for u grid, longitudes are displaced)
29045 ! Therefore: flow is only from one side for points next to poles
29046         IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
29047           DO k=kts,ktf
29048             ad_from4 = i_start
29049             i = i_end + 1
29050             CALL PUSHINTEGER4(i - 1)
29051             CALL PUSHINTEGER4(ad_from4)
29052           END DO
29053           CALL PUSHCONTROL4B(0)
29054         ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
29055           DO k=kts,ktf
29056             ad_from5 = i_start
29057             i = i_end + 1
29058             CALL PUSHINTEGER4(i - 1)
29059             CALL PUSHINTEGER4(ad_from5)
29060           END DO
29061           CALL PUSHCONTROL4B(1)
29062         ELSE IF (j .GT. j_start) THEN
29063 ! normal code
29064           DO k=kts,ktf
29065             ad_from6 = i_start
29066             i = i_end + 1
29067             CALL PUSHINTEGER4(i - 1)
29068             CALL PUSHINTEGER4(ad_from6)
29069           END DO
29070           CALL PUSHCONTROL4B(2)
29071         ELSE
29072           CALL PUSHCONTROL4B(3)
29073         END IF
29074       ELSE IF (is .EQ. 1) THEN
29075 ! (j > j_start) will miss the u(,,jds) tendency
29076         IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
29077           DO k=kts,ktf
29078             ad_from7 = i_start
29079             i = i_end + 1
29080             CALL PUSHINTEGER4(i - 1)
29081             CALL PUSHINTEGER4(ad_from7)
29082           END DO
29083           CALL PUSHCONTROL4B(4)
29084         ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
29085 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
29086           DO k=kts,ktf
29087             ad_from8 = i_start
29088             i = i_end + 1
29089             CALL PUSHINTEGER4(i - 1)
29090             CALL PUSHINTEGER4(ad_from8)
29091           END DO
29092           CALL PUSHCONTROL4B(5)
29093         ELSE IF (j .GT. j_start) THEN
29094 ! normal code
29095           DO k=kts,ktf
29096             ad_from9 = i_start
29097             i = i_end + 1
29098             CALL PUSHINTEGER4(i - 1)
29099             CALL PUSHINTEGER4(ad_from9)
29100           END DO
29101           CALL PUSHCONTROL4B(6)
29102         ELSE
29103           CALL PUSHCONTROL4B(7)
29104         END IF
29105       ELSE
29106         CALL PUSHCONTROL4B(8)
29107       END IF
29108       jtmp = jp1
29109       CALL PUSHINTEGER4(jp1)
29110       jp1 = jp0
29111       CALL PUSHINTEGER4(jp0)
29112       jp0 = jtmp
29113     END DO j_loop_y_flux_5
29114     CALL PUSHINTEGER4(j - 1)
29115     CALL PUSHINTEGER4(ad_from10)
29116 !  next, x - flux divergence
29117     i_start = its
29118     IF (ite .GT. ide - 1) THEN
29119       i_end = ide - 1
29120     ELSE
29121       i_end = ite
29122     END IF
29123     j_start = jts
29124     IF (jte .GT. jde - 1) THEN
29125       j_end = jde - 1
29126     ELSE
29127       j_end = jte
29128     END IF
29129 !  higher order flux has a 5 or 7 point stencil, so compute
29130 !  bounds so we can switch to second order flux close to the boundary
29131     i_start_f = i_start
29132     i_end_f = i_end + 1
29133     IF (degrade_xs) THEN
29134       IF (ids + 1 .LT. its) THEN
29135         i_start = its
29136       ELSE
29137         i_start = ids + 1
29138       END IF
29139       IF (i_start + 2 .GT. ids + 3) THEN
29140         CALL PUSHCONTROL1B(1)
29141         i_start_f = ids + 3
29142       ELSE
29143         CALL PUSHCONTROL1B(1)
29144         i_start_f = i_start + 2
29145       END IF
29146     ELSE
29147       CALL PUSHCONTROL1B(0)
29148     END IF
29149     IF (degrade_xe) THEN
29150       IF (ide - 2 .GT. ite) THEN
29151         CALL PUSHCONTROL1B(1)
29152         i_end = ite
29153       ELSE
29154         CALL PUSHCONTROL1B(1)
29155         i_end = ide - 2
29156       END IF
29157       i_end_f = ide - 3
29158     ELSE
29159       CALL PUSHCONTROL1B(0)
29160     END IF
29161     ad_from14 = j_start
29162 !  compute fluxes
29163     DO j=ad_from14,j_end
29164 !  5th or 6th order flux
29165       DO k=kts,ktf
29166         DO i=i_start_f,i_end_f
29167 !          vel = ru(i,k,j)
29168           vel = 0.5*(ru(i, k, j)+ru(i-is, k-ks, j-js))
29169           IF (vel*SIGN(1, time_step) .GE. 0.0) THEN
29170             CALL PUSHREAL8(qip2)
29171             qip2 = field(i+1, k, j)
29172             CALL PUSHREAL8(qip1)
29173             qip1 = field(i, k, j)
29174             CALL PUSHREAL8(qi)
29175             qi = field(i-1, k, j)
29176             CALL PUSHREAL8(qim1)
29177             qim1 = field(i-2, k, j)
29178             CALL PUSHREAL8(qim2)
29179             qim2 = field(i-3, k, j)
29180             CALL PUSHCONTROL1B(0)
29181           ELSE
29182             CALL PUSHREAL8(qip2)
29183             qip2 = field(i-2, k, j)
29184             CALL PUSHREAL8(qip1)
29185             qip1 = field(i-1, k, j)
29186             CALL PUSHREAL8(qi)
29187             qi = field(i, k, j)
29188             CALL PUSHREAL8(qim1)
29189             qim1 = field(i+1, k, j)
29190             CALL PUSHREAL8(qim2)
29191             qim2 = field(i+2, k, j)
29192             CALL PUSHCONTROL1B(1)
29193           END IF
29194           CALL PUSHREAL8(f0)
29195           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
29196           CALL PUSHREAL8(f1)
29197           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
29198           CALL PUSHREAL8(f2)
29199           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
29200           CALL PUSHREAL8(beta0)
29201           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
29202 &           qi)**2
29203           CALL PUSHREAL8(beta1)
29204           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
29205           CALL PUSHREAL8(beta2)
29206           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
29207 &           qi)**2
29208         END DO
29209       END DO
29210 !          fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
29211 !                                         field(i-1,k,j), field(i  ,k,j),  &
29212 !                                         field(i+1,k,j), field(i+2,k,j),  &
29213 !                                         vel                             )
29214 !  lower order fluxes close to boundaries (if not periodic or symmetric)
29215       IF (degrade_xs) THEN
29216         ad_from11 = i_start
29217         DO i=ad_from11,i_start_f-1
29218           IF (i .EQ. ids + 1) THEN
29219             CALL PUSHCONTROL1B(0)
29220           ELSE
29221             CALL PUSHCONTROL1B(1)
29222           END IF
29223           IF (i .EQ. ids + 2) THEN
29224             CALL PUSHCONTROL1B(1)
29225           ELSE
29226             CALL PUSHCONTROL1B(0)
29227           END IF
29228         END DO
29229         CALL PUSHINTEGER4(ad_from11)
29230         CALL PUSHCONTROL1B(0)
29231       ELSE
29232         CALL PUSHCONTROL1B(1)
29233       END IF
29234       IF (degrade_xe) THEN
29235         DO i=i_end_f+1,i_end+1
29236           IF (i .EQ. ide - 1) THEN
29237             CALL PUSHCONTROL1B(0)
29238           ELSE
29239             CALL PUSHCONTROL1B(1)
29240           END IF
29241           IF (i .EQ. ide - 2) THEN
29242             CALL PUSHCONTROL1B(1)
29243           ELSE
29244             CALL PUSHCONTROL1B(0)
29245           END IF
29246         END DO
29247         CALL PUSHINTEGER4(i - 1)
29248         CALL PUSHCONTROL1B(0)
29249       ELSE
29250         CALL PUSHCONTROL1B(1)
29251       END IF
29252 !  x flux-divergence into tendency
29253       IF (is .EQ. 0) THEN
29254         DO k=kts,ktf
29255           ad_from12 = i_start
29256           i = i_end + 1
29257           CALL PUSHINTEGER4(i - 1)
29258           CALL PUSHINTEGER4(ad_from12)
29259         END DO
29260         CALL PUSHCONTROL2B(2)
29261       ELSE IF (is .EQ. 1) THEN
29262         DO k=kts,ktf
29263           ad_from13 = i_start
29264           i = i_end + 1
29265           CALL PUSHINTEGER4(i - 1)
29266           CALL PUSHINTEGER4(ad_from13)
29267         END DO
29268         CALL PUSHCONTROL2B(1)
29269       ELSE
29270         CALL PUSHCONTROL2B(0)
29271       END IF
29272     END DO
29273     CALL PUSHINTEGER4(j - 1)
29274     CALL PUSHINTEGER4(ad_from14)
29275     CALL PUSHCONTROL1B(1)
29276   ELSE
29277     CALL PUSHCONTROL1B(0)
29278   END IF
29279 !  pick up the rest of the horizontal radiation boundary conditions.
29280 !  (these are the computations that don't require 'cb'.
29281 !  first, set to index ranges
29282   i_start = its
29283   IF (ite .GT. ide - 1) THEN
29284     i_end = ide - 1
29285   ELSE
29286     i_end = ite
29287   END IF
29288   j_start = jts
29289   IF (jte .GT. jde - 1) THEN
29290     j_end = jde - 1
29291   ELSE
29292     j_end = jte
29293   END IF
29294 !  compute x (u) conditions for v, w, or scalar
29295   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
29296     ad_from15 = j_start
29297     DO j=ad_from15,j_end
29298       DO k=kts,ktf
29299         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
29300           CALL PUSHREAL8(ub)
29301           ub = 0.
29302           CALL PUSHCONTROL1B(0)
29303         ELSE
29304           CALL PUSHREAL8(ub)
29305           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
29306           CALL PUSHCONTROL1B(1)
29307         END IF
29308       END DO
29309     END DO
29310     CALL PUSHINTEGER4(j - 1)
29311     CALL PUSHINTEGER4(ad_from15)
29312     CALL PUSHCONTROL1B(0)
29313   ELSE
29314     CALL PUSHCONTROL1B(1)
29315   END IF
29316   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
29317     ad_from16 = j_start
29318     DO j=ad_from16,j_end
29319       DO k=kts,ktf
29320         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
29321           CALL PUSHREAL8(ub)
29322           ub = 0.
29323           CALL PUSHCONTROL1B(0)
29324         ELSE
29325           CALL PUSHREAL8(ub)
29326           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
29327           CALL PUSHCONTROL1B(1)
29328         END IF
29329       END DO
29330     END DO
29331     CALL PUSHINTEGER4(j - 1)
29332     CALL PUSHINTEGER4(ad_from16)
29333     CALL PUSHCONTROL1B(0)
29334   ELSE
29335     CALL PUSHCONTROL1B(1)
29336   END IF
29337   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
29338     ad_from17 = i_start
29339     DO i=ad_from17,i_end
29340       DO k=kts,ktf
29341         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
29342           CALL PUSHREAL8(vb)
29343           vb = 0.
29344           CALL PUSHCONTROL1B(0)
29345         ELSE
29346           CALL PUSHREAL8(vb)
29347           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
29348           CALL PUSHCONTROL1B(1)
29349         END IF
29350       END DO
29351     END DO
29352     CALL PUSHINTEGER4(i - 1)
29353     CALL PUSHINTEGER4(ad_from17)
29354     CALL PUSHCONTROL1B(0)
29355   ELSE
29356     CALL PUSHCONTROL1B(1)
29357   END IF
29358   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
29359     ad_from18 = i_start
29360     DO i=ad_from18,i_end
29361       DO k=kts,ktf
29362         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
29363           CALL PUSHREAL8(vb)
29364           vb = 0.
29365           CALL PUSHCONTROL1B(0)
29366         ELSE
29367           CALL PUSHREAL8(vb)
29368           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
29369           CALL PUSHCONTROL1B(1)
29370         END IF
29371       END DO
29372     END DO
29373     CALL PUSHINTEGER4(i - 1)
29374     CALL PUSHINTEGER4(ad_from18)
29375     CALL PUSHCONTROL1B(1)
29376   ELSE
29377     CALL PUSHCONTROL1B(0)
29378   END IF
29379 !-------------------- vertical advection
29380 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
29381 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
29382 !     So we don't need to make a correction for advect_scalar
29383   i_start = its
29384   IF (ite .GT. ide - 1) THEN
29385     CALL PUSHINTEGER4(i_end)
29386     i_end = ide - 1
29387     CALL PUSHCONTROL1B(0)
29388   ELSE
29389     CALL PUSHINTEGER4(i_end)
29390     i_end = ite
29391     CALL PUSHCONTROL1B(1)
29392   END IF
29393   j_start = jts
29394   IF (jte .GT. jde - 1) THEN
29395     CALL PUSHINTEGER4(j_end)
29396     j_end = jde - 1
29397     CALL PUSHCONTROL1B(0)
29398   ELSE
29399     CALL PUSHINTEGER4(j_end)
29400     j_end = jte
29401     CALL PUSHCONTROL1B(1)
29402   END IF
29403   DO j=j_start,j_end
29404     DO k=kts+3,ktf-2
29405       DO i=i_start,i_end
29406 !           vel = rom(i,k,j)
29407         vel = 0.5*(rom(i, k, j)+rom(i-is, k-ks, j-js))
29408         IF (-(vel*SIGN(1, time_step)) .GE. 0.0) THEN
29409           CALL PUSHREAL8(qip2)
29410           qip2 = field(i, k+1, j)
29411           CALL PUSHREAL8(qip1)
29412           qip1 = field(i, k, j)
29413           CALL PUSHREAL8(qi)
29414           qi = field(i, k-1, j)
29415           CALL PUSHREAL8(qim1)
29416           qim1 = field(i, k-2, j)
29417           CALL PUSHREAL8(qim2)
29418           qim2 = field(i, k-3, j)
29419           CALL PUSHCONTROL1B(0)
29420         ELSE
29421           CALL PUSHREAL8(qip2)
29422           qip2 = field(i, k-2, j)
29423           CALL PUSHREAL8(qip1)
29424           qip1 = field(i, k-1, j)
29425           CALL PUSHREAL8(qi)
29426           qi = field(i, k, j)
29427           CALL PUSHREAL8(qim1)
29428           qim1 = field(i, k+1, j)
29429           CALL PUSHREAL8(qim2)
29430           qim2 = field(i, k+2, j)
29431           CALL PUSHCONTROL1B(1)
29432         END IF
29433         CALL PUSHREAL8(f0)
29434         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
29435         CALL PUSHREAL8(f1)
29436         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
29437         CALL PUSHREAL8(f2)
29438         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
29439         CALL PUSHREAL8(beta0)
29440         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
29441 &         )**2
29442         CALL PUSHREAL8(beta1)
29443         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
29444         CALL PUSHREAL8(beta2)
29445         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
29446 &         )**2
29447       END DO
29448     END DO
29449     CALL PUSHINTEGER4(k)
29450   END DO
29451   vfluxb = 0.0
29452   DO j=j_end,j_start,-1
29453     DO k=ktf,kts,-1
29454       DO i=i_end,i_start,-1
29455         vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
29456         vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
29457       END DO
29458     END DO
29459     CALL POPINTEGER4(k)
29460     DO i=i_end,i_start,-1
29461       k = ktf
29462       tempb47 = rom(i, k, j)*vfluxb(i, k)
29463       romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
29464 &       field(i, k-1, j))*vfluxb(i, k)
29465       fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb47
29466       fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb47
29467       vfluxb(i, k) = 0.0
29468       k = ktf - 1
29469       vel = rom(i, k, j)
29470       temp23 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-&
29471 &       field(i, k-1, j))
29472       temp25 = SIGN(1., -vel)
29473       temp24 = temp25/12.
29474       tempb48 = vel*vfluxb(i, k)
29475       tempb49 = 7.*tempb48/12.
29476       tempb50 = temp24*tempb48
29477       velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, &
29478 &       j)+field(i, k-2, j))/12.+temp24*temp23)*vfluxb(i, k)
29479       fieldb(i, k, j) = fieldb(i, k, j) + tempb49 - 3.*tempb50
29480       fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb50 + tempb49
29481       fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb50 - tempb48/12.
29482       fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb50 - tempb48/12.
29483       vfluxb(i, k) = 0.0
29484       romb(i, k, j) = romb(i, k, j) + velb
29485       k = kts + 2
29486       vel = rom(i, k, j)
29487       temp20 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-&
29488 &       field(i, k-1, j))
29489       temp22 = SIGN(1., -vel)
29490       temp21 = temp22/12.
29491       tempb51 = vel*vfluxb(i, k)
29492       tempb52 = 7.*tempb51/12.
29493       tempb53 = temp21*tempb51
29494       velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, &
29495 &       j)+field(i, k-2, j))/12.+temp21*temp20)*vfluxb(i, k)
29496       fieldb(i, k, j) = fieldb(i, k, j) + tempb52 - 3.*tempb53
29497       fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb53 + tempb52
29498       fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb53 - tempb51/12.
29499       fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb53 - tempb51/12.
29500       vfluxb(i, k) = 0.0
29501       romb(i, k, j) = romb(i, k, j) + velb
29502       k = kts + 1
29503       tempb54 = rom(i, k, j)*vfluxb(i, k)
29504       romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*&
29505 &       field(i, k-1, j))*vfluxb(i, k)
29506       fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb54
29507       fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb54
29508       vfluxb(i, k) = 0.0
29509     END DO
29510     DO k=ktf-2,kts+3,-1
29511       DO i=i_end,i_start,-1
29512         wi0 = gi0/(eps+beta0)**pw
29513         wi1 = gi1/(eps+beta1)**pw
29514         wi2 = gi2/(eps+beta2)**pw
29515         sumwk = wi0 + wi1 + wi2
29516         vel = 0.5*(rom(i, k, j)+rom(i-is, k-ks, j-js))
29517         tempb39 = vel*vfluxb(i, k)/sumwk
29518         tempb40 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk
29519         f0b = wi0*tempb39
29520         f1b = wi1*tempb39
29521         f2b = wi2*tempb39
29522         velb = tempb40
29523         sumwkb = -(vel*tempb40/sumwk)
29524         wi0b = sumwkb + f0*tempb39
29525         wi1b = sumwkb + f1*tempb39
29526         wi2b = sumwkb + f2*tempb39
29527         vfluxb(i, k) = 0.0
29528         temp19 = (eps+beta2)**pw
29529         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
29530 &           )) THEN
29531           beta2b = 0.0
29532         ELSE
29533           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp19**2)
29534         END IF
29535         temp18 = (eps+beta1)**pw
29536         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
29537 &           )) THEN
29538           beta1b = 0.0
29539         ELSE
29540           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp18**2)
29541         END IF
29542         temp17 = (eps+beta0)**pw
29543         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
29544 &           )) THEN
29545           beta0b = 0.0
29546         ELSE
29547           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp17**2)
29548         END IF
29549         CALL POPREAL8(beta2)
29550         tempb41 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
29551         tempb42 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
29552         qip2b = tempb42 - f2b/6. + tempb41
29553         CALL POPREAL8(beta1)
29554         tempb43 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
29555         tempb46 = 2*(qim1-qip1)*beta1b/4.
29556         qip1b = tempb43 - tempb46 + f1b/3. + 5.*f2b/6. - 4.*tempb42 - 2.&
29557 &         *tempb41
29558         CALL POPREAL8(beta0)
29559         tempb45 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
29560         tempb44 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
29561         qib = f2b/3. - 2.*tempb43 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb44 &
29562 &         + tempb45 + 3.*tempb42 + tempb41
29563         qim1b = tempb46 - 4.*tempb44 - 7.*f0b/6. - f1b/6. - 2.*tempb45 +&
29564 &         tempb43
29565         qim2b = f0b/3. + tempb44 + tempb45
29566         CALL POPREAL8(f2)
29567         CALL POPREAL8(f1)
29568         CALL POPREAL8(f0)
29569         CALL POPCONTROL1B(branch)
29570         IF (branch .EQ. 0) THEN
29571           CALL POPREAL8(qim2)
29572           fieldb(i, k-3, j) = fieldb(i, k-3, j) + qim2b
29573           CALL POPREAL8(qim1)
29574           fieldb(i, k-2, j) = fieldb(i, k-2, j) + qim1b
29575           CALL POPREAL8(qi)
29576           fieldb(i, k-1, j) = fieldb(i, k-1, j) + qib
29577           CALL POPREAL8(qip1)
29578           fieldb(i, k, j) = fieldb(i, k, j) + qip1b
29579           CALL POPREAL8(qip2)
29580           fieldb(i, k+1, j) = fieldb(i, k+1, j) + qip2b
29581         ELSE
29582           CALL POPREAL8(qim2)
29583           fieldb(i, k+2, j) = fieldb(i, k+2, j) + qim2b
29584           CALL POPREAL8(qim1)
29585           fieldb(i, k+1, j) = fieldb(i, k+1, j) + qim1b
29586           CALL POPREAL8(qi)
29587           fieldb(i, k, j) = fieldb(i, k, j) + qib
29588           CALL POPREAL8(qip1)
29589           fieldb(i, k-1, j) = fieldb(i, k-1, j) + qip1b
29590           CALL POPREAL8(qip2)
29591           fieldb(i, k-2, j) = fieldb(i, k-2, j) + qip2b
29592         END IF
29593         romb(i, k, j) = romb(i, k, j) + 0.5*velb
29594         romb(i-is, k-ks, j-js) = romb(i-is, k-ks, j-js) + 0.5*velb
29595       END DO
29596     END DO
29597   END DO
29598   CALL POPCONTROL1B(branch)
29599   IF (branch .EQ. 0) THEN
29600     CALL POPINTEGER4(j_end)
29601   ELSE
29602     CALL POPINTEGER4(j_end)
29603   END IF
29604   CALL POPCONTROL1B(branch)
29605   IF (branch .EQ. 0) THEN
29606     CALL POPINTEGER4(i_end)
29607   ELSE
29608     CALL POPINTEGER4(i_end)
29609   END IF
29610   CALL POPCONTROL1B(branch)
29611   IF (branch .NE. 0) THEN
29612     CALL POPINTEGER4(ad_from18)
29613     CALL POPINTEGER4(ad_to18)
29614     DO i=ad_to18,ad_from18,-1
29615       DO k=ktf,kts,-1
29616         tempb37 = -(rdy*tendencyb(i, k, j_end))
29617         tempb38 = field(i, k, j_end)*tempb37
29618         vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*tempb37
29619         field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*tempb37
29620         field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*&
29621 &         tempb37
29622         fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i&
29623 &         , k, jte-1))*tempb37
29624         rvb(i, k, jte) = rvb(i, k, jte) + tempb38
29625         rvb(i, k, jte-1) = rvb(i, k, jte-1) - tempb38
29626         CALL POPCONTROL1B(branch)
29627         IF (branch .EQ. 0) THEN
29628           CALL POPREAL8(vb)
29629         ELSE
29630           CALL POPREAL8(vb)
29631           rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb
29632           rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb
29633         END IF
29634       END DO
29635     END DO
29636   END IF
29637   CALL POPCONTROL1B(branch)
29638   IF (branch .EQ. 0) THEN
29639     CALL POPINTEGER4(ad_from17)
29640     CALL POPINTEGER4(ad_to17)
29641     DO i=ad_to17,ad_from17,-1
29642       DO k=ktf,kts,-1
29643         tempb35 = -(rdy*tendencyb(i, k, jts))
29644         tempb36 = field(i, k, jts)*tempb35
29645         vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*tempb35
29646         field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*tempb35
29647         field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*tempb35
29648         fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k&
29649 &         , jts))*tempb35
29650         rvb(i, k, jts+1) = rvb(i, k, jts+1) + tempb36
29651         rvb(i, k, jts) = rvb(i, k, jts) - tempb36
29652         CALL POPCONTROL1B(branch)
29653         IF (branch .EQ. 0) THEN
29654           CALL POPREAL8(vb)
29655         ELSE
29656           CALL POPREAL8(vb)
29657           rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb
29658           rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb
29659         END IF
29660       END DO
29661     END DO
29662   END IF
29663   CALL POPCONTROL1B(branch)
29664   IF (branch .EQ. 0) THEN
29665     CALL POPINTEGER4(ad_from16)
29666     CALL POPINTEGER4(ad_to16)
29667     DO j=ad_to16,ad_from16,-1
29668       DO k=ktf,kts,-1
29669         tempb33 = -(rdx*tendencyb(i_end, k, j))
29670         tempb34 = field(i_end, k, j)*tempb33
29671         ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*tempb33
29672         field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*tempb33
29673         field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*&
29674 &         tempb33
29675         fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(&
29676 &         ite-1, k, j))*tempb33
29677         rub(ite, k, j) = rub(ite, k, j) + tempb34
29678         rub(ite-1, k, j) = rub(ite-1, k, j) - tempb34
29679         CALL POPCONTROL1B(branch)
29680         IF (branch .EQ. 0) THEN
29681           CALL POPREAL8(ub)
29682         ELSE
29683           CALL POPREAL8(ub)
29684           rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb
29685           rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb
29686         END IF
29687       END DO
29688     END DO
29689   END IF
29690   CALL POPCONTROL1B(branch)
29691   IF (branch .EQ. 0) THEN
29692     CALL POPINTEGER4(ad_from15)
29693     CALL POPINTEGER4(ad_to15)
29694     DO j=ad_to15,ad_from15,-1
29695       DO k=ktf,kts,-1
29696         tempb31 = -(rdx*tendencyb(its, k, j))
29697         tempb32 = field(its, k, j)*tempb31
29698         ubb = (field_old(its+1, k, j)-field_old(its, k, j))*tempb31
29699         field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*tempb31
29700         field_oldb(its, k, j) = field_oldb(its, k, j) - ub*tempb31
29701         fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its&
29702 &         , k, j))*tempb31
29703         rub(its+1, k, j) = rub(its+1, k, j) + tempb32
29704         rub(its, k, j) = rub(its, k, j) - tempb32
29705         CALL POPCONTROL1B(branch)
29706         IF (branch .EQ. 0) THEN
29707           CALL POPREAL8(ub)
29708         ELSE
29709           CALL POPREAL8(ub)
29710           rub(its, k, j) = rub(its, k, j) + 0.5*ubb
29711           rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb
29712         END IF
29713       END DO
29714     END DO
29715   END IF
29716   CALL POPCONTROL1B(branch)
29717   IF (branch .NE. 0) THEN
29718     fqxb = 0.0
29719     CALL POPINTEGER4(ad_from14)
29720     CALL POPINTEGER4(ad_to14)
29721     DO j=ad_to14,ad_from14,-1
29722       CALL POPCONTROL2B(branch)
29723       IF (branch .NE. 0) THEN
29724         IF (branch .EQ. 1) THEN
29725           DO k=ktf,kts,-1
29726             CALL POPINTEGER4(ad_from13)
29727             CALL POPINTEGER4(ad_to13)
29728             DO i=ad_to13,ad_from13,-1
29729               mrdx = msfux(i, j)*rdx
29730               fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
29731               fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
29732             END DO
29733           END DO
29734         ELSE
29735           DO k=ktf,kts,-1
29736             CALL POPINTEGER4(ad_from12)
29737             CALL POPINTEGER4(ad_to12)
29738             DO i=ad_to12,ad_from12,-1
29739               mrdx = msftx(i, j)*rdx
29740               fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
29741               fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
29742             END DO
29743           END DO
29744         END IF
29745       END IF
29746       CALL POPCONTROL1B(branch)
29747       IF (branch .EQ. 0) THEN
29748         CALL POPINTEGER4(ad_to11)
29749         DO i=ad_to11,i_end_f+1,-1
29750           CALL POPCONTROL1B(branch)
29751           IF (branch .NE. 0) THEN
29752             DO k=ktf,kts,-1
29753               vel = ru(i, k, j)
29754               temp14 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
29755 &               , k, j)-field(i-1, k, j))
29756               temp16 = SIGN(1., vel)
29757               temp15 = temp16/12.
29758               tempb28 = vel*fqxb(i, k)
29759               tempb29 = 7.*tempb28/12.
29760               tempb30 = temp15*tempb28
29761               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
29762 &               i+1, k, j)+field(i-2, k, j))/12.+temp15*temp14)*fqxb(i, &
29763 &               k)
29764               fieldb(i, k, j) = fieldb(i, k, j) + tempb29 - 3.*tempb30
29765               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb30 + &
29766 &               tempb29
29767               fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb30 - tempb28/&
29768 &               12.
29769               fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb30 - tempb28/&
29770 &               12.
29771               fqxb(i, k) = 0.0
29772               rub(i, k, j) = rub(i, k, j) + velb
29773             END DO
29774           END IF
29775           CALL POPCONTROL1B(branch)
29776           IF (branch .EQ. 0) THEN
29777             DO k=ktf,kts,-1
29778               tempb27 = 0.5*ru(i, k, j)*fqxb(i, k)
29779               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
29780 &               1, k, j))*fqxb(i, k)
29781               fieldb(i, k, j) = fieldb(i, k, j) + tempb27
29782               fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb27
29783               fqxb(i, k) = 0.0
29784             END DO
29785           END IF
29786         END DO
29787       END IF
29788       CALL POPCONTROL1B(branch)
29789       IF (branch .EQ. 0) THEN
29790         CALL POPINTEGER4(ad_from11)
29791         DO i=i_start_f-1,ad_from11,-1
29792           CALL POPCONTROL1B(branch)
29793           IF (branch .NE. 0) THEN
29794             DO k=ktf,kts,-1
29795               vel = ru(i, k, j)
29796               temp11 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i&
29797 &               , k, j)-field(i-1, k, j))
29798               temp13 = SIGN(1., vel)
29799               temp12 = temp13/12.
29800               tempb24 = vel*fqxb(i, k)
29801               tempb25 = 7.*tempb24/12.
29802               tempb26 = temp12*tempb24
29803               velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(&
29804 &               i+1, k, j)+field(i-2, k, j))/12.+temp12*temp11)*fqxb(i, &
29805 &               k)
29806               fieldb(i, k, j) = fieldb(i, k, j) + tempb25 - 3.*tempb26
29807               fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb26 + &
29808 &               tempb25
29809               fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb26 - tempb24/&
29810 &               12.
29811               fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb26 - tempb24/&
29812 &               12.
29813               fqxb(i, k) = 0.0
29814               rub(i, k, j) = rub(i, k, j) + velb
29815             END DO
29816           END IF
29817           CALL POPCONTROL1B(branch)
29818           IF (branch .EQ. 0) THEN
29819             DO k=ktf,kts,-1
29820               tempb23 = 0.5*ru(i, k, j)*fqxb(i, k)
29821               rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-&
29822 &               1, k, j))*fqxb(i, k)
29823               fieldb(i, k, j) = fieldb(i, k, j) + tempb23
29824               fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb23
29825               fqxb(i, k) = 0.0
29826             END DO
29827           END IF
29828         END DO
29829       END IF
29830       DO k=ktf,kts,-1
29831         DO i=i_end_f,i_start_f,-1
29832           wi0 = gi0/(eps+beta0)**pw
29833           wi1 = gi1/(eps+beta1)**pw
29834           wi2 = gi2/(eps+beta2)**pw
29835           sumwk = wi0 + wi1 + wi2
29836           vel = 0.5*(ru(i, k, j)+ru(i-is, k-ks, j-js))
29837           tempb15 = vel*fqxb(i, k)/sumwk
29838           tempb16 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk
29839           f0b = wi0*tempb15
29840           f1b = wi1*tempb15
29841           f2b = wi2*tempb15
29842           velb = tempb16
29843           sumwkb = -(vel*tempb16/sumwk)
29844           wi0b = sumwkb + f0*tempb15
29845           wi1b = sumwkb + f1*tempb15
29846           wi2b = sumwkb + f2*tempb15
29847           fqxb(i, k) = 0.0
29848           temp10 = (eps+beta2)**pw
29849           IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
29850 &             pw))) THEN
29851             beta2b = 0.0
29852           ELSE
29853             beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp10**2)
29854           END IF
29855           temp9 = (eps+beta1)**pw
29856           IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
29857 &             pw))) THEN
29858             beta1b = 0.0
29859           ELSE
29860             beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp9**2)
29861           END IF
29862           temp8 = (eps+beta0)**pw
29863           IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
29864 &             pw))) THEN
29865             beta0b = 0.0
29866           ELSE
29867             beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp8**2)
29868           END IF
29869           CALL POPREAL8(beta2)
29870           tempb17 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
29871           tempb18 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
29872           qip2b = tempb18 - f2b/6. + tempb17
29873           CALL POPREAL8(beta1)
29874           tempb19 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
29875           tempb22 = 2*(qim1-qip1)*beta1b/4.
29876           qip1b = tempb19 - tempb22 + f1b/3. + 5.*f2b/6. - 4.*tempb18 - &
29877 &           2.*tempb17
29878           CALL POPREAL8(beta0)
29879           tempb21 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
29880           tempb20 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
29881           qib = f2b/3. - 2.*tempb19 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
29882 &           tempb20 + tempb21 + 3.*tempb18 + tempb17
29883           qim1b = tempb22 - 4.*tempb20 - 7.*f0b/6. - f1b/6. - 2.*tempb21&
29884 &           + tempb19
29885           qim2b = f0b/3. + tempb20 + tempb21
29886           CALL POPREAL8(f2)
29887           CALL POPREAL8(f1)
29888           CALL POPREAL8(f0)
29889           CALL POPCONTROL1B(branch)
29890           IF (branch .EQ. 0) THEN
29891             CALL POPREAL8(qim2)
29892             fieldb(i-3, k, j) = fieldb(i-3, k, j) + qim2b
29893             CALL POPREAL8(qim1)
29894             fieldb(i-2, k, j) = fieldb(i-2, k, j) + qim1b
29895             CALL POPREAL8(qi)
29896             fieldb(i-1, k, j) = fieldb(i-1, k, j) + qib
29897             CALL POPREAL8(qip1)
29898             fieldb(i, k, j) = fieldb(i, k, j) + qip1b
29899             CALL POPREAL8(qip2)
29900             fieldb(i+1, k, j) = fieldb(i+1, k, j) + qip2b
29901           ELSE
29902             CALL POPREAL8(qim2)
29903             fieldb(i+2, k, j) = fieldb(i+2, k, j) + qim2b
29904             CALL POPREAL8(qim1)
29905             fieldb(i+1, k, j) = fieldb(i+1, k, j) + qim1b
29906             CALL POPREAL8(qi)
29907             fieldb(i, k, j) = fieldb(i, k, j) + qib
29908             CALL POPREAL8(qip1)
29909             fieldb(i-1, k, j) = fieldb(i-1, k, j) + qip1b
29910             CALL POPREAL8(qip2)
29911             fieldb(i-2, k, j) = fieldb(i-2, k, j) + qip2b
29912           END IF
29913           rub(i, k, j) = rub(i, k, j) + 0.5*velb
29914           rub(i-is, k-ks, j-js) = rub(i-is, k-ks, j-js) + 0.5*velb
29915         END DO
29916       END DO
29917     END DO
29918     CALL POPCONTROL1B(branch)
29919     CALL POPCONTROL1B(branch)
29920     fqyb = 0.0
29921     CALL POPINTEGER4(ad_from10)
29922     CALL POPINTEGER4(ad_to10)
29923     DO j=ad_to10,ad_from10,-1
29924       CALL POPINTEGER4(jp0)
29925       CALL POPINTEGER4(jp1)
29926       CALL POPCONTROL4B(branch)
29927       IF (branch .LT. 4) THEN
29928         IF (branch .LT. 2) THEN
29929           IF (branch .EQ. 0) THEN
29930             DO k=ktf,kts,-1
29931               CALL POPINTEGER4(ad_from4)
29932               CALL POPINTEGER4(ad_to4)
29933               DO i=ad_to4,ad_from4,-1
29934                 mrdy = msftx(i, j-1)*rdy
29935                 fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k&
29936 &                 , j-1)
29937               END DO
29938             END DO
29939           ELSE
29940             DO k=ktf,kts,-1
29941               CALL POPINTEGER4(ad_from5)
29942               CALL POPINTEGER4(ad_to5)
29943               DO i=ad_to5,ad_from5,-1
29944                 mrdy = msftx(i, j-1)*rdy
29945                 fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k&
29946 &                 , j-1)
29947               END DO
29948             END DO
29949           END IF
29950         ELSE IF (branch .EQ. 2) THEN
29951           DO k=ktf,kts,-1
29952             CALL POPINTEGER4(ad_from6)
29953             CALL POPINTEGER4(ad_to6)
29954             DO i=ad_to6,ad_from6,-1
29955               mrdy = msftx(i, j-1)*rdy
29956               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
29957 &               -1)
29958               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
29959 &               -1)
29960             END DO
29961           END DO
29962         END IF
29963       ELSE IF (branch .LT. 6) THEN
29964         IF (branch .EQ. 4) THEN
29965           DO k=ktf,kts,-1
29966             CALL POPINTEGER4(ad_from7)
29967             CALL POPINTEGER4(ad_to7)
29968             DO i=ad_to7,ad_from7,-1
29969               mrdy = msfux(i, j-1)*rdy
29970               fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j&
29971 &               -1)
29972             END DO
29973           END DO
29974         ELSE
29975           DO k=ktf,kts,-1
29976             CALL POPINTEGER4(ad_from8)
29977             CALL POPINTEGER4(ad_to8)
29978             DO i=ad_to8,ad_from8,-1
29979               mrdy = msfux(i, j-1)*rdy
29980               fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j&
29981 &               -1)
29982             END DO
29983           END DO
29984         END IF
29985       ELSE IF (branch .EQ. 6) THEN
29986         DO k=ktf,kts,-1
29987           CALL POPINTEGER4(ad_from9)
29988           CALL POPINTEGER4(ad_to9)
29989           DO i=ad_to9,ad_from9,-1
29990             mrdy = msfux(i, j-1)*rdy
29991             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
29992 &             )
29993             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
29994 &             )
29995           END DO
29996         END DO
29997       END IF
29998       CALL POPCONTROL3B(branch)
29999       IF (branch .LT. 3) THEN
30000         IF (branch .EQ. 0) THEN
30001           DO k=ktf,kts,-1
30002             CALL POPINTEGER4(ad_from)
30003             CALL POPINTEGER4(ad_to)
30004             DO i=ad_to,ad_from,-1
30005               wi0 = gi0/(eps+beta0)**pw
30006               wi1 = gi1/(eps+beta1)**pw
30007               wi2 = gi2/(eps+beta2)**pw
30008               sumwk = wi0 + wi1 + wi2
30009               vel = 0.5*(rv(i, k, j)+rv(i-is, k-ks, j-js))
30010               tempb = vel*fqyb(i, k, jp1)/sumwk
30011               tempb0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk
30012               f0b = wi0*tempb
30013               f1b = wi1*tempb
30014               f2b = wi2*tempb
30015               velb = tempb0
30016               sumwkb = -(vel*tempb0/sumwk)
30017               wi0b = sumwkb + f0*tempb
30018               wi1b = sumwkb + f1*tempb
30019               wi2b = sumwkb + f2*tempb
30020               fqyb(i, k, jp1) = 0.0
30021               temp1 = (eps+beta2)**pw
30022               IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. &
30023 &                 INT(pw))) THEN
30024                 beta2b = 0.0
30025               ELSE
30026                 beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2)
30027               END IF
30028               temp0 = (eps+beta1)**pw
30029               IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. &
30030 &                 INT(pw))) THEN
30031                 beta1b = 0.0
30032               ELSE
30033                 beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2)
30034               END IF
30035               temp = (eps+beta0)**pw
30036               IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. &
30037 &                 INT(pw))) THEN
30038                 beta0b = 0.0
30039               ELSE
30040                 beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2)
30041               END IF
30042               CALL POPREAL8(beta2)
30043               tempb1 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
30044               tempb2 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
30045               qip2b = tempb2 - f2b/6. + tempb1
30046               CALL POPREAL8(beta1)
30047               tempb3 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
30048               tempb6 = 2*(qim1-qip1)*beta1b/4.
30049               qip1b = tempb3 - tempb6 + f1b/3. + 5.*f2b/6. - 4.*tempb2 -&
30050 &               2.*tempb1
30051               CALL POPREAL8(beta0)
30052               tempb5 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
30053               tempb4 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
30054               qib = f2b/3. - 2.*tempb3 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
30055 &               tempb4 + tempb5 + 3.*tempb2 + tempb1
30056               qim1b = tempb6 - 4.*tempb4 - 7.*f0b/6. - f1b/6. - 2.*&
30057 &               tempb5 + tempb3
30058               qim2b = f0b/3. + tempb4 + tempb5
30059               CALL POPREAL8(f2)
30060               CALL POPREAL8(f1)
30061               CALL POPREAL8(f0)
30062               CALL POPCONTROL1B(branch)
30063               IF (branch .EQ. 0) THEN
30064                 CALL POPREAL8(qim2)
30065                 fieldb(i, k, j-3) = fieldb(i, k, j-3) + qim2b
30066                 CALL POPREAL8(qim1)
30067                 fieldb(i, k, j-2) = fieldb(i, k, j-2) + qim1b
30068                 CALL POPREAL8(qi)
30069                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + qib
30070                 CALL POPREAL8(qip1)
30071                 fieldb(i, k, j) = fieldb(i, k, j) + qip1b
30072                 CALL POPREAL8(qip2)
30073                 fieldb(i, k, j+1) = fieldb(i, k, j+1) + qip2b
30074               ELSE
30075                 CALL POPREAL8(qim2)
30076                 fieldb(i, k, j+2) = fieldb(i, k, j+2) + qim2b
30077                 CALL POPREAL8(qim1)
30078                 fieldb(i, k, j+1) = fieldb(i, k, j+1) + qim1b
30079                 CALL POPREAL8(qi)
30080                 fieldb(i, k, j) = fieldb(i, k, j) + qib
30081                 CALL POPREAL8(qip1)
30082                 fieldb(i, k, j-1) = fieldb(i, k, j-1) + qip1b
30083                 CALL POPREAL8(qip2)
30084                 fieldb(i, k, j-2) = fieldb(i, k, j-2) + qip2b
30085               END IF
30086               rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
30087               rvb(i-is, k-ks, j-js) = rvb(i-is, k-ks, j-js) + 0.5*velb
30088             END DO
30089           END DO
30090         ELSE IF (branch .EQ. 1) THEN
30091           DO k=ktf,kts,-1
30092             CALL POPINTEGER4(ad_from0)
30093             CALL POPINTEGER4(ad_to0)
30094             DO i=ad_to0,ad_from0,-1
30095               tempb7 = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
30096               rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i&
30097 &               , k, j-1))*fqyb(i, k, jp1)
30098               fieldb(i, k, j) = fieldb(i, k, j) + tempb7
30099               fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb7
30100               fqyb(i, k, jp1) = 0.0
30101             END DO
30102           END DO
30103         ELSE
30104           DO k=ktf,kts,-1
30105             CALL POPINTEGER4(ad_from1)
30106             CALL POPINTEGER4(ad_to1)
30107             DO i=ad_to1,ad_from1,-1
30108               vel = rv(i, k, j)
30109               temp2 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i&
30110 &               , k, j)-field(i, k, j-1))
30111               temp4 = SIGN(1., vel)
30112               temp3 = temp4/12.
30113               tempb8 = vel*fqyb(i, k, jp1)
30114               tempb9 = 7.*tempb8/12.
30115               tempb10 = temp3*tempb8
30116               velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(&
30117 &               i, k, j+1)+field(i, k, j-2))/12.+temp3*temp2)*fqyb(i, k&
30118 &               , jp1)
30119               fieldb(i, k, j) = fieldb(i, k, j) + tempb9 - 3.*tempb10
30120               fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb10 + &
30121 &               tempb9
30122               fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb10 - tempb8/&
30123 &               12.
30124               fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb10 - tempb8/&
30125 &               12.
30126               fqyb(i, k, jp1) = 0.0
30127               rvb(i, k, j) = rvb(i, k, j) + velb
30128             END DO
30129           END DO
30130         END IF
30131       ELSE IF (branch .EQ. 3) THEN
30132         DO k=ktf,kts,-1
30133           CALL POPINTEGER4(ad_from2)
30134           CALL POPINTEGER4(ad_to2)
30135           DO i=ad_to2,ad_from2,-1
30136             tempb11 = 0.5*rv(i, k, j)*fqyb(i, k, jp1)
30137             rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k&
30138 &             , j-1))*fqyb(i, k, jp1)
30139             fieldb(i, k, j) = fieldb(i, k, j) + tempb11
30140             fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb11
30141             fqyb(i, k, jp1) = 0.0
30142           END DO
30143         END DO
30144       ELSE IF (branch .EQ. 4) THEN
30145         DO k=ktf,kts,-1
30146           CALL POPINTEGER4(ad_from3)
30147           CALL POPINTEGER4(ad_to3)
30148           DO i=ad_to3,ad_from3,-1
30149             vel = rv(i, k, j)
30150             temp5 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k&
30151 &             , j)-field(i, k, j-1))
30152             temp7 = SIGN(1., vel)
30153             temp6 = temp7/12.
30154             tempb12 = vel*fqyb(i, k, jp1)
30155             tempb13 = 7.*tempb12/12.
30156             tempb14 = temp6*tempb12
30157             velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i&
30158 &             , k, j+1)+field(i, k, j-2))/12.+temp6*temp5)*fqyb(i, k, &
30159 &             jp1)
30160             fieldb(i, k, j) = fieldb(i, k, j) + tempb13 - 3.*tempb14
30161             fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb14 + tempb13
30162             fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb14 - tempb12/&
30163 &             12.
30164             fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb14 - tempb12/&
30165 &             12.
30166             fqyb(i, k, jp1) = 0.0
30167             rvb(i, k, j) = rvb(i, k, j) + velb
30168           END DO
30169         END DO
30170       END IF
30171     END DO
30172     CALL POPCONTROL1B(branch)
30173     CALL POPCONTROL1B(branch)
30174     CALL POPCONTROL1B(branch)
30175     CALL POPCONTROL1B(branch)
30176     IF (branch .NE. 0) THEN
30177       CALL POPCONTROL1B(branch)
30178       CALL POPCONTROL1B(branch)
30179     END IF
30180   END IF
30181 END SUBROUTINE A_ADVECT_SCALAR_WENO
30182
30183 !        Generated by TAPENADE     (INRIA, Tropics team)
30184 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
30185 !
30186 !  Differentiation of advect_weno_u in reverse (adjoint) mode:
30187 !   gradient     of useful results: rom u tendency u_old ru rv
30188 !                mut
30189 !   with respect to varying inputs: rom u tendency u_old ru rv
30190 !                mut
30191 !   RW status of diff variables: rom:incr u:incr tendency:in-out
30192 !                u_old:incr ru:incr rv:incr mut:incr
30193 SUBROUTINE A_ADVECT_WENO_U(u, ub0, u_old, u_oldb, tendency, tendencyb, &
30194 &  ru, rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux&
30195 &  , msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, &
30196 &  ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, &
30197 &  jte, kts, kte)
30198   IMPLICIT NONE
30199 ! Input data
30200   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
30201   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
30202 &  jme, kms, kme, its, ite, jts, jte, kts, kte
30203   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru&
30204 &  , rv, rom
30205   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ub0, u_oldb, rub, rvb, &
30206 &  romb
30207   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
30208   REAL, DIMENSION(ims:ime, jms:jme) :: mutb
30209   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
30210   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb
30211   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
30212 &  msfvy, msftx, msfty
30213   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
30214   REAL, INTENT(IN) :: rdx, rdy
30215   INTEGER, INTENT(IN) :: time_step
30216 ! Local data
30217   INTEGER :: i, j, k, itf, jtf, ktf
30218   INTEGER :: i_start, i_end, j_start, j_end
30219   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
30220   INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
30221   INTEGER :: jp1, jp0, jtmp
30222   REAL :: dir, vv
30223   REAL :: ue, vs, vn, wb, wt
30224   REAL, PARAMETER :: f30=7./12., f31=1./12.
30225   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
30226   INTEGER :: kt, kb
30227   REAL :: qim2, qim1, qi, qip1, qip2
30228   REAL :: qim2b, qim1b, qib, qip1b, qip2b
30229   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
30230 &  sumwk
30231   DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b&
30232 &  , wi2b, sumwkb
30233   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
30234 &    3.d0/10.d0, eps=1.0d-18
30235   INTEGER, PARAMETER :: pw=2
30236   INTEGER :: horz_order, vert_order
30237   REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
30238   REAL :: ubb, vbb, vwb, dvmb, dvpb
30239   REAL, DIMENSION(its:ite, kts:kte) :: vflux
30240   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
30241   REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx
30242   REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxb
30243   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
30244   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
30245   LOGICAL :: degrade_xs, degrade_ys
30246   LOGICAL :: degrade_xe, degrade_ye
30247 ! definition of flux operators, 3rd, 4th, 5th or 6th order
30248   REAL :: flux3, flux4, flux5, flux6
30249   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
30250   REAL :: velb
30251   LOGICAL :: specified
30252   INTEGER :: branch
30253   INTEGER :: ad_from
30254   INTEGER :: ad_to
30255   INTEGER :: ad_from0
30256   INTEGER :: ad_to0
30257   INTEGER :: ad_from1
30258   INTEGER :: ad_to1
30259   INTEGER :: ad_from2
30260   INTEGER :: ad_to2
30261   INTEGER :: ad_from3
30262   INTEGER :: ad_to3
30263   INTEGER :: ad_from4
30264   INTEGER :: ad_to4
30265   INTEGER :: ad_from5
30266   INTEGER :: ad_to5
30267   INTEGER :: ad_from6
30268   INTEGER :: ad_to6
30269   INTEGER :: ad_from7
30270   INTEGER :: ad_to7
30271   INTEGER :: ad_from8
30272   INTEGER :: ad_to8
30273   INTEGER :: ad_from9
30274   INTEGER :: ad_to9
30275   INTEGER :: ad_from10
30276   INTEGER :: ad_to10
30277   INTEGER :: ad_from11
30278   INTEGER :: ad_to11
30279   INTEGER :: ad_from12
30280   INTEGER :: ad_to12
30281   INTEGER :: ad_from13
30282   INTEGER :: ad_to13
30283   INTEGER :: temp3
30284   INTEGER :: temp29
30285   REAL :: temp2
30286   REAL :: temp28
30287   DOUBLE PRECISION :: temp1
30288   REAL :: temp27
30289   DOUBLE PRECISION :: temp0
30290   DOUBLE PRECISION :: temp13b
30291   REAL :: temp26
30292   REAL :: temp21b
30293   INTEGER :: temp25
30294   REAL :: temp24
30295   DOUBLE PRECISION :: temp23
30296   DOUBLE PRECISION :: temp22
30297   DOUBLE PRECISION :: temp21
30298   REAL :: temp20
30299   REAL :: temp13b5
30300   REAL :: temp13b4
30301   DOUBLE PRECISION :: temp24b
30302   REAL :: temp13b3
30303   REAL :: temp32b
30304   REAL :: temp13b2
30305   REAL :: temp13b1
30306   DOUBLE PRECISION :: temp13b0
30307   REAL :: tempb4
30308   REAL :: temp21b10
30309   REAL :: tempb3
30310   REAL :: temp28b1
30311   REAL :: tempb2
30312   REAL :: temp28b0
30313   REAL :: tempb1
30314   REAL :: tempb0
30315   INTRINSIC MAX
30316   INTRINSIC SIGN
30317   REAL :: temp2b5
30318   REAL :: temp2b4
30319   REAL :: temp19
30320   REAL :: temp2b3
30321   INTEGER :: temp18
30322   REAL :: temp2b2
30323   REAL :: temp17
30324   REAL :: temp2b1
30325   REAL :: temp16
30326   DOUBLE PRECISION :: temp2b0
30327   REAL :: temp6b
30328   REAL :: temp15
30329   INTEGER :: temp14
30330   REAL :: temp13
30331   REAL :: temp21b9
30332   DOUBLE PRECISION :: temp12
30333   REAL :: temp21b8
30334   DOUBLE PRECISION :: temp11
30335   REAL :: temp21b7
30336   DOUBLE PRECISION :: temp10
30337   REAL :: temp21b6
30338   REAL :: temp21b5
30339   REAL :: temp21b4
30340   REAL :: temp21b3
30341   REAL :: temp21b2
30342   REAL :: temp21b1
30343   REAL :: temp21b0
30344   REAL :: tempb
30345   REAL :: temp24b5
30346   DOUBLE PRECISION :: temp2b
30347   REAL :: temp24b4
30348   REAL :: temp24b3
30349   REAL :: temp24b2
30350   REAL :: temp24b1
30351   DOUBLE PRECISION :: temp24b0
30352   REAL :: temp17b3
30353   REAL :: temp17b2
30354   REAL :: temp17b1
30355   REAL :: temp17b0
30356   REAL :: temp31
30357   REAL :: temp30
30358   REAL :: temp17b
30359   INTRINSIC MIN
30360   REAL :: temp28b
30361   REAL :: temp6b3
30362   REAL :: temp6b2
30363   REAL :: temp6b1
30364   DOUBLE PRECISION :: temp
30365   REAL :: temp6b0
30366   REAL :: temp9
30367   REAL :: temp10b4
30368   REAL :: temp32b0
30369   REAL :: temp8
30370   REAL :: temp10b3
30371   INTEGER :: temp7
30372   REAL :: temp10b
30373   REAL :: temp10b2
30374   REAL :: temp6
30375   REAL :: temp10b1
30376   REAL :: temp5
30377   REAL :: temp10b0
30378   REAL :: temp4
30379   specified = .false.
30380   IF (config_flags%specified .OR. config_flags%nested) specified = &
30381 &      .true.
30382 !  set order for vertical and horzontal flux operators
30383   IF (kte .GT. kde - 1) THEN
30384     ktf = kde - 1
30385   ELSE
30386     ktf = kte
30387   END IF
30388 !  begin with horizontal flux divergence
30389 !   horizontal_order_test : IF( horz_order == 6 ) THEN
30390 !   ELSE IF( horz_order == 5 ) THEN
30391 !  5th order horizontal flux calculation
30392 !  This code is EXACTLY the same as the 6th order code
30393 !  EXCEPT the 5th order and 3rd operators are used in
30394 !  place of the 6th and 4th order operators
30395 !  determine boundary mods for flux operators
30396 !  We degrade the flux operators from 3rd/4th order
30397 !   to second order one gridpoint in from the boundaries for
30398 !   all boundary conditions except periodic and symmetry - these
30399 !   conditions have boundary zone data fill for correct application
30400 !   of the higher order flux stencils
30401   degrade_xs = .true.
30402   degrade_xe = .true.
30403   degrade_ys = .true.
30404   degrade_ye = .true.
30405   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
30406 &      .GT. ids + 3) degrade_xs = .false.
30407   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
30408 &      .LT. ide - 2) degrade_xe = .false.
30409   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
30410 &      .GT. jds + 3) degrade_ys = .false.
30411   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
30412 &      .LT. jde - 4) degrade_ye = .false.
30413 !--------------- y - advection first
30414   i_start = its
30415   i_end = ite
30416   IF (config_flags%open_xs .OR. specified) THEN
30417     IF (ids + 1 .LT. its) THEN
30418       i_start = its
30419     ELSE
30420       i_start = ids + 1
30421     END IF
30422   END IF
30423   IF (config_flags%open_xe .OR. specified) THEN
30424     IF (ide - 1 .GT. ite) THEN
30425       i_end = ite
30426     ELSE
30427       i_end = ide - 1
30428     END IF
30429   END IF
30430   IF (config_flags%periodic_x) i_start = its
30431   IF (config_flags%periodic_x) i_end = ite
30432   j_start = jts
30433   IF (jte .GT. jde - 1) THEN
30434     j_end = jde - 1
30435   ELSE
30436     j_end = jte
30437   END IF
30438 !  higher order flux has a 5 or 7 point stencil, so compute
30439 !  bounds so we can switch to second order flux close to the boundary
30440   j_start_f = j_start
30441   j_end_f = j_end + 1
30442   IF (degrade_ys) THEN
30443     IF (jts .LT. jds + 1) THEN
30444       j_start = jds + 1
30445     ELSE
30446       j_start = jts
30447     END IF
30448     j_start_f = jds + 3
30449   END IF
30450   IF (degrade_ye) THEN
30451     IF (jte .GT. jde - 2) THEN
30452       j_end = jde - 2
30453     ELSE
30454       j_end = jte
30455     END IF
30456     j_end_f = jde - 3
30457   END IF
30458   IF (config_flags%polar) THEN
30459     IF (jte .GT. jde - 1) THEN
30460       j_end = jde - 1
30461     ELSE
30462       j_end = jte
30463     END IF
30464   END IF
30465 !  compute fluxes, 5th or 6th order
30466   jp1 = 2
30467   jp0 = 1
30468   ad_from7 = j_start
30469 j_loop_y_flux_5:DO j=ad_from7,j_end+1
30470     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
30471 ! use full stencil
30472       DO k=kts,ktf
30473         ad_from = i_start
30474         DO i=ad_from,i_end
30475           vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
30476           IF (vel*sign(1,time_step) .GE. 0.0) THEN
30477             CALL PUSHREAL8(qip2)
30478             qip2 = u(i, k, j+1)
30479             CALL PUSHREAL8(qip1)
30480             qip1 = u(i, k, j)
30481             CALL PUSHREAL8(qi)
30482             qi = u(i, k, j-1)
30483             CALL PUSHREAL8(qim1)
30484             qim1 = u(i, k, j-2)
30485             CALL PUSHREAL8(qim2)
30486             qim2 = u(i, k, j-3)
30487             CALL PUSHCONTROL1B(0)
30488           ELSE
30489             CALL PUSHREAL8(qip2)
30490             qip2 = u(i, k, j-2)
30491             CALL PUSHREAL8(qip1)
30492             qip1 = u(i, k, j-1)
30493             CALL PUSHREAL8(qi)
30494             qi = u(i, k, j)
30495             CALL PUSHREAL8(qim1)
30496             qim1 = u(i, k, j+1)
30497             CALL PUSHREAL8(qim2)
30498             qim2 = u(i, k, j+2)
30499             CALL PUSHCONTROL1B(1)
30500           END IF
30501           CALL PUSHREAL8(f0)
30502           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
30503           CALL PUSHREAL8(f1)
30504           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
30505           CALL PUSHREAL8(f2)
30506           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
30507           CALL PUSHREAL8(beta0)
30508           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
30509 &            qi)**2
30510           CALL PUSHREAL8(beta1)
30511           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
30512           CALL PUSHREAL8(beta2)
30513           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
30514 &            qi)**2
30515         END DO
30516         CALL PUSHINTEGER4(i - 1)
30517         CALL PUSHINTEGER4(ad_from)
30518       END DO
30519       CALL PUSHCONTROL3B(0)
30520     ELSE IF (j .EQ. jds + 1) THEN
30521 !          fqy( i, k, jp1 ) = vel*flux5(               &
30522 !                  u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
30523 !                  u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
30524 !  we must be close to some boundary where we need to reduce the order of the stencil
30525 ! 2nd order flux next to south boundary
30526       DO k=kts,ktf
30527         ad_from0 = i_start
30528         i = i_end + 1
30529         CALL PUSHINTEGER4(i - 1)
30530         CALL PUSHINTEGER4(ad_from0)
30531       END DO
30532       CALL PUSHCONTROL3B(1)
30533     ELSE IF (j .EQ. jds + 2) THEN
30534 ! third of 4th order flux 2 in from south boundary
30535       DO k=kts,ktf
30536         ad_from1 = i_start
30537         i = i_end + 1
30538         CALL PUSHINTEGER4(i - 1)
30539         CALL PUSHINTEGER4(ad_from1)
30540       END DO
30541       CALL PUSHCONTROL3B(2)
30542     ELSE IF (j .EQ. jde - 1) THEN
30543 ! 2nd order flux next to north boundary
30544       DO k=kts,ktf
30545         ad_from2 = i_start
30546         i = i_end + 1
30547         CALL PUSHINTEGER4(i - 1)
30548         CALL PUSHINTEGER4(ad_from2)
30549       END DO
30550       CALL PUSHCONTROL3B(3)
30551     ELSE IF (j .EQ. jde - 2) THEN
30552 ! 3rd order flux 2 in from north boundary
30553       DO k=kts,ktf
30554         ad_from3 = i_start
30555         i = i_end + 1
30556         CALL PUSHINTEGER4(i - 1)
30557         CALL PUSHINTEGER4(ad_from3)
30558       END DO
30559       CALL PUSHCONTROL3B(4)
30560     ELSE
30561       CALL PUSHCONTROL3B(5)
30562     END IF
30563 !  y flux-divergence into tendency
30564 ! (j > j_start) will miss the u(,,jds) tendency
30565     IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
30566       DO k=kts,ktf
30567         ad_from4 = i_start
30568         i = i_end + 1
30569         CALL PUSHINTEGER4(i - 1)
30570         CALL PUSHINTEGER4(ad_from4)
30571       END DO
30572       CALL PUSHCONTROL2B(0)
30573     ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
30574 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
30575       DO k=kts,ktf
30576         ad_from5 = i_start
30577         i = i_end + 1
30578         CALL PUSHINTEGER4(i - 1)
30579         CALL PUSHINTEGER4(ad_from5)
30580       END DO
30581       CALL PUSHCONTROL2B(1)
30582     ELSE IF (j .GT. j_start) THEN
30583 ! normal code
30584       DO k=kts,ktf
30585         ad_from6 = i_start
30586         i = i_end + 1
30587         CALL PUSHINTEGER4(i - 1)
30588         CALL PUSHINTEGER4(ad_from6)
30589       END DO
30590       CALL PUSHCONTROL2B(2)
30591     ELSE
30592       CALL PUSHCONTROL2B(3)
30593     END IF
30594     jtmp = jp1
30595     CALL PUSHINTEGER4(jp1)
30596     jp1 = jp0
30597     CALL PUSHINTEGER4(jp0)
30598     jp0 = jtmp
30599   END DO j_loop_y_flux_5
30600   CALL PUSHINTEGER4(j - 1)
30601   CALL PUSHINTEGER4(ad_from7)
30602 !  next, x - flux divergence
30603   i_start = its
30604   i_end = ite
30605   j_start = jts
30606   IF (jte .GT. jde - 1) THEN
30607     j_end = jde - 1
30608   ELSE
30609     j_end = jte
30610   END IF
30611 !  higher order flux has a 5 or 7 point stencil, so compute
30612 !  bounds so we can switch to second order flux close to the boundary
30613   i_start_f = i_start
30614   i_end_f = i_end + 1
30615   IF (degrade_xs) THEN
30616     IF (ids + 1 .LT. its) THEN
30617       i_start = its
30618     ELSE
30619       i_start = ids + 1
30620     END IF
30621     i_start_f = ids + 3
30622   END IF
30623   IF (degrade_xe) THEN
30624     IF (ide - 1 .GT. ite) THEN
30625       i_end = ite
30626     ELSE
30627       i_end = ide - 1
30628     END IF
30629     i_end_f = ide - 2
30630   END IF
30631   ad_from9 = j_start
30632 !  compute fluxes
30633   DO j=ad_from9,j_end
30634 !  5th or 6th order flux
30635     DO k=kts,ktf
30636       CALL PUSHINTEGER4(i)
30637       DO i=i_start_f,i_end_f
30638         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
30639         IF (vel*sign(1,time_step) .GE. 0.0) THEN
30640           CALL PUSHREAL8(qip2)
30641           qip2 = u(i+1, k, j)
30642           CALL PUSHREAL8(qip1)
30643           qip1 = u(i, k, j)
30644           CALL PUSHREAL8(qi)
30645           qi = u(i-1, k, j)
30646           CALL PUSHREAL8(qim1)
30647           qim1 = u(i-2, k, j)
30648           CALL PUSHREAL8(qim2)
30649           qim2 = u(i-3, k, j)
30650           CALL PUSHCONTROL1B(0)
30651         ELSE
30652           CALL PUSHREAL8(qip2)
30653           qip2 = u(i-2, k, j)
30654           CALL PUSHREAL8(qip1)
30655           qip1 = u(i-1, k, j)
30656           CALL PUSHREAL8(qi)
30657           qi = u(i, k, j)
30658           CALL PUSHREAL8(qim1)
30659           qim1 = u(i+1, k, j)
30660           CALL PUSHREAL8(qim2)
30661           qim2 = u(i+2, k, j)
30662           CALL PUSHCONTROL1B(1)
30663         END IF
30664         CALL PUSHREAL8(f0)
30665         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
30666         CALL PUSHREAL8(f1)
30667         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
30668         CALL PUSHREAL8(f2)
30669         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
30670         CALL PUSHREAL8(beta0)
30671         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
30672 &          )**2
30673         CALL PUSHREAL8(beta1)
30674         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
30675         CALL PUSHREAL8(beta2)
30676         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
30677 &          )**2
30678       END DO
30679     END DO
30680 !          fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
30681 !                                         u(i-1,k,j), u(i  ,k,j),  &
30682 !                                         u(i+1,k,j), u(i+2,k,j),  &
30683 !                                         vel                     )
30684 !  lower order fluxes close to boundaries (if not periodic or symmetric)
30685 !  specified uses upstream normal wind at boundaries
30686     IF (degrade_xs) THEN
30687       IF (i_start .EQ. ids + 1) THEN
30688         CALL PUSHINTEGER4(i)
30689 ! second order flux next to the boundary
30690         i = ids + 1
30691         DO k=kts,ktf
30692           CALL PUSHREAL8(ub)
30693           ub = u(i-1, k, j)
30694           IF (specified .AND. u(i, k, j) .LT. 0.) THEN
30695             ub = u(i, k, j)
30696             CALL PUSHCONTROL1B(0)
30697           ELSE
30698             CALL PUSHCONTROL1B(1)
30699           END IF
30700         END DO
30701         CALL PUSHCONTROL1B(0)
30702       ELSE
30703         CALL PUSHCONTROL1B(1)
30704       END IF
30705       CALL PUSHINTEGER4(i)
30706       i = ids + 2
30707       CALL PUSHCONTROL1B(0)
30708     ELSE
30709       CALL PUSHCONTROL1B(1)
30710     END IF
30711     IF (degrade_xe) THEN
30712       IF (i_end .EQ. ide - 1) THEN
30713         CALL PUSHINTEGER4(i)
30714 ! second order flux next to the boundary
30715         i = ide
30716         DO k=kts,ktf
30717           CALL PUSHREAL8(ub)
30718           ub = u(i, k, j)
30719           IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
30720             ub = u(i-1, k, j)
30721             CALL PUSHCONTROL1B(0)
30722           ELSE
30723             CALL PUSHCONTROL1B(1)
30724           END IF
30725         END DO
30726         CALL PUSHCONTROL1B(1)
30727       ELSE
30728         CALL PUSHCONTROL1B(0)
30729       END IF
30730       DO k=kts,ktf
30731         CALL PUSHINTEGER4(i)
30732       END DO
30733       CALL PUSHCONTROL1B(1)
30734     ELSE
30735       CALL PUSHCONTROL1B(0)
30736     END IF
30737 !  x flux-divergence into tendency
30738     DO k=kts,ktf
30739       ad_from8 = i_start
30740       CALL PUSHINTEGER4(i)
30741       i = i_end + 1
30742       CALL PUSHINTEGER4(i - 1)
30743       CALL PUSHINTEGER4(ad_from8)
30744     END DO
30745   END DO
30746   CALL PUSHINTEGER4(j - 1)
30747   CALL PUSHINTEGER4(ad_from9)
30748 !  radiative lateral boundary condition in x for normal velocity (u)
30749   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
30750     j_start = jts
30751     IF (jte .GT. jde - 1) THEN
30752       j_end = jde - 1
30753     ELSE
30754       j_end = jte
30755     END IF
30756     ad_from10 = j_start
30757     DO j=ad_from10,j_end
30758       DO k=kts,ktf
30759         IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN
30760           CALL PUSHREAL8(ub)
30761           ub = 0.
30762           CALL PUSHCONTROL1B(0)
30763         ELSE
30764           CALL PUSHREAL8(ub)
30765           ub = ru(its, k, j) - cb*mut(its, j)
30766           CALL PUSHCONTROL1B(1)
30767         END IF
30768       END DO
30769     END DO
30770     CALL PUSHINTEGER4(j - 1)
30771     CALL PUSHINTEGER4(ad_from10)
30772     CALL PUSHCONTROL1B(0)
30773   ELSE
30774     CALL PUSHCONTROL1B(1)
30775   END IF
30776   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
30777     j_start = jts
30778     IF (jte .GT. jde - 1) THEN
30779       j_end = jde - 1
30780     ELSE
30781       j_end = jte
30782     END IF
30783     ad_from11 = j_start
30784     DO j=ad_from11,j_end
30785       DO k=kts,ktf
30786         IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN
30787           CALL PUSHREAL8(ub)
30788           ub = 0.
30789           CALL PUSHCONTROL1B(0)
30790         ELSE
30791           CALL PUSHREAL8(ub)
30792           ub = ru(ite, k, j) + cb*mut(ite-1, j)
30793           CALL PUSHCONTROL1B(1)
30794         END IF
30795       END DO
30796     END DO
30797     CALL PUSHINTEGER4(j - 1)
30798     CALL PUSHINTEGER4(ad_from11)
30799     CALL PUSHCONTROL1B(1)
30800   ELSE
30801     CALL PUSHCONTROL1B(0)
30802   END IF
30803 !  pick up the rest of the horizontal radiation boundary conditions.
30804 !  (these are the computations that don't require 'cb')
30805 !  first, set to index ranges
30806   i_start = its
30807   IF (ite .GT. ide) THEN
30808     i_end = ide
30809   ELSE
30810     i_end = ite
30811   END IF
30812   imin = ids
30813   imax = ide - 1
30814   IF (config_flags%open_xs) THEN
30815     IF (ids + 1 .LT. its) THEN
30816       i_start = its
30817     ELSE
30818       i_start = ids + 1
30819     END IF
30820     imin = ids
30821   END IF
30822   IF (config_flags%open_xe) THEN
30823     IF (ite .GT. ide - 1) THEN
30824       i_end = ide - 1
30825     ELSE
30826       i_end = ite
30827     END IF
30828     imax = ide - 1
30829   END IF
30830   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
30831     ad_from12 = i_start
30832     CALL PUSHINTEGER4(i)
30833     DO i=ad_from12,i_end
30834       CALL PUSHREAL8(mrdy)
30835 ! ADT eqn 44, 2nd term on RHS
30836       mrdy = msfux(i, jts)*rdy
30837       IF (imax .GT. i) THEN
30838         CALL PUSHINTEGER4(ip)
30839         ip = i
30840         CALL PUSHCONTROL1B(0)
30841       ELSE
30842         CALL PUSHINTEGER4(ip)
30843         ip = imax
30844         CALL PUSHCONTROL1B(1)
30845       END IF
30846       IF (imin .LT. i - 1) THEN
30847         CALL PUSHINTEGER4(im)
30848         im = i - 1
30849         CALL PUSHCONTROL1B(0)
30850       ELSE
30851         CALL PUSHINTEGER4(im)
30852         im = imin
30853         CALL PUSHCONTROL1B(1)
30854       END IF
30855       DO k=kts,ktf
30856         vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts))
30857         IF (vw .GT. 0.) THEN
30858           CALL PUSHREAL8(vb)
30859           vb = 0.
30860           CALL PUSHCONTROL1B(0)
30861         ELSE
30862           CALL PUSHREAL8(vb)
30863           vb = vw
30864           CALL PUSHCONTROL1B(1)
30865         END IF
30866       END DO
30867     END DO
30868     CALL PUSHINTEGER4(i - 1)
30869     CALL PUSHINTEGER4(ad_from12)
30870     CALL PUSHCONTROL1B(0)
30871   ELSE
30872     CALL PUSHCONTROL1B(1)
30873   END IF
30874   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
30875     ad_from13 = i_start
30876     CALL PUSHINTEGER4(i)
30877     DO i=ad_from13,i_end
30878       CALL PUSHREAL8(mrdy)
30879 ! ADT eqn 44, 2nd term on RHS
30880       mrdy = msfux(i, jte-1)*rdy
30881       IF (imax .GT. i) THEN
30882         CALL PUSHINTEGER4(ip)
30883         ip = i
30884         CALL PUSHCONTROL1B(0)
30885       ELSE
30886         CALL PUSHINTEGER4(ip)
30887         ip = imax
30888         CALL PUSHCONTROL1B(1)
30889       END IF
30890       IF (imin .LT. i - 1) THEN
30891         CALL PUSHINTEGER4(im)
30892         im = i - 1
30893         CALL PUSHCONTROL1B(0)
30894       ELSE
30895         CALL PUSHINTEGER4(im)
30896         im = imin
30897         CALL PUSHCONTROL1B(1)
30898       END IF
30899       DO k=kts,ktf
30900         vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte))
30901         IF (vw .LT. 0.) THEN
30902           CALL PUSHREAL8(vb)
30903           vb = 0.
30904           CALL PUSHCONTROL1B(0)
30905         ELSE
30906           CALL PUSHREAL8(vb)
30907           vb = vw
30908           CALL PUSHCONTROL1B(1)
30909         END IF
30910       END DO
30911     END DO
30912     CALL PUSHINTEGER4(i - 1)
30913     CALL PUSHINTEGER4(ad_from13)
30914     CALL PUSHCONTROL1B(1)
30915   ELSE
30916     CALL PUSHCONTROL1B(0)
30917   END IF
30918 !-------------------- vertical advection
30919 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
30920 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
30921 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
30922 !  this is what we need, so leave unchanged in advect_u
30923   i_start = its
30924   i_end = ite
30925   j_start = jts
30926   IF (jte .GT. jde - 1) THEN
30927     j_end = jde - 1
30928   ELSE
30929     j_end = jte
30930   END IF
30931 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
30932 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
30933   IF (config_flags%open_ys .OR. specified) THEN
30934     IF (ids + 1 .LT. its) THEN
30935       i_start = its
30936     ELSE
30937       i_start = ids + 1
30938     END IF
30939   END IF
30940   IF (config_flags%open_ye .OR. specified) THEN
30941     IF (ide - 1 .GT. ite) THEN
30942       i_end = ite
30943     ELSE
30944       i_end = ide - 1
30945     END IF
30946   END IF
30947   IF (config_flags%periodic_x) i_start = its
30948   IF (config_flags%periodic_x) i_end = ite
30949 !   vert_order_test : IF (vert_order == 6) THEN
30950 !    ELSE IF (vert_order == 5) THEN
30951   DO j=j_start,j_end
30952     DO k=kts+3,ktf-2
30953       CALL PUSHINTEGER4(i)
30954       DO i=i_start,i_end
30955         vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
30956         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
30957           CALL PUSHREAL8(qip2)
30958           qip2 = u(i, k+1, j)
30959           CALL PUSHREAL8(qip1)
30960           qip1 = u(i, k, j)
30961           CALL PUSHREAL8(qi)
30962           qi = u(i, k-1, j)
30963           CALL PUSHREAL8(qim1)
30964           qim1 = u(i, k-2, j)
30965           CALL PUSHREAL8(qim2)
30966           qim2 = u(i, k-3, j)
30967           CALL PUSHCONTROL1B(0)
30968         ELSE
30969           CALL PUSHREAL8(qip2)
30970           qip2 = u(i, k-2, j)
30971           CALL PUSHREAL8(qip1)
30972           qip1 = u(i, k-1, j)
30973           CALL PUSHREAL8(qi)
30974           qi = u(i, k, j)
30975           CALL PUSHREAL8(qim1)
30976           qim1 = u(i, k+1, j)
30977           CALL PUSHREAL8(qim2)
30978           qim2 = u(i, k+2, j)
30979           CALL PUSHCONTROL1B(1)
30980         END IF
30981         CALL PUSHREAL8(f0)
30982         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
30983         CALL PUSHREAL8(f1)
30984         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
30985         CALL PUSHREAL8(f2)
30986         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
30987         CALL PUSHREAL8(beta0)
30988         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
30989 &          )**2
30990         CALL PUSHREAL8(beta1)
30991         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
30992         CALL PUSHREAL8(beta2)
30993         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
30994 &          )**2
30995       END DO
30996     END DO
30997     CALL PUSHINTEGER4(i)
30998     CALL PUSHINTEGER4(k)
30999   END DO
31000   vfluxb = 0.0
31001   DO j=j_end,j_start,-1
31002     DO k=ktf,kts,-1
31003       DO i=i_end,i_start,-1
31004         vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j)
31005         vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j)
31006       END DO
31007     END DO
31008     CALL POPINTEGER4(k)
31009     DO i=i_end,i_start,-1
31010       k = ktf
31011       temp32b = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, k)
31012       temp32b0 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
31013       romb(i, k, j) = romb(i, k, j) + temp32b
31014       romb(i-1, k, j) = romb(i-1, k, j) + temp32b
31015       ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp32b0
31016       ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp32b0
31017       vfluxb(i, k) = 0.0
31018       k = ktf - 1
31019       vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
31020       temp28 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, j)&
31021 &        )
31022       temp31 = SIGN(1., -vel)
31023       temp30 = temp31/12.0
31024       temp29 = SIGN(1, time_step)
31025       temp28b = vel*vfluxb(i, k)
31026       temp28b0 = temp28b/12.0
31027       temp28b1 = temp29*temp30*temp28b
31028       velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))/&
31029 &        12.0+temp29*(temp30*temp28))*vfluxb(i, k)
31030       ub0(i, k, j) = ub0(i, k, j) + 7.*temp28b0 - 3.*temp28b1
31031       ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp28b1 + 7.*temp28b0
31032       ub0(i, k+1, j) = ub0(i, k+1, j) + temp28b1 - temp28b0
31033       ub0(i, k-2, j) = ub0(i, k-2, j) - temp28b1 - temp28b0
31034       vfluxb(i, k) = 0.0
31035       romb(i, k, j) = romb(i, k, j) + 0.5*velb
31036       romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
31037       k = kts + 2
31038       vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
31039       temp24 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, j)&
31040 &        )
31041       temp27 = SIGN(1., -vel)
31042       temp26 = temp27/12.0
31043       temp25 = SIGN(1, time_step)
31044       temp24b1 = vel*vfluxb(i, k)
31045       temp24b2 = temp24b1/12.0
31046       temp24b3 = temp25*temp26*temp24b1
31047       velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))/&
31048 &        12.0+temp25*(temp26*temp24))*vfluxb(i, k)
31049       ub0(i, k, j) = ub0(i, k, j) + 7.*temp24b2 - 3.*temp24b3
31050       ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp24b3 + 7.*temp24b2
31051       ub0(i, k+1, j) = ub0(i, k+1, j) + temp24b3 - temp24b2
31052       ub0(i, k-2, j) = ub0(i, k-2, j) - temp24b3 - temp24b2
31053       vfluxb(i, k) = 0.0
31054       romb(i, k, j) = romb(i, k, j) + 0.5*velb
31055       romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
31056       k = kts + 1
31057       temp24b4 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, k&
31058 &        )
31059       temp24b5 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k)
31060       romb(i, k, j) = romb(i, k, j) + temp24b4
31061       romb(i-1, k, j) = romb(i-1, k, j) + temp24b4
31062       ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp24b5
31063       ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp24b5
31064       vfluxb(i, k) = 0.0
31065     END DO
31066     CALL POPINTEGER4(i)
31067     DO k=ktf-2,kts+3,-1
31068       DO i=i_end,i_start,-1
31069         wi0 = gi0/(eps+beta0)**pw
31070         wi1 = gi1/(eps+beta1)**pw
31071         wi2 = gi2/(eps+beta2)**pw
31072         sumwk = wi0 + wi1 + wi2
31073         vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
31074         temp24b = vel*vfluxb(i, k)/sumwk
31075         temp24b0 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk
31076         f0b = wi0*temp24b
31077         f1b = wi1*temp24b
31078         f2b = wi2*temp24b
31079         velb = temp24b0
31080         sumwkb = -(vel*temp24b0/sumwk)
31081         wi0b = sumwkb + f0*temp24b
31082         wi1b = sumwkb + f1*temp24b
31083         wi2b = sumwkb + f2*temp24b
31084         vfluxb(i, k) = 0.0
31085         temp23 = (eps+beta2)**pw
31086         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
31087 &            )) THEN
31088           beta2b = 0.0
31089         ELSE
31090           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp23**2)
31091         END IF
31092         temp22 = (eps+beta1)**pw
31093         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
31094 &            )) THEN
31095           beta1b = 0.0
31096         ELSE
31097           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp22**2)
31098         END IF
31099         temp21 = (eps+beta0)**pw
31100         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
31101 &            )) THEN
31102           beta0b = 0.0
31103         ELSE
31104           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp21**2)
31105         END IF
31106         CALL POPREAL8(beta2)
31107         temp21b5 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
31108         temp21b6 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
31109         qip2b = temp21b6 - f2b/6. + temp21b5
31110         CALL POPREAL8(beta1)
31111         temp21b7 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
31112         temp21b10 = 2*(qim1-qip1)*beta1b/4.
31113         qip1b = temp21b7 - temp21b10 + f1b/3. + 5.*f2b/6. - 4.*temp21b6 &
31114 &          - 2.*temp21b5
31115         CALL POPREAL8(beta0)
31116         temp21b9 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
31117         temp21b8 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
31118         qib = f2b/3. - 2.*temp21b7 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
31119 &          temp21b8 + temp21b9 + 3.*temp21b6 + temp21b5
31120         qim1b = temp21b10 - 4.*temp21b8 - 7.*f0b/6. - f1b/6. - 2.*&
31121 &          temp21b9 + temp21b7
31122         qim2b = f0b/3. + temp21b8 + temp21b9
31123         CALL POPREAL8(f2)
31124         CALL POPREAL8(f1)
31125         CALL POPREAL8(f0)
31126         CALL POPCONTROL1B(branch)
31127         IF (branch .EQ. 0) THEN
31128           CALL POPREAL8(qim2)
31129           ub0(i, k-3, j) = ub0(i, k-3, j) + qim2b
31130           CALL POPREAL8(qim1)
31131           ub0(i, k-2, j) = ub0(i, k-2, j) + qim1b
31132           CALL POPREAL8(qi)
31133           ub0(i, k-1, j) = ub0(i, k-1, j) + qib
31134           CALL POPREAL8(qip1)
31135           ub0(i, k, j) = ub0(i, k, j) + qip1b
31136           CALL POPREAL8(qip2)
31137           ub0(i, k+1, j) = ub0(i, k+1, j) + qip2b
31138         ELSE
31139           CALL POPREAL8(qim2)
31140           ub0(i, k+2, j) = ub0(i, k+2, j) + qim2b
31141           CALL POPREAL8(qim1)
31142           ub0(i, k+1, j) = ub0(i, k+1, j) + qim1b
31143           CALL POPREAL8(qi)
31144           ub0(i, k, j) = ub0(i, k, j) + qib
31145           CALL POPREAL8(qip1)
31146           ub0(i, k-1, j) = ub0(i, k-1, j) + qip1b
31147           CALL POPREAL8(qip2)
31148           ub0(i, k-2, j) = ub0(i, k-2, j) + qip2b
31149         END IF
31150         romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb
31151         romb(i, k, j) = romb(i, k, j) + 0.5*velb
31152       END DO
31153       CALL POPINTEGER4(i)
31154     END DO
31155   END DO
31156   CALL POPCONTROL1B(branch)
31157   IF (branch .NE. 0) THEN
31158     CALL POPINTEGER4(ad_from13)
31159     CALL POPINTEGER4(ad_to13)
31160     DO i=ad_to13,ad_from13,-1
31161       DO k=ktf,kts,-1
31162         dvm = rv(ip, k, jte) - rv(ip, k, jte-1)
31163         dvp = rv(im, k, jte) - rv(im, k, jte-1)
31164         temp21b3 = -(mrdy*tendencyb(i, k, jte-1))
31165         temp21b4 = 0.5*u(i, k, jte-1)*temp21b3
31166         vbb = (u_old(i, k, jte-1)-u_old(i, k, jte-2))*temp21b3
31167         u_oldb(i, k, jte-1) = u_oldb(i, k, jte-1) + vb*temp21b3
31168         u_oldb(i, k, jte-2) = u_oldb(i, k, jte-2) - vb*temp21b3
31169         ub0(i, k, jte-1) = ub0(i, k, jte-1) + 0.5*(dvm+dvp)*temp21b3
31170         dvmb = temp21b4
31171         dvpb = temp21b4
31172         rvb(im, k, jte) = rvb(im, k, jte) + dvpb
31173         rvb(im, k, jte-1) = rvb(im, k, jte-1) - dvpb
31174         rvb(ip, k, jte) = rvb(ip, k, jte) + dvmb
31175         rvb(ip, k, jte-1) = rvb(ip, k, jte-1) - dvmb
31176         CALL POPCONTROL1B(branch)
31177         IF (branch .EQ. 0) THEN
31178           CALL POPREAL8(vb)
31179           vwb = 0.0
31180         ELSE
31181           CALL POPREAL8(vb)
31182           vwb = vbb
31183         END IF
31184         rvb(ip, k, jte) = rvb(ip, k, jte) + 0.5*vwb
31185         rvb(im, k, jte) = rvb(im, k, jte) + 0.5*vwb
31186       END DO
31187       CALL POPCONTROL1B(branch)
31188       IF (branch .EQ. 0) THEN
31189         CALL POPINTEGER4(im)
31190       ELSE
31191         CALL POPINTEGER4(im)
31192       END IF
31193       CALL POPCONTROL1B(branch)
31194       IF (branch .EQ. 0) THEN
31195         CALL POPINTEGER4(ip)
31196       ELSE
31197         CALL POPINTEGER4(ip)
31198       END IF
31199       CALL POPREAL8(mrdy)
31200     END DO
31201     CALL POPINTEGER4(i)
31202   END IF
31203   CALL POPCONTROL1B(branch)
31204   IF (branch .EQ. 0) THEN
31205     CALL POPINTEGER4(ad_from12)
31206     CALL POPINTEGER4(ad_to12)
31207     DO i=ad_to12,ad_from12,-1
31208       DO k=ktf,kts,-1
31209         dvm = rv(ip, k, jts+1) - rv(ip, k, jts)
31210         dvp = rv(im, k, jts+1) - rv(im, k, jts)
31211         temp21b1 = -(mrdy*tendencyb(i, k, jts))
31212         temp21b2 = 0.5*u(i, k, jts)*temp21b1
31213         vbb = (u_old(i, k, jts+1)-u_old(i, k, jts))*temp21b1
31214         u_oldb(i, k, jts+1) = u_oldb(i, k, jts+1) + vb*temp21b1
31215         u_oldb(i, k, jts) = u_oldb(i, k, jts) - vb*temp21b1
31216         ub0(i, k, jts) = ub0(i, k, jts) + 0.5*(dvm+dvp)*temp21b1
31217         dvmb = temp21b2
31218         dvpb = temp21b2
31219         rvb(im, k, jts+1) = rvb(im, k, jts+1) + dvpb
31220         rvb(im, k, jts) = rvb(im, k, jts) - dvpb
31221         rvb(ip, k, jts+1) = rvb(ip, k, jts+1) + dvmb
31222         rvb(ip, k, jts) = rvb(ip, k, jts) - dvmb
31223         CALL POPCONTROL1B(branch)
31224         IF (branch .EQ. 0) THEN
31225           CALL POPREAL8(vb)
31226           vwb = 0.0
31227         ELSE
31228           CALL POPREAL8(vb)
31229           vwb = vbb
31230         END IF
31231         rvb(ip, k, jts) = rvb(ip, k, jts) + 0.5*vwb
31232         rvb(im, k, jts) = rvb(im, k, jts) + 0.5*vwb
31233       END DO
31234       CALL POPCONTROL1B(branch)
31235       IF (branch .EQ. 0) THEN
31236         CALL POPINTEGER4(im)
31237       ELSE
31238         CALL POPINTEGER4(im)
31239       END IF
31240       CALL POPCONTROL1B(branch)
31241       IF (branch .EQ. 0) THEN
31242         CALL POPINTEGER4(ip)
31243       ELSE
31244         CALL POPINTEGER4(ip)
31245       END IF
31246       CALL POPREAL8(mrdy)
31247     END DO
31248     CALL POPINTEGER4(i)
31249   END IF
31250   CALL POPCONTROL1B(branch)
31251   IF (branch .NE. 0) THEN
31252     CALL POPINTEGER4(ad_from11)
31253     CALL POPINTEGER4(ad_to11)
31254     DO j=ad_to11,ad_from11,-1
31255       DO k=ktf,kts,-1
31256         temp21b0 = -(rdx*tendencyb(ite, k, j))
31257         ubb = (u_old(ite, k, j)-u_old(ite-1, k, j))*temp21b0
31258         u_oldb(ite, k, j) = u_oldb(ite, k, j) + ub*temp21b0
31259         u_oldb(ite-1, k, j) = u_oldb(ite-1, k, j) - ub*temp21b0
31260         CALL POPCONTROL1B(branch)
31261         IF (branch .EQ. 0) THEN
31262           CALL POPREAL8(ub)
31263         ELSE
31264           CALL POPREAL8(ub)
31265           rub(ite, k, j) = rub(ite, k, j) + ubb
31266           mutb(ite-1, j) = mutb(ite-1, j) + cb*ubb
31267         END IF
31268       END DO
31269     END DO
31270   END IF
31271   CALL POPCONTROL1B(branch)
31272   IF (branch .EQ. 0) THEN
31273     CALL POPINTEGER4(ad_from10)
31274     CALL POPINTEGER4(ad_to10)
31275     DO j=ad_to10,ad_from10,-1
31276       DO k=ktf,kts,-1
31277         temp21b = -(rdx*tendencyb(its, k, j))
31278         ubb = (u_old(its+1, k, j)-u_old(its, k, j))*temp21b
31279         u_oldb(its+1, k, j) = u_oldb(its+1, k, j) + ub*temp21b
31280         u_oldb(its, k, j) = u_oldb(its, k, j) - ub*temp21b
31281         CALL POPCONTROL1B(branch)
31282         IF (branch .EQ. 0) THEN
31283           CALL POPREAL8(ub)
31284         ELSE
31285           CALL POPREAL8(ub)
31286           rub(its, k, j) = rub(its, k, j) + ubb
31287           mutb(its, j) = mutb(its, j) - cb*ubb
31288         END IF
31289       END DO
31290     END DO
31291   END IF
31292   fqxb = 0.0
31293   CALL POPINTEGER4(ad_from9)
31294   CALL POPINTEGER4(ad_to9)
31295   DO j=ad_to9,ad_from9,-1
31296     DO k=ktf,kts,-1
31297       CALL POPINTEGER4(ad_from8)
31298       CALL POPINTEGER4(ad_to8)
31299       DO i=ad_to8,ad_from8,-1
31300         mrdx = msfux(i, j)*rdx
31301         fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
31302         fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
31303       END DO
31304       CALL POPINTEGER4(i)
31305     END DO
31306     CALL POPCONTROL1B(branch)
31307     IF (branch .NE. 0) THEN
31308       DO k=ktf,kts,-1
31309         i = ide - 1
31310         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
31311         temp17 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1, k, &
31312 &          j))
31313         temp20 = SIGN(1., vel)
31314         temp19 = temp20/12.0
31315         temp18 = SIGN(1, time_step)
31316         temp17b1 = vel*fqxb(i, k)
31317         temp17b2 = temp17b1/12.0
31318         temp17b3 = temp18*temp19*temp17b1
31319         velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, j))&
31320 &          /12.0+temp18*(temp19*temp17))*fqxb(i, k)
31321         ub0(i, k, j) = ub0(i, k, j) + 7.*temp17b2 - 3.*temp17b3
31322         ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp17b3 + 7.*temp17b2
31323         ub0(i+1, k, j) = ub0(i+1, k, j) + temp17b3 - temp17b2
31324         ub0(i-2, k, j) = ub0(i-2, k, j) - temp17b3 - temp17b2
31325         fqxb(i, k) = 0.0
31326         rub(i, k, j) = rub(i, k, j) + 0.5*velb
31327         rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
31328         CALL POPINTEGER4(i)
31329       END DO
31330       CALL POPCONTROL1B(branch)
31331       IF (branch .NE. 0) THEN
31332         DO k=ktf,kts,-1
31333           temp17b = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k)
31334           temp17b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
31335           rub(i, k, j) = rub(i, k, j) + temp17b
31336           rub(i-1, k, j) = rub(i-1, k, j) + temp17b
31337           ub0(i-1, k, j) = ub0(i-1, k, j) + temp17b0
31338           ubb = temp17b0
31339           fqxb(i, k) = 0.0
31340           CALL POPCONTROL1B(branch)
31341           IF (branch .EQ. 0) THEN
31342             ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
31343             ubb = 0.0
31344           END IF
31345           CALL POPREAL8(ub)
31346           ub0(i, k, j) = ub0(i, k, j) + ubb
31347         END DO
31348         CALL POPINTEGER4(i)
31349       END IF
31350     END IF
31351     CALL POPCONTROL1B(branch)
31352     IF (branch .EQ. 0) THEN
31353       DO k=ktf,kts,-1
31354         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
31355         temp13 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1, k, &
31356 &          j))
31357         temp16 = SIGN(1., vel)
31358         temp15 = temp16/12.0
31359         temp14 = SIGN(1, time_step)
31360         temp13b3 = vel*fqxb(i, k)
31361         temp13b4 = temp13b3/12.0
31362         temp13b5 = temp14*temp15*temp13b3
31363         velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, j))&
31364 &          /12.0+temp14*(temp15*temp13))*fqxb(i, k)
31365         ub0(i, k, j) = ub0(i, k, j) + 7.*temp13b4 - 3.*temp13b5
31366         ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp13b5 + 7.*temp13b4
31367         ub0(i+1, k, j) = ub0(i+1, k, j) + temp13b5 - temp13b4
31368         ub0(i-2, k, j) = ub0(i-2, k, j) - temp13b5 - temp13b4
31369         fqxb(i, k) = 0.0
31370         rub(i, k, j) = rub(i, k, j) + 0.5*velb
31371         rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
31372       END DO
31373       CALL POPINTEGER4(i)
31374       CALL POPCONTROL1B(branch)
31375       IF (branch .EQ. 0) THEN
31376         DO k=ktf,kts,-1
31377           temp13b1 = 0.25*(u(i, k, j)+ub)*fqxb(i, k)
31378           temp13b2 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k)
31379           rub(i, k, j) = rub(i, k, j) + temp13b1
31380           rub(i-1, k, j) = rub(i-1, k, j) + temp13b1
31381           ub0(i, k, j) = ub0(i, k, j) + temp13b2
31382           ubb = temp13b2
31383           fqxb(i, k) = 0.0
31384           CALL POPCONTROL1B(branch)
31385           IF (branch .EQ. 0) THEN
31386             ub0(i, k, j) = ub0(i, k, j) + ubb
31387             ubb = 0.0
31388           END IF
31389           CALL POPREAL8(ub)
31390           ub0(i-1, k, j) = ub0(i-1, k, j) + ubb
31391         END DO
31392         CALL POPINTEGER4(i)
31393       END IF
31394     END IF
31395     DO k=ktf,kts,-1
31396       DO i=i_end_f,i_start_f,-1
31397         wi0 = gi0/(eps+beta0)**pw
31398         wi1 = gi1/(eps+beta1)**pw
31399         wi2 = gi2/(eps+beta2)**pw
31400         sumwk = wi0 + wi1 + wi2
31401         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
31402         temp13b = vel*fqxb(i, k)/sumwk
31403         temp13b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk
31404         f0b = wi0*temp13b
31405         f1b = wi1*temp13b
31406         f2b = wi2*temp13b
31407         velb = temp13b0
31408         sumwkb = -(vel*temp13b0/sumwk)
31409         wi0b = sumwkb + f0*temp13b
31410         wi1b = sumwkb + f1*temp13b
31411         wi2b = sumwkb + f2*temp13b
31412         fqxb(i, k) = 0.0
31413         temp12 = (eps+beta2)**pw
31414         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
31415 &            )) THEN
31416           beta2b = 0.0
31417         ELSE
31418           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp12**2)
31419         END IF
31420         temp11 = (eps+beta1)**pw
31421         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
31422 &            )) THEN
31423           beta1b = 0.0
31424         ELSE
31425           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp11**2)
31426         END IF
31427         temp10 = (eps+beta0)**pw
31428         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
31429 &            )) THEN
31430           beta0b = 0.0
31431         ELSE
31432           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp10**2)
31433         END IF
31434         CALL POPREAL8(beta2)
31435         temp10b = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
31436         temp10b0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
31437         qip2b = temp10b0 - f2b/6. + temp10b
31438         CALL POPREAL8(beta1)
31439         temp10b1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
31440         temp10b4 = 2*(qim1-qip1)*beta1b/4.
31441         qip1b = temp10b1 - temp10b4 + f1b/3. + 5.*f2b/6. - 4.*temp10b0 -&
31442 &          2.*temp10b
31443         CALL POPREAL8(beta0)
31444         temp10b3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
31445         temp10b2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
31446         qib = f2b/3. - 2.*temp10b1 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
31447 &          temp10b2 + temp10b3 + 3.*temp10b0 + temp10b
31448         qim1b = temp10b4 - 4.*temp10b2 - 7.*f0b/6. - f1b/6. - 2.*&
31449 &          temp10b3 + temp10b1
31450         qim2b = f0b/3. + temp10b2 + temp10b3
31451         CALL POPREAL8(f2)
31452         CALL POPREAL8(f1)
31453         CALL POPREAL8(f0)
31454         CALL POPCONTROL1B(branch)
31455         IF (branch .EQ. 0) THEN
31456           CALL POPREAL8(qim2)
31457           ub0(i-3, k, j) = ub0(i-3, k, j) + qim2b
31458           CALL POPREAL8(qim1)
31459           ub0(i-2, k, j) = ub0(i-2, k, j) + qim1b
31460           CALL POPREAL8(qi)
31461           ub0(i-1, k, j) = ub0(i-1, k, j) + qib
31462           CALL POPREAL8(qip1)
31463           ub0(i, k, j) = ub0(i, k, j) + qip1b
31464           CALL POPREAL8(qip2)
31465           ub0(i+1, k, j) = ub0(i+1, k, j) + qip2b
31466         ELSE
31467           CALL POPREAL8(qim2)
31468           ub0(i+2, k, j) = ub0(i+2, k, j) + qim2b
31469           CALL POPREAL8(qim1)
31470           ub0(i+1, k, j) = ub0(i+1, k, j) + qim1b
31471           CALL POPREAL8(qi)
31472           ub0(i, k, j) = ub0(i, k, j) + qib
31473           CALL POPREAL8(qip1)
31474           ub0(i-1, k, j) = ub0(i-1, k, j) + qip1b
31475           CALL POPREAL8(qip2)
31476           ub0(i-2, k, j) = ub0(i-2, k, j) + qip2b
31477         END IF
31478         rub(i, k, j) = rub(i, k, j) + 0.5*velb
31479         rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb
31480       END DO
31481       CALL POPINTEGER4(i)
31482     END DO
31483   END DO
31484   fqyb = 0.0
31485   CALL POPINTEGER4(ad_from7)
31486   CALL POPINTEGER4(ad_to7)
31487   DO j=ad_to7,ad_from7,-1
31488     CALL POPINTEGER4(jp0)
31489     CALL POPINTEGER4(jp1)
31490     CALL POPCONTROL2B(branch)
31491     IF (branch .LT. 2) THEN
31492       IF (branch .EQ. 0) THEN
31493         DO k=ktf,kts,-1
31494           CALL POPINTEGER4(ad_from4)
31495           CALL POPINTEGER4(ad_to4)
31496           DO i=ad_to4,ad_from4,-1
31497             mrdy = msfux(i, j-1)*rdy
31498             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
31499 &              )
31500           END DO
31501         END DO
31502       ELSE
31503         DO k=ktf,kts,-1
31504           CALL POPINTEGER4(ad_from5)
31505           CALL POPINTEGER4(ad_to5)
31506           DO i=ad_to5,ad_from5,-1
31507             mrdy = msfux(i, j-1)*rdy
31508             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
31509 &              )
31510           END DO
31511         END DO
31512       END IF
31513     ELSE IF (branch .EQ. 2) THEN
31514       DO k=ktf,kts,-1
31515         CALL POPINTEGER4(ad_from6)
31516         CALL POPINTEGER4(ad_to6)
31517         DO i=ad_to6,ad_from6,-1
31518           mrdy = msfux(i, j-1)*rdy
31519           fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1)
31520           fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1)
31521         END DO
31522       END DO
31523     END IF
31524     CALL POPCONTROL3B(branch)
31525     IF (branch .LT. 3) THEN
31526       IF (branch .EQ. 0) THEN
31527         DO k=ktf,kts,-1
31528           CALL POPINTEGER4(ad_from)
31529           CALL POPINTEGER4(ad_to)
31530           DO i=ad_to,ad_from,-1
31531             wi0 = gi0/(eps+beta0)**pw
31532             wi1 = gi1/(eps+beta1)**pw
31533             wi2 = gi2/(eps+beta2)**pw
31534             sumwk = wi0 + wi1 + wi2
31535             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
31536             temp2b = vel*fqyb(i, k, jp1)/sumwk
31537             temp2b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk
31538             f0b = wi0*temp2b
31539             f1b = wi1*temp2b
31540             f2b = wi2*temp2b
31541             velb = temp2b0
31542             sumwkb = -(vel*temp2b0/sumwk)
31543             wi0b = sumwkb + f0*temp2b
31544             wi1b = sumwkb + f1*temp2b
31545             wi2b = sumwkb + f2*temp2b
31546             fqyb(i, k, jp1) = 0.0
31547             temp1 = (eps+beta2)**pw
31548             IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
31549 &                (pw))) THEN
31550               beta2b = 0.0
31551             ELSE
31552               beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2)
31553             END IF
31554             temp0 = (eps+beta1)**pw
31555             IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
31556 &                (pw))) THEN
31557               beta1b = 0.0
31558             ELSE
31559               beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2)
31560             END IF
31561             temp = (eps+beta0)**pw
31562             IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
31563 &                (pw))) THEN
31564               beta0b = 0.0
31565             ELSE
31566               beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2)
31567             END IF
31568             CALL POPREAL8(beta2)
31569             tempb = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
31570             tempb0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
31571             qip2b = tempb0 - f2b/6. + tempb
31572             CALL POPREAL8(beta1)
31573             tempb1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
31574             tempb4 = 2*(qim1-qip1)*beta1b/4.
31575             qip1b = tempb1 - tempb4 + f1b/3. + 5.*f2b/6. - 4.*tempb0 - &
31576 &              2.*tempb
31577             CALL POPREAL8(beta0)
31578             tempb3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
31579             tempb2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
31580             qib = f2b/3. - 2.*tempb1 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
31581 &              tempb2 + tempb3 + 3.*tempb0 + tempb
31582             qim1b = tempb4 - 4.*tempb2 - 7.*f0b/6. - f1b/6. - 2.*tempb3 &
31583 &              + tempb1
31584             qim2b = f0b/3. + tempb2 + tempb3
31585             CALL POPREAL8(f2)
31586             CALL POPREAL8(f1)
31587             CALL POPREAL8(f0)
31588             CALL POPCONTROL1B(branch)
31589             IF (branch .EQ. 0) THEN
31590               CALL POPREAL8(qim2)
31591               ub0(i, k, j-3) = ub0(i, k, j-3) + qim2b
31592               CALL POPREAL8(qim1)
31593               ub0(i, k, j-2) = ub0(i, k, j-2) + qim1b
31594               CALL POPREAL8(qi)
31595               ub0(i, k, j-1) = ub0(i, k, j-1) + qib
31596               CALL POPREAL8(qip1)
31597               ub0(i, k, j) = ub0(i, k, j) + qip1b
31598               CALL POPREAL8(qip2)
31599               ub0(i, k, j+1) = ub0(i, k, j+1) + qip2b
31600             ELSE
31601               CALL POPREAL8(qim2)
31602               ub0(i, k, j+2) = ub0(i, k, j+2) + qim2b
31603               CALL POPREAL8(qim1)
31604               ub0(i, k, j+1) = ub0(i, k, j+1) + qim1b
31605               CALL POPREAL8(qi)
31606               ub0(i, k, j) = ub0(i, k, j) + qib
31607               CALL POPREAL8(qip1)
31608               ub0(i, k, j-1) = ub0(i, k, j-1) + qip1b
31609               CALL POPREAL8(qip2)
31610               ub0(i, k, j-2) = ub0(i, k, j-2) + qip2b
31611             END IF
31612             rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
31613             rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
31614           END DO
31615         END DO
31616       ELSE IF (branch .EQ. 1) THEN
31617         DO k=ktf,kts,-1
31618           CALL POPINTEGER4(ad_from0)
31619           CALL POPINTEGER4(ad_to0)
31620           DO i=ad_to0,ad_from0,-1
31621             temp2b1 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
31622             temp2b2 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1)
31623             rvb(i, k, j) = rvb(i, k, j) + temp2b1
31624             rvb(i-1, k, j) = rvb(i-1, k, j) + temp2b1
31625             ub0(i, k, j) = ub0(i, k, j) + temp2b2
31626             ub0(i, k, j-1) = ub0(i, k, j-1) + temp2b2
31627             fqyb(i, k, jp1) = 0.0
31628           END DO
31629         END DO
31630       ELSE
31631         DO k=ktf,kts,-1
31632           CALL POPINTEGER4(ad_from1)
31633           CALL POPINTEGER4(ad_to1)
31634           DO i=ad_to1,ad_from1,-1
31635             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
31636             temp2 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, k&
31637 &              , j-1))
31638             temp5 = SIGN(1., vel)
31639             temp4 = temp5/12.0
31640             temp3 = SIGN(1, time_step)
31641             temp2b3 = vel*fqyb(i, k, jp1)
31642             temp2b4 = temp2b3/12.0
31643             temp2b5 = temp3*temp4*temp2b3
31644             velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, j&
31645 &              -2))/12.0+temp3*(temp4*temp2))*fqyb(i, k, jp1)
31646             ub0(i, k, j) = ub0(i, k, j) + 7.*temp2b4 - 3.*temp2b5
31647             ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp2b5 + 7.*temp2b4
31648             ub0(i, k, j+1) = ub0(i, k, j+1) + temp2b5 - temp2b4
31649             ub0(i, k, j-2) = ub0(i, k, j-2) - temp2b5 - temp2b4
31650             fqyb(i, k, jp1) = 0.0
31651             rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
31652             rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
31653           END DO
31654         END DO
31655       END IF
31656     ELSE IF (branch .EQ. 3) THEN
31657       DO k=ktf,kts,-1
31658         CALL POPINTEGER4(ad_from2)
31659         CALL POPINTEGER4(ad_to2)
31660         DO i=ad_to2,ad_from2,-1
31661           temp6b = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1)
31662           temp6b0 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1)
31663           rvb(i, k, j) = rvb(i, k, j) + temp6b
31664           rvb(i-1, k, j) = rvb(i-1, k, j) + temp6b
31665           ub0(i, k, j) = ub0(i, k, j) + temp6b0
31666           ub0(i, k, j-1) = ub0(i, k, j-1) + temp6b0
31667           fqyb(i, k, jp1) = 0.0
31668         END DO
31669       END DO
31670     ELSE IF (branch .EQ. 4) THEN
31671       DO k=ktf,kts,-1
31672         CALL POPINTEGER4(ad_from3)
31673         CALL POPINTEGER4(ad_to3)
31674         DO i=ad_to3,ad_from3,-1
31675           vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
31676           temp6 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, k, j&
31677 &            -1))
31678           temp9 = SIGN(1., vel)
31679           temp8 = temp9/12.0
31680           temp7 = SIGN(1, time_step)
31681           temp6b1 = vel*fqyb(i, k, jp1)
31682           temp6b2 = temp6b1/12.0
31683           temp6b3 = temp7*temp8*temp6b1
31684           velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, j-2&
31685 &            ))/12.0+temp7*(temp8*temp6))*fqyb(i, k, jp1)
31686           ub0(i, k, j) = ub0(i, k, j) + 7.*temp6b2 - 3.*temp6b3
31687           ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp6b3 + 7.*temp6b2
31688           ub0(i, k, j+1) = ub0(i, k, j+1) + temp6b3 - temp6b2
31689           ub0(i, k, j-2) = ub0(i, k, j-2) - temp6b3 - temp6b2
31690           fqyb(i, k, jp1) = 0.0
31691           rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
31692           rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb
31693         END DO
31694       END DO
31695     END IF
31696   END DO
31697 END SUBROUTINE A_ADVECT_WENO_U
31698
31699 !        Generated by TAPENADE     (INRIA, Tropics team)
31700 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
31701 !
31702 !  Differentiation of advect_weno_v in reverse (adjoint) mode:
31703 !   gradient     of useful results: rom tendency v v_old ru rv
31704 !                mut
31705 !   with respect to varying inputs: rom tendency v v_old ru rv
31706 !                mut
31707 !   RW status of diff variables: rom:incr tendency:in-out v:incr
31708 !                v_old:incr ru:incr rv:incr mut:incr
31709 SUBROUTINE A_ADVECT_WENO_V(v, vb0, v_old, v_oldb, tendency, tendencyb, &
31710 &  ru, rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux&
31711 &  , msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, &
31712 &  ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, &
31713 &  jte, kts, kte)
31714   IMPLICIT NONE
31715 ! Input data
31716   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
31717   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
31718 &  jme, kms, kme, its, ite, jts, jte, kts, kte
31719   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru&
31720 &  , rv, rom
31721   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: vb0, v_oldb, rub, rvb, &
31722 &  romb
31723   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
31724   REAL, DIMENSION(ims:ime, jms:jme) :: mutb
31725   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
31726   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb
31727   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
31728 &  msfvy, msftx, msfty
31729   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
31730   REAL, INTENT(IN) :: rdx, rdy
31731   INTEGER, INTENT(IN) :: time_step
31732 ! Local data
31733   INTEGER :: i, j, k, itf, jtf, ktf
31734   INTEGER :: i_start, i_end, j_start, j_end
31735   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
31736   INTEGER :: jmin, jmax, jp, jm, imin, imax
31737   REAL :: dir, vv
31738   REAL :: ue, vs, vn, wb, wt
31739   REAL, PARAMETER :: f30=7./12., f31=1./12.
31740   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
31741   INTEGER :: kt, kb
31742   REAL :: qim2, qim1, qi, qip1, qip2
31743   REAL :: qim2b, qim1b, qib, qip1b, qip2b
31744   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
31745 &  sumwk
31746   DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b&
31747 &  , wi2b, sumwkb
31748   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
31749 &    3.d0/10.d0, eps=1.0d-18
31750   INTEGER, PARAMETER :: pw=2
31751   REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
31752   REAL :: ubb, vbb, uwb, dupb, dumb
31753   REAL, DIMENSION(its:ite, kts:kte) :: vflux
31754   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
31755   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
31756   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb
31757   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
31758   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
31759   INTEGER :: horz_order
31760   INTEGER :: vert_order
31761   LOGICAL :: degrade_xs, degrade_ys
31762   LOGICAL :: degrade_xe, degrade_ye
31763   INTEGER :: jp1, jp0, jtmp
31764 ! definition of flux operators, 3rd, 4th, 5th or 6th order
31765   REAL :: flux3, flux4, flux5, flux6
31766   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
31767   REAL :: velb
31768   LOGICAL :: specified
31769   INTEGER :: branch
31770   INTEGER :: ad_from
31771   INTEGER :: ad_to
31772   INTEGER :: ad_from0
31773   INTEGER :: ad_to0
31774   INTEGER :: ad_from1
31775   INTEGER :: ad_to1
31776   INTEGER :: ad_from2
31777   INTEGER :: ad_to2
31778   INTEGER :: ad_from3
31779   INTEGER :: ad_to3
31780   INTEGER :: ad_from4
31781   INTEGER :: ad_to4
31782   INTEGER :: ad_from5
31783   INTEGER :: ad_to5
31784   INTEGER :: ad_from6
31785   INTEGER :: ad_to6
31786   INTEGER :: ad_from7
31787   INTEGER :: ad_to7
31788   INTEGER :: ad_from8
31789   INTEGER :: ad_to8
31790   INTEGER :: ad_from9
31791   INTEGER :: ad_to9
31792   INTEGER :: ad_from10
31793   INTEGER :: ad_to10
31794   INTEGER :: ad_from11
31795   INTEGER :: ad_to11
31796   INTEGER :: ad_from12
31797   INTEGER :: ad_to12
31798   INTEGER :: ad_from13
31799   INTEGER :: ad_to13
31800   INTEGER :: ad_from14
31801   INTEGER :: ad_to14
31802   INTEGER :: temp3
31803   INTEGER :: temp29
31804   REAL :: temp2
31805   REAL :: temp28
31806   DOUBLE PRECISION :: temp1
31807   REAL :: temp27
31808   DOUBLE PRECISION :: temp0
31809   DOUBLE PRECISION :: temp13b
31810   REAL :: temp26
31811   REAL :: temp21b
31812   INTEGER :: temp25
31813   REAL :: temp24
31814   DOUBLE PRECISION :: temp23
31815   DOUBLE PRECISION :: temp22
31816   DOUBLE PRECISION :: temp21
31817   REAL :: temp20
31818   REAL :: temp13b5
31819   REAL :: temp13b4
31820   DOUBLE PRECISION :: temp24b
31821   REAL :: temp13b3
31822   REAL :: temp32b
31823   REAL :: temp13b2
31824   REAL :: temp13b1
31825   DOUBLE PRECISION :: temp13b0
31826   REAL :: tempb4
31827   REAL :: temp21b10
31828   REAL :: tempb3
31829   REAL :: temp28b1
31830   REAL :: tempb2
31831   REAL :: temp28b0
31832   REAL :: tempb1
31833   REAL :: tempb0
31834   INTRINSIC MAX
31835   INTRINSIC SIGN
31836   REAL :: temp2b5
31837   REAL :: temp2b4
31838   REAL :: temp19
31839   REAL :: temp2b3
31840   INTEGER :: temp18
31841   REAL :: temp2b2
31842   REAL :: temp17
31843   REAL :: temp2b1
31844   REAL :: temp16
31845   DOUBLE PRECISION :: temp2b0
31846   REAL :: temp6b
31847   REAL :: temp15
31848   INTEGER :: temp14
31849   REAL :: temp13
31850   REAL :: temp21b9
31851   DOUBLE PRECISION :: temp12
31852   REAL :: temp21b8
31853   DOUBLE PRECISION :: temp11
31854   REAL :: temp21b7
31855   DOUBLE PRECISION :: temp10
31856   REAL :: temp21b6
31857   REAL :: temp21b5
31858   REAL :: temp21b4
31859   REAL :: temp21b3
31860   REAL :: temp21b2
31861   REAL :: temp21b1
31862   REAL :: temp21b0
31863   REAL :: tempb
31864   REAL :: temp24b5
31865   DOUBLE PRECISION :: temp2b
31866   REAL :: temp24b4
31867   REAL :: temp24b3
31868   REAL :: temp24b2
31869   REAL :: temp24b1
31870   DOUBLE PRECISION :: temp24b0
31871   REAL :: temp17b3
31872   REAL :: temp17b2
31873   REAL :: temp17b1
31874   REAL :: temp17b0
31875   REAL :: temp31
31876   REAL :: temp30
31877   REAL :: temp17b
31878   INTRINSIC MIN
31879   REAL :: temp28b
31880   REAL :: temp6b3
31881   REAL :: temp6b2
31882   REAL :: temp6b1
31883   DOUBLE PRECISION :: temp
31884   REAL :: temp6b0
31885   REAL :: temp32b1
31886   REAL :: temp9
31887   REAL :: temp10b4
31888   REAL :: temp32b0
31889   REAL :: temp8
31890   REAL :: temp10b3
31891   INTEGER :: temp7
31892   REAL :: temp10b
31893   REAL :: temp10b2
31894   REAL :: temp6
31895   REAL :: temp10b1
31896   REAL :: temp5
31897   REAL :: temp10b0
31898   REAL :: temp4
31899   specified = .false.
31900   IF (config_flags%specified .OR. config_flags%nested) specified = &
31901 &      .true.
31902   IF (kte .GT. kde - 1) THEN
31903     ktf = kde - 1
31904   ELSE
31905     ktf = kte
31906   END IF
31907 !  here is the choice of flux operators
31908 !   horizontal_order_test : IF( horz_order == 6 ) THEN
31909 !   ELSE IF( horz_order == 5 ) THEN
31910 !  5th order horizontal flux calculation
31911 !  This code is EXACTLY the same as the 6th order code
31912 !  EXCEPT the 5th order and 3rd operators are used in
31913 !  place of the 6th and 4th order operators
31914 !  determine boundary mods for flux operators
31915 !  We degrade the flux operators from 3rd/4th order
31916 !   to second order one gridpoint in from the boundaries for
31917 !   all boundary conditions except periodic and symmetry - these
31918 !   conditions have boundary zone data fill for correct application
31919 !   of the higher order flux stencils
31920   degrade_xs = .true.
31921   degrade_xe = .true.
31922   degrade_ys = .true.
31923   degrade_ye = .true.
31924   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
31925 &      .GT. ids + 3) degrade_xs = .false.
31926   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
31927 &      .LT. ide - 3) degrade_xe = .false.
31928   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
31929 &      .GT. jds + 3) degrade_ys = .false.
31930   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
31931 &      .LT. jde - 3) degrade_ye = .false.
31932 !--------------- y - advection first
31933   i_start = its
31934   IF (ite .GT. ide - 1) THEN
31935     i_end = ide - 1
31936   ELSE
31937     i_end = ite
31938   END IF
31939   j_start = jts
31940   j_end = jte
31941 !  higher order flux has a 5 or 7 point stencil, so compute
31942 !  bounds so we can switch to second order flux close to the boundary
31943   j_start_f = j_start
31944   j_end_f = j_end + 1
31945   IF (degrade_ys) THEN
31946     IF (jts .LT. jds + 1) THEN
31947       j_start = jds + 1
31948     ELSE
31949       j_start = jts
31950     END IF
31951     j_start_f = jds + 3
31952   END IF
31953   IF (degrade_ye) THEN
31954     IF (jte .GT. jde - 1) THEN
31955       j_end = jde - 1
31956     ELSE
31957       j_end = jte
31958     END IF
31959     j_end_f = jde - 2
31960   END IF
31961 !  compute fluxes, 5th or 6th order
31962   jp1 = 2
31963   jp0 = 1
31964   ad_from7 = j_start
31965 j_loop_y_flux_5:DO j=ad_from7,j_end+1
31966     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
31967       DO k=kts,ktf
31968         ad_from = i_start
31969         DO i=ad_from,i_end
31970           vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
31971           IF (vel*sign(1,time_step) .GE. 0.0) THEN
31972             CALL PUSHREAL8(qip2)
31973             qip2 = v(i, k, j+1)
31974             CALL PUSHREAL8(qip1)
31975             qip1 = v(i, k, j)
31976             CALL PUSHREAL8(qi)
31977             qi = v(i, k, j-1)
31978             CALL PUSHREAL8(qim1)
31979             qim1 = v(i, k, j-2)
31980             CALL PUSHREAL8(qim2)
31981             qim2 = v(i, k, j-3)
31982             CALL PUSHCONTROL1B(0)
31983           ELSE
31984             CALL PUSHREAL8(qip2)
31985             qip2 = v(i, k, j-2)
31986             CALL PUSHREAL8(qip1)
31987             qip1 = v(i, k, j-1)
31988             CALL PUSHREAL8(qi)
31989             qi = v(i, k, j)
31990             CALL PUSHREAL8(qim1)
31991             qim1 = v(i, k, j+1)
31992             CALL PUSHREAL8(qim2)
31993             qim2 = v(i, k, j+2)
31994             CALL PUSHCONTROL1B(1)
31995           END IF
31996           CALL PUSHREAL8(f0)
31997           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
31998           CALL PUSHREAL8(f1)
31999           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
32000           CALL PUSHREAL8(f2)
32001           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
32002           CALL PUSHREAL8(beta0)
32003           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
32004 &            qi)**2
32005           CALL PUSHREAL8(beta1)
32006           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
32007           CALL PUSHREAL8(beta2)
32008           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
32009 &            qi)**2
32010         END DO
32011         CALL PUSHINTEGER4(i - 1)
32012         CALL PUSHINTEGER4(ad_from)
32013       END DO
32014       CALL PUSHCONTROL3B(0)
32015     ELSE IF (j .EQ. jds + 1) THEN
32016 !          fqy( i, k, jp1 ) = vel*flux5(               &
32017 !                  v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
32018 !                  v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
32019 !  we must be close to some boundary where we need to reduce the order of the stencil
32020 !  specified uses upstream normal wind at boundaries
32021 ! 2nd order flux next to south boundary
32022       DO k=kts,ktf
32023         ad_from0 = i_start
32024         DO i=ad_from0,i_end
32025           CALL PUSHREAL8(vb)
32026           vb = v(i, k, j-1)
32027           IF (specified .AND. v(i, k, j) .LT. 0.) THEN
32028             vb = v(i, k, j)
32029             CALL PUSHCONTROL1B(0)
32030           ELSE
32031             CALL PUSHCONTROL1B(1)
32032           END IF
32033         END DO
32034         CALL PUSHINTEGER4(i - 1)
32035         CALL PUSHINTEGER4(ad_from0)
32036       END DO
32037       CALL PUSHCONTROL3B(1)
32038     ELSE IF (j .EQ. jds + 2) THEN
32039 ! third of 4th order flux 2 in from south boundary
32040       DO k=kts,ktf
32041         ad_from1 = i_start
32042         i = i_end + 1
32043         CALL PUSHINTEGER4(i - 1)
32044         CALL PUSHINTEGER4(ad_from1)
32045       END DO
32046       CALL PUSHCONTROL3B(2)
32047     ELSE IF (j .EQ. jde) THEN
32048 ! 2nd order flux next to north boundary
32049       DO k=kts,ktf
32050         ad_from2 = i_start
32051         DO i=ad_from2,i_end
32052           CALL PUSHREAL8(vb)
32053           vb = v(i, k, j)
32054           IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
32055             vb = v(i, k, j-1)
32056             CALL PUSHCONTROL1B(0)
32057           ELSE
32058             CALL PUSHCONTROL1B(1)
32059           END IF
32060         END DO
32061         CALL PUSHINTEGER4(i - 1)
32062         CALL PUSHINTEGER4(ad_from2)
32063       END DO
32064       CALL PUSHCONTROL3B(3)
32065     ELSE IF (j .EQ. jde - 1) THEN
32066 ! 3rd or 4th order flux 2 in from north boundary
32067       DO k=kts,ktf
32068         ad_from3 = i_start
32069         i = i_end + 1
32070         CALL PUSHINTEGER4(i - 1)
32071         CALL PUSHINTEGER4(ad_from3)
32072       END DO
32073       CALL PUSHCONTROL3B(4)
32074     ELSE
32075       CALL PUSHCONTROL3B(5)
32076     END IF
32077 !  y flux-divergence into tendency
32078 ! Comments on polar boundary conditions
32079 ! No advection over the poles means tendencies (held from jds [S. pole]
32080 ! to jde [N pole], i.e., on v grid) must be zero at poles
32081 ! [tendency(jds) and tendency(jde)=0]
32082     IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
32083       DO k=kts,ktf
32084         ad_from4 = i_start
32085         i = i_end + 1
32086         CALL PUSHINTEGER4(i - 1)
32087         CALL PUSHINTEGER4(ad_from4)
32088       END DO
32089       CALL PUSHCONTROL2B(0)
32090     ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
32091 ! If j_end were set to jde in a special if statement apart from
32092 ! degrade_ye, then we would hit the next conditional.  But since
32093 ! we want the tendency to be zero anyway, not looping to jde+1
32094 ! will produce the same effect.
32095       DO k=kts,ktf
32096         ad_from5 = i_start
32097         i = i_end + 1
32098         CALL PUSHINTEGER4(i - 1)
32099         CALL PUSHINTEGER4(ad_from5)
32100       END DO
32101       CALL PUSHCONTROL2B(1)
32102     ELSE IF (j .GT. j_start) THEN
32103 ! Normal code
32104       DO k=kts,ktf
32105         ad_from6 = i_start
32106         i = i_end + 1
32107         CALL PUSHINTEGER4(i - 1)
32108         CALL PUSHINTEGER4(ad_from6)
32109       END DO
32110       CALL PUSHCONTROL2B(2)
32111     ELSE
32112       CALL PUSHCONTROL2B(3)
32113     END IF
32114     jtmp = jp1
32115     CALL PUSHINTEGER4(jp1)
32116     jp1 = jp0
32117     CALL PUSHINTEGER4(jp0)
32118     jp0 = jtmp
32119   END DO j_loop_y_flux_5
32120   CALL PUSHINTEGER4(j - 1)
32121   CALL PUSHINTEGER4(ad_from7)
32122 !  next, x - flux divergence
32123   i_start = its
32124   IF (ite .GT. ide - 1) THEN
32125     i_end = ide - 1
32126   ELSE
32127     i_end = ite
32128   END IF
32129   j_start = jts
32130   j_end = jte
32131 ! Polar boundary conditions are like open or specified
32132   IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
32133 &  THEN
32134     IF (jds + 1 .LT. jts) THEN
32135       j_start = jts
32136     ELSE
32137       j_start = jds + 1
32138     END IF
32139   END IF
32140   IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
32141 &  THEN
32142     IF (jde - 1 .GT. jte) THEN
32143       j_end = jte
32144     ELSE
32145       j_end = jde - 1
32146     END IF
32147   END IF
32148 !  higher order flux has a 5 or 7 point stencil, so compute
32149 !  bounds so we can switch to second order flux close to the boundary
32150   i_start_f = i_start
32151   i_end_f = i_end + 1
32152   IF (degrade_xs) THEN
32153     IF (ids + 1 .LT. its) THEN
32154       i_start = its
32155     ELSE
32156       i_start = ids + 1
32157     END IF
32158     IF (i_start + 2 .GT. ids + 3) THEN
32159       i_start_f = ids + 3
32160     ELSE
32161       i_start_f = i_start + 2
32162     END IF
32163   END IF
32164   IF (degrade_xe) THEN
32165     IF (ide - 2 .GT. ite) THEN
32166       i_end = ite
32167     ELSE
32168       i_end = ide - 2
32169     END IF
32170     i_end_f = ide - 3
32171   END IF
32172   ad_from10 = j_start
32173 !  compute fluxes
32174   DO j=ad_from10,j_end
32175 !  5th or 6th order flux
32176     DO k=kts,ktf
32177       DO i=i_start_f,i_end_f
32178         vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
32179         IF (vel*sign(1,time_step) .GE. 0.0) THEN
32180           CALL PUSHREAL8(qip2)
32181           qip2 = v(i+1, k, j)
32182           CALL PUSHREAL8(qip1)
32183           qip1 = v(i, k, j)
32184           CALL PUSHREAL8(qi)
32185           qi = v(i-1, k, j)
32186           CALL PUSHREAL8(qim1)
32187           qim1 = v(i-2, k, j)
32188           CALL PUSHREAL8(qim2)
32189           qim2 = v(i-3, k, j)
32190           CALL PUSHCONTROL1B(0)
32191         ELSE
32192           CALL PUSHREAL8(qip2)
32193           qip2 = v(i-2, k, j)
32194           CALL PUSHREAL8(qip1)
32195           qip1 = v(i-1, k, j)
32196           CALL PUSHREAL8(qi)
32197           qi = v(i, k, j)
32198           CALL PUSHREAL8(qim1)
32199           qim1 = v(i+1, k, j)
32200           CALL PUSHREAL8(qim2)
32201           qim2 = v(i+2, k, j)
32202           CALL PUSHCONTROL1B(1)
32203         END IF
32204         CALL PUSHREAL8(f0)
32205         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
32206         CALL PUSHREAL8(f1)
32207         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
32208         CALL PUSHREAL8(f2)
32209         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
32210         CALL PUSHREAL8(beta0)
32211         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
32212 &          )**2
32213         CALL PUSHREAL8(beta1)
32214         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
32215         CALL PUSHREAL8(beta2)
32216         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
32217 &          )**2
32218       END DO
32219     END DO
32220 !          fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
32221 !                                         v(i-1,k,j), v(i  ,k,j),  &
32222 !                                         v(i+1,k,j), v(i+2,k,j),  &
32223 !                                         vel                     )
32224 !  lower order fluxes close to boundaries (if not periodic or symmetric)
32225     IF (degrade_xs) THEN
32226       ad_from8 = i_start
32227       DO i=ad_from8,i_start_f-1
32228         IF (i .EQ. ids + 1) THEN
32229           CALL PUSHCONTROL1B(0)
32230         ELSE
32231           CALL PUSHCONTROL1B(1)
32232         END IF
32233         IF (i .EQ. ids + 2) THEN
32234           CALL PUSHCONTROL1B(1)
32235         ELSE
32236           CALL PUSHCONTROL1B(0)
32237         END IF
32238       END DO
32239       CALL PUSHINTEGER4(ad_from8)
32240       CALL PUSHCONTROL1B(0)
32241     ELSE
32242       CALL PUSHCONTROL1B(1)
32243     END IF
32244     IF (degrade_xe) THEN
32245       DO i=i_end_f+1,i_end+1
32246         IF (i .EQ. ide - 1) THEN
32247           CALL PUSHCONTROL1B(0)
32248         ELSE
32249           CALL PUSHCONTROL1B(1)
32250         END IF
32251         IF (i .EQ. ide - 2) THEN
32252           CALL PUSHCONTROL1B(1)
32253         ELSE
32254           CALL PUSHCONTROL1B(0)
32255         END IF
32256       END DO
32257       CALL PUSHINTEGER4(i - 1)
32258       CALL PUSHCONTROL1B(1)
32259     ELSE
32260       CALL PUSHCONTROL1B(0)
32261     END IF
32262 !  x flux-divergence into tendency
32263     DO k=kts,ktf
32264       ad_from9 = i_start
32265       i = i_end + 1
32266       CALL PUSHINTEGER4(i - 1)
32267       CALL PUSHINTEGER4(ad_from9)
32268     END DO
32269   END DO
32270   CALL PUSHINTEGER4(j - 1)
32271   CALL PUSHINTEGER4(ad_from10)
32272 !  Comments on polar boundary condition
32273 !  Force tendency=0 at NP and SP
32274 !  We keep setting this everywhere, but it can't hurt...
32275   IF (config_flags%polar .AND. jts .EQ. jds) THEN
32276     CALL PUSHCONTROL1B(0)
32277   ELSE
32278     CALL PUSHCONTROL1B(1)
32279   END IF
32280   IF (config_flags%polar .AND. jte .EQ. jde) THEN
32281     CALL PUSHCONTROL1B(0)
32282   ELSE
32283     CALL PUSHCONTROL1B(1)
32284   END IF
32285 !  radiative lateral boundary condition in y for normal velocity (v)
32286   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
32287     i_start = its
32288     IF (ite .GT. ide - 1) THEN
32289       CALL PUSHINTEGER4(i_end)
32290       i_end = ide - 1
32291       CALL PUSHCONTROL1B(0)
32292     ELSE
32293       CALL PUSHINTEGER4(i_end)
32294       i_end = ite
32295       CALL PUSHCONTROL1B(1)
32296     END IF
32297     ad_from11 = i_start
32298     DO i=ad_from11,i_end
32299       DO k=kts,ktf
32300         IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN
32301           CALL PUSHREAL8(vb)
32302           vb = 0.
32303           CALL PUSHCONTROL1B(0)
32304         ELSE
32305           CALL PUSHREAL8(vb)
32306           vb = rv(i, k, jts) - cb*mut(i, jts)
32307           CALL PUSHCONTROL1B(1)
32308         END IF
32309       END DO
32310     END DO
32311     CALL PUSHINTEGER4(i - 1)
32312     CALL PUSHINTEGER4(ad_from11)
32313     CALL PUSHCONTROL1B(0)
32314   ELSE
32315     CALL PUSHCONTROL1B(1)
32316   END IF
32317   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
32318     i_start = its
32319     IF (ite .GT. ide - 1) THEN
32320       CALL PUSHINTEGER4(i_end)
32321       i_end = ide - 1
32322       CALL PUSHCONTROL1B(0)
32323     ELSE
32324       CALL PUSHINTEGER4(i_end)
32325       i_end = ite
32326       CALL PUSHCONTROL1B(1)
32327     END IF
32328     ad_from12 = i_start
32329     DO i=ad_from12,i_end
32330       DO k=kts,ktf
32331         IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN
32332           CALL PUSHREAL8(vb)
32333           vb = 0.
32334           CALL PUSHCONTROL1B(0)
32335         ELSE
32336           CALL PUSHREAL8(vb)
32337           vb = rv(i, k, jte) + cb*mut(i, jte-1)
32338           CALL PUSHCONTROL1B(1)
32339         END IF
32340       END DO
32341     END DO
32342     CALL PUSHINTEGER4(i - 1)
32343     CALL PUSHINTEGER4(ad_from12)
32344     CALL PUSHCONTROL1B(1)
32345   ELSE
32346     CALL PUSHCONTROL1B(0)
32347   END IF
32348 !  pick up the rest of the horizontal radiation boundary conditions.
32349 !  (these are the computations that don't require 'cb'.
32350 !  first, set to index ranges
32351   j_start = jts
32352   IF (jte .GT. jde) THEN
32353     j_end = jde
32354   ELSE
32355     j_end = jte
32356   END IF
32357   jmin = jds
32358   jmax = jde - 1
32359   IF (config_flags%open_ys) THEN
32360     IF (jds + 1 .LT. jts) THEN
32361       j_start = jts
32362     ELSE
32363       j_start = jds + 1
32364     END IF
32365     jmin = jds
32366   END IF
32367   IF (config_flags%open_ye) THEN
32368     IF (jte .GT. jde - 1) THEN
32369       j_end = jde - 1
32370     ELSE
32371       j_end = jte
32372     END IF
32373     jmax = jde - 1
32374   END IF
32375 !  compute x (u) conditions for v, w, or scalar
32376   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
32377     ad_from13 = j_start
32378     DO j=ad_from13,j_end
32379       CALL PUSHREAL8(mrdx)
32380 ! ADT eqn 45, 1st term on RHS
32381       mrdx = msfvy(its, j)*rdx
32382       IF (jmax .GT. j) THEN
32383         CALL PUSHINTEGER4(jp)
32384         jp = j
32385         CALL PUSHCONTROL1B(0)
32386       ELSE
32387         CALL PUSHINTEGER4(jp)
32388         jp = jmax
32389         CALL PUSHCONTROL1B(1)
32390       END IF
32391       IF (jmin .LT. j - 1) THEN
32392         CALL PUSHINTEGER4(jm)
32393         jm = j - 1
32394         CALL PUSHCONTROL1B(0)
32395       ELSE
32396         CALL PUSHINTEGER4(jm)
32397         jm = jmin
32398         CALL PUSHCONTROL1B(1)
32399       END IF
32400       DO k=kts,ktf
32401         uw = 0.5*(ru(its, k, jp)+ru(its, k, jm))
32402         IF (uw .GT. 0.) THEN
32403           CALL PUSHREAL8(ub)
32404           ub = 0.
32405           CALL PUSHCONTROL1B(0)
32406         ELSE
32407           CALL PUSHREAL8(ub)
32408           ub = uw
32409           CALL PUSHCONTROL1B(1)
32410         END IF
32411       END DO
32412     END DO
32413     CALL PUSHINTEGER4(j - 1)
32414     CALL PUSHINTEGER4(ad_from13)
32415     CALL PUSHCONTROL1B(0)
32416   ELSE
32417     CALL PUSHCONTROL1B(1)
32418   END IF
32419   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
32420     ad_from14 = j_start
32421     DO j=ad_from14,j_end
32422       CALL PUSHREAL8(mrdx)
32423 ! ADT eqn 45, 1st term on RHS
32424       mrdx = msfvy(ite-1, j)*rdx
32425       IF (jmax .GT. j) THEN
32426         CALL PUSHINTEGER4(jp)
32427         jp = j
32428         CALL PUSHCONTROL1B(0)
32429       ELSE
32430         CALL PUSHINTEGER4(jp)
32431         jp = jmax
32432         CALL PUSHCONTROL1B(1)
32433       END IF
32434       IF (jmin .LT. j - 1) THEN
32435         CALL PUSHINTEGER4(jm)
32436         jm = j - 1
32437         CALL PUSHCONTROL1B(0)
32438       ELSE
32439         CALL PUSHINTEGER4(jm)
32440         jm = jmin
32441         CALL PUSHCONTROL1B(1)
32442       END IF
32443       DO k=kts,ktf
32444         uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm))
32445         IF (uw .LT. 0.) THEN
32446           CALL PUSHREAL8(ub)
32447           ub = 0.
32448           CALL PUSHCONTROL1B(0)
32449         ELSE
32450           CALL PUSHREAL8(ub)
32451           ub = uw
32452           CALL PUSHCONTROL1B(1)
32453         END IF
32454       END DO
32455     END DO
32456     CALL PUSHINTEGER4(j - 1)
32457     CALL PUSHINTEGER4(ad_from14)
32458     CALL PUSHCONTROL1B(1)
32459   ELSE
32460     CALL PUSHCONTROL1B(0)
32461   END IF
32462 !-------------------- vertical advection
32463 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
32464 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
32465 !     We therefore need to make a correction for advect_v
32466 !     since 'my' (map scale factor in y direction) isn't a function of z,
32467 !     we can do this using *(my/mx) (see eqn. 45 for example)
32468   i_start = its
32469   IF (ite .GT. ide - 1) THEN
32470     CALL PUSHINTEGER4(i_end)
32471     i_end = ide - 1
32472     CALL PUSHCONTROL1B(0)
32473   ELSE
32474     CALL PUSHINTEGER4(i_end)
32475     i_end = ite
32476     CALL PUSHCONTROL1B(1)
32477   END IF
32478   j_start = jts
32479   j_end = jte
32480 ! Polar boundary conditions are like open or specified
32481 ! We don't want to calculate vertical v tendencies at the N or S pole
32482   IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
32483 &  THEN
32484     IF (jds + 1 .LT. jts) THEN
32485       j_start = jts
32486     ELSE
32487       j_start = jds + 1
32488     END IF
32489   END IF
32490   IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
32491 &  THEN
32492     IF (jde - 1 .GT. jte) THEN
32493       j_end = jte
32494     ELSE
32495       j_end = jde - 1
32496     END IF
32497   END IF
32498 !    vert_order_test : IF (vert_order == 6) THEN
32499 !   ELSE IF (vert_order == 5) THEN
32500   DO j=j_start,j_end
32501     DO k=kts+3,ktf-2
32502       DO i=i_start,i_end
32503         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
32504         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
32505           CALL PUSHREAL8(qip2)
32506           qip2 = v(i, k+1, j)
32507           CALL PUSHREAL8(qip1)
32508           qip1 = v(i, k, j)
32509           CALL PUSHREAL8(qi)
32510           qi = v(i, k-1, j)
32511           CALL PUSHREAL8(qim1)
32512           qim1 = v(i, k-2, j)
32513           CALL PUSHREAL8(qim2)
32514           qim2 = v(i, k-3, j)
32515           CALL PUSHCONTROL1B(0)
32516         ELSE
32517           CALL PUSHREAL8(qip2)
32518           qip2 = v(i, k-2, j)
32519           CALL PUSHREAL8(qip1)
32520           qip1 = v(i, k-1, j)
32521           CALL PUSHREAL8(qi)
32522           qi = v(i, k, j)
32523           CALL PUSHREAL8(qim1)
32524           qim1 = v(i, k+1, j)
32525           CALL PUSHREAL8(qim2)
32526           qim2 = v(i, k+2, j)
32527           CALL PUSHCONTROL1B(1)
32528         END IF
32529         CALL PUSHREAL8(f0)
32530         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
32531         CALL PUSHREAL8(f1)
32532         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
32533         CALL PUSHREAL8(f2)
32534         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
32535         CALL PUSHREAL8(beta0)
32536         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
32537 &          )**2
32538         CALL PUSHREAL8(beta1)
32539         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
32540         CALL PUSHREAL8(beta2)
32541         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
32542 &          )**2
32543       END DO
32544     END DO
32545     CALL PUSHINTEGER4(k)
32546   END DO
32547   vfluxb = 0.0
32548   DO j=j_end,j_start,-1
32549     DO k=ktf,kts,-1
32550       DO i=i_end,i_start,-1
32551         temp32b1 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j))
32552         vfluxb(i, k+1) = vfluxb(i, k+1) + temp32b1
32553         vfluxb(i, k) = vfluxb(i, k) - temp32b1
32554       END DO
32555     END DO
32556     CALL POPINTEGER4(k)
32557     DO i=i_end,i_start,-1
32558       k = ktf
32559       temp32b = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, k)
32560       temp32b0 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
32561       romb(i, k, j) = romb(i, k, j) + temp32b
32562       romb(i, k, j-1) = romb(i, k, j-1) + temp32b
32563       vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp32b0
32564       vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp32b0
32565       vfluxb(i, k) = 0.0
32566       k = ktf - 1
32567       vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
32568       temp28 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, j)&
32569 &        )
32570       temp31 = SIGN(1., -vel)
32571       temp30 = temp31/12.0
32572       temp29 = SIGN(1, time_step)
32573       temp28b = vel*vfluxb(i, k)
32574       temp28b0 = temp28b/12.0
32575       temp28b1 = temp29*temp30*temp28b
32576       velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))/&
32577 &        12.0+temp29*(temp30*temp28))*vfluxb(i, k)
32578       vb0(i, k, j) = vb0(i, k, j) + 7.*temp28b0 - 3.*temp28b1
32579       vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp28b1 + 7.*temp28b0
32580       vb0(i, k+1, j) = vb0(i, k+1, j) + temp28b1 - temp28b0
32581       vb0(i, k-2, j) = vb0(i, k-2, j) - temp28b1 - temp28b0
32582       vfluxb(i, k) = 0.0
32583       romb(i, k, j) = romb(i, k, j) + 0.5*velb
32584       romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
32585       k = kts + 2
32586       vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
32587       temp24 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, j)&
32588 &        )
32589       temp27 = SIGN(1., -vel)
32590       temp26 = temp27/12.0
32591       temp25 = SIGN(1, time_step)
32592       temp24b1 = vel*vfluxb(i, k)
32593       temp24b2 = temp24b1/12.0
32594       temp24b3 = temp25*temp26*temp24b1
32595       velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))/&
32596 &        12.0+temp25*(temp26*temp24))*vfluxb(i, k)
32597       vb0(i, k, j) = vb0(i, k, j) + 7.*temp24b2 - 3.*temp24b3
32598       vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp24b3 + 7.*temp24b2
32599       vb0(i, k+1, j) = vb0(i, k+1, j) + temp24b3 - temp24b2
32600       vb0(i, k-2, j) = vb0(i, k-2, j) - temp24b3 - temp24b2
32601       vfluxb(i, k) = 0.0
32602       romb(i, k, j) = romb(i, k, j) + 0.5*velb
32603       romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
32604       k = kts + 1
32605       temp24b4 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, k&
32606 &        )
32607       temp24b5 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k)
32608       romb(i, k, j) = romb(i, k, j) + temp24b4
32609       romb(i, k, j-1) = romb(i, k, j-1) + temp24b4
32610       vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp24b5
32611       vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp24b5
32612       vfluxb(i, k) = 0.0
32613     END DO
32614     DO k=ktf-2,kts+3,-1
32615       DO i=i_end,i_start,-1
32616         wi0 = gi0/(eps+beta0)**pw
32617         wi1 = gi1/(eps+beta1)**pw
32618         wi2 = gi2/(eps+beta2)**pw
32619         sumwk = wi0 + wi1 + wi2
32620         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
32621         temp24b = vel*vfluxb(i, k)/sumwk
32622         temp24b0 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk
32623         f0b = wi0*temp24b
32624         f1b = wi1*temp24b
32625         f2b = wi2*temp24b
32626         velb = temp24b0
32627         sumwkb = -(vel*temp24b0/sumwk)
32628         wi0b = sumwkb + f0*temp24b
32629         wi1b = sumwkb + f1*temp24b
32630         wi2b = sumwkb + f2*temp24b
32631         vfluxb(i, k) = 0.0
32632         temp23 = (eps+beta2)**pw
32633         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
32634 &            )) THEN
32635           beta2b = 0.0
32636         ELSE
32637           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp23**2)
32638         END IF
32639         temp22 = (eps+beta1)**pw
32640         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
32641 &            )) THEN
32642           beta1b = 0.0
32643         ELSE
32644           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp22**2)
32645         END IF
32646         temp21 = (eps+beta0)**pw
32647         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
32648 &            )) THEN
32649           beta0b = 0.0
32650         ELSE
32651           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp21**2)
32652         END IF
32653         CALL POPREAL8(beta2)
32654         temp21b5 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
32655         temp21b6 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
32656         qip2b = temp21b6 - f2b/6. + temp21b5
32657         CALL POPREAL8(beta1)
32658         temp21b7 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
32659         temp21b10 = 2*(qim1-qip1)*beta1b/4.
32660         qip1b = temp21b7 - temp21b10 + f1b/3. + 5.*f2b/6. - 4.*temp21b6 &
32661 &          - 2.*temp21b5
32662         CALL POPREAL8(beta0)
32663         temp21b9 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
32664         temp21b8 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
32665         qib = f2b/3. - 2.*temp21b7 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
32666 &          temp21b8 + temp21b9 + 3.*temp21b6 + temp21b5
32667         qim1b = temp21b10 - 4.*temp21b8 - 7.*f0b/6. - f1b/6. - 2.*&
32668 &          temp21b9 + temp21b7
32669         qim2b = f0b/3. + temp21b8 + temp21b9
32670         CALL POPREAL8(f2)
32671         CALL POPREAL8(f1)
32672         CALL POPREAL8(f0)
32673         CALL POPCONTROL1B(branch)
32674         IF (branch .EQ. 0) THEN
32675           CALL POPREAL8(qim2)
32676           vb0(i, k-3, j) = vb0(i, k-3, j) + qim2b
32677           CALL POPREAL8(qim1)
32678           vb0(i, k-2, j) = vb0(i, k-2, j) + qim1b
32679           CALL POPREAL8(qi)
32680           vb0(i, k-1, j) = vb0(i, k-1, j) + qib
32681           CALL POPREAL8(qip1)
32682           vb0(i, k, j) = vb0(i, k, j) + qip1b
32683           CALL POPREAL8(qip2)
32684           vb0(i, k+1, j) = vb0(i, k+1, j) + qip2b
32685         ELSE
32686           CALL POPREAL8(qim2)
32687           vb0(i, k+2, j) = vb0(i, k+2, j) + qim2b
32688           CALL POPREAL8(qim1)
32689           vb0(i, k+1, j) = vb0(i, k+1, j) + qim1b
32690           CALL POPREAL8(qi)
32691           vb0(i, k, j) = vb0(i, k, j) + qib
32692           CALL POPREAL8(qip1)
32693           vb0(i, k-1, j) = vb0(i, k-1, j) + qip1b
32694           CALL POPREAL8(qip2)
32695           vb0(i, k-2, j) = vb0(i, k-2, j) + qip2b
32696         END IF
32697         romb(i, k, j) = romb(i, k, j) + 0.5*velb
32698         romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb
32699       END DO
32700     END DO
32701   END DO
32702   CALL POPCONTROL1B(branch)
32703   IF (branch .EQ. 0) THEN
32704     CALL POPINTEGER4(i_end)
32705   ELSE
32706     CALL POPINTEGER4(i_end)
32707   END IF
32708   CALL POPCONTROL1B(branch)
32709   IF (branch .NE. 0) THEN
32710     CALL POPINTEGER4(ad_from14)
32711     CALL POPINTEGER4(ad_to14)
32712     DO j=ad_to14,ad_from14,-1
32713       DO k=ktf,kts,-1
32714         dum = ru(ite, k, jm) - ru(ite-1, k, jm)
32715         dup = ru(ite, k, jp) - ru(ite-1, k, jp)
32716         temp21b3 = -(mrdx*tendencyb(ite-1, k, j))
32717         temp21b4 = 0.5*v(ite-1, k, j)*temp21b3
32718         ubb = (v_old(ite-1, k, j)-v_old(ite-2, k, j))*temp21b3
32719         v_oldb(ite-1, k, j) = v_oldb(ite-1, k, j) + ub*temp21b3
32720         v_oldb(ite-2, k, j) = v_oldb(ite-2, k, j) - ub*temp21b3
32721         vb0(ite-1, k, j) = vb0(ite-1, k, j) + 0.5*(dup+dum)*temp21b3
32722         dupb = temp21b4
32723         dumb = temp21b4
32724         rub(ite, k, jm) = rub(ite, k, jm) + dumb
32725         rub(ite-1, k, jm) = rub(ite-1, k, jm) - dumb
32726         rub(ite, k, jp) = rub(ite, k, jp) + dupb
32727         rub(ite-1, k, jp) = rub(ite-1, k, jp) - dupb
32728         CALL POPCONTROL1B(branch)
32729         IF (branch .EQ. 0) THEN
32730           CALL POPREAL8(ub)
32731           uwb = 0.0
32732         ELSE
32733           CALL POPREAL8(ub)
32734           uwb = ubb
32735         END IF
32736         rub(ite, k, jp) = rub(ite, k, jp) + 0.5*uwb
32737         rub(ite, k, jm) = rub(ite, k, jm) + 0.5*uwb
32738       END DO
32739       CALL POPCONTROL1B(branch)
32740       IF (branch .EQ. 0) THEN
32741         CALL POPINTEGER4(jm)
32742       ELSE
32743         CALL POPINTEGER4(jm)
32744       END IF
32745       CALL POPCONTROL1B(branch)
32746       IF (branch .EQ. 0) THEN
32747         CALL POPINTEGER4(jp)
32748       ELSE
32749         CALL POPINTEGER4(jp)
32750       END IF
32751       CALL POPREAL8(mrdx)
32752     END DO
32753   END IF
32754   CALL POPCONTROL1B(branch)
32755   IF (branch .EQ. 0) THEN
32756     CALL POPINTEGER4(ad_from13)
32757     CALL POPINTEGER4(ad_to13)
32758     DO j=ad_to13,ad_from13,-1
32759       DO k=ktf,kts,-1
32760         dum = ru(its+1, k, jm) - ru(its, k, jm)
32761         dup = ru(its+1, k, jp) - ru(its, k, jp)
32762         temp21b1 = -(mrdx*tendencyb(its, k, j))
32763         temp21b2 = 0.5*v(its, k, j)*temp21b1
32764         ubb = (v_old(its+1, k, j)-v_old(its, k, j))*temp21b1
32765         v_oldb(its+1, k, j) = v_oldb(its+1, k, j) + ub*temp21b1
32766         v_oldb(its, k, j) = v_oldb(its, k, j) - ub*temp21b1
32767         vb0(its, k, j) = vb0(its, k, j) + 0.5*(dup+dum)*temp21b1
32768         dupb = temp21b2
32769         dumb = temp21b2
32770         rub(its+1, k, jm) = rub(its+1, k, jm) + dumb
32771         rub(its, k, jm) = rub(its, k, jm) - dumb
32772         rub(its+1, k, jp) = rub(its+1, k, jp) + dupb
32773         rub(its, k, jp) = rub(its, k, jp) - dupb
32774         CALL POPCONTROL1B(branch)
32775         IF (branch .EQ. 0) THEN
32776           CALL POPREAL8(ub)
32777           uwb = 0.0
32778         ELSE
32779           CALL POPREAL8(ub)
32780           uwb = ubb
32781         END IF
32782         rub(its, k, jp) = rub(its, k, jp) + 0.5*uwb
32783         rub(its, k, jm) = rub(its, k, jm) + 0.5*uwb
32784       END DO
32785       CALL POPCONTROL1B(branch)
32786       IF (branch .EQ. 0) THEN
32787         CALL POPINTEGER4(jm)
32788       ELSE
32789         CALL POPINTEGER4(jm)
32790       END IF
32791       CALL POPCONTROL1B(branch)
32792       IF (branch .EQ. 0) THEN
32793         CALL POPINTEGER4(jp)
32794       ELSE
32795         CALL POPINTEGER4(jp)
32796       END IF
32797       CALL POPREAL8(mrdx)
32798     END DO
32799   END IF
32800   CALL POPCONTROL1B(branch)
32801   IF (branch .NE. 0) THEN
32802     CALL POPINTEGER4(ad_from12)
32803     CALL POPINTEGER4(ad_to12)
32804     DO i=ad_to12,ad_from12,-1
32805       DO k=ktf,kts,-1
32806         temp21b0 = -(rdy*tendencyb(i, k, jte))
32807         vbb = (v_old(i, k, jte)-v_old(i, k, jte-1))*temp21b0
32808         v_oldb(i, k, jte) = v_oldb(i, k, jte) + vb*temp21b0
32809         v_oldb(i, k, jte-1) = v_oldb(i, k, jte-1) - vb*temp21b0
32810         CALL POPCONTROL1B(branch)
32811         IF (branch .EQ. 0) THEN
32812           CALL POPREAL8(vb)
32813         ELSE
32814           CALL POPREAL8(vb)
32815           rvb(i, k, jte) = rvb(i, k, jte) + vbb
32816           mutb(i, jte-1) = mutb(i, jte-1) + cb*vbb
32817         END IF
32818       END DO
32819     END DO
32820     CALL POPCONTROL1B(branch)
32821     IF (branch .EQ. 0) THEN
32822       CALL POPINTEGER4(i_end)
32823     ELSE
32824       CALL POPINTEGER4(i_end)
32825     END IF
32826   END IF
32827   CALL POPCONTROL1B(branch)
32828   IF (branch .EQ. 0) THEN
32829     CALL POPINTEGER4(ad_from11)
32830     CALL POPINTEGER4(ad_to11)
32831     DO i=ad_to11,ad_from11,-1
32832       DO k=ktf,kts,-1
32833         temp21b = -(rdy*tendencyb(i, k, jts))
32834         vbb = (v_old(i, k, jts+1)-v_old(i, k, jts))*temp21b
32835         v_oldb(i, k, jts+1) = v_oldb(i, k, jts+1) + vb*temp21b
32836         v_oldb(i, k, jts) = v_oldb(i, k, jts) - vb*temp21b
32837         CALL POPCONTROL1B(branch)
32838         IF (branch .EQ. 0) THEN
32839           CALL POPREAL8(vb)
32840         ELSE
32841           CALL POPREAL8(vb)
32842           rvb(i, k, jts) = rvb(i, k, jts) + vbb
32843           mutb(i, jts) = mutb(i, jts) - cb*vbb
32844         END IF
32845       END DO
32846     END DO
32847     CALL POPCONTROL1B(branch)
32848     IF (branch .EQ. 0) THEN
32849       CALL POPINTEGER4(i_end)
32850     ELSE
32851       CALL POPINTEGER4(i_end)
32852     END IF
32853   END IF
32854   CALL POPCONTROL1B(branch)
32855   IF (branch .EQ. 0) THEN
32856     DO i=ite,its,-1
32857       DO k=ktf,kts,-1
32858         tendencyb(i, k, jte) = 0.0
32859       END DO
32860     END DO
32861   END IF
32862   CALL POPCONTROL1B(branch)
32863   IF (branch .EQ. 0) THEN
32864     DO i=ite,its,-1
32865       DO k=ktf,kts,-1
32866         tendencyb(i, k, jts) = 0.0
32867       END DO
32868     END DO
32869   END IF
32870   fqxb = 0.0
32871   CALL POPINTEGER4(ad_from10)
32872   CALL POPINTEGER4(ad_to10)
32873   DO j=ad_to10,ad_from10,-1
32874     DO k=ktf,kts,-1
32875       CALL POPINTEGER4(ad_from9)
32876       CALL POPINTEGER4(ad_to9)
32877       DO i=ad_to9,ad_from9,-1
32878         mrdx = msfvy(i, j)*rdx
32879         fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
32880         fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
32881       END DO
32882     END DO
32883     CALL POPCONTROL1B(branch)
32884     IF (branch .NE. 0) THEN
32885       CALL POPINTEGER4(ad_to8)
32886       DO i=ad_to8,i_end_f+1,-1
32887         CALL POPCONTROL1B(branch)
32888         IF (branch .NE. 0) THEN
32889           DO k=ktf,kts,-1
32890             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
32891             temp17 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(i-1&
32892 &              , k, j))
32893             temp20 = SIGN(1., vel)
32894             temp19 = temp20/12.0
32895             temp18 = SIGN(1, time_step)
32896             temp17b1 = vel*fqxb(i, k)
32897             temp17b2 = temp17b1/12.0
32898             temp17b3 = temp18*temp19*temp17b1
32899             velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k&
32900 &              , j))/12.0+temp18*(temp19*temp17))*fqxb(i, k)
32901             vb0(i, k, j) = vb0(i, k, j) + 7.*temp17b2 - 3.*temp17b3
32902             vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp17b3 + 7.*temp17b2
32903             vb0(i+1, k, j) = vb0(i+1, k, j) + temp17b3 - temp17b2
32904             vb0(i-2, k, j) = vb0(i-2, k, j) - temp17b3 - temp17b2
32905             fqxb(i, k) = 0.0
32906             rub(i, k, j) = rub(i, k, j) + 0.5*velb
32907             rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
32908           END DO
32909         END IF
32910         CALL POPCONTROL1B(branch)
32911         IF (branch .EQ. 0) THEN
32912           DO k=ktf,kts,-1
32913             temp17b = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i, k)
32914             temp17b0 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*fqxb&
32915 &              (i, k)
32916             rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp17b
32917             rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp17b
32918             vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp17b0
32919             vb0(i_end, k, j) = vb0(i_end, k, j) + temp17b0
32920             fqxb(i, k) = 0.0
32921           END DO
32922         END IF
32923       END DO
32924     END IF
32925     CALL POPCONTROL1B(branch)
32926     IF (branch .EQ. 0) THEN
32927       CALL POPINTEGER4(ad_from8)
32928       DO i=i_start_f-1,ad_from8,-1
32929         CALL POPCONTROL1B(branch)
32930         IF (branch .NE. 0) THEN
32931           DO k=ktf,kts,-1
32932             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
32933             temp13 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(i-1&
32934 &              , k, j))
32935             temp16 = SIGN(1., vel)
32936             temp15 = temp16/12.0
32937             temp14 = SIGN(1, time_step)
32938             temp13b3 = vel*fqxb(i, k)
32939             temp13b4 = temp13b3/12.0
32940             temp13b5 = temp14*temp15*temp13b3
32941             velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k&
32942 &              , j))/12.0+temp14*(temp15*temp13))*fqxb(i, k)
32943             vb0(i, k, j) = vb0(i, k, j) + 7.*temp13b4 - 3.*temp13b5
32944             vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp13b5 + 7.*temp13b4
32945             vb0(i+1, k, j) = vb0(i+1, k, j) + temp13b5 - temp13b4
32946             vb0(i-2, k, j) = vb0(i-2, k, j) - temp13b5 - temp13b4
32947             fqxb(i, k) = 0.0
32948             rub(i, k, j) = rub(i, k, j) + 0.5*velb
32949             rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
32950           END DO
32951         END IF
32952         CALL POPCONTROL1B(branch)
32953         IF (branch .EQ. 0) THEN
32954           DO k=ktf,kts,-1
32955             temp13b1 = 0.25*(v(i, k, j)+v(i-1, k, j))*fqxb(i, k)
32956             temp13b2 = 0.25*(ru(i, k, j)+ru(i, k, j-1))*fqxb(i, k)
32957             rub(i, k, j) = rub(i, k, j) + temp13b1
32958             rub(i, k, j-1) = rub(i, k, j-1) + temp13b1
32959             vb0(i, k, j) = vb0(i, k, j) + temp13b2
32960             vb0(i-1, k, j) = vb0(i-1, k, j) + temp13b2
32961             fqxb(i, k) = 0.0
32962           END DO
32963         END IF
32964       END DO
32965     END IF
32966     DO k=ktf,kts,-1
32967       DO i=i_end_f,i_start_f,-1
32968         wi0 = gi0/(eps+beta0)**pw
32969         wi1 = gi1/(eps+beta1)**pw
32970         wi2 = gi2/(eps+beta2)**pw
32971         sumwk = wi0 + wi1 + wi2
32972         vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
32973         temp13b = vel*fqxb(i, k)/sumwk
32974         temp13b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk
32975         f0b = wi0*temp13b
32976         f1b = wi1*temp13b
32977         f2b = wi2*temp13b
32978         velb = temp13b0
32979         sumwkb = -(vel*temp13b0/sumwk)
32980         wi0b = sumwkb + f0*temp13b
32981         wi1b = sumwkb + f1*temp13b
32982         wi2b = sumwkb + f2*temp13b
32983         fqxb(i, k) = 0.0
32984         temp12 = (eps+beta2)**pw
32985         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
32986 &            )) THEN
32987           beta2b = 0.0
32988         ELSE
32989           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp12**2)
32990         END IF
32991         temp11 = (eps+beta1)**pw
32992         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
32993 &            )) THEN
32994           beta1b = 0.0
32995         ELSE
32996           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp11**2)
32997         END IF
32998         temp10 = (eps+beta0)**pw
32999         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
33000 &            )) THEN
33001           beta0b = 0.0
33002         ELSE
33003           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp10**2)
33004         END IF
33005         CALL POPREAL8(beta2)
33006         temp10b = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
33007         temp10b0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
33008         qip2b = temp10b0 - f2b/6. + temp10b
33009         CALL POPREAL8(beta1)
33010         temp10b1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
33011         temp10b4 = 2*(qim1-qip1)*beta1b/4.
33012         qip1b = temp10b1 - temp10b4 + f1b/3. + 5.*f2b/6. - 4.*temp10b0 -&
33013 &          2.*temp10b
33014         CALL POPREAL8(beta0)
33015         temp10b3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
33016         temp10b2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
33017         qib = f2b/3. - 2.*temp10b1 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
33018 &          temp10b2 + temp10b3 + 3.*temp10b0 + temp10b
33019         qim1b = temp10b4 - 4.*temp10b2 - 7.*f0b/6. - f1b/6. - 2.*&
33020 &          temp10b3 + temp10b1
33021         qim2b = f0b/3. + temp10b2 + temp10b3
33022         CALL POPREAL8(f2)
33023         CALL POPREAL8(f1)
33024         CALL POPREAL8(f0)
33025         CALL POPCONTROL1B(branch)
33026         IF (branch .EQ. 0) THEN
33027           CALL POPREAL8(qim2)
33028           vb0(i-3, k, j) = vb0(i-3, k, j) + qim2b
33029           CALL POPREAL8(qim1)
33030           vb0(i-2, k, j) = vb0(i-2, k, j) + qim1b
33031           CALL POPREAL8(qi)
33032           vb0(i-1, k, j) = vb0(i-1, k, j) + qib
33033           CALL POPREAL8(qip1)
33034           vb0(i, k, j) = vb0(i, k, j) + qip1b
33035           CALL POPREAL8(qip2)
33036           vb0(i+1, k, j) = vb0(i+1, k, j) + qip2b
33037         ELSE
33038           CALL POPREAL8(qim2)
33039           vb0(i+2, k, j) = vb0(i+2, k, j) + qim2b
33040           CALL POPREAL8(qim1)
33041           vb0(i+1, k, j) = vb0(i+1, k, j) + qim1b
33042           CALL POPREAL8(qi)
33043           vb0(i, k, j) = vb0(i, k, j) + qib
33044           CALL POPREAL8(qip1)
33045           vb0(i-1, k, j) = vb0(i-1, k, j) + qip1b
33046           CALL POPREAL8(qip2)
33047           vb0(i-2, k, j) = vb0(i-2, k, j) + qip2b
33048         END IF
33049         rub(i, k, j) = rub(i, k, j) + 0.5*velb
33050         rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb
33051       END DO
33052     END DO
33053   END DO
33054   fqyb = 0.0
33055   CALL POPINTEGER4(ad_from7)
33056   CALL POPINTEGER4(ad_to7)
33057   DO j=ad_to7,ad_from7,-1
33058     CALL POPINTEGER4(jp0)
33059     CALL POPINTEGER4(jp1)
33060     CALL POPCONTROL2B(branch)
33061     IF (branch .LT. 2) THEN
33062       IF (branch .EQ. 0) THEN
33063         DO k=ktf,kts,-1
33064           CALL POPINTEGER4(ad_from4)
33065           CALL POPINTEGER4(ad_to4)
33066           DO i=ad_to4,ad_from4,-1
33067             tendencyb(i, k, j-1) = 0.0
33068           END DO
33069         END DO
33070       ELSE
33071         DO k=ktf,kts,-1
33072           CALL POPINTEGER4(ad_from5)
33073           CALL POPINTEGER4(ad_to5)
33074           DO i=ad_to5,ad_from5,-1
33075             tendencyb(i, k, j-1) = 0.0
33076           END DO
33077         END DO
33078       END IF
33079     ELSE IF (branch .EQ. 2) THEN
33080       DO k=ktf,kts,-1
33081         CALL POPINTEGER4(ad_from6)
33082         CALL POPINTEGER4(ad_to6)
33083         DO i=ad_to6,ad_from6,-1
33084           mrdy = msfvy(i, j-1)*rdy
33085           fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1)
33086           fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1)
33087         END DO
33088       END DO
33089     END IF
33090     CALL POPCONTROL3B(branch)
33091     IF (branch .LT. 3) THEN
33092       IF (branch .EQ. 0) THEN
33093         DO k=ktf,kts,-1
33094           CALL POPINTEGER4(ad_from)
33095           CALL POPINTEGER4(ad_to)
33096           DO i=ad_to,ad_from,-1
33097             wi0 = gi0/(eps+beta0)**pw
33098             wi1 = gi1/(eps+beta1)**pw
33099             wi2 = gi2/(eps+beta2)**pw
33100             sumwk = wi0 + wi1 + wi2
33101             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
33102             temp2b = vel*fqyb(i, k, jp1)/sumwk
33103             temp2b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk
33104             f0b = wi0*temp2b
33105             f1b = wi1*temp2b
33106             f2b = wi2*temp2b
33107             velb = temp2b0
33108             sumwkb = -(vel*temp2b0/sumwk)
33109             wi0b = sumwkb + f0*temp2b
33110             wi1b = sumwkb + f1*temp2b
33111             wi2b = sumwkb + f2*temp2b
33112             fqyb(i, k, jp1) = 0.0
33113             temp1 = (eps+beta2)**pw
33114             IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
33115 &                (pw))) THEN
33116               beta2b = 0.0
33117             ELSE
33118               beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2)
33119             END IF
33120             temp0 = (eps+beta1)**pw
33121             IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
33122 &                (pw))) THEN
33123               beta1b = 0.0
33124             ELSE
33125               beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2)
33126             END IF
33127             temp = (eps+beta0)**pw
33128             IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
33129 &                (pw))) THEN
33130               beta0b = 0.0
33131             ELSE
33132               beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2)
33133             END IF
33134             CALL POPREAL8(beta2)
33135             tempb = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
33136             tempb0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
33137             qip2b = tempb0 - f2b/6. + tempb
33138             CALL POPREAL8(beta1)
33139             tempb1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
33140             tempb4 = 2*(qim1-qip1)*beta1b/4.
33141             qip1b = tempb1 - tempb4 + f1b/3. + 5.*f2b/6. - 4.*tempb0 - &
33142 &              2.*tempb
33143             CALL POPREAL8(beta0)
33144             tempb3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
33145             tempb2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
33146             qib = f2b/3. - 2.*tempb1 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
33147 &              tempb2 + tempb3 + 3.*tempb0 + tempb
33148             qim1b = tempb4 - 4.*tempb2 - 7.*f0b/6. - f1b/6. - 2.*tempb3 &
33149 &              + tempb1
33150             qim2b = f0b/3. + tempb2 + tempb3
33151             CALL POPREAL8(f2)
33152             CALL POPREAL8(f1)
33153             CALL POPREAL8(f0)
33154             CALL POPCONTROL1B(branch)
33155             IF (branch .EQ. 0) THEN
33156               CALL POPREAL8(qim2)
33157               vb0(i, k, j-3) = vb0(i, k, j-3) + qim2b
33158               CALL POPREAL8(qim1)
33159               vb0(i, k, j-2) = vb0(i, k, j-2) + qim1b
33160               CALL POPREAL8(qi)
33161               vb0(i, k, j-1) = vb0(i, k, j-1) + qib
33162               CALL POPREAL8(qip1)
33163               vb0(i, k, j) = vb0(i, k, j) + qip1b
33164               CALL POPREAL8(qip2)
33165               vb0(i, k, j+1) = vb0(i, k, j+1) + qip2b
33166             ELSE
33167               CALL POPREAL8(qim2)
33168               vb0(i, k, j+2) = vb0(i, k, j+2) + qim2b
33169               CALL POPREAL8(qim1)
33170               vb0(i, k, j+1) = vb0(i, k, j+1) + qim1b
33171               CALL POPREAL8(qi)
33172               vb0(i, k, j) = vb0(i, k, j) + qib
33173               CALL POPREAL8(qip1)
33174               vb0(i, k, j-1) = vb0(i, k, j-1) + qip1b
33175               CALL POPREAL8(qip2)
33176               vb0(i, k, j-2) = vb0(i, k, j-2) + qip2b
33177             END IF
33178             rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
33179             rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
33180           END DO
33181         END DO
33182       ELSE IF (branch .EQ. 1) THEN
33183         DO k=ktf,kts,-1
33184           CALL POPINTEGER4(ad_from0)
33185           CALL POPINTEGER4(ad_to0)
33186           DO i=ad_to0,ad_from0,-1
33187             temp2b1 = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1)
33188             temp2b2 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1)
33189             rvb(i, k, j) = rvb(i, k, j) + temp2b1
33190             rvb(i, k, j-1) = rvb(i, k, j-1) + temp2b1
33191             vb0(i, k, j) = vb0(i, k, j) + temp2b2
33192             vbb = temp2b2
33193             fqyb(i, k, jp1) = 0.0
33194             CALL POPCONTROL1B(branch)
33195             IF (branch .EQ. 0) THEN
33196               vb0(i, k, j) = vb0(i, k, j) + vbb
33197               vbb = 0.0
33198             END IF
33199             CALL POPREAL8(vb)
33200             vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
33201           END DO
33202         END DO
33203       ELSE
33204         DO k=ktf,kts,-1
33205           CALL POPINTEGER4(ad_from1)
33206           CALL POPINTEGER4(ad_to1)
33207           DO i=ad_to1,ad_from1,-1
33208             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
33209             temp2 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, k&
33210 &              , j-1))
33211             temp5 = SIGN(1., vel)
33212             temp4 = temp5/12.0
33213             temp3 = SIGN(1, time_step)
33214             temp2b3 = vel*fqyb(i, k, jp1)
33215             temp2b4 = temp2b3/12.0
33216             temp2b5 = temp3*temp4*temp2b3
33217             velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, j&
33218 &              -2))/12.0+temp3*(temp4*temp2))*fqyb(i, k, jp1)
33219             vb0(i, k, j) = vb0(i, k, j) + 7.*temp2b4 - 3.*temp2b5
33220             vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp2b5 + 7.*temp2b4
33221             vb0(i, k, j+1) = vb0(i, k, j+1) + temp2b5 - temp2b4
33222             vb0(i, k, j-2) = vb0(i, k, j-2) - temp2b5 - temp2b4
33223             fqyb(i, k, jp1) = 0.0
33224             rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
33225             rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
33226           END DO
33227         END DO
33228       END IF
33229     ELSE IF (branch .EQ. 3) THEN
33230       DO k=ktf,kts,-1
33231         CALL POPINTEGER4(ad_from2)
33232         CALL POPINTEGER4(ad_to2)
33233         DO i=ad_to2,ad_from2,-1
33234           temp6b = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1)
33235           temp6b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1)
33236           rvb(i, k, j) = rvb(i, k, j) + temp6b
33237           rvb(i, k, j-1) = rvb(i, k, j-1) + temp6b
33238           vbb = temp6b0
33239           vb0(i, k, j-1) = vb0(i, k, j-1) + temp6b0
33240           fqyb(i, k, jp1) = 0.0
33241           CALL POPCONTROL1B(branch)
33242           IF (branch .EQ. 0) THEN
33243             vb0(i, k, j-1) = vb0(i, k, j-1) + vbb
33244             vbb = 0.0
33245           END IF
33246           CALL POPREAL8(vb)
33247           vb0(i, k, j) = vb0(i, k, j) + vbb
33248         END DO
33249       END DO
33250     ELSE IF (branch .EQ. 4) THEN
33251       DO k=ktf,kts,-1
33252         CALL POPINTEGER4(ad_from3)
33253         CALL POPINTEGER4(ad_to3)
33254         DO i=ad_to3,ad_from3,-1
33255           vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
33256           temp6 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, k, j&
33257 &            -1))
33258           temp9 = SIGN(1., vel)
33259           temp8 = temp9/12.0
33260           temp7 = SIGN(1, time_step)
33261           temp6b1 = vel*fqyb(i, k, jp1)
33262           temp6b2 = temp6b1/12.0
33263           temp6b3 = temp7*temp8*temp6b1
33264           velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, j-2&
33265 &            ))/12.0+temp7*(temp8*temp6))*fqyb(i, k, jp1)
33266           vb0(i, k, j) = vb0(i, k, j) + 7.*temp6b2 - 3.*temp6b3
33267           vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp6b3 + 7.*temp6b2
33268           vb0(i, k, j+1) = vb0(i, k, j+1) + temp6b3 - temp6b2
33269           vb0(i, k, j-2) = vb0(i, k, j-2) - temp6b3 - temp6b2
33270           fqyb(i, k, jp1) = 0.0
33271           rvb(i, k, j) = rvb(i, k, j) + 0.5*velb
33272           rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb
33273         END DO
33274       END DO
33275     END IF
33276   END DO
33277 END SUBROUTINE A_ADVECT_WENO_V
33278
33279 !        Generated by TAPENADE     (INRIA, Tropics team)
33280 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
33281 !
33282 !  Differentiation of advect_weno_w in reverse (adjoint) mode:
33283 !   gradient     of useful results: rom tendency w ru rv w_old
33284 !   with respect to varying inputs: rom tendency w ru rv w_old
33285 !   RW status of diff variables: rom:incr tendency:in-out w:incr
33286 !                ru:incr rv:incr w_old:incr
33287 SUBROUTINE A_ADVECT_WENO_W(w, wb0, w_old, w_oldb, tendency, tendencyb, &
33288 &  ru, rub, rv, rvb, rom, romb, mut, time_step, config_flags, msfux, &
33289 &  msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide&
33290 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
33291 &  , kts, kte)
33292   IMPLICIT NONE
33293 ! Input data
33294   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
33295   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
33296 &  jme, kms, kme, its, ite, jts, jte, kts, kte
33297   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru&
33298 &  , rv, rom
33299   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: wb0, w_oldb, rub, rvb, &
33300 &  romb
33301   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
33302   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
33303   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb
33304   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
33305 &  msfvy, msftx, msfty
33306   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu
33307   REAL, INTENT(IN) :: rdx, rdy
33308   INTEGER, INTENT(IN) :: time_step
33309 ! Local data
33310   INTEGER :: i, j, k, itf, jtf, ktf
33311   INTEGER :: i_start, i_end, j_start, j_end
33312   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
33313   INTEGER :: jmin, jmax, jp, jm, imin, imax
33314   REAL :: mrdx, mrdy, ub, vb, uw, vw
33315   REAL :: ubb, vbb, uwb, vwb
33316   REAL, DIMENSION(its:ite, kts:kte) :: vflux
33317   REAL, DIMENSION(its:ite, kts:kte) :: vfluxb
33318   REAL :: dir, vv
33319   REAL :: ue, vs, vn, wb, wt
33320   REAL, PARAMETER :: f30=7./12., f31=1./12.
33321   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
33322   INTEGER :: kt, kb
33323   REAL :: qim2, qim1, qi, qip1, qip2
33324   REAL :: qim2b, qim1b, qib, qip1b, qip2b
33325   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
33326 &  sumwk
33327   DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b&
33328 &  , wi2b, sumwkb
33329   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
33330 &    3.d0/10.d0, eps=1.0d-18
33331   INTEGER, PARAMETER :: pw=2
33332   INTEGER :: horz_order, vert_order
33333   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
33334   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb
33335   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
33336   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb
33337   LOGICAL :: degrade_xs, degrade_ys
33338   LOGICAL :: degrade_xe, degrade_ye
33339   INTEGER :: jp1, jp0, jtmp
33340 ! definition of flux operators, 3rd, 4th, 5th or 6th order
33341   REAL :: flux3, flux4, flux5, flux6
33342   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
33343   REAL :: velb
33344   LOGICAL :: specified
33345   INTEGER :: branch
33346   INTEGER :: ad_from
33347   INTEGER :: ad_to
33348   INTEGER :: ad_from0
33349   INTEGER :: ad_to0
33350   INTEGER :: ad_from1
33351   INTEGER :: ad_to1
33352   INTEGER :: ad_from2
33353   INTEGER :: ad_to2
33354   INTEGER :: ad_from3
33355   INTEGER :: ad_to3
33356   INTEGER :: ad_from4
33357   INTEGER :: ad_to4
33358   INTEGER :: ad_from5
33359   INTEGER :: ad_to5
33360   INTEGER :: ad_from6
33361   INTEGER :: ad_to6
33362   INTEGER :: ad_from7
33363   INTEGER :: ad_to7
33364   INTEGER :: ad_from8
33365   INTEGER :: ad_to8
33366   INTEGER :: ad_from9
33367   INTEGER :: ad_to9
33368   INTEGER :: ad_from10
33369   INTEGER :: ad_to10
33370   INTEGER :: ad_from11
33371   INTEGER :: ad_to11
33372   INTEGER :: ad_from12
33373   INTEGER :: ad_to12
33374   INTEGER :: ad_from13
33375   INTEGER :: ad_to13
33376   INTEGER :: ad_from14
33377   INTEGER :: ad_to14
33378   INTEGER :: ad_from15
33379   INTEGER :: ad_to15
33380   INTEGER :: ad_from16
33381   INTEGER :: ad_to16
33382   INTEGER :: ad_from17
33383   INTEGER :: ad_to17
33384   INTEGER :: ad_from18
33385   INTEGER :: ad_to18
33386   INTEGER :: ad_from19
33387   INTEGER :: ad_to19
33388   INTEGER :: ad_from20
33389   INTEGER :: ad_to20
33390   INTEGER :: ad_from21
33391   INTEGER :: ad_to21
33392   INTEGER :: ad_from22
33393   INTEGER :: ad_to22
33394   INTEGER :: ad_from23
33395   INTEGER :: ad_to23
33396   DOUBLE PRECISION :: temp3
33397   REAL :: temp29
33398   REAL :: temp43b40
33399   DOUBLE PRECISION :: temp2
33400   INTEGER :: temp28
33401   DOUBLE PRECISION :: temp1
33402   REAL :: temp27
33403   DOUBLE PRECISION :: temp0
33404   REAL :: temp13b
33405   DOUBLE PRECISION :: temp26
33406   REAL :: temp21b
33407   DOUBLE PRECISION :: temp25
33408   DOUBLE PRECISION :: temp24
33409   DOUBLE PRECISION :: temp23
33410   REAL :: temp35b5
33411   REAL :: temp9b1
33412   DOUBLE PRECISION :: temp22
33413   REAL :: temp35b4
33414   REAL :: temp9b0
33415   DOUBLE PRECISION :: temp21
33416   REAL :: temp35b3
33417   REAL :: temp20
33418   REAL :: temp35b2
33419   REAL :: temp13b5
33420   REAL :: temp35b1
33421   REAL :: temp13b4
33422   DOUBLE PRECISION :: temp24b
33423   REAL :: temp35b0
33424   REAL :: temp13b3
33425   REAL :: temp13b2
33426   REAL :: temp53
33427   REAL :: temp13b1
33428   REAL :: temp52
33429   REAL :: temp13b0
33430   INTEGER :: temp51
33431   REAL :: temp50
33432   REAL :: tempb4
33433   REAL :: tempb3
33434   DOUBLE PRECISION :: temp27b
33435   REAL :: tempb2
33436   REAL :: temp35b
33437   REAL :: tempb1
33438   REAL :: temp43b
33439   REAL :: tempb0
33440   REAL :: temp43b39
33441   INTRINSIC MAX
33442   REAL :: temp43b38
33443   REAL :: temp43b37
33444   REAL :: temp43b36
33445   INTRINSIC SIGN
33446   REAL :: temp43b35
33447   REAL :: temp43b34
33448   DOUBLE PRECISION :: temp46b
33449   REAL :: temp43b33
33450   REAL :: temp54b
33451   REAL :: temp2b6
33452   REAL :: temp43b32
33453   REAL :: temp2b5
33454   REAL :: temp43b31
33455   REAL :: temp2b4
33456   REAL :: temp19
33457   REAL :: temp43b30
33458   REAL :: temp2b3
33459   INTEGER :: temp18
33460   REAL :: temp2b2
33461   REAL :: temp17
33462   REAL :: temp43b9
33463   REAL :: temp50b1
33464   REAL :: temp2b1
33465   REAL :: temp16
33466   REAL :: temp43b8
33467   REAL :: temp50b0
33468   DOUBLE PRECISION :: temp2b0
33469   REAL :: temp15
33470   REAL :: temp43b7
33471   INTEGER :: temp14
33472   REAL :: temp43b6
33473   REAL :: temp13
33474   REAL :: temp43b5
33475   REAL :: temp12
33476   REAL :: temp43b4
33477   REAL :: temp49
33478   REAL :: temp11
33479   REAL :: temp43b3
33480   REAL :: temp48
33481   INTEGER :: temp10
33482   REAL :: temp43b2
33483   INTEGER :: temp47
33484   REAL :: temp43b1
33485   REAL :: temp46
33486   REAL :: temp9b
33487   REAL :: temp21b4
33488   REAL :: temp43b0
33489   DOUBLE PRECISION :: temp45
33490   REAL :: temp21b3
33491   REAL :: temp31b
33492   DOUBLE PRECISION :: temp44
33493   REAL :: temp21b2
33494   DOUBLE PRECISION :: temp43
33495   REAL :: temp5b7
33496   REAL :: temp21b1
33497   REAL :: temp42
33498   REAL :: temp5b6
33499   REAL :: temp21b0
33500   REAL :: temp41
33501   REAL :: temp5b5
33502   INTEGER :: temp40
33503   REAL :: temp5b4
33504   REAL :: temp5b3
33505   REAL :: temp5b2
33506   REAL :: temp5b1
33507   DOUBLE PRECISION :: temp5b0
33508   REAL :: temp50b
33509   REAL :: tempb
33510   REAL :: temp43b29
33511   REAL :: temp31b1
33512   REAL :: temp43b28
33513   REAL :: temp46b5
33514   REAL :: temp31b0
33515   REAL :: temp43b27
33516   REAL :: temp46b4
33517   REAL :: temp43b26
33518   REAL :: temp46b3
33519   REAL :: temp24b6
33520   REAL :: temp43b25
33521   REAL :: temp46b2
33522   REAL :: temp24b5
33523   REAL :: temp43b24
33524   REAL :: temp46b1
33525   DOUBLE PRECISION :: temp2b
33526   REAL :: temp24b4
33527   REAL :: temp43b23
33528   DOUBLE PRECISION :: temp46b0
33529   REAL :: temp24b3
33530   REAL :: temp43b22
33531   REAL :: temp24b2
33532   REAL :: temp43b21
33533   REAL :: temp24b1
33534   REAL :: temp43b20
33535   DOUBLE PRECISION :: temp24b0
33536   DOUBLE PRECISION :: temp5b
33537   REAL :: temp39b1
33538   REAL :: temp39b0
33539   REAL :: temp39
33540   REAL :: temp17b1
33541   REAL :: temp38
33542   REAL :: temp17b0
33543   REAL :: temp37
33544   INTEGER :: temp36
33545   REAL :: temp27b7
33546   REAL :: temp35
33547   REAL :: temp27b6
33548   REAL :: temp34
33549   REAL :: temp27b5
33550   REAL :: temp33
33551   REAL :: temp27b4
33552   INTEGER :: temp32
33553   REAL :: temp27b3
33554   REAL :: temp31
33555   REAL :: temp27b2
33556   REAL :: temp30
33557   REAL :: temp17b
33558   REAL :: temp27b1
33559   DOUBLE PRECISION :: temp27b0
33560   REAL :: temp43b19
33561   INTRINSIC MIN
33562   REAL :: temp43b18
33563   REAL :: temp43b17
33564   REAL :: temp43b16
33565   REAL :: temp43b15
33566   REAL :: temp43b14
33567   REAL :: temp43b13
33568   REAL :: temp54b0
33569   DOUBLE PRECISION :: temp
33570   REAL :: temp43b12
33571   REAL :: temp43b11
33572   REAL :: temp43b10
33573   REAL :: temp9
33574   REAL :: temp8
33575   REAL :: temp39b
33576   REAL :: temp7
33577   INTEGER :: temp6
33578   REAL :: temp5
33579   DOUBLE PRECISION :: temp4
33580   IF (kte .GT. kde - 1) THEN
33581     ktf = kde - 1
33582   ELSE
33583     ktf = kte
33584   END IF
33585 !  here is the choice of flux operators
33586 !  begin with horizontal flux divergence
33587 !  horizontal_order_test : IF( horz_order == 6 ) THEN
33588 ! ELSE IF (horz_order == 5 ) THEN
33589 !  determine boundary mods for flux operators
33590 !  We degrade the flux operators from 3rd/4th order
33591 !   to second order one gridpoint in from the boundaries for
33592 !   all boundary conditions except periodic and symmetry - these
33593 !   conditions have boundary zone data fill for correct application
33594 !   of the higher order flux stencils
33595   degrade_xs = .true.
33596   degrade_xe = .true.
33597   degrade_ys = .true.
33598   degrade_ye = .true.
33599   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
33600 &      .GT. ids + 3) degrade_xs = .false.
33601   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
33602 &      .LT. ide - 3) degrade_xe = .false.
33603   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
33604 &      .GT. jds + 3) degrade_ys = .false.
33605   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
33606 &      .LT. jde - 4) degrade_ye = .false.
33607 !--------------- y - advection first
33608   i_start = its
33609   IF (ite .GT. ide - 1) THEN
33610     i_end = ide - 1
33611   ELSE
33612     i_end = ite
33613   END IF
33614   j_start = jts
33615   IF (jte .GT. jde - 1) THEN
33616     j_end = jde - 1
33617   ELSE
33618     j_end = jte
33619   END IF
33620 !  higher order flux has a 5 or 7 point stencil, so compute
33621 !  bounds so we can switch to second order flux close to the boundary
33622   j_start_f = j_start
33623   j_end_f = j_end + 1
33624   IF (degrade_ys) THEN
33625     IF (jts .LT. jds + 1) THEN
33626       j_start = jds + 1
33627     ELSE
33628       j_start = jts
33629     END IF
33630     j_start_f = jds + 3
33631   END IF
33632   IF (degrade_ye) THEN
33633     IF (jte .GT. jde - 2) THEN
33634       j_end = jde - 2
33635     ELSE
33636       j_end = jte
33637     END IF
33638     j_end_f = jde - 3
33639   END IF
33640   IF (config_flags%polar) THEN
33641     IF (jte .GT. jde - 1) THEN
33642       j_end = jde - 1
33643     ELSE
33644       j_end = jte
33645     END IF
33646   END IF
33647 !  compute fluxes, 5th or 6th order
33648   jp1 = 2
33649   jp0 = 1
33650   ad_from12 = j_start
33651 j_loop_y_flux_5:DO j=ad_from12,j_end+1
33652     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
33653       CALL PUSHINTEGER4(k)
33654       DO k=kts+1,ktf
33655         ad_from = i_start
33656         DO i=ad_from,i_end
33657           CALL PUSHREAL8(vel)
33658           vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
33659           IF (vel*sign(1,time_step) .GE. 0.0) THEN
33660             CALL PUSHREAL8(qip2)
33661             qip2 = w(i, k, j+1)
33662             CALL PUSHREAL8(qip1)
33663             qip1 = w(i, k, j)
33664             CALL PUSHREAL8(qi)
33665             qi = w(i, k, j-1)
33666             CALL PUSHREAL8(qim1)
33667             qim1 = w(i, k, j-2)
33668             CALL PUSHREAL8(qim2)
33669             qim2 = w(i, k, j-3)
33670             CALL PUSHCONTROL1B(0)
33671           ELSE
33672             CALL PUSHREAL8(qip2)
33673             qip2 = w(i, k, j-2)
33674             CALL PUSHREAL8(qip1)
33675             qip1 = w(i, k, j-1)
33676             CALL PUSHREAL8(qi)
33677             qi = w(i, k, j)
33678             CALL PUSHREAL8(qim1)
33679             qim1 = w(i, k, j+1)
33680             CALL PUSHREAL8(qim2)
33681             qim2 = w(i, k, j+2)
33682             CALL PUSHCONTROL1B(1)
33683           END IF
33684           CALL PUSHREAL8(f0)
33685           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
33686           CALL PUSHREAL8(f1)
33687           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
33688           CALL PUSHREAL8(f2)
33689           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
33690           CALL PUSHREAL8(beta0)
33691           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
33692 &            qi)**2
33693           CALL PUSHREAL8(beta1)
33694           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
33695           CALL PUSHREAL8(beta2)
33696           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
33697 &            qi)**2
33698         END DO
33699         CALL PUSHINTEGER4(i - 1)
33700         CALL PUSHINTEGER4(ad_from)
33701       END DO
33702 !          fqy( i, k, jp1 ) = vel*flux5(                     &
33703 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
33704 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
33705       k = ktf + 1
33706       ad_from0 = i_start
33707       DO i=ad_from0,i_end
33708         CALL PUSHREAL8(vel)
33709         vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
33710         IF (vel*sign(1,time_step) .GE. 0.0) THEN
33711           CALL PUSHREAL8(qip2)
33712           qip2 = w(i, k, j+1)
33713           CALL PUSHREAL8(qip1)
33714           qip1 = w(i, k, j)
33715           CALL PUSHREAL8(qi)
33716           qi = w(i, k, j-1)
33717           CALL PUSHREAL8(qim1)
33718           qim1 = w(i, k, j-2)
33719           CALL PUSHREAL8(qim2)
33720           qim2 = w(i, k, j-3)
33721           CALL PUSHCONTROL1B(0)
33722         ELSE
33723           CALL PUSHREAL8(qip2)
33724           qip2 = w(i, k, j-2)
33725           CALL PUSHREAL8(qip1)
33726           qip1 = w(i, k, j-1)
33727           CALL PUSHREAL8(qi)
33728           qi = w(i, k, j)
33729           CALL PUSHREAL8(qim1)
33730           qim1 = w(i, k, j+1)
33731           CALL PUSHREAL8(qim2)
33732           qim2 = w(i, k, j+2)
33733           CALL PUSHCONTROL1B(1)
33734         END IF
33735         CALL PUSHREAL8(f0)
33736         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
33737         CALL PUSHREAL8(f1)
33738         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
33739         CALL PUSHREAL8(f2)
33740         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
33741         CALL PUSHREAL8(beta0)
33742         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
33743 &          )**2
33744         CALL PUSHREAL8(beta1)
33745         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
33746         CALL PUSHREAL8(beta2)
33747         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
33748 &          )**2
33749       END DO
33750       CALL PUSHINTEGER4(i - 1)
33751       CALL PUSHINTEGER4(ad_from0)
33752       CALL PUSHCONTROL3B(0)
33753     ELSE IF (j .EQ. jds + 1) THEN
33754 !          fqy( i, k, jp1 ) = vel*flux5(                     &
33755 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
33756 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
33757       CALL PUSHINTEGER4(k)
33758 ! 2nd order flux next to south boundary
33759       DO k=kts+1,ktf
33760         ad_from1 = i_start
33761         i = i_end + 1
33762         CALL PUSHINTEGER4(i - 1)
33763         CALL PUSHINTEGER4(ad_from1)
33764       END DO
33765       k = ktf + 1
33766       ad_from2 = i_start
33767       i = i_end + 1
33768       CALL PUSHINTEGER4(i - 1)
33769       CALL PUSHINTEGER4(ad_from2)
33770       CALL PUSHCONTROL3B(1)
33771     ELSE IF (j .EQ. jds + 2) THEN
33772       CALL PUSHINTEGER4(k)
33773 ! third of 4th order flux 2 in from south boundary
33774       DO k=kts+1,ktf
33775         ad_from3 = i_start
33776         DO i=ad_from3,i_end
33777           CALL PUSHREAL8(vel)
33778         END DO
33779         CALL PUSHINTEGER4(i - 1)
33780         CALL PUSHINTEGER4(ad_from3)
33781       END DO
33782       k = ktf + 1
33783       ad_from4 = i_start
33784       DO i=ad_from4,i_end
33785         CALL PUSHREAL8(vel)
33786         vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
33787       END DO
33788       CALL PUSHINTEGER4(i - 1)
33789       CALL PUSHINTEGER4(ad_from4)
33790       CALL PUSHCONTROL3B(2)
33791     ELSE IF (j .EQ. jde - 1) THEN
33792       CALL PUSHINTEGER4(k)
33793 ! 2nd order flux next to north boundary
33794       DO k=kts+1,ktf
33795         ad_from5 = i_start
33796         i = i_end + 1
33797         CALL PUSHINTEGER4(i - 1)
33798         CALL PUSHINTEGER4(ad_from5)
33799       END DO
33800       k = ktf + 1
33801       ad_from6 = i_start
33802       i = i_end + 1
33803       CALL PUSHINTEGER4(i - 1)
33804       CALL PUSHINTEGER4(ad_from6)
33805       CALL PUSHCONTROL3B(3)
33806     ELSE IF (j .EQ. jde - 2) THEN
33807       CALL PUSHINTEGER4(k)
33808 ! 3rd or 4th order flux 2 in from north boundary
33809       DO k=kts+1,ktf
33810         ad_from7 = i_start
33811         DO i=ad_from7,i_end
33812           CALL PUSHREAL8(vel)
33813         END DO
33814         CALL PUSHINTEGER4(i - 1)
33815         CALL PUSHINTEGER4(ad_from7)
33816       END DO
33817       k = ktf + 1
33818       ad_from8 = i_start
33819       DO i=ad_from8,i_end
33820         CALL PUSHREAL8(vel)
33821         vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
33822       END DO
33823       CALL PUSHINTEGER4(i - 1)
33824       CALL PUSHINTEGER4(ad_from8)
33825       CALL PUSHCONTROL3B(4)
33826     ELSE
33827       CALL PUSHCONTROL3B(5)
33828     END IF
33829 !  y flux-divergence into tendency
33830 ! Comments for polar boundary conditions
33831 ! Same process as for advect_u - tendencies run from jds to jde-1
33832 ! (latitudes are as for u grid, longitudes are displaced)
33833 ! Therefore: flow is only from one side for points next to poles
33834     IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
33835       CALL PUSHINTEGER4(k)
33836       DO k=kts,ktf
33837         ad_from9 = i_start
33838         i = i_end + 1
33839         CALL PUSHINTEGER4(i - 1)
33840         CALL PUSHINTEGER4(ad_from9)
33841       END DO
33842       CALL PUSHCONTROL2B(0)
33843     ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
33844       CALL PUSHINTEGER4(k)
33845       DO k=kts,ktf
33846         ad_from10 = i_start
33847         i = i_end + 1
33848         CALL PUSHINTEGER4(i - 1)
33849         CALL PUSHINTEGER4(ad_from10)
33850       END DO
33851       CALL PUSHCONTROL2B(1)
33852     ELSE IF (j .GT. j_start) THEN
33853 ! normal code
33854       CALL PUSHINTEGER4(k)
33855       DO k=kts+1,ktf+1
33856         ad_from11 = i_start
33857         i = i_end + 1
33858         CALL PUSHINTEGER4(i - 1)
33859         CALL PUSHINTEGER4(ad_from11)
33860       END DO
33861       CALL PUSHCONTROL2B(2)
33862     ELSE
33863       CALL PUSHCONTROL2B(3)
33864     END IF
33865     jtmp = jp1
33866     CALL PUSHINTEGER4(jp1)
33867     jp1 = jp0
33868     CALL PUSHINTEGER4(jp0)
33869     jp0 = jtmp
33870   END DO j_loop_y_flux_5
33871   CALL PUSHINTEGER4(j - 1)
33872   CALL PUSHINTEGER4(ad_from12)
33873 !  next, x - flux divergence
33874   i_start = its
33875   IF (ite .GT. ide - 1) THEN
33876     i_end = ide - 1
33877   ELSE
33878     i_end = ite
33879   END IF
33880   j_start = jts
33881   IF (jte .GT. jde - 1) THEN
33882     j_end = jde - 1
33883   ELSE
33884     j_end = jte
33885   END IF
33886 !  higher order flux has a 5 or 7 point stencil, so compute
33887 !  bounds so we can switch to second order flux close to the boundary
33888   i_start_f = i_start
33889   i_end_f = i_end + 1
33890   IF (degrade_xs) THEN
33891     IF (ids + 1 .LT. its) THEN
33892       i_start = its
33893     ELSE
33894       i_start = ids + 1
33895     END IF
33896     IF (i_start + 2 .GT. ids + 3) THEN
33897       i_start_f = ids + 3
33898     ELSE
33899       i_start_f = i_start + 2
33900     END IF
33901   END IF
33902   IF (degrade_xe) THEN
33903     IF (ide - 2 .GT. ite) THEN
33904       i_end = ite
33905     ELSE
33906       i_end = ide - 2
33907     END IF
33908     i_end_f = ide - 3
33909   END IF
33910   ad_from15 = j_start
33911 !  compute fluxes
33912   DO j=ad_from15,j_end
33913     CALL PUSHINTEGER4(k)
33914 !  5th or 6th order flux
33915     DO k=kts+1,ktf
33916       DO i=i_start_f,i_end_f
33917         CALL PUSHREAL8(vel)
33918         vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
33919         IF (vel*sign(1,time_step) .GE. 0.0) THEN
33920           CALL PUSHREAL8(qip2)
33921           qip2 = w(i+1, k, j)
33922           CALL PUSHREAL8(qip1)
33923           qip1 = w(i, k, j)
33924           CALL PUSHREAL8(qi)
33925           qi = w(i-1, k, j)
33926           CALL PUSHREAL8(qim1)
33927           qim1 = w(i-2, k, j)
33928           CALL PUSHREAL8(qim2)
33929           qim2 = w(i-3, k, j)
33930           CALL PUSHCONTROL1B(0)
33931         ELSE
33932           CALL PUSHREAL8(qip2)
33933           qip2 = w(i-2, k, j)
33934           CALL PUSHREAL8(qip1)
33935           qip1 = w(i-1, k, j)
33936           CALL PUSHREAL8(qi)
33937           qi = w(i, k, j)
33938           CALL PUSHREAL8(qim1)
33939           qim1 = w(i+1, k, j)
33940           CALL PUSHREAL8(qim2)
33941           qim2 = w(i+2, k, j)
33942           CALL PUSHCONTROL1B(1)
33943         END IF
33944         CALL PUSHREAL8(f0)
33945         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
33946         CALL PUSHREAL8(f1)
33947         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
33948         CALL PUSHREAL8(f2)
33949         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
33950         CALL PUSHREAL8(beta0)
33951         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
33952 &          )**2
33953         CALL PUSHREAL8(beta1)
33954         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
33955         CALL PUSHREAL8(beta2)
33956         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
33957 &          )**2
33958       END DO
33959     END DO
33960 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
33961 !                                  w(i-1,k,j), w(i  ,k,j),  &
33962 !                                  w(i+1,k,j), w(i+2,k,j),  &
33963 !                                  vel                     )
33964     k = ktf + 1
33965     DO i=i_start_f,i_end_f
33966       CALL PUSHREAL8(vel)
33967       vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
33968       IF (vel*sign(1,time_step) .GE. 0.0) THEN
33969         CALL PUSHREAL8(qip2)
33970         qip2 = w(i+1, k, j)
33971         CALL PUSHREAL8(qip1)
33972         qip1 = w(i, k, j)
33973         CALL PUSHREAL8(qi)
33974         qi = w(i-1, k, j)
33975         CALL PUSHREAL8(qim1)
33976         qim1 = w(i-2, k, j)
33977         CALL PUSHREAL8(qim2)
33978         qim2 = w(i-3, k, j)
33979         CALL PUSHCONTROL1B(0)
33980       ELSE
33981         CALL PUSHREAL8(qip2)
33982         qip2 = w(i-2, k, j)
33983         CALL PUSHREAL8(qip1)
33984         qip1 = w(i-1, k, j)
33985         CALL PUSHREAL8(qi)
33986         qi = w(i, k, j)
33987         CALL PUSHREAL8(qim1)
33988         qim1 = w(i+1, k, j)
33989         CALL PUSHREAL8(qim2)
33990         qim2 = w(i+2, k, j)
33991         CALL PUSHCONTROL1B(1)
33992       END IF
33993       CALL PUSHREAL8(f0)
33994       f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
33995       CALL PUSHREAL8(f1)
33996       f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
33997       CALL PUSHREAL8(f2)
33998       f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
33999       CALL PUSHREAL8(beta0)
34000       beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi)&
34001 &        **2
34002       CALL PUSHREAL8(beta1)
34003       beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
34004       CALL PUSHREAL8(beta2)
34005       beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi)&
34006 &        **2
34007     END DO
34008 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
34009 !                                  w(i-1,k,j), w(i  ,k,j),  &
34010 !                                  w(i+1,k,j), w(i+2,k,j),  &
34011 !                                  vel                     )
34012 !  lower order fluxes close to boundaries (if not periodic or symmetric)
34013     IF (degrade_xs) THEN
34014       ad_from13 = i_start
34015       DO i=ad_from13,i_start_f-1
34016         IF (i .EQ. ids + 1) THEN
34017           CALL PUSHINTEGER4(k)
34018           CALL PUSHCONTROL1B(0)
34019         ELSE
34020           CALL PUSHCONTROL1B(1)
34021         END IF
34022         IF (i .EQ. ids + 2) THEN
34023           CALL PUSHINTEGER4(k)
34024 ! third order
34025           DO k=kts+1,ktf
34026             CALL PUSHREAL8(vel)
34027           END DO
34028           k = ktf + 1
34029           CALL PUSHREAL8(vel)
34030           vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
34031           CALL PUSHCONTROL1B(1)
34032         ELSE
34033           CALL PUSHCONTROL1B(0)
34034         END IF
34035       END DO
34036       CALL PUSHINTEGER4(ad_from13)
34037       CALL PUSHCONTROL1B(0)
34038     ELSE
34039       CALL PUSHCONTROL1B(1)
34040     END IF
34041     IF (degrade_xe) THEN
34042       DO i=i_end_f+1,i_end+1
34043         IF (i .EQ. ide - 1) THEN
34044           CALL PUSHINTEGER4(k)
34045           CALL PUSHCONTROL1B(0)
34046         ELSE
34047           CALL PUSHCONTROL1B(1)
34048         END IF
34049         IF (i .EQ. ide - 2) THEN
34050           CALL PUSHINTEGER4(k)
34051 ! third order flux one in from the boundary
34052           DO k=kts+1,ktf
34053             CALL PUSHREAL8(vel)
34054           END DO
34055           k = ktf + 1
34056           CALL PUSHREAL8(vel)
34057           vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
34058           CALL PUSHCONTROL1B(1)
34059         ELSE
34060           CALL PUSHCONTROL1B(0)
34061         END IF
34062       END DO
34063       CALL PUSHINTEGER4(i - 1)
34064       CALL PUSHCONTROL1B(1)
34065     ELSE
34066       CALL PUSHCONTROL1B(0)
34067     END IF
34068     CALL PUSHINTEGER4(k)
34069 !  x flux-divergence into tendency
34070     DO k=kts+1,ktf+1
34071       ad_from14 = i_start
34072       i = i_end + 1
34073       CALL PUSHINTEGER4(i - 1)
34074       CALL PUSHINTEGER4(ad_from14)
34075     END DO
34076   END DO
34077   CALL PUSHINTEGER4(j - 1)
34078   CALL PUSHINTEGER4(ad_from15)
34079 !  pick up the the horizontal radiation boundary conditions.
34080 !  (these are the computations that don't require 'cb'.
34081 !  first, set to index ranges
34082   i_start = its
34083   IF (ite .GT. ide - 1) THEN
34084     i_end = ide - 1
34085   ELSE
34086     i_end = ite
34087   END IF
34088   j_start = jts
34089   IF (jte .GT. jde - 1) THEN
34090     j_end = jde - 1
34091   ELSE
34092     j_end = jte
34093   END IF
34094   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
34095     ad_from16 = j_start
34096     DO j=ad_from16,j_end
34097       CALL PUSHINTEGER4(k)
34098       DO k=kts+1,ktf
34099         uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its&
34100 &          , k-1, j)+ru(its+1, k-1, j)))
34101         IF (uw .GT. 0.) THEN
34102           CALL PUSHREAL8(ub)
34103           ub = 0.
34104           CALL PUSHCONTROL1B(0)
34105         ELSE
34106           CALL PUSHREAL8(ub)
34107           ub = uw
34108           CALL PUSHCONTROL1B(1)
34109         END IF
34110       END DO
34111     END DO
34112     CALL PUSHINTEGER4(j - 1)
34113     CALL PUSHINTEGER4(ad_from16)
34114     CALL PUSHINTEGER4(k)
34115     k = ktf + 1
34116     ad_from17 = j_start
34117     DO j=ad_from17,j_end
34118       uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-&
34119 &        1)*(ru(its, k-2, j)+ru(its+1, k-2, j)))
34120       IF (uw .GT. 0.) THEN
34121         CALL PUSHREAL8(ub)
34122         ub = 0.
34123         CALL PUSHCONTROL1B(0)
34124       ELSE
34125         CALL PUSHREAL8(ub)
34126         ub = uw
34127         CALL PUSHCONTROL1B(1)
34128       END IF
34129     END DO
34130     CALL PUSHINTEGER4(j - 1)
34131     CALL PUSHINTEGER4(ad_from17)
34132     CALL PUSHCONTROL1B(0)
34133   ELSE
34134     CALL PUSHCONTROL1B(1)
34135   END IF
34136   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
34137     ad_from18 = j_start
34138     DO j=ad_from18,j_end
34139       CALL PUSHINTEGER4(k)
34140       DO k=kts+1,ktf
34141         uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-&
34142 &          1, k-1, j)+ru(ite, k-1, j)))
34143         IF (uw .LT. 0.) THEN
34144           CALL PUSHREAL8(ub)
34145           ub = 0.
34146           CALL PUSHCONTROL1B(0)
34147         ELSE
34148           CALL PUSHREAL8(ub)
34149           ub = uw
34150           CALL PUSHCONTROL1B(1)
34151         END IF
34152       END DO
34153     END DO
34154     CALL PUSHINTEGER4(j - 1)
34155     CALL PUSHINTEGER4(ad_from18)
34156     CALL PUSHINTEGER4(k)
34157     k = ktf + 1
34158     ad_from19 = j_start
34159     DO j=ad_from19,j_end
34160       uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-&
34161 &        1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j)))
34162       IF (uw .LT. 0.) THEN
34163         CALL PUSHREAL8(ub)
34164         ub = 0.
34165         CALL PUSHCONTROL1B(0)
34166       ELSE
34167         CALL PUSHREAL8(ub)
34168         ub = uw
34169         CALL PUSHCONTROL1B(1)
34170       END IF
34171     END DO
34172     CALL PUSHINTEGER4(j - 1)
34173     CALL PUSHINTEGER4(ad_from19)
34174     CALL PUSHCONTROL1B(0)
34175   ELSE
34176     CALL PUSHCONTROL1B(1)
34177   END IF
34178   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
34179     ad_from20 = i_start
34180     DO i=ad_from20,i_end
34181       CALL PUSHINTEGER4(k)
34182       DO k=kts+1,ktf
34183         vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k&
34184 &          -1, jts)+rv(i, k-1, jts+1)))
34185         IF (vw .GT. 0.) THEN
34186           CALL PUSHREAL8(vb)
34187           vb = 0.
34188           CALL PUSHCONTROL1B(0)
34189         ELSE
34190           CALL PUSHREAL8(vb)
34191           vb = vw
34192           CALL PUSHCONTROL1B(1)
34193         END IF
34194       END DO
34195     END DO
34196     CALL PUSHINTEGER4(i - 1)
34197     CALL PUSHINTEGER4(ad_from20)
34198     CALL PUSHINTEGER4(k)
34199     k = ktf + 1
34200     ad_from21 = i_start
34201     DO i=ad_from21,i_end
34202       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-&
34203 &        1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1)))
34204       IF (vw .GT. 0.) THEN
34205         CALL PUSHREAL8(vb)
34206         vb = 0.
34207         CALL PUSHCONTROL1B(0)
34208       ELSE
34209         CALL PUSHREAL8(vb)
34210         vb = vw
34211         CALL PUSHCONTROL1B(1)
34212       END IF
34213     END DO
34214     CALL PUSHINTEGER4(i - 1)
34215     CALL PUSHINTEGER4(ad_from21)
34216     CALL PUSHCONTROL1B(0)
34217   ELSE
34218     CALL PUSHCONTROL1B(1)
34219   END IF
34220   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
34221     ad_from22 = i_start
34222     DO i=ad_from22,i_end
34223       CALL PUSHINTEGER4(k)
34224       DO k=kts+1,ktf
34225         vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k&
34226 &          -1, jte-1)+rv(i, k-1, jte)))
34227         IF (vw .LT. 0.) THEN
34228           CALL PUSHREAL8(vb)
34229           vb = 0.
34230           CALL PUSHCONTROL1B(0)
34231         ELSE
34232           CALL PUSHREAL8(vb)
34233           vb = vw
34234           CALL PUSHCONTROL1B(1)
34235         END IF
34236       END DO
34237     END DO
34238     CALL PUSHINTEGER4(i - 1)
34239     CALL PUSHINTEGER4(ad_from22)
34240     CALL PUSHINTEGER4(k)
34241     k = ktf + 1
34242     ad_from23 = i_start
34243     DO i=ad_from23,i_end
34244       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-&
34245 &        1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte)))
34246       IF (vw .LT. 0.) THEN
34247         CALL PUSHREAL8(vb)
34248         vb = 0.
34249         CALL PUSHCONTROL1B(0)
34250       ELSE
34251         CALL PUSHREAL8(vb)
34252         vb = vw
34253         CALL PUSHCONTROL1B(1)
34254       END IF
34255     END DO
34256     CALL PUSHINTEGER4(i - 1)
34257     CALL PUSHINTEGER4(ad_from23)
34258     CALL PUSHCONTROL1B(1)
34259   ELSE
34260     CALL PUSHCONTROL1B(0)
34261   END IF
34262 !-------------------- vertical advection
34263 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
34264 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
34265 !     Therefore we don't need to make a correction for advect_w
34266   i_start = its
34267   IF (ite .GT. ide - 1) THEN
34268     CALL PUSHINTEGER4(i_end)
34269     i_end = ide - 1
34270     CALL PUSHCONTROL1B(0)
34271   ELSE
34272     CALL PUSHINTEGER4(i_end)
34273     i_end = ite
34274     CALL PUSHCONTROL1B(1)
34275   END IF
34276   j_start = jts
34277   IF (jte .GT. jde - 1) THEN
34278     CALL PUSHINTEGER4(j_end)
34279     j_end = jde - 1
34280     CALL PUSHCONTROL1B(0)
34281   ELSE
34282     CALL PUSHINTEGER4(j_end)
34283     j_end = jte
34284     CALL PUSHCONTROL1B(1)
34285   END IF
34286 !    vert_order_test : IF (vert_order == 6) THEN
34287 ! ELSE IF (vert_order == 5) THEN
34288   DO j=j_start,j_end
34289     CALL PUSHINTEGER4(k)
34290     DO k=kts+3,ktf-1
34291       DO i=i_start,i_end
34292         CALL PUSHREAL8(vel)
34293         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
34294         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
34295           CALL PUSHREAL8(qip2)
34296           qip2 = w(i, k+1, j)
34297           CALL PUSHREAL8(qip1)
34298           qip1 = w(i, k, j)
34299           CALL PUSHREAL8(qi)
34300           qi = w(i, k-1, j)
34301           CALL PUSHREAL8(qim1)
34302           qim1 = w(i, k-2, j)
34303           CALL PUSHREAL8(qim2)
34304           qim2 = w(i, k-3, j)
34305           CALL PUSHCONTROL1B(0)
34306         ELSE
34307           CALL PUSHREAL8(qip2)
34308           qip2 = w(i, k-2, j)
34309           CALL PUSHREAL8(qip1)
34310           qip1 = w(i, k-1, j)
34311           CALL PUSHREAL8(qi)
34312           qi = w(i, k, j)
34313           CALL PUSHREAL8(qim1)
34314           qim1 = w(i, k+1, j)
34315           CALL PUSHREAL8(qim2)
34316           qim2 = w(i, k+2, j)
34317           CALL PUSHCONTROL1B(1)
34318         END IF
34319         CALL PUSHREAL8(f0)
34320         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
34321         CALL PUSHREAL8(f1)
34322         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
34323         CALL PUSHREAL8(f2)
34324         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
34325         CALL PUSHREAL8(beta0)
34326         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
34327 &          )**2
34328         CALL PUSHREAL8(beta1)
34329         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
34330         CALL PUSHREAL8(beta2)
34331         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
34332 &          )**2
34333       END DO
34334     END DO
34335 !           vflux(i,k) = vel*flux5(                                   &
34336 !                   w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
34337 !                   w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
34338     DO i=i_start,i_end
34339       CALL PUSHREAL8(vel)
34340     END DO
34341     CALL PUSHINTEGER4(k)
34342 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
34343     k = ktf + 1
34344   END DO
34345   vfluxb = 0.0
34346   DO j=j_end,j_start,-1
34347     DO i=i_end,i_start,-1
34348       vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j)
34349     END DO
34350     DO k=ktf,kts+1,-1
34351       DO i=i_end,i_start,-1
34352         vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j)
34353         vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j)
34354       END DO
34355     END DO
34356     CALL POPINTEGER4(k)
34357     DO i=i_end,i_start,-1
34358       k = ktf + 1
34359       temp54b = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
34360       temp54b0 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
34361       romb(i, k, j) = romb(i, k, j) + temp54b
34362       romb(i, k-1, j) = romb(i, k-1, j) + temp54b
34363       wb0(i, k, j) = wb0(i, k, j) + temp54b0
34364       wb0(i, k-1, j) = wb0(i, k-1, j) + temp54b0
34365       vfluxb(i, k) = 0.0
34366       k = ktf
34367       vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
34368       temp50 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, j)&
34369 &        )
34370       temp53 = SIGN(1., -vel)
34371       temp52 = temp53/12.0
34372       temp51 = SIGN(1, time_step)
34373       temp50b = vel*vfluxb(i, k)
34374       temp50b0 = temp50b/12.0
34375       temp50b1 = temp51*temp52*temp50b
34376       velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))/&
34377 &        12.0+temp51*(temp52*temp50))*vfluxb(i, k)
34378       wb0(i, k, j) = wb0(i, k, j) + 7.*temp50b0 - 3.*temp50b1
34379       wb0(i, k-1, j) = wb0(i, k-1, j) + 3.*temp50b1 + 7.*temp50b0
34380       wb0(i, k+1, j) = wb0(i, k+1, j) + temp50b1 - temp50b0
34381       wb0(i, k-2, j) = wb0(i, k-2, j) - temp50b1 - temp50b0
34382       vfluxb(i, k) = 0.0
34383       romb(i, k, j) = romb(i, k, j) + 0.5*velb
34384       romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
34385       k = kts + 2
34386       vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
34387       temp46 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, j)&
34388 &        )
34389       temp49 = SIGN(1., -vel)
34390       temp48 = temp49/12.0
34391       temp47 = SIGN(1, time_step)
34392       temp46b1 = vel*vfluxb(i, k)
34393       temp46b2 = temp46b1/12.0
34394       temp46b3 = temp47*temp48*temp46b1
34395       velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))/&
34396 &        12.0+temp47*(temp48*temp46))*vfluxb(i, k)
34397       wb0(i, k, j) = wb0(i, k, j) + 7.*temp46b2 - 3.*temp46b3
34398       wb0(i, k-1, j) = wb0(i, k-1, j) + 3.*temp46b3 + 7.*temp46b2
34399       wb0(i, k+1, j) = wb0(i, k+1, j) + temp46b3 - temp46b2
34400       wb0(i, k-2, j) = wb0(i, k-2, j) - temp46b3 - temp46b2
34401       vfluxb(i, k) = 0.0
34402       CALL POPREAL8(vel)
34403       romb(i, k, j) = romb(i, k, j) + 0.5*velb
34404       romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
34405       k = kts + 1
34406       temp46b4 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k)
34407       temp46b5 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k)
34408       romb(i, k, j) = romb(i, k, j) + temp46b4
34409       romb(i, k-1, j) = romb(i, k-1, j) + temp46b4
34410       wb0(i, k, j) = wb0(i, k, j) + temp46b5
34411       wb0(i, k-1, j) = wb0(i, k-1, j) + temp46b5
34412       vfluxb(i, k) = 0.0
34413     END DO
34414     DO k=ktf-1,kts+3,-1
34415       DO i=i_end,i_start,-1
34416         wi0 = gi0/(eps+beta0)**pw
34417         wi1 = gi1/(eps+beta1)**pw
34418         wi2 = gi2/(eps+beta2)**pw
34419         sumwk = wi0 + wi1 + wi2
34420         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
34421         temp46b = vel*vfluxb(i, k)/sumwk
34422         temp46b0 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk
34423         f0b = wi0*temp46b
34424         f1b = wi1*temp46b
34425         f2b = wi2*temp46b
34426         velb = temp46b0
34427         sumwkb = -(vel*temp46b0/sumwk)
34428         wi0b = sumwkb + f0*temp46b
34429         wi1b = sumwkb + f1*temp46b
34430         wi2b = sumwkb + f2*temp46b
34431         vfluxb(i, k) = 0.0
34432         temp45 = (eps+beta2)**pw
34433         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
34434 &            )) THEN
34435           beta2b = 0.0
34436         ELSE
34437           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp45**2)
34438         END IF
34439         temp44 = (eps+beta1)**pw
34440         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
34441 &            )) THEN
34442           beta1b = 0.0
34443         ELSE
34444           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp44**2)
34445         END IF
34446         temp43 = (eps+beta0)**pw
34447         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
34448 &            )) THEN
34449           beta0b = 0.0
34450         ELSE
34451           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp43**2)
34452         END IF
34453         CALL POPREAL8(beta2)
34454         temp43b35 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
34455         temp43b36 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
34456         qip2b = temp43b36 - f2b/6. + temp43b35
34457         CALL POPREAL8(beta1)
34458         temp43b37 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
34459         temp43b40 = 2*(qim1-qip1)*beta1b/4.
34460         qip1b = temp43b37 - temp43b40 + f1b/3. + 5.*f2b/6. - 4.*&
34461 &          temp43b36 - 2.*temp43b35
34462         CALL POPREAL8(beta0)
34463         temp43b39 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
34464         temp43b38 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
34465         qib = f2b/3. - 2.*temp43b37 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
34466 &          temp43b38 + temp43b39 + 3.*temp43b36 + temp43b35
34467         qim1b = temp43b40 - 4.*temp43b38 - 7.*f0b/6. - f1b/6. - 2.*&
34468 &          temp43b39 + temp43b37
34469         qim2b = f0b/3. + temp43b38 + temp43b39
34470         CALL POPREAL8(f2)
34471         CALL POPREAL8(f1)
34472         CALL POPREAL8(f0)
34473         CALL POPCONTROL1B(branch)
34474         IF (branch .EQ. 0) THEN
34475           CALL POPREAL8(qim2)
34476           wb0(i, k-3, j) = wb0(i, k-3, j) + qim2b
34477           CALL POPREAL8(qim1)
34478           wb0(i, k-2, j) = wb0(i, k-2, j) + qim1b
34479           CALL POPREAL8(qi)
34480           wb0(i, k-1, j) = wb0(i, k-1, j) + qib
34481           CALL POPREAL8(qip1)
34482           wb0(i, k, j) = wb0(i, k, j) + qip1b
34483           CALL POPREAL8(qip2)
34484           wb0(i, k+1, j) = wb0(i, k+1, j) + qip2b
34485         ELSE
34486           CALL POPREAL8(qim2)
34487           wb0(i, k+2, j) = wb0(i, k+2, j) + qim2b
34488           CALL POPREAL8(qim1)
34489           wb0(i, k+1, j) = wb0(i, k+1, j) + qim1b
34490           CALL POPREAL8(qi)
34491           wb0(i, k, j) = wb0(i, k, j) + qib
34492           CALL POPREAL8(qip1)
34493           wb0(i, k-1, j) = wb0(i, k-1, j) + qip1b
34494           CALL POPREAL8(qip2)
34495           wb0(i, k-2, j) = wb0(i, k-2, j) + qip2b
34496         END IF
34497         CALL POPREAL8(vel)
34498         romb(i, k, j) = romb(i, k, j) + 0.5*velb
34499         romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb
34500       END DO
34501     END DO
34502     CALL POPINTEGER4(k)
34503   END DO
34504   CALL POPCONTROL1B(branch)
34505   IF (branch .EQ. 0) THEN
34506     CALL POPINTEGER4(j_end)
34507   ELSE
34508     CALL POPINTEGER4(j_end)
34509   END IF
34510   CALL POPCONTROL1B(branch)
34511   IF (branch .EQ. 0) THEN
34512     CALL POPINTEGER4(i_end)
34513   ELSE
34514     CALL POPINTEGER4(i_end)
34515   END IF
34516   CALL POPCONTROL1B(branch)
34517   IF (branch .NE. 0) THEN
34518     CALL POPINTEGER4(ad_from23)
34519     CALL POPINTEGER4(ad_to23)
34520     DO i=ad_to23,ad_from23,-1
34521       temp43b31 = -(rdy*tendencyb(i, k, j_end))
34522       temp43b32 = w(i, k, j_end)*temp43b31
34523       temp43b33 = (2.-fzm(k-1))*temp43b32
34524       temp43b34 = -(fzp(k-1)*temp43b32)
34525       vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp43b31
34526       w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp43b31
34527       w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp43b31
34528       wb0(i, k, j_end) = wb0(i, k, j_end) + ((2.-fzm(k-1))*(rv(i, k-1, &
34529 &        jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, jte&
34530 &        -1)))*temp43b31
34531       rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp43b33
34532       rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - temp43b33
34533       rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp43b34
34534       rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) - temp43b34
34535       CALL POPCONTROL1B(branch)
34536       IF (branch .EQ. 0) THEN
34537         CALL POPREAL8(vb)
34538         vwb = 0.0
34539       ELSE
34540         CALL POPREAL8(vb)
34541         vwb = vbb
34542       END IF
34543       temp43b29 = 0.5*(2.-fzm(k-1))*vwb
34544       temp43b30 = -(0.5*fzp(k-1)*vwb)
34545       rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + temp43b29
34546       rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp43b29
34547       rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) + temp43b30
34548       rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp43b30
34549     END DO
34550     CALL POPINTEGER4(k)
34551     CALL POPINTEGER4(ad_from22)
34552     CALL POPINTEGER4(ad_to22)
34553     DO i=ad_to22,ad_from22,-1
34554       DO k=ktf,kts+1,-1
34555         temp43b27 = -(rdy*tendencyb(i, k, j_end))
34556         temp43b28 = w(i, k, j_end)*temp43b27
34557         vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp43b27
34558         w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp43b27
34559         w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp43b27
34560         wb0(i, k, j_end) = wb0(i, k, j_end) + (fzm(k)*(rv(i, k, jte)-rv(&
34561 &          i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte-1)))*&
34562 &          temp43b27
34563         rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp43b28
34564         rvb(i, k, jte-1) = rvb(i, k, jte-1) - fzm(k)*temp43b28
34565         rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp43b28
34566         rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - fzp(k)*temp43b28
34567         CALL POPCONTROL1B(branch)
34568         IF (branch .EQ. 0) THEN
34569           CALL POPREAL8(vb)
34570           vwb = 0.0
34571         ELSE
34572           CALL POPREAL8(vb)
34573           vwb = vbb
34574         END IF
34575         temp43b26 = 0.5*vwb
34576         rvb(i, k, jte-1) = rvb(i, k, jte-1) + fzm(k)*temp43b26
34577         rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp43b26
34578         rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + fzp(k)*temp43b26
34579         rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp43b26
34580       END DO
34581       CALL POPINTEGER4(k)
34582     END DO
34583   END IF
34584   CALL POPCONTROL1B(branch)
34585   IF (branch .EQ. 0) THEN
34586     CALL POPINTEGER4(ad_from21)
34587     CALL POPINTEGER4(ad_to21)
34588     DO i=ad_to21,ad_from21,-1
34589       temp43b22 = -(rdy*tendencyb(i, k, jts))
34590       temp43b23 = w(i, k, jts)*temp43b22
34591       temp43b24 = (2.-fzm(k-1))*temp43b23
34592       temp43b25 = -(fzp(k-1)*temp43b23)
34593       vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp43b22
34594       w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp43b22
34595       w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp43b22
34596       wb0(i, k, jts) = wb0(i, k, jts) + ((2.-fzm(k-1))*(rv(i, k-1, jts+1&
34597 &        )-rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))&
34598 &        *temp43b22
34599       rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp43b24
34600       rvb(i, k-1, jts) = rvb(i, k-1, jts) - temp43b24
34601       rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp43b25
34602       rvb(i, k-2, jts) = rvb(i, k-2, jts) - temp43b25
34603       CALL POPCONTROL1B(branch)
34604       IF (branch .EQ. 0) THEN
34605         CALL POPREAL8(vb)
34606         vwb = 0.0
34607       ELSE
34608         CALL POPREAL8(vb)
34609         vwb = vbb
34610       END IF
34611       temp43b20 = 0.5*(2.-fzm(k-1))*vwb
34612       temp43b21 = -(0.5*fzp(k-1)*vwb)
34613       rvb(i, k-1, jts) = rvb(i, k-1, jts) + temp43b20
34614       rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp43b20
34615       rvb(i, k-2, jts) = rvb(i, k-2, jts) + temp43b21
34616       rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp43b21
34617     END DO
34618     CALL POPINTEGER4(k)
34619     CALL POPINTEGER4(ad_from20)
34620     CALL POPINTEGER4(ad_to20)
34621     DO i=ad_to20,ad_from20,-1
34622       DO k=ktf,kts+1,-1
34623         temp43b18 = -(rdy*tendencyb(i, k, jts))
34624         temp43b19 = w(i, k, jts)*temp43b18
34625         vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp43b18
34626         w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp43b18
34627         w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp43b18
34628         wb0(i, k, jts) = wb0(i, k, jts) + (fzm(k)*(rv(i, k, jts+1)-rv(i&
34629 &          , k, jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))*&
34630 &          temp43b18
34631         rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp43b19
34632         rvb(i, k, jts) = rvb(i, k, jts) - fzm(k)*temp43b19
34633         rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp43b19
34634         rvb(i, k-1, jts) = rvb(i, k-1, jts) - fzp(k)*temp43b19
34635         CALL POPCONTROL1B(branch)
34636         IF (branch .EQ. 0) THEN
34637           CALL POPREAL8(vb)
34638           vwb = 0.0
34639         ELSE
34640           CALL POPREAL8(vb)
34641           vwb = vbb
34642         END IF
34643         temp43b17 = 0.5*vwb
34644         rvb(i, k, jts) = rvb(i, k, jts) + fzm(k)*temp43b17
34645         rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp43b17
34646         rvb(i, k-1, jts) = rvb(i, k-1, jts) + fzp(k)*temp43b17
34647         rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp43b17
34648       END DO
34649       CALL POPINTEGER4(k)
34650     END DO
34651   END IF
34652   CALL POPCONTROL1B(branch)
34653   IF (branch .EQ. 0) THEN
34654     CALL POPINTEGER4(ad_from19)
34655     CALL POPINTEGER4(ad_to19)
34656     DO j=ad_to19,ad_from19,-1
34657       temp43b13 = -(rdx*tendencyb(i_end, k, j))
34658       temp43b14 = w(i_end, k, j)*temp43b13
34659       temp43b15 = (2.-fzm(k-1))*temp43b14
34660       temp43b16 = -(fzp(k-1)*temp43b14)
34661       ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp43b13
34662       w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp43b13
34663       w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp43b13
34664       wb0(i_end, k, j) = wb0(i_end, k, j) + ((2.-fzm(k-1))*(ru(ite, k-1&
34665 &        , j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-2&
34666 &        , j)))*temp43b13
34667       rub(ite, k-1, j) = rub(ite, k-1, j) + temp43b15
34668       rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - temp43b15
34669       rub(ite, k-2, j) = rub(ite, k-2, j) + temp43b16
34670       rub(ite-1, k-2, j) = rub(ite-1, k-2, j) - temp43b16
34671       CALL POPCONTROL1B(branch)
34672       IF (branch .EQ. 0) THEN
34673         CALL POPREAL8(ub)
34674         uwb = 0.0
34675       ELSE
34676         CALL POPREAL8(ub)
34677         uwb = ubb
34678       END IF
34679       temp43b11 = 0.5*(2.-fzm(k-1))*uwb
34680       temp43b12 = -(0.5*fzp(k-1)*uwb)
34681       rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + temp43b11
34682       rub(ite, k-1, j) = rub(ite, k-1, j) + temp43b11
34683       rub(ite-1, k-2, j) = rub(ite-1, k-2, j) + temp43b12
34684       rub(ite, k-2, j) = rub(ite, k-2, j) + temp43b12
34685     END DO
34686     CALL POPINTEGER4(k)
34687     CALL POPINTEGER4(ad_from18)
34688     CALL POPINTEGER4(ad_to18)
34689     DO j=ad_to18,ad_from18,-1
34690       DO k=ktf,kts+1,-1
34691         temp43b9 = -(rdx*tendencyb(i_end, k, j))
34692         temp43b10 = w(i_end, k, j)*temp43b9
34693         ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp43b9
34694         w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp43b9
34695         w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp43b9
34696         wb0(i_end, k, j) = wb0(i_end, k, j) + (fzm(k)*(ru(ite, k, j)-ru(&
34697 &          ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j)))*&
34698 &          temp43b9
34699         rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp43b10
34700         rub(ite-1, k, j) = rub(ite-1, k, j) - fzm(k)*temp43b10
34701         rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp43b10
34702         rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - fzp(k)*temp43b10
34703         CALL POPCONTROL1B(branch)
34704         IF (branch .EQ. 0) THEN
34705           CALL POPREAL8(ub)
34706           uwb = 0.0
34707         ELSE
34708           CALL POPREAL8(ub)
34709           uwb = ubb
34710         END IF
34711         temp43b8 = 0.5*uwb
34712         rub(ite-1, k, j) = rub(ite-1, k, j) + fzm(k)*temp43b8
34713         rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp43b8
34714         rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + fzp(k)*temp43b8
34715         rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp43b8
34716       END DO
34717       CALL POPINTEGER4(k)
34718     END DO
34719   END IF
34720   CALL POPCONTROL1B(branch)
34721   IF (branch .EQ. 0) THEN
34722     CALL POPINTEGER4(ad_from17)
34723     CALL POPINTEGER4(ad_to17)
34724     DO j=ad_to17,ad_from17,-1
34725       temp43b4 = -(rdx*tendencyb(its, k, j))
34726       temp43b5 = w(its, k, j)*temp43b4
34727       temp43b6 = (2.-fzm(k-1))*temp43b5
34728       temp43b7 = -(fzp(k-1)*temp43b5)
34729       ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp43b4
34730       w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp43b4
34731       w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp43b4
34732       wb0(its, k, j) = wb0(its, k, j) + ((2.-fzm(k-1))*(ru(its+1, k-1, j&
34733 &        )-ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))&
34734 &        *temp43b4
34735       rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp43b6
34736       rub(its, k-1, j) = rub(its, k-1, j) - temp43b6
34737       rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp43b7
34738       rub(its, k-2, j) = rub(its, k-2, j) - temp43b7
34739       CALL POPCONTROL1B(branch)
34740       IF (branch .EQ. 0) THEN
34741         CALL POPREAL8(ub)
34742         uwb = 0.0
34743       ELSE
34744         CALL POPREAL8(ub)
34745         uwb = ubb
34746       END IF
34747       temp43b2 = 0.5*(2.-fzm(k-1))*uwb
34748       temp43b3 = -(0.5*fzp(k-1)*uwb)
34749       rub(its, k-1, j) = rub(its, k-1, j) + temp43b2
34750       rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp43b2
34751       rub(its, k-2, j) = rub(its, k-2, j) + temp43b3
34752       rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp43b3
34753     END DO
34754     CALL POPINTEGER4(k)
34755     CALL POPINTEGER4(ad_from16)
34756     CALL POPINTEGER4(ad_to16)
34757     DO j=ad_to16,ad_from16,-1
34758       DO k=ktf,kts+1,-1
34759         temp43b0 = -(rdx*tendencyb(its, k, j))
34760         temp43b1 = w(its, k, j)*temp43b0
34761         ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp43b0
34762         w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp43b0
34763         w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp43b0
34764         wb0(its, k, j) = wb0(its, k, j) + (fzm(k)*(ru(its+1, k, j)-ru(&
34765 &          its, k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))*&
34766 &          temp43b0
34767         rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp43b1
34768         rub(its, k, j) = rub(its, k, j) - fzm(k)*temp43b1
34769         rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp43b1
34770         rub(its, k-1, j) = rub(its, k-1, j) - fzp(k)*temp43b1
34771         CALL POPCONTROL1B(branch)
34772         IF (branch .EQ. 0) THEN
34773           CALL POPREAL8(ub)
34774           uwb = 0.0
34775         ELSE
34776           CALL POPREAL8(ub)
34777           uwb = ubb
34778         END IF
34779         temp43b = 0.5*uwb
34780         rub(its, k, j) = rub(its, k, j) + fzm(k)*temp43b
34781         rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp43b
34782         rub(its, k-1, j) = rub(its, k-1, j) + fzp(k)*temp43b
34783         rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp43b
34784       END DO
34785       CALL POPINTEGER4(k)
34786     END DO
34787   END IF
34788   fqxb = 0.0
34789   CALL POPINTEGER4(ad_from15)
34790   CALL POPINTEGER4(ad_to15)
34791   DO j=ad_to15,ad_from15,-1
34792     DO k=ktf+1,kts+1,-1
34793       CALL POPINTEGER4(ad_from14)
34794       CALL POPINTEGER4(ad_to14)
34795       DO i=ad_to14,ad_from14,-1
34796         mrdx = msftx(i, j)*rdx
34797         fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j)
34798         fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j)
34799       END DO
34800     END DO
34801     CALL POPINTEGER4(k)
34802     CALL POPCONTROL1B(branch)
34803     IF (branch .NE. 0) THEN
34804       CALL POPINTEGER4(ad_to13)
34805       DO i=ad_to13,i_end_f+1,-1
34806         CALL POPCONTROL1B(branch)
34807         IF (branch .NE. 0) THEN
34808           k = ktf + 1
34809           temp39 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1, k&
34810 &            , j))
34811           temp42 = SIGN(1., vel)
34812           temp41 = temp42/12.0
34813           temp40 = SIGN(1, time_step)
34814           temp39b = vel*fqxb(i, k)
34815           temp39b0 = temp39b/12.0
34816           temp39b1 = temp40*temp41*temp39b
34817           velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j&
34818 &            ))/12.0+temp40*(temp41*temp39))*fqxb(i, k)
34819           wb0(i, k, j) = wb0(i, k, j) + 7.*temp39b0 - 3.*temp39b1
34820           wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp39b1 + 7.*temp39b0
34821           wb0(i+1, k, j) = wb0(i+1, k, j) + temp39b1 - temp39b0
34822           wb0(i-2, k, j) = wb0(i-2, k, j) - temp39b1 - temp39b0
34823           fqxb(i, k) = 0.0
34824           CALL POPREAL8(vel)
34825           rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
34826           rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
34827           DO k=ktf,kts+1,-1
34828             vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
34829             temp35 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1&
34830 &              , k, j))
34831             temp38 = SIGN(1., vel)
34832             temp37 = temp38/12.0
34833             temp36 = SIGN(1, time_step)
34834             temp35b3 = vel*fqxb(i, k)
34835             temp35b4 = temp35b3/12.0
34836             temp35b5 = temp36*temp37*temp35b3
34837             velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
34838 &              , j))/12.0+temp36*(temp37*temp35))*fqxb(i, k)
34839             wb0(i, k, j) = wb0(i, k, j) + 7.*temp35b4 - 3.*temp35b5
34840             wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp35b5 + 7.*temp35b4
34841             wb0(i+1, k, j) = wb0(i+1, k, j) + temp35b5 - temp35b4
34842             wb0(i-2, k, j) = wb0(i-2, k, j) - temp35b5 - temp35b4
34843             fqxb(i, k) = 0.0
34844             CALL POPREAL8(vel)
34845             rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
34846             rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
34847           END DO
34848           CALL POPINTEGER4(k)
34849         END IF
34850         CALL POPCONTROL1B(branch)
34851         IF (branch .EQ. 0) THEN
34852           k = ktf + 1
34853           temp35b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
34854           temp35b2 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2&
34855 &            , j))*fqxb(i, k)
34856           rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp35b1
34857           rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp35b1
34858           wb0(i, k, j) = wb0(i, k, j) + temp35b2
34859           wb0(i-1, k, j) = wb0(i-1, k, j) + temp35b2
34860           fqxb(i, k) = 0.0
34861           DO k=ktf,kts+1,-1
34862             temp35b = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
34863             temp35b0 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
34864 &              fqxb(i, k)
34865             rub(i, k, j) = rub(i, k, j) + fzm(k)*temp35b
34866             rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp35b
34867             wb0(i, k, j) = wb0(i, k, j) + temp35b0
34868             wb0(i-1, k, j) = wb0(i-1, k, j) + temp35b0
34869             fqxb(i, k) = 0.0
34870           END DO
34871           CALL POPINTEGER4(k)
34872         END IF
34873       END DO
34874     END IF
34875     CALL POPCONTROL1B(branch)
34876     IF (branch .EQ. 0) THEN
34877       CALL POPINTEGER4(ad_from13)
34878       DO i=i_start_f-1,ad_from13,-1
34879         CALL POPCONTROL1B(branch)
34880         IF (branch .NE. 0) THEN
34881           k = ktf + 1
34882           temp31 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1, k&
34883 &            , j))
34884           temp34 = SIGN(1., vel)
34885           temp33 = temp34/12.0
34886           temp32 = SIGN(1, time_step)
34887           temp31b = vel*fqxb(i, k)
34888           temp31b0 = temp31b/12.0
34889           temp31b1 = temp32*temp33*temp31b
34890           velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j&
34891 &            ))/12.0+temp32*(temp33*temp31))*fqxb(i, k)
34892           wb0(i, k, j) = wb0(i, k, j) + 7.*temp31b0 - 3.*temp31b1
34893           wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp31b1 + 7.*temp31b0
34894           wb0(i+1, k, j) = wb0(i+1, k, j) + temp31b1 - temp31b0
34895           wb0(i-2, k, j) = wb0(i-2, k, j) - temp31b1 - temp31b0
34896           fqxb(i, k) = 0.0
34897           CALL POPREAL8(vel)
34898           rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
34899           rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
34900           DO k=ktf,kts+1,-1
34901             vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
34902             temp27 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1&
34903 &              , k, j))
34904             temp30 = SIGN(1., vel)
34905             temp29 = temp30/12.0
34906             temp28 = SIGN(1, time_step)
34907             temp27b5 = vel*fqxb(i, k)
34908             temp27b6 = temp27b5/12.0
34909             temp27b7 = temp28*temp29*temp27b5
34910             velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k&
34911 &              , j))/12.0+temp28*(temp29*temp27))*fqxb(i, k)
34912             wb0(i, k, j) = wb0(i, k, j) + 7.*temp27b6 - 3.*temp27b7
34913             wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp27b7 + 7.*temp27b6
34914             wb0(i+1, k, j) = wb0(i+1, k, j) + temp27b7 - temp27b6
34915             wb0(i-2, k, j) = wb0(i-2, k, j) - temp27b7 - temp27b6
34916             fqxb(i, k) = 0.0
34917             CALL POPREAL8(vel)
34918             rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
34919             rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
34920           END DO
34921           CALL POPINTEGER4(k)
34922         END IF
34923         CALL POPCONTROL1B(branch)
34924         IF (branch .EQ. 0) THEN
34925           k = ktf + 1
34926           temp27b3 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
34927           temp27b4 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2&
34928 &            , j))*fqxb(i, k)
34929           rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp27b3
34930           rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp27b3
34931           wb0(i, k, j) = wb0(i, k, j) + temp27b4
34932           wb0(i-1, k, j) = wb0(i-1, k, j) + temp27b4
34933           fqxb(i, k) = 0.0
34934           DO k=ktf,kts+1,-1
34935             temp27b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k)
34936             temp27b2 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
34937 &              fqxb(i, k)
34938             rub(i, k, j) = rub(i, k, j) + fzm(k)*temp27b1
34939             rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp27b1
34940             wb0(i, k, j) = wb0(i, k, j) + temp27b2
34941             wb0(i-1, k, j) = wb0(i-1, k, j) + temp27b2
34942             fqxb(i, k) = 0.0
34943           END DO
34944           CALL POPINTEGER4(k)
34945         END IF
34946       END DO
34947     END IF
34948     k = ktf + 1
34949     DO i=i_end_f,i_start_f,-1
34950       wi0 = gi0/(eps+beta0)**pw
34951       wi1 = gi1/(eps+beta1)**pw
34952       wi2 = gi2/(eps+beta2)**pw
34953       sumwk = wi0 + wi1 + wi2
34954       temp27b = vel*fqxb(i, k)/sumwk
34955       temp27b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk
34956       f0b = wi0*temp27b
34957       f1b = wi1*temp27b
34958       f2b = wi2*temp27b
34959       velb = temp27b0
34960       sumwkb = -(vel*temp27b0/sumwk)
34961       wi0b = sumwkb + f0*temp27b
34962       wi1b = sumwkb + f1*temp27b
34963       wi2b = sumwkb + f2*temp27b
34964       fqxb(i, k) = 0.0
34965       temp26 = (eps+beta2)**pw
34966       IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw))&
34967 &      ) THEN
34968         beta2b = 0.0
34969       ELSE
34970         beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp26**2)
34971       END IF
34972       temp25 = (eps+beta1)**pw
34973       IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw))&
34974 &      ) THEN
34975         beta1b = 0.0
34976       ELSE
34977         beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp25**2)
34978       END IF
34979       temp24 = (eps+beta0)**pw
34980       IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw))&
34981 &      ) THEN
34982         beta0b = 0.0
34983       ELSE
34984         beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp24**2)
34985       END IF
34986       CALL POPREAL8(beta2)
34987       temp24b1 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
34988       temp24b2 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
34989       qip2b = temp24b2 - f2b/6. + temp24b1
34990       CALL POPREAL8(beta1)
34991       temp24b3 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
34992       temp24b6 = 2*(qim1-qip1)*beta1b/4.
34993       qip1b = temp24b3 - temp24b6 + f1b/3. + 5.*f2b/6. - 4.*temp24b2 - &
34994 &        2.*temp24b1
34995       CALL POPREAL8(beta0)
34996       temp24b5 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
34997       temp24b4 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
34998       qib = f2b/3. - 2.*temp24b3 + 11.*f0b/6. + 5.*f1b/6. + 3.*temp24b4 &
34999 &        + temp24b5 + 3.*temp24b2 + temp24b1
35000       qim1b = temp24b6 - 4.*temp24b4 - 7.*f0b/6. - f1b/6. - 2.*temp24b5 &
35001 &        + temp24b3
35002       qim2b = f0b/3. + temp24b4 + temp24b5
35003       CALL POPREAL8(f2)
35004       CALL POPREAL8(f1)
35005       CALL POPREAL8(f0)
35006       CALL POPCONTROL1B(branch)
35007       IF (branch .EQ. 0) THEN
35008         CALL POPREAL8(qim2)
35009         wb0(i-3, k, j) = wb0(i-3, k, j) + qim2b
35010         CALL POPREAL8(qim1)
35011         wb0(i-2, k, j) = wb0(i-2, k, j) + qim1b
35012         CALL POPREAL8(qi)
35013         wb0(i-1, k, j) = wb0(i-1, k, j) + qib
35014         CALL POPREAL8(qip1)
35015         wb0(i, k, j) = wb0(i, k, j) + qip1b
35016         CALL POPREAL8(qip2)
35017         wb0(i+1, k, j) = wb0(i+1, k, j) + qip2b
35018       ELSE
35019         CALL POPREAL8(qim2)
35020         wb0(i+2, k, j) = wb0(i+2, k, j) + qim2b
35021         CALL POPREAL8(qim1)
35022         wb0(i+1, k, j) = wb0(i+1, k, j) + qim1b
35023         CALL POPREAL8(qi)
35024         wb0(i, k, j) = wb0(i, k, j) + qib
35025         CALL POPREAL8(qip1)
35026         wb0(i-1, k, j) = wb0(i-1, k, j) + qip1b
35027         CALL POPREAL8(qip2)
35028         wb0(i-2, k, j) = wb0(i-2, k, j) + qip2b
35029       END IF
35030       CALL POPREAL8(vel)
35031       rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb
35032       rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb
35033     END DO
35034     DO k=ktf,kts+1,-1
35035       DO i=i_end_f,i_start_f,-1
35036         wi0 = gi0/(eps+beta0)**pw
35037         wi1 = gi1/(eps+beta1)**pw
35038         wi2 = gi2/(eps+beta2)**pw
35039         sumwk = wi0 + wi1 + wi2
35040         vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
35041         temp24b = vel*fqxb(i, k)/sumwk
35042         temp24b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk
35043         f0b = wi0*temp24b
35044         f1b = wi1*temp24b
35045         f2b = wi2*temp24b
35046         velb = temp24b0
35047         sumwkb = -(vel*temp24b0/sumwk)
35048         wi0b = sumwkb + f0*temp24b
35049         wi1b = sumwkb + f1*temp24b
35050         wi2b = sumwkb + f2*temp24b
35051         fqxb(i, k) = 0.0
35052         temp23 = (eps+beta2)**pw
35053         IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
35054 &            )) THEN
35055           beta2b = 0.0
35056         ELSE
35057           beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp23**2)
35058         END IF
35059         temp22 = (eps+beta1)**pw
35060         IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
35061 &            )) THEN
35062           beta1b = 0.0
35063         ELSE
35064           beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp22**2)
35065         END IF
35066         temp21 = (eps+beta0)**pw
35067         IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)&
35068 &            )) THEN
35069           beta0b = 0.0
35070         ELSE
35071           beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp21**2)
35072         END IF
35073         CALL POPREAL8(beta2)
35074         temp21b = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
35075         temp21b0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
35076         qip2b = temp21b0 - f2b/6. + temp21b
35077         CALL POPREAL8(beta1)
35078         temp21b1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
35079         temp21b4 = 2*(qim1-qip1)*beta1b/4.
35080         qip1b = temp21b1 - temp21b4 + f1b/3. + 5.*f2b/6. - 4.*temp21b0 -&
35081 &          2.*temp21b
35082         CALL POPREAL8(beta0)
35083         temp21b3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
35084         temp21b2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
35085         qib = f2b/3. - 2.*temp21b1 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
35086 &          temp21b2 + temp21b3 + 3.*temp21b0 + temp21b
35087         qim1b = temp21b4 - 4.*temp21b2 - 7.*f0b/6. - f1b/6. - 2.*&
35088 &          temp21b3 + temp21b1
35089         qim2b = f0b/3. + temp21b2 + temp21b3
35090         CALL POPREAL8(f2)
35091         CALL POPREAL8(f1)
35092         CALL POPREAL8(f0)
35093         CALL POPCONTROL1B(branch)
35094         IF (branch .EQ. 0) THEN
35095           CALL POPREAL8(qim2)
35096           wb0(i-3, k, j) = wb0(i-3, k, j) + qim2b
35097           CALL POPREAL8(qim1)
35098           wb0(i-2, k, j) = wb0(i-2, k, j) + qim1b
35099           CALL POPREAL8(qi)
35100           wb0(i-1, k, j) = wb0(i-1, k, j) + qib
35101           CALL POPREAL8(qip1)
35102           wb0(i, k, j) = wb0(i, k, j) + qip1b
35103           CALL POPREAL8(qip2)
35104           wb0(i+1, k, j) = wb0(i+1, k, j) + qip2b
35105         ELSE
35106           CALL POPREAL8(qim2)
35107           wb0(i+2, k, j) = wb0(i+2, k, j) + qim2b
35108           CALL POPREAL8(qim1)
35109           wb0(i+1, k, j) = wb0(i+1, k, j) + qim1b
35110           CALL POPREAL8(qi)
35111           wb0(i, k, j) = wb0(i, k, j) + qib
35112           CALL POPREAL8(qip1)
35113           wb0(i-1, k, j) = wb0(i-1, k, j) + qip1b
35114           CALL POPREAL8(qip2)
35115           wb0(i-2, k, j) = wb0(i-2, k, j) + qip2b
35116         END IF
35117         CALL POPREAL8(vel)
35118         rub(i, k, j) = rub(i, k, j) + fzm(k)*velb
35119         rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb
35120       END DO
35121     END DO
35122     CALL POPINTEGER4(k)
35123   END DO
35124   fqyb = 0.0
35125   CALL POPINTEGER4(ad_from12)
35126   CALL POPINTEGER4(ad_to12)
35127   DO j=ad_to12,ad_from12,-1
35128     CALL POPINTEGER4(jp0)
35129     CALL POPINTEGER4(jp1)
35130     CALL POPCONTROL2B(branch)
35131     IF (branch .LT. 2) THEN
35132       IF (branch .EQ. 0) THEN
35133         DO k=ktf,kts,-1
35134           CALL POPINTEGER4(ad_from9)
35135           CALL POPINTEGER4(ad_to9)
35136           DO i=ad_to9,ad_from9,-1
35137             mrdy = msftx(i, j-1)*rdy
35138             fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1&
35139 &              )
35140           END DO
35141         END DO
35142         CALL POPINTEGER4(k)
35143       ELSE
35144         DO k=ktf,kts,-1
35145           CALL POPINTEGER4(ad_from10)
35146           CALL POPINTEGER4(ad_to10)
35147           DO i=ad_to10,ad_from10,-1
35148             mrdy = msftx(i, j-1)*rdy
35149             fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1&
35150 &              )
35151           END DO
35152         END DO
35153         CALL POPINTEGER4(k)
35154       END IF
35155     ELSE IF (branch .EQ. 2) THEN
35156       DO k=ktf+1,kts+1,-1
35157         CALL POPINTEGER4(ad_from11)
35158         CALL POPINTEGER4(ad_to11)
35159         DO i=ad_to11,ad_from11,-1
35160           mrdy = msftx(i, j-1)*rdy
35161           fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1)
35162           fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1)
35163         END DO
35164       END DO
35165       CALL POPINTEGER4(k)
35166     END IF
35167     CALL POPCONTROL3B(branch)
35168     IF (branch .LT. 3) THEN
35169       IF (branch .EQ. 0) THEN
35170         CALL POPINTEGER4(ad_from0)
35171         CALL POPINTEGER4(ad_to0)
35172         DO i=ad_to0,ad_from0,-1
35173           wi0 = gi0/(eps+beta0)**pw
35174           wi1 = gi1/(eps+beta1)**pw
35175           wi2 = gi2/(eps+beta2)**pw
35176           sumwk = wi0 + wi1 + wi2
35177           temp5b = vel*fqyb(i, k, jp1)/sumwk
35178           temp5b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk
35179           f0b = wi0*temp5b
35180           f1b = wi1*temp5b
35181           f2b = wi2*temp5b
35182           velb = temp5b0
35183           sumwkb = -(vel*temp5b0/sumwk)
35184           wi0b = sumwkb + f0*temp5b
35185           wi1b = sumwkb + f1*temp5b
35186           wi2b = sumwkb + f2*temp5b
35187           fqyb(i, k, jp1) = 0.0
35188           temp4 = (eps+beta2)**pw
35189           IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
35190 &              pw))) THEN
35191             beta2b = 0.0
35192           ELSE
35193             beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp4**2)
35194           END IF
35195           temp3 = (eps+beta1)**pw
35196           IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
35197 &              pw))) THEN
35198             beta1b = 0.0
35199           ELSE
35200             beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp3**2)
35201           END IF
35202           temp2 = (eps+beta0)**pw
35203           IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(&
35204 &              pw))) THEN
35205             beta0b = 0.0
35206           ELSE
35207             beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp2**2)
35208           END IF
35209           CALL POPREAL8(beta2)
35210           temp2b1 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
35211           temp2b2 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
35212           qip2b = temp2b2 - f2b/6. + temp2b1
35213           CALL POPREAL8(beta1)
35214           temp2b3 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
35215           temp2b6 = 2*(qim1-qip1)*beta1b/4.
35216           qip1b = temp2b3 - temp2b6 + f1b/3. + 5.*f2b/6. - 4.*temp2b2 - &
35217 &            2.*temp2b1
35218           CALL POPREAL8(beta0)
35219           temp2b5 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
35220           temp2b4 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
35221           qib = f2b/3. - 2.*temp2b3 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
35222 &            temp2b4 + temp2b5 + 3.*temp2b2 + temp2b1
35223           qim1b = temp2b6 - 4.*temp2b4 - 7.*f0b/6. - f1b/6. - 2.*temp2b5&
35224 &            + temp2b3
35225           qim2b = f0b/3. + temp2b4 + temp2b5
35226           CALL POPREAL8(f2)
35227           CALL POPREAL8(f1)
35228           CALL POPREAL8(f0)
35229           CALL POPCONTROL1B(branch)
35230           IF (branch .EQ. 0) THEN
35231             CALL POPREAL8(qim2)
35232             wb0(i, k, j-3) = wb0(i, k, j-3) + qim2b
35233             CALL POPREAL8(qim1)
35234             wb0(i, k, j-2) = wb0(i, k, j-2) + qim1b
35235             CALL POPREAL8(qi)
35236             wb0(i, k, j-1) = wb0(i, k, j-1) + qib
35237             CALL POPREAL8(qip1)
35238             wb0(i, k, j) = wb0(i, k, j) + qip1b
35239             CALL POPREAL8(qip2)
35240             wb0(i, k, j+1) = wb0(i, k, j+1) + qip2b
35241           ELSE
35242             CALL POPREAL8(qim2)
35243             wb0(i, k, j+2) = wb0(i, k, j+2) + qim2b
35244             CALL POPREAL8(qim1)
35245             wb0(i, k, j+1) = wb0(i, k, j+1) + qim1b
35246             CALL POPREAL8(qi)
35247             wb0(i, k, j) = wb0(i, k, j) + qib
35248             CALL POPREAL8(qip1)
35249             wb0(i, k, j-1) = wb0(i, k, j-1) + qip1b
35250             CALL POPREAL8(qip2)
35251             wb0(i, k, j-2) = wb0(i, k, j-2) + qip2b
35252           END IF
35253           CALL POPREAL8(vel)
35254           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
35255           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
35256         END DO
35257         DO k=ktf,kts+1,-1
35258           CALL POPINTEGER4(ad_from)
35259           CALL POPINTEGER4(ad_to)
35260           DO i=ad_to,ad_from,-1
35261             wi0 = gi0/(eps+beta0)**pw
35262             wi1 = gi1/(eps+beta1)**pw
35263             wi2 = gi2/(eps+beta2)**pw
35264             sumwk = wi0 + wi1 + wi2
35265             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
35266             temp2b = vel*fqyb(i, k, jp1)/sumwk
35267             temp2b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk
35268             f0b = wi0*temp2b
35269             f1b = wi1*temp2b
35270             f2b = wi2*temp2b
35271             velb = temp2b0
35272             sumwkb = -(vel*temp2b0/sumwk)
35273             wi0b = sumwkb + f0*temp2b
35274             wi1b = sumwkb + f1*temp2b
35275             wi2b = sumwkb + f2*temp2b
35276             fqyb(i, k, jp1) = 0.0
35277             temp1 = (eps+beta2)**pw
35278             IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
35279 &                (pw))) THEN
35280               beta2b = 0.0
35281             ELSE
35282               beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2)
35283             END IF
35284             temp0 = (eps+beta1)**pw
35285             IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
35286 &                (pw))) THEN
35287               beta1b = 0.0
35288             ELSE
35289               beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2)
35290             END IF
35291             temp = (eps+beta0)**pw
35292             IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT&
35293 &                (pw))) THEN
35294               beta0b = 0.0
35295             ELSE
35296               beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2)
35297             END IF
35298             CALL POPREAL8(beta2)
35299             tempb = 13.*2*(qi-2.*qip1+qip2)*beta2b/12.
35300             tempb0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4.
35301             qip2b = tempb0 - f2b/6. + tempb
35302             CALL POPREAL8(beta1)
35303             tempb1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12.
35304             tempb4 = 2*(qim1-qip1)*beta1b/4.
35305             qip1b = tempb1 - tempb4 + f1b/3. + 5.*f2b/6. - 4.*tempb0 - &
35306 &              2.*tempb
35307             CALL POPREAL8(beta0)
35308             tempb3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12.
35309             tempb2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4.
35310             qib = f2b/3. - 2.*tempb1 + 11.*f0b/6. + 5.*f1b/6. + 3.*&
35311 &              tempb2 + tempb3 + 3.*tempb0 + tempb
35312             qim1b = tempb4 - 4.*tempb2 - 7.*f0b/6. - f1b/6. - 2.*tempb3 &
35313 &              + tempb1
35314             qim2b = f0b/3. + tempb2 + tempb3
35315             CALL POPREAL8(f2)
35316             CALL POPREAL8(f1)
35317             CALL POPREAL8(f0)
35318             CALL POPCONTROL1B(branch)
35319             IF (branch .EQ. 0) THEN
35320               CALL POPREAL8(qim2)
35321               wb0(i, k, j-3) = wb0(i, k, j-3) + qim2b
35322               CALL POPREAL8(qim1)
35323               wb0(i, k, j-2) = wb0(i, k, j-2) + qim1b
35324               CALL POPREAL8(qi)
35325               wb0(i, k, j-1) = wb0(i, k, j-1) + qib
35326               CALL POPREAL8(qip1)
35327               wb0(i, k, j) = wb0(i, k, j) + qip1b
35328               CALL POPREAL8(qip2)
35329               wb0(i, k, j+1) = wb0(i, k, j+1) + qip2b
35330             ELSE
35331               CALL POPREAL8(qim2)
35332               wb0(i, k, j+2) = wb0(i, k, j+2) + qim2b
35333               CALL POPREAL8(qim1)
35334               wb0(i, k, j+1) = wb0(i, k, j+1) + qim1b
35335               CALL POPREAL8(qi)
35336               wb0(i, k, j) = wb0(i, k, j) + qib
35337               CALL POPREAL8(qip1)
35338               wb0(i, k, j-1) = wb0(i, k, j-1) + qip1b
35339               CALL POPREAL8(qip2)
35340               wb0(i, k, j-2) = wb0(i, k, j-2) + qip2b
35341             END IF
35342             CALL POPREAL8(vel)
35343             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
35344             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
35345           END DO
35346         END DO
35347         CALL POPINTEGER4(k)
35348       ELSE IF (branch .EQ. 1) THEN
35349         CALL POPINTEGER4(ad_from2)
35350         CALL POPINTEGER4(ad_to2)
35351         DO i=ad_to2,ad_from2,-1
35352           temp5b3 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
35353           temp5b4 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2&
35354 &            , j))*fqyb(i, k, jp1)
35355           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp5b3
35356           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp5b3
35357           wb0(i, k, j) = wb0(i, k, j) + temp5b4
35358           wb0(i, k, j-1) = wb0(i, k, j-1) + temp5b4
35359           fqyb(i, k, jp1) = 0.0
35360         END DO
35361         DO k=ktf,kts+1,-1
35362           CALL POPINTEGER4(ad_from1)
35363           CALL POPINTEGER4(ad_to1)
35364           DO i=ad_to1,ad_from1,-1
35365             temp5b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
35366             temp5b2 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*fqyb&
35367 &              (i, k, jp1)
35368             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp5b1
35369             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp5b1
35370             wb0(i, k, j) = wb0(i, k, j) + temp5b2
35371             wb0(i, k, j-1) = wb0(i, k, j-1) + temp5b2
35372             fqyb(i, k, jp1) = 0.0
35373           END DO
35374         END DO
35375         CALL POPINTEGER4(k)
35376       ELSE
35377         CALL POPINTEGER4(ad_from4)
35378         CALL POPINTEGER4(ad_to4)
35379         DO i=ad_to4,ad_from4,-1
35380           temp9 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, j&
35381 &            -1))
35382           temp12 = SIGN(1., vel)
35383           temp11 = temp12/12.0
35384           temp10 = SIGN(1, time_step)
35385           temp9b = vel*fqyb(i, k, jp1)
35386           temp9b0 = temp9b/12.0
35387           temp9b1 = temp10*temp11*temp9b
35388           velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2&
35389 &            ))/12.0+temp10*(temp11*temp9))*fqyb(i, k, jp1)
35390           wb0(i, k, j) = wb0(i, k, j) + 7.*temp9b0 - 3.*temp9b1
35391           wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp9b1 + 7.*temp9b0
35392           wb0(i, k, j+1) = wb0(i, k, j+1) + temp9b1 - temp9b0
35393           wb0(i, k, j-2) = wb0(i, k, j-2) - temp9b1 - temp9b0
35394           fqyb(i, k, jp1) = 0.0
35395           CALL POPREAL8(vel)
35396           rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
35397           rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
35398         END DO
35399         DO k=ktf,kts+1,-1
35400           CALL POPINTEGER4(ad_from3)
35401           CALL POPINTEGER4(ad_to3)
35402           DO i=ad_to3,ad_from3,-1
35403             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
35404             temp5 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k&
35405 &              , j-1))
35406             temp8 = SIGN(1., vel)
35407             temp7 = temp8/12.0
35408             temp6 = SIGN(1, time_step)
35409             temp5b5 = vel*fqyb(i, k, jp1)
35410             temp5b6 = temp5b5/12.0
35411             temp5b7 = temp6*temp7*temp5b5
35412             velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j&
35413 &              -2))/12.0+temp6*(temp7*temp5))*fqyb(i, k, jp1)
35414             wb0(i, k, j) = wb0(i, k, j) + 7.*temp5b6 - 3.*temp5b7
35415             wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp5b7 + 7.*temp5b6
35416             wb0(i, k, j+1) = wb0(i, k, j+1) + temp5b7 - temp5b6
35417             wb0(i, k, j-2) = wb0(i, k, j-2) - temp5b7 - temp5b6
35418             fqyb(i, k, jp1) = 0.0
35419             CALL POPREAL8(vel)
35420             rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
35421             rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
35422           END DO
35423         END DO
35424         CALL POPINTEGER4(k)
35425       END IF
35426     ELSE IF (branch .EQ. 3) THEN
35427       CALL POPINTEGER4(ad_from6)
35428       CALL POPINTEGER4(ad_to6)
35429       DO i=ad_to6,ad_from6,-1
35430         temp13b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
35431         temp13b2 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, &
35432 &          j))*fqyb(i, k, jp1)
35433         rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp13b1
35434         rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp13b1
35435         wb0(i, k, j) = wb0(i, k, j) + temp13b2
35436         wb0(i, k, j-1) = wb0(i, k, j-1) + temp13b2
35437         fqyb(i, k, jp1) = 0.0
35438       END DO
35439       DO k=ktf,kts+1,-1
35440         CALL POPINTEGER4(ad_from5)
35441         CALL POPINTEGER4(ad_to5)
35442         DO i=ad_to5,ad_from5,-1
35443           temp13b = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1)
35444           temp13b0 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*fqyb(&
35445 &            i, k, jp1)
35446           rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp13b
35447           rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp13b
35448           wb0(i, k, j) = wb0(i, k, j) + temp13b0
35449           wb0(i, k, j-1) = wb0(i, k, j-1) + temp13b0
35450           fqyb(i, k, jp1) = 0.0
35451         END DO
35452       END DO
35453       CALL POPINTEGER4(k)
35454     ELSE IF (branch .EQ. 4) THEN
35455       CALL POPINTEGER4(ad_from8)
35456       CALL POPINTEGER4(ad_to8)
35457       DO i=ad_to8,ad_from8,-1
35458         temp17 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, j-&
35459 &          1))
35460         temp20 = SIGN(1., vel)
35461         temp19 = temp20/12.0
35462         temp18 = SIGN(1, time_step)
35463         temp17b = vel*fqyb(i, k, jp1)
35464         temp17b0 = temp17b/12.0
35465         temp17b1 = temp18*temp19*temp17b
35466         velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2))&
35467 &          /12.0+temp18*(temp19*temp17))*fqyb(i, k, jp1)
35468         wb0(i, k, j) = wb0(i, k, j) + 7.*temp17b0 - 3.*temp17b1
35469         wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp17b1 + 7.*temp17b0
35470         wb0(i, k, j+1) = wb0(i, k, j+1) + temp17b1 - temp17b0
35471         wb0(i, k, j-2) = wb0(i, k, j-2) - temp17b1 - temp17b0
35472         fqyb(i, k, jp1) = 0.0
35473         CALL POPREAL8(vel)
35474         rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb
35475         rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb
35476       END DO
35477       DO k=ktf,kts+1,-1
35478         CALL POPINTEGER4(ad_from7)
35479         CALL POPINTEGER4(ad_to7)
35480         DO i=ad_to7,ad_from7,-1
35481           vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
35482           temp13 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, &
35483 &            j-1))
35484           temp16 = SIGN(1., vel)
35485           temp15 = temp16/12.0
35486           temp14 = SIGN(1, time_step)
35487           temp13b3 = vel*fqyb(i, k, jp1)
35488           temp13b4 = temp13b3/12.0
35489           temp13b5 = temp14*temp15*temp13b3
35490           velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2&
35491 &            ))/12.0+temp14*(temp15*temp13))*fqyb(i, k, jp1)
35492           wb0(i, k, j) = wb0(i, k, j) + 7.*temp13b4 - 3.*temp13b5
35493           wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp13b5 + 7.*temp13b4
35494           wb0(i, k, j+1) = wb0(i, k, j+1) + temp13b5 - temp13b4
35495           wb0(i, k, j-2) = wb0(i, k, j-2) - temp13b5 - temp13b4
35496           fqyb(i, k, jp1) = 0.0
35497           CALL POPREAL8(vel)
35498           rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb
35499           rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb
35500         END DO
35501       END DO
35502       CALL POPINTEGER4(k)
35503     END IF
35504   END DO
35505   CALL POPCONTROL1B(branch)
35506   CALL POPCONTROL1B(branch)
35507   CALL POPCONTROL1B(branch)
35508   CALL POPCONTROL1B(branch)
35509 END SUBROUTINE A_ADVECT_WENO_W
35510
35511 END MODULE a_module_advect_em
35512