! ====================================================================================== ! This file was generated by the version 4.3.7 of ADG on 07/17/2010. The Adjoint Code ! Generator (ADG) was developed and sponsored by LASG of IAP (1999-2010) ! The Copyright of the ADG system was declared by Walls at LASG, 1999-2010 ! ====================================================================================== MODULE a_module_advect_em USE module_bc USE module_model_constants USE module_wrf_error CONTAINS ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35 ! ! Differentiation of advect_u in reverse (adjoint) mode: ! gradient of useful results: rom u tendency u_old ru rv ! mut ! with respect to varying inputs: rom u tendency u_old ru rv ! mut ! RW status of diff variables: rom:incr u:incr tendency:in-out ! u_old:incr ru:incr rv:incr mut:incr SUBROUTINE A_ADVECT_U(u, ub0, u_old, u_oldb, tendency, tendencyb, ru, & & rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux, & & msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide& & , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte& & , kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru& & , rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ub0, u_oldb, rub, rvb, & & romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, jms:jme) :: mutb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip INTEGER :: jp1, jp0, jtmp INTEGER :: horz_order, vert_order REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp REAL :: ubb, vbb, vwb, dvmb, dvpb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: branch INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 INTEGER :: ad_from24 INTEGER :: ad_to24 INTEGER :: ad_from25 INTEGER :: ad_to25 INTEGER :: ad_from26 INTEGER :: ad_to26 INTEGER :: ad_from27 INTEGER :: ad_to27 INTEGER :: ad_from28 INTEGER :: ad_to28 INTEGER :: ad_from29 INTEGER :: ad_to29 INTEGER :: ad_from30 INTEGER :: ad_to30 INTEGER :: ad_from31 INTEGER :: ad_to31 INTEGER :: ad_from32 INTEGER :: ad_to32 INTEGER :: ad_from33 INTEGER :: ad_to33 INTEGER :: ad_from34 INTEGER :: ad_to34 INTEGER :: ad_from35 INTEGER :: ad_to35 INTEGER :: ad_from36 INTEGER :: ad_to36 INTEGER :: ad_from37 INTEGER :: ad_to37 INTEGER :: ad_from38 INTEGER :: ad_to38 INTEGER :: ad_from39 INTEGER :: ad_to39 INTEGER :: ad_from40 INTEGER :: ad_to40 INTEGER :: ad_from41 INTEGER :: ad_to41 INTEGER :: ad_from42 INTEGER :: ad_to42 INTEGER :: ad_from43 INTEGER :: ad_to43 INTEGER :: ad_from44 INTEGER :: ad_to44 INTEGER :: ad_from45 INTEGER :: ad_to45 INTEGER :: ad_from46 INTEGER :: ad_to46 INTEGER :: ad_from47 INTEGER :: ad_to47 INTEGER :: ad_from48 INTEGER :: ad_to48 REAL :: temp3 REAL :: temp29 REAL :: temp31b43 REAL :: temp2 INTEGER :: temp28 REAL :: temp31b42 REAL :: temp1 REAL :: temp27 REAL :: temp31b41 INTEGER :: temp0 REAL :: temp26 REAL :: temp31b40 REAL :: temp7b REAL :: temp25 INTEGER :: temp24 REAL :: temp23 REAL :: temp22 REAL :: temp21 REAL :: temp35b3 INTEGER :: temp20 REAL :: temp35b2 REAL :: temp35b1 REAL :: temp35b0 REAL :: temp23b9 REAL :: temp23b8 REAL :: temp19b REAL :: temp23b7 REAL :: temp23b6 REAL :: temp27b REAL :: temp23b5 REAL :: temp35b REAL :: tempb1 REAL :: temp23b4 REAL :: temp43b REAL :: tempb0 REAL :: temp23b3 REAL :: temp23b2 REAL :: temp23b1 REAL :: temp23b0 REAL :: temp31b39 REAL :: temp31b38 REAL :: temp7b3 REAL :: temp31b37 REAL :: temp3b REAL :: temp7b2 REAL :: temp31b36 REAL :: temp7b1 REAL :: temp31b35 REAL :: temp7b0 REAL :: temp31b34 REAL :: temp19 REAL :: temp31b33 REAL :: temp18 REAL :: temp31b32 REAL :: temp17 REAL :: temp31b31 INTEGER :: temp16 REAL :: temp23b11 REAL :: temp31b30 REAL :: temp43b8 REAL :: temp15 REAL :: temp23b10 REAL :: temp43b7 REAL :: temp14 REAL :: temp11b1 REAL :: temp43b6 REAL :: temp13 REAL :: temp11b0 REAL :: temp43b5 INTEGER :: temp12 REAL :: temp43b4 REAL :: temp11 REAL :: temp43b3 REAL :: temp10 REAL :: temp43b2 REAL :: temp15b REAL :: temp43b1 REAL :: temp46 REAL :: temp23b REAL :: temp43b0 REAL :: temp45 REAL :: temp31b INTEGER :: temp44 REAL :: temp43 REAL :: temp42 REAL :: temp19b3 REAL :: temp31b9 REAL :: temp41 REAL :: temp19b2 REAL :: temp31b8 INTEGER :: temp40 REAL :: temp19b1 REAL :: temp31b7 REAL :: temp19b0 REAL :: temp31b6 REAL :: temp31b5 REAL :: temp31b4 REAL :: temp31b3 REAL :: tempb REAL :: temp31b2 REAL :: temp31b1 REAL :: temp31b0 REAL :: temp31b29 REAL :: temp31b28 REAL :: temp31b27 REAL :: temp31b26 REAL :: temp31b25 REAL :: temp31b24 REAL :: temp31b23 REAL :: temp31b22 REAL :: temp31b21 REAL :: temp11b REAL :: temp31b20 REAL :: temp39b1 REAL :: temp39b0 REAL :: temp31b54 REAL :: temp31b53 REAL :: temp39 REAL :: temp31b52 REAL :: temp38 REAL :: temp3b3 REAL :: temp27b9 REAL :: temp31b51 REAL :: temp37 REAL :: temp3b2 REAL :: temp27b8 REAL :: temp31b50 INTEGER :: temp36 REAL :: temp3b1 REAL :: temp27b7 REAL :: temp35 REAL :: temp3b0 REAL :: temp27b6 REAL :: temp34 REAL :: temp27b5 REAL :: temp33 REAL :: temp27b4 INTEGER :: temp32 REAL :: temp27b3 REAL :: temp31 REAL :: temp27b2 REAL :: temp30 REAL :: temp27b1 REAL :: temp27b0 INTRINSIC MIN REAL :: temp31b19 REAL :: temp31b18 REAL :: temp31b17 REAL :: temp15b3 REAL :: temp31b16 REAL :: temp REAL :: temp15b2 REAL :: temp31b15 REAL :: temp15b1 REAL :: temp31b14 REAL :: temp15b0 REAL :: temp31b13 REAL :: temp9 REAL :: temp31b12 REAL :: temp31b49 REAL :: temp47b4 INTEGER :: temp8 REAL :: temp31b11 REAL :: temp31b48 REAL :: temp39b REAL :: temp47b3 REAL :: temp7 REAL :: temp31b10 REAL :: temp31b47 REAL :: temp47b REAL :: temp47b2 REAL :: temp6 REAL :: temp31b46 REAL :: temp47b1 REAL :: temp5 REAL :: temp31b45 REAL :: temp47b0 INTEGER :: temp4 REAL :: temp31b44 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. ! set order for vertical and horzontal flux operators horz_order = config_flags%h_mom_adv_order vert_order = config_flags%v_mom_adv_order IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF ! begin with horizontal flux divergence IF (horz_order .EQ. 6) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = ite IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from42 = j_start j_loop_y_flux_6:DO j=ad_from42,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from34 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from34) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! we must be close to some boundary where we need to reduce the order of the stencil ! 2nd order flux next to south boundary DO k=kts,ktf ad_from35 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from35) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from36 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from36) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from37 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from37) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN ! 3rd order flux 2 in from north boundary DO k=kts,ktf ad_from38 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from38) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from39 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from39) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN ! This would be seen by (j > j_start) but we need to zero out the NP tendency DO k=kts,ktf ad_from40 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from40) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from41 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from41) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_6 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from42) ! next, x - flux divergence i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF i_start_f = ids + 3 END IF IF (degrade_xe) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF i_end_f = ide - 2 END IF ad_from44 = j_start ! compute fluxes DO j=ad_from44,j_end ! 5th or 6th order flux DO k=kts,ktf CALL PUSHINTEGER4(i) END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF (degrade_xs) THEN IF (i_start .EQ. ids + 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ids + 1 DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i-1, k, j) IF (specified .AND. u(i, k, j) .LT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF CALL PUSHINTEGER4(i) i = ids + 2 CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN IF (i_end .EQ. ide - 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ide DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i, k, j) IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN ub = u(i-1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF DO k=kts,ktf CALL PUSHINTEGER4(i) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from43 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from43) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from44) CALL PUSHCONTROL3B(0) ELSE IF (horz_order .EQ. 5) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = ite IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from7 = j_start j_loop_y_flux_5:DO j=ad_from7,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! we must be close to some boundary where we need to reduce the order of the stencil ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN ! 3rd order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from4 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN ! This would be seen by (j > j_start) but we need to zero out the NP tendency DO k=kts,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from7) ! next, x - flux divergence i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF i_start_f = ids + 3 END IF IF (degrade_xe) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF i_end_f = ide - 2 END IF ad_from9 = j_start ! compute fluxes DO j=ad_from9,j_end ! 5th or 6th order flux DO k=kts,ktf CALL PUSHINTEGER4(i) END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF (degrade_xs) THEN IF (i_start .EQ. ids + 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ids + 1 DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i-1, k, j) IF (specified .AND. u(i, k, j) .LT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF CALL PUSHINTEGER4(i) i = ids + 2 CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN IF (i_end .EQ. ide - 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ide DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i, k, j) IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN ub = u(i-1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF DO k=kts,ktf CALL PUSHINTEGER4(i) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from8 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from8) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from9) CALL PUSHCONTROL3B(1) ELSE IF (horz_order .EQ. 4) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 1) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. !--------------- x - advection first i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 1 i_end_f = ide - 1 END IF ad_from11 = j_start ! compute fluxes DO j=ad_from11,j_end DO k=kts,ktf CALL PUSHINTEGER4(i) END DO ! second order flux close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF (degrade_xs) THEN CALL PUSHINTEGER4(i) i = i_start DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i-1, k, j) IF (specified .AND. u(i, k, j) .LT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHINTEGER4(i) i = i_end + 1 DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i, k, j) IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN ub = u(i-1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from10 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from10) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from11) ! y flux divergence i_start = its i_end = ite IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 !CJM these may not work with tiling because they define j_start and end in terms of domain dim IF (degrade_ys) THEN j_start = jds + 1 j_start_f = j_start + 1 END IF IF (degrade_ye) THEN j_end = jde - 2 j_end_f = jde - 2 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! j flux loop for v flux of u momentum jp1 = 2 jp0 = 1 ad_from18 = j_start DO j=ad_from18,j_end+1 IF (j .LT. j_start_f .AND. degrade_ys) THEN DO k=kts,ktf ad_from12 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) END DO CALL PUSHCONTROL2B(0) ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN DO k=kts,ktf ad_from13 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) END DO CALL PUSHCONTROL2B(1) ELSE ! 3rd or 4th order flux DO k=kts,ktf ad_from14 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO CALL PUSHCONTROL2B(2) END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from15 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from15) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN ! This would be seen by (j > j_start) but we need to zero out the NP tendency DO k=kts,ktf ad_from16 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from16) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from17 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from17) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from18) CALL PUSHCONTROL3B(2) ELSE IF (horz_order .EQ. 3) THEN ! As with the 5th and 6th order flux chioces, the 3rd and 4th order ! code is EXACTLY the same EXCEPT for the flux operator. ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 1) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. !--------------- x - advection first i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 1 i_end_f = ide - 1 END IF ad_from20 = j_start ! compute fluxes DO j=ad_from20,j_end DO k=kts,ktf CALL PUSHINTEGER4(i) END DO ! second order flux close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF (degrade_xs) THEN CALL PUSHINTEGER4(i) i = i_start DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i-1, k, j) IF (specified .AND. u(i, k, j) .LT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHINTEGER4(i) i = i_end + 1 DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i, k, j) IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN ub = u(i-1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from19 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from19) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from20) ! y flux divergence i_start = its i_end = ite IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 !CJM these may not work with tiling because they define j_start and end in terms of domain dim IF (degrade_ys) THEN j_start = jds + 1 j_start_f = j_start + 1 END IF IF (degrade_ye) THEN j_end = jde - 2 j_end_f = jde - 2 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! j flux loop for v flux of u momentum jp1 = 2 jp0 = 1 ad_from27 = j_start DO j=ad_from27,j_end+1 IF (j .LT. j_start_f .AND. degrade_ys) THEN DO k=kts,ktf ad_from21 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from21) END DO CALL PUSHCONTROL2B(0) ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN DO k=kts,ktf ad_from22 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from22) END DO CALL PUSHCONTROL2B(1) ELSE ! 3rd or 4th order flux DO k=kts,ktf ad_from23 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) END DO CALL PUSHCONTROL2B(2) END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from24 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from24) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN ! This would be seen by (j > j_start) but we need to zero out the NP tendency DO k=kts,ktf ad_from25 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from25) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from26 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from26) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from27) CALL PUSHCONTROL3B(3) ELSE IF (horz_order .EQ. 2) THEN i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF IF (config_flags%open_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (specified) THEN IF (ids + 2 .LT. its) THEN i_start = its ELSE i_start = ids + 2 END IF END IF IF (specified) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite ad_from29 = j_start DO j=ad_from29,j_end DO k=kts,ktf ad_from28 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from28) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from29) IF (specified .AND. its .LE. ids + 1 .AND. (.NOT.config_flags%& & periodic_x)) THEN ad_from30 = j_start DO j=ad_from30,j_end DO k=kts,ktf i = ids + 1 CALL PUSHREAL8(ub) ! ADT eqn 44, 1st term on RHS ub = u(i-1, k, j) IF (u(i, k, j) .LT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from30) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (specified .AND. ite .GE. ide - 1 .AND. (.NOT.config_flags%& & periodic_x)) THEN ad_from31 = j_start DO j=ad_from31,j_end DO k=kts,ktf i = ide - 1 CALL PUSHREAL8(ub) ! ADT eqn 44, 1st term on RHS ub = u(i+1, k, j) IF (u(i, k, j) .GT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from31) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .OR. specified) THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF (config_flags%open_ye .OR. specified) THEN IF (jde - 2 .GT. jte) THEN j_end = jte ELSE j_end = jde - 2 END IF END IF ad_from33 = j_start DO j=ad_from33,j_end DO k=kts,ktf ad_from32 = i_start CALL PUSHINTEGER4(i) DO i=ad_from32,i_end ! ADT eqn 44, 1st term on RHS ! Comments for polar boundary condition ! Flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds) THEN CALL PUSHCONTROL2B(2) ELSE IF (config_flags%polar .AND. j .EQ. jde - 1) THEN CALL PUSHCONTROL2B(1) ELSE CALL PUSHCONTROL2B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from32) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from33) CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! radiative lateral boundary condition in x for normal velocity (u) IF (config_flags%open_xs .AND. its .EQ. ids) THEN CALL PUSHINTEGER4(j_start) j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ad_from45 = j_start DO j=ad_from45,j_end DO k=kts,ktf IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = ru(its, k, j) - cb*mut(its, j) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from45) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN CALL PUSHINTEGER4(j_start) j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ad_from46 = j_start DO j=ad_from46,j_end DO k=kts,ktf IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = ru(ite, k, j) + cb*mut(ite-1, j) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from46) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb') ! first, set to index ranges i_start = its IF (ite .GT. ide) THEN i_end = ide ELSE i_end = ite END IF imin = ids imax = ide - 1 IF (config_flags%open_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF imin = ids END IF IF (config_flags%open_xe) THEN IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF imax = ide - 1 END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from47 = i_start CALL PUSHINTEGER4(i) DO i=ad_from47,i_end CALL PUSHREAL8(mrdy) ! ADT eqn 44, 2nd term on RHS mrdy = msfux(i, jts)*rdy IF (imax .GT. i) THEN CALL PUSHINTEGER4(ip) ip = i CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(ip) ip = imax CALL PUSHCONTROL1B(1) END IF IF (imin .LT. i - 1) THEN CALL PUSHINTEGER4(im) im = i - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(im) im = imin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts)) IF (vw .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from47) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from48 = i_start CALL PUSHINTEGER4(i) DO i=ad_from48,i_end CALL PUSHREAL8(mrdy) ! ADT eqn 44, 2nd term on RHS mrdy = msfux(i, jte-1)*rdy IF (imax .GT. i) THEN CALL PUSHINTEGER4(ip) ip = i CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(ip) ip = imax CALL PUSHCONTROL1B(1) END IF IF (imin .LT. i - 1) THEN CALL PUSHINTEGER4(im) im = i - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(im) im = imin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte)) IF (vw .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from48) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w) ! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my) ! Since 'my' (map scale factor in y-direction) isn't a function of z, ! this is what we need, so leave unchanged in advect_u i_start = its i_end = ite CALL PUSHINTEGER4(j_start) j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) ! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) IF (config_flags%open_ys .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_ye .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite IF (vert_order .EQ. 6) THEN DO j=j_start,j_end DO k=kts+3,ktf-2 CALL PUSHINTEGER4(i) END DO CALL PUSHINTEGER4(i) CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp31b46 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i& & , k) temp31b47 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp31b46 romb(i-1, k, j) = romb(i-1, k, j) + temp31b46 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp31b47 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp31b47 vfluxb(i, k) = 0.0 k = ktf - 1 vel = 0.5*(rom(i, k, j)+rom(i-1, k, j)) temp31b48 = vel*vfluxb(i, k)/12.0 velb = (7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))*& & vfluxb(i, k)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b48 ub0(i, k-1, j) = ub0(i, k-1, j) + 7.*temp31b48 ub0(i, k+1, j) = ub0(i, k+1, j) - temp31b48 ub0(i, k-2, j) = ub0(i, k-2, j) - temp31b48 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i-1, k, j)) temp31b49 = vel*vfluxb(i, k)/12.0 velb = (7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))*& & vfluxb(i, k)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b49 ub0(i, k-1, j) = ub0(i, k-1, j) + 7.*temp31b49 ub0(i, k+1, j) = ub0(i, k+1, j) - temp31b49 ub0(i, k-2, j) = ub0(i, k-2, j) - temp31b49 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb k = kts + 1 temp31b50 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i& & , k) temp31b51 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp31b50 romb(i-1, k, j) = romb(i-1, k, j) + temp31b50 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp31b51 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp31b51 vfluxb(i, k) = 0.0 END DO CALL POPINTEGER4(i) DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i-1, k, j)+rom(i, k, j)) temp31b45 = vel*vfluxb(i, k)/60.0 velb = (37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1, j)+u(i, k-& & 2, j))+u(i, k+2, j)+u(i, k-3, j))*vfluxb(i, k)/60.0 ub0(i, k, j) = ub0(i, k, j) + 37.*temp31b45 ub0(i, k-1, j) = ub0(i, k-1, j) + 37.*temp31b45 ub0(i, k+1, j) = ub0(i, k+1, j) - 8.*temp31b45 ub0(i, k-2, j) = ub0(i, k-2, j) - 8.*temp31b45 ub0(i, k+2, j) = ub0(i, k+2, j) + temp31b45 ub0(i, k-3, j) = ub0(i, k-3, j) + temp31b45 vfluxb(i, k) = 0.0 romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb romb(i, k, j) = romb(i, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO ELSE IF (vert_order .EQ. 5) THEN DO j=j_start,j_end DO k=kts+3,ktf-2 CALL PUSHINTEGER4(i) END DO CALL PUSHINTEGER4(i) CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp43b = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, & & k) temp43b0 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp43b romb(i-1, k, j) = romb(i-1, k, j) + temp43b ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp43b0 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp43b0 vfluxb(i, k) = 0.0 k = ktf - 1 vel = 0.5*(rom(i, k, j)+rom(i-1, k, j)) temp39 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, & & j)) temp42 = SIGN(1., -vel) temp41 = temp42/12.0 temp40 = SIGN(1, time_step) temp39b = vel*vfluxb(i, k) temp39b0 = temp39b/12.0 temp39b1 = temp40*temp41*temp39b velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))& & /12.0+temp40*(temp41*temp39))*vfluxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp39b0 - 3.*temp39b1 ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp39b1 + 7.*temp39b0 ub0(i, k+1, j) = ub0(i, k+1, j) + temp39b1 - temp39b0 ub0(i, k-2, j) = ub0(i, k-2, j) - temp39b1 - temp39b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i-1, k, j)) temp35 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, & & j)) temp38 = SIGN(1., -vel) temp37 = temp38/12.0 temp36 = SIGN(1, time_step) temp35b = vel*vfluxb(i, k) temp35b0 = temp35b/12.0 temp35b1 = temp36*temp37*temp35b velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))& & /12.0+temp36*(temp37*temp35))*vfluxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp35b0 - 3.*temp35b1 ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp35b1 + 7.*temp35b0 ub0(i, k+1, j) = ub0(i, k+1, j) + temp35b1 - temp35b0 ub0(i, k-2, j) = ub0(i, k-2, j) - temp35b1 - temp35b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb k = kts + 1 temp35b2 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i& & , k) temp35b3 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp35b2 romb(i-1, k, j) = romb(i-1, k, j) + temp35b2 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp35b3 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp35b3 vfluxb(i, k) = 0.0 END DO CALL POPINTEGER4(i) DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i-1, k, j)+rom(i, k, j)) temp31 = u(i, k+2, j) - u(i, k-3, j) + 10.*(u(i, k, j)-u(i, k-& & 1, j)) - 5.*(u(i, k+1, j)-u(i, k-2, j)) temp34 = SIGN(1., -vel) temp33 = temp34/60.0 temp32 = SIGN(1, time_step) temp31b52 = vel*vfluxb(i, k) temp31b53 = temp31b52/60.0 temp31b54 = -(temp32*temp33*temp31b52) velb = ((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1, j)+u(i, k& & -2, j))+u(i, k+2, j)+u(i, k-3, j))/60.0-temp32*(temp33*& & temp31))*vfluxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 10.*temp31b54 + 37.*temp31b53 ub0(i, k-1, j) = ub0(i, k-1, j) + 37.*temp31b53 - 10.*& & temp31b54 ub0(i, k+1, j) = ub0(i, k+1, j) - 5.*temp31b54 - 8.*temp31b53 ub0(i, k-2, j) = ub0(i, k-2, j) + 5.*temp31b54 - 8.*temp31b53 ub0(i, k+2, j) = ub0(i, k+2, j) + temp31b54 + temp31b53 ub0(i, k-3, j) = ub0(i, k-3, j) + temp31b53 - temp31b54 vfluxb(i, k) = 0.0 romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb romb(i, k, j) = romb(i, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO ELSE IF (vert_order .EQ. 4) THEN DO j=j_start,j_end DO k=kts+2,ktf-1 CALL PUSHINTEGER4(i) END DO CALL PUSHINTEGER4(i) CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp43b2 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i& & , k) temp43b3 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp43b2 romb(i-1, k, j) = romb(i-1, k, j) + temp43b2 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp43b3 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp43b3 vfluxb(i, k) = 0.0 k = kts + 1 temp43b4 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i& & , k) temp43b5 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp43b4 romb(i-1, k, j) = romb(i-1, k, j) + temp43b4 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp43b5 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp43b5 vfluxb(i, k) = 0.0 END DO CALL POPINTEGER4(i) DO k=ktf-1,kts+2,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i-1, k, j)+rom(i, k, j)) temp43b1 = vel*vfluxb(i, k)/12.0 velb = (7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j)& & )*vfluxb(i, k)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp43b1 ub0(i, k-1, j) = ub0(i, k-1, j) + 7.*temp43b1 ub0(i, k+1, j) = ub0(i, k+1, j) - temp43b1 ub0(i, k-2, j) = ub0(i, k-2, j) - temp43b1 vfluxb(i, k) = 0.0 romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb romb(i, k, j) = romb(i, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO ELSE IF (vert_order .EQ. 3) THEN DO j=j_start,j_end DO k=kts+2,ktf-1 CALL PUSHINTEGER4(i) END DO CALL PUSHINTEGER4(i) CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp47b = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, & & k) temp47b0 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp47b romb(i-1, k, j) = romb(i-1, k, j) + temp47b ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp47b0 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp47b0 vfluxb(i, k) = 0.0 k = kts + 1 temp47b1 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i& & , k) temp47b2 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp47b1 romb(i-1, k, j) = romb(i-1, k, j) + temp47b1 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp47b2 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp47b2 vfluxb(i, k) = 0.0 END DO CALL POPINTEGER4(i) DO k=ktf-1,kts+2,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i-1, k, j)+rom(i, k, j)) temp43 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1& & , j)) temp46 = SIGN(1., -vel) temp45 = temp46/12.0 temp44 = SIGN(1, time_step) temp43b6 = vel*vfluxb(i, k) temp43b7 = temp43b6/12.0 temp43b8 = temp44*temp45*temp43b6 velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j& & ))/12.0+temp44*(temp45*temp43))*vfluxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp43b7 - 3.*temp43b8 ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp43b8 + 7.*temp43b7 ub0(i, k+1, j) = ub0(i, k+1, j) + temp43b8 - temp43b7 ub0(i, k-2, j) = ub0(i, k-2, j) - temp43b8 - temp43b7 vfluxb(i, k) = 0.0 romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb romb(i, k, j) = romb(i, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO ELSE IF (vert_order .EQ. 2) THEN DO j=j_start,j_end DO k=kts+1,ktf CALL PUSHINTEGER4(i) END DO DO k=kts,ktf CALL PUSHINTEGER4(i) END DO END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO CALL POPINTEGER4(i) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 temp47b3 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(& & i, k) temp47b4 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp47b3 romb(i-1, k, j) = romb(i-1, k, j) + temp47b3 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp47b4 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp47b4 vfluxb(i, k) = 0.0 END DO CALL POPINTEGER4(i) END DO END DO END IF CALL POPINTEGER4(j_start) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from48) CALL POPINTEGER4(ad_to48) DO i=ad_to48,ad_from48,-1 DO k=ktf,kts,-1 dvm = rv(ip, k, jte) - rv(ip, k, jte-1) dvp = rv(im, k, jte) - rv(im, k, jte-1) temp31b43 = -(mrdy*tendencyb(i, k, jte-1)) temp31b44 = 0.5*u(i, k, jte-1)*temp31b43 vbb = (u_old(i, k, jte-1)-u_old(i, k, jte-2))*temp31b43 u_oldb(i, k, jte-1) = u_oldb(i, k, jte-1) + vb*temp31b43 u_oldb(i, k, jte-2) = u_oldb(i, k, jte-2) - vb*temp31b43 ub0(i, k, jte-1) = ub0(i, k, jte-1) + 0.5*(dvm+dvp)*temp31b43 dvmb = temp31b44 dvpb = temp31b44 rvb(im, k, jte) = rvb(im, k, jte) + dvpb rvb(im, k, jte-1) = rvb(im, k, jte-1) - dvpb rvb(ip, k, jte) = rvb(ip, k, jte) + dvmb rvb(ip, k, jte-1) = rvb(ip, k, jte-1) - dvmb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF rvb(ip, k, jte) = rvb(ip, k, jte) + 0.5*vwb rvb(im, k, jte) = rvb(im, k, jte) + 0.5*vwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(im) ELSE CALL POPINTEGER4(im) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ip) ELSE CALL POPINTEGER4(ip) END IF CALL POPREAL8(mrdy) END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from47) CALL POPINTEGER4(ad_to47) DO i=ad_to47,ad_from47,-1 DO k=ktf,kts,-1 dvm = rv(ip, k, jts+1) - rv(ip, k, jts) dvp = rv(im, k, jts+1) - rv(im, k, jts) temp31b41 = -(mrdy*tendencyb(i, k, jts)) temp31b42 = 0.5*u(i, k, jts)*temp31b41 vbb = (u_old(i, k, jts+1)-u_old(i, k, jts))*temp31b41 u_oldb(i, k, jts+1) = u_oldb(i, k, jts+1) + vb*temp31b41 u_oldb(i, k, jts) = u_oldb(i, k, jts) - vb*temp31b41 ub0(i, k, jts) = ub0(i, k, jts) + 0.5*(dvm+dvp)*temp31b41 dvmb = temp31b42 dvpb = temp31b42 rvb(im, k, jts+1) = rvb(im, k, jts+1) + dvpb rvb(im, k, jts) = rvb(im, k, jts) - dvpb rvb(ip, k, jts+1) = rvb(ip, k, jts+1) + dvmb rvb(ip, k, jts) = rvb(ip, k, jts) - dvmb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF rvb(ip, k, jts) = rvb(ip, k, jts) + 0.5*vwb rvb(im, k, jts) = rvb(im, k, jts) + 0.5*vwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(im) ELSE CALL POPINTEGER4(im) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ip) ELSE CALL POPINTEGER4(ip) END IF CALL POPREAL8(mrdy) END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from46) CALL POPINTEGER4(ad_to46) DO j=ad_to46,ad_from46,-1 DO k=ktf,kts,-1 temp31b40 = -(rdx*tendencyb(ite, k, j)) ubb = (u_old(ite, k, j)-u_old(ite-1, k, j))*temp31b40 u_oldb(ite, k, j) = u_oldb(ite, k, j) + ub*temp31b40 u_oldb(ite-1, k, j) = u_oldb(ite-1, k, j) - ub*temp31b40 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(ite, k, j) = rub(ite, k, j) + ubb mutb(ite-1, j) = mutb(ite-1, j) + cb*ubb END IF END DO END DO CALL POPINTEGER4(j_start) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from45) CALL POPINTEGER4(ad_to45) DO j=ad_to45,ad_from45,-1 DO k=ktf,kts,-1 temp31b39 = -(rdx*tendencyb(its, k, j)) ubb = (u_old(its+1, k, j)-u_old(its, k, j))*temp31b39 u_oldb(its+1, k, j) = u_oldb(its+1, k, j) + ub*temp31b39 u_oldb(its, k, j) = u_oldb(its, k, j) - ub*temp31b39 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(its, k, j) = rub(its, k, j) + ubb mutb(its, j) = mutb(its, j) - cb*ubb END IF END DO END DO CALL POPINTEGER4(j_start) END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from44) CALL POPINTEGER4(ad_to44) DO j=ad_to44,ad_from44,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from43) CALL POPINTEGER4(ad_to43) DO i=ad_to43,ad_from43,-1 mrdx = msfux(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 i = ide - 1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp31b38 = vel*fqxb(i, k)/12.0 velb = (7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, & & j))*fqxb(i, k)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b38 ub0(i-1, k, j) = ub0(i-1, k, j) + 7.*temp31b38 ub0(i+1, k, j) = ub0(i+1, k, j) - temp31b38 ub0(i-2, k, j) = ub0(i-2, k, j) - temp31b38 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp31b36 = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k) temp31b37 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp31b36 rub(i-1, k, j) = rub(i-1, k, j) + temp31b36 ub0(i-1, k, j) = ub0(i-1, k, j) + temp31b37 ubb = temp31b37 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i-1, k, j) = ub0(i-1, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i, k, j) = ub0(i, k, j) + ubb END DO CALL POPINTEGER4(i) END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp31b35 = vel*fqxb(i, k)/12.0 velb = (7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, & & j))*fqxb(i, k)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b35 ub0(i-1, k, j) = ub0(i-1, k, j) + 7.*temp31b35 ub0(i+1, k, j) = ub0(i+1, k, j) - temp31b35 ub0(i-2, k, j) = ub0(i-2, k, j) - temp31b35 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp31b33 = 0.25*(u(i, k, j)+ub)*fqxb(i, k) temp31b34 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp31b33 rub(i-1, k, j) = rub(i-1, k, j) + temp31b33 ub0(i, k, j) = ub0(i, k, j) + temp31b34 ubb = temp31b34 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i-1, k, j) = ub0(i-1, k, j) + ubb END DO CALL POPINTEGER4(i) END IF END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp31b32 = vel*fqxb(i, k)/60.0 velb = (37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, j)+u(i-2& & , k, j))+u(i+2, k, j)+u(i-3, k, j))*fqxb(i, k)/60.0 ub0(i, k, j) = ub0(i, k, j) + 37.*temp31b32 ub0(i-1, k, j) = ub0(i-1, k, j) + 37.*temp31b32 ub0(i+1, k, j) = ub0(i+1, k, j) - 8.*temp31b32 ub0(i-2, k, j) = ub0(i-2, k, j) - 8.*temp31b32 ub0(i+2, k, j) = ub0(i+2, k, j) + temp31b32 ub0(i-3, k, j) = ub0(i-3, k, j) + temp31b32 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from42) CALL POPINTEGER4(ad_to42) DO j=ad_to42,ad_from42,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from39) CALL POPINTEGER4(ad_to39) DO i=ad_to39,ad_from39,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from40) CALL POPINTEGER4(ad_to40) DO i=ad_to40,ad_from40,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from41) CALL POPINTEGER4(ad_to41) DO i=ad_to41,ad_from41,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from34) CALL POPINTEGER4(ad_to34) DO i=ad_to34,ad_from34,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp31b25 = vel*fqyb(i, k, jp1)/60.0 velb = (37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i, k, j+1)+u& & (i, k, j-2))+u(i, k, j+2)+u(i, k, j-3))*fqyb(i, k, jp1& & )/60.0 ub0(i, k, j) = ub0(i, k, j) + 37.*temp31b25 ub0(i, k, j-1) = ub0(i, k, j-1) + 37.*temp31b25 ub0(i, k, j+1) = ub0(i, k, j+1) - 8.*temp31b25 ub0(i, k, j-2) = ub0(i, k, j-2) - 8.*temp31b25 ub0(i, k, j+2) = ub0(i, k, j+2) + temp31b25 ub0(i, k, j-3) = ub0(i, k, j-3) + temp31b25 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from35) CALL POPINTEGER4(ad_to35) DO i=ad_to35,ad_from35,-1 temp31b26 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, & & jp1) temp31b27 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, & & jp1) rvb(i, k, j) = rvb(i, k, j) + temp31b26 rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b26 ub0(i, k, j) = ub0(i, k, j) + temp31b27 ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b27 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from36) CALL POPINTEGER4(ad_to36) DO i=ad_to36,ad_from36,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp31b28 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k& & , j-2))*fqyb(i, k, jp1)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b28 ub0(i, k, j-1) = ub0(i, k, j-1) + 7.*temp31b28 ub0(i, k, j+1) = ub0(i, k, j+1) - temp31b28 ub0(i, k, j-2) = ub0(i, k, j-2) - temp31b28 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from37) CALL POPINTEGER4(ad_to37) DO i=ad_to37,ad_from37,-1 temp31b29 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp31b30 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, & & jp1) rvb(i, k, j) = rvb(i, k, j) + temp31b29 rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b29 ub0(i, k, j) = ub0(i, k, j) + temp31b30 ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b30 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from38) CALL POPINTEGER4(ad_to38) DO i=ad_to38,ad_from38,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp31b31 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, & & j-2))*fqyb(i, k, jp1)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp31b31 ub0(i, k, j-1) = ub0(i, k, j-1) + 7.*temp31b31 ub0(i, k, j+1) = ub0(i, k, j+1) - temp31b31 ub0(i, k, j-2) = ub0(i, k, j-2) - temp31b31 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO END IF END DO ELSE IF (branch .EQ. 1) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO j=ad_to9,ad_from9,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO i=ad_to8,ad_from8,-1 mrdx = msfux(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 i = ide - 1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp19 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1& & , k, j)) temp22 = SIGN(1., vel) temp21 = temp22/12.0 temp20 = SIGN(1, time_step) temp19b1 = vel*fqxb(i, k) temp19b2 = temp19b1/12.0 temp19b3 = temp20*temp21*temp19b1 velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k& & , j))/12.0+temp20*(temp21*temp19))*fqxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp19b2 - 3.*temp19b3 ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp19b3 + 7.*temp19b2 ub0(i+1, k, j) = ub0(i+1, k, j) + temp19b3 - temp19b2 ub0(i-2, k, j) = ub0(i-2, k, j) - temp19b3 - temp19b2 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp19b = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k) temp19b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp19b rub(i-1, k, j) = rub(i-1, k, j) + temp19b ub0(i-1, k, j) = ub0(i-1, k, j) + temp19b0 ubb = temp19b0 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i-1, k, j) = ub0(i-1, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i, k, j) = ub0(i, k, j) + ubb END DO CALL POPINTEGER4(i) END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp15 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1& & , k, j)) temp18 = SIGN(1., vel) temp17 = temp18/12.0 temp16 = SIGN(1, time_step) temp15b1 = vel*fqxb(i, k) temp15b2 = temp15b1/12.0 temp15b3 = temp16*temp17*temp15b1 velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k& & , j))/12.0+temp16*(temp17*temp15))*fqxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp15b2 - 3.*temp15b3 ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp15b3 + 7.*temp15b2 ub0(i+1, k, j) = ub0(i+1, k, j) + temp15b3 - temp15b2 ub0(i-2, k, j) = ub0(i-2, k, j) - temp15b3 - temp15b2 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp15b = 0.25*(u(i, k, j)+ub)*fqxb(i, k) temp15b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp15b rub(i-1, k, j) = rub(i-1, k, j) + temp15b ub0(i, k, j) = ub0(i, k, j) + temp15b0 ubb = temp15b0 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i-1, k, j) = ub0(i-1, k, j) + ubb END DO CALL POPINTEGER4(i) END IF END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp11 = u(i+2, k, j) - u(i-3, k, j) + 10.*(u(i, k, j)-u(i-1& & , k, j)) - 5.*(u(i+1, k, j)-u(i-2, k, j)) temp14 = SIGN(1., vel) temp13 = temp14/60.0 temp12 = SIGN(1, time_step) temp11b = vel*fqxb(i, k) temp11b0 = temp11b/60.0 temp11b1 = -(temp12*temp13*temp11b) velb = ((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, j)+u(i-& & 2, k, j))+u(i+2, k, j)+u(i-3, k, j))/60.0-temp12*(temp13*& & temp11))*fqxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 10.*temp11b1 + 37.*temp11b0 ub0(i-1, k, j) = ub0(i-1, k, j) + 37.*temp11b0 - 10.*& & temp11b1 ub0(i+1, k, j) = ub0(i+1, k, j) - 5.*temp11b1 - 8.*temp11b0 ub0(i-2, k, j) = ub0(i-2, k, j) + 5.*temp11b1 - 8.*temp11b0 ub0(i+2, k, j) = ub0(i+2, k, j) + temp11b1 + temp11b0 ub0(i-3, k, j) = ub0(i-3, k, j) + temp11b0 - temp11b1 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO j=ad_to7,ad_from7,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp = u(i, k, j+2) - u(i, k, j-3) + 10.*(u(i, k, j)-u(i& & , k, j-1)) - 5.*(u(i, k, j+1)-u(i, k, j-2)) temp2 = SIGN(1., vel) temp1 = temp2/60.0 temp0 = SIGN(1, time_step) tempb = vel*fqyb(i, k, jp1) tempb0 = tempb/60.0 tempb1 = -(temp0*temp1*tempb) velb = ((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i, k, j+1)+& & u(i, k, j-2))+u(i, k, j+2)+u(i, k, j-3))/60.0-temp0*(& & temp1*temp))*fqyb(i, k, jp1) ub0(i, k, j) = ub0(i, k, j) + 10.*tempb1 + 37.*tempb0 ub0(i, k, j-1) = ub0(i, k, j-1) + 37.*tempb0 - 10.*& & tempb1 ub0(i, k, j+1) = ub0(i, k, j+1) - 5.*tempb1 - 8.*tempb0 ub0(i, k, j-2) = ub0(i, k, j-2) + 5.*tempb1 - 8.*tempb0 ub0(i, k, j+2) = ub0(i, k, j+2) + tempb1 + tempb0 ub0(i, k, j-3) = ub0(i, k, j-3) + tempb0 - tempb1 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 temp3b = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp3b0 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, & & jp1) rvb(i, k, j) = rvb(i, k, j) + temp3b rvb(i-1, k, j) = rvb(i-1, k, j) + temp3b ub0(i, k, j) = ub0(i, k, j) + temp3b0 ub0(i, k, j-1) = ub0(i, k, j-1) + temp3b0 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp3 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i& & , k, j-1)) temp6 = SIGN(1., vel) temp5 = temp6/12.0 temp4 = SIGN(1, time_step) temp3b1 = vel*fqyb(i, k, jp1) temp3b2 = temp3b1/12.0 temp3b3 = temp4*temp5*temp3b1 velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, & & k, j-2))/12.0+temp4*(temp5*temp3))*fqyb(i, k, jp1) ub0(i, k, j) = ub0(i, k, j) + 7.*temp3b2 - 3.*temp3b3 ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp3b3 + 7.*& & temp3b2 ub0(i, k, j+1) = ub0(i, k, j+1) + temp3b3 - temp3b2 ub0(i, k, j-2) = ub0(i, k, j-2) - temp3b3 - temp3b2 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp7b = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp7b0 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp7b rvb(i-1, k, j) = rvb(i-1, k, j) + temp7b ub0(i, k, j) = ub0(i, k, j) + temp7b0 ub0(i, k, j-1) = ub0(i, k, j-1) + temp7b0 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp7 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, & & k, j-1)) temp10 = SIGN(1., vel) temp9 = temp10/12.0 temp8 = SIGN(1, time_step) temp7b1 = vel*fqyb(i, k, jp1) temp7b2 = temp7b1/12.0 temp7b3 = temp8*temp9*temp7b1 velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k& & , j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, jp1) ub0(i, k, j) = ub0(i, k, j) + 7.*temp7b2 - 3.*temp7b3 ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp7b3 + 7.*temp7b2 ub0(i, k, j+1) = ub0(i, k, j+1) + temp7b3 - temp7b2 ub0(i, k, j-2) = ub0(i, k, j-2) - temp7b3 - temp7b2 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO END IF END DO ELSE fqyb = 0.0 CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO j=ad_to18,ad_from18,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO i=ad_to15,ad_from15,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO CALL POPINTEGER4(i) END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO i=ad_to16,ad_from16,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO CALL POPINTEGER4(i) END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO i=ad_to17,ad_from17,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO CALL POPINTEGER4(i) END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 temp23b4 = 0.25*(u(i, k, j_start)+u(i, k, j_start-1))*fqyb& & (i, k, jp1) temp23b5 = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start))*& & fqyb(i, k, jp1) rvb(i, k, j_start) = rvb(i, k, j_start) + temp23b4 rvb(i-1, k, j_start) = rvb(i-1, k, j_start) + temp23b4 ub0(i, k, j_start) = ub0(i, k, j_start) + temp23b5 ub0(i, k, j_start-1) = ub0(i, k, j_start-1) + temp23b5 fqyb(i, k, jp1) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 temp23b6 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp23b7 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1& & ) rvb(i, k, j) = rvb(i, k, j) + temp23b6 rvb(i-1, k, j) = rvb(i-1, k, j) + temp23b6 ub0(i, k, j) = ub0(i, k, j) + temp23b7 ub0(i, k, j-1) = ub0(i, k, j-1) + temp23b7 fqyb(i, k, jp1) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp23b8 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, & & j-2))*fqyb(i, k, jp1)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp23b8 ub0(i, k, j-1) = ub0(i, k, j-1) + 7.*temp23b8 ub0(i, k, j+1) = ub0(i, k, j+1) - temp23b8 ub0(i, k, j-2) = ub0(i, k, j-2) - temp23b8 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END IF END DO fqxb = 0.0 CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO j=ad_to11,ad_from11,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO i=ad_to10,ad_from10,-1 mrdx = msfux(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp23b2 = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k) temp23b3 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp23b2 rub(i-1, k, j) = rub(i-1, k, j) + temp23b2 ub0(i-1, k, j) = ub0(i-1, k, j) + temp23b3 ubb = temp23b3 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i-1, k, j) = ub0(i-1, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i, k, j) = ub0(i, k, j) + ubb END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp23b0 = 0.25*(u(i, k, j)+ub)*fqxb(i, k) temp23b1 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp23b0 rub(i-1, k, j) = rub(i-1, k, j) + temp23b0 ub0(i, k, j) = ub0(i, k, j) + temp23b1 ubb = temp23b1 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i-1, k, j) = ub0(i-1, k, j) + ubb END DO CALL POPINTEGER4(i) END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp23b = vel*fqxb(i, k)/12.0 velb = (7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, & & j))*fqxb(i, k)/12.0 ub0(i, k, j) = ub0(i, k, j) + 7.*temp23b ub0(i-1, k, j) = ub0(i-1, k, j) + 7.*temp23b ub0(i+1, k, j) = ub0(i+1, k, j) - temp23b ub0(i-2, k, j) = ub0(i-2, k, j) - temp23b fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO END IF ELSE IF (branch .EQ. 3) THEN fqyb = 0.0 CALL POPINTEGER4(ad_from27) CALL POPINTEGER4(ad_to27) DO j=ad_to27,ad_from27,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from24) CALL POPINTEGER4(ad_to24) DO i=ad_to24,ad_from24,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) END DO CALL POPINTEGER4(i) END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from25) CALL POPINTEGER4(ad_to25) DO i=ad_to25,ad_from25,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO CALL POPINTEGER4(i) END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from26) CALL POPINTEGER4(ad_to26) DO i=ad_to26,ad_from26,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO CALL POPINTEGER4(i) END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO i=ad_to21,ad_from21,-1 temp27b3 = 0.25*(u(i, k, j_start)+u(i, k, j_start-1))*fqyb(i& & , k, jp1) temp27b4 = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start))*fqyb& & (i, k, jp1) rvb(i, k, j_start) = rvb(i, k, j_start) + temp27b3 rvb(i-1, k, j_start) = rvb(i-1, k, j_start) + temp27b3 ub0(i, k, j_start) = ub0(i, k, j_start) + temp27b4 ub0(i, k, j_start-1) = ub0(i, k, j_start-1) + temp27b4 fqyb(i, k, jp1) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO i=ad_to22,ad_from22,-1 temp27b5 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp27b6 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp27b5 rvb(i-1, k, j) = rvb(i-1, k, j) + temp27b5 ub0(i, k, j) = ub0(i, k, j) + temp27b6 ub0(i, k, j-1) = ub0(i, k, j-1) + temp27b6 fqyb(i, k, jp1) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp27 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, k& & , j-1)) temp30 = SIGN(1., vel) temp29 = temp30/12.0 temp28 = SIGN(1, time_step) temp27b7 = vel*fqyb(i, k, jp1) temp27b8 = temp27b7/12.0 temp27b9 = temp28*temp29*temp27b7 velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, j& & -2))/12.0+temp28*(temp29*temp27))*fqyb(i, k, jp1) ub0(i, k, j) = ub0(i, k, j) + 7.*temp27b8 - 3.*temp27b9 ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp27b9 + 7.*temp27b8 ub0(i, k, j+1) = ub0(i, k, j+1) + temp27b9 - temp27b8 ub0(i, k, j-2) = ub0(i, k, j-2) - temp27b9 - temp27b8 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END IF END DO fqxb = 0.0 CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO j=ad_to20,ad_from20,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO i=ad_to19,ad_from19,-1 mrdx = msfux(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp27b1 = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k) temp27b2 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp27b1 rub(i-1, k, j) = rub(i-1, k, j) + temp27b1 ub0(i-1, k, j) = ub0(i-1, k, j) + temp27b2 ubb = temp27b2 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i-1, k, j) = ub0(i-1, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i, k, j) = ub0(i, k, j) + ubb END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp27b = 0.25*(u(i, k, j)+ub)*fqxb(i, k) temp27b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp27b rub(i-1, k, j) = rub(i-1, k, j) + temp27b ub0(i, k, j) = ub0(i, k, j) + temp27b0 ubb = temp27b0 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i-1, k, j) = ub0(i-1, k, j) + ubb END DO CALL POPINTEGER4(i) END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp23 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1, k& & , j)) temp26 = SIGN(1., vel) temp25 = temp26/12.0 temp24 = SIGN(1, time_step) temp23b9 = vel*fqxb(i, k) temp23b10 = temp23b9/12.0 temp23b11 = temp24*temp25*temp23b9 velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, j& & ))/12.0+temp24*(temp25*temp23))*fqxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp23b10 - 3.*temp23b11 ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp23b11 + 7.*temp23b10 ub0(i+1, k, j) = ub0(i+1, k, j) + temp23b11 - temp23b10 ub0(i-2, k, j) = ub0(i-2, k, j) - temp23b11 - temp23b10 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from33) CALL POPINTEGER4(ad_to33) DO j=ad_to33,ad_from33,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from32) CALL POPINTEGER4(ad_to32) DO i=ad_to32,ad_from32,-1 CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN mrdy = msfux(i, j)*rdy temp31b20 = -(mrdy*0.25*tendencyb(i, k, j)) temp31b21 = (u(i, k, j+1)+u(i, k, j))*temp31b20 temp31b22 = (rv(i, k, j+1)+rv(i-1, k, j+1))*temp31b20 temp31b23 = -((u(i, k, j)+u(i, k, j-1))*temp31b20) temp31b24 = -((rv(i, k, j)+rv(i-1, k, j))*temp31b20) rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b21 rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + temp31b21 ub0(i, k, j+1) = ub0(i, k, j+1) + temp31b22 ub0(i, k, j) = ub0(i, k, j) + temp31b24 + temp31b22 rvb(i, k, j) = rvb(i, k, j) + temp31b23 rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b23 ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b24 ELSE IF (branch .EQ. 1) THEN mrdy = msfux(i, j)*rdy temp31b17 = mrdy*0.25*tendencyb(i, k, j) temp31b18 = (u(i, k, j)+u(i, k, j-1))*temp31b17 temp31b19 = (rv(i, k, j)+rv(i-1, k, j))*temp31b17 rvb(i, k, j) = rvb(i, k, j) + temp31b18 rvb(i-1, k, j) = rvb(i-1, k, j) + temp31b18 ub0(i, k, j) = ub0(i, k, j) + temp31b19 ub0(i, k, j-1) = ub0(i, k, j-1) + temp31b19 ELSE mrdy = msfux(i, j)*rdy temp31b14 = -(mrdy*0.25*tendencyb(i, k, j)) temp31b15 = (u(i, k, j+1)+u(i, k, j))*temp31b14 temp31b16 = (rv(i, k, j+1)+rv(i-1, k, j+1))*temp31b14 rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b15 rvb(i-1, k, j+1) = rvb(i-1, k, j+1) + temp31b15 ub0(i, k, j+1) = ub0(i, k, j+1) + temp31b16 ub0(i, k, j) = ub0(i, k, j) + temp31b16 END IF END DO CALL POPINTEGER4(i) END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from31) CALL POPINTEGER4(ad_to31) DO j=ad_to31,ad_from31,-1 DO k=ktf,kts,-1 i = ide - 1 mrdx = msfux(i, j)*rdx temp31b9 = -(mrdx*0.25*tendencyb(i, k, j)) temp31b10 = (ub+u(i, k, j))*temp31b9 temp31b11 = (ru(i+1, k, j)+ru(i, k, j))*temp31b9 temp31b12 = -((u(i, k, j)+u(i-1, k, j))*temp31b9) temp31b13 = -((ru(i, k, j)+ru(i-1, k, j))*temp31b9) rub(i+1, k, j) = rub(i+1, k, j) + temp31b10 rub(i, k, j) = rub(i, k, j) + temp31b12 + temp31b10 ubb = temp31b11 ub0(i, k, j) = ub0(i, k, j) + temp31b13 + temp31b11 rub(i-1, k, j) = rub(i-1, k, j) + temp31b12 ub0(i-1, k, j) = ub0(i-1, k, j) + temp31b13 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i+1, k, j) = ub0(i+1, k, j) + ubb END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from30) CALL POPINTEGER4(ad_to30) DO j=ad_to30,ad_from30,-1 DO k=ktf,kts,-1 i = ids + 1 mrdx = msfux(i, j)*rdx temp31b4 = -(mrdx*0.25*tendencyb(i, k, j)) temp31b5 = (u(i+1, k, j)+u(i, k, j))*temp31b4 temp31b6 = (ru(i+1, k, j)+ru(i, k, j))*temp31b4 temp31b7 = -((u(i, k, j)+ub)*temp31b4) temp31b8 = -((ru(i, k, j)+ru(i-1, k, j))*temp31b4) rub(i+1, k, j) = rub(i+1, k, j) + temp31b5 rub(i, k, j) = rub(i, k, j) + temp31b7 + temp31b5 ub0(i+1, k, j) = ub0(i+1, k, j) + temp31b6 ub0(i, k, j) = ub0(i, k, j) + temp31b8 + temp31b6 rub(i-1, k, j) = rub(i-1, k, j) + temp31b7 ubb = temp31b8 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i-1, k, j) = ub0(i-1, k, j) + ubb END DO END DO END IF CALL POPINTEGER4(ad_from29) CALL POPINTEGER4(ad_to29) DO j=ad_to29,ad_from29,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from28) CALL POPINTEGER4(ad_to28) DO i=ad_to28,ad_from28,-1 mrdx = msfux(i, j)*rdx temp31b = -(mrdx*0.25*tendencyb(i, k, j)) temp31b0 = (u(i+1, k, j)+u(i, k, j))*temp31b temp31b1 = (ru(i+1, k, j)+ru(i, k, j))*temp31b temp31b2 = -((u(i, k, j)+u(i-1, k, j))*temp31b) temp31b3 = -((ru(i, k, j)+ru(i-1, k, j))*temp31b) rub(i+1, k, j) = rub(i+1, k, j) + temp31b0 rub(i, k, j) = rub(i, k, j) + temp31b2 + temp31b0 ub0(i+1, k, j) = ub0(i+1, k, j) + temp31b1 ub0(i, k, j) = ub0(i, k, j) + temp31b3 + temp31b1 rub(i-1, k, j) = rub(i-1, k, j) + temp31b2 ub0(i-1, k, j) = ub0(i-1, k, j) + temp31b3 END DO END DO END DO END IF END SUBROUTINE A_ADVECT_U ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35 ! ! Differentiation of advect_v in reverse (adjoint) mode: ! gradient of useful results: rom tendency v v_old ru rv ! mut ! with respect to varying inputs: rom tendency v v_old ru rv ! mut ! RW status of diff variables: rom:incr tendency:in-out v:incr ! v_old:incr ru:incr rv:incr mut:incr SUBROUTINE A_ADVECT_V(v, vb0, v_old, v_oldb, tendency, tendencyb, ru, & & rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux, & & msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide& & , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte& & , kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru& & , rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: vb0, v_oldb, rub, rvb, & & romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, jms:jme) :: mutb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum REAL :: ubb, vbb, uwb, dupb, dumb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb INTEGER :: horz_order INTEGER :: vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified INTEGER :: ad_from INTEGER :: ad_to INTEGER :: branch INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 INTEGER :: ad_from24 INTEGER :: ad_to24 INTEGER :: ad_from25 INTEGER :: ad_to25 INTEGER :: ad_from26 INTEGER :: ad_to26 INTEGER :: ad_from27 INTEGER :: ad_to27 INTEGER :: ad_from28 INTEGER :: ad_to28 INTEGER :: ad_from29 INTEGER :: ad_to29 INTEGER :: ad_from30 INTEGER :: ad_to30 INTEGER :: ad_from31 INTEGER :: ad_to31 INTEGER :: ad_from32 INTEGER :: ad_to32 INTEGER :: ad_from33 INTEGER :: ad_to33 INTEGER :: ad_from34 INTEGER :: ad_to34 INTEGER :: ad_from35 INTEGER :: ad_to35 INTEGER :: ad_from36 INTEGER :: ad_to36 INTEGER :: ad_from37 INTEGER :: ad_to37 INTEGER :: ad_from38 INTEGER :: ad_to38 INTEGER :: ad_from39 INTEGER :: ad_to39 INTEGER :: ad_from40 INTEGER :: ad_to40 INTEGER :: ad_from41 INTEGER :: ad_to41 INTEGER :: ad_from42 INTEGER :: ad_to42 INTEGER :: ad_from43 INTEGER :: ad_to43 INTEGER :: ad_from44 INTEGER :: ad_to44 INTEGER :: ad_from45 INTEGER :: ad_to45 INTEGER :: ad_from46 INTEGER :: ad_to46 INTEGER :: ad_from47 INTEGER :: ad_to47 INTEGER :: ad_from48 INTEGER :: ad_to48 INTEGER :: ad_from49 INTEGER :: ad_to49 INTEGER :: ad_from50 INTEGER :: ad_to50 INTEGER :: ad_from51 INTEGER :: ad_to51 INTEGER :: ad_from52 INTEGER :: ad_to52 REAL :: temp3 REAL :: temp29 REAL :: temp31b43 REAL :: temp2 INTEGER :: temp28 REAL :: temp31b42 REAL :: temp1 REAL :: temp27 REAL :: temp31b41 INTEGER :: temp0 REAL :: temp26 REAL :: temp31b40 REAL :: temp7b REAL :: temp25 INTEGER :: temp24 REAL :: temp23 REAL :: temp22 REAL :: temp21 REAL :: temp35b3 INTEGER :: temp20 REAL :: temp35b2 REAL :: temp35b1 REAL :: temp35b0 REAL :: temp23b9 REAL :: temp23b8 REAL :: temp19b REAL :: temp23b7 REAL :: temp23b6 REAL :: temp27b REAL :: temp23b5 REAL :: temp35b REAL :: tempb1 REAL :: temp23b4 REAL :: temp43b REAL :: tempb0 REAL :: temp23b3 REAL :: temp23b2 REAL :: temp23b1 REAL :: temp23b0 REAL :: temp31b39 REAL :: temp31b38 REAL :: temp7b3 REAL :: temp31b37 REAL :: temp3b REAL :: temp7b2 REAL :: temp31b36 REAL :: temp7b1 REAL :: temp31b35 REAL :: temp7b0 REAL :: temp23b15 REAL :: temp31b34 REAL :: temp19 REAL :: temp23b14 REAL :: temp31b33 REAL :: cb REAL :: temp18 REAL :: temp23b13 REAL :: temp31b32 REAL :: temp17 REAL :: temp23b12 REAL :: temp31b31 REAL :: temp43b9 INTEGER :: temp16 REAL :: temp23b11 REAL :: temp31b30 REAL :: temp43b8 REAL :: temp15 REAL :: temp23b10 REAL :: temp43b7 REAL :: temp14 REAL :: temp11b1 REAL :: temp43b6 REAL :: temp13 REAL :: temp11b0 REAL :: temp43b5 INTEGER :: temp12 REAL :: temp43b4 REAL :: temp11 REAL :: temp43b3 REAL :: temp10 REAL :: temp43b2 REAL :: temp15b REAL :: temp43b1 REAL :: temp46 REAL :: temp23b REAL :: temp43b0 REAL :: temp45 REAL :: temp31b INTEGER :: temp44 REAL :: temp43 REAL :: temp42 REAL :: temp19b3 REAL :: temp31b9 REAL :: temp41 REAL :: temp19b2 REAL :: temp31b8 INTEGER :: temp40 REAL :: temp19b1 REAL :: temp31b7 REAL :: temp19b0 REAL :: temp31b6 REAL :: temp31b5 REAL :: temp31b4 REAL :: temp31b3 REAL :: tempb REAL :: temp31b2 REAL :: temp31b1 REAL :: temp31b0 REAL :: temp31b29 REAL :: temp31b28 REAL :: temp31b27 REAL :: temp31b26 REAL :: temp31b25 REAL :: temp31b24 REAL :: temp31b23 REAL :: temp31b22 REAL :: temp31b21 REAL :: temp11b REAL :: temp31b20 REAL :: temp39b1 REAL :: temp39b0 REAL :: temp31b53 REAL :: temp39 REAL :: temp31b52 REAL :: temp38 REAL :: temp3b3 REAL :: temp31b51 REAL :: temp37 REAL :: temp3b2 REAL :: temp31b50 INTEGER :: temp36 REAL :: temp3b1 REAL :: temp35 REAL :: temp3b0 REAL :: temp34 REAL :: temp33 INTEGER :: temp32 REAL :: temp31 REAL :: temp30 REAL :: temp27b1 REAL :: temp27b0 REAL :: temp31b19 REAL :: temp31b18 REAL :: temp31b17 REAL :: temp15b3 REAL :: temp31b16 REAL :: temp REAL :: temp15b2 REAL :: temp31b15 REAL :: temp15b1 REAL :: temp31b14 REAL :: temp47b6 REAL :: temp15b0 REAL :: temp31b13 REAL :: temp43b10 REAL :: temp47b5 REAL :: temp9 REAL :: temp31b12 REAL :: temp31b49 REAL :: temp47b4 INTEGER :: temp8 REAL :: temp31b11 REAL :: temp31b48 REAL :: temp39b REAL :: temp47b3 REAL :: temp7 REAL :: temp31b10 REAL :: temp31b47 REAL :: temp47b REAL :: temp47b2 REAL :: temp6 REAL :: temp31b46 REAL :: temp47b1 REAL :: temp5 REAL :: temp31b45 REAL :: temp47b0 INTEGER :: temp4 REAL :: temp31b44 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF horz_order = config_flags%h_mom_adv_order vert_order = config_flags%v_mom_adv_order ! here is the choice of flux operators IF (horz_order .EQ. 6) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. !--------------- y - advection first i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF j_end_f = jde - 2 END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from45 = j_start j_loop_y_flux_6:DO j=ad_from45,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN DO k=kts,ktf ad_from37 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from37) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! we must be close to some boundary where we need to reduce the order of the stencil ! specified uses upstream normal wind at boundaries ! 2nd order flux next to south boundary DO k=kts,ktf ad_from38 = i_start DO i=ad_from38,i_end CALL PUSHREAL8(vb) vb = v(i, k, j-1) IF (specified .AND. v(i, k, j) .LT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from38) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from39 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from39) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from40 = i_start DO i=ad_from40,i_end CALL PUSHREAL8(vb) vb = v(i, k, j) IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN vb = v(i, k, j-1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from40) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 1) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from41 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from41) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from42 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from42) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. DO k=kts,ktf ad_from43 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from43) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! Normal code DO k=kts,ktf ad_from44 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from44) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_6 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from45) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from48 = j_start ! compute fluxes DO j=ad_from48,j_end ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from46 = i_start DO i=ad_from46,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from46) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from47 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from47) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from48) CALL PUSHCONTROL3B(0) ELSE IF (horz_order .EQ. 5) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. !--------------- y - advection first i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF j_end_f = jde - 2 END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from7 = j_start j_loop_y_flux_5:DO j=ad_from7,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN DO k=kts,ktf ad_from = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! we must be close to some boundary where we need to reduce the order of the stencil ! specified uses upstream normal wind at boundaries ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start DO i=ad_from0,i_end CALL PUSHREAL8(vb) vb = v(i, k, j-1) IF (specified .AND. v(i, k, j) .LT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start DO i=ad_from2,i_end CALL PUSHREAL8(vb) vb = v(i, k, j) IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN vb = v(i, k, j-1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 1) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from4 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. DO k=kts,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! Normal code DO k=kts,ktf ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from7) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from10 = j_start ! compute fluxes DO j=ad_from10,j_end ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from8 = i_start DO i=ad_from8,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from8) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from9 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from10) CALL PUSHCONTROL3B(1) ELSE IF (horz_order .EQ. 4) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 2) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary !CJM May not work with tiling because defined in terms of domain dims IF (degrade_ys) j_start = jds + 1 IF (degrade_ye) j_end = jde - 1 ! compute fluxes ! specified uses upstream normal wind at boundaries jp0 = 1 jp1 = 2 ad_from17 = j_start DO j=ad_from17,j_end+1 IF (j .EQ. j_start .AND. degrade_ys) THEN DO k=kts,ktf ad_from11 = i_start DO i=ad_from11,i_end CALL PUSHREAL8(vb) vb = v(i, k, j-1) IF (specified .AND. v(i, k, j) .LT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from11) END DO CALL PUSHCONTROL2B(0) ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN DO k=kts,ktf ad_from12 = i_start DO i=ad_from12,i_end CALL PUSHREAL8(vb) vb = v(i, k, j) IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN vb = v(i, k, j-1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) END DO CALL PUSHCONTROL2B(1) ELSE DO k=kts,ktf ad_from13 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) END DO CALL PUSHCONTROL2B(2) END IF ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from14 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. DO k=kts,ktf ad_from15 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from15) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! Normal code DO k=kts,ktf ad_from16 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from16) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from17) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 2 i_end_f = ide - 2 END IF ad_from19 = j_start ! compute fluxes DO j=ad_from19,j_end ! second order flux close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from18 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from18) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from19) CALL PUSHCONTROL3B(2) ELSE IF (horz_order .EQ. 3) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 2) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary !CJM May not work with tiling because defined in terms of domain dims IF (degrade_ys) j_start = jds + 1 IF (degrade_ye) j_end = jde - 1 ! compute fluxes ! specified uses upstream normal wind at boundaries jp0 = 1 jp1 = 2 ad_from26 = j_start DO j=ad_from26,j_end+1 IF (j .EQ. j_start .AND. degrade_ys) THEN DO k=kts,ktf ad_from20 = i_start DO i=ad_from20,i_end CALL PUSHREAL8(vb) vb = v(i, k, j-1) IF (specified .AND. v(i, k, j) .LT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from20) END DO CALL PUSHCONTROL2B(0) ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN DO k=kts,ktf ad_from21 = i_start DO i=ad_from21,i_end CALL PUSHREAL8(vb) vb = v(i, k, j) IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN vb = v(i, k, j-1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from21) END DO CALL PUSHCONTROL2B(1) ELSE DO k=kts,ktf ad_from22 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from22) END DO CALL PUSHCONTROL2B(2) END IF ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from23 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. DO k=kts,ktf ad_from24 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from24) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! Normal code DO k=kts,ktf ad_from25 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from25) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from26) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 2 i_end_f = ide - 2 END IF ad_from28 = j_start ! compute fluxes DO j=ad_from28,j_end ! second order flux close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from27 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from27) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from28) CALL PUSHCONTROL3B(3) ELSE IF (horz_order .EQ. 2) THEN i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte IF (config_flags%open_ys) THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF (config_flags%open_ye) THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF IF (specified) THEN IF (jds + 2 .LT. jts) THEN j_start = jts ELSE j_start = jds + 2 END IF END IF IF (specified) THEN IF (jde - 2 .GT. jte) THEN j_end = jte ELSE j_end = jde - 2 END IF END IF IF (config_flags%polar) THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF (config_flags%polar) THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ad_from30 = j_start DO j=ad_from30,j_end DO k=kts,ktf ad_from29 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from29) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from30) ! Comments on polar boundary conditions ! tendencies = 0 at poles, and polar points do not contribute at points ! next to poles IF (config_flags%polar) THEN IF (jts .EQ. jds) THEN DO k=kts,ktf ad_from31 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from31) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (jte .EQ. jde) THEN DO k=kts,ktf ad_from32 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from32) END DO CALL PUSHCONTROL2B(0) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(2) END IF ! specified uses upstream normal wind at boundaries IF (specified .AND. jts .LE. jds + 1) THEN j = jds + 1 DO k=kts,ktf ad_from33 = i_start DO i=ad_from33,i_end CALL PUSHREAL8(vb) ! ADT eqn 45, 2nd term on RHS vb = v(i, k, j-1) IF (v(i, k, j) .LT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from33) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (specified .AND. jte .GE. jde - 1) THEN CALL PUSHINTEGER4(j) j = jde - 1 DO k=kts,ktf ad_from34 = i_start DO i=ad_from34,i_end CALL PUSHREAL8(vb) ! ADT eqn 45, 2nd term on RHS vb = v(i, k, j+1) IF (v(i, k, j) .GT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from34) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (.NOT.config_flags%periodic_x) THEN IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF END IF END IF IF (config_flags%polar) THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF (config_flags%polar) THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ad_from36 = j_start CALL PUSHINTEGER4(j) DO j=ad_from36,j_end DO k=kts,ktf ad_from35 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from35) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from36) CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! Comments on polar boundary condition ! Force tendency=0 at NP and SP ! We keep setting this everywhere, but it can't hurt... IF (config_flags%polar .AND. jts .EQ. jds) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar .AND. jte .EQ. jde) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF ! radiative lateral boundary condition in y for normal velocity (v) IF (config_flags%open_ys .AND. jts .EQ. jds) THEN CALL PUSHINTEGER4(i_start) i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF ad_from49 = i_start DO i=ad_from49,i_end DO k=kts,ktf IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = rv(i, k, jts) - cb*mut(i, jts) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from49) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN CALL PUSHINTEGER4(i_start) i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF ad_from50 = i_start DO i=ad_from50,i_end DO k=kts,ktf IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = rv(i, k, jte) + cb*mut(i, jte-1) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from50) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges j_start = jts IF (jte .GT. jde) THEN j_end = jde ELSE j_end = jte END IF jmin = jds jmax = jde - 1 IF (config_flags%open_ys) THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF jmin = jds END IF IF (config_flags%open_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF jmax = jde - 1 END IF ! compute x (u) conditions for v, w, or scalar IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from51 = j_start DO j=ad_from51,j_end CALL PUSHREAL8(mrdx) ! ADT eqn 45, 1st term on RHS mrdx = msfvy(its, j)*rdx IF (jmax .GT. j) THEN CALL PUSHINTEGER4(jp) jp = j CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jp) jp = jmax CALL PUSHCONTROL1B(1) END IF IF (jmin .LT. j - 1) THEN CALL PUSHINTEGER4(jm) jm = j - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jm) jm = jmin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf uw = 0.5*(ru(its, k, jp)+ru(its, k, jm)) IF (uw .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from51) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from52 = j_start DO j=ad_from52,j_end CALL PUSHREAL8(mrdx) ! ADT eqn 45, 1st term on RHS mrdx = msfvy(ite-1, j)*rdx IF (jmax .GT. j) THEN CALL PUSHINTEGER4(jp) jp = j CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jp) jp = jmax CALL PUSHCONTROL1B(1) END IF IF (jmin .LT. j - 1) THEN CALL PUSHINTEGER4(jm) jm = j - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jm) jm = jmin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm)) IF (uw .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from52) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF CALL PUSHINTEGER4(i_start) !-------------------- vertical advection ! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w) ! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my) ! We therefore need to make a correction for advect_v ! since 'my' (map scale factor in y direction) isn't a function of z, ! we can do this using *(my/mx) (see eqn. 45 for example) i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified ! We don't want to calculate vertical v tendencies at the N or S pole IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF IF (vert_order .EQ. 6) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp31b50 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, & & j)) vfluxb(i, k+1) = vfluxb(i, k+1) + temp31b50 vfluxb(i, k) = vfluxb(i, k) - temp31b50 END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp31b44 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i& & , k) temp31b45 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp31b44 romb(i, k, j-1) = romb(i, k, j-1) + temp31b44 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp31b45 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp31b45 vfluxb(i, k) = 0.0 k = ktf - 1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp31b46 = vel*vfluxb(i, k)/12.0 velb = (7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))*& & vfluxb(i, k)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b46 vb0(i, k-1, j) = vb0(i, k-1, j) + 7.*temp31b46 vb0(i, k+1, j) = vb0(i, k+1, j) - temp31b46 vb0(i, k-2, j) = vb0(i, k-2, j) - temp31b46 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp31b47 = vel*vfluxb(i, k)/12.0 velb = (7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))*& & vfluxb(i, k)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b47 vb0(i, k-1, j) = vb0(i, k-1, j) + 7.*temp31b47 vb0(i, k+1, j) = vb0(i, k+1, j) - temp31b47 vb0(i, k-2, j) = vb0(i, k-2, j) - temp31b47 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb k = kts + 1 temp31b48 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i& & , k) temp31b49 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp31b48 romb(i, k, j-1) = romb(i, k, j-1) + temp31b48 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp31b49 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp31b49 vfluxb(i, k) = 0.0 END DO DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp31b43 = vel*vfluxb(i, k)/60.0 velb = (37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1, j)+v(i, k-& & 2, j))+v(i, k+2, j)+v(i, k-3, j))*vfluxb(i, k)/60.0 vb0(i, k, j) = vb0(i, k, j) + 37.*temp31b43 vb0(i, k-1, j) = vb0(i, k-1, j) + 37.*temp31b43 vb0(i, k+1, j) = vb0(i, k+1, j) - 8.*temp31b43 vb0(i, k-2, j) = vb0(i, k-2, j) - 8.*temp31b43 vb0(i, k+2, j) = vb0(i, k+2, j) + temp31b43 vb0(i, k-3, j) = vb0(i, k-3, j) + temp31b43 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb END DO END DO END DO ELSE IF (vert_order .EQ. 5) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp43b1 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j& & )) vfluxb(i, k+1) = vfluxb(i, k+1) + temp43b1 vfluxb(i, k) = vfluxb(i, k) - temp43b1 END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp43b = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, & & k) temp43b0 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp43b romb(i, k, j-1) = romb(i, k, j-1) + temp43b vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp43b0 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp43b0 vfluxb(i, k) = 0.0 k = ktf - 1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp39 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, & & j)) temp42 = SIGN(1., -vel) temp41 = temp42/12.0 temp40 = SIGN(1, time_step) temp39b = vel*vfluxb(i, k) temp39b0 = temp39b/12.0 temp39b1 = temp40*temp41*temp39b velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))& & /12.0+temp40*(temp41*temp39))*vfluxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp39b0 - 3.*temp39b1 vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp39b1 + 7.*temp39b0 vb0(i, k+1, j) = vb0(i, k+1, j) + temp39b1 - temp39b0 vb0(i, k-2, j) = vb0(i, k-2, j) - temp39b1 - temp39b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp35 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, & & j)) temp38 = SIGN(1., -vel) temp37 = temp38/12.0 temp36 = SIGN(1, time_step) temp35b = vel*vfluxb(i, k) temp35b0 = temp35b/12.0 temp35b1 = temp36*temp37*temp35b velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))& & /12.0+temp36*(temp37*temp35))*vfluxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp35b0 - 3.*temp35b1 vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp35b1 + 7.*temp35b0 vb0(i, k+1, j) = vb0(i, k+1, j) + temp35b1 - temp35b0 vb0(i, k-2, j) = vb0(i, k-2, j) - temp35b1 - temp35b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb k = kts + 1 temp35b2 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i& & , k) temp35b3 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp35b2 romb(i, k, j-1) = romb(i, k, j-1) + temp35b2 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp35b3 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp35b3 vfluxb(i, k) = 0.0 END DO DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp31 = v(i, k+2, j) - v(i, k-3, j) + 10.*(v(i, k, j)-v(i, k-& & 1, j)) - 5.*(v(i, k+1, j)-v(i, k-2, j)) temp34 = SIGN(1., -vel) temp33 = temp34/60.0 temp32 = SIGN(1, time_step) temp31b51 = vel*vfluxb(i, k) temp31b52 = temp31b51/60.0 temp31b53 = -(temp32*temp33*temp31b51) velb = ((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1, j)+v(i, k& & -2, j))+v(i, k+2, j)+v(i, k-3, j))/60.0-temp32*(temp33*& & temp31))*vfluxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 10.*temp31b53 + 37.*temp31b52 vb0(i, k-1, j) = vb0(i, k-1, j) + 37.*temp31b52 - 10.*& & temp31b53 vb0(i, k+1, j) = vb0(i, k+1, j) - 5.*temp31b53 - 8.*temp31b52 vb0(i, k-2, j) = vb0(i, k-2, j) + 5.*temp31b53 - 8.*temp31b52 vb0(i, k+2, j) = vb0(i, k+2, j) + temp31b53 + temp31b52 vb0(i, k-3, j) = vb0(i, k-3, j) + temp31b52 - temp31b53 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb END DO END DO END DO ELSE IF (vert_order .EQ. 4) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp43b7 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j& & )) vfluxb(i, k+1) = vfluxb(i, k+1) + temp43b7 vfluxb(i, k) = vfluxb(i, k) - temp43b7 END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp43b3 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i& & , k) temp43b4 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp43b3 romb(i, k, j-1) = romb(i, k, j-1) + temp43b3 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp43b4 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp43b4 vfluxb(i, k) = 0.0 k = kts + 1 temp43b5 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i& & , k) temp43b6 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp43b5 romb(i, k, j-1) = romb(i, k, j-1) + temp43b5 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp43b6 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp43b6 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+2,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp43b2 = vel*vfluxb(i, k)/12.0 velb = (7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j)& & )*vfluxb(i, k)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp43b2 vb0(i, k-1, j) = vb0(i, k-1, j) + 7.*temp43b2 vb0(i, k+1, j) = vb0(i, k+1, j) - temp43b2 vb0(i, k-2, j) = vb0(i, k-2, j) - temp43b2 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb END DO END DO END DO ELSE IF (vert_order .EQ. 3) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp47b3 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j& & )) vfluxb(i, k+1) = vfluxb(i, k+1) + temp47b3 vfluxb(i, k) = vfluxb(i, k) - temp47b3 END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp47b = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, & & k) temp47b0 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp47b romb(i, k, j-1) = romb(i, k, j-1) + temp47b vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp47b0 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp47b0 vfluxb(i, k) = 0.0 k = kts + 1 temp47b1 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i& & , k) temp47b2 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp47b1 romb(i, k, j-1) = romb(i, k, j-1) + temp47b1 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp47b2 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp47b2 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+2,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp43 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1& & , j)) temp46 = SIGN(1., -vel) temp45 = temp46/12.0 temp44 = SIGN(1, time_step) temp43b8 = vel*vfluxb(i, k) temp43b9 = temp43b8/12.0 temp43b10 = temp44*temp45*temp43b8 velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j& & ))/12.0+temp44*(temp45*temp43))*vfluxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp43b9 - 3.*temp43b10 vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp43b10 + 7.*temp43b9 vb0(i, k+1, j) = vb0(i, k+1, j) + temp43b10 - temp43b9 vb0(i, k-2, j) = vb0(i, k-2, j) - temp43b10 - temp43b9 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb END DO END DO END DO ELSE IF (vert_order .EQ. 2) THEN vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp47b6 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j& & )) vfluxb(i, k+1) = vfluxb(i, k+1) + temp47b6 vfluxb(i, k) = vfluxb(i, k) - temp47b6 END DO END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 temp47b4 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(& & i, k) temp47b5 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp47b4 romb(i, k, j-1) = romb(i, k, j-1) + temp47b4 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp47b5 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp47b5 vfluxb(i, k) = 0.0 END DO END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from52) CALL POPINTEGER4(ad_to52) DO j=ad_to52,ad_from52,-1 DO k=ktf,kts,-1 dum = ru(ite, k, jm) - ru(ite-1, k, jm) dup = ru(ite, k, jp) - ru(ite-1, k, jp) temp31b41 = -(mrdx*tendencyb(ite-1, k, j)) temp31b42 = 0.5*v(ite-1, k, j)*temp31b41 ubb = (v_old(ite-1, k, j)-v_old(ite-2, k, j))*temp31b41 v_oldb(ite-1, k, j) = v_oldb(ite-1, k, j) + ub*temp31b41 v_oldb(ite-2, k, j) = v_oldb(ite-2, k, j) - ub*temp31b41 vb0(ite-1, k, j) = vb0(ite-1, k, j) + 0.5*(dup+dum)*temp31b41 dupb = temp31b42 dumb = temp31b42 rub(ite, k, jm) = rub(ite, k, jm) + dumb rub(ite-1, k, jm) = rub(ite-1, k, jm) - dumb rub(ite, k, jp) = rub(ite, k, jp) + dupb rub(ite-1, k, jp) = rub(ite-1, k, jp) - dupb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF rub(ite, k, jp) = rub(ite, k, jp) + 0.5*uwb rub(ite, k, jm) = rub(ite, k, jm) + 0.5*uwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jm) ELSE CALL POPINTEGER4(jm) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jp) ELSE CALL POPINTEGER4(jp) END IF CALL POPREAL8(mrdx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from51) CALL POPINTEGER4(ad_to51) DO j=ad_to51,ad_from51,-1 DO k=ktf,kts,-1 dum = ru(its+1, k, jm) - ru(its, k, jm) dup = ru(its+1, k, jp) - ru(its, k, jp) temp31b39 = -(mrdx*tendencyb(its, k, j)) temp31b40 = 0.5*v(its, k, j)*temp31b39 ubb = (v_old(its+1, k, j)-v_old(its, k, j))*temp31b39 v_oldb(its+1, k, j) = v_oldb(its+1, k, j) + ub*temp31b39 v_oldb(its, k, j) = v_oldb(its, k, j) - ub*temp31b39 vb0(its, k, j) = vb0(its, k, j) + 0.5*(dup+dum)*temp31b39 dupb = temp31b40 dumb = temp31b40 rub(its+1, k, jm) = rub(its+1, k, jm) + dumb rub(its, k, jm) = rub(its, k, jm) - dumb rub(its+1, k, jp) = rub(its+1, k, jp) + dupb rub(its, k, jp) = rub(its, k, jp) - dupb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF rub(its, k, jp) = rub(its, k, jp) + 0.5*uwb rub(its, k, jm) = rub(its, k, jm) + 0.5*uwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jm) ELSE CALL POPINTEGER4(jm) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jp) ELSE CALL POPINTEGER4(jp) END IF CALL POPREAL8(mrdx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from50) CALL POPINTEGER4(ad_to50) DO i=ad_to50,ad_from50,-1 DO k=ktf,kts,-1 temp31b38 = -(rdy*tendencyb(i, k, jte)) vbb = (v_old(i, k, jte)-v_old(i, k, jte-1))*temp31b38 v_oldb(i, k, jte) = v_oldb(i, k, jte) + vb*temp31b38 v_oldb(i, k, jte-1) = v_oldb(i, k, jte-1) - vb*temp31b38 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte) = rvb(i, k, jte) + vbb mutb(i, jte-1) = mutb(i, jte-1) + cb*vbb END IF END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from49) CALL POPINTEGER4(ad_to49) DO i=ad_to49,ad_from49,-1 DO k=ktf,kts,-1 temp31b37 = -(rdy*tendencyb(i, k, jts)) vbb = (v_old(i, k, jts+1)-v_old(i, k, jts))*temp31b37 v_oldb(i, k, jts+1) = v_oldb(i, k, jts+1) + vb*temp31b37 v_oldb(i, k, jts) = v_oldb(i, k, jts) - vb*temp31b37 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts) = rvb(i, k, jts) + vbb mutb(i, jts) = mutb(i, jts) - cb*vbb END IF END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO i=ite,its,-1 DO k=ktf,kts,-1 tendencyb(i, k, jte) = 0.0 END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO i=ite,its,-1 DO k=ktf,kts,-1 tendencyb(i, k, jts) = 0.0 END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from48) CALL POPINTEGER4(ad_to48) DO j=ad_to48,ad_from48,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from47) CALL POPINTEGER4(ad_to47) DO i=ad_to47,ad_from47,-1 mrdx = msfvy(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to46) DO i=ad_to46,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp31b36 = vel*fqxb(i, k)/12.0 velb = (7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2& & , k, j))*fqxb(i, k)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b36 vb0(i-1, k, j) = vb0(i-1, k, j) + 7.*temp31b36 vb0(i+1, k, j) = vb0(i+1, k, j) - temp31b36 vb0(i-2, k, j) = vb0(i-2, k, j) - temp31b36 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp31b34 = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(& & i, k) temp31b35 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))& & *fqxb(i, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp31b34 rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp31b34 vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp31b35 vb0(i_end, k, j) = vb0(i_end, k, j) + temp31b35 fqxb(i, k) = 0.0 END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from46) DO i=i_start_f-1,ad_from46,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp31b33 = vel*fqxb(i, k)/12.0 velb = (7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2& & , k, j))*fqxb(i, k)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b33 vb0(i-1, k, j) = vb0(i-1, k, j) + 7.*temp31b33 vb0(i+1, k, j) = vb0(i+1, k, j) - temp31b33 vb0(i-2, k, j) = vb0(i-2, k, j) - temp31b33 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp31b31 = 0.25*(v(i, k, j)+v(i-1, k, j))*fqxb(i, k) temp31b32 = 0.25*(ru(i, k, j)+ru(i, k, j-1))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp31b31 rub(i, k, j-1) = rub(i, k, j-1) + temp31b31 vb0(i, k, j) = vb0(i, k, j) + temp31b32 vb0(i-1, k, j) = vb0(i-1, k, j) + temp31b32 fqxb(i, k) = 0.0 END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp31b30 = vel*fqxb(i, k)/60.0 velb = (37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, j)+v(i-2& & , k, j))+v(i+2, k, j)+v(i-3, k, j))*fqxb(i, k)/60.0 vb0(i, k, j) = vb0(i, k, j) + 37.*temp31b30 vb0(i-1, k, j) = vb0(i-1, k, j) + 37.*temp31b30 vb0(i+1, k, j) = vb0(i+1, k, j) - 8.*temp31b30 vb0(i-2, k, j) = vb0(i-2, k, j) - 8.*temp31b30 vb0(i+2, k, j) = vb0(i+2, k, j) + temp31b30 vb0(i-3, k, j) = vb0(i-3, k, j) + temp31b30 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from45) CALL POPINTEGER4(ad_to45) DO j=ad_to45,ad_from45,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from42) CALL POPINTEGER4(ad_to42) DO i=ad_to42,ad_from42,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from43) CALL POPINTEGER4(ad_to43) DO i=ad_to43,ad_from43,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from44) CALL POPINTEGER4(ad_to44) DO i=ad_to44,ad_from44,-1 mrdy = msfvy(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from37) CALL POPINTEGER4(ad_to37) DO i=ad_to37,ad_from37,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp31b23 = vel*fqyb(i, k, jp1)/60.0 velb = (37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i, k, j+1)+v& & (i, k, j-2))+v(i, k, j+2)+v(i, k, j-3))*fqyb(i, k, jp1& & )/60.0 vb0(i, k, j) = vb0(i, k, j) + 37.*temp31b23 vb0(i, k, j-1) = vb0(i, k, j-1) + 37.*temp31b23 vb0(i, k, j+1) = vb0(i, k, j+1) - 8.*temp31b23 vb0(i, k, j-2) = vb0(i, k, j-2) - 8.*temp31b23 vb0(i, k, j+2) = vb0(i, k, j+2) + temp31b23 vb0(i, k, j-3) = vb0(i, k, j-3) + temp31b23 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from38) CALL POPINTEGER4(ad_to38) DO i=ad_to38,ad_from38,-1 temp31b24 = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1) temp31b25 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, & & jp1) rvb(i, k, j) = rvb(i, k, j) + temp31b24 rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b24 vb0(i, k, j) = vb0(i, k, j) + temp31b25 vbb = temp31b25 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j-1) = vb0(i, k, j-1) + vbb END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from39) CALL POPINTEGER4(ad_to39) DO i=ad_to39,ad_from39,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp31b26 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k& & , j-2))*fqyb(i, k, jp1)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b26 vb0(i, k, j-1) = vb0(i, k, j-1) + 7.*temp31b26 vb0(i, k, j+1) = vb0(i, k, j+1) - temp31b26 vb0(i, k, j-2) = vb0(i, k, j-2) - temp31b26 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from40) CALL POPINTEGER4(ad_to40) DO i=ad_to40,ad_from40,-1 temp31b27 = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1) temp31b28 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, & & jp1) rvb(i, k, j) = rvb(i, k, j) + temp31b27 rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b27 vbb = temp31b28 vb0(i, k, j-1) = vb0(i, k, j-1) + temp31b28 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j-1) = vb0(i, k, j-1) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j) = vb0(i, k, j) + vbb END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from41) CALL POPINTEGER4(ad_to41) DO i=ad_to41,ad_from41,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp31b29 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, & & j-2))*fqyb(i, k, jp1)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp31b29 vb0(i, k, j-1) = vb0(i, k, j-1) + 7.*temp31b29 vb0(i, k, j+1) = vb0(i, k, j+1) - temp31b29 vb0(i, k, j-2) = vb0(i, k, j-2) - temp31b29 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF END DO ELSE IF (branch .EQ. 1) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO j=ad_to10,ad_from10,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 mrdx = msfvy(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to8) DO i=ad_to8,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp19 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(& & i-1, k, j)) temp22 = SIGN(1., vel) temp21 = temp22/12.0 temp20 = SIGN(1, time_step) temp19b1 = vel*fqxb(i, k) temp19b2 = temp19b1/12.0 temp19b3 = temp20*temp21*temp19b1 velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2& & , k, j))/12.0+temp20*(temp21*temp19))*fqxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp19b2 - 3.*temp19b3 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp19b3 + 7.*& & temp19b2 vb0(i+1, k, j) = vb0(i+1, k, j) + temp19b3 - temp19b2 vb0(i-2, k, j) = vb0(i-2, k, j) - temp19b3 - temp19b2 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp19b = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i& & , k) temp19b0 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*& & fqxb(i, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp19b rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp19b vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp19b0 vb0(i_end, k, j) = vb0(i_end, k, j) + temp19b0 fqxb(i, k) = 0.0 END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from8) DO i=i_start_f-1,ad_from8,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp15 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(& & i-1, k, j)) temp18 = SIGN(1., vel) temp17 = temp18/12.0 temp16 = SIGN(1, time_step) temp15b1 = vel*fqxb(i, k) temp15b2 = temp15b1/12.0 temp15b3 = temp16*temp17*temp15b1 velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2& & , k, j))/12.0+temp16*(temp17*temp15))*fqxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp15b2 - 3.*temp15b3 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp15b3 + 7.*& & temp15b2 vb0(i+1, k, j) = vb0(i+1, k, j) + temp15b3 - temp15b2 vb0(i-2, k, j) = vb0(i-2, k, j) - temp15b3 - temp15b2 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp15b = 0.25*(v(i, k, j)+v(i-1, k, j))*fqxb(i, k) temp15b0 = 0.25*(ru(i, k, j)+ru(i, k, j-1))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp15b rub(i, k, j-1) = rub(i, k, j-1) + temp15b vb0(i, k, j) = vb0(i, k, j) + temp15b0 vb0(i-1, k, j) = vb0(i-1, k, j) + temp15b0 fqxb(i, k) = 0.0 END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp11 = v(i+2, k, j) - v(i-3, k, j) + 10.*(v(i, k, j)-v(i-1& & , k, j)) - 5.*(v(i+1, k, j)-v(i-2, k, j)) temp14 = SIGN(1., vel) temp13 = temp14/60.0 temp12 = SIGN(1, time_step) temp11b = vel*fqxb(i, k) temp11b0 = temp11b/60.0 temp11b1 = -(temp12*temp13*temp11b) velb = ((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, j)+v(i-& & 2, k, j))+v(i+2, k, j)+v(i-3, k, j))/60.0-temp12*(temp13*& & temp11))*fqxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 10.*temp11b1 + 37.*temp11b0 vb0(i-1, k, j) = vb0(i-1, k, j) + 37.*temp11b0 - 10.*& & temp11b1 vb0(i+1, k, j) = vb0(i+1, k, j) - 5.*temp11b1 - 8.*temp11b0 vb0(i-2, k, j) = vb0(i-2, k, j) + 5.*temp11b1 - 8.*temp11b0 vb0(i+2, k, j) = vb0(i+2, k, j) + temp11b1 + temp11b0 vb0(i-3, k, j) = vb0(i-3, k, j) + temp11b0 - temp11b1 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO j=ad_to7,ad_from7,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 mrdy = msfvy(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp = v(i, k, j+2) - v(i, k, j-3) + 10.*(v(i, k, j)-v(i& & , k, j-1)) - 5.*(v(i, k, j+1)-v(i, k, j-2)) temp2 = SIGN(1., vel) temp1 = temp2/60.0 temp0 = SIGN(1, time_step) tempb = vel*fqyb(i, k, jp1) tempb0 = tempb/60.0 tempb1 = -(temp0*temp1*tempb) velb = ((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i, k, j+1)+& & v(i, k, j-2))+v(i, k, j+2)+v(i, k, j-3))/60.0-temp0*(& & temp1*temp))*fqyb(i, k, jp1) vb0(i, k, j) = vb0(i, k, j) + 10.*tempb1 + 37.*tempb0 vb0(i, k, j-1) = vb0(i, k, j-1) + 37.*tempb0 - 10.*& & tempb1 vb0(i, k, j+1) = vb0(i, k, j+1) - 5.*tempb1 - 8.*tempb0 vb0(i, k, j-2) = vb0(i, k, j-2) + 5.*tempb1 - 8.*tempb0 vb0(i, k, j+2) = vb0(i, k, j+2) + tempb1 + tempb0 vb0(i, k, j-3) = vb0(i, k, j-3) + tempb0 - tempb1 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 temp3b = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1) temp3b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, & & jp1) rvb(i, k, j) = rvb(i, k, j) + temp3b rvb(i, k, j-1) = rvb(i, k, j-1) + temp3b vb0(i, k, j) = vb0(i, k, j) + temp3b0 vbb = temp3b0 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j-1) = vb0(i, k, j-1) + vbb END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp3 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i& & , k, j-1)) temp6 = SIGN(1., vel) temp5 = temp6/12.0 temp4 = SIGN(1, time_step) temp3b1 = vel*fqyb(i, k, jp1) temp3b2 = temp3b1/12.0 temp3b3 = temp4*temp5*temp3b1 velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, & & k, j-2))/12.0+temp4*(temp5*temp3))*fqyb(i, k, jp1) vb0(i, k, j) = vb0(i, k, j) + 7.*temp3b2 - 3.*temp3b3 vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp3b3 + 7.*& & temp3b2 vb0(i, k, j+1) = vb0(i, k, j+1) + temp3b3 - temp3b2 vb0(i, k, j-2) = vb0(i, k, j-2) - temp3b3 - temp3b2 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp7b = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1) temp7b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp7b rvb(i, k, j-1) = rvb(i, k, j-1) + temp7b vbb = temp7b0 vb0(i, k, j-1) = vb0(i, k, j-1) + temp7b0 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j-1) = vb0(i, k, j-1) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j) = vb0(i, k, j) + vbb END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp7 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, & & k, j-1)) temp10 = SIGN(1., vel) temp9 = temp10/12.0 temp8 = SIGN(1, time_step) temp7b1 = vel*fqyb(i, k, jp1) temp7b2 = temp7b1/12.0 temp7b3 = temp8*temp9*temp7b1 velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k& & , j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, jp1) vb0(i, k, j) = vb0(i, k, j) + 7.*temp7b2 - 3.*temp7b3 vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp7b3 + 7.*temp7b2 vb0(i, k, j+1) = vb0(i, k, j+1) + temp7b3 - temp7b2 vb0(i, k, j-2) = vb0(i, k, j-2) - temp7b3 - temp7b2 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF END DO ELSE fqxb = 0.0 CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO j=ad_to19,ad_from19,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO i=ad_to18,ad_from18,-1 mrdx = msfvy(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp23b7 = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i_end& & +1, k) temp23b8 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*fqxb& & (i_end+1, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp23b7 rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp23b7 vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp23b8 vb0(i_end, k, j) = vb0(i_end, k, j) + temp23b8 fqxb(i_end+1, k) = 0.0 END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp23b5 = 0.25*(v(i_start, k, j)+v(i_start-1, k, j))*fqxb(& & i_start, k) temp23b6 = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))*fqxb& & (i_start, k) rub(i_start, k, j) = rub(i_start, k, j) + temp23b5 rub(i_start, k, j-1) = rub(i_start, k, j-1) + temp23b5 vb0(i_start, k, j) = vb0(i_start, k, j) + temp23b6 vb0(i_start-1, k, j) = vb0(i_start-1, k, j) + temp23b6 fqxb(i_start, k) = 0.0 END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp23b4 = vel*fqxb(i, k)/12.0 velb = (7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k, & & j))*fqxb(i, k)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp23b4 vb0(i-1, k, j) = vb0(i-1, k, j) + 7.*temp23b4 vb0(i+1, k, j) = vb0(i+1, k, j) - temp23b4 vb0(i-2, k, j) = vb0(i-2, k, j) - temp23b4 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO j=ad_to17,ad_from17,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO i=ad_to15,ad_from15,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO i=ad_to16,ad_from16,-1 mrdy = msfvy(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO i=ad_to11,ad_from11,-1 temp23b = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1) temp23b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1& & ) rvb(i, k, j) = rvb(i, k, j) + temp23b rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b vb0(i, k, j) = vb0(i, k, j) + temp23b0 vbb = temp23b0 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j-1) = vb0(i, k, j-1) + vbb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 temp23b1 = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1) temp23b2 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1& & ) rvb(i, k, j) = rvb(i, k, j) + temp23b1 rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b1 vbb = temp23b2 vb0(i, k, j-1) = vb0(i, k, j-1) + temp23b2 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j-1) = vb0(i, k, j-1) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j) = vb0(i, k, j) + vbb END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp23b3 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, & & j-2))*fqyb(i, k, jp1)/12.0 vb0(i, k, j) = vb0(i, k, j) + 7.*temp23b3 vb0(i, k, j-1) = vb0(i, k, j-1) + 7.*temp23b3 vb0(i, k, j+1) = vb0(i, k, j+1) - temp23b3 vb0(i, k, j-2) = vb0(i, k, j-2) - temp23b3 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF END DO END IF ELSE IF (branch .EQ. 3) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from28) CALL POPINTEGER4(ad_to28) DO j=ad_to28,ad_from28,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from27) CALL POPINTEGER4(ad_to27) DO i=ad_to27,ad_from27,-1 mrdx = msfvy(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp31b1 = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i_end+1& & , k) temp31b2 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*fqxb(& & i_end+1, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp31b1 rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp31b1 vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp31b2 vb0(i_end, k, j) = vb0(i_end, k, j) + temp31b2 fqxb(i_end+1, k) = 0.0 END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp31b = 0.25*(v(i_start, k, j)+v(i_start-1, k, j))*fqxb(& & i_start, k) temp31b0 = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))*fqxb(& & i_start, k) rub(i_start, k, j) = rub(i_start, k, j) + temp31b rub(i_start, k, j-1) = rub(i_start, k, j-1) + temp31b vb0(i_start, k, j) = vb0(i_start, k, j) + temp31b0 vb0(i_start-1, k, j) = vb0(i_start-1, k, j) + temp31b0 fqxb(i_start, k) = 0.0 END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp27 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(i-1, k& & , j)) temp30 = SIGN(1., vel) temp29 = temp30/12.0 temp28 = SIGN(1, time_step) temp27b = vel*fqxb(i, k) temp27b0 = temp27b/12.0 temp27b1 = temp28*temp29*temp27b velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k, j& & ))/12.0+temp28*(temp29*temp27))*fqxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp27b0 - 3.*temp27b1 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp27b1 + 7.*temp27b0 vb0(i+1, k, j) = vb0(i+1, k, j) + temp27b1 - temp27b0 vb0(i-2, k, j) = vb0(i-2, k, j) - temp27b1 - temp27b0 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from26) CALL POPINTEGER4(ad_to26) DO j=ad_to26,ad_from26,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from24) CALL POPINTEGER4(ad_to24) DO i=ad_to24,ad_from24,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from25) CALL POPINTEGER4(ad_to25) DO i=ad_to25,ad_from25,-1 mrdy = msfvy(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO i=ad_to20,ad_from20,-1 temp23b9 = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1) temp23b10 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp23b9 rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b9 vb0(i, k, j) = vb0(i, k, j) + temp23b10 vbb = temp23b10 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j-1) = vb0(i, k, j-1) + vbb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO i=ad_to21,ad_from21,-1 temp23b11 = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1) temp23b12 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp23b11 rvb(i, k, j-1) = rvb(i, k, j-1) + temp23b11 vbb = temp23b12 vb0(i, k, j-1) = vb0(i, k, j-1) + temp23b12 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j-1) = vb0(i, k, j-1) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j) = vb0(i, k, j) + vbb END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO i=ad_to22,ad_from22,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp23 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, k& & , j-1)) temp26 = SIGN(1., vel) temp25 = temp26/12.0 temp24 = SIGN(1, time_step) temp23b13 = vel*fqyb(i, k, jp1) temp23b14 = temp23b13/12.0 temp23b15 = temp24*temp25*temp23b13 velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, j& & -2))/12.0+temp24*(temp25*temp23))*fqyb(i, k, jp1) vb0(i, k, j) = vb0(i, k, j) + 7.*temp23b14 - 3.*temp23b15 vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp23b15 + 7.*& & temp23b14 vb0(i, k, j+1) = vb0(i, k, j+1) + temp23b15 - temp23b14 vb0(i, k, j-2) = vb0(i, k, j-2) - temp23b15 - temp23b14 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF END DO ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from36) CALL POPINTEGER4(ad_to36) DO j=ad_to36,ad_from36,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from35) CALL POPINTEGER4(ad_to35) DO i=ad_to35,ad_from35,-1 mrdx = msfvy(i, j)*rdx temp31b18 = -(mrdx*0.25*tendencyb(i, k, j)) temp31b19 = (v(i+1, k, j)+v(i, k, j))*temp31b18 temp31b20 = (ru(i+1, k, j)+ru(i+1, k, j-1))*temp31b18 temp31b21 = -((v(i, k, j)+v(i-1, k, j))*temp31b18) temp31b22 = -((ru(i, k, j)+ru(i, k, j-1))*temp31b18) rub(i+1, k, j) = rub(i+1, k, j) + temp31b19 rub(i+1, k, j-1) = rub(i+1, k, j-1) + temp31b19 vb0(i+1, k, j) = vb0(i+1, k, j) + temp31b20 vb0(i, k, j) = vb0(i, k, j) + temp31b22 + temp31b20 rub(i, k, j) = rub(i, k, j) + temp31b21 rub(i, k, j-1) = rub(i, k, j-1) + temp31b21 vb0(i-1, k, j) = vb0(i-1, k, j) + temp31b22 END DO END DO END DO CALL POPINTEGER4(j) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from34) CALL POPINTEGER4(ad_to34) DO i=ad_to34,ad_from34,-1 mrdy = msfvy(i, j)*rdy temp31b13 = -(mrdy*0.25*tendencyb(i, k, j)) temp31b14 = (vb+v(i, k, j))*temp31b13 temp31b15 = (rv(i, k, j+1)+rv(i, k, j))*temp31b13 temp31b16 = -((v(i, k, j)+v(i, k, j-1))*temp31b13) temp31b17 = -((rv(i, k, j)+rv(i, k, j-1))*temp31b13) rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b14 rvb(i, k, j) = rvb(i, k, j) + temp31b16 + temp31b14 vbb = temp31b15 vb0(i, k, j) = vb0(i, k, j) + temp31b17 + temp31b15 rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b16 vb0(i, k, j-1) = vb0(i, k, j-1) + temp31b17 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j+1) = vb0(i, k, j+1) + vbb END DO END DO CALL POPINTEGER4(j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from33) CALL POPINTEGER4(ad_to33) DO i=ad_to33,ad_from33,-1 mrdy = msfvy(i, j)*rdy temp31b8 = -(mrdy*0.25*tendencyb(i, k, j)) temp31b9 = (v(i, k, j+1)+v(i, k, j))*temp31b8 temp31b10 = (rv(i, k, j+1)+rv(i, k, j))*temp31b8 temp31b11 = -((v(i, k, j)+vb)*temp31b8) temp31b12 = -((rv(i, k, j)+rv(i, k, j-1))*temp31b8) rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b9 rvb(i, k, j) = rvb(i, k, j) + temp31b11 + temp31b9 vb0(i, k, j+1) = vb0(i, k, j+1) + temp31b10 vb0(i, k, j) = vb0(i, k, j) + temp31b12 + temp31b10 rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b11 vbb = temp31b12 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j-1) = vb0(i, k, j-1) + vbb END DO END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from32) CALL POPINTEGER4(ad_to32) DO i=ad_to32,ad_from32,-1 tendencyb(i, k, jde) = 0.0 END DO END DO ELSE IF (branch .NE. 1) THEN GOTO 100 END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from31) CALL POPINTEGER4(ad_to31) DO i=ad_to31,ad_from31,-1 tendencyb(i, k, jds) = 0.0 END DO END DO END IF 100 CALL POPINTEGER4(ad_from30) CALL POPINTEGER4(ad_to30) DO j=ad_to30,ad_from30,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from29) CALL POPINTEGER4(ad_to29) DO i=ad_to29,ad_from29,-1 mrdy = msfvy(i, j)*rdy temp31b3 = -(mrdy*0.25*tendencyb(i, k, j)) temp31b4 = (v(i, k, j+1)+v(i, k, j))*temp31b3 temp31b5 = (rv(i, k, j+1)+rv(i, k, j))*temp31b3 temp31b6 = -((v(i, k, j)+v(i, k, j-1))*temp31b3) temp31b7 = -((rv(i, k, j)+rv(i, k, j-1))*temp31b3) rvb(i, k, j+1) = rvb(i, k, j+1) + temp31b4 rvb(i, k, j) = rvb(i, k, j) + temp31b6 + temp31b4 vb0(i, k, j+1) = vb0(i, k, j+1) + temp31b5 vb0(i, k, j) = vb0(i, k, j) + temp31b7 + temp31b5 rvb(i, k, j-1) = rvb(i, k, j-1) + temp31b6 vb0(i, k, j-1) = vb0(i, k, j-1) + temp31b7 END DO END DO END DO END IF END SUBROUTINE A_ADVECT_V ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35 ! ! Differentiation of advect_scalar in reverse (adjoint) mode: ! gradient of useful results: rom field tendency ru rv field_old ! with respect to varying inputs: rom field tendency ru rv field_old ! RW status of diff variables: rom:incr field:incr tendency:in-out ! ru:incr rv:incr field_old:incr SUBROUTINE A_ADVECT_SCALAR(field, fieldb, field_old, field_oldb, & & tendency, tendencyb, ru, rub, rv, rvb, rom, romb, mut, time_step, & & config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx& & , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, & & kme, its, ite, jts, jte, kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, & & field_old, ru, rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub& & , rvb, romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw REAL :: ubb, vbb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: branch INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 INTEGER :: ad_from24 INTEGER :: ad_to24 INTEGER :: ad_from25 INTEGER :: ad_to25 INTEGER :: ad_from26 INTEGER :: ad_to26 INTEGER :: ad_from27 INTEGER :: ad_to27 INTEGER :: ad_from28 INTEGER :: ad_to28 INTEGER :: ad_from29 INTEGER :: ad_to29 INTEGER :: ad_from30 INTEGER :: ad_to30 INTEGER :: ad_from31 INTEGER :: ad_to31 INTEGER :: ad_from32 INTEGER :: ad_to32 INTEGER :: ad_from33 INTEGER :: ad_to33 INTEGER :: ad_from34 INTEGER :: ad_to34 INTEGER :: ad_from35 INTEGER :: ad_to35 INTEGER :: ad_from36 INTEGER :: ad_to36 INTEGER :: ad_from37 INTEGER :: ad_to37 INTEGER :: ad_from38 INTEGER :: ad_to38 INTEGER :: ad_from39 INTEGER :: ad_to39 INTEGER :: ad_from40 INTEGER :: ad_to40 INTEGER :: ad_from41 INTEGER :: ad_to41 INTEGER :: ad_from42 INTEGER :: ad_to42 INTEGER :: ad_from43 INTEGER :: ad_to43 INTEGER :: ad_from44 INTEGER :: ad_to44 INTEGER :: ad_from45 INTEGER :: ad_to45 INTEGER :: ad_from46 INTEGER :: ad_to46 INTEGER :: ad_from47 INTEGER :: ad_to47 INTEGER :: ad_from48 INTEGER :: ad_to48 INTEGER :: ad_from49 INTEGER :: ad_to49 INTEGER :: ad_from50 INTEGER :: ad_to50 REAL :: temp3 REAL :: temp29 REAL :: temp2 INTEGER :: temp28 REAL :: temp1 REAL :: temp27 INTEGER :: temp0 REAL :: temp26 REAL :: temp7b REAL :: temp25 INTEGER :: temp24 REAL :: temp23 REAL :: temp22 REAL :: temp21 INTEGER :: temp20 REAL :: temp35b2 REAL :: temp35b1 REAL :: temp35b0 REAL :: temp19b REAL :: temp23b7 REAL :: temp23b6 REAL :: temp27b REAL :: temp23b5 REAL :: temp35b REAL :: tempb1 REAL :: temp23b4 REAL :: temp43b REAL :: tempb0 REAL :: temp23b3 REAL :: temp23b2 REAL :: temp23b1 REAL :: temp23b0 REAL :: temp3b REAL :: temp7b2 REAL :: temp7b1 REAL :: temp7b0 REAL :: temp31b34 REAL :: temp19 REAL :: temp31b33 REAL :: temp18 REAL :: temp31b32 REAL :: temp17 REAL :: temp31b31 INTEGER :: temp16 REAL :: temp31b30 REAL :: temp15 REAL :: temp14 REAL :: temp11b1 REAL :: temp13 REAL :: temp11b0 REAL :: temp43b5 INTEGER :: temp12 REAL :: temp43b4 REAL :: temp11 REAL :: temp43b3 REAL :: temp10 REAL :: temp43b2 REAL :: temp15b REAL :: temp43b1 REAL :: temp46 REAL :: temp23b REAL :: temp43b0 REAL :: temp45 REAL :: temp31b INTEGER :: temp44 REAL :: temp43 REAL :: temp42 REAL :: temp31b9 REAL :: temp41 REAL :: temp19b2 REAL :: temp31b8 INTEGER :: temp40 REAL :: temp19b1 REAL :: temp31b7 REAL :: temp19b0 REAL :: temp31b6 REAL :: temp31b5 REAL :: temp31b4 REAL :: temp31b3 REAL :: tempb REAL :: temp31b2 REAL :: temp31b1 REAL :: temp31b0 REAL :: temp31b29 REAL :: temp31b28 REAL :: temp31b27 REAL :: temp31b26 REAL :: temp31b25 REAL :: temp31b24 REAL :: temp31b23 REAL :: temp31b22 REAL :: temp31b21 REAL :: temp11b REAL :: temp31b20 REAL :: temp39b1 REAL :: temp39b0 REAL :: temp39 REAL :: temp38 REAL :: temp37 REAL :: temp3b2 INTEGER :: temp36 REAL :: temp3b1 REAL :: temp35 REAL :: temp3b0 REAL :: temp34 REAL :: temp27b5 REAL :: temp33 REAL :: temp27b4 INTEGER :: temp32 REAL :: temp27b3 REAL :: temp31 REAL :: temp27b2 REAL :: temp30 REAL :: temp27b1 REAL :: temp27b0 INTRINSIC MIN REAL :: temp31b19 REAL :: temp31b18 REAL :: temp31b17 REAL :: temp31b16 REAL :: temp REAL :: temp15b2 REAL :: temp31b15 REAL :: temp15b1 REAL :: temp31b14 REAL :: temp15b0 REAL :: temp31b13 REAL :: temp9 REAL :: temp31b12 INTEGER :: temp8 REAL :: temp31b11 REAL :: temp39b REAL :: temp7 REAL :: temp31b10 REAL :: temp47b REAL :: temp6 REAL :: temp47b1 REAL :: temp5 REAL :: temp47b0 INTEGER :: temp4 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! begin with horizontal flux divergence ! here is the choice of flux operators IF (horz_order .EQ. 6) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from43 = j_start j_loop_y_flux_6:DO j=ad_from43,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from35 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from35) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from36 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from36) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! 4th order flux 2 in from south boundary DO k=kts,ktf ad_from37 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from37) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from38 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from38) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from39 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from39) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from40 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from40) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN DO k=kts,ktf ad_from41 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from41) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from42 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from42) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_6 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from43) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from46 = j_start ! compute fluxes DO j=ad_from46,j_end ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from44 = i_start DO i=ad_from44,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from44) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from45 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from45) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from46) CALL PUSHCONTROL3B(7) ELSE IF (horz_order .EQ. 5) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from7 = j_start j_loop_y_flux_5:DO j=ad_from7,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from4 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN DO k=kts,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from7) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from10 = j_start ! compute fluxes DO j=ad_from10,j_end ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from8 = i_start DO i=ad_from8,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from8) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from9 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from10) CALL PUSHCONTROL3B(6) ELSE IF (horz_order .EQ. 4) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 2 i_end_f = ide - 2 END IF ad_from12 = j_start ! compute fluxes DO j=ad_from12,j_end ! second order flux close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from11 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from11) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from12) CALL PUSHINTEGER4(i_start) ! next -> y flux divergence calculation i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN j_start = jds + 1 j_start_f = j_start + 1 END IF IF (degrade_ye) THEN j_end = jde - 2 j_end_f = jde - 2 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF jp1 = 2 jp0 = 1 ad_from19 = j_start DO j=ad_from19,j_end+1 IF (j .LT. j_start_f .AND. degrade_ys) THEN DO k=kts,ktf ad_from13 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) END DO CALL PUSHCONTROL2B(0) ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN DO k=kts,ktf ad_from14 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO CALL PUSHCONTROL2B(1) ELSE ! 3rd or 4th order flux DO k=kts,ktf ad_from15 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from15) END DO CALL PUSHCONTROL2B(2) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from16 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from16) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN DO k=kts,ktf ad_from17 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from17) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from18 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from18) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from19) CALL PUSHCONTROL3B(5) ELSE IF (horz_order .EQ. 3) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 2 i_end_f = ide - 2 END IF ad_from21 = j_start ! compute fluxes DO j=ad_from21,j_end ! second order flux close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from20 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from20) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from21) CALL PUSHINTEGER4(i_start) ! next -> y flux divergence calculation i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN j_start = jds + 1 j_start_f = j_start + 1 END IF IF (degrade_ye) THEN j_end = jde - 2 j_end_f = jde - 2 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF jp1 = 2 jp0 = 1 ad_from28 = j_start DO j=ad_from28,j_end+1 IF (j .LT. j_start_f .AND. degrade_ys) THEN DO k=kts,ktf ad_from22 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from22) END DO CALL PUSHCONTROL2B(0) ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN DO k=kts,ktf ad_from23 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) END DO CALL PUSHCONTROL2B(1) ELSE ! 3rd or 4th order flux DO k=kts,ktf ad_from24 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from24) END DO CALL PUSHCONTROL2B(2) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from25 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from25) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN DO k=kts,ktf ad_from26 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from26) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from27 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from27) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from28) CALL PUSHCONTROL3B(4) ELSE IF (horz_order .EQ. 2) THEN i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF IF (.NOT.config_flags%periodic_x) THEN IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF END IF END IF ad_from30 = j_start DO j=ad_from30,j_end DO k=kts,ktf ad_from29 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from29) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from30) i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 2 .GT. jte) THEN j_end = jte ELSE j_end = jde - 2 END IF END IF ad_from32 = j_start DO j=ad_from32,j_end DO k=kts,ktf ad_from31 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from31) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from32) ! Polar boundary condtions ! These won't be covered in the loop above... IF (config_flags%polar) THEN IF (jts .EQ. jds) THEN DO k=kts,ktf ad_from33 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from33) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (jte .EQ. jde) THEN DO k=kts,ktf ad_from34 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from34) END DO CALL PUSHCONTROL3B(3) ELSE CALL PUSHCONTROL3B(2) END IF ELSE CALL PUSHCONTROL3B(1) END IF ELSE CALL PUSHCONTROL3B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF CALL PUSHINTEGER4(j_start) j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! compute x (u) conditions for v, w, or scalar IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from47 = j_start DO j=ad_from47,j_end DO k=kts,ktf IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(its, k, j)+ru(its+1, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from47) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from48 = j_start DO j=ad_from48,j_end DO k=kts,ktf IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from48) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from49 = i_start DO i=ad_from49,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from49) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from50 = i_start DO i=ad_from50,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from50) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my) ! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my) ! So we don't need to make a correction for advect_scalar i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN CALL PUSHINTEGER4(j_end) j_end = jde - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(j_end) j_end = jte CALL PUSHCONTROL1B(1) END IF IF (vert_order .EQ. 6) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp31b28 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b28 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b28 vfluxb(i, k) = 0.0 k = ktf - 1 vel = rom(i, k, j) temp31b29 = vel*vfluxb(i, k)/12.0 velb = (7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-& & field(i, k-2, j))*vfluxb(i, k)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b29 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 7.*temp31b29 fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b29 fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b29 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb k = kts + 2 vel = rom(i, k, j) temp31b30 = vel*vfluxb(i, k)/12.0 velb = (7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-& & field(i, k-2, j))*vfluxb(i, k)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b30 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 7.*temp31b30 fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b30 fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b30 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb k = kts + 1 temp31b31 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b31 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b31 vfluxb(i, k) = 0.0 END DO DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 vel = rom(i, k, j) temp31b27 = vel*vfluxb(i, k)/60.0 velb = (37.*(field(i, k, j)+field(i, k-1, j))-8.*(field(i, k+1& & , j)+field(i, k-2, j))+field(i, k+2, j)+field(i, k-3, j))*& & vfluxb(i, k)/60.0 fieldb(i, k, j) = fieldb(i, k, j) + 37.*temp31b27 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 37.*temp31b27 fieldb(i, k+1, j) = fieldb(i, k+1, j) - 8.*temp31b27 fieldb(i, k-2, j) = fieldb(i, k-2, j) - 8.*temp31b27 fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b27 fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b27 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb END DO END DO END DO ELSE IF (vert_order .EQ. 5) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp43b = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b vfluxb(i, k) = 0.0 k = ktf - 1 vel = rom(i, k, j) temp39 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j& & )-field(i, k-1, j)) temp42 = SIGN(1., -vel) temp41 = temp42/12.0 temp40 = SIGN(1, time_step) temp39b = vel*vfluxb(i, k) temp39b0 = temp39b/12.0 temp39b1 = temp40*temp41*temp39b velb = ((7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-& & field(i, k-2, j))/12.0+temp40*(temp41*temp39))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp39b0 - 3.*temp39b1 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp39b1 + 7.*& & temp39b0 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp39b1 - temp39b0 fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp39b1 - temp39b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb k = kts + 2 vel = rom(i, k, j) temp35 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j& & )-field(i, k-1, j)) temp38 = SIGN(1., -vel) temp37 = temp38/12.0 temp36 = SIGN(1, time_step) temp35b = vel*vfluxb(i, k) temp35b0 = temp35b/12.0 temp35b1 = temp36*temp37*temp35b velb = ((7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-& & field(i, k-2, j))/12.0+temp36*(temp37*temp35))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp35b0 - 3.*temp35b1 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp35b1 + 7.*& & temp35b0 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp35b1 - temp35b0 fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp35b1 - temp35b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb k = kts + 1 temp35b2 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp35b2 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp35b2 vfluxb(i, k) = 0.0 END DO DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 vel = rom(i, k, j) temp31 = field(i, k+2, j) - field(i, k-3, j) + 10.*(field(i, k& & , j)-field(i, k-1, j)) - 5.*(field(i, k+1, j)-field(i, k-2, & & j)) temp34 = SIGN(1., -vel) temp33 = temp34/60.0 temp32 = SIGN(1, time_step) temp31b32 = vel*vfluxb(i, k) temp31b33 = temp31b32/60.0 temp31b34 = -(temp32*temp33*temp31b32) velb = ((37.*(field(i, k, j)+field(i, k-1, j))-8.*(field(i, k+& & 1, j)+field(i, k-2, j))+field(i, k+2, j)+field(i, k-3, j))/& & 60.0-temp32*(temp33*temp31))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp31b34 + 37.*& & temp31b33 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 37.*temp31b33 - 10.*& & temp31b34 fieldb(i, k+1, j) = fieldb(i, k+1, j) - 5.*temp31b34 - 8.*& & temp31b33 fieldb(i, k-2, j) = fieldb(i, k-2, j) + 5.*temp31b34 - 8.*& & temp31b33 fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b34 + temp31b33 fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b33 - temp31b34 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb END DO END DO END DO ELSE IF (vert_order .EQ. 4) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp43b1 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b1 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b1 vfluxb(i, k) = 0.0 k = kts + 1 temp43b2 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b2 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b2 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+2,-1 DO i=i_end,i_start,-1 vel = rom(i, k, j) temp43b0 = vel*vfluxb(i, k)/12.0 velb = (7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)-& & field(i, k-2, j))*vfluxb(i, k)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp43b0 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 7.*temp43b0 fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp43b0 fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb END DO END DO END DO ELSE IF (vert_order .EQ. 3) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp47b = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b vfluxb(i, k) = 0.0 k = kts + 1 temp47b0 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b0 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b0 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+2,-1 DO i=i_end,i_start,-1 vel = rom(i, k, j) temp43 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k& & , j)-field(i, k-1, j)) temp46 = SIGN(1., -vel) temp45 = temp46/12.0 temp44 = SIGN(1, time_step) temp43b3 = vel*vfluxb(i, k) temp43b4 = temp43b3/12.0 temp43b5 = temp44*temp45*temp43b3 velb = ((7.*(field(i, k, j)+field(i, k-1, j))-field(i, k+1, j)& & -field(i, k-2, j))/12.0+temp44*(temp45*temp43))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp43b4 - 3.*temp43b5 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp43b5 + 7.*& & temp43b4 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp43b5 - temp43b4 fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b5 - temp43b4 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb END DO END DO END DO ELSE IF (vert_order .EQ. 2) THEN vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 temp47b1 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b1 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b1 vfluxb(i, k) = 0.0 END DO END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(j_end) ELSE CALL POPINTEGER4(j_end) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from50) CALL POPINTEGER4(ad_to50) DO i=ad_to50,ad_from50,-1 DO k=ktf,kts,-1 temp31b25 = -(rdy*tendencyb(i, k, j_end)) temp31b26 = field(i, k, j_end)*temp31b25 vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*& & temp31b25 field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*temp31b25 field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*& & temp31b25 fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i& & , k, jte-1))*temp31b25 rvb(i, k, jte) = rvb(i, k, jte) + temp31b26 rvb(i, k, jte-1) = rvb(i, k, jte-1) - temp31b26 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from49) CALL POPINTEGER4(ad_to49) DO i=ad_to49,ad_from49,-1 DO k=ktf,kts,-1 temp31b23 = -(rdy*tendencyb(i, k, jts)) temp31b24 = field(i, k, jts)*temp31b23 vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*temp31b23 field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*temp31b23 field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*temp31b23 fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k& & , jts))*temp31b23 rvb(i, k, jts+1) = rvb(i, k, jts+1) + temp31b24 rvb(i, k, jts) = rvb(i, k, jts) - temp31b24 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from48) CALL POPINTEGER4(ad_to48) DO j=ad_to48,ad_from48,-1 DO k=ktf,kts,-1 temp31b21 = -(rdx*tendencyb(i_end, k, j)) temp31b22 = field(i_end, k, j)*temp31b21 ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*& & temp31b21 field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*temp31b21 field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*& & temp31b21 fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(& & ite-1, k, j))*temp31b21 rub(ite, k, j) = rub(ite, k, j) + temp31b22 rub(ite-1, k, j) = rub(ite-1, k, j) - temp31b22 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from47) CALL POPINTEGER4(ad_to47) DO j=ad_to47,ad_from47,-1 DO k=ktf,kts,-1 temp31b19 = -(rdx*tendencyb(its, k, j)) temp31b20 = field(its, k, j)*temp31b19 ubb = (field_old(its+1, k, j)-field_old(its, k, j))*temp31b19 field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*temp31b19 field_oldb(its, k, j) = field_oldb(its, k, j) - ub*temp31b19 fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its& & , k, j))*temp31b19 rub(its+1, k, j) = rub(its+1, k, j) + temp31b20 rub(its, k, j) = rub(its, k, j) - temp31b20 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(its, k, j) = rub(its, k, j) + 0.5*ubb rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPINTEGER4(j_start) CALL POPCONTROL3B(branch) IF (branch .LT. 4) THEN IF (branch .LT. 2) THEN IF (branch .EQ. 0) GOTO 100 ELSE IF (branch .NE. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from34) CALL POPINTEGER4(ad_to34) DO i=ad_to34,ad_from34,-1 mrdy = msftx(i, jde-1)*rdy temp31b7 = mrdy*0.5*tendencyb(i, k, jde-1) temp31b8 = rv(i, k, jde-1)*temp31b7 rvb(i, k, jde-1) = rvb(i, k, jde-1) + (field(i, k, jde-1)+& & field(i, k, jde-2))*temp31b7 fieldb(i, k, jde-1) = fieldb(i, k, jde-1) + temp31b8 fieldb(i, k, jde-2) = fieldb(i, k, jde-2) + temp31b8 END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from33) CALL POPINTEGER4(ad_to33) DO i=ad_to33,ad_from33,-1 mrdy = msftx(i, jds)*rdy temp31b5 = -(mrdy*0.5*tendencyb(i, k, jds)) temp31b6 = rv(i, k, jds+1)*temp31b5 rvb(i, k, jds+1) = rvb(i, k, jds+1) + (field(i, k, jds+1)+& & field(i, k, jds))*temp31b5 fieldb(i, k, jds+1) = fieldb(i, k, jds+1) + temp31b6 fieldb(i, k, jds) = fieldb(i, k, jds) + temp31b6 END DO END DO END IF END IF CALL POPINTEGER4(ad_from32) CALL POPINTEGER4(ad_to32) DO j=ad_to32,ad_from32,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from31) CALL POPINTEGER4(ad_to31) DO i=ad_to31,ad_from31,-1 mrdy = msftx(i, j)*rdy temp31b2 = -(mrdy*0.5*tendencyb(i, k, j)) temp31b3 = rv(i, k, j+1)*temp31b2 temp31b4 = -(rv(i, k, j)*temp31b2) rvb(i, k, j+1) = rvb(i, k, j+1) + (field(i, k, j+1)+field(i, k& & , j))*temp31b2 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp31b3 fieldb(i, k, j) = fieldb(i, k, j) + temp31b4 + temp31b3 rvb(i, k, j) = rvb(i, k, j) - (field(i, k, j)+field(i, k, j-1)& & )*temp31b2 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b4 END DO END DO END DO CALL POPINTEGER4(ad_from30) CALL POPINTEGER4(ad_to30) DO j=ad_to30,ad_from30,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from29) CALL POPINTEGER4(ad_to29) DO i=ad_to29,ad_from29,-1 mrdx = msftx(i, j)*rdx temp31b = -(mrdx*0.5*tendencyb(i, k, j)) temp31b0 = ru(i+1, k, j)*temp31b temp31b1 = -(ru(i, k, j)*temp31b) rub(i+1, k, j) = rub(i+1, k, j) + (field(i+1, k, j)+field(i, k& & , j))*temp31b fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp31b0 fieldb(i, k, j) = fieldb(i, k, j) + temp31b1 + temp31b0 rub(i, k, j) = rub(i, k, j) - (field(i, k, j)+field(i-1, k, j)& & )*temp31b fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b1 END DO END DO END DO ELSE IF (branch .LT. 6) THEN IF (branch .EQ. 4) THEN fqyb = 0.0 CALL POPINTEGER4(ad_from28) CALL POPINTEGER4(ad_to28) DO j=ad_to28,ad_from28,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from25) CALL POPINTEGER4(ad_to25) DO i=ad_to25,ad_from25,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from26) CALL POPINTEGER4(ad_to26) DO i=ad_to26,ad_from26,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from27) CALL POPINTEGER4(ad_to27) DO i=ad_to27,ad_from27,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO i=ad_to22,ad_from22,-1 temp27b1 = 0.5*rv(i, k, j_start)*fqyb(i, k, jp1) rvb(i, k, j_start) = rvb(i, k, j_start) + 0.5*(field(i, k& & , j_start)+field(i, k, j_start-1))*fqyb(i, k, jp1) fieldb(i, k, j_start) = fieldb(i, k, j_start) + temp27b1 fieldb(i, k, j_start-1) = fieldb(i, k, j_start-1) + & & temp27b1 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 temp27b2 = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + temp27b2 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp27b2 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from24) CALL POPINTEGER4(ad_to24) DO i=ad_to24,ad_from24,-1 temp27 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i& & , k, j)-field(i, k, j-1)) temp30 = SIGN(1., rv(i, k, j)) temp29 = temp30/12.0 temp28 = SIGN(1, time_step) temp27b3 = rv(i, k, j)*fqyb(i, k, jp1) temp27b4 = temp27b3/12.0 temp27b5 = temp28*temp29*temp27b3 rvb(i, k, j) = rvb(i, k, j) + ((7.*(field(i, k, j)+field(i& & , k, j-1))-field(i, k, j+1)-field(i, k, j-2))/12.0+& & temp28*(temp29*temp27))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp27b4 - 3.*& & temp27b5 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp27b5 + 7.*& & temp27b4 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp27b5 - & & temp27b4 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp27b5 - & & temp27b4 fqyb(i, k, jp1) = 0.0 END DO END DO END IF END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) fqxb = 0.0 CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO j=ad_to21,ad_from21,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO i=ad_to20,ad_from20,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp27b0 = 0.5*ru(i_end+1, k, j)*fqxb(i_end+1, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + 0.5*(field(i_end+1& & , k, j)+field(i_end, k, j))*fqxb(i_end+1, k) fieldb(i_end+1, k, j) = fieldb(i_end+1, k, j) + temp27b0 fieldb(i_end, k, j) = fieldb(i_end, k, j) + temp27b0 fqxb(i_end+1, k) = 0.0 END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp27b = 0.5*ru(i_start, k, j)*fqxb(i_start, k) rub(i_start, k, j) = rub(i_start, k, j) + 0.5*(field(i_start& & , k, j)+field(i_start-1, k, j))*fqxb(i_start, k) fieldb(i_start, k, j) = fieldb(i_start, k, j) + temp27b fieldb(i_start-1, k, j) = fieldb(i_start-1, k, j) + temp27b fqxb(i_start, k) = 0.0 END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 temp23 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i, & & k, j)-field(i-1, k, j)) temp26 = SIGN(1., ru(i, k, j)) temp25 = temp26/12.0 temp24 = SIGN(1, time_step) temp23b5 = ru(i, k, j)*fqxb(i, k) temp23b6 = temp23b5/12.0 temp23b7 = temp24*temp25*temp23b5 rub(i, k, j) = rub(i, k, j) + ((7.*(field(i, k, j)+field(i-1& & , k, j))-field(i+1, k, j)-field(i-2, k, j))/12.0+temp24*(& & temp25*temp23))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp23b6 - 3.*& & temp23b7 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp23b7 + 7.*& & temp23b6 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp23b7 - temp23b6 fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp23b7 - temp23b6 fqxb(i, k) = 0.0 END DO END DO END DO ELSE fqyb = 0.0 CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO j=ad_to19,ad_from19,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO i=ad_to16,ad_from16,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO i=ad_to17,ad_from17,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO i=ad_to18,ad_from18,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 temp23b2 = 0.5*rv(i, k, j_start)*fqyb(i, k, jp1) rvb(i, k, j_start) = rvb(i, k, j_start) + 0.5*(field(i, k& & , j_start)+field(i, k, j_start-1))*fqyb(i, k, jp1) fieldb(i, k, j_start) = fieldb(i, k, j_start) + temp23b2 fieldb(i, k, j_start-1) = fieldb(i, k, j_start-1) + & & temp23b2 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 temp23b3 = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + temp23b3 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b3 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO i=ad_to15,ad_from15,-1 temp23b4 = rv(i, k, j)*fqyb(i, k, jp1)/12.0 rvb(i, k, j) = rvb(i, k, j) + (7.*(field(i, k, j)+field(i& & , k, j-1))-field(i, k, j+1)-field(i, k, j-2))*fqyb(i, k& & , jp1)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp23b4 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 7.*temp23b4 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp23b4 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp23b4 fqyb(i, k, jp1) = 0.0 END DO END DO END IF END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) fqxb = 0.0 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO j=ad_to12,ad_from12,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO i=ad_to11,ad_from11,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp23b1 = 0.5*ru(i_end+1, k, j)*fqxb(i_end+1, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + 0.5*(field(i_end+1& & , k, j)+field(i_end, k, j))*fqxb(i_end+1, k) fieldb(i_end+1, k, j) = fieldb(i_end+1, k, j) + temp23b1 fieldb(i_end, k, j) = fieldb(i_end, k, j) + temp23b1 fqxb(i_end+1, k) = 0.0 END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp23b0 = 0.5*ru(i_start, k, j)*fqxb(i_start, k) rub(i_start, k, j) = rub(i_start, k, j) + 0.5*(field(i_start& & , k, j)+field(i_start-1, k, j))*fqxb(i_start, k) fieldb(i_start, k, j) = fieldb(i_start, k, j) + temp23b0 fieldb(i_start-1, k, j) = fieldb(i_start-1, k, j) + temp23b0 fqxb(i_start, k) = 0.0 END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 temp23b = ru(i, k, j)*fqxb(i, k)/12.0 rub(i, k, j) = rub(i, k, j) + (7.*(field(i, k, j)+field(i-1& & , k, j))-field(i+1, k, j)-field(i-2, k, j))*fqxb(i, k)/& & 12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp23b fieldb(i-1, k, j) = fieldb(i-1, k, j) + 7.*temp23b fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp23b fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp23b fqxb(i, k) = 0.0 END DO END DO END DO END IF ELSE IF (branch .EQ. 6) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO j=ad_to10,ad_from10,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to8) DO i=ad_to8,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = ru(i, k, j) temp19 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp22 = SIGN(1., vel) temp21 = temp22/12.0 temp20 = SIGN(1, time_step) temp19b0 = vel*fqxb(i, k) temp19b1 = temp19b0/12.0 temp19b2 = temp20*temp21*temp19b0 velb = ((7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k& & , j)-field(i-2, k, j))/12.0+temp20*(temp21*temp19))*fqxb& & (i, k) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp19b1 - 3.*& & temp19b2 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp19b2 + 7.*& & temp19b1 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp19b2 - & & temp19b1 fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp19b2 - & & temp19b1 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp19b = 0.5*ru(i, k, j)*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + temp19b fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp19b fqxb(i, k) = 0.0 END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from8) DO i=i_start_f-1,ad_from8,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = ru(i, k, j) temp15 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp18 = SIGN(1., vel) temp17 = temp18/12.0 temp16 = SIGN(1, time_step) temp15b0 = vel*fqxb(i, k) temp15b1 = temp15b0/12.0 temp15b2 = temp16*temp17*temp15b0 velb = ((7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k& & , j)-field(i-2, k, j))/12.0+temp16*(temp17*temp15))*fqxb& & (i, k) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp15b1 - 3.*& & temp15b2 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp15b2 + 7.*& & temp15b1 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp15b2 - & & temp15b1 fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp15b2 - & & temp15b1 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp15b = 0.5*ru(i, k, j)*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + temp15b fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp15b fqxb(i, k) = 0.0 END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = ru(i, k, j) temp11 = field(i+2, k, j) - field(i-3, k, j) + 10.*(field(i, k& & , j)-field(i-1, k, j)) - 5.*(field(i+1, k, j)-field(i-2, k, & & j)) temp14 = SIGN(1., vel) temp13 = temp14/60.0 temp12 = SIGN(1, time_step) temp11b = vel*fqxb(i, k) temp11b0 = temp11b/60.0 temp11b1 = -(temp12*temp13*temp11b) velb = ((37.*(field(i, k, j)+field(i-1, k, j))-8.*(field(i+1, & & k, j)+field(i-2, k, j))+field(i+2, k, j)+field(i-3, k, j))/& & 60.0-temp12*(temp13*temp11))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp11b1 + 37.*& & temp11b0 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 37.*temp11b0 - 10.*& & temp11b1 fieldb(i+1, k, j) = fieldb(i+1, k, j) - 5.*temp11b1 - 8.*& & temp11b0 fieldb(i-2, k, j) = fieldb(i-2, k, j) + 5.*temp11b1 - 8.*& & temp11b0 fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp11b1 + temp11b0 fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp11b0 - temp11b1 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO j=ad_to7,ad_from7,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 vel = rv(i, k, j) temp = field(i, k, j+2) - field(i, k, j-3) + 10.*(field(i& & , k, j)-field(i, k, j-1)) - 5.*(field(i, k, j+1)-field(i& & , k, j-2)) temp2 = SIGN(1., vel) temp1 = temp2/60.0 temp0 = SIGN(1, time_step) tempb = vel*fqyb(i, k, jp1) tempb0 = tempb/60.0 tempb1 = -(temp0*temp1*tempb) velb = ((37.*(field(i, k, j)+field(i, k, j-1))-8.*(field(i& & , k, j+1)+field(i, k, j-2))+field(i, k, j+2)+field(i, k& & , j-3))/60.0-temp0*(temp1*temp))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + 10.*tempb1 + 37.*& & tempb0 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 37.*tempb0 - 10.*& & tempb1 fieldb(i, k, j+1) = fieldb(i, k, j+1) - 5.*tempb1 - 8.*& & tempb0 fieldb(i, k, j-2) = fieldb(i, k, j-2) + 5.*tempb1 - 8.*& & tempb0 fieldb(i, k, j+2) = fieldb(i, k, j+2) + tempb1 + tempb0 fieldb(i, k, j-3) = fieldb(i, k, j-3) + tempb0 - tempb1 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 temp3b = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + temp3b fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp3b fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 vel = rv(i, k, j) temp3 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i& & , k, j)-field(i, k, j-1)) temp6 = SIGN(1., vel) temp5 = temp6/12.0 temp4 = SIGN(1, time_step) temp3b0 = vel*fqyb(i, k, jp1) temp3b1 = temp3b0/12.0 temp3b2 = temp4*temp5*temp3b0 velb = ((7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, & & j+1)-field(i, k, j-2))/12.0+temp4*(temp5*temp3))*fqyb(i& & , k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp3b1 - 3.*& & temp3b2 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp3b2 + 7.*& & temp3b1 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp3b2 - temp3b1 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp3b2 - temp3b1 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp7b = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k& & , j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + temp7b fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp7b fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = rv(i, k, j) temp7 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k& & , j)-field(i, k, j-1)) temp10 = SIGN(1., vel) temp9 = temp10/12.0 temp8 = SIGN(1, time_step) temp7b0 = vel*fqyb(i, k, jp1) temp7b1 = temp7b0/12.0 temp7b2 = temp8*temp9*temp7b0 velb = ((7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, j+& & 1)-field(i, k, j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, & & jp1) fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp7b1 - 3.*temp7b2 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp7b2 + 7.*& & temp7b1 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp7b2 - temp7b1 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp7b2 - temp7b1 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO END IF END DO ELSE fqxb = 0.0 CALL POPINTEGER4(ad_from46) CALL POPINTEGER4(ad_to46) DO j=ad_to46,ad_from46,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from45) CALL POPINTEGER4(ad_to45) DO i=ad_to45,ad_from45,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to44) DO i=ad_to44,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = ru(i, k, j) temp31b18 = vel*fqxb(i, k)/12.0 velb = (7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k& & , j)-field(i-2, k, j))*fqxb(i, k)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b18 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 7.*temp31b18 fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b18 fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b18 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp31b17 = 0.5*ru(i, k, j)*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + temp31b17 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b17 fqxb(i, k) = 0.0 END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from44) DO i=i_start_f-1,ad_from44,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = ru(i, k, j) temp31b16 = vel*fqxb(i, k)/12.0 velb = (7.*(field(i, k, j)+field(i-1, k, j))-field(i+1, k& & , j)-field(i-2, k, j))*fqxb(i, k)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b16 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 7.*temp31b16 fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b16 fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b16 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp31b15 = 0.5*ru(i, k, j)*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + temp31b15 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b15 fqxb(i, k) = 0.0 END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 vel = ru(i, k, j) temp31b14 = vel*fqxb(i, k)/60.0 velb = (37.*(field(i, k, j)+field(i-1, k, j))-8.*(field(i+1, k& & , j)+field(i-2, k, j))+field(i+2, k, j)+field(i-3, k, j))*& & fqxb(i, k)/60.0 fieldb(i, k, j) = fieldb(i, k, j) + 37.*temp31b14 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 37.*temp31b14 fieldb(i+1, k, j) = fieldb(i+1, k, j) - 8.*temp31b14 fieldb(i-2, k, j) = fieldb(i-2, k, j) - 8.*temp31b14 fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp31b14 fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp31b14 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from43) CALL POPINTEGER4(ad_to43) DO j=ad_to43,ad_from43,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from40) CALL POPINTEGER4(ad_to40) DO i=ad_to40,ad_from40,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from41) CALL POPINTEGER4(ad_to41) DO i=ad_to41,ad_from41,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from42) CALL POPINTEGER4(ad_to42) DO i=ad_to42,ad_from42,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from35) CALL POPINTEGER4(ad_to35) DO i=ad_to35,ad_from35,-1 vel = rv(i, k, j) temp31b9 = vel*fqyb(i, k, jp1)/60.0 velb = (37.*(field(i, k, j)+field(i, k, j-1))-8.*(field(i& & , k, j+1)+field(i, k, j-2))+field(i, k, j+2)+field(i, k& & , j-3))*fqyb(i, k, jp1)/60.0 fieldb(i, k, j) = fieldb(i, k, j) + 37.*temp31b9 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 37.*temp31b9 fieldb(i, k, j+1) = fieldb(i, k, j+1) - 8.*temp31b9 fieldb(i, k, j-2) = fieldb(i, k, j-2) - 8.*temp31b9 fieldb(i, k, j+2) = fieldb(i, k, j+2) + temp31b9 fieldb(i, k, j-3) = fieldb(i, k, j-3) + temp31b9 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from36) CALL POPINTEGER4(ad_to36) DO i=ad_to36,ad_from36,-1 temp31b10 = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + temp31b10 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b10 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from37) CALL POPINTEGER4(ad_to37) DO i=ad_to37,ad_from37,-1 vel = rv(i, k, j) temp31b11 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, j& & +1)-field(i, k, j-2))*fqyb(i, k, jp1)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b11 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 7.*temp31b11 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b11 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b11 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from38) CALL POPINTEGER4(ad_to38) DO i=ad_to38,ad_from38,-1 temp31b12 = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k& & , j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + temp31b12 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b12 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from39) CALL POPINTEGER4(ad_to39) DO i=ad_to39,ad_from39,-1 vel = rv(i, k, j) temp31b13 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(field(i, k, j)+field(i, k, j-1))-field(i, k, j+1& & )-field(i, k, j-2))*fqyb(i, k, jp1)/12.0 fieldb(i, k, j) = fieldb(i, k, j) + 7.*temp31b13 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 7.*temp31b13 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b13 fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b13 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO END IF END DO END IF 100 CONTINUE END SUBROUTINE A_ADVECT_SCALAR ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35 ! ! Differentiation of advect_w in reverse (adjoint) mode: ! gradient of useful results: rom tendency w ru rv w_old ! with respect to varying inputs: rom tendency w ru rv w_old ! RW status of diff variables: rom:incr tendency:in-out w:incr ! ru:incr rv:incr w_old:incr SUBROUTINE A_ADVECT_W(w, wb, w_old, w_oldb, tendency, tendencyb, ru, rub& & , rv, rvb, rom, romb, mut, time_step, config_flags, msfux, msfuy, & & msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide, jds, & & jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, & & kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru& & , rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: wb, w_oldb, rub, rvb, & & romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw REAL :: ubb, vbb, uwb, vwb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb INTEGER :: horz_order, vert_order REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified EXTERNAL WRF_ERROR_FATAL INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: branch INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 INTEGER :: ad_from24 INTEGER :: ad_to24 INTEGER :: ad_from25 INTEGER :: ad_to25 INTEGER :: ad_from26 INTEGER :: ad_to26 INTEGER :: ad_from27 INTEGER :: ad_to27 INTEGER :: ad_from28 INTEGER :: ad_to28 INTEGER :: ad_from29 INTEGER :: ad_to29 INTEGER :: ad_from30 INTEGER :: ad_to30 INTEGER :: ad_from31 INTEGER :: ad_to31 INTEGER :: ad_from32 INTEGER :: ad_to32 INTEGER :: ad_from33 INTEGER :: ad_to33 INTEGER :: ad_from34 INTEGER :: ad_to34 INTEGER :: ad_from35 INTEGER :: ad_to35 INTEGER :: ad_from36 INTEGER :: ad_to36 INTEGER :: ad_from37 INTEGER :: ad_to37 INTEGER :: ad_from38 INTEGER :: ad_to38 INTEGER :: ad_from39 INTEGER :: ad_to39 INTEGER :: ad_from40 INTEGER :: ad_to40 INTEGER :: ad_from41 INTEGER :: ad_to41 INTEGER :: ad_from42 INTEGER :: ad_to42 INTEGER :: ad_from43 INTEGER :: ad_to43 INTEGER :: ad_from44 INTEGER :: ad_to44 INTEGER :: ad_from45 INTEGER :: ad_to45 INTEGER :: ad_from46 INTEGER :: ad_to46 INTEGER :: ad_from47 INTEGER :: ad_to47 INTEGER :: ad_from48 INTEGER :: ad_to48 INTEGER :: ad_from49 INTEGER :: ad_to49 INTEGER :: ad_from50 INTEGER :: ad_to50 INTEGER :: ad_from51 INTEGER :: ad_to51 INTEGER :: ad_from52 INTEGER :: ad_to52 INTEGER :: ad_from53 INTEGER :: ad_to53 INTEGER :: ad_from54 INTEGER :: ad_to54 INTEGER :: ad_from55 INTEGER :: ad_to55 INTEGER :: ad_from56 INTEGER :: ad_to56 INTEGER :: ad_from57 INTEGER :: ad_to57 INTEGER :: ad_from58 INTEGER :: ad_to58 INTEGER :: ad_from59 INTEGER :: ad_to59 INTEGER :: ad_from60 INTEGER :: ad_to60 INTEGER :: ad_from61 INTEGER :: ad_to61 INTEGER :: ad_from62 INTEGER :: ad_to62 INTEGER :: ad_from63 INTEGER :: ad_to63 INTEGER :: ad_from64 INTEGER :: ad_to64 INTEGER :: ad_from65 INTEGER :: ad_to65 INTEGER :: ad_from66 INTEGER :: ad_to66 INTEGER :: ad_from67 INTEGER :: ad_to67 INTEGER :: ad_from68 INTEGER :: ad_to68 INTEGER :: ad_from69 INTEGER :: ad_to69 INTEGER :: ad_from70 INTEGER :: ad_to70 INTEGER :: ad_from71 INTEGER :: ad_to71 INTEGER :: ad_from72 INTEGER :: ad_to72 INTEGER :: ad_from73 INTEGER :: ad_to73 INTEGER :: ad_from74 INTEGER :: ad_to74 REAL :: temp3 REAL :: temp29 REAL :: temp63b93 REAL :: temp79b3 REAL :: temp2 INTEGER :: temp28 REAL :: temp63b92 REAL :: temp79b2 REAL :: temp1 REAL :: temp27 REAL :: temp63b91 REAL :: temp79b1 INTEGER :: temp0 REAL :: temp26 REAL :: temp63b90 REAL :: temp63b104 REAL :: temp79b0 REAL :: temp7b REAL :: temp25 REAL :: temp63b103 INTEGER :: temp24 REAL :: temp63b102 REAL :: temp23 REAL :: temp63b101 REAL :: temp22 REAL :: temp59 REAL :: temp63b100 REAL :: temp21 REAL :: temp58 INTEGER :: temp20 REAL :: temp57 REAL :: temp35b1 INTEGER :: temp56 REAL :: temp35b0 REAL :: temp55 REAL :: temp63b29 REAL :: temp54 REAL :: temp63b28 REAL :: temp53 REAL :: temp63b27 REAL :: temp67b3 INTEGER :: temp52 REAL :: temp63b26 REAL :: temp67b2 REAL :: temp51 REAL :: temp63b25 REAL :: temp67b1 REAL :: temp50 REAL :: temp63b24 REAL :: temp67b0 REAL :: temp19b REAL :: temp63b23 REAL :: temp27b REAL :: temp63b22 REAL :: temp63b59 REAL :: temp35b REAL :: temp63b21 REAL :: temp63b58 REAL :: tempb1 REAL :: temp43b REAL :: temp47b19 REAL :: temp55b9 REAL :: temp63b20 REAL :: temp63b57 REAL :: tempb0 REAL :: temp47b18 REAL :: temp51b REAL :: temp55b8 REAL :: temp63b56 REAL :: temp47b17 REAL :: temp55b7 REAL :: temp63b55 INTRINSIC MAX REAL :: temp23b1 REAL :: temp47b16 REAL :: temp55b6 REAL :: temp63b54 REAL :: temp23b0 REAL :: temp47b15 REAL :: temp55b5 REAL :: temp63b53 REAL :: temp7b5 REAL :: temp47b14 REAL :: temp55b4 REAL :: temp63b52 REAL :: temp63b89 INTRINSIC SIGN REAL :: temp7b4 REAL :: temp47b13 REAL :: temp55b3 REAL :: temp63b51 REAL :: temp63b88 REAL :: temp7b3 REAL :: temp47b12 REAL :: temp55b2 REAL :: temp63b50 REAL :: temp63b87 REAL :: temp3b REAL :: temp7b2 REAL :: temp47b11 REAL :: temp55b1 REAL :: temp63b86 REAL :: temp7b1 REAL :: temp47b10 REAL :: temp55b0 REAL :: temp63b85 REAL :: temp7b0 REAL :: temp63b84 REAL :: temp19 REAL :: temp63b83 REAL :: temp18 REAL :: temp63b82 REAL :: temp17 REAL :: temp63b81 INTEGER :: temp16 REAL :: temp63b80 REAL :: temp15 REAL :: temp14 REAL :: temp11b1 REAL :: temp13 REAL :: temp11b0 INTEGER :: temp12 REAL :: temp49 REAL :: temp11 INTEGER :: temp48 REAL :: temp75b8 REAL :: temp10 REAL :: temp47 REAL :: temp75b7 REAL :: temp15b REAL :: temp46 REAL :: temp43b1 REAL :: temp75b6 REAL :: temp23b REAL :: temp45 REAL :: temp43b0 REAL :: temp63b19 REAL :: temp75b5 REAL :: temp31b INTEGER :: temp44 REAL :: temp63b18 REAL :: temp75b4 REAL :: temp43 REAL :: temp63b17 REAL :: temp75b3 REAL :: temp42 REAL :: temp63b16 REAL :: temp75b2 REAL :: temp41 REAL :: temp63b15 REAL :: temp75b1 REAL :: temp78 INTEGER :: temp40 REAL :: temp63b14 REAL :: temp75b0 REAL :: temp77 REAL :: temp19b1 REAL :: temp63b13 INTEGER :: temp76 REAL :: temp19b0 REAL :: temp63b12 REAL :: temp63b49 REAL :: temp75 REAL :: temp31b5 REAL :: temp63b11 REAL :: temp63b48 REAL :: temp74 REAL :: temp31b4 REAL :: temp63b9 REAL :: temp63b10 REAL :: temp63b47 REAL :: temp73 REAL :: temp79b REAL :: temp31b3 REAL :: temp63b8 REAL :: temp63b46 INTEGER :: temp72 REAL :: tempb REAL :: temp31b2 REAL :: temp63b7 REAL :: temp63b45 REAL :: temp71 REAL :: temp31b1 REAL :: temp63b6 REAL :: temp63b44 REAL :: temp70 REAL :: temp31b0 REAL :: temp63b5 REAL :: temp63b43 REAL :: temp63b4 REAL :: temp63b42 REAL :: temp63b79 REAL :: temp63b3 REAL :: temp63b41 REAL :: temp63b78 REAL :: temp63b2 REAL :: temp63b40 REAL :: temp63b77 REAL :: temp63b1 REAL :: temp63b76 REAL :: temp63b0 REAL :: temp63b75 REAL :: temp63b74 REAL :: temp39b5 REAL :: temp63b73 REAL :: temp39b4 REAL :: temp63b72 REAL :: temp39b3 REAL :: temp63b71 REAL :: temp11b REAL :: temp39b2 REAL :: temp63b70 REAL :: temp39b1 REAL :: temp39b0 REAL :: temp39 REAL :: temp38 REAL :: temp37 INTEGER :: temp36 REAL :: temp51b1 REAL :: temp3b1 REAL :: temp35 REAL :: temp51b0 REAL :: temp59b REAL :: temp3b0 REAL :: temp34 REAL :: temp67b REAL :: temp33 REAL :: temp75b INTEGER :: temp32 REAL :: temp69 REAL :: temp31 INTEGER :: temp68 REAL :: temp30 REAL :: temp67 REAL :: temp27b1 REAL :: temp66 REAL :: temp27b0 REAL :: temp63b39 REAL :: temp65 REAL :: temp63b38 INTEGER :: temp64 REAL :: temp63b37 REAL :: temp63 REAL :: temp55b17 REAL :: temp62 REAL :: temp63b36 REAL :: temp55b16 REAL :: temp61 REAL :: temp59b1 REAL :: temp63b35 INTRINSIC MIN REAL :: temp55b15 INTEGER :: temp60 REAL :: temp59b0 REAL :: temp63b34 REAL :: temp55b14 REAL :: temp63b33 REAL :: temp55b13 REAL :: temp63b32 REAL :: temp63b69 REAL :: temp15b5 REAL :: temp55b12 REAL :: temp63b31 REAL :: temp63b68 REAL :: temp15b4 REAL :: temp47b9 REAL :: temp55b11 REAL :: temp63b30 REAL :: temp63b67 REAL :: temp15b3 REAL :: temp47b8 REAL :: temp55b10 REAL :: temp63b66 REAL :: temp71b1 REAL :: temp REAL :: temp15b2 REAL :: temp47b7 REAL :: temp63b65 REAL :: temp71b0 REAL :: temp15b1 REAL :: temp47b6 REAL :: temp63b64 REAL :: temp15b0 REAL :: temp47b5 REAL :: temp63b63 REAL :: temp9 REAL :: temp47b4 REAL :: temp63b62 REAL :: temp63b99 INTEGER :: temp8 REAL :: temp39b REAL :: temp47b3 REAL :: temp63b61 REAL :: temp63b98 REAL :: temp7 REAL :: temp47b REAL :: temp47b2 REAL :: temp63b60 REAL :: temp63b97 REAL :: temp6 REAL :: temp47b1 REAL :: temp47b21 REAL :: temp55b REAL :: temp63b96 REAL :: temp5 REAL :: temp47b0 REAL :: temp47b20 REAL :: temp63b REAL :: temp63b95 INTEGER :: temp4 REAL :: temp63b94 REAL :: temp71b REAL :: temp79b4 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! here is the choice of flux operators ! begin with horizontal flux divergence IF (horz_order .EQ. 6) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. !--------------- y - advection first i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from63 = j_start j_loop_y_flux_6:DO j=ad_from63,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from50 = i_start DO i=ad_from50,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from50) END DO k = ktf + 1 ad_from51 = i_start DO i=ad_from51,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from51) CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) ! 2nd order flux next to south boundary DO k=kts+1,ktf ad_from52 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from52) END DO k = ktf + 1 ad_from53 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from53) CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN CALL PUSHINTEGER4(k) ! third of 4th order flux 2 in from south boundary DO k=kts+1,ktf ad_from54 = i_start DO i=ad_from54,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from54) END DO k = ktf + 1 ad_from55 = i_start DO i=ad_from55,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from55) CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN CALL PUSHINTEGER4(k) ! 2nd order flux next to north boundary DO k=kts+1,ktf ad_from56 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from56) END DO k = ktf + 1 ad_from57 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from57) CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN CALL PUSHINTEGER4(k) ! 3rd or 4th order flux 2 in from north boundary DO k=kts+1,ktf ad_from58 = i_start DO i=ad_from58,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from58) END DO k = ktf + 1 ad_from59 = i_start DO i=ad_from59,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from59) CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from60 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from60) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from61 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from61) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code CALL PUSHINTEGER4(k) DO k=kts+1,ktf+1 ad_from62 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from62) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_6 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from63) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from66 = j_start ! compute fluxes DO j=ad_from66,j_end CALL PUSHINTEGER4(k) ! 5th or 6th order flux DO k=kts+1,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) END DO END DO k = ktf + 1 DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from64 = i_start DO i=ad_from64,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHINTEGER4(k) ! third order DO k=kts+1,ktf CALL PUSHREAL8(vel) END DO k = ktf + 1 CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from64) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHINTEGER4(k) ! third order flux one in from the boundary DO k=kts+1,ktf CALL PUSHREAL8(vel) END DO k = ktf + 1 CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF CALL PUSHINTEGER4(k) ! x flux-divergence into tendency DO k=kts+1,ktf+1 ad_from65 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from65) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from66) CALL PUSHCONTROL3B(7) ELSE IF (horz_order .EQ. 5) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. !--------------- y - advection first i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from12 = j_start j_loop_y_flux_5:DO j=ad_from12,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from = i_start DO i=ad_from,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO k = ktf + 1 ad_from0 = i_start DO i=ad_from0,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) ! 2nd order flux next to south boundary DO k=kts+1,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO k = ktf + 1 ad_from2 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN CALL PUSHINTEGER4(k) ! third of 4th order flux 2 in from south boundary DO k=kts+1,ktf ad_from3 = i_start DO i=ad_from3,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO k = ktf + 1 ad_from4 = i_start DO i=ad_from4,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN CALL PUSHINTEGER4(k) ! 2nd order flux next to north boundary DO k=kts+1,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO k = ktf + 1 ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN CALL PUSHINTEGER4(k) ! 3rd or 4th order flux 2 in from north boundary DO k=kts+1,ktf ad_from7 = i_start DO i=ad_from7,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from7) END DO k = ktf + 1 ad_from8 = i_start DO i=ad_from8,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from8) CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from9 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from10 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from10) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code CALL PUSHINTEGER4(k) DO k=kts+1,ktf+1 ad_from11 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from11) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from12) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from15 = j_start ! compute fluxes DO j=ad_from15,j_end CALL PUSHINTEGER4(k) ! 5th or 6th order flux DO k=kts+1,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) END DO END DO k = ktf + 1 DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from13 = i_start DO i=ad_from13,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHINTEGER4(k) ! third order DO k=kts+1,ktf CALL PUSHREAL8(vel) END DO k = ktf + 1 CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from13) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHINTEGER4(k) ! third order flux one in from the boundary DO k=kts+1,ktf CALL PUSHREAL8(vel) END DO k = ktf + 1 CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF CALL PUSHINTEGER4(k) ! x flux-divergence into tendency DO k=kts+1,ktf+1 ad_from14 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from15) CALL PUSHCONTROL3B(6) ELSE IF (horz_order .EQ. 4) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 2 i_end_f = ide - 2 END IF ad_from17 = j_start ! compute fluxes DO j=ad_from17,j_end DO k=kts+1,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) END DO END DO k = ktf + 1 DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) END DO ! second order flux close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF CALL PUSHINTEGER4(k) ! x flux-divergence into tendency DO k=kts+1,ktf+1 ad_from16 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from16) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from17) CALL PUSHINTEGER4(i_start) ! next -> y flux divergence calculation i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN j_start = jds + 1 j_start_f = j_start + 1 END IF IF (degrade_ye) THEN j_end = jde - 2 j_end_f = jde - 2 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF jp1 = 2 jp0 = 1 ad_from27 = j_start DO j=ad_from27,j_end+1 IF (j .LT. j_start_f .AND. degrade_ys) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from18 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from18) END DO k = ktf + 1 ad_from19 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from19) CALL PUSHCONTROL2B(0) ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from20 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from20) END DO k = ktf + 1 ad_from21 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from21) CALL PUSHCONTROL2B(1) ELSE CALL PUSHINTEGER4(k) ! 3rd or 4th order flux DO k=kts+1,ktf ad_from22 = i_start DO i=ad_from22,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from22) END DO k = ktf + 1 ad_from23 = i_start DO i=ad_from23,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) CALL PUSHCONTROL2B(2) END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from24 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from24) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from25 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from25) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code CALL PUSHINTEGER4(k) DO k=kts+1,ktf+1 ad_from26 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from26) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from27) CALL PUSHCONTROL3B(5) ELSE IF (horz_order .EQ. 3) THEN degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 3) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN i_start = ids + 1 i_start_f = i_start + 1 END IF IF (degrade_xe) THEN i_end = ide - 2 i_end_f = ide - 2 END IF ad_from29 = j_start ! compute fluxes DO j=ad_from29,j_end DO k=kts+1,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) END DO END DO k = ktf + 1 DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) END DO ! second order flux close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF CALL PUSHINTEGER4(k) ! x flux-divergence into tendency DO k=kts+1,ktf+1 ad_from28 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from28) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from29) CALL PUSHINTEGER4(i_start) ! next -> y flux divergence calculation i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! 3rd or 4th order flux has a 5 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN j_start = jds + 1 j_start_f = j_start + 1 END IF IF (degrade_ye) THEN j_end = jde - 2 j_end_f = jde - 2 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF jp1 = 2 jp0 = 1 ad_from39 = j_start DO j=ad_from39,j_end+1 IF (j .LT. j_start_f .AND. degrade_ys) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from30 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from30) END DO k = ktf + 1 ad_from31 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from31) CALL PUSHCONTROL2B(0) ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from32 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from32) END DO k = ktf + 1 ad_from33 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from33) CALL PUSHCONTROL2B(1) ELSE CALL PUSHINTEGER4(k) ! 3rd or 4th order flux DO k=kts+1,ktf ad_from34 = i_start DO i=ad_from34,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from34) END DO k = ktf + 1 ad_from35 = i_start DO i=ad_from35,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from35) CALL PUSHCONTROL2B(2) END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from36 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from36) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from37 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from37) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code CALL PUSHINTEGER4(k) DO k=kts+1,ktf+1 ad_from38 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from38) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from39) CALL PUSHCONTROL3B(4) ELSE IF (horz_order .EQ. 2) THEN i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF IF (.NOT.config_flags%periodic_x) THEN IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF END IF END IF ad_from42 = j_start DO j=ad_from42,j_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from40 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from40) END DO k = ktf + 1 ad_from41 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from41) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from42) i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 2 .GT. jte) THEN j_end = jte ELSE j_end = jde - 2 END IF END IF ad_from45 = j_start DO j=ad_from45,j_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from43 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from43) END DO k = ktf + 1 ad_from44 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from44) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from45) ! Polar boundary condition ... not covered in above j-loop IF (config_flags%polar) THEN IF (jts .EQ. jds) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from46 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from46) END DO k = ktf + 1 ad_from47 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from47) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (jte .EQ. jde) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from48 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from48) END DO k = ktf + 1 ad_from49 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from49) CALL PUSHCONTROL3B(3) ELSE CALL PUSHCONTROL3B(2) END IF ELSE CALL PUSHCONTROL3B(1) END IF ELSE CALL PUSHCONTROL3B(0) END IF ! pick up the the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF CALL PUSHINTEGER4(j_start) j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from67 = j_start DO j=ad_from67,j_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its& & , k-1, j)+ru(its+1, k-1, j))) IF (uw .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from67) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from68 = j_start DO j=ad_from68,j_end uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-& & 1)*(ru(its, k-2, j)+ru(its+1, k-2, j))) IF (uw .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from68) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from69 = j_start DO j=ad_from69,j_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-& & 1, k-1, j)+ru(ite, k-1, j))) IF (uw .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from69) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from70 = j_start DO j=ad_from70,j_end uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-& & 1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j))) IF (uw .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from70) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from71 = i_start DO i=ad_from71,i_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k& & -1, jts)+rv(i, k-1, jts+1))) IF (vw .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from71) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from72 = i_start DO i=ad_from72,i_end vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-& & 1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1))) IF (vw .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from72) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from73 = i_start DO i=ad_from73,i_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k& & -1, jte-1)+rv(i, k-1, jte))) IF (vw .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from73) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from74 = i_start DO i=ad_from74,i_end vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-& & 1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte))) IF (vw .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from74) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my) ! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my) ! Therefore we don't need to make a correction for advect_w i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN CALL PUSHINTEGER4(j_end) j_end = jde - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(j_end) j_end = jte CALL PUSHCONTROL1B(1) END IF IF (vert_order .EQ. 6) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts+3,ktf-1 DO i=i_start,i_end CALL PUSHREAL8(vel) END DO END DO DO i=i_start,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(k) ! pick up flux contribution for w at the lid. wcs, 13 march 2004 k = ktf + 1 END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf + 1 temp63b96 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp63b97 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp63b96 romb(i, k-1, j) = romb(i, k-1, j) + temp63b96 wb(i, k, j) = wb(i, k, j) + temp63b97 wb(i, k-1, j) = wb(i, k-1, j) + temp63b97 vfluxb(i, k) = 0.0 k = ktf vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp63b98 = vel*vfluxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))*& & vfluxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b98 wb(i, k-1, j) = wb(i, k-1, j) + 7.*temp63b98 wb(i, k+1, j) = wb(i, k+1, j) - temp63b98 wb(i, k-2, j) = wb(i, k-2, j) - temp63b98 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp63b99 = vel*vfluxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))*& & vfluxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b99 wb(i, k-1, j) = wb(i, k-1, j) + 7.*temp63b99 wb(i, k+1, j) = wb(i, k+1, j) - temp63b99 wb(i, k-2, j) = wb(i, k-2, j) - temp63b99 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb k = kts + 1 temp63b100 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp63b101 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp63b100 romb(i, k-1, j) = romb(i, k-1, j) + temp63b100 wb(i, k, j) = wb(i, k, j) + temp63b101 wb(i, k-1, j) = wb(i, k-1, j) + temp63b101 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+3,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp63b95 = vel*vfluxb(i, k)/60.0 velb = (37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1, j)+w(i, k-& & 2, j))+w(i, k+2, j)+w(i, k-3, j))*vfluxb(i, k)/60.0 wb(i, k, j) = wb(i, k, j) + 37.*temp63b95 wb(i, k-1, j) = wb(i, k-1, j) + 37.*temp63b95 wb(i, k+1, j) = wb(i, k+1, j) - 8.*temp63b95 wb(i, k-2, j) = wb(i, k-2, j) - 8.*temp63b95 wb(i, k+2, j) = wb(i, k+2, j) + temp63b95 wb(i, k-3, j) = wb(i, k-3, j) + temp63b95 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb END DO END DO CALL POPINTEGER4(k) END DO ELSE IF (vert_order .EQ. 5) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts+3,ktf-1 DO i=i_start,i_end CALL PUSHREAL8(vel) END DO END DO DO i=i_start,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(k) ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf + 1 END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf + 1 temp75b = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp75b0 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp75b romb(i, k-1, j) = romb(i, k-1, j) + temp75b wb(i, k, j) = wb(i, k, j) + temp75b0 wb(i, k-1, j) = wb(i, k-1, j) + temp75b0 vfluxb(i, k) = 0.0 k = ktf vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp71 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, & & j)) temp74 = SIGN(1., -vel) temp73 = temp74/12.0 temp72 = SIGN(1, time_step) temp71b = vel*vfluxb(i, k) temp71b0 = temp71b/12.0 temp71b1 = temp72*temp73*temp71b velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))& & /12.0+temp72*(temp73*temp71))*vfluxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp71b0 - 3.*temp71b1 wb(i, k-1, j) = wb(i, k-1, j) + 3.*temp71b1 + 7.*temp71b0 wb(i, k+1, j) = wb(i, k+1, j) + temp71b1 - temp71b0 wb(i, k-2, j) = wb(i, k-2, j) - temp71b1 - temp71b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp67 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, & & j)) temp70 = SIGN(1., -vel) temp69 = temp70/12.0 temp68 = SIGN(1, time_step) temp67b = vel*vfluxb(i, k) temp67b0 = temp67b/12.0 temp67b1 = temp68*temp69*temp67b velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))& & /12.0+temp68*(temp69*temp67))*vfluxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp67b0 - 3.*temp67b1 wb(i, k-1, j) = wb(i, k-1, j) + 3.*temp67b1 + 7.*temp67b0 wb(i, k+1, j) = wb(i, k+1, j) + temp67b1 - temp67b0 wb(i, k-2, j) = wb(i, k-2, j) - temp67b1 - temp67b0 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb k = kts + 1 temp67b2 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp67b3 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp67b2 romb(i, k-1, j) = romb(i, k-1, j) + temp67b2 wb(i, k, j) = wb(i, k, j) + temp67b3 wb(i, k-1, j) = wb(i, k-1, j) + temp67b3 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+3,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp63 = w(i, k+2, j) - w(i, k-3, j) + 10.*(w(i, k, j)-w(i, k-& & 1, j)) - 5.*(w(i, k+1, j)-w(i, k-2, j)) temp66 = SIGN(1., -vel) temp65 = temp66/60.0 temp64 = SIGN(1, time_step) temp63b102 = vel*vfluxb(i, k) temp63b103 = temp63b102/60.0 temp63b104 = -(temp64*temp65*temp63b102) velb = ((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1, j)+w(i, k& & -2, j))+w(i, k+2, j)+w(i, k-3, j))/60.0-temp64*(temp65*& & temp63))*vfluxb(i, k) wb(i, k, j) = wb(i, k, j) + 10.*temp63b104 + 37.*temp63b103 wb(i, k-1, j) = wb(i, k-1, j) + 37.*temp63b103 - 10.*& & temp63b104 wb(i, k+1, j) = wb(i, k+1, j) - 5.*temp63b104 - 8.*temp63b103 wb(i, k-2, j) = wb(i, k-2, j) + 5.*temp63b104 - 8.*temp63b103 wb(i, k+2, j) = wb(i, k+2, j) + temp63b104 + temp63b103 wb(i, k-3, j) = wb(i, k-3, j) + temp63b103 - temp63b104 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb END DO END DO CALL POPINTEGER4(k) END DO ELSE IF (vert_order .EQ. 4) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts+2,ktf DO i=i_start,i_end CALL PUSHREAL8(vel) END DO END DO CALL PUSHINTEGER4(k) ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf + 1 END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf + 1 temp75b2 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp75b3 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp75b2 romb(i, k-1, j) = romb(i, k-1, j) + temp75b2 wb(i, k, j) = wb(i, k, j) + temp75b3 wb(i, k-1, j) = wb(i, k-1, j) + temp75b3 vfluxb(i, k) = 0.0 k = kts + 1 temp75b4 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp75b5 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp75b4 romb(i, k-1, j) = romb(i, k-1, j) + temp75b4 wb(i, k, j) = wb(i, k, j) + temp75b5 wb(i, k-1, j) = wb(i, k-1, j) + temp75b5 vfluxb(i, k) = 0.0 END DO DO k=ktf,kts+2,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp75b1 = vel*vfluxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j)& & )*vfluxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp75b1 wb(i, k-1, j) = wb(i, k-1, j) + 7.*temp75b1 wb(i, k+1, j) = wb(i, k+1, j) - temp75b1 wb(i, k-2, j) = wb(i, k-2, j) - temp75b1 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb END DO END DO CALL POPINTEGER4(k) END DO ELSE IF (vert_order .EQ. 3) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts+2,ktf DO i=i_start,i_end CALL PUSHREAL8(vel) END DO END DO CALL PUSHINTEGER4(k) ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf + 1 END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf + 1 temp79b = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp79b0 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp79b romb(i, k-1, j) = romb(i, k-1, j) + temp79b wb(i, k, j) = wb(i, k, j) + temp79b0 wb(i, k-1, j) = wb(i, k-1, j) + temp79b0 vfluxb(i, k) = 0.0 k = kts + 1 temp79b1 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp79b2 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp79b1 romb(i, k-1, j) = romb(i, k-1, j) + temp79b1 wb(i, k, j) = wb(i, k, j) + temp79b2 wb(i, k-1, j) = wb(i, k-1, j) + temp79b2 vfluxb(i, k) = 0.0 END DO DO k=ktf,kts+2,-1 DO i=i_end,i_start,-1 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp75 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1& & , j)) temp78 = SIGN(1., -vel) temp77 = temp78/12.0 temp76 = SIGN(1, time_step) temp75b6 = vel*vfluxb(i, k) temp75b7 = temp75b6/12.0 temp75b8 = temp76*temp77*temp75b6 velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j& & ))/12.0+temp76*(temp77*temp75))*vfluxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp75b7 - 3.*temp75b8 wb(i, k-1, j) = wb(i, k-1, j) + 3.*temp75b8 + 7.*temp75b7 wb(i, k+1, j) = wb(i, k+1, j) + temp75b8 - temp75b7 wb(i, k-2, j) = wb(i, k-2, j) - temp75b8 - temp75b7 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb END DO END DO CALL POPINTEGER4(k) END DO ELSE IF (vert_order .EQ. 2) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf + 1 END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j) END DO END DO DO k=ktf+1,kts+1,-1 DO i=i_end,i_start,-1 temp79b3 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp79b4 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp79b3 romb(i, k-1, j) = romb(i, k-1, j) + temp79b3 wb(i, k, j) = wb(i, k, j) + temp79b4 wb(i, k-1, j) = wb(i, k-1, j) + temp79b4 vfluxb(i, k) = 0.0 END DO END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(j_end) ELSE CALL POPINTEGER4(j_end) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from74) CALL POPINTEGER4(ad_to74) DO i=ad_to74,ad_from74,-1 temp63b91 = -(rdy*tendencyb(i, k, j_end)) temp63b92 = w(i, k, j_end)*temp63b91 temp63b93 = (2.-fzm(k-1))*temp63b92 temp63b94 = -(fzp(k-1)*temp63b92) vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp63b91 w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp63b91 w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp63b91 wb(i, k, j_end) = wb(i, k, j_end) + ((2.-fzm(k-1))*(rv(i, k-1, jte& & )-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, jte-1)& & ))*temp63b91 rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp63b93 rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - temp63b93 rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp63b94 rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) - temp63b94 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp63b89 = 0.5*(2.-fzm(k-1))*vwb temp63b90 = -(0.5*fzp(k-1)*vwb) rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + temp63b89 rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp63b89 rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) + temp63b90 rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp63b90 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from73) CALL POPINTEGER4(ad_to73) DO i=ad_to73,ad_from73,-1 DO k=ktf,kts+1,-1 temp63b87 = -(rdy*tendencyb(i, k, j_end)) temp63b88 = w(i, k, j_end)*temp63b87 vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp63b87 w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp63b87 w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp63b87 wb(i, k, j_end) = wb(i, k, j_end) + (fzm(k)*(rv(i, k, jte)-rv(i& & , k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte-1)))*& & temp63b87 rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp63b88 rvb(i, k, jte-1) = rvb(i, k, jte-1) - fzm(k)*temp63b88 rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp63b88 rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - fzp(k)*temp63b88 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp63b86 = 0.5*vwb rvb(i, k, jte-1) = rvb(i, k, jte-1) + fzm(k)*temp63b86 rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp63b86 rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + fzp(k)*temp63b86 rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp63b86 END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from72) CALL POPINTEGER4(ad_to72) DO i=ad_to72,ad_from72,-1 temp63b82 = -(rdy*tendencyb(i, k, jts)) temp63b83 = w(i, k, jts)*temp63b82 temp63b84 = (2.-fzm(k-1))*temp63b83 temp63b85 = -(fzp(k-1)*temp63b83) vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp63b82 w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp63b82 w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp63b82 wb(i, k, jts) = wb(i, k, jts) + ((2.-fzm(k-1))*(rv(i, k-1, jts+1)-& & rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))*& & temp63b82 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp63b84 rvb(i, k-1, jts) = rvb(i, k-1, jts) - temp63b84 rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp63b85 rvb(i, k-2, jts) = rvb(i, k-2, jts) - temp63b85 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp63b80 = 0.5*(2.-fzm(k-1))*vwb temp63b81 = -(0.5*fzp(k-1)*vwb) rvb(i, k-1, jts) = rvb(i, k-1, jts) + temp63b80 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp63b80 rvb(i, k-2, jts) = rvb(i, k-2, jts) + temp63b81 rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp63b81 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from71) CALL POPINTEGER4(ad_to71) DO i=ad_to71,ad_from71,-1 DO k=ktf,kts+1,-1 temp63b78 = -(rdy*tendencyb(i, k, jts)) temp63b79 = w(i, k, jts)*temp63b78 vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp63b78 w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp63b78 w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp63b78 wb(i, k, jts) = wb(i, k, jts) + (fzm(k)*(rv(i, k, jts+1)-rv(i, k& & , jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))*temp63b78 rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp63b79 rvb(i, k, jts) = rvb(i, k, jts) - fzm(k)*temp63b79 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp63b79 rvb(i, k-1, jts) = rvb(i, k-1, jts) - fzp(k)*temp63b79 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp63b77 = 0.5*vwb rvb(i, k, jts) = rvb(i, k, jts) + fzm(k)*temp63b77 rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp63b77 rvb(i, k-1, jts) = rvb(i, k-1, jts) + fzp(k)*temp63b77 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp63b77 END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from70) CALL POPINTEGER4(ad_to70) DO j=ad_to70,ad_from70,-1 temp63b73 = -(rdx*tendencyb(i_end, k, j)) temp63b74 = w(i_end, k, j)*temp63b73 temp63b75 = (2.-fzm(k-1))*temp63b74 temp63b76 = -(fzp(k-1)*temp63b74) ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp63b73 w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp63b73 w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp63b73 wb(i_end, k, j) = wb(i_end, k, j) + ((2.-fzm(k-1))*(ru(ite, k-1, j& & )-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-2, j)& & ))*temp63b73 rub(ite, k-1, j) = rub(ite, k-1, j) + temp63b75 rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - temp63b75 rub(ite, k-2, j) = rub(ite, k-2, j) + temp63b76 rub(ite-1, k-2, j) = rub(ite-1, k-2, j) - temp63b76 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp63b71 = 0.5*(2.-fzm(k-1))*uwb temp63b72 = -(0.5*fzp(k-1)*uwb) rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + temp63b71 rub(ite, k-1, j) = rub(ite, k-1, j) + temp63b71 rub(ite-1, k-2, j) = rub(ite-1, k-2, j) + temp63b72 rub(ite, k-2, j) = rub(ite, k-2, j) + temp63b72 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from69) CALL POPINTEGER4(ad_to69) DO j=ad_to69,ad_from69,-1 DO k=ktf,kts+1,-1 temp63b69 = -(rdx*tendencyb(i_end, k, j)) temp63b70 = w(i_end, k, j)*temp63b69 ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp63b69 w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp63b69 w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp63b69 wb(i_end, k, j) = wb(i_end, k, j) + (fzm(k)*(ru(ite, k, j)-ru(& & ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j)))*& & temp63b69 rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp63b70 rub(ite-1, k, j) = rub(ite-1, k, j) - fzm(k)*temp63b70 rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp63b70 rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - fzp(k)*temp63b70 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp63b68 = 0.5*uwb rub(ite-1, k, j) = rub(ite-1, k, j) + fzm(k)*temp63b68 rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp63b68 rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + fzp(k)*temp63b68 rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp63b68 END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from68) CALL POPINTEGER4(ad_to68) DO j=ad_to68,ad_from68,-1 temp63b64 = -(rdx*tendencyb(its, k, j)) temp63b65 = w(its, k, j)*temp63b64 temp63b66 = (2.-fzm(k-1))*temp63b65 temp63b67 = -(fzp(k-1)*temp63b65) ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp63b64 w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp63b64 w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp63b64 wb(its, k, j) = wb(its, k, j) + ((2.-fzm(k-1))*(ru(its+1, k-1, j)-& & ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))*& & temp63b64 rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp63b66 rub(its, k-1, j) = rub(its, k-1, j) - temp63b66 rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp63b67 rub(its, k-2, j) = rub(its, k-2, j) - temp63b67 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp63b62 = 0.5*(2.-fzm(k-1))*uwb temp63b63 = -(0.5*fzp(k-1)*uwb) rub(its, k-1, j) = rub(its, k-1, j) + temp63b62 rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp63b62 rub(its, k-2, j) = rub(its, k-2, j) + temp63b63 rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp63b63 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from67) CALL POPINTEGER4(ad_to67) DO j=ad_to67,ad_from67,-1 DO k=ktf,kts+1,-1 temp63b60 = -(rdx*tendencyb(its, k, j)) temp63b61 = w(its, k, j)*temp63b60 ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp63b60 w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp63b60 w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp63b60 wb(its, k, j) = wb(its, k, j) + (fzm(k)*(ru(its+1, k, j)-ru(its& & , k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))*temp63b60 rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp63b61 rub(its, k, j) = rub(its, k, j) - fzm(k)*temp63b61 rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp63b61 rub(its, k-1, j) = rub(its, k-1, j) - fzp(k)*temp63b61 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp63b59 = 0.5*uwb rub(its, k, j) = rub(its, k, j) + fzm(k)*temp63b59 rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp63b59 rub(its, k-1, j) = rub(its, k-1, j) + fzp(k)*temp63b59 rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp63b59 END DO CALL POPINTEGER4(k) END DO END IF CALL POPINTEGER4(j_start) CALL POPCONTROL3B(branch) IF (branch .LT. 4) THEN IF (branch .LT. 2) THEN IF (branch .EQ. 0) GOTO 100 ELSE IF (branch .NE. 2) THEN CALL POPINTEGER4(ad_from49) CALL POPINTEGER4(ad_to49) DO i=ad_to49,ad_from49,-1 mrdy = msftx(i, jde-1)*rdy temp63b28 = mrdy*0.5*tendencyb(i, k, jde-1) temp63b29 = (w(i, k, jde-1)+w(i, k, jde-2))*temp63b28 temp63b30 = ((2.-fzm(k-1))*rv(i, k-1, jde-1)-fzp(k-1)*rv(i, k-& & 2, jde-1))*temp63b28 rvb(i, k-1, jde-1) = rvb(i, k-1, jde-1) + (2.-fzm(k-1))*& & temp63b29 rvb(i, k-2, jde-1) = rvb(i, k-2, jde-1) - fzp(k-1)*temp63b29 wb(i, k, jde-1) = wb(i, k, jde-1) + temp63b30 wb(i, k, jde-2) = wb(i, k, jde-2) + temp63b30 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from48) CALL POPINTEGER4(ad_to48) DO i=ad_to48,ad_from48,-1 mrdy = msftx(i, jde-1)*rdy temp63b25 = mrdy*0.5*tendencyb(i, k, jde-1) temp63b26 = (w(i, k, jde-1)+w(i, k, jde-2))*temp63b25 temp63b27 = (fzm(k)*rv(i, k, jde-1)+fzp(k)*rv(i, k-1, jde-1)& & )*temp63b25 rvb(i, k, jde-1) = rvb(i, k, jde-1) + fzm(k)*temp63b26 rvb(i, k-1, jde-1) = rvb(i, k-1, jde-1) + fzp(k)*temp63b26 wb(i, k, jde-1) = wb(i, k, jde-1) + temp63b27 wb(i, k, jde-2) = wb(i, k, jde-2) + temp63b27 END DO END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from47) CALL POPINTEGER4(ad_to47) DO i=ad_to47,ad_from47,-1 mrdy = msftx(i, jds)*rdy temp63b22 = -(mrdy*0.5*tendencyb(i, k, jds)) temp63b23 = (w(i, k, jds+1)+w(i, k, jds))*temp63b22 temp63b24 = ((2.-fzm(k-1))*rv(i, k-1, jds+1)-fzp(k-1)*rv(i, k-& & 2, jds+1))*temp63b22 rvb(i, k-1, jds+1) = rvb(i, k-1, jds+1) + (2.-fzm(k-1))*& & temp63b23 rvb(i, k-2, jds+1) = rvb(i, k-2, jds+1) - fzp(k-1)*temp63b23 wb(i, k, jds+1) = wb(i, k, jds+1) + temp63b24 wb(i, k, jds) = wb(i, k, jds) + temp63b24 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from46) CALL POPINTEGER4(ad_to46) DO i=ad_to46,ad_from46,-1 mrdy = msftx(i, jds)*rdy temp63b19 = -(mrdy*0.5*tendencyb(i, k, jds)) temp63b20 = (w(i, k, jds+1)+w(i, k, jds))*temp63b19 temp63b21 = (fzm(k)*rv(i, k, jds+1)+fzp(k)*rv(i, k-1, jds+1)& & )*temp63b19 rvb(i, k, jds+1) = rvb(i, k, jds+1) + fzm(k)*temp63b20 rvb(i, k-1, jds+1) = rvb(i, k-1, jds+1) + fzp(k)*temp63b20 wb(i, k, jds+1) = wb(i, k, jds+1) + temp63b21 wb(i, k, jds) = wb(i, k, jds) + temp63b21 END DO END DO CALL POPINTEGER4(k) END IF END IF CALL POPINTEGER4(ad_from45) CALL POPINTEGER4(ad_to45) DO j=ad_to45,ad_from45,-1 CALL POPINTEGER4(ad_from44) CALL POPINTEGER4(ad_to44) DO i=ad_to44,ad_from44,-1 mrdy = msftx(i, j)*rdy temp63b14 = -(mrdy*0.5*tendencyb(i, k, j)) temp63b15 = (w(i, k, j+1)+w(i, k, j))*temp63b14 temp63b16 = ((2.-fzm(k-1))*rv(i, k-1, j+1)-fzp(k-1)*rv(i, k-2, j& & +1))*temp63b14 temp63b17 = -((w(i, k, j)+w(i, k, j-1))*temp63b14) temp63b18 = -(((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, j& & ))*temp63b14) rvb(i, k-1, j+1) = rvb(i, k-1, j+1) + (2.-fzm(k-1))*temp63b15 rvb(i, k-2, j+1) = rvb(i, k-2, j+1) - fzp(k-1)*temp63b15 wb(i, k, j+1) = wb(i, k, j+1) + temp63b16 wb(i, k, j) = wb(i, k, j) + temp63b18 + temp63b16 rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp63b17 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp63b17 wb(i, k, j-1) = wb(i, k, j-1) + temp63b18 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from43) CALL POPINTEGER4(ad_to43) DO i=ad_to43,ad_from43,-1 mrdy = msftx(i, j)*rdy temp63b9 = -(mrdy*0.5*tendencyb(i, k, j)) temp63b10 = (w(i, k, j+1)+w(i, k, j))*temp63b9 temp63b11 = (fzm(k)*rv(i, k, j+1)+fzp(k)*rv(i, k-1, j+1))*& & temp63b9 temp63b12 = -((w(i, k, j)+w(i, k, j-1))*temp63b9) temp63b13 = -((fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & temp63b9) rvb(i, k, j+1) = rvb(i, k, j+1) + fzm(k)*temp63b10 rvb(i, k-1, j+1) = rvb(i, k-1, j+1) + fzp(k)*temp63b10 wb(i, k, j+1) = wb(i, k, j+1) + temp63b11 wb(i, k, j) = wb(i, k, j) + temp63b13 + temp63b11 rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp63b12 rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp63b12 wb(i, k, j-1) = wb(i, k, j-1) + temp63b13 END DO END DO CALL POPINTEGER4(k) END DO CALL POPINTEGER4(ad_from42) CALL POPINTEGER4(ad_to42) DO j=ad_to42,ad_from42,-1 CALL POPINTEGER4(ad_from41) CALL POPINTEGER4(ad_to41) DO i=ad_to41,ad_from41,-1 mrdx = msftx(i, j)*rdx temp63b4 = -(mrdx*0.5*tendencyb(i, k, j)) temp63b5 = (w(i+1, k, j)+w(i, k, j))*temp63b4 temp63b6 = ((2.-fzm(k-1))*ru(i+1, k-1, j)-fzp(k-1)*ru(i+1, k-2, & & j))*temp63b4 temp63b7 = -((w(i, k, j)+w(i-1, k, j))*temp63b4) temp63b8 = -(((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2, j)& & )*temp63b4) rub(i+1, k-1, j) = rub(i+1, k-1, j) + (2.-fzm(k-1))*temp63b5 rub(i+1, k-2, j) = rub(i+1, k-2, j) - fzp(k-1)*temp63b5 wb(i+1, k, j) = wb(i+1, k, j) + temp63b6 wb(i, k, j) = wb(i, k, j) + temp63b8 + temp63b6 rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp63b7 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp63b7 wb(i-1, k, j) = wb(i-1, k, j) + temp63b8 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from40) CALL POPINTEGER4(ad_to40) DO i=ad_to40,ad_from40,-1 mrdx = msftx(i, j)*rdx temp63b = -(mrdx*0.5*tendencyb(i, k, j)) temp63b0 = (w(i+1, k, j)+w(i, k, j))*temp63b temp63b1 = (fzm(k)*ru(i+1, k, j)+fzp(k)*ru(i+1, k-1, j))*& & temp63b temp63b2 = -((w(i, k, j)+w(i-1, k, j))*temp63b) temp63b3 = -((fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*temp63b& & ) rub(i+1, k, j) = rub(i+1, k, j) + fzm(k)*temp63b0 rub(i+1, k-1, j) = rub(i+1, k-1, j) + fzp(k)*temp63b0 wb(i+1, k, j) = wb(i+1, k, j) + temp63b1 wb(i, k, j) = wb(i, k, j) + temp63b3 + temp63b1 rub(i, k, j) = rub(i, k, j) + fzm(k)*temp63b2 rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp63b2 wb(i-1, k, j) = wb(i-1, k, j) + temp63b3 END DO END DO CALL POPINTEGER4(k) END DO ELSE IF (branch .LT. 6) THEN IF (branch .EQ. 4) THEN fqyb = 0.0 CALL POPINTEGER4(ad_from39) CALL POPINTEGER4(ad_to39) DO j=ad_to39,ad_from39,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from36) CALL POPINTEGER4(ad_to36) DO i=ad_to36,ad_from36,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO CALL POPINTEGER4(k) ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from37) CALL POPINTEGER4(ad_to37) DO i=ad_to37,ad_from37,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from38) CALL POPINTEGER4(ad_to38) DO i=ad_to38,ad_from38,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from31) CALL POPINTEGER4(ad_to31) DO i=ad_to31,ad_from31,-1 temp55b9 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(i& & , k, jp1) temp55b10 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*& & rv(i, k-2, j_start))*fqyb(i, k, jp1) rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + (2.-fzm(k-1))*& & temp55b9 rvb(i, k-2, j_start) = rvb(i, k-2, j_start) - fzp(k-1)*& & temp55b9 wb(i, k, j_start) = wb(i, k, j_start) + temp55b10 wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp55b10 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from30) CALL POPINTEGER4(ad_to30) DO i=ad_to30,ad_from30,-1 temp55b7 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(& & i, k, jp1) temp55b8 = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1& & , j_start))*fqyb(i, k, jp1) rvb(i, k, j_start) = rvb(i, k, j_start) + fzm(k)*temp55b7 rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + fzp(k)*& & temp55b7 wb(i, k, j_start) = wb(i, k, j_start) + temp55b8 wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp55b8 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from33) CALL POPINTEGER4(ad_to33) DO i=ad_to33,ad_from33,-1 temp55b13 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp55b14 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, & & k-2, j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp55b13 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp55b13 wb(i, k, j) = wb(i, k, j) + temp55b14 wb(i, k, j-1) = wb(i, k, j-1) + temp55b14 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from32) CALL POPINTEGER4(ad_to32) DO i=ad_to32,ad_from32,-1 temp55b11 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp55b12 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp55b11 rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp55b11 wb(i, k, j) = wb(i, k, j) + temp55b12 wb(i, k, j-1) = wb(i, k, j-1) + temp55b12 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE CALL POPINTEGER4(ad_from35) CALL POPINTEGER4(ad_to35) DO i=ad_to35,ad_from35,-1 temp59 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k& & , j-1)) temp62 = SIGN(1., vel) temp61 = temp62/12.0 temp60 = SIGN(1, time_step) temp59b = vel*fqyb(i, k, jp1) temp59b0 = temp59b/12.0 temp59b1 = temp60*temp61*temp59b velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j& & -2))/12.0+temp60*(temp61*temp59))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 7.*temp59b0 - 3.*temp59b1 wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp59b1 + 7.*temp59b0 wb(i, k, j+1) = wb(i, k, j+1) + temp59b1 - temp59b0 wb(i, k, j-2) = wb(i, k, j-2) - temp59b1 - temp59b0 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from34) CALL POPINTEGER4(ad_to34) DO i=ad_to34,ad_from34,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp55 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i& & , k, j-1)) temp58 = SIGN(1., vel) temp57 = temp58/12.0 temp56 = SIGN(1, time_step) temp55b15 = vel*fqyb(i, k, jp1) temp55b16 = temp55b15/12.0 temp55b17 = temp56*temp57*temp55b15 velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k& & , j-2))/12.0+temp56*(temp57*temp55))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 7.*temp55b16 - 3.*temp55b17 wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp55b17 + 7.*& & temp55b16 wb(i, k, j+1) = wb(i, k, j+1) + temp55b17 - temp55b16 wb(i, k, j-2) = wb(i, k, j-2) - temp55b17 - temp55b16 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) fqxb = 0.0 CALL POPINTEGER4(ad_from29) CALL POPINTEGER4(ad_to29) DO j=ad_to29,ad_from29,-1 DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from28) CALL POPINTEGER4(ad_to28) DO i=ad_to28,ad_from28,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp55b5 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+1& & , k) temp55b6 = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(& & i_end+1, k-2, j))*fqxb(i_end+1, k) rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + (2.-fzm(k-1))*& & temp55b5 rub(i_end+1, k-2, j) = rub(i_end+1, k-2, j) - fzp(k-1)*& & temp55b5 wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp55b6 wb(i_end, k, j) = wb(i_end, k, j) + temp55b6 fqxb(i_end+1, k) = 0.0 DO k=ktf,kts+1,-1 temp55b3 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+& & 1, k) temp55b4 = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, & & k-1, j))*fqxb(i_end+1, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + fzm(k)*temp55b3 rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + fzp(k)*& & temp55b3 wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp55b4 wb(i_end, k, j) = wb(i_end, k, j) + temp55b4 fqxb(i_end+1, k) = 0.0 END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp55b1 = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(& & i_start, k) temp55b2 = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(& & i_start, k-2, j))*fqxb(i_start, k) rub(i_start, k-1, j) = rub(i_start, k-1, j) + (2.-fzm(k-1))*& & temp55b1 rub(i_start, k-2, j) = rub(i_start, k-2, j) - fzp(k-1)*& & temp55b1 wb(i_start, k, j) = wb(i_start, k, j) + temp55b2 wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp55b2 fqxb(i_start, k) = 0.0 DO k=ktf,kts+1,-1 temp55b = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(& & i_start, k) temp55b0 = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(i_start, & & k-1, j))*fqxb(i_start, k) rub(i_start, k, j) = rub(i_start, k, j) + fzm(k)*temp55b rub(i_start, k-1, j) = rub(i_start, k-1, j) + fzp(k)*temp55b wb(i_start, k, j) = wb(i_start, k, j) + temp55b0 wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp55b0 fqxb(i_start, k) = 0.0 END DO CALL POPINTEGER4(k) END IF k = ktf + 1 DO i=i_end_f,i_start_f,-1 temp51 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1, k& & , j)) temp54 = SIGN(1., vel) temp53 = temp54/12.0 temp52 = SIGN(1, time_step) temp51b = vel*fqxb(i, k) temp51b0 = temp51b/12.0 temp51b1 = temp52*temp53*temp51b velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j& & ))/12.0+temp52*(temp53*temp51))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp51b0 - 3.*temp51b1 wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp51b1 + 7.*temp51b0 wb(i+1, k, j) = wb(i+1, k, j) + temp51b1 - temp51b0 wb(i-2, k, j) = wb(i-2, k, j) - temp51b1 - temp51b0 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 DO i=i_end_f,i_start_f,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp47 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1& & , k, j)) temp50 = SIGN(1., vel) temp49 = temp50/12.0 temp48 = SIGN(1, time_step) temp47b19 = vel*fqxb(i, k) temp47b20 = temp47b19/12.0 temp47b21 = temp48*temp49*temp47b19 velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))/12.0+temp48*(temp49*temp47))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp47b20 - 3.*temp47b21 wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp47b21 + 7.*temp47b20 wb(i+1, k, j) = wb(i+1, k, j) + temp47b21 - temp47b20 wb(i-2, k, j) = wb(i-2, k, j) - temp47b21 - temp47b20 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO END DO END DO ELSE fqyb = 0.0 CALL POPINTEGER4(ad_from27) CALL POPINTEGER4(ad_to27) DO j=ad_to27,ad_from27,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from24) CALL POPINTEGER4(ad_to24) DO i=ad_to24,ad_from24,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO CALL POPINTEGER4(k) ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from25) CALL POPINTEGER4(ad_to25) DO i=ad_to25,ad_from25,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from26) CALL POPINTEGER4(ad_to26) DO i=ad_to26,ad_from26,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO i=ad_to19,ad_from19,-1 temp47b11 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(i& & , k, jp1) temp47b12 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*& & rv(i, k-2, j_start))*fqyb(i, k, jp1) rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + (2.-fzm(k-1))*& & temp47b11 rvb(i, k-2, j_start) = rvb(i, k-2, j_start) - fzp(k-1)*& & temp47b11 wb(i, k, j_start) = wb(i, k, j_start) + temp47b12 wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp47b12 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO i=ad_to18,ad_from18,-1 temp47b9 = 0.5*(w(i, k, j_start)+w(i, k, j_start-1))*fqyb(& & i, k, jp1) temp47b10 = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1& & , j_start))*fqyb(i, k, jp1) rvb(i, k, j_start) = rvb(i, k, j_start) + fzm(k)*temp47b9 rvb(i, k-1, j_start) = rvb(i, k-1, j_start) + fzp(k)*& & temp47b9 wb(i, k, j_start) = wb(i, k, j_start) + temp47b10 wb(i, k, j_start-1) = wb(i, k, j_start-1) + temp47b10 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO i=ad_to21,ad_from21,-1 temp47b15 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp47b16 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, & & k-2, j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp47b15 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp47b15 wb(i, k, j) = wb(i, k, j) + temp47b16 wb(i, k, j-1) = wb(i, k, j-1) + temp47b16 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO i=ad_to20,ad_from20,-1 temp47b13 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp47b14 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp47b13 rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp47b13 wb(i, k, j) = wb(i, k, j) + temp47b14 wb(i, k, j-1) = wb(i, k, j-1) + temp47b14 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 temp47b18 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-& & 2))*fqyb(i, k, jp1)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp47b18 wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp47b18 wb(i, k, j+1) = wb(i, k, j+1) - temp47b18 wb(i, k, j-2) = wb(i, k, j-2) - temp47b18 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO i=ad_to22,ad_from22,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp47b17 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, & & j-2))*fqyb(i, k, jp1)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp47b17 wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp47b17 wb(i, k, j+1) = wb(i, k, j+1) - temp47b17 wb(i, k, j-2) = wb(i, k, j-2) - temp47b17 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPINTEGER4(i_start) fqxb = 0.0 CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO j=ad_to17,ad_from17,-1 DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO i=ad_to16,ad_from16,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp47b7 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+1& & , k) temp47b8 = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(& & i_end+1, k-2, j))*fqxb(i_end+1, k) rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + (2.-fzm(k-1))*& & temp47b7 rub(i_end+1, k-2, j) = rub(i_end+1, k-2, j) - fzp(k-1)*& & temp47b7 wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp47b8 wb(i_end, k, j) = wb(i_end, k, j) + temp47b8 fqxb(i_end+1, k) = 0.0 DO k=ktf,kts+1,-1 temp47b5 = 0.5*(w(i_end+1, k, j)+w(i_end, k, j))*fqxb(i_end+& & 1, k) temp47b6 = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, & & k-1, j))*fqxb(i_end+1, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + fzm(k)*temp47b5 rub(i_end+1, k-1, j) = rub(i_end+1, k-1, j) + fzp(k)*& & temp47b5 wb(i_end+1, k, j) = wb(i_end+1, k, j) + temp47b6 wb(i_end, k, j) = wb(i_end, k, j) + temp47b6 fqxb(i_end+1, k) = 0.0 END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp47b3 = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(& & i_start, k) temp47b4 = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(& & i_start, k-2, j))*fqxb(i_start, k) rub(i_start, k-1, j) = rub(i_start, k-1, j) + (2.-fzm(k-1))*& & temp47b3 rub(i_start, k-2, j) = rub(i_start, k-2, j) - fzp(k-1)*& & temp47b3 wb(i_start, k, j) = wb(i_start, k, j) + temp47b4 wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp47b4 fqxb(i_start, k) = 0.0 DO k=ktf,kts+1,-1 temp47b1 = 0.5*(w(i_start, k, j)+w(i_start-1, k, j))*fqxb(& & i_start, k) temp47b2 = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(i_start, & & k-1, j))*fqxb(i_start, k) rub(i_start, k, j) = rub(i_start, k, j) + fzm(k)*temp47b1 rub(i_start, k-1, j) = rub(i_start, k-1, j) + fzp(k)*& & temp47b1 wb(i_start, k, j) = wb(i_start, k, j) + temp47b2 wb(i_start-1, k, j) = wb(i_start-1, k, j) + temp47b2 fqxb(i_start, k) = 0.0 END DO CALL POPINTEGER4(k) END IF k = ktf + 1 DO i=i_end_f,i_start_f,-1 temp47b0 = vel*fqxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j)& & )*fqxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp47b0 wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp47b0 wb(i+1, k, j) = wb(i+1, k, j) - temp47b0 wb(i-2, k, j) = wb(i-2, k, j) - temp47b0 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 DO i=i_end_f,i_start_f,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp47b = vel*fqxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, & & j))*fqxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp47b wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp47b wb(i+1, k, j) = wb(i+1, k, j) - temp47b wb(i-2, k, j) = wb(i-2, k, j) - temp47b fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO END DO END DO END IF ELSE IF (branch .EQ. 6) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO j=ad_to15,ad_from15,-1 DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to13) DO i=ad_to13,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp43 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1& & , k, j)) temp46 = SIGN(1., vel) temp45 = temp46/12.0 temp44 = SIGN(1, time_step) temp43b = vel*fqxb(i, k) temp43b0 = temp43b/12.0 temp43b1 = temp44*temp45*temp43b velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))/12.0+temp44*(temp45*temp43))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp43b0 - 3.*temp43b1 wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp43b1 + 7.*temp43b0 wb(i+1, k, j) = wb(i+1, k, j) + temp43b1 - temp43b0 wb(i-2, k, j) = wb(i-2, k, j) - temp43b1 - temp43b0 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb DO k=ktf,kts+1,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp39 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-& & 1, k, j)) temp42 = SIGN(1., vel) temp41 = temp42/12.0 temp40 = SIGN(1, time_step) temp39b3 = vel*fqxb(i, k) temp39b4 = temp39b3/12.0 temp39b5 = temp40*temp41*temp39b3 velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, & & k, j))/12.0+temp40*(temp41*temp39))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp39b4 - 3.*temp39b5 wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp39b5 + 7.*temp39b4 wb(i+1, k, j) = wb(i+1, k, j) + temp39b5 - temp39b4 wb(i-2, k, j) = wb(i-2, k, j) - temp39b5 - temp39b4 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp39b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp39b2 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k& & -2, j))*fqxb(i, k) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp39b1 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp39b1 wb(i, k, j) = wb(i, k, j) + temp39b2 wb(i-1, k, j) = wb(i-1, k, j) + temp39b2 fqxb(i, k) = 0.0 DO k=ktf,kts+1,-1 temp39b = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp39b0 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*& & fqxb(i, k) rub(i, k, j) = rub(i, k, j) + fzm(k)*temp39b rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp39b wb(i, k, j) = wb(i, k, j) + temp39b0 wb(i-1, k, j) = wb(i-1, k, j) + temp39b0 fqxb(i, k) = 0.0 END DO CALL POPINTEGER4(k) END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from13) DO i=i_start_f-1,ad_from13,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp35 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1& & , k, j)) temp38 = SIGN(1., vel) temp37 = temp38/12.0 temp36 = SIGN(1, time_step) temp35b = vel*fqxb(i, k) temp35b0 = temp35b/12.0 temp35b1 = temp36*temp37*temp35b velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))/12.0+temp36*(temp37*temp35))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp35b0 - 3.*temp35b1 wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp35b1 + 7.*temp35b0 wb(i+1, k, j) = wb(i+1, k, j) + temp35b1 - temp35b0 wb(i-2, k, j) = wb(i-2, k, j) - temp35b1 - temp35b0 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb DO k=ktf,kts+1,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp31 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-& & 1, k, j)) temp34 = SIGN(1., vel) temp33 = temp34/12.0 temp32 = SIGN(1, time_step) temp31b3 = vel*fqxb(i, k) temp31b4 = temp31b3/12.0 temp31b5 = temp32*temp33*temp31b3 velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, & & k, j))/12.0+temp32*(temp33*temp31))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 7.*temp31b4 - 3.*temp31b5 wb(i-1, k, j) = wb(i-1, k, j) + 3.*temp31b5 + 7.*temp31b4 wb(i+1, k, j) = wb(i+1, k, j) + temp31b5 - temp31b4 wb(i-2, k, j) = wb(i-2, k, j) - temp31b5 - temp31b4 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp31b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp31b2 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k& & -2, j))*fqxb(i, k) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp31b1 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp31b1 wb(i, k, j) = wb(i, k, j) + temp31b2 wb(i-1, k, j) = wb(i-1, k, j) + temp31b2 fqxb(i, k) = 0.0 DO k=ktf,kts+1,-1 temp31b = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp31b0 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*& & fqxb(i, k) rub(i, k, j) = rub(i, k, j) + fzm(k)*temp31b rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp31b wb(i, k, j) = wb(i, k, j) + temp31b0 wb(i-1, k, j) = wb(i-1, k, j) + temp31b0 fqxb(i, k) = 0.0 END DO CALL POPINTEGER4(k) END IF END DO END IF k = ktf + 1 DO i=i_end_f,i_start_f,-1 temp27 = w(i+2, k, j) - w(i-3, k, j) + 10.*(w(i, k, j)-w(i-1, k& & , j)) - 5.*(w(i+1, k, j)-w(i-2, k, j)) temp30 = SIGN(1., vel) temp29 = temp30/60.0 temp28 = SIGN(1, time_step) temp27b = vel*fqxb(i, k) temp27b0 = temp27b/60.0 temp27b1 = -(temp28*temp29*temp27b) velb = ((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2, k& & , j))+w(i+2, k, j)+w(i-3, k, j))/60.0-temp28*(temp29*temp27))*& & fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 10.*temp27b1 + 37.*temp27b0 wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp27b0 - 10.*temp27b1 wb(i+1, k, j) = wb(i+1, k, j) - 5.*temp27b1 - 8.*temp27b0 wb(i-2, k, j) = wb(i-2, k, j) + 5.*temp27b1 - 8.*temp27b0 wb(i+2, k, j) = wb(i+2, k, j) + temp27b1 + temp27b0 wb(i-3, k, j) = wb(i-3, k, j) + temp27b0 - temp27b1 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 DO i=i_end_f,i_start_f,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp23 = w(i+2, k, j) - w(i-3, k, j) + 10.*(w(i, k, j)-w(i-1, & & k, j)) - 5.*(w(i+1, k, j)-w(i-2, k, j)) temp26 = SIGN(1., vel) temp25 = temp26/60.0 temp24 = SIGN(1, time_step) temp23b = vel*fqxb(i, k) temp23b0 = temp23b/60.0 temp23b1 = -(temp24*temp25*temp23b) velb = ((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2& & , k, j))+w(i+2, k, j)+w(i-3, k, j))/60.0-temp24*(temp25*& & temp23))*fqxb(i, k) wb(i, k, j) = wb(i, k, j) + 10.*temp23b1 + 37.*temp23b0 wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp23b0 - 10.*temp23b1 wb(i+1, k, j) = wb(i+1, k, j) - 5.*temp23b1 - 8.*temp23b0 wb(i-2, k, j) = wb(i-2, k, j) + 5.*temp23b1 - 8.*temp23b0 wb(i+2, k, j) = wb(i+2, k, j) + temp23b1 + temp23b0 wb(i-3, k, j) = wb(i-3, k, j) + temp23b0 - temp23b1 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END DO fqyb = 0.0 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO j=ad_to12,ad_from12,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) END DO END DO CALL POPINTEGER4(k) ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO i=ad_to10,ad_from10,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO i=ad_to11,ad_from11,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 temp3 = w(i, k, j+2) - w(i, k, j-3) + 10.*(w(i, k, j)-w(i, k& & , j-1)) - 5.*(w(i, k, j+1)-w(i, k, j-2)) temp6 = SIGN(1., vel) temp5 = temp6/60.0 temp4 = SIGN(1, time_step) temp3b = vel*fqyb(i, k, jp1) temp3b0 = temp3b/60.0 temp3b1 = -(temp4*temp5*temp3b) velb = ((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(i& & , k, j-2))+w(i, k, j+2)+w(i, k, j-3))/60.0-temp4*(temp5*& & temp3))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 10.*temp3b1 + 37.*temp3b0 wb(i, k, j-1) = wb(i, k, j-1) + 37.*temp3b0 - 10.*temp3b1 wb(i, k, j+1) = wb(i, k, j+1) - 5.*temp3b1 - 8.*temp3b0 wb(i, k, j-2) = wb(i, k, j-2) + 5.*temp3b1 - 8.*temp3b0 wb(i, k, j+2) = wb(i, k, j+2) + temp3b1 + temp3b0 wb(i, k, j-3) = wb(i, k, j-3) + temp3b0 - temp3b1 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp = w(i, k, j+2) - w(i, k, j-3) + 10.*(w(i, k, j)-w(i, & & k, j-1)) - 5.*(w(i, k, j+1)-w(i, k, j-2)) temp2 = SIGN(1., vel) temp1 = temp2/60.0 temp0 = SIGN(1, time_step) tempb = vel*fqyb(i, k, jp1) tempb0 = tempb/60.0 tempb1 = -(temp0*temp1*tempb) velb = ((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(& & i, k, j-2))+w(i, k, j+2)+w(i, k, j-3))/60.0-temp0*(temp1& & *temp))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 10.*tempb1 + 37.*tempb0 wb(i, k, j-1) = wb(i, k, j-1) + 37.*tempb0 - 10.*tempb1 wb(i, k, j+1) = wb(i, k, j+1) - 5.*tempb1 - 8.*tempb0 wb(i, k, j-2) = wb(i, k, j-2) + 5.*tempb1 - 8.*tempb0 wb(i, k, j+2) = wb(i, k, j+2) + tempb1 + tempb0 wb(i, k, j-3) = wb(i, k, j-3) + tempb0 - tempb1 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp7b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp7b2 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-& & 2, j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp7b1 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp7b1 wb(i, k, j) = wb(i, k, j) + temp7b2 wb(i, k, j-1) = wb(i, k, j-1) + temp7b2 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 temp7b = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp7b0 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp7b rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp7b wb(i, k, j) = wb(i, k, j) + temp7b0 wb(i, k, j-1) = wb(i, k, j-1) + temp7b0 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 temp11 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k& & , j-1)) temp14 = SIGN(1., vel) temp13 = temp14/12.0 temp12 = SIGN(1, time_step) temp11b = vel*fqyb(i, k, jp1) temp11b0 = temp11b/12.0 temp11b1 = temp12*temp13*temp11b velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j& & -2))/12.0+temp12*(temp13*temp11))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 7.*temp11b0 - 3.*temp11b1 wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp11b1 + 7.*temp11b0 wb(i, k, j+1) = wb(i, k, j+1) + temp11b1 - temp11b0 wb(i, k, j-2) = wb(i, k, j-2) - temp11b1 - temp11b0 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp7 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, & & k, j-1)) temp10 = SIGN(1., vel) temp9 = temp10/12.0 temp8 = SIGN(1, time_step) temp7b3 = vel*fqyb(i, k, jp1) temp7b4 = temp7b3/12.0 temp7b5 = temp8*temp9*temp7b3 velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k& & , j-2))/12.0+temp8*(temp9*temp7))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 7.*temp7b4 - 3.*temp7b5 wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp7b5 + 7.*temp7b4 wb(i, k, j+1) = wb(i, k, j+1) + temp7b5 - temp7b4 wb(i, k, j-2) = wb(i, k, j-2) - temp7b5 - temp7b4 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 3) THEN CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 temp15b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp15b2 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2& & , j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp15b1 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp15b1 wb(i, k, j) = wb(i, k, j) + temp15b2 wb(i, k, j-1) = wb(i, k, j-1) + temp15b2 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 temp15b = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp15b0 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp15b rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp15b wb(i, k, j) = wb(i, k, j) + temp15b0 wb(i, k, j-1) = wb(i, k, j-1) + temp15b0 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO i=ad_to8,ad_from8,-1 temp19 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, & & j-1)) temp22 = SIGN(1., vel) temp21 = temp22/12.0 temp20 = SIGN(1, time_step) temp19b = vel*fqyb(i, k, jp1) temp19b0 = temp19b/12.0 temp19b1 = temp20*temp21*temp19b velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2& & ))/12.0+temp20*(temp21*temp19))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 7.*temp19b0 - 3.*temp19b1 wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp19b1 + 7.*temp19b0 wb(i, k, j+1) = wb(i, k, j+1) + temp19b1 - temp19b0 wb(i, k, j-2) = wb(i, k, j-2) - temp19b1 - temp19b0 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO i=ad_to7,ad_from7,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp15 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k& & , j-1)) temp18 = SIGN(1., vel) temp17 = temp18/12.0 temp16 = SIGN(1, time_step) temp15b3 = vel*fqyb(i, k, jp1) temp15b4 = temp15b3/12.0 temp15b5 = temp16*temp17*temp15b3 velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j& & -2))/12.0+temp16*(temp17*temp15))*fqyb(i, k, jp1) wb(i, k, j) = wb(i, k, j) + 7.*temp15b4 - 3.*temp15b5 wb(i, k, j-1) = wb(i, k, j-1) + 3.*temp15b5 + 7.*temp15b4 wb(i, k, j+1) = wb(i, k, j+1) + temp15b5 - temp15b4 wb(i, k, j-2) = wb(i, k, j-2) - temp15b5 - temp15b4 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF END DO ELSE fqxb = 0.0 CALL POPINTEGER4(ad_from66) CALL POPINTEGER4(ad_to66) DO j=ad_to66,ad_from66,-1 DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from65) CALL POPINTEGER4(ad_to65) DO i=ad_to65,ad_from65,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to64) DO i=ad_to64,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp63b58 = vel*fqxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, & & j))*fqxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b58 wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b58 wb(i+1, k, j) = wb(i+1, k, j) - temp63b58 wb(i-2, k, j) = wb(i-2, k, j) - temp63b58 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb DO k=ktf,kts+1,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp63b57 = vel*fqxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))*fqxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b57 wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b57 wb(i+1, k, j) = wb(i+1, k, j) - temp63b57 wb(i-2, k, j) = wb(i-2, k, j) - temp63b57 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp63b55 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp63b56 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, & & k-2, j))*fqxb(i, k) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp63b55 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp63b55 wb(i, k, j) = wb(i, k, j) + temp63b56 wb(i-1, k, j) = wb(i-1, k, j) + temp63b56 fqxb(i, k) = 0.0 DO k=ktf,kts+1,-1 temp63b53 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp63b54 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*& & fqxb(i, k) rub(i, k, j) = rub(i, k, j) + fzm(k)*temp63b53 rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp63b53 wb(i, k, j) = wb(i, k, j) + temp63b54 wb(i-1, k, j) = wb(i-1, k, j) + temp63b54 fqxb(i, k) = 0.0 END DO CALL POPINTEGER4(k) END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from64) DO i=i_start_f-1,ad_from64,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp63b52 = vel*fqxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, & & j))*fqxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b52 wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b52 wb(i+1, k, j) = wb(i+1, k, j) - temp63b52 wb(i-2, k, j) = wb(i-2, k, j) - temp63b52 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb DO k=ktf,kts+1,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp63b51 = vel*fqxb(i, k)/12.0 velb = (7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))*fqxb(i, k)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b51 wb(i-1, k, j) = wb(i-1, k, j) + 7.*temp63b51 wb(i+1, k, j) = wb(i+1, k, j) - temp63b51 wb(i-2, k, j) = wb(i-2, k, j) - temp63b51 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp63b49 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp63b50 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, & & k-2, j))*fqxb(i, k) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp63b49 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp63b49 wb(i, k, j) = wb(i, k, j) + temp63b50 wb(i-1, k, j) = wb(i-1, k, j) + temp63b50 fqxb(i, k) = 0.0 DO k=ktf,kts+1,-1 temp63b47 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp63b48 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*& & fqxb(i, k) rub(i, k, j) = rub(i, k, j) + fzm(k)*temp63b47 rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp63b47 wb(i, k, j) = wb(i, k, j) + temp63b48 wb(i-1, k, j) = wb(i-1, k, j) + temp63b48 fqxb(i, k) = 0.0 END DO CALL POPINTEGER4(k) END IF END DO END IF k = ktf + 1 DO i=i_end_f,i_start_f,-1 temp63b46 = vel*fqxb(i, k)/60.0 velb = (37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2, k& & , j))+w(i+2, k, j)+w(i-3, k, j))*fqxb(i, k)/60.0 wb(i, k, j) = wb(i, k, j) + 37.*temp63b46 wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp63b46 wb(i+1, k, j) = wb(i+1, k, j) - 8.*temp63b46 wb(i-2, k, j) = wb(i-2, k, j) - 8.*temp63b46 wb(i+2, k, j) = wb(i+2, k, j) + temp63b46 wb(i-3, k, j) = wb(i-3, k, j) + temp63b46 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 DO i=i_end_f,i_start_f,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp63b45 = vel*fqxb(i, k)/60.0 velb = (37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)+w(i-2, & & k, j))+w(i+2, k, j)+w(i-3, k, j))*fqxb(i, k)/60.0 wb(i, k, j) = wb(i, k, j) + 37.*temp63b45 wb(i-1, k, j) = wb(i-1, k, j) + 37.*temp63b45 wb(i+1, k, j) = wb(i+1, k, j) - 8.*temp63b45 wb(i-2, k, j) = wb(i-2, k, j) - 8.*temp63b45 wb(i+2, k, j) = wb(i+2, k, j) + temp63b45 wb(i-3, k, j) = wb(i-3, k, j) + temp63b45 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END DO fqyb = 0.0 CALL POPINTEGER4(ad_from63) CALL POPINTEGER4(ad_to63) DO j=ad_to63,ad_from63,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from60) CALL POPINTEGER4(ad_to60) DO i=ad_to60,ad_from60,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) END DO END DO CALL POPINTEGER4(k) ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from61) CALL POPINTEGER4(ad_to61) DO i=ad_to61,ad_from61,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from62) CALL POPINTEGER4(ad_to62) DO i=ad_to62,ad_from62,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from51) CALL POPINTEGER4(ad_to51) DO i=ad_to51,ad_from51,-1 temp63b32 = vel*fqyb(i, k, jp1)/60.0 velb = (37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(i, & & k, j-2))+w(i, k, j+2)+w(i, k, j-3))*fqyb(i, k, jp1)/60.0 wb(i, k, j) = wb(i, k, j) + 37.*temp63b32 wb(i, k, j-1) = wb(i, k, j-1) + 37.*temp63b32 wb(i, k, j+1) = wb(i, k, j+1) - 8.*temp63b32 wb(i, k, j-2) = wb(i, k, j-2) - 8.*temp63b32 wb(i, k, j+2) = wb(i, k, j+2) + temp63b32 wb(i, k, j-3) = wb(i, k, j-3) + temp63b32 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from50) CALL POPINTEGER4(ad_to50) DO i=ad_to50,ad_from50,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp63b31 = vel*fqyb(i, k, jp1)/60.0 velb = (37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, k, j+1)+w(i& & , k, j-2))+w(i, k, j+2)+w(i, k, j-3))*fqyb(i, k, jp1)/& & 60.0 wb(i, k, j) = wb(i, k, j) + 37.*temp63b31 wb(i, k, j-1) = wb(i, k, j-1) + 37.*temp63b31 wb(i, k, j+1) = wb(i, k, j+1) - 8.*temp63b31 wb(i, k, j-2) = wb(i, k, j-2) - 8.*temp63b31 wb(i, k, j+2) = wb(i, k, j+2) + temp63b31 wb(i, k, j-3) = wb(i, k, j-3) + temp63b31 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from53) CALL POPINTEGER4(ad_to53) DO i=ad_to53,ad_from53,-1 temp63b35 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp63b36 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, & & k-2, j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp63b35 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp63b35 wb(i, k, j) = wb(i, k, j) + temp63b36 wb(i, k, j-1) = wb(i, k, j-1) + temp63b36 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from52) CALL POPINTEGER4(ad_to52) DO i=ad_to52,ad_from52,-1 temp63b33 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp63b34 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp63b33 rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp63b33 wb(i, k, j) = wb(i, k, j) + temp63b34 wb(i, k, j-1) = wb(i, k, j-1) + temp63b34 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE CALL POPINTEGER4(ad_from55) CALL POPINTEGER4(ad_to55) DO i=ad_to55,ad_from55,-1 temp63b38 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-& & 2))*fqyb(i, k, jp1)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b38 wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b38 wb(i, k, j+1) = wb(i, k, j+1) - temp63b38 wb(i, k, j-2) = wb(i, k, j-2) - temp63b38 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from54) CALL POPINTEGER4(ad_to54) DO i=ad_to54,ad_from54,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp63b37 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, & & j-2))*fqyb(i, k, jp1)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b37 wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b37 wb(i, k, j+1) = wb(i, k, j+1) - temp63b37 wb(i, k, j-2) = wb(i, k, j-2) - temp63b37 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 3) THEN CALL POPINTEGER4(ad_from57) CALL POPINTEGER4(ad_to57) DO i=ad_to57,ad_from57,-1 temp63b41 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp63b42 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-& & 2, j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp63b41 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp63b41 wb(i, k, j) = wb(i, k, j) + temp63b42 wb(i, k, j-1) = wb(i, k, j-1) + temp63b42 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from56) CALL POPINTEGER4(ad_to56) DO i=ad_to56,ad_from56,-1 temp63b39 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp63b40 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*& & fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp63b39 rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp63b39 wb(i, k, j) = wb(i, k, j) + temp63b40 wb(i, k, j-1) = wb(i, k, j-1) + temp63b40 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from59) CALL POPINTEGER4(ad_to59) DO i=ad_to59,ad_from59,-1 temp63b44 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2)& & )*fqyb(i, k, jp1)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b44 wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b44 wb(i, k, j+1) = wb(i, k, j+1) - temp63b44 wb(i, k, j-2) = wb(i, k, j-2) - temp63b44 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from58) CALL POPINTEGER4(ad_to58) DO i=ad_to58,ad_from58,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp63b43 = vel*fqyb(i, k, jp1)/12.0 velb = (7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-& & 2))*fqyb(i, k, jp1)/12.0 wb(i, k, j) = wb(i, k, j) + 7.*temp63b43 wb(i, k, j-1) = wb(i, k, j-1) + 7.*temp63b43 wb(i, k, j+1) = wb(i, k, j+1) - temp63b43 wb(i, k, j-2) = wb(i, k, j-2) - temp63b43 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF END DO END IF 100 CONTINUE END SUBROUTINE A_ADVECT_W ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35 ! ! Differentiation of advect_scalar_pd in reverse (adjoint) mode: ! gradient of useful results: rom field tendency h_tendency ! z_tendency ru rv mu_old field_old mut ! with respect to varying inputs: rom field tendency h_tendency ! z_tendency ru rv mu_old field_old mut ! RW status of diff variables: rom:incr field:incr tendency:in-out ! h_tendency:in-out z_tendency:in-out ru:incr rv:incr ! mu_old:incr field_old:incr mut:incr SUBROUTINE A_ADVECT_SCALAR_PD(field, fieldb, field_old, field_oldb, & & tendency, tendencyb, h_tendency, h_tendencyb, z_tendency, z_tendencyb& & , ru, rub, rv, rvb, rom, romb, mut, mutb, mub, mu_old, mu_oldb, & & time_step, config_flags, tenddec, msfux, msfuy, msfvx, msfvy, msftx, & & msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, kde, ims& & , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags ! tendency flag LOGICAL, INTENT(IN) :: tenddec INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, & & field_old, ru, rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub& & , rvb, romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old REAL, DIMENSION(ims:ime, jms:jme) :: mutb, mu_oldb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: tendencyb REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: h_tendency, z_tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: h_tendencyb, z_tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy, dt INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, mu REAL :: ubb, vbb, mub0 ! storage for high and low order fluxes REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqx, fqy& & , fqz REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxb, fqyb, fqzb REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqxl, & & fqyl, fqzl REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxlb, fqylb, & & fqzlb INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outb, ph_lowb REAL :: scale REAL :: scaleb REAL, PARAMETER :: eps=1.e-20 ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6, flux_upwind REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr REAL :: velb, crb ! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & ! +0.5*(1.-sign(1.,cr))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0. REAL :: dx, dy, dz LOGICAL, PARAMETER :: pd_limit=.true. INTEGER :: branch INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 INTEGER :: ad_from24 INTEGER :: ad_to24 INTEGER :: ad_from25 INTEGER :: ad_to25 INTEGER :: ad_from26 INTEGER :: ad_to26 INTEGER :: ad_from27 INTEGER :: ad_to27 INTEGER :: ad_from28 INTEGER :: ad_to28 INTEGER :: ad_from29 INTEGER :: ad_to29 INTEGER :: ad_from30 INTEGER :: ad_to30 INTEGER :: ad_from31 INTEGER :: ad_to31 INTEGER :: ad_from32 INTEGER :: ad_to32 INTEGER :: ad_from33 INTEGER :: ad_to33 INTEGER :: ad_from34 INTEGER :: ad_to34 INTEGER :: ad_from35 INTEGER :: ad_to35 INTEGER :: ad_from36 INTEGER :: ad_to36 INTEGER :: ad_from37 INTEGER :: ad_to37 INTEGER :: ad_from38 INTEGER :: ad_to38 INTEGER :: ad_from39 INTEGER :: ad_to39 INTEGER :: ad_from40 INTEGER :: ad_to40 INTEGER :: ad_from41 INTEGER :: ad_to41 INTEGER :: ad_from42 INTEGER :: ad_to42 INTEGER :: ad_from43 INTEGER :: ad_to43 INTEGER :: ad_from44 INTEGER :: ad_to44 INTEGER :: ad_from45 INTEGER :: ad_to45 INTEGER :: ad_from46 INTEGER :: ad_to46 INTEGER :: ad_from47 INTEGER :: ad_to47 INTEGER :: ad_from48 INTEGER :: ad_to48 INTEGER :: ad_from49 INTEGER :: ad_to49 INTEGER :: ad_from50 INTEGER :: ad_to50 INTEGER :: ad_from51 INTEGER :: ad_to51 INTEGER :: ad_from52 INTEGER :: ad_to52 INTEGER :: ad_from53 INTEGER :: ad_to53 INTEGER :: ad_from54 INTEGER :: ad_to54 INTEGER :: ad_from55 INTEGER :: ad_to55 INTEGER :: ad_from56 INTEGER :: ad_to56 INTEGER :: ad_from57 INTEGER :: ad_to57 INTEGER :: ad_from58 INTEGER :: ad_to58 INTEGER :: ad_from59 INTEGER :: ad_to59 INTEGER :: ad_from60 INTEGER :: ad_to60 INTEGER :: ad_from61 INTEGER :: ad_to61 INTEGER :: ad_from62 INTEGER :: ad_to62 INTEGER :: ad_from63 INTEGER :: ad_to63 REAL :: abs30 REAL :: y93 REAL :: max43 REAL :: abs67 REAL :: abs100 REAL :: temp3 REAL :: temp29 REAL :: temp31b43 REAL :: y86b REAL :: abs92b REAL :: y92 REAL :: max42 REAL :: abs66 REAL :: temp2 REAL :: min42b INTEGER :: temp28 REAL :: y1b REAL :: temp31b42 REAL :: temp31b79 REAL :: y94b REAL :: y91 REAL :: max41 REAL :: abs65 REAL :: temp1 REAL :: abs18b REAL :: temp23b22 REAL :: temp27 REAL :: temp31b41 REAL :: temp31b78 REAL :: y90 REAL :: max40 REAL :: abs64 INTEGER :: temp0 REAL :: abs26b REAL :: temp26 REAL :: temp23b21 REAL :: temp31b40 REAL :: max39b REAL :: temp31b77 REAL :: abs63 REAL :: temp7b REAL :: temp25 REAL :: temp23b20 REAL :: y28b REAL :: abs34b REAL :: min5b REAL :: max10b REAL :: temp31b76 REAL :: max47b REAL :: abs62 REAL :: abs99 INTEGER :: temp24 REAL :: abs79b REAL :: y36b REAL :: temp31b75 REAL :: abs42b REAL :: temp35b6 REAL :: abs61 REAL :: abs98 REAL :: temp23 REAL :: abs87b REAL :: temp31b74 REAL :: temp35b5 REAL :: y44b REAL :: abs50b INTEGER :: min39 REAL :: abs60 REAL :: abs97 REAL :: temp22 REAL :: min37b REAL :: y52b REAL :: y89b REAL :: temp31b73 REAL :: temp35b4 REAL :: abs95b INTEGER :: min9 REAL :: min38 REAL :: abs96 REAL :: temp21 REAL :: y4b REAL :: y60b REAL :: temp31b72 REAL :: temp35b3 REAL :: y97b INTEGER :: min8 REAL :: min37 REAL :: abs95 INTEGER :: temp20 REAL :: temp31b71 REAL :: temp35b2 REAL :: min7 REAL :: min36 REAL :: abs94 REAL :: abs29b REAL :: temp31b70 REAL :: min61b REAL :: temp35b1 REAL :: abs102b REAL :: min6 INTEGER :: min35 REAL :: y29 REAL :: abs93 REAL :: max13b REAL :: abs37b REAL :: temp35b0 REAL :: min5 INTEGER :: min34 REAL :: y28 REAL :: abs92 REAL :: max21b REAL :: abs1b REAL :: y39b REAL :: abs45b REAL :: min4 REAL :: min33 REAL :: y27 REAL :: abs91 REAL :: abs53b REAL :: y10b REAL :: y47b REAL :: min3 REAL :: min32 REAL :: y26 REAL :: min69 REAL :: abs90 REAL :: y55b REAL :: abs61b REAL :: abs98b INTEGER :: min2 REAL :: min31 REAL :: y25 REAL :: min68 REAL :: y63b REAL :: temp23b9 REAL :: min48b REAL :: max2b REAL :: y7b REAL :: min11b INTEGER :: min1 INTEGER :: min30 REAL :: y24 REAL :: min67 REAL :: y71b REAL :: temp23b8 REAL :: min56b REAL :: y23 REAL :: min66 REAL :: tempb4 REAL :: temp19b REAL :: temp23b7 REAL :: min64b REAL :: y22 REAL :: min65 REAL :: y59 REAL :: tempb3 REAL :: max16b REAL :: temp23b6 REAL :: temp27b REAL :: y21 REAL :: min64 REAL :: y58 REAL :: abs11b REAL :: tempb2 REAL :: temp23b5 REAL :: max24b REAL :: abs4b REAL :: temp35b REAL :: abs48b REAL :: y20 REAL :: min63 REAL :: y57 REAL :: tempb1 REAL :: y13b REAL :: temp23b4 REAL :: max32b REAL :: abs56b REAL :: temp43b REAL :: min62 REAL :: y56 REAL :: tempb0 REAL :: abs64b REAL :: y21b REAL :: temp23b3 REAL :: y58b REAL :: max40b REAL :: temp47b18 REAL :: min61 REAL :: y55 REAL :: abs29 REAL :: y66b REAL :: abs72b REAL :: temp23b2 REAL :: max5b REAL :: min14b REAL :: temp47b17 REAL :: min60 REAL :: y54 REAL :: abs28 REAL :: temp23b1 REAL :: y74b REAL :: abs80b REAL :: min59b REAL :: y102b REAL :: temp47b16 REAL :: y53 REAL :: abs27 REAL :: temp7b6 REAL :: temp23b0 REAL :: y82b REAL :: min67b REAL :: temp47b15 REAL :: y52 REAL :: abs26 REAL :: y89 REAL :: max39 REAL :: temp7b5 REAL :: max19b REAL :: temp31b39 REAL :: y90b REAL :: min75b REAL :: temp47b14 REAL :: y51 REAL :: abs25 REAL :: y88 REAL :: max38 REAL :: abs14b REAL :: temp7b4 REAL :: max27b REAL :: temp23b19 REAL :: abs7b REAL :: temp31b38 REAL :: temp47b13 REAL :: y50 REAL :: abs24 REAL :: y87 REAL :: max37 REAL :: temp7b3 REAL :: y16b REAL :: abs22b REAL :: temp23b18 REAL :: max35b REAL :: abs59b REAL :: temp31b37 REAL :: temp47b12 REAL :: abs23 REAL :: y86 REAL :: max36 REAL :: temp3b REAL :: temp7b2 REAL :: abs67b REAL :: y24b REAL :: temp23b17 REAL :: abs30b REAL :: temp31b36 REAL :: max43b REAL :: temp47b11 REAL :: abs22 REAL :: y85 REAL :: max35 REAL :: abs59 REAL :: min17b REAL :: temp7b1 REAL :: y69b REAL :: abs75b REAL :: temp23b16 REAL :: y32b REAL :: max8b REAL :: temp31b35 REAL :: max51b REAL :: temp47b10 REAL :: abs21 REAL :: y84 REAL :: max34 REAL :: abs58 REAL :: temp7b0 REAL :: min25b REAL :: temp23b15 REAL :: y77b REAL :: abs83b REAL :: temp31b34 REAL :: y40b REAL :: abs20 REAL :: y83 REAL :: max33 REAL :: abs57 REAL :: temp19 REAL :: min33b REAL :: temp23b14 REAL :: y85b REAL :: temp31b33 REAL :: abs91b REAL :: y82 REAL :: max32 REAL :: abs56 REAL :: temp18 REAL :: temp23b13 REAL :: min41b REAL :: temp31b32 REAL :: temp31b69 REAL :: y93b REAL :: y81 REAL :: max31 REAL :: abs55 REAL :: temp11b4 REAL :: abs17b REAL :: temp17 REAL :: temp23b12 REAL :: temp31b31 REAL :: temp31b68 REAL :: temp43b9 REAL :: y80 REAL :: max30 REAL :: abs54 REAL :: temp11b3 INTEGER :: temp16 REAL :: y19b REAL :: temp23b11 REAL :: abs25b REAL :: temp31b30 REAL :: max38b REAL :: temp31b67 REAL :: temp43b8 REAL :: abs53 REAL :: temp11b2 REAL :: temp15 REAL :: temp23b10 REAL :: y27b REAL :: abs33b REAL :: min4b REAL :: temp31b66 REAL :: max46b REAL :: temp43b7 REAL :: abs52 REAL :: abs89 REAL :: temp14 REAL :: temp11b1 REAL :: abs78b REAL :: y35b REAL :: temp31b65 REAL :: abs41b REAL :: temp43b6 REAL :: max54b REAL :: abs51 REAL :: abs88 REAL :: temp13 REAL :: temp11b0 REAL :: min28b REAL :: abs86b REAL :: temp31b64 REAL :: y43b REAL :: temp43b5 INTEGER :: min29 REAL :: abs50 REAL :: abs87 INTEGER :: temp12 REAL :: min36b REAL :: temp31b63 REAL :: y88b REAL :: abs94b REAL :: temp43b4 REAL :: y51b REAL :: min28 REAL :: abs86 REAL :: temp11 REAL :: y3b REAL :: temp31b62 REAL :: y96b REAL :: temp43b3 REAL :: min27 REAL :: abs85 REAL :: temp10 REAL :: min52b REAL :: temp31b61 REAL :: temp43b2 REAL :: min26 REAL :: abs84 REAL :: temp15b REAL :: abs28b REAL :: temp31b60 REAL :: min60b REAL :: temp43b1 REAL :: temp46 REAL :: abs101b REAL :: min25 REAL :: y19 REAL :: abs83 REAL :: max12b REAL :: temp23b REAL :: min7b REAL :: abs36b REAL :: temp43b0 REAL :: max49b REAL :: temp45 REAL :: min24 REAL :: y18 REAL :: abs82 REAL :: max20b REAL :: temp19b6 REAL :: temp31b REAL :: y38b REAL :: abs44b INTEGER :: temp44 INTEGER :: min23 REAL :: y17 REAL :: abs81 REAL :: temp19b5 REAL :: abs52b REAL :: abs89b REAL :: y46b REAL :: temp43 INTEGER :: min22 REAL :: y16 REAL :: min59 REAL :: abs80 REAL :: temp19b4 REAL :: y54b REAL :: abs60b REAL :: temp42 REAL :: abs97b REAL :: y15 REAL :: min21 REAL :: min58 REAL :: y62b REAL :: temp19b3 REAL :: min47b REAL :: temp31b9 REAL :: y6b REAL :: min10b REAL :: temp41 REAL :: y99b REAL :: max1b REAL :: y14 REAL :: min20 REAL :: min57 REAL :: y70b REAL :: temp19b2 REAL :: temp31b8 REAL :: min55b INTEGER :: temp40 REAL :: y13 REAL :: min56 REAL :: temp19b1 REAL :: temp31b7 REAL :: min63b REAL :: y12 REAL :: min55 REAL :: y49 REAL :: max15b REAL :: temp19b0 REAL :: temp31b6 REAL :: abs39b REAL :: min71b REAL :: y11 INTEGER :: min54 REAL :: y48 REAL :: max23b REAL :: temp31b5 REAL :: abs3b REAL :: abs10b REAL :: abs47b REAL :: y10 INTEGER :: min53 REAL :: y47 REAL :: y12b REAL :: max31b REAL :: temp31b4 REAL :: abs55b REAL :: y49b REAL :: min52 REAL :: y46 REAL :: abs63b REAL :: y20b REAL :: temp31b3 REAL :: y57b REAL :: min51 REAL :: y45 REAL :: abs19 REAL :: tempb REAL :: y65b REAL :: abs71b REAL :: temp31b2 REAL :: max4b REAL :: y9b REAL :: min13b INTEGER :: min50 REAL :: y44 REAL :: abs18 REAL :: min21b REAL :: y73b REAL :: temp31b1 REAL :: min58b REAL :: y101b REAL :: y43 REAL :: abs17 REAL :: y81b REAL :: temp31b0 REAL :: min66b REAL :: y42 REAL :: abs16 REAL :: y79 REAL :: max29 REAL :: max18b REAL :: temp31b29 REAL :: min74b REAL :: y41 REAL :: abs15 REAL :: y78 REAL :: max28 REAL :: abs13b REAL :: max26b REAL :: temp31b28 REAL :: abs6b REAL :: y40 REAL :: abs14 REAL :: y77 REAL :: max27 REAL :: y15b REAL :: abs21b REAL :: max34b REAL :: temp31b27 REAL :: abs58b REAL :: abs13 REAL :: y76 REAL :: max26 REAL :: abs66b REAL :: y23b REAL :: temp31b26 REAL :: max42b REAL :: abs12 REAL :: y75 REAL :: max25 REAL :: abs49 REAL :: y68b REAL :: abs74b REAL :: y31b REAL :: temp31b25 REAL :: max7b REAL :: max50b REAL :: abs11 REAL :: y74 REAL :: max24 REAL :: abs48 REAL :: y102 REAL :: min24b REAL :: y76b REAL :: abs82b REAL :: temp31b24 REAL :: abs10 REAL :: y73 REAL :: max23 REAL :: abs47 REAL :: y101 REAL :: min32b REAL :: y84b REAL :: temp31b23 REAL :: abs90b REAL :: min69b REAL :: y72 REAL :: max22 REAL :: abs46 REAL :: y100 REAL :: temp31b22 REAL :: temp31b59 REAL :: y92b REAL :: y71 REAL :: max21 REAL :: abs45 REAL :: abs16b REAL :: max29b REAL :: temp31b21 REAL :: abs9b REAL :: temp31b58 REAL :: temp39b3 REAL :: y70 REAL :: max20 REAL :: abs44 REAL :: temp11b REAL :: y18b REAL :: abs24b REAL :: temp31b20 REAL :: temp31b57 REAL :: max37b REAL :: temp39b2 REAL :: abs43 REAL :: abs69b REAL :: y26b REAL :: abs32b REAL :: min3b REAL :: temp31b56 REAL :: temp39b1 REAL :: max45b REAL :: abs42 REAL :: abs79 REAL :: min19b REAL :: abs77b REAL :: y34b REAL :: temp31b55 REAL :: abs40b REAL :: temp39b0 REAL :: max53b REAL :: abs41 REAL :: abs78 REAL :: max54 REAL :: temp3b6 REAL :: min27b REAL :: y79b REAL :: abs85b REAL :: temp31b54 REAL :: y42b REAL :: min19 REAL :: abs40 REAL :: abs77 REAL :: max53 REAL :: temp3b5 REAL :: temp31b53 REAL :: y87b REAL :: abs93b REAL :: temp39 REAL :: y50b REAL :: min18 REAL :: max52 REAL :: abs76 REAL :: temp3b4 REAL :: min43b REAL :: y2b REAL :: temp31b52 REAL :: temp38 REAL :: y95b REAL :: min17 REAL :: max51 REAL :: abs75 REAL :: temp3b3 REAL :: abs19b REAL :: temp27b9 REAL :: min51b REAL :: temp31b51 REAL :: temp37 INTEGER :: min16 REAL :: abs9 REAL :: max50 REAL :: abs74 REAL :: temp3b2 REAL :: abs27b REAL :: temp27b8 REAL :: temp31b50 INTEGER :: temp36 REAL :: abs100b INTEGER :: min15 REAL :: abs8 REAL :: abs73 REAL :: temp3b1 REAL :: y29b REAL :: temp27b7 REAL :: min6b REAL :: max11b REAL :: abs35b REAL :: temp35 REAL :: max48b REAL :: min14 REAL :: abs7 REAL :: abs72 REAL :: temp3b0 REAL :: temp27b6 REAL :: y37b REAL :: temp34 REAL :: abs43b REAL :: min13 REAL :: abs6 REAL :: abs71 REAL :: temp27b5 REAL :: abs88b REAL :: temp33 REAL :: y45b REAL :: abs51b REAL :: min12 INTEGER :: min49 REAL :: abs5 REAL :: abs70 REAL :: min38b REAL :: temp27b4 REAL :: y53b INTEGER :: temp32 REAL :: abs96b REAL :: min11 REAL :: min48 REAL :: abs4 REAL :: temp27b3 REAL :: min46b REAL :: y5b REAL :: y61b REAL :: temp31 REAL :: y98b REAL :: min10 REAL :: min47 REAL :: abs3 REAL :: temp27b2 REAL :: temp30 REAL :: temp31b81 REAL :: min46 REAL :: abs2 REAL :: temp27b1 REAL :: temp31b80 REAL :: min62b INTEGER :: min45 REAL :: y39 REAL :: abs1 REAL :: max14b REAL :: temp27b0 REAL :: abs38b REAL :: min70b INTEGER :: min44 REAL :: y38 REAL :: max22b REAL :: abs2b REAL :: abs46b REAL :: min43 REAL :: y37 REAL :: y11b REAL :: max30b REAL :: abs54b REAL :: y48b REAL :: min42 REAL :: y36 REAL :: abs62b REAL :: y56b REAL :: abs99b REAL :: min41 REAL :: y35 REAL :: y64b REAL :: abs70b REAL :: max3b REAL :: y8b REAL :: min12b INTEGER :: min40 REAL :: y34 REAL :: min20b REAL :: y72b REAL :: min57b REAL :: y100b REAL :: y33 REAL :: max9 REAL :: min76 REAL :: y80b REAL :: min65b REAL :: y32 REAL :: max8 REAL :: y69 REAL :: max19 REAL :: min75 REAL :: max17b REAL :: temp31b19 REAL :: temp43b16 REAL :: y31 REAL :: max7 REAL :: y68 REAL :: max18 REAL :: min74 REAL :: abs12b REAL :: temp15b5 REAL :: max25b REAL :: temp31b18 REAL :: abs5b REAL :: temp43b15 REAL :: abs49b REAL :: y30 INTEGER :: min73 REAL :: max6 REAL :: y67 REAL :: max17 REAL :: y14b REAL :: temp15b4 REAL :: abs20b REAL :: max33b REAL :: temp31b17 REAL :: abs57b REAL :: temp43b14 REAL :: temp47b9 INTEGER :: min72 REAL :: max5 REAL :: y66 REAL :: max16 REAL :: abs65b REAL :: temp15b3 REAL :: y22b REAL :: temp31b16 REAL :: y59b REAL :: max41b REAL :: temp43b13 REAL :: temp47b8 REAL :: y9 REAL :: min71 REAL :: max4 REAL :: y65 REAL :: max15 REAL :: abs39 REAL :: temp REAL :: y67b REAL :: temp15b2 REAL :: abs73b REAL :: y30b REAL :: temp31b15 REAL :: max6b REAL :: temp43b12 REAL :: temp47b7 REAL :: y8 REAL :: min70 REAL :: max3 REAL :: y64 REAL :: max14 REAL :: abs38 REAL :: temp15b1 REAL :: y75b REAL :: abs81b REAL :: temp31b14 REAL :: temp43b11 REAL :: temp47b6 REAL :: y7 REAL :: max2 REAL :: y63 REAL :: max13 REAL :: abs37 REAL :: temp15b0 REAL :: min31b REAL :: y83b REAL :: temp31b13 REAL :: temp43b10 REAL :: min68b REAL :: temp47b5 REAL :: y6 REAL :: max1 REAL :: y62 REAL :: max12 REAL :: abs36 REAL :: y99 REAL :: max49 REAL :: temp9 REAL :: temp31b12 REAL :: temp31b49 REAL :: y91b REAL :: temp47b4 REAL :: min76b REAL :: y5 REAL :: y61 REAL :: max11 REAL :: abs35 REAL :: y98 REAL :: max48 REAL :: abs15b INTEGER :: temp8 REAL :: max28b REAL :: temp31b11 REAL :: abs8b REAL :: temp31b48 REAL :: temp39b REAL :: temp47b3 REAL :: y4 REAL :: y60 REAL :: max10 REAL :: abs34 REAL :: y97 REAL :: max47 REAL :: temp7 REAL :: y17b REAL :: abs23b REAL :: temp31b10 REAL :: temp31b47 REAL :: max36b REAL :: temp47b REAL :: temp47b2 REAL :: y3 REAL :: abs33 REAL :: y96 REAL :: max46 REAL :: temp6 REAL :: abs68b REAL :: y25b REAL :: abs31b REAL :: temp31b46 REAL :: max44b REAL :: temp47b1 REAL :: y2 REAL :: abs32 REAL :: y95 REAL :: max45 REAL :: abs69 REAL :: abs102 REAL :: min18b REAL :: temp5 REAL :: abs76b REAL :: y33b REAL :: max9b REAL :: temp31b45 REAL :: temp47b0 REAL :: max52b REAL :: y1 REAL :: abs31 REAL :: y94 REAL :: max44 REAL :: abs68 REAL :: abs101 INTEGER :: temp4 REAL :: min26b REAL :: y78b REAL :: abs84b REAL :: temp31b44 REAL :: y41b ! set order for the advection schemes ! write(6,*) ' in pd advection routine ' ! Empty arrays just in case: IF (config_flags%polar) THEN fqx(:, :, :) = 0. fqy(:, :, :) = 0. fqz(:, :, :) = 0. fqxl(:, :, :) = 0. fqyl(:, :, :) = 0. fqzl(:, :, :) = 0. END IF IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. ! begin with horizontal flux divergence ! here is the choice of flux operators IF (horz_order .EQ. 6) THEN IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 4) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its - 1 IF (ite .GT. ide - 1) THEN min1 = ide - 1 ELSE min1 = ite END IF i_end = min1 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min2 = jde - 1 ELSE min2 = jte END IF j_end = min2 + 1 j_start_f = j_start j_end_f = j_end + 1 !-- modify loop bounds if open or specified ! IF(degrade_xs) i_start = MAX(its-1,ids-1) ! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN i_start = ids ELSE i_start = its - 1 END IF END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite + 1 END IF END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts - 1 END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte + 1 END IF j_end_f = jde - 3 END IF ad_from26 = j_start ! compute fluxes, 6th order j_loop_y_flux_6:DO j=ad_from26,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from21 = i_start DO i=ad_from21,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs1 = cr CALL PUSHCONTROL1B(0) ELSE abs1 = -cr CALL PUSHCONTROL1B(1) END IF y1 = cr + abs1 IF (1.0 .GT. y1) THEN CALL PUSHREAL8(min3) min3 = y1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min3) min3 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs52 = cr CALL PUSHCONTROL1B(0) ELSE abs52 = -cr CALL PUSHCONTROL1B(1) END IF y52 = cr - abs52 IF (-1.0 .LT. y52) THEN CALL PUSHREAL8(max2) max2 = y52 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max2) max2 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+& & 0.5*max2*field_old(i, k, j)) fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)& & )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field& & (i, k, j+2)+field(i, k, j-3))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from21) END DO CALL PUSHCONTROL3B(5) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from22 = i_start DO i=ad_from22,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs2 = cr CALL PUSHCONTROL1B(0) ELSE abs2 = -cr CALL PUSHCONTROL1B(1) END IF y2 = cr + abs2 IF (1.0 .GT. y2) THEN CALL PUSHREAL8(min4) min4 = y2 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min4) min4 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs53 = cr CALL PUSHCONTROL1B(0) ELSE abs53 = -cr CALL PUSHCONTROL1B(1) END IF y53 = cr - abs53 IF (-1.0 .LT. y53) THEN CALL PUSHREAL8(max3) max3 = y53 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max3) max3 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+& & 0.5*max3*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from22) END DO CALL PUSHCONTROL3B(4) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from23 = i_start DO i=ad_from23,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs3 = cr CALL PUSHCONTROL1B(0) ELSE abs3 = -cr CALL PUSHCONTROL1B(1) END IF y3 = cr + abs3 IF (1.0 .GT. y3) THEN CALL PUSHREAL8(min5) min5 = y3 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min5) min5 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs54 = cr CALL PUSHCONTROL1B(0) ELSE abs54 = -cr CALL PUSHCONTROL1B(1) END IF y54 = cr - abs54 IF (-1.0 .LT. y54) THEN CALL PUSHREAL8(max4) max4 = y54 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max4) max4 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+& & 0.5*max4*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))& & -1./12.*(field(i, k, j+1)+field(i, k, j-2))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from24 = i_start DO i=ad_from24,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs4 = cr CALL PUSHCONTROL1B(0) ELSE abs4 = -cr CALL PUSHCONTROL1B(1) END IF y4 = cr + abs4 IF (1.0 .GT. y4) THEN CALL PUSHREAL8(min6) min6 = y4 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min6) min6 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs55 = cr CALL PUSHCONTROL1B(0) ELSE abs55 = -cr CALL PUSHCONTROL1B(1) END IF y55 = cr - abs55 IF (-1.0 .LT. y55) THEN CALL PUSHREAL8(max5) max5 = y55 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max5) max5 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+& & 0.5*max5*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from24) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 2) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from25 = i_start DO i=ad_from25,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs5 = cr CALL PUSHCONTROL1B(0) ELSE abs5 = -cr CALL PUSHCONTROL1B(1) END IF y5 = cr + abs5 IF (1.0 .GT. y5) THEN CALL PUSHREAL8(min7) min7 = y5 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min7) min7 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs56 = cr CALL PUSHCONTROL1B(0) ELSE abs56 = -cr CALL PUSHCONTROL1B(1) END IF y56 = cr - abs56 IF (-1.0 .LT. y56) THEN CALL PUSHREAL8(max6) max6 = y56 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max6) max6 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+& & 0.5*max6*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))& & -1./12.*(field(i, k, j+1)+field(i, k, j-2))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from25) END DO CALL PUSHCONTROL3B(1) ELSE CALL PUSHCONTROL3B(0) END IF END DO j_loop_y_flux_6 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from26) ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min8 = ide - 1 ELSE min8 = ite END IF i_end = min8 + 1 i_start_f = i_start i_end_f = i_end + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min9 = jde - 1 ELSE min9 = jte END IF j_end = min9 + 1 !-- modify loop bounds for open and specified b.c ! IF(degrade_ys) j_start = MAX(jts-1,jds+1) ! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN j_start = jds ELSE j_start = jts - 1 END IF END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte + 1 END IF END IF IF (degrade_xs) THEN IF (ids + 1 .LT. its - 1) THEN i_start = its - 1 ELSE i_start = ids + 1 END IF i_start_f = ids + 3 END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite + 1) THEN i_end = ite + 1 ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from28 = j_start ! compute fluxes DO j=ad_from28,j_end ! 5th order flux DO k=kts,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs6 = cr CALL PUSHCONTROL1B(0) ELSE abs6 = -cr CALL PUSHCONTROL1B(1) END IF y6 = cr + abs6 IF (1.0 .GT. y6) THEN CALL PUSHREAL8(min10) min10 = y6 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min10) min10 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs57 = cr CALL PUSHCONTROL1B(0) ELSE abs57 = -cr CALL PUSHCONTROL1B(1) END IF y57 = cr - abs57 IF (-1.0 .LT. y57) THEN CALL PUSHREAL8(max7) max7 = y57 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max7) max7 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5& & *max7*field_old(i, k, j)) fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-& & 2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2& & , k, j)+field(i-3, k, j))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from27 = i_start DO i=ad_from27,i_start_f-1 IF (i .EQ. ids + 1) THEN ! second order DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j)/mu cr = vel*dt/dx IF (cr .GE. 0.) THEN abs7 = cr CALL PUSHCONTROL1B(0) ELSE abs7 = -cr CALL PUSHCONTROL1B(1) END IF y7 = cr + abs7 IF (1.0 .GT. y7) THEN CALL PUSHREAL8(min11) min11 = y7 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min11) min11 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs58 = cr CALL PUSHCONTROL1B(0) ELSE abs58 = -cr CALL PUSHCONTROL1B(1) END IF y58 = cr - abs58 IF (-1.0 .LT. y58) THEN CALL PUSHREAL8(max8) max8 = y58 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max8) max8 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)& & +0.5*max8*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, & & k, j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN ! fourth order DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs8 = cr CALL PUSHCONTROL1B(0) ELSE abs8 = -cr CALL PUSHCONTROL1B(1) END IF y8 = cr + abs8 IF (1.0 .GT. y8) THEN CALL PUSHREAL8(min12) min12 = y8 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min12) min12 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs59 = cr CALL PUSHCONTROL1B(0) ELSE abs59 = -cr CALL PUSHCONTROL1B(1) END IF y59 = cr - abs59 IF (-1.0 .LT. y59) THEN CALL PUSHREAL8(max9) max9 = y59 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max9) max9 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)& & +0.5*max9*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j& & ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from27) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN ! second order flux next to the boundary DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs9 = cr CALL PUSHCONTROL1B(0) ELSE abs9 = -cr CALL PUSHCONTROL1B(1) END IF y9 = cr + abs9 IF (1.0 .GT. y9) THEN CALL PUSHREAL8(min13) min13 = y9 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min13) min13 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs60 = cr CALL PUSHCONTROL1B(0) ELSE abs60 = -cr CALL PUSHCONTROL1B(1) END IF y60 = cr - abs60 IF (-1.0 .LT. y60) THEN CALL PUSHREAL8(max10) max10 = y60 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max10) max10 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)& & +0.5*max10*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, & & k, j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN ! fourth order flux one in from the boundary DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs10 = cr CALL PUSHCONTROL1B(0) ELSE abs10 = -cr CALL PUSHCONTROL1B(1) END IF y10 = cr + abs10 IF (1.0 .GT. y10) THEN CALL PUSHREAL8(min14) min14 = y10 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min14) min14 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs61 = cr CALL PUSHCONTROL1B(0) ELSE abs61 = -cr CALL PUSHCONTROL1B(1) END IF y61 = cr - abs61 IF (-1.0 .LT. y61) THEN CALL PUSHREAL8(max11) max11 = y61 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max11) max11 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)& & +0.5*max11*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j& & ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from28) CALL PUSHCONTROL3B(5) ELSE IF (horz_order .EQ. 5) THEN ! enddo for outer J loop !--- end of 6th order horizontal flux calculation IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 4) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its - 1 IF (ite .GT. ide - 1) THEN min15 = ide - 1 ELSE min15 = ite END IF i_end = min15 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min16 = jde - 1 ELSE min16 = jte END IF j_end = min16 + 1 j_start_f = j_start j_end_f = j_end + 1 !-- modify loop bounds if open or specified ! IF(degrade_xs) i_start = MAX(its-1,ids-1) ! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN i_start = ids ELSE i_start = its - 1 END IF END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite + 1 END IF END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts - 1 END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte + 1 END IF j_end_f = jde - 3 END IF ad_from4 = j_start ! compute fluxes, 5th order j_loop_y_flux_5:DO j=ad_from4,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from = i_start DO i=ad_from,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs11 = cr CALL PUSHCONTROL1B(0) ELSE abs11 = -cr CALL PUSHCONTROL1B(1) END IF y11 = cr + abs11 IF (1.0 .GT. y11) THEN CALL PUSHREAL8(min17) min17 = y11 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min17) min17 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs62 = cr CALL PUSHCONTROL1B(0) ELSE abs62 = -cr CALL PUSHCONTROL1B(1) END IF y62 = cr - abs62 IF (-1.0 .LT. y62) THEN CALL PUSHREAL8(max12) max12 = y62 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max12) max12 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min17*field_old(i, k, j-1)+& & 0.5*max12*field_old(i, k, j)) fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)& & )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field& & (i, k, j+2)+field(i, k, j-3))-SIGN(1, time_step)*SIGN(1., & & vel)*(1./60.)*(field(i, k, j+2)-field(i, k, j-3)-5.*(field& & (i, k, j+1)-field(i, k, j-2))+10.*(field(i, k, j)-field(i& & , k, j-1)))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(5) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start DO i=ad_from0,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs12 = cr CALL PUSHCONTROL1B(0) ELSE abs12 = -cr CALL PUSHCONTROL1B(1) END IF y12 = cr + abs12 IF (1.0 .GT. y12) THEN CALL PUSHREAL8(min18) min18 = y12 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min18) min18 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs63 = cr CALL PUSHCONTROL1B(0) ELSE abs63 = -cr CALL PUSHCONTROL1B(1) END IF y63 = cr - abs63 IF (-1.0 .LT. y63) THEN CALL PUSHREAL8(max13) max13 = y63 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max13) max13 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min18*field_old(i, k, j-1)+& & 0.5*max13*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(4) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start DO i=ad_from1,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs13 = cr CALL PUSHCONTROL1B(0) ELSE abs13 = -cr CALL PUSHCONTROL1B(1) END IF y13 = cr + abs13 IF (1.0 .GT. y13) THEN CALL PUSHREAL8(min19) min19 = y13 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min19) min19 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs64 = cr CALL PUSHCONTROL1B(0) ELSE abs64 = -cr CALL PUSHCONTROL1B(1) END IF y64 = cr - abs64 IF (-1.0 .LT. y64) THEN CALL PUSHREAL8(max14) max14 = y64 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max14) max14 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min19*field_old(i, k, j-1)+& & 0.5*max14*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))& & -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(& & i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start DO i=ad_from2,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs14 = cr CALL PUSHCONTROL1B(0) ELSE abs14 = -cr CALL PUSHCONTROL1B(1) END IF y14 = cr + abs14 IF (1.0 .GT. y14) THEN CALL PUSHREAL8(min20) min20 = y14 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min20) min20 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs65 = cr CALL PUSHCONTROL1B(0) ELSE abs65 = -cr CALL PUSHCONTROL1B(1) END IF y65 = cr - abs65 IF (-1.0 .LT. y65) THEN CALL PUSHREAL8(max15) max15 = y65 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max15) max15 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min20*field_old(i, k, j-1)+& & 0.5*max15*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 2) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start DO i=ad_from3,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs15 = cr CALL PUSHCONTROL1B(0) ELSE abs15 = -cr CALL PUSHCONTROL1B(1) END IF y15 = cr + abs15 IF (1.0 .GT. y15) THEN CALL PUSHREAL8(min21) min21 = y15 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min21) min21 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs66 = cr CALL PUSHCONTROL1B(0) ELSE abs66 = -cr CALL PUSHCONTROL1B(1) END IF y66 = cr - abs66 IF (-1.0 .LT. y66) THEN CALL PUSHREAL8(max16) max16 = y66 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max16) max16 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min21*field_old(i, k, j-1)+& & 0.5*max16*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))& & -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(& & i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(1) ELSE CALL PUSHCONTROL3B(0) END IF END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from4) ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min22 = ide - 1 ELSE min22 = ite END IF i_end = min22 + 1 i_start_f = i_start i_end_f = i_end + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min23 = jde - 1 ELSE min23 = jte END IF j_end = min23 + 1 !-- modify loop bounds for open and specified b.c ! IF(degrade_ys) j_start = MAX(jts-1,jds+1) ! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN j_start = jds ELSE j_start = jts - 1 END IF END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte + 1 END IF END IF IF (degrade_xs) THEN IF (ids + 1 .LT. its - 1) THEN i_start = its - 1 ELSE i_start = ids + 1 END IF i_start_f = ids + 3 END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite + 1) THEN i_end = ite + 1 ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from6 = j_start ! compute fluxes DO j=ad_from6,j_end ! 5th order flux DO k=kts,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs16 = cr CALL PUSHCONTROL1B(0) ELSE abs16 = -cr CALL PUSHCONTROL1B(1) END IF y16 = cr + abs16 IF (1.0 .GT. y16) THEN CALL PUSHREAL8(min24) min24 = y16 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min24) min24 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs67 = cr CALL PUSHCONTROL1B(0) ELSE abs67 = -cr CALL PUSHCONTROL1B(1) END IF y67 = cr - abs67 IF (-1.0 .LT. y67) THEN CALL PUSHREAL8(max17) max17 = y67 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max17) max17 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min24*field_old(i-1, k, j)+0.5& & *max17*field_old(i, k, j)) fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-& & 2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2& & , k, j)+field(i-3, k, j))-SIGN(1, time_step)*SIGN(1., vel)*(& & 1./60.)*(field(i+2, k, j)-field(i-3, k, j)-5.*(field(i+1, k& & , j)-field(i-2, k, j))+10.*(field(i, k, j)-field(i-1, k, j))& & )) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from5 = i_start DO i=ad_from5,i_start_f-1 IF (i .EQ. ids + 1) THEN ! second order DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j)/mu cr = vel*dt/dx IF (cr .GE. 0.) THEN abs17 = cr CALL PUSHCONTROL1B(0) ELSE abs17 = -cr CALL PUSHCONTROL1B(1) END IF y17 = cr + abs17 IF (1.0 .GT. y17) THEN CALL PUSHREAL8(min25) min25 = y17 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min25) min25 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs68 = cr CALL PUSHCONTROL1B(0) ELSE abs68 = -cr CALL PUSHCONTROL1B(1) END IF y68 = cr - abs68 IF (-1.0 .LT. y68) THEN CALL PUSHREAL8(max18) max18 = y68 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max18) max18 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min25*field_old(i-1, k, j)& & +0.5*max18*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, & & k, j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN ! third order DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs18 = cr CALL PUSHCONTROL1B(0) ELSE abs18 = -cr CALL PUSHCONTROL1B(1) END IF y18 = cr + abs18 IF (1.0 .GT. y18) THEN CALL PUSHREAL8(min26) min26 = y18 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min26) min26 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs69 = cr CALL PUSHCONTROL1B(0) ELSE abs69 = -cr CALL PUSHCONTROL1B(1) END IF y69 = cr - abs69 IF (-1.0 .LT. y69) THEN CALL PUSHREAL8(max19) max19 = y69 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max19) max19 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min26*field_old(i-1, k, j)& & +0.5*max19*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j& & ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-& & field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from5) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN ! second order flux next to the boundary DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs19 = cr CALL PUSHCONTROL1B(0) ELSE abs19 = -cr CALL PUSHCONTROL1B(1) END IF y19 = cr + abs19 IF (1.0 .GT. y19) THEN CALL PUSHREAL8(min27) min27 = y19 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min27) min27 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs70 = cr CALL PUSHCONTROL1B(0) ELSE abs70 = -cr CALL PUSHCONTROL1B(1) END IF y70 = cr - abs70 IF (-1.0 .LT. y70) THEN CALL PUSHREAL8(max20) max20 = y70 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max20) max20 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min27*field_old(i-1, k, j)& & +0.5*max20*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, & & k, j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN ! third order flux one in from the boundary DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs20 = cr CALL PUSHCONTROL1B(0) ELSE abs20 = -cr CALL PUSHCONTROL1B(1) END IF y20 = cr + abs20 IF (1.0 .GT. y20) THEN CALL PUSHREAL8(min28) min28 = y20 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min28) min28 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs71 = cr CALL PUSHCONTROL1B(0) ELSE abs71 = -cr CALL PUSHCONTROL1B(1) END IF y71 = cr - abs71 IF (-1.0 .LT. y71) THEN CALL PUSHREAL8(max21) max21 = y71 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max21) max21 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min28*field_old(i-1, k, j)& & +0.5*max21*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j& & ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-& & field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from6) CALL PUSHCONTROL3B(4) ELSE IF (horz_order .EQ. 4) THEN ! enddo for outer J loop !--- end of 5th order horizontal flux calculation IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 1) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 1) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 2) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its - 1 IF (ite .GT. ide - 1) THEN min29 = ide - 1 ELSE min29 = ite END IF i_end = min29 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min30 = jde - 1 ELSE min30 = jte END IF j_end = min30 + 1 j_start_f = j_start j_end_f = j_end + 1 !-- modify loop bounds if open or specified IF (degrade_xs) i_start = its IF (degrade_xe) THEN IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF END IF IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 2 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 2 END IF ad_from10 = j_start ! compute fluxes, 4th order j_loop_y_flux_4:DO j=ad_from10,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from7 = i_start DO i=ad_from7,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs21 = cr CALL PUSHCONTROL1B(0) ELSE abs21 = -cr CALL PUSHCONTROL1B(1) END IF y21 = cr + abs21 IF (1.0 .GT. y21) THEN CALL PUSHREAL8(min31) min31 = y21 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min31) min31 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs72 = cr CALL PUSHCONTROL1B(0) ELSE abs72 = -cr CALL PUSHCONTROL1B(1) END IF y72 = cr - abs72 IF (-1.0 .LT. y72) THEN CALL PUSHREAL8(max22) max22 = y72 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max22) max22 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min31*field_old(i, k, j-1)+& & 0.5*max22*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))& & -1./12.*(field(i, k, j+1)+field(i, k, j-2))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from7) END DO CALL PUSHCONTROL2B(3) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from8 = i_start DO i=ad_from8,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs22 = cr CALL PUSHCONTROL1B(0) ELSE abs22 = -cr CALL PUSHCONTROL1B(1) END IF y22 = cr + abs22 IF (1.0 .GT. y22) THEN CALL PUSHREAL8(min32) min32 = y22 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min32) min32 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs73 = cr CALL PUSHCONTROL1B(0) ELSE abs73 = -cr CALL PUSHCONTROL1B(1) END IF y73 = cr - abs73 IF (-1.0 .LT. y73) THEN CALL PUSHREAL8(max23) max23 = y73 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max23) max23 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min32*field_old(i, k, j-1)+& & 0.5*max23*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from8) END DO CALL PUSHCONTROL2B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from9 = i_start DO i=ad_from9,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs23 = cr CALL PUSHCONTROL1B(0) ELSE abs23 = -cr CALL PUSHCONTROL1B(1) END IF y23 = cr + abs23 IF (1.0 .GT. y23) THEN CALL PUSHREAL8(min33) min33 = y23 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min33) min33 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs74 = cr CALL PUSHCONTROL1B(0) ELSE abs74 = -cr CALL PUSHCONTROL1B(1) END IF y74 = cr - abs74 IF (-1.0 .LT. y74) THEN CALL PUSHREAL8(max24) max24 = y74 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max24) max24 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min33*field_old(i, k, j-1)+& & 0.5*max24*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO CALL PUSHCONTROL2B(1) ELSE CALL PUSHCONTROL2B(0) END IF END DO j_loop_y_flux_4 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from10) ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min34 = ide - 1 ELSE min34 = ite END IF i_end = min34 + 1 i_start_f = i_start i_end_f = i_end + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min35 = jde - 1 ELSE min35 = jte END IF j_end = min35 + 1 !-- modify loop bounds for open and specified b.c IF (degrade_ys) j_start = jts IF (degrade_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF i_start_f = i_start + 1 END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 2 END IF ad_from11 = j_start ! compute fluxes DO j=ad_from11,j_end ! 4th order flux DO k=kts,ktf CALL PUSHINTEGER4(i) DO i=i_start_f,i_end_f CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs24 = cr CALL PUSHCONTROL1B(0) ELSE abs24 = -cr CALL PUSHCONTROL1B(1) END IF y24 = cr + abs24 IF (1.0 .GT. y24) THEN CALL PUSHREAL8(min36) min36 = y24 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min36) min36 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs75 = cr CALL PUSHCONTROL1B(0) ELSE abs75 = -cr CALL PUSHCONTROL1B(1) END IF y75 = cr - abs75 IF (-1.0 .LT. y75) THEN CALL PUSHREAL8(max25) max25 = y75 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max25) max25 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min36*field_old(i-1, k, j)+0.5& & *max25*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-& & 1./12.*(field(i+1, k, j)+field(i-2, k, j))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN IF (i_start .EQ. ids + 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ids + 1 DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j)/mu cr = vel*dt/dx IF (cr .GE. 0.) THEN abs25 = cr CALL PUSHCONTROL1B(0) ELSE abs25 = -cr CALL PUSHCONTROL1B(1) END IF y25 = cr + abs25 IF (1.0 .GT. y25) THEN CALL PUSHREAL8(min37) min37 = y25 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min37) min37 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs76 = cr CALL PUSHCONTROL1B(0) ELSE abs76 = -cr CALL PUSHCONTROL1B(1) END IF y76 = cr - abs76 IF (-1.0 .LT. y76) THEN CALL PUSHREAL8(max26) max26 = y76 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max26) max26 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min37*field_old(i-1, k, j)+& & 0.5*max26*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k& & , j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL2B(0) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(2) END IF IF (degrade_xe) THEN IF (i_end .EQ. ide - 2) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ide - 1 DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs26 = cr CALL PUSHCONTROL1B(0) ELSE abs26 = -cr CALL PUSHCONTROL1B(1) END IF y26 = cr + abs26 IF (1.0 .GT. y26) THEN CALL PUSHREAL8(min38) min38 = y26 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min38) min38 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs77 = cr CALL PUSHCONTROL1B(0) ELSE abs77 = -cr CALL PUSHCONTROL1B(1) END IF y77 = cr - abs77 IF (-1.0 .LT. y77) THEN CALL PUSHREAL8(max27) max27 = y77 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max27) max27 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min38*field_old(i-1, k, j)+& & 0.5*max27*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k& & , j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(0) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from11) CALL PUSHCONTROL3B(3) ELSE IF (horz_order .EQ. 3) THEN ! enddo for outer J loop !--- end of 4th order horizontal flux calculation IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 2) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 1) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 2) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 1) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its - 1 IF (ite .GT. ide - 1) THEN min39 = ide - 1 ELSE min39 = ite END IF i_end = min39 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min40 = jde - 1 ELSE min40 = jte END IF j_end = min40 + 1 j_start_f = j_start j_end_f = j_end + 1 !-- modify loop bounds if open or specified IF (degrade_xs) i_start = its IF (degrade_xe) THEN IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF END IF IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 2 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 2 END IF ad_from15 = j_start ! compute fluxes, 3rd order j_loop_y_flux_3:DO j=ad_from15,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from12 = i_start DO i=ad_from12,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs27 = cr CALL PUSHCONTROL1B(0) ELSE abs27 = -cr CALL PUSHCONTROL1B(1) END IF y27 = cr + abs27 IF (1.0 .GT. y27) THEN CALL PUSHREAL8(min41) min41 = y27 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min41) min41 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs78 = cr CALL PUSHCONTROL1B(0) ELSE abs78 = -cr CALL PUSHCONTROL1B(1) END IF y78 = cr - abs78 IF (-1.0 .LT. y78) THEN CALL PUSHREAL8(max28) max28 = y78 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max28) max28 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min41*field_old(i, k, j-1)+& & 0.5*max28*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))& & -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(& & i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) END DO CALL PUSHCONTROL2B(3) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from13 = i_start DO i=ad_from13,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs28 = cr CALL PUSHCONTROL1B(0) ELSE abs28 = -cr CALL PUSHCONTROL1B(1) END IF y28 = cr + abs28 IF (1.0 .GT. y28) THEN CALL PUSHREAL8(min42) min42 = y28 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min42) min42 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs79 = cr CALL PUSHCONTROL1B(0) ELSE abs79 = -cr CALL PUSHCONTROL1B(1) END IF y79 = cr - abs79 IF (-1.0 .LT. y79) THEN CALL PUSHREAL8(max29) max29 = y79 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max29) max29 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min42*field_old(i, k, j-1)+& & 0.5*max29*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) END DO CALL PUSHCONTROL2B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from14 = i_start DO i=ad_from14,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs29 = cr CALL PUSHCONTROL1B(0) ELSE abs29 = -cr CALL PUSHCONTROL1B(1) END IF y29 = cr + abs29 IF (1.0 .GT. y29) THEN CALL PUSHREAL8(min43) min43 = y29 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min43) min43 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs80 = cr CALL PUSHCONTROL1B(0) ELSE abs80 = -cr CALL PUSHCONTROL1B(1) END IF y80 = cr - abs80 IF (-1.0 .LT. y80) THEN CALL PUSHREAL8(max30) max30 = y80 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max30) max30 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min43*field_old(i, k, j-1)+& & 0.5*max30*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j& & -1)) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO CALL PUSHCONTROL2B(1) ELSE CALL PUSHCONTROL2B(0) END IF END DO j_loop_y_flux_3 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from15) ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min44 = ide - 1 ELSE min44 = ite END IF i_end = min44 + 1 i_start_f = i_start i_end_f = i_end + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min45 = jde - 1 ELSE min45 = jte END IF j_end = min45 + 1 !-- modify loop bounds for open and specified b.c IF (degrade_ys) j_start = jts IF (degrade_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF i_start_f = i_start + 1 END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 2 END IF ad_from16 = j_start ! compute fluxes DO j=ad_from16,j_end ! 4th order flux DO k=kts,ktf CALL PUSHINTEGER4(i) DO i=i_start_f,i_end_f CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs30 = cr CALL PUSHCONTROL1B(0) ELSE abs30 = -cr CALL PUSHCONTROL1B(1) END IF y30 = cr + abs30 IF (1.0 .GT. y30) THEN CALL PUSHREAL8(min46) min46 = y30 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min46) min46 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs81 = cr CALL PUSHCONTROL1B(0) ELSE abs81 = -cr CALL PUSHCONTROL1B(1) END IF y81 = cr - abs81 IF (-1.0 .LT. y81) THEN CALL PUSHREAL8(max31) max31 = y81 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max31) max31 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min46*field_old(i-1, k, j)+0.5& & *max31*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-& & 1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, time_step& & )*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-& & 3.*(field(i, k, j)-field(i-1, k, j)))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN IF (i_start .EQ. ids + 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ids + 1 DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j)/mu cr = vel*dt/dx IF (cr .GE. 0.) THEN abs31 = cr CALL PUSHCONTROL1B(0) ELSE abs31 = -cr CALL PUSHCONTROL1B(1) END IF y31 = cr + abs31 IF (1.0 .GT. y31) THEN CALL PUSHREAL8(min47) min47 = y31 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min47) min47 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs82 = cr CALL PUSHCONTROL1B(0) ELSE abs82 = -cr CALL PUSHCONTROL1B(1) END IF y82 = cr - abs82 IF (-1.0 .LT. y82) THEN CALL PUSHREAL8(max32) max32 = y82 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max32) max32 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min47*field_old(i-1, k, j)+& & 0.5*max32*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k& & , j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL2B(0) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(2) END IF IF (degrade_xe) THEN IF (i_end .EQ. ide - 2) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ide - 1 DO k=kts,ktf CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs32 = cr CALL PUSHCONTROL1B(0) ELSE abs32 = -cr CALL PUSHCONTROL1B(1) END IF y32 = cr + abs32 IF (1.0 .GT. y32) THEN CALL PUSHREAL8(min48) min48 = y32 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min48) min48 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs83 = cr CALL PUSHCONTROL1B(0) ELSE abs83 = -cr CALL PUSHCONTROL1B(1) END IF y83 = cr - abs83 IF (-1.0 .LT. y83) THEN CALL PUSHREAL8(max33) max33 = y83 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max33) max33 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min48*field_old(i-1, k, j)+& & 0.5*max33*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k& & , j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(0) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from16) CALL PUSHCONTROL3B(2) ELSE IF (horz_order .EQ. 2) THEN ! enddo for outer J loop !--- end of 3rd order horizontal flux calculation IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 1) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 1) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 2) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its - 1 IF (ite .GT. ide - 1) THEN min49 = ide - 1 ELSE min49 = ite END IF i_end = min49 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min50 = jde - 1 ELSE min50 = jte END IF j_end = min50 + 1 !-- modify loop bounds if open or specified IF (degrade_xs) i_start = its IF (degrade_xe) THEN IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF END IF IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF END IF ad_from18 = j_start ! compute fluxes, 2nd order, y flux DO j=ad_from18,j_end+1 DO k=kts,ktf ad_from17 = i_start DO i=ad_from17,i_end CALL PUSHREAL8(dy) ! ADT eqn 48 d/dy dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs33 = cr CALL PUSHCONTROL1B(0) ELSE abs33 = -cr CALL PUSHCONTROL1B(1) END IF y33 = cr + abs33 IF (1.0 .GT. y33) THEN CALL PUSHREAL8(min51) min51 = y33 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min51) min51 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs84 = cr CALL PUSHCONTROL1B(0) ELSE abs84 = -cr CALL PUSHCONTROL1B(1) END IF y84 = cr - abs84 IF (-1.0 .LT. y84) THEN CALL PUSHREAL8(max34) max34 = y84 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max34) max34 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min51*field_old(i, k, j-1)+0.5& & *max34*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1& & )) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from17) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from18) ad_from20 = j_start ! next, x flux DO j=ad_from20,j_end DO k=kts,ktf ad_from19 = i_start DO i=ad_from19,i_end+1 CALL PUSHREAL8(dx) ! ADT eqn 48 d/dx dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs34 = cr CALL PUSHCONTROL1B(0) ELSE abs34 = -cr CALL PUSHCONTROL1B(1) END IF y34 = cr + abs34 IF (1.0 .GT. y34) THEN CALL PUSHREAL8(min52) min52 = y34 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min52) min52 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs85 = cr CALL PUSHCONTROL1B(0) ELSE abs85 = -cr CALL PUSHCONTROL1B(1) END IF y85 = cr - abs85 IF (-1.0 .LT. y85) THEN CALL PUSHREAL8(max35) max35 = y85 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max35) max35 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min52*field_old(i-1, k, j)+0.5& & *max35*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, j& & )) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from19) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from20) CALL PUSHCONTROL3B(1) ELSE CALL PUSHCONTROL3B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! compute x (u) conditions for v, w, or scalar IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from29 = j_start DO j=ad_from29,j_end DO k=kts,ktf IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(its, k, j)+ru(its+1, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from29) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from30 = j_start DO j=ad_from30,j_end DO k=kts,ktf IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from30) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from31 = i_start CALL PUSHINTEGER4(i) DO i=ad_from31,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from31) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from32 = i_start CALL PUSHINTEGER4(i) DO i=ad_from32,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from32) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar .AND. jts .EQ. jds) THEN ad_from33 = i_start CALL PUSHINTEGER4(i) ! Assuming rv(i,k,jds) = 0. DO i=ad_from33,i_end DO k=kts,ktf IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*rv(i, k, jts+1) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from33) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar .AND. jte .EQ. jde) THEN ad_from34 = i_start CALL PUSHINTEGER4(i) ! Assuming rv(i,k,jde) = 0. DO i=ad_from34,i_end DO k=kts,ktf IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*rv(i, k, jte-1) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from34) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection !-- loop bounds for periodic or sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min53 = ide - 1 ELSE min53 = ite END IF CALL PUSHINTEGER4(i_end) i_end = min53 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min54 = jde - 1 ELSE min54 = jte END IF CALL PUSHINTEGER4(j_end) j_end = min54 + 1 !-- loop bounds for open or specified conditions IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN i_start = ids ELSE i_start = its - 1 END IF END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite + 1 END IF END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN j_start = jds ELSE j_start = jts - 1 END IF END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte + 1 END IF END IF IF (vert_order .EQ. 6) THEN ad_from38 = j_start DO j=ad_from38,j_end ad_from35 = i_start CALL PUSHINTEGER4(i) DO i=ad_from35,i_end fqz(i, 1, j) = 0. fqzl(i, 1, j) = 0. fqz(i, kde, j) = 0. fqzl(i, kde, j) = 0. END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from35) CALL PUSHINTEGER4(k) DO k=kts+3,ktf-2 ad_from36 = i_start DO i=ad_from36,i_end CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs35 = cr CALL PUSHCONTROL1B(0) ELSE abs35 = -cr CALL PUSHCONTROL1B(1) END IF y35 = cr + abs35 IF (1.0 .GT. y35) THEN CALL PUSHREAL8(min55) min55 = y35 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min55) min55 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs86 = cr CALL PUSHCONTROL1B(0) ELSE abs86 = -cr CALL PUSHCONTROL1B(1) END IF y86 = cr - abs86 IF (-1.0 .LT. y86) THEN CALL PUSHREAL8(max36) max36 = y86 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max36) max36 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min55*field_old(i, k-1, j)+0.5& & *max36*field_old(i, k, j)) fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-& & 2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, & & k+2, j)+field(i, k-3, j))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from36) END DO ad_from37 = i_start DO i=ad_from37,i_end CALL PUSHINTEGER4(k) k = kts + 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs36 = cr CALL PUSHCONTROL1B(0) ELSE abs36 = -cr CALL PUSHCONTROL1B(1) END IF y36 = cr + abs36 IF (1.0 .GT. y36) THEN CALL PUSHREAL8(min56) min56 = y36 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min56) min56 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs87 = cr CALL PUSHCONTROL1B(0) ELSE abs87 = -cr CALL PUSHCONTROL1B(1) END IF y87 = cr - abs87 IF (-1.0 .LT. y87) THEN CALL PUSHREAL8(max37) max37 = y87 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max37) max37 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min56*field_old(i, k-1, j)+0.5*& & max37*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = kts + 2 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs37 = cr CALL PUSHCONTROL1B(0) ELSE abs37 = -cr CALL PUSHCONTROL1B(1) END IF y37 = cr + abs37 IF (1.0 .GT. y37) THEN CALL PUSHREAL8(min57) min57 = y37 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min57) min57 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs88 = cr CALL PUSHCONTROL1B(0) ELSE abs88 = -cr CALL PUSHCONTROL1B(1) END IF y88 = cr - abs88 IF (-1.0 .LT. y88) THEN CALL PUSHREAL8(max38) max38 = y88 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max38) max38 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min57*field_old(i, k-1, j)+0.5*& & max38*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./& & 12.*(field(i, k+1, j)+field(i, k-2, j))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf - 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs38 = cr CALL PUSHCONTROL1B(0) ELSE abs38 = -cr CALL PUSHCONTROL1B(1) END IF y38 = cr + abs38 IF (1.0 .GT. y38) THEN CALL PUSHREAL8(min58) min58 = y38 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min58) min58 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs89 = cr CALL PUSHCONTROL1B(0) ELSE abs89 = -cr CALL PUSHCONTROL1B(1) END IF y89 = cr - abs89 IF (-1.0 .LT. y89) THEN CALL PUSHREAL8(max39) max39 = y89 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max39) max39 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min58*field_old(i, k-1, j)+0.5*& & max39*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./& & 12.*(field(i, k+1, j)+field(i, k-2, j))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs39 = cr CALL PUSHCONTROL1B(0) ELSE abs39 = -cr CALL PUSHCONTROL1B(1) END IF y39 = cr + abs39 IF (1.0 .GT. y39) THEN CALL PUSHREAL8(min59) min59 = y39 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min59) min59 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs90 = cr CALL PUSHCONTROL1B(0) ELSE abs90 = -cr CALL PUSHCONTROL1B(1) END IF y90 = cr - abs90 IF (-1.0 .LT. y90) THEN CALL PUSHREAL8(max40) max40 = y90 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max40) max40 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min59*field_old(i, k-1, j)+0.5*& & max40*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from37) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from38) CALL PUSHCONTROL3B(0) ELSE IF (vert_order .EQ. 5) THEN ad_from42 = j_start DO j=ad_from42,j_end ad_from39 = i_start CALL PUSHINTEGER4(i) DO i=ad_from39,i_end fqz(i, 1, j) = 0. fqzl(i, 1, j) = 0. fqz(i, kde, j) = 0. fqzl(i, kde, j) = 0. END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from39) CALL PUSHINTEGER4(k) DO k=kts+3,ktf-2 ad_from40 = i_start DO i=ad_from40,i_end CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs40 = cr CALL PUSHCONTROL1B(0) ELSE abs40 = -cr CALL PUSHCONTROL1B(1) END IF y40 = cr + abs40 IF (1.0 .GT. y40) THEN CALL PUSHREAL8(min60) min60 = y40 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min60) min60 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs91 = cr CALL PUSHCONTROL1B(0) ELSE abs91 = -cr CALL PUSHCONTROL1B(1) END IF y91 = cr - abs91 IF (-1.0 .LT. y91) THEN CALL PUSHREAL8(max41) max41 = y91 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max41) max41 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min60*field_old(i, k-1, j)+0.5& & *max41*field_old(i, k, j)) fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-& & 2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, & & k+2, j)+field(i, k-3, j))-SIGN(1, time_step)*SIGN(1., -vel)*& & (1./60.)*(field(i, k+2, j)-field(i, k-3, j)-5.*(field(i, k+1& & , j)-field(i, k-2, j))+10.*(field(i, k, j)-field(i, k-1, j))& & )) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from40) END DO ad_from41 = i_start DO i=ad_from41,i_end CALL PUSHINTEGER4(k) k = kts + 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs41 = cr CALL PUSHCONTROL1B(0) ELSE abs41 = -cr CALL PUSHCONTROL1B(1) END IF y41 = cr + abs41 IF (1.0 .GT. y41) THEN CALL PUSHREAL8(min61) min61 = y41 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min61) min61 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs92 = cr CALL PUSHCONTROL1B(0) ELSE abs92 = -cr CALL PUSHCONTROL1B(1) END IF y92 = cr - abs92 IF (-1.0 .LT. y92) THEN CALL PUSHREAL8(max42) max42 = y92 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max42) max42 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min61*field_old(i, k-1, j)+0.5*& & max42*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = kts + 2 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs42 = cr CALL PUSHCONTROL1B(0) ELSE abs42 = -cr CALL PUSHCONTROL1B(1) END IF y42 = cr + abs42 IF (1.0 .GT. y42) THEN CALL PUSHREAL8(min62) min62 = y42 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min62) min62 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs93 = cr CALL PUSHCONTROL1B(0) ELSE abs93 = -cr CALL PUSHCONTROL1B(1) END IF y93 = cr - abs93 IF (-1.0 .LT. y93) THEN CALL PUSHREAL8(max43) max43 = y93 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max43) max43 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min62*field_old(i, k-1, j)+0.5*& & max43*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./& & 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*& & SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*& & (field(i, k, j)-field(i, k-1, j)))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf - 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs43 = cr CALL PUSHCONTROL1B(0) ELSE abs43 = -cr CALL PUSHCONTROL1B(1) END IF y43 = cr + abs43 IF (1.0 .GT. y43) THEN CALL PUSHREAL8(min63) min63 = y43 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min63) min63 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs94 = cr CALL PUSHCONTROL1B(0) ELSE abs94 = -cr CALL PUSHCONTROL1B(1) END IF y94 = cr - abs94 IF (-1.0 .LT. y94) THEN CALL PUSHREAL8(max44) max44 = y94 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max44) max44 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min63*field_old(i, k-1, j)+0.5*& & max44*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./& & 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*& & SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*& & (field(i, k, j)-field(i, k-1, j)))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs44 = cr CALL PUSHCONTROL1B(0) ELSE abs44 = -cr CALL PUSHCONTROL1B(1) END IF y44 = cr + abs44 IF (1.0 .GT. y44) THEN CALL PUSHREAL8(min64) min64 = y44 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min64) min64 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs95 = cr CALL PUSHCONTROL1B(0) ELSE abs95 = -cr CALL PUSHCONTROL1B(1) END IF y95 = cr - abs95 IF (-1.0 .LT. y95) THEN CALL PUSHREAL8(max45) max45 = y95 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max45) max45 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min64*field_old(i, k-1, j)+0.5*& & max45*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from41) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from42) CALL PUSHCONTROL3B(1) ELSE IF (vert_order .EQ. 4) THEN ad_from46 = j_start DO j=ad_from46,j_end ad_from43 = i_start CALL PUSHINTEGER4(i) DO i=ad_from43,i_end fqz(i, 1, j) = 0. fqzl(i, 1, j) = 0. fqz(i, kde, j) = 0. fqzl(i, kde, j) = 0. END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from43) CALL PUSHINTEGER4(k) DO k=kts+2,ktf-1 ad_from44 = i_start DO i=ad_from44,i_end CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs45 = cr CALL PUSHCONTROL1B(0) ELSE abs45 = -cr CALL PUSHCONTROL1B(1) END IF y45 = cr + abs45 IF (1.0 .GT. y45) THEN CALL PUSHREAL8(min65) min65 = y45 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min65) min65 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs96 = cr CALL PUSHCONTROL1B(0) ELSE abs96 = -cr CALL PUSHCONTROL1B(1) END IF y96 = cr - abs96 IF (-1.0 .LT. y96) THEN CALL PUSHREAL8(max46) max46 = y96 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max46) max46 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min65*field_old(i, k-1, j)+0.5& & *max46*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-& & 1./12.*(field(i, k+1, j)+field(i, k-2, j))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from44) END DO ad_from45 = i_start DO i=ad_from45,i_end CALL PUSHINTEGER4(k) k = kts + 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs46 = cr CALL PUSHCONTROL1B(0) ELSE abs46 = -cr CALL PUSHCONTROL1B(1) END IF y46 = cr + abs46 IF (1.0 .GT. y46) THEN CALL PUSHREAL8(min66) min66 = y46 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min66) min66 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs97 = cr CALL PUSHCONTROL1B(0) ELSE abs97 = -cr CALL PUSHCONTROL1B(1) END IF y97 = cr - abs97 IF (-1.0 .LT. y97) THEN CALL PUSHREAL8(max47) max47 = y97 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max47) max47 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min66*field_old(i, k-1, j)+0.5*& & max47*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs47 = cr CALL PUSHCONTROL1B(0) ELSE abs47 = -cr CALL PUSHCONTROL1B(1) END IF y47 = cr + abs47 IF (1.0 .GT. y47) THEN CALL PUSHREAL8(min67) min67 = y47 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min67) min67 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs98 = cr CALL PUSHCONTROL1B(0) ELSE abs98 = -cr CALL PUSHCONTROL1B(1) END IF y98 = cr - abs98 IF (-1.0 .LT. y98) THEN CALL PUSHREAL8(max48) max48 = y98 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max48) max48 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min67*field_old(i, k-1, j)+0.5*& & max48*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from45) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from46) CALL PUSHCONTROL3B(2) ELSE IF (vert_order .EQ. 3) THEN ad_from50 = j_start DO j=ad_from50,j_end ad_from47 = i_start CALL PUSHINTEGER4(i) DO i=ad_from47,i_end fqz(i, 1, j) = 0. fqzl(i, 1, j) = 0. fqz(i, kde, j) = 0. fqzl(i, kde, j) = 0. END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from47) CALL PUSHINTEGER4(k) DO k=kts+2,ktf-1 ad_from48 = i_start DO i=ad_from48,i_end CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs48 = cr CALL PUSHCONTROL1B(0) ELSE abs48 = -cr CALL PUSHCONTROL1B(1) END IF y48 = cr + abs48 IF (1.0 .GT. y48) THEN CALL PUSHREAL8(min68) min68 = y48 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min68) min68 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs99 = cr CALL PUSHCONTROL1B(0) ELSE abs99 = -cr CALL PUSHCONTROL1B(1) END IF y99 = cr - abs99 IF (-1.0 .LT. y99) THEN CALL PUSHREAL8(max49) max49 = y99 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max49) max49 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min68*field_old(i, k-1, j)+0.5& & *max49*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-& & 1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step& & )*SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)& & -3.*(field(i, k, j)-field(i, k-1, j)))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from48) END DO ad_from49 = i_start DO i=ad_from49,i_end CALL PUSHINTEGER4(k) k = kts + 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs49 = cr CALL PUSHCONTROL1B(0) ELSE abs49 = -cr CALL PUSHCONTROL1B(1) END IF y49 = cr + abs49 IF (1.0 .GT. y49) THEN CALL PUSHREAL8(min69) min69 = y49 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min69) min69 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs100 = cr CALL PUSHCONTROL1B(0) ELSE abs100 = -cr CALL PUSHCONTROL1B(1) END IF y100 = cr - abs100 IF (-1.0 .LT. y100) THEN CALL PUSHREAL8(max50) max50 = y100 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max50) max50 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min69*field_old(i, k-1, j)+0.5*& & max50*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs50 = cr CALL PUSHCONTROL1B(0) ELSE abs50 = -cr CALL PUSHCONTROL1B(1) END IF y50 = cr + abs50 IF (1.0 .GT. y50) THEN CALL PUSHREAL8(min70) min70 = y50 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min70) min70 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs101 = cr CALL PUSHCONTROL1B(0) ELSE abs101 = -cr CALL PUSHCONTROL1B(1) END IF y101 = cr - abs101 IF (-1.0 .LT. y101) THEN CALL PUSHREAL8(max51) max51 = y101 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max51) max51 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min70*field_old(i, k-1, j)+0.5*& & max51*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(& & i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from49) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from50) CALL PUSHCONTROL3B(3) ELSE IF (vert_order .EQ. 2) THEN ad_from53 = j_start DO j=ad_from53,j_end ad_from51 = i_start CALL PUSHINTEGER4(i) DO i=ad_from51,i_end fqz(i, 1, j) = 0. fqzl(i, 1, j) = 0. fqz(i, kde, j) = 0. fqzl(i, kde, j) = 0. END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from51) DO k=kts+1,ktf ad_from52 = i_start DO i=ad_from52,i_end CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs51 = cr CALL PUSHCONTROL1B(0) ELSE abs51 = -cr CALL PUSHCONTROL1B(1) END IF y51 = cr + abs51 IF (1.0 .GT. y51) THEN CALL PUSHREAL8(min71) min71 = y51 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min71) min71 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs102 = cr CALL PUSHCONTROL1B(0) ELSE abs102 = -cr CALL PUSHCONTROL1B(1) END IF y102 = cr - abs102 IF (-1.0 .LT. y102) THEN CALL PUSHREAL8(max52) max52 = y102 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max52) max52 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min71*field_old(i, k-1, j)+0.5& & *max52*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from52) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from53) CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF IF (pd_limit) THEN ! positive definite filter i_start = its - 1 IF (ite .GT. ide - 1) THEN min72 = ide - 1 ELSE min72 = ite END IF i_end = min72 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min73 = jde - 1 ELSE min73 = jte END IF j_end = min73 + 1 !-- loop bounds for open or specified conditions IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN i_start = ids ELSE i_start = its - 1 END IF END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite + 1 END IF END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN j_start = jds ELSE j_start = jts - 1 END IF END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte + 1 END IF END IF IF (config_flags%specified .OR. config_flags%nested) THEN IF (degrade_xs) THEN IF (its - 1 .LT. ids + 1) THEN i_start = ids + 1 ELSE i_start = its - 1 END IF END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 2) THEN i_end = ide - 2 ELSE i_end = ite + 1 END IF END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts - 1 END IF END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte + 1 END IF END IF END IF IF (config_flags%open_xs) THEN IF (degrade_xs) THEN IF (its - 1 .LT. ids + 1) THEN i_start = ids + 1 ELSE i_start = its - 1 END IF END IF END IF IF (config_flags%open_xe) THEN IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 2) THEN i_end = ide - 2 ELSE i_end = ite + 1 END IF END IF END IF IF (config_flags%open_ys) THEN IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts - 1 END IF END IF END IF IF (config_flags%open_ye) THEN IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte + 1 END IF END IF END IF ad_from55 = j_start ! ADT note: ! We don't want to change j_start and j_end ! for polar BC's since we want to calculate ! fluxes for directions other than y at the ! edge !-- here is the limiter... DO j=ad_from55,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from54 = i_start CALL PUSHINTEGER4(i) DO i=ad_from54,i_end CALL PUSHREAL8(ph_low(i,k,j)) ph_low(i,k,j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) - dt*(& & msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, k, j))& & +rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw(k)*(& & fqzl(i, k+1, j)-fqzl(i, k, j))) ENDDO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from54) END DO ENDDO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from55) ad_from55 = j_start DO j=ad_from55,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from54 = i_start CALL PUSHINTEGER4(i) DO i=ad_from54,i_end IF (0. .LT. fqx(i+1, k, j)) THEN max1 = fqx(i+1, k, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) max1 = 0. END IF IF (0. .GT. fqx(i, k, j)) THEN min74 = fqx(i, k, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) min74 = 0. END IF IF (0. .LT. fqy(i, k, j+1)) THEN max53 = fqy(i, k, j+1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) max53 = 0. END IF IF (0. .GT. fqy(i, k, j)) THEN min75 = fqy(i, k, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) min75 = 0. END IF IF (0. .GT. fqz(i, k+1, j)) THEN min76 = fqz(i, k+1, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) min76 = 0. END IF IF (0. .LT. fqz(i, k, j)) THEN max54 = fqz(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) max54 = 0. END IF CALL PUSHREAL8(flux_out(i,k,j)) flux_out(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-min74)+rdy*(& & max53-min75))+msfty(i, j)*rdzw(k)*(min76-max54)) ENDDO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from54) END DO ENDDO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from55) ad_from55 = j_start DO j=ad_from55,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from54 = i_start CALL PUSHINTEGER4(i) DO i=ad_from54,i_end IF (flux_out(i,k,j) .GT. ph_low(i,k,j)) THEN IF (0. .LT. ph_low(i,k,j)/(flux_out(i,k,j)+eps)) THEN CALL PUSHREAL8(scale) scale = ph_low(i,k,j)/(flux_out(i,k,j)+eps) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(scale) scale = 0. CALL PUSHCONTROL1B(1) END IF IF (fqx(i+1, k, j) .GT. 0.) THEN CALL PUSHREAL8(fqx(i+1, k, j)) fqx(i+1, k, j) = scale*fqx(i+1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqx(i, k, j) .LT. 0.) THEN CALL PUSHREAL8(fqx(i, k, j)) fqx(i, k, j) = scale*fqx(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqy(i, k, j+1) .GT. 0.) THEN CALL PUSHREAL8(fqy(i, k, j+1)) fqy(i, k, j+1) = scale*fqy(i, k, j+1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqy(i, k, j) .LT. 0.) THEN CALL PUSHREAL8(fqy(i, k, j)) fqy(i, k, j) = scale*fqy(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF ! note: z flux is opposite sign in mass coordinate because ! vertical coordinate decreases with increasing k IF (fqz(i, k+1, j) .LT. 0.) THEN CALL PUSHREAL8(fqz(i, k+1, j)) fqz(i, k+1, j) = scale*fqz(i, k+1, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqz(i, k, j) .GT. 0.) THEN CALL PUSHREAL8(fqz(i, k, j)) fqz(i, k, j) = scale*fqz(i, k, j) CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from54) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from55) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! add in the pd-limited flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ad_from57 = j_start DO j=ad_from57,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from56 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from56) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from57) IF (tenddec) THEN ad_from59 = j_start DO j=ad_from59,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from58 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from58) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from59) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF ! x flux divergence ! IF (degrade_xs) THEN IF (its .LT. ids + 1) THEN i_start = ids + 1 ELSE i_start = its END IF END IF IF (degrade_xe) THEN IF (ite .GT. ide - 2) THEN i_end = ide - 2 ELSE i_end = ite END IF END IF ad_from61 = j_start DO j=ad_from61,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from60 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from60) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from61) IF (tenddec) THEN ad_from63 = j_start DO j=ad_from63,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from62 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from62) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from63) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! y flux divergence ! i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF END IF DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf CALL PUSHINTEGER4(i) END DO END DO IF (tenddec) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf CALL PUSHINTEGER4(i) END DO END DO fqylb = 0.0 fqyb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp47b18 = -(msftx(i, j)*rdy*h_tendencyb(i, k, j)) fqyb(i, k, j+1) = fqyb(i, k, j+1) + temp47b18 fqyb(i, k, j) = fqyb(i, k, j) - temp47b18 fqylb(i, k, j+1) = fqylb(i, k, j+1) + temp47b18 fqylb(i, k, j) = fqylb(i, k, j) - temp47b18 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO ELSE fqylb = 0.0 fqyb = 0.0 END IF DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp47b17 = -(msftx(i, j)*rdy*tendencyb(i, k, j)) fqyb(i, k, j+1) = fqyb(i, k, j+1) + temp47b17 fqyb(i, k, j) = fqyb(i, k, j) - temp47b17 fqylb(i, k, j+1) = fqylb(i, k, j+1) + temp47b17 fqylb(i, k, j) = fqylb(i, k, j) - temp47b17 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN fqxlb = 0.0 fqxb = 0.0 ELSE fqxlb = 0.0 fqxb = 0.0 CALL POPINTEGER4(ad_from63) CALL POPINTEGER4(ad_to63) DO j=ad_to63,ad_from63,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from62) CALL POPINTEGER4(ad_to62) DO i=ad_to62,ad_from62,-1 temp47b16 = -(msftx(i, j)*rdx*h_tendencyb(i, k, j)) fqxb(i+1, k, j) = fqxb(i+1, k, j) + temp47b16 fqxb(i, k, j) = fqxb(i, k, j) - temp47b16 fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + temp47b16 fqxlb(i, k, j) = fqxlb(i, k, j) - temp47b16 h_tendencyb(i, k, j) = 0.0 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO END IF CALL POPINTEGER4(ad_from61) CALL POPINTEGER4(ad_to61) DO j=ad_to61,ad_from61,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from60) CALL POPINTEGER4(ad_to60) DO i=ad_to60,ad_from60,-1 temp47b15 = -(msftx(i, j)*rdx*tendencyb(i, k, j)) fqxb(i+1, k, j) = fqxb(i+1, k, j) + temp47b15 fqxb(i, k, j) = fqxb(i, k, j) - temp47b15 fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + temp47b15 fqxlb(i, k, j) = fqxlb(i, k, j) - temp47b15 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN fqzb = 0.0 fqzlb = 0.0 CALL POPINTEGER4(ad_from59) CALL POPINTEGER4(ad_to59) DO j=ad_to59,ad_from59,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from58) CALL POPINTEGER4(ad_to58) DO i=ad_to58,ad_from58,-1 temp47b14 = -(rdzw(k)*z_tendencyb(i, k, j)) fqzb(i, k+1, j) = fqzb(i, k+1, j) + temp47b14 fqzb(i, k, j) = fqzb(i, k, j) - temp47b14 fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + temp47b14 fqzlb(i, k, j) = fqzlb(i, k, j) - temp47b14 z_tendencyb(i, k, j) = 0.0 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO ELSE fqzb = 0.0 fqzlb = 0.0 END IF CALL POPINTEGER4(ad_from57) CALL POPINTEGER4(ad_to57) DO j=ad_to57,ad_from57,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from56) CALL POPINTEGER4(ad_to56) DO i=ad_to56,ad_from56,-1 temp47b13 = -(rdzw(k)*tendencyb(i, k, j)) fqzb(i, k+1, j) = fqzb(i, k+1, j) + temp47b13 fqzb(i, k, j) = fqzb(i, k, j) - temp47b13 fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + temp47b13 fqzlb(i, k, j) = fqzlb(i, k, j) - temp47b13 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from55) CALL POPINTEGER4(ad_to55) DO j=ad_to55,ad_from55,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from54) CALL POPINTEGER4(ad_to54) DO i=ad_to54,ad_from54,-1 CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN flux_outb(i,k,j) = 0.0 ph_lowb(i,k,j) = 0.0 ELSE IF (branch .EQ. 1) THEN scaleb = 0.0 ELSE CALL POPREAL8(fqz(i, k, j)) scaleb = fqz(i, k, j)*fqzb(i, k, j) fqzb(i, k, j) = scale*fqzb(i, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqz(i, k+1, j)) scaleb = scaleb + fqz(i, k+1, j)*fqzb(i, k+1, j) fqzb(i, k+1, j) = scale*fqzb(i, k+1, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqy(i, k, j)) scaleb = scaleb + fqy(i, k, j)*fqyb(i, k, j) fqyb(i, k, j) = scale*fqyb(i, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqy(i, k, j+1)) scaleb = scaleb + fqy(i, k, j+1)*fqyb(i, k, j+1) fqyb(i, k, j+1) = scale*fqyb(i, k, j+1) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqx(i, k, j)) scaleb = scaleb + fqx(i, k, j)*fqxb(i, k, j) fqxb(i, k, j) = scale*fqxb(i, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqx(i+1, k, j)) scaleb = scaleb + fqx(i+1, k, j)*fqxb(i+1, k, j) fqxb(i+1, k, j) = scale*fqxb(i+1, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(scale) temp47b12 = scaleb/(eps+flux_out(i,k,j)) ph_lowb(i,k,j) = temp47b12 flux_outb(i,k,j) = -(ph_low(i,k,j)*temp47b12/(eps+flux_out(i,k,j))) ELSE CALL POPREAL8(scale) flux_outb(i,k,j) = 0.0 ph_lowb(i,k,j) = 0.0 END IF END IF END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO CALL POPINTEGER4(ad_from55) CALL POPINTEGER4(ad_to55) DO j=ad_to55,ad_from55,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from54) CALL POPINTEGER4(ad_to54) DO i=ad_to54,ad_from54,-1 CALL POPREAL8(flux_out(i,k,j)) temp47b10 = dt*msftx(i, j)*msfty(i, j)*flux_outb(i,k,j) temp47b11 = msfty(i, j)*dt*rdzw(k)*flux_outb(i,k,j) max1b = rdx*temp47b10 min74b = -(rdx*temp47b10) max53b = rdy*temp47b10 min75b = -(rdy*temp47b10) min76b = temp47b11 max54b = -temp47b11 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) fqzb(i, k, j) = fqzb(i, k, j) + max54b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqzb(i, k+1, j) = fqzb(i, k+1, j) + min76b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqyb(i, k, j) = fqyb(i, k, j) + min75b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqyb(i, k, j+1) = fqyb(i, k, j+1) + max53b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqxb(i, k, j) = fqxb(i, k, j) + min74b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqxb(i+1, k, j) = fqxb(i+1, k, j) + max1b END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO CALL POPINTEGER4(ad_from55) CALL POPINTEGER4(ad_to55) DO j=ad_to55,ad_from55,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from54) CALL POPINTEGER4(ad_to54) DO i=ad_to54,ad_from54,-1 CALL POPREAL8(ph_low(i,k,j)) temp47b8 = -(dt*msftx(i, j)*msfty(i, j)*ph_lowb(i,k,j)) temp47b9 = -(dt*msfty(i, j)*rdzw(k)*ph_lowb(i,k,j)) mu_oldb(i, j) = mu_oldb(i, j) + field_old(i, k, j)*ph_lowb(i,k,j) field_oldb(i, k, j) = field_oldb(i, k, j) + (mub(i, j)+mu_old(& & i, j))*ph_lowb(i,k,j) fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + rdx*temp47b8 fqxlb(i, k, j) = fqxlb(i, k, j) - rdx*temp47b8 fqylb(i, k, j+1) = fqylb(i, k, j+1) + rdy*temp47b8 fqylb(i, k, j) = fqylb(i, k, j) - rdy*temp47b8 fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + temp47b9 fqzlb(i, k, j) = fqzlb(i, k, j) - temp47b9 END DO CALL POPINTEGER4(i) END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from38) CALL POPINTEGER4(ad_to38) DO j=ad_to38,ad_from38,-1 CALL POPINTEGER4(ad_from37) CALL POPINTEGER4(ad_to37) DO i=ad_to37,ad_from37,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp31b74 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b74 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b74 fqzb(i, k, j) = 0.0 temp31b75 = dz*mu*fqzlb(i, k, j)/dt min59b = 0.5*field_old(i, k-1, j)*temp31b75 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min59*& & temp31b75 max40b = 0.5*field_old(i, k, j)*temp31b75 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max40*& & temp31b75 mub0 = (0.5*(min59*field_old(i, k-1, j))+0.5*(max40*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max40) y90b = max40b ELSE CALL POPREAL8(max40) y90b = 0.0 END IF crb = y90b abs90b = -y90b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs90b ELSE crb = crb - abs90b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min59) y39b = min59b ELSE CALL POPREAL8(min59) y39b = 0.0 END IF crb = crb + y39b abs39b = y39b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs39b ELSE crb = crb - abs39b END IF temp31b70 = dt*crb/(dz*mu) velb = temp31b70 mub0 = mub0 - vel*temp31b70/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = ktf - 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp31b71 = vel*fqzb(i, k, j) temp31b72 = 7.*temp31b71/12. velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k& & +1, j)+field(i, k-2, j))/12.)*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b72 fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b72 fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b71/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b71/12. fqzb(i, k, j) = 0.0 temp31b73 = dz*mu*fqzlb(i, k, j)/dt min58b = 0.5*field_old(i, k-1, j)*temp31b73 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min58*& & temp31b73 max39b = 0.5*field_old(i, k, j)*temp31b73 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max39*& & temp31b73 mub0 = (0.5*(min58*field_old(i, k-1, j))+0.5*(max39*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max39) y89b = max39b ELSE CALL POPREAL8(max39) y89b = 0.0 END IF crb = y89b abs89b = -y89b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs89b ELSE crb = crb - abs89b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min58) y38b = min58b ELSE CALL POPREAL8(min58) y38b = 0.0 END IF crb = crb + y38b abs38b = y38b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs38b ELSE crb = crb - abs38b END IF temp31b66 = dt*crb/(dz*mu) velb = velb + temp31b66 mub0 = mub0 - vel*temp31b66/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 2 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp31b67 = vel*fqzb(i, k, j) temp31b68 = 7.*temp31b67/12. velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k& & +1, j)+field(i, k-2, j))/12.)*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b68 fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b68 fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp31b67/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp31b67/12. fqzb(i, k, j) = 0.0 temp31b69 = dz*mu*fqzlb(i, k, j)/dt min57b = 0.5*field_old(i, k-1, j)*temp31b69 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min57*& & temp31b69 max38b = 0.5*field_old(i, k, j)*temp31b69 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max38*& & temp31b69 mub0 = (0.5*(min57*field_old(i, k-1, j))+0.5*(max38*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max38) y88b = max38b ELSE CALL POPREAL8(max38) y88b = 0.0 END IF crb = y88b abs88b = -y88b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs88b ELSE crb = crb - abs88b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min57) y37b = min57b ELSE CALL POPREAL8(min57) y37b = 0.0 END IF crb = crb + y37b abs37b = y37b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs37b ELSE crb = crb - abs37b END IF temp31b63 = dt*crb/(dz*mu) velb = velb + temp31b63 mub0 = mub0 - vel*temp31b63/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp31b64 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp31b64 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp31b64 fqzb(i, k, j) = 0.0 temp31b65 = dz*mu*fqzlb(i, k, j)/dt min56b = 0.5*field_old(i, k-1, j)*temp31b65 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min56*& & temp31b65 max37b = 0.5*field_old(i, k, j)*temp31b65 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max37*& & temp31b65 mub0 = (0.5*(min56*field_old(i, k-1, j))+0.5*(max37*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max37) y87b = max37b ELSE CALL POPREAL8(max37) y87b = 0.0 END IF crb = y87b abs87b = -y87b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs87b ELSE crb = crb - abs87b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min56) y36b = min56b ELSE CALL POPREAL8(min56) y36b = 0.0 END IF crb = crb + y36b abs36b = y36b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs36b ELSE crb = crb - abs36b END IF temp31b62 = dt*crb/(dz*mu) velb = temp31b62 mub0 = mub0 - vel*temp31b62/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) CALL POPINTEGER4(k) END DO DO k=ktf-2,kts+3,-1 CALL POPINTEGER4(ad_from36) CALL POPINTEGER4(ad_to36) DO i=ad_to36,ad_from36,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp31b58 = vel*fqzb(i, k, j) temp31b59 = 37.*temp31b58/60. temp31b60 = -(2.*temp31b58/15.) velb = (37.*((field(i, k, j)+field(i, k-1, j))/60.)-2.*((& & field(i, k+1, j)+field(i, k-2, j))/15.)+(field(i, k+2, j)+& & field(i, k-3, j))/60.)*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b59 fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b59 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp31b60 fieldb(i, k-2, j) = fieldb(i, k-2, j) + temp31b60 fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b58/60. fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b58/60. fqzb(i, k, j) = 0.0 temp31b61 = dz*mu*fqzlb(i, k, j)/dt min55b = 0.5*field_old(i, k-1, j)*temp31b61 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min55*& & temp31b61 max36b = 0.5*field_old(i, k, j)*temp31b61 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max36*& & temp31b61 mub0 = (0.5*(min55*field_old(i, k-1, j))+0.5*(max36*& & field_old(i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max36) y86b = max36b ELSE CALL POPREAL8(max36) y86b = 0.0 END IF crb = y86b abs86b = -y86b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs86b ELSE crb = crb - abs86b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min55) y35b = min55b ELSE CALL POPREAL8(min55) y35b = 0.0 END IF crb = crb + y35b abs35b = y35b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs35b ELSE crb = crb - abs35b END IF temp31b57 = dt*crb/(dz*mu) velb = velb + temp31b57 mub0 = mub0 - vel*temp31b57/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) END DO END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from35) CALL POPINTEGER4(ad_to35) DO i=ad_to35,ad_from35,-1 fqzlb(i, kde, j) = 0.0 fqzb(i, kde, j) = 0.0 fqzlb(i, 1, j) = 0.0 fqzb(i, 1, j) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from42) CALL POPINTEGER4(ad_to42) DO j=ad_to42,ad_from42,-1 CALL POPINTEGER4(ad_from41) CALL POPINTEGER4(ad_to41) DO i=ad_to41,ad_from41,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp43b0 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b0 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b0 fqzb(i, k, j) = 0.0 temp43b1 = dz*mu*fqzlb(i, k, j)/dt min64b = 0.5*field_old(i, k-1, j)*temp43b1 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min64*& & temp43b1 max45b = 0.5*field_old(i, k, j)*temp43b1 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max45*temp43b1 mub0 = (0.5*(min64*field_old(i, k-1, j))+0.5*(max45*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max45) y95b = max45b ELSE CALL POPREAL8(max45) y95b = 0.0 END IF crb = y95b abs95b = -y95b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs95b ELSE crb = crb - abs95b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min64) y44b = min64b ELSE CALL POPREAL8(min64) y44b = 0.0 END IF crb = crb + y44b abs44b = y44b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs44b ELSE crb = crb - abs44b END IF temp43b = dt*crb/(dz*mu) velb = temp43b mub0 = mub0 - vel*temp43b/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = ktf - 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp39 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k& & , j)-field(i, k-1, j)) temp42 = SIGN(1., -vel) temp41 = temp42/12. temp40 = SIGN(1, time_step) temp39b0 = vel*fqzb(i, k, j) temp39b1 = 7.*temp39b0/12. temp39b2 = temp40*temp41*temp39b0 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k& & +1, j)+field(i, k-2, j))/12.+temp40*(temp41*temp39))*fqzb(i& & , k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp39b1 - 3.*temp39b2 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp39b2 + temp39b1 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp39b2 - temp39b0/& & 12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp39b2 - temp39b0/& & 12. fqzb(i, k, j) = 0.0 temp39b3 = dz*mu*fqzlb(i, k, j)/dt min63b = 0.5*field_old(i, k-1, j)*temp39b3 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min63*& & temp39b3 max44b = 0.5*field_old(i, k, j)*temp39b3 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max44*temp39b3 mub0 = (0.5*(min63*field_old(i, k-1, j))+0.5*(max44*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max44) y94b = max44b ELSE CALL POPREAL8(max44) y94b = 0.0 END IF crb = y94b abs94b = -y94b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs94b ELSE crb = crb - abs94b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min63) y43b = min63b ELSE CALL POPREAL8(min63) y43b = 0.0 END IF crb = crb + y43b abs43b = y43b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs43b ELSE crb = crb - abs43b END IF temp39b = dt*crb/(dz*mu) velb = velb + temp39b mub0 = mub0 - vel*temp39b/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 2 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp35 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k& & , j)-field(i, k-1, j)) temp38 = SIGN(1., -vel) temp37 = temp38/12. temp36 = SIGN(1, time_step) temp35b3 = vel*fqzb(i, k, j) temp35b4 = 7.*temp35b3/12. temp35b5 = temp36*temp37*temp35b3 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k& & +1, j)+field(i, k-2, j))/12.+temp36*(temp37*temp35))*fqzb(i& & , k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp35b4 - 3.*temp35b5 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp35b5 + temp35b4 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp35b5 - temp35b3/& & 12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp35b5 - temp35b3/& & 12. fqzb(i, k, j) = 0.0 temp35b6 = dz*mu*fqzlb(i, k, j)/dt min62b = 0.5*field_old(i, k-1, j)*temp35b6 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min62*& & temp35b6 max43b = 0.5*field_old(i, k, j)*temp35b6 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max43*temp35b6 mub0 = (0.5*(min62*field_old(i, k-1, j))+0.5*(max43*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max43) y93b = max43b ELSE CALL POPREAL8(max43) y93b = 0.0 END IF crb = y93b abs93b = -y93b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs93b ELSE crb = crb - abs93b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min62) y42b = min62b ELSE CALL POPREAL8(min62) y42b = 0.0 END IF crb = crb + y42b abs42b = y42b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs42b ELSE crb = crb - abs42b END IF temp35b0 = dt*crb/(dz*mu) velb = velb + temp35b0 mub0 = mub0 - vel*temp35b0/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp35b1 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp35b1 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp35b1 fqzb(i, k, j) = 0.0 temp35b2 = dz*mu*fqzlb(i, k, j)/dt min61b = 0.5*field_old(i, k-1, j)*temp35b2 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min61*& & temp35b2 max42b = 0.5*field_old(i, k, j)*temp35b2 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max42*temp35b2 mub0 = (0.5*(min61*field_old(i, k-1, j))+0.5*(max42*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max42) y92b = max42b ELSE CALL POPREAL8(max42) y92b = 0.0 END IF crb = y92b abs92b = -y92b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs92b ELSE crb = crb - abs92b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min61) y41b = min61b ELSE CALL POPREAL8(min61) y41b = 0.0 END IF crb = crb + y41b abs41b = y41b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs41b ELSE crb = crb - abs41b END IF temp35b = dt*crb/(dz*mu) velb = temp35b mub0 = mub0 - vel*temp35b/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) CALL POPINTEGER4(k) END DO DO k=ktf-2,kts+3,-1 CALL POPINTEGER4(ad_from40) CALL POPINTEGER4(ad_to40) DO i=ad_to40,ad_from40,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp31 = field(i, k+2, j) - field(i, k-3, j) + 10.*(field(i& & , k, j)-field(i, k-1, j)) - 5.*(field(i, k+1, j)-field(i, & & k-2, j)) temp34 = SIGN(1., -vel) temp33 = temp34/60. temp32 = SIGN(1, time_step) temp31b77 = vel*fqzb(i, k, j) temp31b78 = 37.*temp31b77/60. temp31b79 = -(2.*temp31b77/15.) temp31b80 = -(temp32*temp33*temp31b77) velb = (37.*((field(i, k, j)+field(i, k-1, j))/60.)-2.*((& & field(i, k+1, j)+field(i, k-2, j))/15.)+(field(i, k+2, j)+& & field(i, k-3, j))/60.-temp32*(temp33*temp31))*fqzb(i, k, j& & ) fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp31b80 + & & temp31b78 fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp31b78 - 10.*& & temp31b80 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp31b79 - 5.*& & temp31b80 fieldb(i, k-2, j) = fieldb(i, k-2, j) + 5.*temp31b80 + & & temp31b79 fieldb(i, k+2, j) = fieldb(i, k+2, j) + temp31b80 + & & temp31b77/60. fieldb(i, k-3, j) = fieldb(i, k-3, j) + temp31b77/60. - & & temp31b80 fqzb(i, k, j) = 0.0 temp31b81 = dz*mu*fqzlb(i, k, j)/dt min60b = 0.5*field_old(i, k-1, j)*temp31b81 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min60*& & temp31b81 max41b = 0.5*field_old(i, k, j)*temp31b81 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max41*& & temp31b81 mub0 = (0.5*(min60*field_old(i, k-1, j))+0.5*(max41*& & field_old(i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max41) y91b = max41b ELSE CALL POPREAL8(max41) y91b = 0.0 END IF crb = y91b abs91b = -y91b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs91b ELSE crb = crb - abs91b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min60) y40b = min60b ELSE CALL POPREAL8(min60) y40b = 0.0 END IF crb = crb + y40b abs40b = y40b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs40b ELSE crb = crb - abs40b END IF temp31b76 = dt*crb/(dz*mu) velb = velb + temp31b76 mub0 = mub0 - vel*temp31b76/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) END DO END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from39) CALL POPINTEGER4(ad_to39) DO i=ad_to39,ad_from39,-1 fqzlb(i, kde, j) = 0.0 fqzb(i, kde, j) = 0.0 fqzlb(i, 1, j) = 0.0 fqzb(i, 1, j) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE CALL POPINTEGER4(ad_from46) CALL POPINTEGER4(ad_to46) DO j=ad_to46,ad_from46,-1 CALL POPINTEGER4(ad_from45) CALL POPINTEGER4(ad_to45) DO i=ad_to45,ad_from45,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp43b10 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b10 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b10 fqzb(i, k, j) = 0.0 temp43b11 = dz*mu*fqzlb(i, k, j)/dt min67b = 0.5*field_old(i, k-1, j)*temp43b11 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min67*& & temp43b11 max48b = 0.5*field_old(i, k, j)*temp43b11 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max48*& & temp43b11 mub0 = (0.5*(min67*field_old(i, k-1, j))+0.5*(max48*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max48) y98b = max48b ELSE CALL POPREAL8(max48) y98b = 0.0 END IF crb = y98b abs98b = -y98b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs98b ELSE crb = crb - abs98b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min67) y47b = min67b ELSE CALL POPREAL8(min67) y47b = 0.0 END IF crb = crb + y47b abs47b = y47b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs47b ELSE crb = crb - abs47b END IF temp43b7 = dt*crb/(dz*mu) velb = temp43b7 mub0 = mub0 - vel*temp43b7/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp43b8 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp43b8 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp43b8 fqzb(i, k, j) = 0.0 temp43b9 = dz*mu*fqzlb(i, k, j)/dt min66b = 0.5*field_old(i, k-1, j)*temp43b9 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min66*& & temp43b9 max47b = 0.5*field_old(i, k, j)*temp43b9 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max47*temp43b9 mub0 = (0.5*(min66*field_old(i, k-1, j))+0.5*(max47*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max47) y97b = max47b ELSE CALL POPREAL8(max47) y97b = 0.0 END IF crb = y97b abs97b = -y97b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs97b ELSE crb = crb - abs97b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min66) y46b = min66b ELSE CALL POPREAL8(min66) y46b = 0.0 END IF crb = crb + y46b abs46b = y46b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs46b ELSE crb = crb - abs46b END IF temp43b6 = dt*crb/(dz*mu) velb = temp43b6 mub0 = mub0 - vel*temp43b6/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) CALL POPINTEGER4(k) END DO DO k=ktf-1,kts+2,-1 CALL POPINTEGER4(ad_from44) CALL POPINTEGER4(ad_to44) DO i=ad_to44,ad_from44,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp43b3 = vel*fqzb(i, k, j) temp43b4 = 7.*temp43b3/12. velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i& & , k+1, j)+field(i, k-2, j))/12.)*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp43b4 fieldb(i, k-1, j) = fieldb(i, k-1, j) + temp43b4 fieldb(i, k+1, j) = fieldb(i, k+1, j) - temp43b3/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b3/12. fqzb(i, k, j) = 0.0 temp43b5 = dz*mu*fqzlb(i, k, j)/dt min65b = 0.5*field_old(i, k-1, j)*temp43b5 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min65*& & temp43b5 max46b = 0.5*field_old(i, k, j)*temp43b5 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max46*& & temp43b5 mub0 = (0.5*(min65*field_old(i, k-1, j))+0.5*(max46*& & field_old(i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max46) y96b = max46b ELSE CALL POPREAL8(max46) y96b = 0.0 END IF crb = y96b abs96b = -y96b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs96b ELSE crb = crb - abs96b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min65) y45b = min65b ELSE CALL POPREAL8(min65) y45b = 0.0 END IF crb = crb + y45b abs45b = y45b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs45b ELSE crb = crb - abs45b END IF temp43b2 = dt*crb/(dz*mu) velb = velb + temp43b2 mub0 = mub0 - vel*temp43b2/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) END DO END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from43) CALL POPINTEGER4(ad_to43) DO i=ad_to43,ad_from43,-1 fqzlb(i, kde, j) = 0.0 fqzb(i, kde, j) = 0.0 fqzlb(i, 1, j) = 0.0 fqzb(i, 1, j) = 0.0 END DO CALL POPINTEGER4(i) END DO END IF ELSE IF (branch .EQ. 3) THEN CALL POPINTEGER4(ad_from50) CALL POPINTEGER4(ad_to50) DO j=ad_to50,ad_from50,-1 CALL POPINTEGER4(ad_from49) CALL POPINTEGER4(ad_to49) DO i=ad_to49,ad_from49,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp47b3 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b3 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b3 fqzb(i, k, j) = 0.0 temp47b4 = dz*mu*fqzlb(i, k, j)/dt min70b = 0.5*field_old(i, k-1, j)*temp47b4 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min70*& & temp47b4 max51b = 0.5*field_old(i, k, j)*temp47b4 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max51*temp47b4 mub0 = (0.5*(min70*field_old(i, k-1, j))+0.5*(max51*field_old(i& & , k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max51) y101b = max51b ELSE CALL POPREAL8(max51) y101b = 0.0 END IF crb = y101b abs101b = -y101b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs101b ELSE crb = crb - abs101b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min70) y50b = min70b ELSE CALL POPREAL8(min70) y50b = 0.0 END IF crb = crb + y50b abs50b = y50b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs50b ELSE crb = crb - abs50b END IF temp47b0 = dt*crb/(dz*mu) velb = temp47b0 mub0 = mub0 - vel*temp47b0/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp47b1 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b1 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b1 fqzb(i, k, j) = 0.0 temp47b2 = dz*mu*fqzlb(i, k, j)/dt min69b = 0.5*field_old(i, k-1, j)*temp47b2 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min69*& & temp47b2 max50b = 0.5*field_old(i, k, j)*temp47b2 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max50*temp47b2 mub0 = (0.5*(min69*field_old(i, k-1, j))+0.5*(max50*field_old(i& & , k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max50) y100b = max50b ELSE CALL POPREAL8(max50) y100b = 0.0 END IF crb = y100b abs100b = -y100b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs100b ELSE crb = crb - abs100b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min69) y49b = min69b ELSE CALL POPREAL8(min69) y49b = 0.0 END IF crb = crb + y49b abs49b = y49b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs49b ELSE crb = crb - abs49b END IF temp47b = dt*crb/(dz*mu) velb = temp47b mub0 = mub0 - vel*temp47b/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) CALL POPINTEGER4(k) END DO DO k=ktf-1,kts+2,-1 CALL POPINTEGER4(ad_from48) CALL POPINTEGER4(ad_to48) DO i=ad_to48,ad_from48,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp43 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k& & , j)-field(i, k-1, j)) temp46 = SIGN(1., -vel) temp45 = temp46/12. temp44 = SIGN(1, time_step) temp43b13 = vel*fqzb(i, k, j) temp43b14 = 7.*temp43b13/12. temp43b15 = temp44*temp45*temp43b13 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k& & +1, j)+field(i, k-2, j))/12.+temp44*(temp45*temp43))*fqzb(i& & , k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp43b14 - 3.*temp43b15 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*temp43b15 + & & temp43b14 fieldb(i, k+1, j) = fieldb(i, k+1, j) + temp43b15 - temp43b13/& & 12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - temp43b15 - temp43b13/& & 12. fqzb(i, k, j) = 0.0 temp43b16 = dz*mu*fqzlb(i, k, j)/dt min68b = 0.5*field_old(i, k-1, j)*temp43b16 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min68*& & temp43b16 max49b = 0.5*field_old(i, k, j)*temp43b16 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max49*& & temp43b16 mub0 = (0.5*(min68*field_old(i, k-1, j))+0.5*(max49*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max49) y99b = max49b ELSE CALL POPREAL8(max49) y99b = 0.0 END IF crb = y99b abs99b = -y99b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs99b ELSE crb = crb - abs99b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min68) y48b = min68b ELSE CALL POPREAL8(min68) y48b = 0.0 END IF crb = crb + y48b abs48b = y48b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs48b ELSE crb = crb - abs48b END IF temp43b12 = dt*crb/(dz*mu) velb = velb + temp43b12 mub0 = mub0 - vel*temp43b12/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) END DO END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from47) CALL POPINTEGER4(ad_to47) DO i=ad_to47,ad_from47,-1 fqzlb(i, kde, j) = 0.0 fqzb(i, kde, j) = 0.0 fqzlb(i, 1, j) = 0.0 fqzb(i, 1, j) = 0.0 END DO CALL POPINTEGER4(i) END DO ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from53) CALL POPINTEGER4(ad_to53) DO j=ad_to53,ad_from53,-1 DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from52) CALL POPINTEGER4(ad_to52) DO i=ad_to52,ad_from52,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp47b6 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*temp47b6 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*temp47b6 fqzb(i, k, j) = 0.0 temp47b7 = dz*mu*fqzlb(i, k, j)/dt min71b = 0.5*field_old(i, k-1, j)*temp47b7 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min71*& & temp47b7 max52b = 0.5*field_old(i, k, j)*temp47b7 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max52*temp47b7 mub0 = (0.5*(min71*field_old(i, k-1, j))+0.5*(max52*field_old(& & i, k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max52) y102b = max52b ELSE CALL POPREAL8(max52) y102b = 0.0 END IF crb = y102b abs102b = -y102b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs102b ELSE crb = crb - abs102b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min71) y51b = min71b ELSE CALL POPREAL8(min71) y51b = 0.0 END IF crb = crb + y51b abs51b = y51b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs51b ELSE crb = crb - abs51b END IF temp47b5 = dt*crb/(dz*mu) velb = temp47b5 mub0 = mub0 - vel*temp47b5/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) END DO END DO CALL POPINTEGER4(ad_from51) CALL POPINTEGER4(ad_to51) DO i=ad_to51,ad_from51,-1 fqzlb(i, kde, j) = 0.0 fqzb(i, kde, j) = 0.0 fqzlb(i, 1, j) = 0.0 fqzb(i, 1, j) = 0.0 END DO CALL POPINTEGER4(i) END DO END IF CALL POPINTEGER4(j_end) CALL POPINTEGER4(i_end) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from34) CALL POPINTEGER4(ad_to34) DO i=ad_to34,ad_from34,-1 DO k=ktf,kts,-1 temp31b56 = -(rdy*tendencyb(i, k, j_end)) vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*& & temp31b56 field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*temp31b56 field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*& & temp31b56 fieldb(i, k, j_end) = fieldb(i, k, j_end) - rv(i, k, jte-1)*& & temp31b56 rvb(i, k, jte-1) = rvb(i, k, jte-1) - field(i, k, j_end)*& & temp31b56 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb END IF END DO END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from33) CALL POPINTEGER4(ad_to33) DO i=ad_to33,ad_from33,-1 DO k=ktf,kts,-1 temp31b55 = -(rdy*tendencyb(i, k, jts)) vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*temp31b55 field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*temp31b55 field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*temp31b55 fieldb(i, k, jts) = fieldb(i, k, jts) + rv(i, k, jts+1)*& & temp31b55 rvb(i, k, jts+1) = rvb(i, k, jts+1) + field(i, k, jts)*temp31b55 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb END IF END DO END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from32) CALL POPINTEGER4(ad_to32) DO i=ad_to32,ad_from32,-1 DO k=ktf,kts,-1 temp31b53 = -(rdy*tendencyb(i, k, j_end)) temp31b54 = field(i, k, j_end)*temp31b53 vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*& & temp31b53 field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*temp31b53 field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*& & temp31b53 fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i& & , k, jte-1))*temp31b53 rvb(i, k, jte) = rvb(i, k, jte) + temp31b54 rvb(i, k, jte-1) = rvb(i, k, jte-1) - temp31b54 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb END IF END DO END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from31) CALL POPINTEGER4(ad_to31) DO i=ad_to31,ad_from31,-1 DO k=ktf,kts,-1 temp31b51 = -(rdy*tendencyb(i, k, jts)) temp31b52 = field(i, k, jts)*temp31b51 vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*temp31b51 field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*temp31b51 field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*temp31b51 fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k& & , jts))*temp31b51 rvb(i, k, jts+1) = rvb(i, k, jts+1) + temp31b52 rvb(i, k, jts) = rvb(i, k, jts) - temp31b52 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb END IF END DO END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from30) CALL POPINTEGER4(ad_to30) DO j=ad_to30,ad_from30,-1 DO k=ktf,kts,-1 temp31b49 = -(rdx*tendencyb(i_end, k, j)) temp31b50 = field(i_end, k, j)*temp31b49 ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*& & temp31b49 field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*temp31b49 field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*& & temp31b49 fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(& & ite-1, k, j))*temp31b49 rub(ite, k, j) = rub(ite, k, j) + temp31b50 rub(ite-1, k, j) = rub(ite-1, k, j) - temp31b50 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from29) CALL POPINTEGER4(ad_to29) DO j=ad_to29,ad_from29,-1 DO k=ktf,kts,-1 temp31b47 = -(rdx*tendencyb(its, k, j)) temp31b48 = field(its, k, j)*temp31b47 ubb = (field_old(its+1, k, j)-field_old(its, k, j))*temp31b47 field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*temp31b47 field_oldb(its, k, j) = field_oldb(its, k, j) - ub*temp31b47 fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its& & , k, j))*temp31b47 rub(its+1, k, j) = rub(its+1, k, j) + temp31b48 rub(its, k, j) = rub(its, k, j) - temp31b48 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(its, k, j) = rub(its, k, j) + 0.5*ubb rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .NE. 0) THEN IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO j=ad_to20,ad_from20,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO i=ad_to19,ad_from19,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b8 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b8 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b8 fqxb(i, k, j) = 0.0 temp31b9 = dx*mu*fqxlb(i, k, j)/dt min52b = 0.5*field_old(i-1, k, j)*temp31b9 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min52*& & temp31b9 max35b = 0.5*field_old(i, k, j)*temp31b9 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max35*& & temp31b9 mub0 = (0.5*(min52*field_old(i-1, k, j))+0.5*(max35*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max35) y85b = max35b ELSE CALL POPREAL8(max35) y85b = 0.0 END IF crb = y85b abs85b = -y85b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs85b ELSE crb = crb - abs85b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min52) y34b = min52b ELSE CALL POPREAL8(min52) y34b = 0.0 END IF crb = crb + y34b abs34b = y34b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs34b ELSE crb = crb - abs34b END IF temp31b7 = dt*crb/(dx*mu) velb = temp31b7 mub0 = mub0 - vel*temp31b7/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END DO END DO CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO j=ad_to18,ad_from18,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO i=ad_to17,ad_from17,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp31b5 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b5 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b5 fqyb(i, k, j) = 0.0 temp31b6 = dy*mu*fqylb(i, k, j)/dt min51b = 0.5*field_old(i, k, j-1)*temp31b6 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min51*& & temp31b6 max34b = 0.5*field_old(i, k, j)*temp31b6 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max34*& & temp31b6 mub0 = (0.5*(min51*field_old(i, k, j-1))+0.5*(max34*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max34) y84b = max34b ELSE CALL POPREAL8(max34) y84b = 0.0 END IF crb = y84b abs84b = -y84b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs84b ELSE crb = crb - abs84b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min51) y33b = min51b ELSE CALL POPREAL8(min51) y33b = 0.0 END IF crb = crb + y33b abs33b = y33b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs33b ELSE crb = crb - abs33b END IF temp31b4 = dt*crb/(dy*mu) velb = temp31b4 mub0 = mub0 - vel*temp31b4/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END DO ELSE CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO j=ad_to16,ad_from16,-1 CALL POPCONTROL2B(branch) IF (branch .NE. 0) THEN IF (branch .NE. 1) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b2 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(& & i-1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b2 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b2 fqxb(i, k, j) = 0.0 temp31b3 = dx*mu*fqxlb(i, k, j)/dt min48b = 0.5*field_old(i-1, k, j)*temp31b3 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*& & min48*temp31b3 max33b = 0.5*field_old(i, k, j)*temp31b3 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max33*& & temp31b3 mub0 = (0.5*(min48*field_old(i-1, k, j))+0.5*(max33*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max33) y83b = max33b ELSE CALL POPREAL8(max33) y83b = 0.0 END IF crb = y83b abs83b = -y83b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs83b ELSE crb = crb - abs83b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min48) y32b = min48b ELSE CALL POPREAL8(min48) y32b = 0.0 END IF crb = crb + y32b abs32b = y32b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs32b ELSE crb = crb - abs32b END IF temp31b1 = dt*crb/(dx*mu) velb = temp31b1 mub0 = mub0 - vel*temp31b1/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO CALL POPINTEGER4(i) END IF END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b fqxb(i, k, j) = 0.0 temp31b0 = dx*mu*fqxlb(i, k, j)/dt min47b = 0.5*field_old(i-1, k, j)*temp31b0 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min47*& & temp31b0 max32b = 0.5*field_old(i, k, j)*temp31b0 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max32*& & temp31b0 mub0 = (0.5*(min47*field_old(i-1, k, j))+0.5*(max32*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max32) y82b = max32b ELSE CALL POPREAL8(max32) y82b = 0.0 END IF crb = y82b abs82b = -y82b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs82b ELSE crb = crb - abs82b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min47) y31b = min47b ELSE CALL POPREAL8(min47) y31b = 0.0 END IF crb = crb + y31b abs31b = y31b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs31b ELSE crb = crb - abs31b END IF velb = dt*crb/dx CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb/mu mub0 = mub0 - ru(i, k, j)*velb/mu**2 CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO CALL POPINTEGER4(i) END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp27 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp30 = SIGN(1., vel) temp29 = temp30/12. temp28 = SIGN(1, time_step) temp27b6 = vel*fqxb(i, k, j) temp27b7 = 7.*temp27b6/12. temp27b8 = temp28*temp29*temp27b6 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.+temp28*(temp29*temp27))& & *fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp27b7 - 3.*temp27b8 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp27b8 + & & temp27b7 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp27b8 - & & temp27b6/12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp27b8 - & & temp27b6/12. fqxb(i, k, j) = 0.0 temp27b9 = dx*mu*fqxlb(i, k, j)/dt min46b = 0.5*field_old(i-1, k, j)*temp27b9 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min46*& & temp27b9 max31b = 0.5*field_old(i, k, j)*temp27b9 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max31*& & temp27b9 mub0 = (0.5*(min46*field_old(i-1, k, j))+0.5*(max31*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max31) y81b = max31b ELSE CALL POPREAL8(max31) y81b = 0.0 END IF crb = y81b abs81b = -y81b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs81b ELSE crb = crb - abs81b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min46) y30b = min46b ELSE CALL POPREAL8(min46) y30b = 0.0 END IF crb = crb + y30b abs30b = y30b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs30b ELSE crb = crb - abs30b END IF temp27b5 = dt*crb/(dx*mu) velb = velb + temp27b5 mub0 = mub0 - vel*temp27b5/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO CALL POPINTEGER4(i) END DO END DO CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO j=ad_to15,ad_from15,-1 CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .NE. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp27b3 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+& & field(i, k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp27b3 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp27b3 fqyb(i, k, j) = 0.0 temp27b4 = dy*mu*fqylb(i, k, j)/dt min43b = 0.5*field_old(i, k, j-1)*temp27b4 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*& & min43*temp27b4 max30b = 0.5*field_old(i, k, j)*temp27b4 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max30*& & temp27b4 mub0 = (0.5*(min43*field_old(i, k, j-1))+0.5*(max30*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max30) y80b = max30b ELSE CALL POPREAL8(max30) y80b = 0.0 END IF crb = y80b abs80b = -y80b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs80b ELSE crb = crb - abs80b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min43) y29b = min43b ELSE CALL POPREAL8(min43) y29b = 0.0 END IF crb = crb + y29b abs29b = y29b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs29b ELSE crb = crb - abs29b END IF temp27b2 = dt*crb/(dy*mu) velb = temp27b2 mub0 = mub0 - vel*temp27b2/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp27b0 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(& & i, k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp27b0 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp27b0 fqyb(i, k, j) = 0.0 temp27b1 = dy*mu*fqylb(i, k, j)/dt min42b = 0.5*field_old(i, k, j-1)*temp27b1 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*& & min42*temp27b1 max29b = 0.5*field_old(i, k, j)*temp27b1 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max29*& & temp27b1 mub0 = (0.5*(min42*field_old(i, k, j-1))+0.5*(max29*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max29) y79b = max29b ELSE CALL POPREAL8(max29) y79b = 0.0 END IF crb = y79b abs79b = -y79b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs79b ELSE crb = crb - abs79b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min42) y28b = min42b ELSE CALL POPREAL8(min42) y28b = 0.0 END IF crb = crb + y28b abs28b = y28b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs28b ELSE crb = crb - abs28b END IF temp27b = dt*crb/(dy*mu) velb = temp27b mub0 = mub0 - vel*temp27b/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp23 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field& & (i, k, j)-field(i, k, j-1)) temp26 = SIGN(1., vel) temp25 = temp26/12. temp24 = SIGN(1, time_step) temp23b19 = vel*fqyb(i, k, j) temp23b20 = 7.*temp23b19/12. temp23b21 = temp24*temp25*temp23b19 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(& & field(i, k, j+1)+field(i, k, j-2))/12.+temp24*(temp25*& & temp23))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b20 - 3.*& & temp23b21 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp23b21 + & & temp23b20 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp23b21 - & & temp23b19/12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp23b21 - & & temp23b19/12. fqyb(i, k, j) = 0.0 temp23b22 = dy*mu*fqylb(i, k, j)/dt min41b = 0.5*field_old(i, k, j-1)*temp23b22 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*& & min41*temp23b22 max28b = 0.5*field_old(i, k, j)*temp23b22 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max28*& & temp23b22 mub0 = (0.5*(min41*field_old(i, k, j-1))+0.5*(max28*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max28) y78b = max28b ELSE CALL POPREAL8(max28) y78b = 0.0 END IF crb = y78b abs78b = -y78b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs78b ELSE crb = crb - abs78b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min41) y27b = min41b ELSE CALL POPREAL8(min41) y27b = 0.0 END IF crb = crb + y27b abs27b = y27b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs27b ELSE crb = crb - abs27b END IF temp23b18 = dt*crb/(dy*mu) velb = velb + temp23b18 mub0 = mub0 - vel*temp23b18/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END DO END IF END IF ELSE IF (branch .EQ. 3) THEN CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO j=ad_to11,ad_from11,-1 CALL POPCONTROL2B(branch) IF (branch .NE. 0) THEN IF (branch .NE. 1) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp23b16 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1& & , k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b16 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp23b16 fqxb(i, k, j) = 0.0 temp23b17 = dx*mu*fqxlb(i, k, j)/dt min38b = 0.5*field_old(i-1, k, j)*temp23b17 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min38*& & temp23b17 max27b = 0.5*field_old(i, k, j)*temp23b17 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max27*& & temp23b17 mub0 = (0.5*(min38*field_old(i-1, k, j))+0.5*(max27*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max27) y77b = max27b ELSE CALL POPREAL8(max27) y77b = 0.0 END IF crb = y77b abs77b = -y77b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs77b ELSE crb = crb - abs77b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min38) y26b = min38b ELSE CALL POPREAL8(min38) y26b = 0.0 END IF crb = crb + y26b abs26b = y26b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs26b ELSE crb = crb - abs26b END IF temp23b15 = dt*crb/(dx*mu) velb = temp23b15 mub0 = mub0 - vel*temp23b15/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO CALL POPINTEGER4(i) END IF END IF CALL POPCONTROL2B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp23b13 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1, k& & , j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b13 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp23b13 fqxb(i, k, j) = 0.0 temp23b14 = dx*mu*fqxlb(i, k, j)/dt min37b = 0.5*field_old(i-1, k, j)*temp23b14 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min37*& & temp23b14 max26b = 0.5*field_old(i, k, j)*temp23b14 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max26*& & temp23b14 mub0 = (0.5*(min37*field_old(i-1, k, j))+0.5*(max26*field_old(& & i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max26) y76b = max26b ELSE CALL POPREAL8(max26) y76b = 0.0 END IF crb = y76b abs76b = -y76b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs76b ELSE crb = crb - abs76b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min37) y25b = min37b ELSE CALL POPREAL8(min37) y25b = 0.0 END IF crb = crb + y25b abs25b = y25b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs25b ELSE crb = crb - abs25b END IF velb = dt*crb/dx CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb/mu mub0 = mub0 - ru(i, k, j)*velb/mu**2 CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO CALL POPINTEGER4(i) END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp23b10 = vel*fqxb(i, k, j) temp23b11 = 7.*temp23b10/12. velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(i+1& & , k, j)+field(i-2, k, j))/12.)*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b11 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp23b11 fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp23b10/12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp23b10/12. fqxb(i, k, j) = 0.0 temp23b12 = dx*mu*fqxlb(i, k, j)/dt min36b = 0.5*field_old(i-1, k, j)*temp23b12 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min36*& & temp23b12 max25b = 0.5*field_old(i, k, j)*temp23b12 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max25*& & temp23b12 mub0 = (0.5*(min36*field_old(i-1, k, j))+0.5*(max25*field_old(& & i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max25) y75b = max25b ELSE CALL POPREAL8(max25) y75b = 0.0 END IF crb = y75b abs75b = -y75b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs75b ELSE crb = crb - abs75b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min36) y24b = min36b ELSE CALL POPREAL8(min36) y24b = 0.0 END IF crb = crb + y24b abs24b = y24b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs24b ELSE crb = crb - abs24b END IF temp23b9 = dt*crb/(dx*mu) velb = velb + temp23b9 mub0 = mub0 - vel*temp23b9/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO CALL POPINTEGER4(i) END DO END DO CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO j=ad_to10,ad_from10,-1 CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .NE. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp23b7 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b7 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b7 fqyb(i, k, j) = 0.0 temp23b8 = dy*mu*fqylb(i, k, j)/dt min33b = 0.5*field_old(i, k, j-1)*temp23b8 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min33*& & temp23b8 max24b = 0.5*field_old(i, k, j)*temp23b8 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max24*& & temp23b8 mub0 = (0.5*(min33*field_old(i, k, j-1))+0.5*(max24*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max24) y74b = max24b ELSE CALL POPREAL8(max24) y74b = 0.0 END IF crb = y74b abs74b = -y74b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs74b ELSE crb = crb - abs74b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min33) y23b = min33b ELSE CALL POPREAL8(min33) y23b = 0.0 END IF crb = crb + y23b abs23b = y23b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs23b ELSE crb = crb - abs23b END IF temp23b6 = dt*crb/(dy*mu) velb = temp23b6 mub0 = mub0 - vel*temp23b6/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO i=ad_to8,ad_from8,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp23b4 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k& & , j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b4 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b4 fqyb(i, k, j) = 0.0 temp23b5 = dy*mu*fqylb(i, k, j)/dt min32b = 0.5*field_old(i, k, j-1)*temp23b5 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min32*& & temp23b5 max23b = 0.5*field_old(i, k, j)*temp23b5 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max23*& & temp23b5 mub0 = (0.5*(min32*field_old(i, k, j-1))+0.5*(max23*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max23) y73b = max23b ELSE CALL POPREAL8(max23) y73b = 0.0 END IF crb = y73b abs73b = -y73b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs73b ELSE crb = crb - abs73b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min32) y22b = min32b ELSE CALL POPREAL8(min32) y22b = 0.0 END IF crb = crb + y22b abs22b = y22b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs22b ELSE crb = crb - abs22b END IF temp23b3 = dt*crb/(dy*mu) velb = temp23b3 mub0 = mub0 - vel*temp23b3/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO i=ad_to7,ad_from7,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp23b0 = vel*fqyb(i, k, j) temp23b1 = 7.*temp23b0/12. velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i& & , k, j+1)+field(i, k, j-2))/12.)*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp23b1 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp23b1 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp23b0/12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp23b0/12. fqyb(i, k, j) = 0.0 temp23b2 = dy*mu*fqylb(i, k, j)/dt min31b = 0.5*field_old(i, k, j-1)*temp23b2 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min31*& & temp23b2 max22b = 0.5*field_old(i, k, j)*temp23b2 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max22*& & temp23b2 mub0 = (0.5*(min31*field_old(i, k, j-1))+0.5*(max22*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max22) y72b = max22b ELSE CALL POPREAL8(max22) y72b = 0.0 END IF crb = y72b abs72b = -y72b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs72b ELSE crb = crb - abs72b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min31) y21b = min31b ELSE CALL POPREAL8(min31) y21b = 0.0 END IF crb = crb + y21b abs21b = y21b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs21b ELSE crb = crb - abs21b END IF temp23b = dt*crb/(dy*mu) velb = velb + temp23b mub0 = mub0 - vel*temp23b/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END DO ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO j=ad_to6,ad_from6,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to5) DO i=ad_to5,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp19 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp22 = SIGN(1., vel) temp21 = temp22/12. temp20 = SIGN(1, time_step) temp19b3 = vel*fqxb(i, k, j) temp19b4 = 7.*temp19b3/12. temp19b5 = temp20*temp21*temp19b3 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.+temp20*(temp21*temp19))& & *fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp19b4 - 3.*temp19b5 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp19b5 + & & temp19b4 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp19b5 - & & temp19b3/12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp19b5 - & & temp19b3/12. fqxb(i, k, j) = 0.0 temp19b6 = dx*mu*fqxlb(i, k, j)/dt min28b = 0.5*field_old(i-1, k, j)*temp19b6 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min28*& & temp19b6 max21b = 0.5*field_old(i, k, j)*temp19b6 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max21*& & temp19b6 mub0 = (0.5*(min28*field_old(i-1, k, j))+0.5*(max21*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max21) y71b = max21b ELSE CALL POPREAL8(max21) y71b = 0.0 END IF crb = y71b abs71b = -y71b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs71b ELSE crb = crb - abs71b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min28) y20b = min28b ELSE CALL POPREAL8(min28) y20b = 0.0 END IF crb = crb + y20b abs20b = y20b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs20b ELSE crb = crb - abs20b END IF temp19b2 = dt*crb/(dx*mu) velb = velb + temp19b2 mub0 = mub0 - vel*temp19b2/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp19b0 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp19b0 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp19b0 fqxb(i, k, j) = 0.0 temp19b1 = dx*mu*fqxlb(i, k, j)/dt min27b = 0.5*field_old(i-1, k, j)*temp19b1 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min27*& & temp19b1 max20b = 0.5*field_old(i, k, j)*temp19b1 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max20*& & temp19b1 mub0 = (0.5*(min27*field_old(i-1, k, j))+0.5*(max20*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max20) y70b = max20b ELSE CALL POPREAL8(max20) y70b = 0.0 END IF crb = y70b abs70b = -y70b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs70b ELSE crb = crb - abs70b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min27) y19b = min27b ELSE CALL POPREAL8(min27) y19b = 0.0 END IF crb = crb + y19b abs19b = y19b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs19b ELSE crb = crb - abs19b END IF temp19b = dt*crb/(dx*mu) velb = temp19b mub0 = mub0 - vel*temp19b/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from5) DO i=i_start_f-1,ad_from5,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp15 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp18 = SIGN(1., vel) temp17 = temp18/12. temp16 = SIGN(1, time_step) temp15b2 = vel*fqxb(i, k, j) temp15b3 = 7.*temp15b2/12. temp15b4 = temp16*temp17*temp15b2 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.+temp16*(temp17*temp15))& & *fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp15b3 - 3.*temp15b4 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*temp15b4 + & & temp15b3 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp15b4 - & & temp15b2/12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp15b4 - & & temp15b2/12. fqxb(i, k, j) = 0.0 temp15b5 = dx*mu*fqxlb(i, k, j)/dt min26b = 0.5*field_old(i-1, k, j)*temp15b5 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min26*& & temp15b5 max19b = 0.5*field_old(i, k, j)*temp15b5 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max19*& & temp15b5 mub0 = (0.5*(min26*field_old(i-1, k, j))+0.5*(max19*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max19) y69b = max19b ELSE CALL POPREAL8(max19) y69b = 0.0 END IF crb = y69b abs69b = -y69b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs69b ELSE crb = crb - abs69b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min26) y18b = min26b ELSE CALL POPREAL8(min26) y18b = 0.0 END IF crb = crb + y18b abs18b = y18b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs18b ELSE crb = crb - abs18b END IF temp15b1 = dt*crb/(dx*mu) velb = velb + temp15b1 mub0 = mub0 - vel*temp15b1/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp15b = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp15b fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp15b fqxb(i, k, j) = 0.0 temp15b0 = dx*mu*fqxlb(i, k, j)/dt min25b = 0.5*field_old(i-1, k, j)*temp15b0 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min25*& & temp15b0 max18b = 0.5*field_old(i, k, j)*temp15b0 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max18*& & temp15b0 mub0 = (0.5*(min25*field_old(i-1, k, j))+0.5*(max18*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max18) y68b = max18b ELSE CALL POPREAL8(max18) y68b = 0.0 END IF crb = y68b abs68b = -y68b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs68b ELSE crb = crb - abs68b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min25) y17b = min25b ELSE CALL POPREAL8(min25) y17b = 0.0 END IF crb = crb + y17b abs17b = y17b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs17b ELSE crb = crb - abs17b END IF velb = dt*crb/dx CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb/mu mub0 = mub0 - ru(i, k, j)*velb/mu**2 CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp11 = field(i+2, k, j) - field(i-3, k, j) + 10.*(field(i, k& & , j)-field(i-1, k, j)) - 5.*(field(i+1, k, j)-field(i-2, k, & & j)) temp14 = SIGN(1., vel) temp13 = temp14/60. temp12 = SIGN(1, time_step) temp11b0 = vel*fqxb(i, k, j) temp11b1 = 37.*temp11b0/60. temp11b2 = -(2.*temp11b0/15.) temp11b3 = -(temp12*temp13*temp11b0) velb = (37.*((field(i, k, j)+field(i-1, k, j))/60.)-2.*((field& & (i+1, k, j)+field(i-2, k, j))/15.)+(field(i+2, k, j)+field(i& & -3, k, j))/60.-temp12*(temp13*temp11))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + 10.*temp11b3 + temp11b1 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp11b1 - 10.*& & temp11b3 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp11b2 - 5.*temp11b3 fieldb(i-2, k, j) = fieldb(i-2, k, j) + 5.*temp11b3 + temp11b2 fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp11b3 + temp11b0/& & 60. fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp11b0/60. - & & temp11b3 fqxb(i, k, j) = 0.0 temp11b4 = dx*mu*fqxlb(i, k, j)/dt min24b = 0.5*field_old(i-1, k, j)*temp11b4 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min24*& & temp11b4 max17b = 0.5*field_old(i, k, j)*temp11b4 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max17*temp11b4 mub0 = (0.5*(min24*field_old(i-1, k, j))+0.5*(max17*field_old(& & i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max17) y67b = max17b ELSE CALL POPREAL8(max17) y67b = 0.0 END IF crb = y67b abs67b = -y67b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs67b ELSE crb = crb - abs67b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min24) y16b = min24b ELSE CALL POPREAL8(min24) y16b = 0.0 END IF crb = crb + y16b abs16b = y16b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs16b ELSE crb = crb - abs16b END IF temp11b = dt*crb/(dx*mu) velb = velb + temp11b mub0 = mub0 - vel*temp11b/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END DO END DO CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO j=ad_to4,ad_from4,-1 CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .NE. 0) THEN IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp7 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(& & i, k, j)-field(i, k, j-1)) temp10 = SIGN(1., vel) temp9 = temp10/12. temp8 = SIGN(1, time_step) temp7b3 = vel*fqyb(i, k, j) temp7b4 = 7.*temp7b3/12. temp7b5 = temp8*temp9*temp7b3 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(& & field(i, k, j+1)+field(i, k, j-2))/12.+temp8*(temp9*& & temp7))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp7b4 - 3.*temp7b5 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp7b5 + & & temp7b4 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp7b5 - & & temp7b3/12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp7b5 - & & temp7b3/12. fqyb(i, k, j) = 0.0 temp7b6 = dy*mu*fqylb(i, k, j)/dt min21b = 0.5*field_old(i, k, j-1)*temp7b6 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*& & min21*temp7b6 max16b = 0.5*field_old(i, k, j)*temp7b6 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max16*& & temp7b6 mub0 = (0.5*(min21*field_old(i, k, j-1))+0.5*(max16*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max16) y66b = max16b ELSE CALL POPREAL8(max16) y66b = 0.0 END IF crb = y66b abs66b = -y66b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs66b ELSE crb = crb - abs66b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min21) y15b = min21b ELSE CALL POPREAL8(min21) y15b = 0.0 END IF crb = crb + y15b abs15b = y15b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs15b ELSE crb = crb - abs15b END IF temp7b2 = dt*crb/(dy*mu) velb = velb + temp7b2 mub0 = mub0 - vel*temp7b2/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp7b0 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(& & i, k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp7b0 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp7b0 fqyb(i, k, j) = 0.0 temp7b1 = dy*mu*fqylb(i, k, j)/dt min20b = 0.5*field_old(i, k, j-1)*temp7b1 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*& & min20*temp7b1 max15b = 0.5*field_old(i, k, j)*temp7b1 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max15*& & temp7b1 mub0 = (0.5*(min20*field_old(i, k, j-1))+0.5*(max15*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max15) y65b = max15b ELSE CALL POPREAL8(max15) y65b = 0.0 END IF crb = y65b abs65b = -y65b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs65b ELSE crb = crb - abs65b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min20) y14b = min20b ELSE CALL POPREAL8(min20) y14b = 0.0 END IF crb = crb + y14b abs14b = y14b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs14b ELSE crb = crb - abs14b END IF temp7b = dt*crb/(dy*mu) velb = temp7b mub0 = mub0 - vel*temp7b/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp3 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k& & , j)-field(i, k, j-1)) temp6 = SIGN(1., vel) temp5 = temp6/12. temp4 = SIGN(1, time_step) temp3b3 = vel*fqyb(i, k, j) temp3b4 = 7.*temp3b3/12. temp3b5 = temp4*temp5*temp3b3 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i& & , k, j+1)+field(i, k, j-2))/12.+temp4*(temp5*temp3))*fqyb(& & i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp3b4 - 3.*temp3b5 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*temp3b5 + temp3b4 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp3b5 - temp3b3/& & 12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp3b5 - temp3b3/& & 12. fqyb(i, k, j) = 0.0 temp3b6 = dy*mu*fqylb(i, k, j)/dt min19b = 0.5*field_old(i, k, j-1)*temp3b6 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min19*& & temp3b6 max14b = 0.5*field_old(i, k, j)*temp3b6 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max14*& & temp3b6 mub0 = (0.5*(min19*field_old(i, k, j-1))+0.5*(max14*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max14) y64b = max14b ELSE CALL POPREAL8(max14) y64b = 0.0 END IF crb = y64b abs64b = -y64b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs64b ELSE crb = crb - abs64b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min19) y13b = min19b ELSE CALL POPREAL8(min19) y13b = 0.0 END IF crb = crb + y13b abs13b = y13b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs13b ELSE crb = crb - abs13b END IF temp3b2 = dt*crb/(dy*mu) velb = velb + temp3b2 mub0 = mub0 - vel*temp3b2/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp3b0 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k& & , j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp3b0 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp3b0 fqyb(i, k, j) = 0.0 temp3b1 = dy*mu*fqylb(i, k, j)/dt min18b = 0.5*field_old(i, k, j-1)*temp3b1 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min18*& & temp3b1 max13b = 0.5*field_old(i, k, j)*temp3b1 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max13*& & temp3b1 mub0 = (0.5*(min18*field_old(i, k, j-1))+0.5*(max13*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max13) y63b = max13b ELSE CALL POPREAL8(max13) y63b = 0.0 END IF crb = y63b abs63b = -y63b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs63b ELSE crb = crb - abs63b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min18) y12b = min18b ELSE CALL POPREAL8(min18) y12b = 0.0 END IF crb = crb + y12b abs12b = y12b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs12b ELSE crb = crb - abs12b END IF temp3b = dt*crb/(dy*mu) velb = temp3b mub0 = mub0 - vel*temp3b/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp = field(i, k, j+2) - field(i, k, j-3) + 10.*(field(i, k& & , j)-field(i, k, j-1)) - 5.*(field(i, k, j+1)-field(i, k, & & j-2)) temp2 = SIGN(1., vel) temp1 = temp2/60. temp0 = SIGN(1, time_step) tempb0 = vel*fqyb(i, k, j) tempb1 = 37.*tempb0/60. tempb2 = -(2.*tempb0/15.) tempb3 = -(temp0*temp1*tempb0) velb = (37.*((field(i, k, j)+field(i, k, j-1))/60.)-2.*((& & field(i, k, j+1)+field(i, k, j-2))/15.)+(field(i, k, j+2)+& & field(i, k, j-3))/60.-temp0*(temp1*temp))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + 10.*tempb3 + tempb1 fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb1 - 10.*tempb3 fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb2 - 5.*tempb3 fieldb(i, k, j-2) = fieldb(i, k, j-2) + 5.*tempb3 + tempb2 fieldb(i, k, j+2) = fieldb(i, k, j+2) + tempb3 + tempb0/60. fieldb(i, k, j-3) = fieldb(i, k, j-3) + tempb0/60. - tempb3 fqyb(i, k, j) = 0.0 tempb4 = dy*mu*fqylb(i, k, j)/dt min17b = 0.5*field_old(i, k, j-1)*tempb4 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min17*& & tempb4 max12b = 0.5*field_old(i, k, j)*tempb4 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max12*tempb4 mub0 = (0.5*(min17*field_old(i, k, j-1))+0.5*(max12*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max12) y62b = max12b ELSE CALL POPREAL8(max12) y62b = 0.0 END IF crb = y62b abs62b = -y62b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs62b ELSE crb = crb - abs62b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min17) y11b = min17b ELSE CALL POPREAL8(min17) y11b = 0.0 END IF crb = crb + y11b abs11b = y11b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs11b ELSE crb = crb - abs11b END IF tempb = dt*crb/(dy*mu) velb = velb + tempb mub0 = mub0 - vel*tempb/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END DO ELSE CALL POPINTEGER4(ad_from28) CALL POPINTEGER4(ad_to28) DO j=ad_to28,ad_from28,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to27) DO i=ad_to27,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b44 = vel*fqxb(i, k, j) temp31b45 = 7.*temp31b44/12. velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.)*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b45 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b45 fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b44/12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b44/12. fqxb(i, k, j) = 0.0 temp31b46 = dx*mu*fqxlb(i, k, j)/dt min14b = 0.5*field_old(i-1, k, j)*temp31b46 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min14*& & temp31b46 max11b = 0.5*field_old(i, k, j)*temp31b46 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max11*& & temp31b46 mub0 = (0.5*(min14*field_old(i-1, k, j))+0.5*(max11*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max11) y61b = max11b ELSE CALL POPREAL8(max11) y61b = 0.0 END IF crb = y61b abs61b = -y61b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs61b ELSE crb = crb - abs61b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min14) y10b = min14b ELSE CALL POPREAL8(min14) y10b = 0.0 END IF crb = crb + y10b abs10b = y10b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs10b ELSE crb = crb - abs10b END IF temp31b43 = dt*crb/(dx*mu) velb = velb + temp31b43 mub0 = mub0 - vel*temp31b43/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b41 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b41 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b41 fqxb(i, k, j) = 0.0 temp31b42 = dx*mu*fqxlb(i, k, j)/dt min13b = 0.5*field_old(i-1, k, j)*temp31b42 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min13*& & temp31b42 max10b = 0.5*field_old(i, k, j)*temp31b42 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max10*& & temp31b42 mub0 = (0.5*(min13*field_old(i-1, k, j))+0.5*(max10*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max10) y60b = max10b ELSE CALL POPREAL8(max10) y60b = 0.0 END IF crb = y60b abs60b = -y60b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs60b ELSE crb = crb - abs60b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min13) y9b = min13b ELSE CALL POPREAL8(min13) y9b = 0.0 END IF crb = crb + y9b abs9b = y9b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs9b ELSE crb = crb - abs9b END IF temp31b40 = dt*crb/(dx*mu) velb = temp31b40 mub0 = mub0 - vel*temp31b40/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from27) DO i=i_start_f-1,ad_from27,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b37 = vel*fqxb(i, k, j) temp31b38 = 7.*temp31b37/12. velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.)*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b38 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b38 fieldb(i+1, k, j) = fieldb(i+1, k, j) - temp31b37/12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - temp31b37/12. fqxb(i, k, j) = 0.0 temp31b39 = dx*mu*fqxlb(i, k, j)/dt min12b = 0.5*field_old(i-1, k, j)*temp31b39 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min12*& & temp31b39 max9b = 0.5*field_old(i, k, j)*temp31b39 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max9*& & temp31b39 mub0 = (0.5*(min12*field_old(i-1, k, j))+0.5*(max9*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max9) y59b = max9b ELSE CALL POPREAL8(max9) y59b = 0.0 END IF crb = y59b abs59b = -y59b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs59b ELSE crb = crb - abs59b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min12) y8b = min12b ELSE CALL POPREAL8(min12) y8b = 0.0 END IF crb = crb + y8b abs8b = y8b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs8b ELSE crb = crb - abs8b END IF temp31b36 = dt*crb/(dx*mu) velb = velb + temp31b36 mub0 = mub0 - vel*temp31b36/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b34 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b34 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b34 fqxb(i, k, j) = 0.0 temp31b35 = dx*mu*fqxlb(i, k, j)/dt min11b = 0.5*field_old(i-1, k, j)*temp31b35 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min11*& & temp31b35 max8b = 0.5*field_old(i, k, j)*temp31b35 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max8*& & temp31b35 mub0 = (0.5*(min11*field_old(i-1, k, j))+0.5*(max8*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max8) y58b = max8b ELSE CALL POPREAL8(max8) y58b = 0.0 END IF crb = y58b abs58b = -y58b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs58b ELSE crb = crb - abs58b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min11) y7b = min11b ELSE CALL POPREAL8(min11) y7b = 0.0 END IF crb = crb + y7b abs7b = y7b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs7b ELSE crb = crb - abs7b END IF velb = dt*crb/dx CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb/mu mub0 = mub0 - ru(i, k, j)*velb/mu**2 CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp31b30 = vel*fqxb(i, k, j) temp31b31 = 37.*temp31b30/60. temp31b32 = -(2.*temp31b30/15.) velb = (37.*((field(i, k, j)+field(i-1, k, j))/60.)-2.*((field& & (i+1, k, j)+field(i-2, k, j))/15.)+(field(i+2, k, j)+field(i& & -3, k, j))/60.)*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b31 fieldb(i-1, k, j) = fieldb(i-1, k, j) + temp31b31 fieldb(i+1, k, j) = fieldb(i+1, k, j) + temp31b32 fieldb(i-2, k, j) = fieldb(i-2, k, j) + temp31b32 fieldb(i+2, k, j) = fieldb(i+2, k, j) + temp31b30/60. fieldb(i-3, k, j) = fieldb(i-3, k, j) + temp31b30/60. fqxb(i, k, j) = 0.0 temp31b33 = dx*mu*fqxlb(i, k, j)/dt min10b = 0.5*field_old(i-1, k, j)*temp31b33 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min10*& & temp31b33 max7b = 0.5*field_old(i, k, j)*temp31b33 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max7*temp31b33 mub0 = (0.5*(min10*field_old(i-1, k, j))+0.5*(max7*field_old(i& & , k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max7) y57b = max7b ELSE CALL POPREAL8(max7) y57b = 0.0 END IF crb = y57b abs57b = -y57b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs57b ELSE crb = crb - abs57b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min10) y6b = min10b ELSE CALL POPREAL8(min10) y6b = 0.0 END IF crb = crb + y6b abs6b = y6b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs6b ELSE crb = crb - abs6b END IF temp31b29 = dt*crb/(dx*mu) velb = velb + temp31b29 mub0 = mub0 - vel*temp31b29/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END DO END DO CALL POPINTEGER4(ad_from26) CALL POPINTEGER4(ad_to26) DO j=ad_to26,ad_from26,-1 CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .NE. 0) THEN IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from25) CALL POPINTEGER4(ad_to25) DO i=ad_to25,ad_from25,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp31b26 = vel*fqyb(i, k, j) temp31b27 = 7.*temp31b26/12. velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(& & field(i, k, j+1)+field(i, k, j-2))/12.)*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b27 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b27 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b26/12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b26/12. fqyb(i, k, j) = 0.0 temp31b28 = dy*mu*fqylb(i, k, j)/dt min7b = 0.5*field_old(i, k, j-1)*temp31b28 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min7& & *temp31b28 max6b = 0.5*field_old(i, k, j)*temp31b28 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max6*& & temp31b28 mub0 = (0.5*(min7*field_old(i, k, j-1))+0.5*(max6*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max6) y56b = max6b ELSE CALL POPREAL8(max6) y56b = 0.0 END IF crb = y56b abs56b = -y56b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs56b ELSE crb = crb - abs56b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min7) y5b = min7b ELSE CALL POPREAL8(min7) y5b = 0.0 END IF crb = crb + y5b abs5b = y5b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs5b ELSE crb = crb - abs5b END IF temp31b25 = dt*crb/(dy*mu) velb = velb + temp31b25 mub0 = mub0 - vel*temp31b25/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from24) CALL POPINTEGER4(ad_to24) DO i=ad_to24,ad_from24,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp31b23 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(& & i, k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b23 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b23 fqyb(i, k, j) = 0.0 temp31b24 = dy*mu*fqylb(i, k, j)/dt min6b = 0.5*field_old(i, k, j-1)*temp31b24 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min6& & *temp31b24 max5b = 0.5*field_old(i, k, j)*temp31b24 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max5*& & temp31b24 mub0 = (0.5*(min6*field_old(i, k, j-1))+0.5*(max5*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max5) y55b = max5b ELSE CALL POPREAL8(max5) y55b = 0.0 END IF crb = y55b abs55b = -y55b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs55b ELSE crb = crb - abs55b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min6) y4b = min6b ELSE CALL POPREAL8(min6) y4b = 0.0 END IF crb = crb + y4b abs4b = y4b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs4b ELSE crb = crb - abs4b END IF temp31b22 = dt*crb/(dy*mu) velb = temp31b22 mub0 = mub0 - vel*temp31b22/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp31b19 = vel*fqyb(i, k, j) temp31b20 = 7.*temp31b19/12. velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i& & , k, j+1)+field(i, k, j-2))/12.)*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b20 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b20 fieldb(i, k, j+1) = fieldb(i, k, j+1) - temp31b19/12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - temp31b19/12. fqyb(i, k, j) = 0.0 temp31b21 = dy*mu*fqylb(i, k, j)/dt min5b = 0.5*field_old(i, k, j-1)*temp31b21 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min5*& & temp31b21 max4b = 0.5*field_old(i, k, j)*temp31b21 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max4*& & temp31b21 mub0 = (0.5*(min5*field_old(i, k, j-1))+0.5*(max4*field_old(& & i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max4) y54b = max4b ELSE CALL POPREAL8(max4) y54b = 0.0 END IF crb = y54b abs54b = -y54b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs54b ELSE crb = crb - abs54b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min5) y3b = min5b ELSE CALL POPREAL8(min5) y3b = 0.0 END IF crb = crb + y3b abs3b = y3b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs3b ELSE crb = crb - abs3b END IF temp31b18 = dt*crb/(dy*mu) velb = velb + temp31b18 mub0 = mub0 - vel*temp31b18/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO i=ad_to22,ad_from22,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp31b16 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k& & , j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b16 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b16 fqyb(i, k, j) = 0.0 temp31b17 = dy*mu*fqylb(i, k, j)/dt min4b = 0.5*field_old(i, k, j-1)*temp31b17 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min4*& & temp31b17 max3b = 0.5*field_old(i, k, j)*temp31b17 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max3*& & temp31b17 mub0 = (0.5*(min4*field_old(i, k, j-1))+0.5*(max3*field_old(& & i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max3) y53b = max3b ELSE CALL POPREAL8(max3) y53b = 0.0 END IF crb = y53b abs53b = -y53b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs53b ELSE crb = crb - abs53b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min4) y2b = min4b ELSE CALL POPREAL8(min4) y2b = 0.0 END IF crb = crb + y2b abs2b = y2b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs2b ELSE crb = crb - abs2b END IF temp31b15 = dt*crb/(dy*mu) velb = temp31b15 mub0 = mub0 - vel*temp31b15/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO i=ad_to21,ad_from21,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp31b11 = vel*fqyb(i, k, j) temp31b12 = 37.*temp31b11/60. temp31b13 = -(2.*temp31b11/15.) velb = (37.*((field(i, k, j)+field(i, k, j-1))/60.)-2.*((& & field(i, k, j+1)+field(i, k, j-2))/15.)+(field(i, k, j+2)+& & field(i, k, j-3))/60.)*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + temp31b12 fieldb(i, k, j-1) = fieldb(i, k, j-1) + temp31b12 fieldb(i, k, j+1) = fieldb(i, k, j+1) + temp31b13 fieldb(i, k, j-2) = fieldb(i, k, j-2) + temp31b13 fieldb(i, k, j+2) = fieldb(i, k, j+2) + temp31b11/60. fieldb(i, k, j-3) = fieldb(i, k, j-3) + temp31b11/60. fqyb(i, k, j) = 0.0 temp31b14 = dy*mu*fqylb(i, k, j)/dt min3b = 0.5*field_old(i, k, j-1)*temp31b14 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min3*& & temp31b14 max2b = 0.5*field_old(i, k, j)*temp31b14 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max2*& & temp31b14 mub0 = (0.5*(min3*field_old(i, k, j-1))+0.5*(max2*field_old(& & i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max2) y52b = max2b ELSE CALL POPREAL8(max2) y52b = 0.0 END IF crb = y52b abs52b = -y52b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs52b ELSE crb = crb - abs52b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min3) y1b = min3b ELSE CALL POPREAL8(min3) y1b = 0.0 END IF crb = crb + y1b abs1b = y1b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs1b ELSE crb = crb - abs1b END IF temp31b10 = dt*crb/(dy*mu) velb = velb + temp31b10 mub0 = mub0 - vel*temp31b10/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END DO END IF END SUBROUTINE A_ADVECT_SCALAR_PD ! Generated by TAPENADE (INRIA, Ecuador team) ! Tapenade 3.12 (r6213) - 13 Oct 2016 10:54 ! ! Differentiation of advect_scalar_wenopd in reverse (adjoint) mode: ! gradient of useful results: rom field tendency ru rv mu_old ! field_old mut ! with respect to varying inputs: rom field tendency ru rv mu_old ! field_old mut ! RW status of diff variables: rom:incr field:incr tendency:in-out ! ru:incr rv:incr mu_old:incr field_old:incr mut:incr SUBROUTINE A_ADVECT_SCALAR_WENOPD(field, fieldb, field_old, field_oldb, & & tendency, tendencyb, ru, rub, rv, rvb, rom, romb, mut, mutb, mub, & & mu_old, mu_oldb, time_step, config_flags, msfux, msfuy, msfvx, msfvy, & & msftx, msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, & & kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, & & field_old, ru, rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub& & , rvb, romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old REAL, DIMENSION(ims:ime, jms:jme) :: mutb, mu_oldb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy, dt INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, mu REAL :: ubb, vbb, mub0 ! storage for high and low order fluxes REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqx, fqy, fqz REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxb, fqyb, fqzb REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxl, fqyl, fqzl REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxlb, fqylb, & & fqzlb INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outb, & & ph_lowb REAL :: scale REAL :: scaleb REAL, PARAMETER :: eps=1.e-20 REAL :: dir, vv REAL :: ue, vs, vn, wb, wt REAL, PARAMETER :: f30=7./12., f31=1./12. REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60. REAL :: qim2, qim1, qi, qip1, qip2 REAL :: qim2b, qim1b, qib, qip1b, qip2b DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, & & sumwk DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b& & , wi2b, sumwkb DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=& & 3.d0/10.d0, eps1=1.0d-28 INTEGER, PARAMETER :: pw=2 ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6, flux_upwind REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr REAL :: velb, crb ! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & ! +0.5*(1.-sign(1.,cr))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0. REAL :: dx, dy, dz LOGICAL, PARAMETER :: pd_limit=.true. INTEGER :: min1 INTEGER :: min2 REAL :: min3 REAL :: min3b REAL :: min4 REAL :: min4b REAL :: min5 REAL :: min5b REAL :: min6 REAL :: min6b REAL :: min7 REAL :: min7b INTEGER :: min8 INTEGER :: min9 REAL :: min10 REAL :: min10b REAL :: min11 REAL :: min11b REAL :: min12 REAL :: min12b REAL :: min13 REAL :: min13b REAL :: min14 REAL :: min14b INTEGER :: min15 INTEGER :: min16 REAL :: min17 REAL :: min17b REAL :: min18 REAL :: min18b REAL :: min19 REAL :: min19b REAL :: min20 REAL :: min20b REAL :: min21 REAL :: min21b INTEGER :: min22 INTEGER :: min23 REAL :: max1 REAL :: max1b REAL :: abs0 REAL :: abs0b REAL :: max2 REAL :: max2b REAL :: abs1 REAL :: abs1b REAL :: max3 REAL :: max3b REAL :: abs2 REAL :: abs2b REAL :: max4 REAL :: max4b REAL :: abs3 REAL :: abs3b REAL :: max5 REAL :: max5b REAL :: abs4 REAL :: abs4b REAL :: max6 REAL :: max6b REAL :: abs5 REAL :: abs5b REAL :: max7 REAL :: max7b REAL :: abs6 REAL :: abs6b REAL :: max8 REAL :: max8b REAL :: abs7 REAL :: abs7b REAL :: max9 REAL :: max9b REAL :: abs8 REAL :: abs8b REAL :: max10 REAL :: max10b REAL :: abs9 REAL :: abs9b REAL :: max11 REAL :: max11b REAL :: abs10 REAL :: abs10b REAL :: max12 REAL :: max12b REAL :: abs11 REAL :: abs11b REAL :: max13 REAL :: max13b REAL :: abs12 REAL :: abs12b REAL :: max14 REAL :: max14b REAL :: abs13 REAL :: abs13b REAL :: max15 REAL :: max15b REAL :: abs14 REAL :: abs14b REAL :: max16 REAL :: max16b REAL :: min24 REAL :: min24b REAL :: abs15 REAL :: abs15b REAL :: abs16 REAL :: abs16b REAL :: abs17 REAL :: abs17b REAL :: abs18 REAL :: abs18b REAL :: abs19 REAL :: abs19b REAL :: abs20 REAL :: abs20b REAL :: abs21 REAL :: abs21b REAL :: abs22 REAL :: abs22b REAL :: abs23 REAL :: abs23b REAL :: abs24 REAL :: abs24b REAL :: abs25 REAL :: abs25b REAL :: abs26 REAL :: abs26b REAL :: abs27 REAL :: abs27b REAL :: abs28 REAL :: abs28b REAL :: abs29 REAL :: abs29b REAL :: max17 REAL :: max17b REAL :: min25 REAL :: min25b REAL :: min26 REAL :: min26b REAL :: max18 REAL :: max18b REAL :: tempb REAL :: y1b REAL :: y17b REAL :: tempb0 DOUBLE PRECISION :: temp DOUBLE PRECISION :: temp0 DOUBLE PRECISION :: temp1 DOUBLE PRECISION :: tempb1 DOUBLE PRECISION :: tempb2 REAL :: tempb3 REAL :: tempb4 REAL :: tempb5 REAL :: tempb6 REAL :: tempb7 REAL :: tempb8 REAL :: tempb9 REAL :: y2b REAL :: y18b REAL :: tempb10 REAL :: tempb11 REAL :: tempb12 REAL :: y3b REAL :: y19b REAL :: temp2 REAL :: temp3 REAL :: temp4 REAL :: temp5 REAL :: tempb13 REAL :: tempb14 REAL :: tempb15 REAL :: tempb16 REAL :: tempb17 REAL :: y4b REAL :: y20b REAL :: tempb18 REAL :: tempb19 REAL :: tempb20 REAL :: y5b REAL :: y21b REAL :: temp6 REAL :: temp7 REAL :: temp8 REAL :: temp9 REAL :: tempb21 REAL :: tempb22 REAL :: tempb23 REAL :: tempb24 REAL :: tempb25 REAL :: y6b REAL :: y22b REAL :: tempb26 DOUBLE PRECISION :: temp10 DOUBLE PRECISION :: temp11 DOUBLE PRECISION :: temp12 DOUBLE PRECISION :: tempb27 DOUBLE PRECISION :: tempb28 REAL :: tempb29 REAL :: tempb30 REAL :: tempb31 REAL :: tempb32 REAL :: tempb33 REAL :: tempb34 REAL :: y7b REAL :: y23b REAL :: tempb35 REAL :: tempb36 REAL :: tempb37 REAL :: y8b REAL :: y24b REAL :: temp13 REAL :: temp14 REAL :: temp15 REAL :: temp16 REAL :: tempb38 REAL :: tempb39 REAL :: tempb40 REAL :: tempb41 REAL :: tempb42 REAL :: y9b REAL :: y25b REAL :: tempb43 REAL :: tempb44 REAL :: tempb45 REAL :: y10b REAL :: y26b REAL :: temp17 REAL :: temp18 REAL :: temp19 REAL :: temp20 REAL :: tempb46 REAL :: tempb47 REAL :: tempb48 REAL :: tempb49 REAL :: tempb50 REAL :: tempb51 REAL :: tempb52 REAL :: tempb53 REAL :: tempb54 REAL :: tempb55 REAL :: tempb56 REAL :: tempb57 REAL :: tempb58 REAL :: tempb59 REAL :: tempb60 REAL :: y11b REAL :: y27b REAL :: tempb61 DOUBLE PRECISION :: temp21 DOUBLE PRECISION :: temp22 DOUBLE PRECISION :: temp23 DOUBLE PRECISION :: tempb62 DOUBLE PRECISION :: tempb63 REAL :: tempb64 REAL :: tempb65 REAL :: tempb66 REAL :: tempb67 REAL :: tempb68 REAL :: tempb69 REAL :: tempb70 REAL :: y12b REAL :: y28b REAL :: tempb71 REAL :: tempb72 REAL :: tempb73 REAL :: y13b REAL :: y29b REAL :: temp24 REAL :: temp25 REAL :: temp26 REAL :: temp27 REAL :: tempb74 REAL :: tempb75 REAL :: tempb76 REAL :: tempb77 REAL :: tempb78 REAL :: y14b REAL :: y30b REAL :: temp28 REAL :: temp29 REAL :: temp30 REAL :: temp31 REAL :: tempb79 REAL :: tempb80 REAL :: tempb81 REAL :: tempb82 REAL :: tempb83 REAL :: y15b REAL :: y31b REAL :: tempb84 REAL :: tempb85 REAL :: tempb86 REAL :: tempb87 REAL :: tempb88 REAL :: tempb89 REAL :: temp32 REAL :: y16b REAL :: tempb90 REAL :: tempb91 REAL :: tempb92 INTEGER :: branch INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 INTEGER :: ad_from24 INTEGER :: ad_to24 INTEGER :: ad_from25 INTEGER :: ad_to25 INTEGER :: ad_from26 INTEGER :: ad_to26 REAL :: y29 REAL :: y28 REAL :: y27 REAL :: y26 REAL :: y25 REAL :: y24 REAL :: y23 REAL :: y22 REAL :: y21 REAL :: y20 REAL :: y19 REAL :: y18 REAL :: y17 REAL :: y16 REAL :: y15 REAL :: y14 REAL :: y13 REAL :: y12 REAL :: y11 REAL :: y10 REAL :: y31 REAL :: y30 REAL :: y9 REAL :: y8 REAL :: y7 REAL :: y6 REAL :: y5 REAL :: y4 REAL :: y3 REAL :: y2 REAL :: y1 ! set order for the advection schemes ! write(6,*) ' in pd advection routine ' ! Empty arrays just in case: IF (config_flags%polar) THEN fqx(:, :, :) = 0. fqy(:, :, :) = 0. fqz(:, :, :) = 0. fqxl(:, :, :) = 0. fqyl(:, :, :) = 0. fqzl(:, :, :) = 0. END IF ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. ! begin with horizontal flux divergence ! here is the choice of flux operators ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF( horz_order == 5 ) THEN IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its & & .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite & & .LT. ide - 4) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts & & .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte & & .LT. jde - 4) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its - 1 IF (ite .GT. ide - 1) THEN min1 = ide - 1 ELSE min1 = ite END IF i_end = min1 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min2 = jde - 1 ELSE min2 = jte END IF j_end = min2 + 1 j_start_f = j_start j_end_f = j_end + 1 !-- modify loop bounds if open or specified ! IF(degrade_xs) i_start = MAX(its-1,ids-1) ! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN CALL PUSHCONTROL1B(1) i_start = ids ELSE CALL PUSHCONTROL1B(1) i_start = its - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN CALL PUSHCONTROL1B(1) i_end = ide - 1 ELSE CALL PUSHCONTROL1B(1) i_end = ite + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN CALL PUSHCONTROL1B(0) j_start = jds + 1 ELSE CALL PUSHCONTROL1B(0) j_start = jts - 1 END IF j_start_f = jds + 3 ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN CALL PUSHCONTROL1B(1) j_end = jde - 2 ELSE CALL PUSHCONTROL1B(1) j_end = jte + 1 END IF j_end_f = jde - 3 ELSE CALL PUSHCONTROL1B(0) END IF ad_from4 = j_start ! compute fluxes, 5th order j_loop_y_flux_5:DO j=ad_from4,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from = i_start DO i=ad_from,i_end ! ADT eqn 48 d/dy CALL PUSHREAL8(dy) dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs0 = cr CALL PUSHCONTROL1B(0) ELSE abs0 = -cr CALL PUSHCONTROL1B(1) END IF y1 = cr + abs0 IF (1.0 .GT. y1) THEN CALL PUSHREAL8(min3) min3 = y1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min3) min3 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs15 = cr CALL PUSHCONTROL1B(0) ELSE abs15 = -cr CALL PUSHCONTROL1B(1) END IF y17 = cr - abs15 IF (-1.0 .LT. y17) THEN CALL PUSHREAL8(max2) max2 = y17 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max2) max2 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+0.5*& & max2*field_old(i, k, j)) IF (vel*SIGN(1, time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = field(i, k, j+1) CALL PUSHREAL8(qip1) qip1 = field(i, k, j) CALL PUSHREAL8(qi) qi = field(i, k, j-1) CALL PUSHREAL8(qim1) qim1 = field(i, k, j-2) CALL PUSHREAL8(qim2) qim2 = field(i, k, j-3) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = field(i, k, j-2) CALL PUSHREAL8(qip1) qip1 = field(i, k, j-1) CALL PUSHREAL8(qi) qi = field(i, k, j) CALL PUSHREAL8(qim1) qim1 = field(i, k, j+1) CALL PUSHREAL8(qim2) qim2 = field(i, k, j+2) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*& & qi)**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*& & qi)**2 wi0 = gi0/(eps1+beta0)**pw wi1 = gi1/(eps1+beta1)**pw wi2 = gi2/(eps1+beta2)**pw sumwk = wi0 + wi1 + wi2 fqy(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk ! 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 ), field(i,k,j+1), field(i,k,j+2), vel ) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(5) ELSE IF (j .EQ. jds + 1) THEN ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start DO i=ad_from0,i_end ! ADT eqn 48 d/dy CALL PUSHREAL8(dy) dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs1 = cr CALL PUSHCONTROL1B(0) ELSE abs1 = -cr CALL PUSHCONTROL1B(1) END IF y2 = cr + abs1 IF (1.0 .GT. y2) THEN CALL PUSHREAL8(min4) min4 = y2 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min4) min4 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs16 = cr CALL PUSHCONTROL1B(0) ELSE abs16 = -cr CALL PUSHCONTROL1B(1) END IF y18 = cr - abs16 IF (-1.0 .LT. y18) THEN CALL PUSHREAL8(max3) max3 = y18 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max3) max3 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+0.5*& & max3*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1& & )) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(4) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start DO i=ad_from1,i_end ! ADT eqn 48 d/dy CALL PUSHREAL8(dy) dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs2 = cr CALL PUSHCONTROL1B(0) ELSE abs2 = -cr CALL PUSHCONTROL1B(1) END IF y3 = cr + abs2 IF (1.0 .GT. y3) THEN CALL PUSHREAL8(min5) min5 = y3 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min5) min5 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs17 = cr CALL PUSHCONTROL1B(0) ELSE abs17 = -cr CALL PUSHCONTROL1B(1) END IF y19 = cr - abs17 IF (-1.0 .LT. y19) THEN CALL PUSHREAL8(max4) max4 = y19 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max4) max4 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+0.5*& & max4*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-& & 1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step& & )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-& & 3.*(field(i, k, j)-field(i, k, j-1)))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start DO i=ad_from2,i_end ! ADT eqn 48 d/dy CALL PUSHREAL8(dy) dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs3 = cr CALL PUSHCONTROL1B(0) ELSE abs3 = -cr CALL PUSHCONTROL1B(1) END IF y4 = cr + abs3 IF (1.0 .GT. y4) THEN CALL PUSHREAL8(min6) min6 = y4 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min6) min6 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs18 = cr CALL PUSHCONTROL1B(0) ELSE abs18 = -cr CALL PUSHCONTROL1B(1) END IF y20 = cr - abs18 IF (-1.0 .LT. y20) THEN CALL PUSHREAL8(max5) max5 = y20 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max5) max5 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+0.5*& & max5*field_old(i, k, j)) fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1& & )) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 2) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start DO i=ad_from3,i_end ! ADT eqn 48 d/dy CALL PUSHREAL8(dy) dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j-1)) CALL PUSHREAL8(vel) vel = rv(i, k, j) cr = vel*dt/dy/mu IF (cr .GE. 0.) THEN abs4 = cr CALL PUSHCONTROL1B(0) ELSE abs4 = -cr CALL PUSHCONTROL1B(1) END IF y5 = cr + abs4 IF (1.0 .GT. y5) THEN CALL PUSHREAL8(min7) min7 = y5 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min7) min7 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs19 = cr CALL PUSHCONTROL1B(0) ELSE abs19 = -cr CALL PUSHCONTROL1B(1) END IF y21 = cr - abs19 IF (-1.0 .LT. y21) THEN CALL PUSHREAL8(max6) max6 = y21 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max6) max6 = -1.0 CALL PUSHCONTROL1B(1) END IF fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+0.5*& & max6*field_old(i, k, j)) fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-& & 1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step& & )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-& & 3.*(field(i, k, j)-field(i, k, j-1)))) fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(1) ELSE CALL PUSHCONTROL3B(0) END IF END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from4) ! next, x flux !-- these bounds are for periodic and sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min8 = ide - 1 ELSE min8 = ite END IF i_end = min8 + 1 i_start_f = i_start i_end_f = i_end + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min9 = jde - 1 ELSE min9 = jte END IF j_end = min9 + 1 !-- modify loop bounds for open and specified b.c ! IF(degrade_ys) j_start = MAX(jts-1,jds+1) ! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN CALL PUSHCONTROL1B(1) j_start = jds ELSE CALL PUSHCONTROL1B(1) j_start = jts - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN CALL PUSHCONTROL1B(1) j_end = jde - 1 ELSE CALL PUSHCONTROL1B(1) j_end = jte + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xs) THEN IF (ids + 1 .LT. its - 1) THEN CALL PUSHCONTROL1B(0) i_start = its - 1 ELSE CALL PUSHCONTROL1B(0) i_start = ids + 1 END IF i_start_f = ids + 3 ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite + 1) THEN CALL PUSHCONTROL1B(1) i_end = ite + 1 ELSE CALL PUSHCONTROL1B(1) i_end = ide - 2 END IF i_end_f = ide - 3 ELSE CALL PUSHCONTROL1B(0) END IF ad_from6 = j_start ! compute fluxes DO j=ad_from6,j_end ! 5th order flux DO k=kts,ktf DO i=i_start_f,i_end_f ! ADT eqn 48 d/dx CALL PUSHREAL8(dx) dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs5 = cr CALL PUSHCONTROL1B(0) ELSE abs5 = -cr CALL PUSHCONTROL1B(1) END IF y6 = cr + abs5 IF (1.0 .GT. y6) THEN CALL PUSHREAL8(min10) min10 = y6 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min10) min10 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs20 = cr CALL PUSHCONTROL1B(0) ELSE abs20 = -cr CALL PUSHCONTROL1B(1) END IF y22 = cr - abs20 IF (-1.0 .LT. y22) THEN CALL PUSHREAL8(max7) max7 = y22 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max7) max7 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5*& & max7*field_old(i, k, j)) IF (vel*SIGN(1, time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = field(i+1, k, j) CALL PUSHREAL8(qip1) qip1 = field(i, k, j) CALL PUSHREAL8(qi) qi = field(i-1, k, j) CALL PUSHREAL8(qim1) qim1 = field(i-2, k, j) CALL PUSHREAL8(qim2) qim2 = field(i-3, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = field(i-2, k, j) CALL PUSHREAL8(qip1) qip1 = field(i-1, k, j) CALL PUSHREAL8(qi) qi = field(i, k, j) CALL PUSHREAL8(qim1) qim1 = field(i+1, k, j) CALL PUSHREAL8(qim2) qim2 = field(i+2, k, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 wi0 = gi0/(eps1+beta0)**pw wi1 = gi1/(eps1+beta1)**pw wi2 = gi2/(eps1+beta2)**pw sumwk = wi0 + wi1 + wi2 fqx(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk ! 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), & ! field(i+1,k,j), field(i+2,k,j), & ! vel ) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO END DO ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from5 = i_start DO i=ad_from5,i_start_f-1 IF (i .EQ. ids + 1) THEN ! second order DO k=kts,ktf ! ADT eqn 48 d/dx CALL PUSHREAL8(dx) dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j)/mu cr = vel*dt/dx IF (cr .GE. 0.) THEN abs6 = cr CALL PUSHCONTROL1B(0) ELSE abs6 = -cr CALL PUSHCONTROL1B(1) END IF y7 = cr + abs6 IF (1.0 .GT. y7) THEN CALL PUSHREAL8(min11) min11 = y7 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min11) min11 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs21 = cr CALL PUSHCONTROL1B(0) ELSE abs21 = -cr CALL PUSHCONTROL1B(1) END IF y23 = cr - abs21 IF (-1.0 .LT. y23) THEN CALL PUSHREAL8(max8) max8 = y23 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max8) max8 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)+& & 0.5*max8*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k& & , j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN ! third order DO k=kts,ktf ! ADT eqn 48 d/dx CALL PUSHREAL8(dx) dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs7 = cr CALL PUSHCONTROL1B(0) ELSE abs7 = -cr CALL PUSHCONTROL1B(1) END IF y8 = cr + abs7 IF (1.0 .GT. y8) THEN CALL PUSHREAL8(min12) min12 = y8 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min12) min12 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs22 = cr CALL PUSHCONTROL1B(0) ELSE abs22 = -cr CALL PUSHCONTROL1B(1) END IF y24 = cr - abs22 IF (-1.0 .LT. y24) THEN CALL PUSHREAL8(max9) max9 = y24 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max9) max9 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)+& & 0.5*max9*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))& & -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(& & i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from5) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN ! second order flux next to the boundary DO k=kts,ktf ! ADT eqn 48 d/dx CALL PUSHREAL8(dx) dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs8 = cr CALL PUSHCONTROL1B(0) ELSE abs8 = -cr CALL PUSHCONTROL1B(1) END IF y9 = cr + abs8 IF (1.0 .GT. y9) THEN CALL PUSHREAL8(min13) min13 = y9 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min13) min13 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs23 = cr CALL PUSHCONTROL1B(0) ELSE abs23 = -cr CALL PUSHCONTROL1B(1) END IF y25 = cr - abs23 IF (-1.0 .LT. y25) THEN CALL PUSHREAL8(max10) max10 = y25 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max10) max10 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)+& & 0.5*max10*field_old(i, k, j)) fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k& & , j)) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN ! third order flux one in from the boundary DO k=kts,ktf ! ADT eqn 48 d/dx CALL PUSHREAL8(dx) dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i-1, j)) CALL PUSHREAL8(vel) vel = ru(i, k, j) cr = vel*dt/dx/mu IF (cr .GE. 0.) THEN abs9 = cr CALL PUSHCONTROL1B(0) ELSE abs9 = -cr CALL PUSHCONTROL1B(1) END IF y10 = cr + abs9 IF (1.0 .GT. y10) THEN CALL PUSHREAL8(min14) min14 = y10 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min14) min14 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs24 = cr CALL PUSHCONTROL1B(0) ELSE abs24 = -cr CALL PUSHCONTROL1B(1) END IF y26 = cr - abs24 IF (-1.0 .LT. y26) THEN CALL PUSHREAL8(max11) max11 = y26 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max11) max11 = -1.0 CALL PUSHCONTROL1B(1) END IF fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)+& & 0.5*max11*field_old(i, k, j)) fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))& & -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, & & time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(& & i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from6) ! enddo for outer J loop !--- end of 5th order horizontal flux calculation ! ELSE ! WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) ! ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! compute x (u) conditions for v, w, or scalar IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from7 = j_start DO j=ad_from7,j_end DO k=kts,ktf IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(its, k, j)+ru(its+1, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from7) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from8 = j_start DO j=ad_from8,j_end DO k=kts,ktf IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from8) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from9 = i_start DO i=ad_from9,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from10 = i_start DO i=ad_from10,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from10) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar .AND. jts .EQ. jds) THEN ad_from11 = i_start ! Assuming rv(i,k,jds) = 0. DO i=ad_from11,i_end DO k=kts,ktf IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*rv(i, k, jts+1) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from11) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar .AND. jte .EQ. jde) THEN ad_from12 = i_start ! Assuming rv(i,k,jde) = 0. DO i=ad_from12,i_end DO k=kts,ktf IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*rv(i, k, jte-1) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection !-- loop bounds for periodic or sym conditions i_start = its - 1 IF (ite .GT. ide - 1) THEN min15 = ide - 1 ELSE min15 = ite END IF CALL PUSHINTEGER4(i_end) i_end = min15 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min16 = jde - 1 ELSE min16 = jte END IF CALL PUSHINTEGER4(j_end) j_end = min16 + 1 !-- loop bounds for open or specified conditions IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN CALL PUSHCONTROL1B(1) i_start = ids ELSE CALL PUSHCONTROL1B(1) i_start = its - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN CALL PUSHCONTROL1B(1) i_end = ide - 1 ELSE CALL PUSHCONTROL1B(1) i_end = ite + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN CALL PUSHCONTROL1B(1) j_start = jds ELSE CALL PUSHCONTROL1B(1) j_start = jts - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN CALL PUSHCONTROL1B(1) j_end = jde - 1 ELSE CALL PUSHCONTROL1B(1) j_end = jte + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF ad_from16 = j_start ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j=ad_from16,j_end ad_from13 = i_start DO i=ad_from13,i_end fqz(i, 1, j) = 0. fqzl(i, 1, j) = 0. fqz(i, kde, j) = 0. fqzl(i, kde, j) = 0. END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) CALL PUSHINTEGER4(k) DO k=kts+3,ktf-2 ad_from14 = i_start DO i=ad_from14,i_end CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs10 = cr CALL PUSHCONTROL1B(0) ELSE abs10 = -cr CALL PUSHCONTROL1B(1) END IF y11 = cr + abs10 IF (1.0 .GT. y11) THEN CALL PUSHREAL8(min17) min17 = y11 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min17) min17 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs25 = cr CALL PUSHCONTROL1B(0) ELSE abs25 = -cr CALL PUSHCONTROL1B(1) END IF y27 = cr - abs25 IF (-1.0 .LT. y27) THEN CALL PUSHREAL8(max12) max12 = y27 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max12) max12 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min17*field_old(i, k-1, j)+0.5*& & max12*field_old(i, k, j)) IF (-(vel*SIGN(1, time_step)) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = field(i, k+1, j) CALL PUSHREAL8(qip1) qip1 = field(i, k, j) CALL PUSHREAL8(qi) qi = field(i, k-1, j) CALL PUSHREAL8(qim1) qim1 = field(i, k-2, j) CALL PUSHREAL8(qim2) qim2 = field(i, k-3, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = field(i, k-2, j) CALL PUSHREAL8(qip1) qip1 = field(i, k-1, j) CALL PUSHREAL8(qi) qi = field(i, k, j) CALL PUSHREAL8(qim1) qim1 = field(i, k+1, j) CALL PUSHREAL8(qim2) qim2 = field(i, k+2, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 wi0 = gi0/(eps1+beta0)**pw wi1 = gi1/(eps1+beta1)**pw wi2 = gi2/(eps1+beta2)**pw sumwk = wi0 + wi1 + wi2 fqz(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk ! fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & ! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO ad_from15 = i_start DO i=ad_from15,i_end CALL PUSHINTEGER4(k) k = kts + 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) CALL PUSHREAL8(mu) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs11 = cr CALL PUSHCONTROL1B(0) ELSE abs11 = -cr CALL PUSHCONTROL1B(1) END IF y12 = cr + abs11 IF (1.0 .GT. y12) THEN CALL PUSHREAL8(min18) min18 = y12 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min18) min18 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs26 = cr CALL PUSHCONTROL1B(0) ELSE abs26 = -cr CALL PUSHCONTROL1B(1) END IF y28 = cr - abs26 IF (-1.0 .LT. y28) THEN CALL PUSHREAL8(max13) max13 = y28 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max13) max13 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min18*field_old(i, k-1, j)+0.5*& & max13*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i& & , k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = kts + 2 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs12 = cr CALL PUSHCONTROL1B(0) ELSE abs12 = -cr CALL PUSHCONTROL1B(1) END IF y13 = cr + abs12 IF (1.0 .GT. y13) THEN CALL PUSHREAL8(min19) min19 = y13 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min19) min19 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs27 = cr CALL PUSHCONTROL1B(0) ELSE abs27 = -cr CALL PUSHCONTROL1B(1) END IF y29 = cr - abs27 IF (-1.0 .LT. y29) THEN CALL PUSHREAL8(max14) max14 = y29 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max14) max14 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min19*field_old(i, k-1, j)+0.5*& & max14*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./& & 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(& & 1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(& & i, k, j)-field(i, k-1, j)))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf - 1 CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs13 = cr CALL PUSHCONTROL1B(0) ELSE abs13 = -cr CALL PUSHCONTROL1B(1) END IF y14 = cr + abs13 IF (1.0 .GT. y14) THEN CALL PUSHREAL8(min20) min20 = y14 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min20) min20 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs28 = cr CALL PUSHCONTROL1B(0) ELSE abs28 = -cr CALL PUSHCONTROL1B(1) END IF y30 = cr - abs28 IF (-1.0 .LT. y30) THEN CALL PUSHREAL8(max15) max15 = y30 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max15) max15 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min20*field_old(i, k-1, j)+0.5*& & max15*field_old(i, k, j)) fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./& & 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(& & 1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(& & i, k, j)-field(i, k-1, j)))) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) k = ktf CALL PUSHREAL8(dz) dz = 2./(rdzw(k)+rdzw(k-1)) mu = 0.5*(mut(i, j)+mut(i, j)) CALL PUSHREAL8(vel) vel = rom(i, k, j) cr = vel*dt/dz/mu IF (cr .GE. 0.) THEN abs14 = cr CALL PUSHCONTROL1B(0) ELSE abs14 = -cr CALL PUSHCONTROL1B(1) END IF y15 = cr + abs14 IF (1.0 .GT. y15) THEN CALL PUSHREAL8(min21) min21 = y15 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(min21) min21 = 1.0 CALL PUSHCONTROL1B(1) END IF IF (cr .GE. 0.) THEN abs29 = cr CALL PUSHCONTROL1B(0) ELSE abs29 = -cr CALL PUSHCONTROL1B(1) END IF y31 = cr - abs29 IF (-1.0 .LT. y31) THEN CALL PUSHREAL8(max16) max16 = y31 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(max16) max16 = -1.0 CALL PUSHCONTROL1B(1) END IF fqzl(i, k, j) = mu*(dz/dt)*(0.5*min21*field_old(i, k-1, j)+0.5*& & max16*field_old(i, k, j)) fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i& & , k-1, j)) fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from15) END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from16) ! ELSE ! WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order ! CALL wrf_error_fatal ( wrf_err_message ) ! ENDIF vert_order_test IF (pd_limit) THEN ! positive definite filter i_start = its - 1 IF (ite .GT. ide - 1) THEN min22 = ide - 1 ELSE min22 = ite END IF i_end = min22 + 1 j_start = jts - 1 IF (jte .GT. jde - 1) THEN min23 = jde - 1 ELSE min23 = jte END IF j_end = min23 + 1 !-- loop bounds for open or specified conditions IF (degrade_xs) THEN IF (its - 1 .LT. ids) THEN CALL PUSHCONTROL1B(1) i_start = ids ELSE CALL PUSHCONTROL1B(1) i_start = its - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 1) THEN CALL PUSHCONTROL1B(1) i_end = ide - 1 ELSE CALL PUSHCONTROL1B(1) i_end = ite + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds) THEN CALL PUSHCONTROL1B(1) j_start = jds ELSE CALL PUSHCONTROL1B(1) j_start = jts - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 1) THEN CALL PUSHCONTROL1B(1) j_end = jde - 1 ELSE CALL PUSHCONTROL1B(1) j_end = jte + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (config_flags%specified .OR. config_flags%nested) THEN IF (degrade_xs) THEN IF (its - 1 .LT. ids + 1) THEN CALL PUSHCONTROL1B(1) i_start = ids + 1 ELSE CALL PUSHCONTROL1B(1) i_start = its - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 2) THEN CALL PUSHCONTROL1B(1) i_end = ide - 2 ELSE CALL PUSHCONTROL1B(1) i_end = ite + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN CALL PUSHCONTROL1B(1) j_start = jds + 1 ELSE CALL PUSHCONTROL1B(1) j_start = jts - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN CALL PUSHCONTROL2B(2) j_end = jde - 2 ELSE CALL PUSHCONTROL2B(2) j_end = jte + 1 END IF ELSE CALL PUSHCONTROL2B(0) END IF ELSE CALL PUSHCONTROL2B(1) END IF IF (config_flags%open_xs) THEN IF (degrade_xs) THEN IF (its - 1 .LT. ids + 1) THEN CALL PUSHCONTROL2B(2) i_start = ids + 1 ELSE CALL PUSHCONTROL2B(2) i_start = its - 1 END IF ELSE CALL PUSHCONTROL2B(0) END IF ELSE CALL PUSHCONTROL2B(1) END IF IF (config_flags%open_xe) THEN IF (degrade_xe) THEN IF (ite + 1 .GT. ide - 2) THEN CALL PUSHCONTROL2B(2) i_end = ide - 2 ELSE CALL PUSHCONTROL2B(2) i_end = ite + 1 END IF ELSE CALL PUSHCONTROL2B(0) END IF ELSE CALL PUSHCONTROL2B(1) END IF IF (config_flags%open_ys) THEN IF (degrade_ys) THEN IF (jts - 1 .LT. jds + 1) THEN CALL PUSHCONTROL2B(2) j_start = jds + 1 ELSE CALL PUSHCONTROL2B(2) j_start = jts - 1 END IF ELSE CALL PUSHCONTROL2B(0) END IF ELSE CALL PUSHCONTROL2B(1) END IF IF (config_flags%open_ye) THEN IF (degrade_ye) THEN IF (jte + 1 .GT. jde - 2) THEN CALL PUSHCONTROL2B(2) j_end = jde - 2 ELSE CALL PUSHCONTROL2B(2) j_end = jte + 1 END IF ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(0) END IF ad_from18 = j_start ! ADT note: ! We don't want to change j_start and j_end ! for polar BC's since we want to calculate ! fluxes for directions other than y at the ! edge !-- here is the limiter... DO j=ad_from18,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from17 = i_start DO i=ad_from17,i_end ph_low(i, k, j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) & & - dt*(msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, & & k, j))+rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw& & (k)*(fqzl(i, k+1, j)-fqzl(i, k, j))) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from17) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from18) ad_from20 = j_start DO j=ad_from20,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from19 = i_start !DIR$ vector always DO i=ad_from19,i_end IF (0. .LT. fqx(i+1, k, j)) THEN max1 = fqx(i+1, k, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) max1 = 0. END IF IF (0. .GT. fqx(i, k, j)) THEN min24 = fqx(i, k, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) min24 = 0. END IF IF (0. .LT. fqy(i, k, j+1)) THEN max17 = fqy(i, k, j+1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) max17 = 0. END IF IF (0. .GT. fqy(i, k, j)) THEN min25 = fqy(i, k, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) min25 = 0. END IF IF (0. .GT. fqz(i, k+1, j)) THEN min26 = fqz(i, k+1, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) min26 = 0. END IF IF (0. .LT. fqz(i, k, j)) THEN max18 = fqz(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) max18 = 0. END IF flux_out(i, k, j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-& & min24)+rdy*(max17-min25))+msfty(i, j)*rdzw(k)*(min26-max18)) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from19) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from20) ad_from22 = j_start DO j=ad_from22,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from21 = i_start !DIR$ vector always DO i=ad_from21,i_end IF (flux_out(i, k, j) .GT. ph_low(i, k, j)) THEN y16 = ph_low(i, k, j)/(flux_out(i, k, j)+eps) IF (0. .LT. y16) THEN CALL PUSHREAL8(scale) scale = y16 CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(scale) scale = 0. CALL PUSHCONTROL1B(1) END IF IF (fqx(i+1, k, j) .GT. 0.) THEN CALL PUSHREAL8(fqx(i+1, k, j)) fqx(i+1, k, j) = scale*fqx(i+1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqx(i, k, j) .LT. 0.) THEN CALL PUSHREAL8(fqx(i, k, j)) fqx(i, k, j) = scale*fqx(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqy(i, k, j+1) .GT. 0.) THEN CALL PUSHREAL8(fqy(i, k, j+1)) fqy(i, k, j+1) = scale*fqy(i, k, j+1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqy(i, k, j) .LT. 0.) THEN CALL PUSHREAL8(fqy(i, k, j)) fqy(i, k, j) = scale*fqy(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF ! note: z flux is opposite sign in mass coordinate because ! vertical coordinate decreases with increasing k IF (fqz(i, k+1, j) .LT. 0.) THEN CALL PUSHREAL8(fqz(i, k+1, j)) fqz(i, k+1, j) = scale*fqz(i, k+1, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (fqz(i, k, j) .GT. 0.) THEN CALL PUSHREAL8(fqz(i, k, j)) fqz(i, k, j) = scale*fqz(i, k, j) CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(1) END IF ELSE CALL PUSHCONTROL2B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from21) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from22) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! add in the pd-limited flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ad_from24 = j_start DO j=ad_from24,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from23 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from24) ! x flux divergence ! IF (degrade_xs) THEN IF (its .LT. ids + 1) THEN CALL PUSHCONTROL1B(1) i_start = ids + 1 ELSE CALL PUSHCONTROL1B(1) i_start = its END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xe) THEN IF (ite .GT. ide - 2) THEN CALL PUSHCONTROL1B(1) i_end = ide - 2 ELSE CALL PUSHCONTROL1B(1) i_end = ite END IF ELSE CALL PUSHCONTROL1B(0) END IF ad_from26 = j_start DO j=ad_from26,j_end CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from25 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from25) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from26) ! y flux divergence ! i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN CALL PUSHCONTROL1B(1) j_start = jds + 1 ELSE CALL PUSHCONTROL1B(1) j_start = jts END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN CALL PUSHCONTROL1B(1) j_end = jde - 2 ELSE CALL PUSHCONTROL1B(1) j_end = jte END IF ELSE CALL PUSHCONTROL1B(0) END IF DO j=j_start,j_end CALL PUSHINTEGER4(k) END DO fqylb = 0.0 fqyb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 tempb92 = -(msftx(i, j)*rdy*tendencyb(i, k, j)) fqyb(i, k, j+1) = fqyb(i, k, j+1) + tempb92 fqyb(i, k, j) = fqyb(i, k, j) - tempb92 fqylb(i, k, j+1) = fqylb(i, k, j+1) + tempb92 fqylb(i, k, j) = fqylb(i, k, j) - tempb92 END DO END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) fqxlb = 0.0 fqxb = 0.0 CALL POPINTEGER4(ad_from26) CALL POPINTEGER4(ad_to26) DO j=ad_to26,ad_from26,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from25) CALL POPINTEGER4(ad_to25) DO i=ad_to25,ad_from25,-1 tempb91 = -(msftx(i, j)*rdx*tendencyb(i, k, j)) fqxb(i+1, k, j) = fqxb(i+1, k, j) + tempb91 fqxb(i, k, j) = fqxb(i, k, j) - tempb91 fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + tempb91 fqxlb(i, k, j) = fqxlb(i, k, j) - tempb91 END DO END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) fqzb = 0.0 fqzlb = 0.0 CALL POPINTEGER4(ad_from24) CALL POPINTEGER4(ad_to24) DO j=ad_to24,ad_from24,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 tempb90 = -(rdzw(k)*tendencyb(i, k, j)) fqzb(i, k+1, j) = fqzb(i, k+1, j) + tempb90 fqzb(i, k, j) = fqzb(i, k, j) - tempb90 fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + tempb90 fqzlb(i, k, j) = fqzlb(i, k, j) - tempb90 END DO END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN flux_outb = 0.0 ph_lowb = 0.0 CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO j=ad_to22,ad_from22,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO i=ad_to21,ad_from21,-1 CALL POPCONTROL2B(branch) IF (branch .NE. 0) THEN IF (branch .EQ. 1) THEN scaleb = 0.0 ELSE CALL POPREAL8(fqz(i, k, j)) scaleb = fqz(i, k, j)*fqzb(i, k, j) fqzb(i, k, j) = scale*fqzb(i, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqz(i, k+1, j)) scaleb = scaleb + fqz(i, k+1, j)*fqzb(i, k+1, j) fqzb(i, k+1, j) = scale*fqzb(i, k+1, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqy(i, k, j)) scaleb = scaleb + fqy(i, k, j)*fqyb(i, k, j) fqyb(i, k, j) = scale*fqyb(i, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqy(i, k, j+1)) scaleb = scaleb + fqy(i, k, j+1)*fqyb(i, k, j+1) fqyb(i, k, j+1) = scale*fqyb(i, k, j+1) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqx(i, k, j)) scaleb = scaleb + fqx(i, k, j)*fqxb(i, k, j) fqxb(i, k, j) = scale*fqxb(i, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(fqx(i+1, k, j)) scaleb = scaleb + fqx(i+1, k, j)*fqxb(i+1, k, j) fqxb(i+1, k, j) = scale*fqxb(i+1, k, j) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(scale) y16b = scaleb ELSE CALL POPREAL8(scale) y16b = 0.0 END IF temp32 = eps + flux_out(i, k, j) ph_lowb(i, k, j) = ph_lowb(i, k, j) + y16b/temp32 flux_outb(i, k, j) = flux_outb(i, k, j) - ph_low(i, k, j)*& & y16b/temp32**2 END IF END DO END DO CALL POPINTEGER4(k) END DO CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO j=ad_to20,ad_from20,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO i=ad_to19,ad_from19,-1 tempb88 = dt*msftx(i, j)*msfty(i, j)*flux_outb(i, k, j) tempb89 = msfty(i, j)*dt*rdzw(k)*flux_outb(i, k, j) max1b = rdx*tempb88 min24b = -(rdx*tempb88) max17b = rdy*tempb88 min25b = -(rdy*tempb88) min26b = tempb89 max18b = -tempb89 flux_outb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) fqzb(i, k, j) = fqzb(i, k, j) + max18b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqzb(i, k+1, j) = fqzb(i, k+1, j) + min26b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqyb(i, k, j) = fqyb(i, k, j) + min25b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqyb(i, k, j+1) = fqyb(i, k, j+1) + max17b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqxb(i, k, j) = fqxb(i, k, j) + min24b CALL POPCONTROL1B(branch) IF (branch .NE. 0) fqxb(i+1, k, j) = fqxb(i+1, k, j) + max1b END DO END DO CALL POPINTEGER4(k) END DO CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO j=ad_to18,ad_from18,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO i=ad_to17,ad_from17,-1 tempb86 = -(dt*msftx(i, j)*msfty(i, j)*ph_lowb(i, k, j)) tempb87 = -(dt*msfty(i, j)*rdzw(k)*ph_lowb(i, k, j)) mu_oldb(i, j) = mu_oldb(i, j) + field_old(i, k, j)*ph_lowb(i, & & k, j) field_oldb(i, k, j) = field_oldb(i, k, j) + (mub(i, j)+mu_old(& & i, j))*ph_lowb(i, k, j) fqxlb(i+1, k, j) = fqxlb(i+1, k, j) + rdx*tempb86 fqxlb(i, k, j) = fqxlb(i, k, j) - rdx*tempb86 fqylb(i, k, j+1) = fqylb(i, k, j+1) + rdy*tempb86 fqylb(i, k, j) = fqylb(i, k, j) - rdy*tempb86 fqzlb(i, k+1, j) = fqzlb(i, k+1, j) + tempb87 fqzlb(i, k, j) = fqzlb(i, k, j) - tempb87 ph_lowb(i, k, j) = 0.0 END DO END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL2B(branch) CALL POPCONTROL2B(branch) CALL POPCONTROL2B(branch) CALL POPCONTROL2B(branch) CALL POPCONTROL2B(branch) IF (branch .NE. 0) THEN IF (branch .EQ. 1) GOTO 100 END IF CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) 100 CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) END IF CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO j=ad_to16,ad_from16,-1 CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO i=ad_to15,ad_from15,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) tempb84 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb84 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb84 fqzb(i, k, j) = 0.0 tempb85 = dz*mu*fqzlb(i, k, j)/dt min21b = 0.5*field_old(i, k-1, j)*tempb85 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min21*tempb85 max16b = 0.5*field_old(i, k, j)*tempb85 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max16*tempb85 mub0 = (0.5*(min21*field_old(i, k-1, j))+0.5*(max16*field_old(i, k& & , j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max16) y31b = max16b ELSE CALL POPREAL8(max16) y31b = 0.0 END IF crb = y31b abs29b = -y31b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs29b ELSE crb = crb - abs29b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min21) y15b = min21b ELSE CALL POPREAL8(min21) y15b = 0.0 END IF crb = crb + y15b abs14b = y15b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs14b ELSE crb = crb - abs14b END IF tempb79 = dt*crb/(dz*mu) velb = tempb79 mub0 = mub0 - vel*tempb79/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = ktf - 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp28 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-& & field(i, k-1, j)) temp31 = SIGN(1., -vel) temp30 = temp31/12. temp29 = SIGN(1, time_step) tempb80 = vel*fqzb(i, k, j) tempb81 = 7.*tempb80/12. tempb82 = temp29*temp30*tempb80 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, & & j)+field(i, k-2, j))/12.+temp29*(temp30*temp28))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb81 - 3.*tempb82 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb82 + tempb81 fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb82 - tempb80/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb82 - tempb80/12. fqzb(i, k, j) = 0.0 tempb83 = dz*mu*fqzlb(i, k, j)/dt min20b = 0.5*field_old(i, k-1, j)*tempb83 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min20*tempb83 max15b = 0.5*field_old(i, k, j)*tempb83 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max15*tempb83 mub0 = (0.5*(min20*field_old(i, k-1, j))+0.5*(max15*field_old(i, k& & , j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max15) y30b = max15b ELSE CALL POPREAL8(max15) y30b = 0.0 END IF crb = y30b abs28b = -y30b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs28b ELSE crb = crb - abs28b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min20) y14b = min20b ELSE CALL POPREAL8(min20) y14b = 0.0 END IF crb = crb + y14b abs13b = y14b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs13b ELSE crb = crb - abs13b END IF tempb74 = dt*crb/(dz*mu) velb = velb + tempb74 mub0 = mub0 - vel*tempb74/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 2 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) temp24 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-& & field(i, k-1, j)) temp27 = SIGN(1., -vel) temp26 = temp27/12. temp25 = SIGN(1, time_step) tempb75 = vel*fqzb(i, k, j) tempb76 = 7.*tempb75/12. tempb77 = temp25*temp26*tempb75 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, & & j)+field(i, k-2, j))/12.+temp25*(temp26*temp24))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb76 - 3.*tempb77 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb77 + tempb76 fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb77 - tempb75/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb77 - tempb75/12. fqzb(i, k, j) = 0.0 tempb78 = dz*mu*fqzlb(i, k, j)/dt min19b = 0.5*field_old(i, k-1, j)*tempb78 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min19*tempb78 max14b = 0.5*field_old(i, k, j)*tempb78 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max14*tempb78 mub0 = (0.5*(min19*field_old(i, k-1, j))+0.5*(max14*field_old(i, k& & , j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max14) y29b = max14b ELSE CALL POPREAL8(max14) y29b = 0.0 END IF crb = y29b abs27b = -y29b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs27b ELSE crb = crb - abs27b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min19) y13b = min19b ELSE CALL POPREAL8(min19) y13b = 0.0 END IF crb = crb + y13b abs12b = y13b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs12b ELSE crb = crb - abs12b END IF tempb71 = dt*crb/(dz*mu) velb = velb + tempb71 mub0 = mub0 - vel*tempb71/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb mutb(i, j) = mutb(i, j) + 0.5*2*mub0 mu = 0.5*(mut(i, j)+mut(i, j)) CALL POPREAL8(dz) k = kts + 1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) tempb72 = rom(i, k, j)*fqzb(i, k, j) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*fqzb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb72 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb72 fqzb(i, k, j) = 0.0 tempb73 = dz*mu*fqzlb(i, k, j)/dt min18b = 0.5*field_old(i, k-1, j)*tempb73 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min18*tempb73 max13b = 0.5*field_old(i, k, j)*tempb73 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max13*tempb73 mub0 = (0.5*(min18*field_old(i, k-1, j))+0.5*(max13*field_old(i, k& & , j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max13) y28b = max13b ELSE CALL POPREAL8(max13) y28b = 0.0 END IF crb = y28b abs26b = -y28b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs26b ELSE crb = crb - abs26b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min18) y12b = min18b ELSE CALL POPREAL8(min18) y12b = 0.0 END IF crb = crb + y12b abs11b = y12b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs11b ELSE crb = crb - abs11b END IF tempb70 = dt*crb/(dz*mu) velb = tempb70 mub0 = mub0 - vel*tempb70/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) CALL POPINTEGER4(k) END DO DO k=ktf-2,kts+3,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 fqzlb(i, k, j) = fqzlb(i, k, j) - fqzb(i, k, j) wi0 = gi0/(eps1+beta0)**pw wi1 = gi1/(eps1+beta1)**pw wi2 = gi2/(eps1+beta2)**pw sumwk = wi0 + wi1 + wi2 tempb62 = vel*fqzb(i, k, j)/sumwk tempb63 = (wi0*f0+wi1*f1+wi2*f2)*fqzb(i, k, j)/sumwk f0b = wi0*tempb62 f1b = wi1*tempb62 f2b = wi2*tempb62 velb = tempb63 sumwkb = -(vel*tempb63/sumwk) wi0b = sumwkb + f0*tempb62 wi1b = sumwkb + f1*tempb62 wi2b = sumwkb + f2*tempb62 fqzb(i, k, j) = 0.0 temp23 = (eps1+beta2)**pw IF (eps1 + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw& & ))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps1+beta2)**(pw-1)*wi2b/temp23**2) END IF temp22 = (eps1+beta1)**pw IF (eps1 + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw& & ))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps1+beta1)**(pw-1)*wi1b/temp22**2) END IF temp21 = (eps1+beta0)**pw IF (eps1 + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw& & ))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps1+beta0)**(pw-1)*wi0b/temp21**2) END IF CALL POPREAL8(beta2) tempb64 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb65 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb65 - f2b/6. + tempb64 CALL POPREAL8(beta1) tempb66 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb69 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb66 - tempb69 + f1b/3. + 5.*f2b/6. - 4.*tempb65 - 2.& & *tempb64 CALL POPREAL8(beta0) tempb68 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb67 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb66 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb67 & & + tempb68 + 3.*tempb65 + tempb64 qim1b = tempb69 - 4.*tempb67 - 7.*f0b/6. - f1b/6. - 2.*tempb68 +& & tempb66 qim2b = f0b/3. + tempb67 + tempb68 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) fieldb(i, k-3, j) = fieldb(i, k-3, j) + qim2b CALL POPREAL8(qim1) fieldb(i, k-2, j) = fieldb(i, k-2, j) + qim1b CALL POPREAL8(qi) fieldb(i, k-1, j) = fieldb(i, k-1, j) + qib CALL POPREAL8(qip1) fieldb(i, k, j) = fieldb(i, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i, k+1, j) = fieldb(i, k+1, j) + qip2b ELSE CALL POPREAL8(qim2) fieldb(i, k+2, j) = fieldb(i, k+2, j) + qim2b CALL POPREAL8(qim1) fieldb(i, k+1, j) = fieldb(i, k+1, j) + qim1b CALL POPREAL8(qi) fieldb(i, k, j) = fieldb(i, k, j) + qib CALL POPREAL8(qip1) fieldb(i, k-1, j) = fieldb(i, k-1, j) + qip1b CALL POPREAL8(qip2) fieldb(i, k-2, j) = fieldb(i, k-2, j) + qip2b END IF tempb61 = dz*mu*fqzlb(i, k, j)/dt min17b = 0.5*field_old(i, k-1, j)*tempb61 field_oldb(i, k-1, j) = field_oldb(i, k-1, j) + 0.5*min17*& & tempb61 max12b = 0.5*field_old(i, k, j)*tempb61 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max12*tempb61 mub0 = (0.5*(min17*field_old(i, k-1, j))+0.5*(max12*field_old(i& & , k, j)))*dz*fqzlb(i, k, j)/dt fqzlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max12) y27b = max12b ELSE CALL POPREAL8(max12) y27b = 0.0 END IF crb = y27b abs25b = -y27b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs25b ELSE crb = crb - abs25b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min17) y11b = min17b ELSE CALL POPREAL8(min17) y11b = 0.0 END IF crb = crb + y11b abs10b = y11b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs10b ELSE crb = crb - abs10b END IF tempb60 = dt*crb/(dz*mu) velb = velb + tempb60 mub0 = mub0 - vel*tempb60/mu CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*2*mub0 CALL POPREAL8(dz) END DO END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 fqzlb(i, kde, j) = 0.0 fqzb(i, kde, j) = 0.0 fqzlb(i, 1, j) = 0.0 fqzb(i, 1, j) = 0.0 END DO END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPINTEGER4(j_end) CALL POPINTEGER4(i_end) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 DO k=ktf,kts,-1 tempb59 = -(rdy*tendencyb(i, k, j_end)) vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*tempb59 field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*tempb59 field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*& & tempb59 fieldb(i, k, j_end) = fieldb(i, k, j_end) - rv(i, k, jte-1)*& & tempb59 rvb(i, k, jte-1) = rvb(i, k, jte-1) - field(i, k, j_end)*tempb59 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO i=ad_to11,ad_from11,-1 DO k=ktf,kts,-1 tempb58 = -(rdy*tendencyb(i, k, jts)) vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*tempb58 field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*tempb58 field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*tempb58 fieldb(i, k, jts) = fieldb(i, k, jts) + rv(i, k, jts+1)*tempb58 rvb(i, k, jts+1) = rvb(i, k, jts+1) + field(i, k, jts)*tempb58 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO i=ad_to10,ad_from10,-1 DO k=ktf,kts,-1 tempb56 = -(rdy*tendencyb(i, k, j_end)) tempb57 = field(i, k, j_end)*tempb56 vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*tempb56 field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*tempb56 field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*& & tempb56 fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i& & , k, jte-1))*tempb56 rvb(i, k, jte) = rvb(i, k, jte) + tempb57 rvb(i, k, jte-1) = rvb(i, k, jte-1) - tempb57 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 DO k=ktf,kts,-1 tempb54 = -(rdy*tendencyb(i, k, jts)) tempb55 = field(i, k, jts)*tempb54 vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*tempb54 field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*tempb54 field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*tempb54 fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k& & , jts))*tempb54 rvb(i, k, jts+1) = rvb(i, k, jts+1) + tempb55 rvb(i, k, jts) = rvb(i, k, jts) - tempb55 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO j=ad_to8,ad_from8,-1 DO k=ktf,kts,-1 tempb52 = -(rdx*tendencyb(i_end, k, j)) tempb53 = field(i_end, k, j)*tempb52 ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*tempb52 field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*tempb52 field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*& & tempb52 fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(& & ite-1, k, j))*tempb52 rub(ite, k, j) = rub(ite, k, j) + tempb53 rub(ite-1, k, j) = rub(ite-1, k, j) - tempb53 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO j=ad_to7,ad_from7,-1 DO k=ktf,kts,-1 tempb50 = -(rdx*tendencyb(its, k, j)) tempb51 = field(its, k, j)*tempb50 ubb = (field_old(its+1, k, j)-field_old(its, k, j))*tempb50 field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*tempb50 field_oldb(its, k, j) = field_oldb(its, k, j) - ub*tempb50 fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its& & , k, j))*tempb50 rub(its+1, k, j) = rub(its+1, k, j) + tempb51 rub(its, k, j) = rub(its, k, j) - tempb51 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(its, k, j) = rub(its, k, j) + 0.5*ubb rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO j=ad_to6,ad_from6,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to5) DO i=ad_to5,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp17 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i, & & k, j)-field(i-1, k, j)) temp20 = SIGN(1., vel) temp19 = temp20/12. temp18 = SIGN(1, time_step) tempb46 = vel*fqxb(i, k, j) tempb47 = 7.*tempb46/12. tempb48 = temp18*temp19*tempb46 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(i+& & 1, k, j)+field(i-2, k, j))/12.+temp18*(temp19*temp17))*& & fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb47 - 3.*tempb48 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb48 + tempb47 fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb48 - tempb46/& & 12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb48 - tempb46/& & 12. fqxb(i, k, j) = 0.0 tempb49 = dx*mu*fqxlb(i, k, j)/dt min14b = 0.5*field_old(i-1, k, j)*tempb49 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min14*& & tempb49 max11b = 0.5*field_old(i, k, j)*tempb49 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max11*& & tempb49 mub0 = (0.5*(min14*field_old(i-1, k, j))+0.5*(max11*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max11) y26b = max11b ELSE CALL POPREAL8(max11) y26b = 0.0 END IF crb = y26b abs24b = -y26b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs24b ELSE crb = crb - abs24b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min14) y10b = min14b ELSE CALL POPREAL8(min14) y10b = 0.0 END IF crb = crb + y10b abs9b = y10b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs9b ELSE crb = crb - abs9b END IF tempb45 = dt*crb/(dx*mu) velb = velb + tempb45 mub0 = mub0 - vel*tempb45/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) tempb43 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1& & , k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb43 fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb43 fqxb(i, k, j) = 0.0 tempb44 = dx*mu*fqxlb(i, k, j)/dt min13b = 0.5*field_old(i-1, k, j)*tempb44 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min13*& & tempb44 max10b = 0.5*field_old(i, k, j)*tempb44 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max10*& & tempb44 mub0 = (0.5*(min13*field_old(i-1, k, j))+0.5*(max10*& & field_old(i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max10) y25b = max10b ELSE CALL POPREAL8(max10) y25b = 0.0 END IF crb = y25b abs23b = -y25b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs23b ELSE crb = crb - abs23b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min13) y9b = min13b ELSE CALL POPREAL8(min13) y9b = 0.0 END IF crb = crb + y9b abs8b = y9b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs8b ELSE crb = crb - abs8b END IF tempb42 = dt*crb/(dx*mu) velb = tempb42 mub0 = mub0 - vel*tempb42/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from5) DO i=i_start_f-1,ad_from5,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) temp13 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i, & & k, j)-field(i-1, k, j)) temp16 = SIGN(1., vel) temp15 = temp16/12. temp14 = SIGN(1, time_step) tempb38 = vel*fqxb(i, k, j) tempb39 = 7.*tempb38/12. tempb40 = temp14*temp15*tempb38 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(i+& & 1, k, j)+field(i-2, k, j))/12.+temp14*(temp15*temp13))*& & fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb39 - 3.*tempb40 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb40 + tempb39 fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb40 - tempb38/& & 12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb40 - tempb38/& & 12. fqxb(i, k, j) = 0.0 tempb41 = dx*mu*fqxlb(i, k, j)/dt min12b = 0.5*field_old(i-1, k, j)*tempb41 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min12*& & tempb41 max9b = 0.5*field_old(i, k, j)*tempb41 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max9*tempb41 mub0 = (0.5*(min12*field_old(i-1, k, j))+0.5*(max9*field_old& & (i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max9) y24b = max9b ELSE CALL POPREAL8(max9) y24b = 0.0 END IF crb = y24b abs22b = -y24b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs22b ELSE crb = crb - abs22b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min12) y8b = min12b ELSE CALL POPREAL8(min12) y8b = 0.0 END IF crb = crb + y8b abs7b = y8b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs7b ELSE crb = crb - abs7b END IF tempb37 = dt*crb/(dx*mu) velb = velb + tempb37 mub0 = mub0 - vel*tempb37/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) tempb35 = 0.5*ru(i, k, j)*fqxb(i, k, j) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-1& & , k, j))*fqxb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb35 fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb35 fqxb(i, k, j) = 0.0 tempb36 = dx*mu*fqxlb(i, k, j)/dt min11b = 0.5*field_old(i-1, k, j)*tempb36 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min11*& & tempb36 max8b = 0.5*field_old(i, k, j)*tempb36 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max8*tempb36 mub0 = (0.5*(min11*field_old(i-1, k, j))+0.5*(max8*field_old& & (i, k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max8) y23b = max8b ELSE CALL POPREAL8(max8) y23b = 0.0 END IF crb = y23b abs21b = -y23b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs21b ELSE crb = crb - abs21b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min11) y7b = min11b ELSE CALL POPREAL8(min11) y7b = 0.0 END IF crb = crb + y7b abs6b = y7b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs6b ELSE crb = crb - abs6b END IF velb = dt*crb/dx CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb/mu mub0 = mub0 - ru(i, k, j)*velb/mu**2 CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 fqxlb(i, k, j) = fqxlb(i, k, j) - fqxb(i, k, j) wi0 = gi0/(eps1+beta0)**pw wi1 = gi1/(eps1+beta1)**pw wi2 = gi2/(eps1+beta2)**pw sumwk = wi0 + wi1 + wi2 tempb27 = vel*fqxb(i, k, j)/sumwk tempb28 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k, j)/sumwk f0b = wi0*tempb27 f1b = wi1*tempb27 f2b = wi2*tempb27 velb = tempb28 sumwkb = -(vel*tempb28/sumwk) wi0b = sumwkb + f0*tempb27 wi1b = sumwkb + f1*tempb27 wi2b = sumwkb + f2*tempb27 fqxb(i, k, j) = 0.0 temp12 = (eps1+beta2)**pw IF (eps1 + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw& & ))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps1+beta2)**(pw-1)*wi2b/temp12**2) END IF temp11 = (eps1+beta1)**pw IF (eps1 + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw& & ))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps1+beta1)**(pw-1)*wi1b/temp11**2) END IF temp10 = (eps1+beta0)**pw IF (eps1 + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw& & ))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps1+beta0)**(pw-1)*wi0b/temp10**2) END IF CALL POPREAL8(beta2) tempb29 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb30 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb30 - f2b/6. + tempb29 CALL POPREAL8(beta1) tempb31 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb34 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb31 - tempb34 + f1b/3. + 5.*f2b/6. - 4.*tempb30 - 2.& & *tempb29 CALL POPREAL8(beta0) tempb33 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb32 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb31 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb32 & & + tempb33 + 3.*tempb30 + tempb29 qim1b = tempb34 - 4.*tempb32 - 7.*f0b/6. - f1b/6. - 2.*tempb33 +& & tempb31 qim2b = f0b/3. + tempb32 + tempb33 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) fieldb(i-3, k, j) = fieldb(i-3, k, j) + qim2b CALL POPREAL8(qim1) fieldb(i-2, k, j) = fieldb(i-2, k, j) + qim1b CALL POPREAL8(qi) fieldb(i-1, k, j) = fieldb(i-1, k, j) + qib CALL POPREAL8(qip1) fieldb(i, k, j) = fieldb(i, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i+1, k, j) = fieldb(i+1, k, j) + qip2b ELSE CALL POPREAL8(qim2) fieldb(i+2, k, j) = fieldb(i+2, k, j) + qim2b CALL POPREAL8(qim1) fieldb(i+1, k, j) = fieldb(i+1, k, j) + qim1b CALL POPREAL8(qi) fieldb(i, k, j) = fieldb(i, k, j) + qib CALL POPREAL8(qip1) fieldb(i-1, k, j) = fieldb(i-1, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i-2, k, j) = fieldb(i-2, k, j) + qip2b END IF tempb26 = dx*mu*fqxlb(i, k, j)/dt min10b = 0.5*field_old(i-1, k, j)*tempb26 field_oldb(i-1, k, j) = field_oldb(i-1, k, j) + 0.5*min10*& & tempb26 max7b = 0.5*field_old(i, k, j)*tempb26 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max7*tempb26 mub0 = (0.5*(min10*field_old(i-1, k, j))+0.5*(max7*field_old(i, & & k, j)))*dx*fqxlb(i, k, j)/dt fqxlb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max7) y22b = max7b ELSE CALL POPREAL8(max7) y22b = 0.0 END IF crb = y22b abs20b = -y22b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs20b ELSE crb = crb - abs20b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min10) y6b = min10b ELSE CALL POPREAL8(min10) y6b = 0.0 END IF crb = crb + y6b abs5b = y6b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs5b ELSE crb = crb - abs5b END IF tempb25 = dt*crb/(dx*mu) velb = velb + tempb25 mub0 = mub0 - vel*tempb25/mu CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i-1, j) = mutb(i-1, j) + 0.5*mub0 CALL POPREAL8(dx) END DO END DO END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO j=ad_to4,ad_from4,-1 CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .NE. 0) THEN IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp6 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i& & , k, j)-field(i, k, j-1)) temp9 = SIGN(1., vel) temp8 = temp9/12. temp7 = SIGN(1, time_step) tempb21 = vel*fqyb(i, k, j) tempb22 = 7.*tempb21/12. tempb23 = temp7*temp8*tempb21 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(& & i, k, j+1)+field(i, k, j-2))/12.+temp7*(temp8*temp6))*& & fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb22 - 3.*tempb23 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb23 + & & tempb22 fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb23 - tempb21/& & 12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb23 - tempb21/& & 12. fqyb(i, k, j) = 0.0 tempb24 = dy*mu*fqylb(i, k, j)/dt min7b = 0.5*field_old(i, k, j-1)*tempb24 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min7*& & tempb24 max6b = 0.5*field_old(i, k, j)*tempb24 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max6*& & tempb24 mub0 = (0.5*(min7*field_old(i, k, j-1))+0.5*(max6*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max6) y21b = max6b ELSE CALL POPREAL8(max6) y21b = 0.0 END IF crb = y21b abs19b = -y21b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs19b ELSE crb = crb - abs19b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min7) y5b = min7b ELSE CALL POPREAL8(min7) y5b = 0.0 END IF crb = crb + y5b abs4b = y5b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs4b ELSE crb = crb - abs4b END IF tempb20 = dt*crb/(dy*mu) velb = velb + tempb20 mub0 = mub0 - vel*tempb20/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) tempb18 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb18 fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb18 fqyb(i, k, j) = 0.0 tempb19 = dy*mu*fqylb(i, k, j)/dt min6b = 0.5*field_old(i, k, j-1)*tempb19 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min6*& & tempb19 max5b = 0.5*field_old(i, k, j)*tempb19 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max5*& & tempb19 mub0 = (0.5*(min6*field_old(i, k, j-1))+0.5*(max5*& & field_old(i, k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max5) y20b = max5b ELSE CALL POPREAL8(max5) y20b = 0.0 END IF crb = y20b abs18b = -y20b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs18b ELSE crb = crb - abs18b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min6) y4b = min6b ELSE CALL POPREAL8(min6) y4b = 0.0 END IF crb = crb + y4b abs3b = y4b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs3b ELSE crb = crb - abs3b END IF tempb17 = dt*crb/(dy*mu) velb = tempb17 mub0 = mub0 - vel*tempb17/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) temp2 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k, & & j)-field(i, k, j-1)) temp5 = SIGN(1., vel) temp4 = temp5/12. temp3 = SIGN(1, time_step) tempb13 = vel*fqyb(i, k, j) tempb14 = 7.*tempb13/12. tempb15 = temp3*temp4*tempb13 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i, k& & , j+1)+field(i, k, j-2))/12.+temp3*(temp4*temp2))*fqyb(i, k& & , j) fieldb(i, k, j) = fieldb(i, k, j) + tempb14 - 3.*tempb15 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb15 + tempb14 fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb15 - tempb13/12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb15 - tempb13/12. fqyb(i, k, j) = 0.0 tempb16 = dy*mu*fqylb(i, k, j)/dt min5b = 0.5*field_old(i, k, j-1)*tempb16 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min5*& & tempb16 max4b = 0.5*field_old(i, k, j)*tempb16 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max4*tempb16 mub0 = (0.5*(min5*field_old(i, k, j-1))+0.5*(max4*field_old(i& & , k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max4) y19b = max4b ELSE CALL POPREAL8(max4) y19b = 0.0 END IF crb = y19b abs17b = -y19b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs17b ELSE crb = crb - abs17b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min5) y3b = min5b ELSE CALL POPREAL8(min5) y3b = 0.0 END IF crb = crb + y3b abs2b = y3b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs2b ELSE crb = crb - abs2b END IF tempb12 = dt*crb/(dy*mu) velb = velb + tempb12 mub0 = mub0 - vel*tempb12/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) tempb10 = 0.5*rv(i, k, j)*fqyb(i, k, j) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k, & & j-1))*fqyb(i, k, j) fieldb(i, k, j) = fieldb(i, k, j) + tempb10 fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb10 fqyb(i, k, j) = 0.0 tempb11 = dy*mu*fqylb(i, k, j)/dt min4b = 0.5*field_old(i, k, j-1)*tempb11 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min4*& & tempb11 max3b = 0.5*field_old(i, k, j)*tempb11 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max3*tempb11 mub0 = (0.5*(min4*field_old(i, k, j-1))+0.5*(max3*field_old(i& & , k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max3) y18b = max3b ELSE CALL POPREAL8(max3) y18b = 0.0 END IF crb = y18b abs16b = -y18b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs16b ELSE crb = crb - abs16b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min4) y2b = min4b ELSE CALL POPREAL8(min4) y2b = 0.0 END IF crb = crb + y2b abs1b = y2b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs1b ELSE crb = crb - abs1b END IF tempb9 = dt*crb/(dy*mu) velb = tempb9 mub0 = mub0 - vel*tempb9/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 fqylb(i, k, j) = fqylb(i, k, j) - fqyb(i, k, j) wi0 = gi0/(eps1+beta0)**pw wi1 = gi1/(eps1+beta1)**pw wi2 = gi2/(eps1+beta2)**pw sumwk = wi0 + wi1 + wi2 tempb1 = vel*fqyb(i, k, j)/sumwk tempb2 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, j)/sumwk f0b = wi0*tempb1 f1b = wi1*tempb1 f2b = wi2*tempb1 velb = tempb2 sumwkb = -(vel*tempb2/sumwk) wi0b = sumwkb + f0*tempb1 wi1b = sumwkb + f1*tempb1 wi2b = sumwkb + f2*tempb1 fqyb(i, k, j) = 0.0 temp1 = (eps1+beta2)**pw IF (eps1 + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps1+beta2)**(pw-1)*wi2b/temp1**2) END IF temp0 = (eps1+beta1)**pw IF (eps1 + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps1+beta1)**(pw-1)*wi1b/temp0**2) END IF temp = (eps1+beta0)**pw IF (eps1 + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps1+beta0)**(pw-1)*wi0b/temp**2) END IF CALL POPREAL8(beta2) tempb3 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb4 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb4 - f2b/6. + tempb3 CALL POPREAL8(beta1) tempb5 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb8 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb5 - tempb8 + f1b/3. + 5.*f2b/6. - 4.*tempb4 - 2.*& & tempb3 CALL POPREAL8(beta0) tempb7 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb6 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb5 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb6 & & + tempb7 + 3.*tempb4 + tempb3 qim1b = tempb8 - 4.*tempb6 - 7.*f0b/6. - f1b/6. - 2.*tempb7 + & & tempb5 qim2b = f0b/3. + tempb6 + tempb7 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) fieldb(i, k, j-3) = fieldb(i, k, j-3) + qim2b CALL POPREAL8(qim1) fieldb(i, k, j-2) = fieldb(i, k, j-2) + qim1b CALL POPREAL8(qi) fieldb(i, k, j-1) = fieldb(i, k, j-1) + qib CALL POPREAL8(qip1) fieldb(i, k, j) = fieldb(i, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i, k, j+1) = fieldb(i, k, j+1) + qip2b ELSE CALL POPREAL8(qim2) fieldb(i, k, j+2) = fieldb(i, k, j+2) + qim2b CALL POPREAL8(qim1) fieldb(i, k, j+1) = fieldb(i, k, j+1) + qim1b CALL POPREAL8(qi) fieldb(i, k, j) = fieldb(i, k, j) + qib CALL POPREAL8(qip1) fieldb(i, k, j-1) = fieldb(i, k, j-1) + qip1b CALL POPREAL8(qip2) fieldb(i, k, j-2) = fieldb(i, k, j-2) + qip2b END IF tempb0 = dy*mu*fqylb(i, k, j)/dt min3b = 0.5*field_old(i, k, j-1)*tempb0 field_oldb(i, k, j-1) = field_oldb(i, k, j-1) + 0.5*min3*& & tempb0 max2b = 0.5*field_old(i, k, j)*tempb0 field_oldb(i, k, j) = field_oldb(i, k, j) + 0.5*max2*tempb0 mub0 = (0.5*(min3*field_old(i, k, j-1))+0.5*(max2*field_old(i& & , k, j)))*dy*fqylb(i, k, j)/dt fqylb(i, k, j) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(max2) y17b = max2b ELSE CALL POPREAL8(max2) y17b = 0.0 END IF crb = y17b abs15b = -y17b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs15b ELSE crb = crb - abs15b END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(min3) y1b = min3b ELSE CALL POPREAL8(min3) y1b = 0.0 END IF crb = crb + y1b abs0b = y1b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN crb = crb + abs0b ELSE crb = crb - abs0b END IF tempb = dt*crb/(dy*mu) velb = velb + tempb mub0 = mub0 - vel*tempb/mu CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + velb CALL POPREAL8(mu) mutb(i, j) = mutb(i, j) + 0.5*mub0 mutb(i, j-1) = mutb(i, j-1) + 0.5*mub0 CALL POPREAL8(dy) END DO END DO END IF END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) END SUBROUTINE A_ADVECT_SCALAR_WENOPD SUBROUTINE a_advect_scalar_mono(field,a_field,field_old,a_field_old,tendency, & 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, & config_flags,tenddec,msfux,msfuy,msfvx,msfvy,msftx,msfty,fzm,fzp,rdx,rdy,rdzw,dt,ids,ide,jds, & jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte) !PART I: DECLARATION OF VARIABLES IMPLICIT NONE INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ TYPE(grid_config_rec_type) :: config_flags LOGICAL :: tenddec INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,a_field,field_old,a_field_old, & ru,a_ru,rv,a_rv,rom,a_rom REAL,DIMENSION(ims:ime,jms:jme) :: mut,a_mut,mub,mu_old,a_mu_old REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: h_tendency, z_tendency REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_h_tendency, a_z_tendency REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty REAL,DIMENSION(kms:kme) :: fzm,fzp,rdzw REAL :: rdx,rdy,dt INTEGER :: i,j,k,itf,jtf,ktf INTEGER :: i_start,i_end,j_start,j_end INTEGER :: i_start_f,i_end_f,j_start_f,j_end_f INTEGER :: jmin,jmax,jp,jm,imin,imax REAL :: ub,a_ub,vb,a_vb REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqx,a_fqx,fqy,a_fqy,fqz,a_fqz REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqxl,a_fqxl,fqyl,a_fqyl,fqzl,a_fqzl REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: qmin,a_qmin,qmax,a_qmax REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: scale_in,a_scale_in,scale_out,a_scale_out REAL :: ph_upwind,a_ph_upwind INTEGER :: horz_order,vert_order LOGICAL :: degrade_xs,degrade_ys LOGICAL :: degrade_xe,degrade_ye INTEGER :: jp1,jp0,jtmp REAL :: flux_out,a_flux_out,ph_low,a_ph_low,flux_in,a_flux_in,ph_hi,a_ph_hi,scale,a_scale REAL,PARAMETER :: eps =1.e-20 REAL :: flux3,Diff_flux3,flux4,Diff_flux4,flux5,Diff_flux5,flux6,Diff_flux6,flux_upwind, & Diff_flux_upwind 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, & q_ip2,Diff_q_ip2,ua,Diff_ua,vel,a_vel,cr,Diff_cr,a_cr Diff_flux4(q_im2, Diff_q_im2,q_im1, Diff_q_im1,q_i, Diff_q_i,q_ip1, Diff_q_ip1, & ua, Diff_ua) =(7./12.)*(Diff_q_i +Diff_q_im1) -(1./12.)*(Diff_q_ip1 +Diff_q_im2) flux4(q_im2,q_im1,q_i,q_ip1,ua) =(7./12.)*(q_i +q_im1) -(1./12.)*(q_ip1 +q_im2) Diff_flux3(q_im2, Diff_q_im2,q_im1, Diff_q_im1,q_i, Diff_q_i,q_ip1, Diff_q_ip1, & ua, Diff_ua) =Diff_flux4(q_im2,Diff_q_im2,q_im1,Diff_q_im1,q_i,Diff_q_i,q_ip1, & Diff_q_ip1,ua,Diff_ua) +sign(1., ua) *(1./12.)*((Diff_q_ip1 -Diff_q_im2) & -3.*(Diff_q_i -Diff_q_im1)) flux3(q_im2,q_im1,q_i,q_ip1,ua) =flux4(q_im2,q_im1,q_i,q_ip1,ua) +sign(1., ua) & *(1./12.)*((q_ip1 -q_im2) -3.*(q_i -q_im1)) Diff_flux6(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,q_ip2, Diff_q_ip2,ua, Diff_ua) =(37./60.)*(Diff_q_i +Diff_q_im1) & -(2./15.)*(Diff_q_ip1 +Diff_q_im2) +(1./60.)*(Diff_q_ip2 +Diff_q_im3) flux6(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2,ua) =(37./60.)*(q_i +q_im1) -(2./15.) & *(q_ip1 +q_im2) +(1./60.)*(q_ip2 +q_im3) Diff_flux5(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,q_ip2, Diff_q_ip2,ua, Diff_ua) =Diff_flux6(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,q_ip2,Diff_q_ip2,ua, & Diff_ua) -sign(1., ua) *(1./60.)*((Diff_q_ip2 -Diff_q_im3) -5.*(Diff_q_ip1 - & Diff_q_im2) +10.*(Diff_q_i -Diff_q_im1)) 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, & ua) -sign(1., ua) *(1./60.)*((q_ip2 -q_im3) -5.*(q_ip1 -q_im2) +10.*(q_i -q_im1)) Diff_flux_upwind(q_im1, Diff_q_im1,q_i, Diff_q_i,cr, Diff_cr) =0.5 *(1.+sign(1., cr)) & *Diff_q_im1 +0.5 *(1.-sign(1., cr))*Diff_q_i flux_upwind(q_im1,q_i,cr) =0.5 *(1.+sign(1., cr))*q_im1 +0.5 *(1.-sign(1., cr))*q_i LOGICAL,PARAMETER :: mono_limit =.true. REAL :: Keep_Lpb3_cr REAL :: Keep_Lpb7_ub REAL :: Keep_Lpb11_vb REAL :: Keep_Lpb21_vel REAL :: Keep_Lpb21_cr INTEGER :: IX1,IX2,IX3 REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, & a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007,a_Tmpv8,Tmpv008,a_Tmpv9, & Tmpv009,a_Tmpv10,Tmpv010,a_Tmpv11,Tmpv011,a_Tmpv12,Tmpv012,gwalls REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv2400,Tmpv2401,Tmpv2402,Tmpv2403,Tmpv2404,Tmpv2405 REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv600,Tmpv601,Tmpv602,Tmpv603 REAL,DIMENSION(its-2:ite+2,kts:kte) :: Tmpv604,Tmpv605,Tmpv606,Tmpv607,Tmpv608, & Tmpv609,Tmpv6010,Tmpv6011,Tmpv6012,Tmpv6013,Tmpv6014,Tmpv6015,Tmpv6016, & Tmpv6017,Tmpv6018,Tmpv6019 REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv700,Tmpv701,Tmpv702,Tmpv703 REAL,DIMENSION(kts:kte,jts-2:jte+2) :: Tmpv704,Tmpv705,Tmpv706,Tmpv707,Tmpv708, & Tmpv709,Tmpv710,Tmpv711,Tmpv712,Tmpv713,Tmpv714,Tmpv715,Tmpv716, & Tmpv717,Tmpv718,Tmpv719 REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Tmpv800,Tmpv801,Tmpv802,Tmpv803 REAL,DIMENSION(its-2:ite+2,jts-2:jte+2) :: Tmpv804,Tmpv805,Tmpv806,Tmpv807,Tmpv808, & Tmpv809,Tmpv810,Tmpv811 !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & (ite < ide-4) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ye .or. & (jte < jde-4) ) degrade_ye = .false. !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS a_ub =0.0 a_vb =0.0 Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_fqx(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_fqy(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_fqz(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_fqxl(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_fqyl(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_fqzl(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_qmin(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_qmax(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_scale_in(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do Do K2_ADJ =jts-2, jte+2 Do K1_ADJ =kts, kte Do K0_ADJ =its-2, ite+2 a_scale_out(K0_ADJ,K1_ADJ,K2_ADJ) =0.0 End Do End Do End Do a_ph_upwind =0.0 a_flux_out =0.0 a_ph_low =0.0 a_flux_in =0.0 a_ph_hi =0.0 a_scale =0.0 a_vel =0.0 a_cr =0.0 !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[35] i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF(degrade_ys) j_start = MAX(jts,jds+1) IF(degrade_ye) j_end = MIN(jte,jde-2) IF(tenddec) THEN DO j =j_end, j_start, -1 DO k =ktf, kts, -1 DO i =i_end, i_start, -1 a_Tmpv1 =-rdy*msftx(i,j)*a_h_tendency(i,k,j) a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_Tmpv1 a_fqyl(i,k,j+1) =a_fqyl(i,k,j+1) +a_Tmpv1 a_fqy(i,k,j+1) =a_fqy(i,k,j+1) +a_Tmpv1 a_fqy(i,k,j) =a_fqy(i,k,j) -a_Tmpv1 ENDDO ENDDO ENDDO ENDIF DO j =j_end, j_start, -1 DO k =ktf, kts, -1 DO i =i_end, i_start, -1 a_Tmpv1 =-rdy*msftx(i,j)*a_tendency(i,k,j) a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_Tmpv1 a_fqyl(i,k,j+1) =a_fqyl(i,k,j+1) +a_Tmpv1 a_fqy(i,k,j+1) =a_fqy(i,k,j+1) +a_Tmpv1 a_fqy(i,k,j) =a_fqy(i,k,j) -a_Tmpv1 ENDDO ENDDO ENDDO !LPB[30] i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF(degrade_xs) i_start = MAX(its,ids+1) IF(degrade_xe) i_end = MIN(ite,ide-2) IF(tenddec) THEN DO j =j_end, j_start, -1 DO k =ktf, kts, -1 DO i =i_end, i_start, -1 a_Tmpv1 =-rdx*msftx(i,j)*a_h_tendency(i,k,j) a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_Tmpv1 a_fqxl(i+1,k,j) =a_fqxl(i+1,k,j) +a_Tmpv1 a_fqx(i+1,k,j) =a_fqx(i+1,k,j) +a_Tmpv1 a_fqx(i,k,j) =a_fqx(i,k,j) -a_Tmpv1 a_h_tendency(i,k,j) = 0.0 ENDDO ENDDO ENDDO ENDIF DO j =j_end, j_start, -1 DO k =ktf, kts, -1 DO i =i_end, i_start, -1 a_Tmpv1 =-rdx*msftx(i,j)*a_tendency(i,k,j) a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_Tmpv1 a_fqxl(i+1,k,j) =a_fqxl(i+1,k,j) +a_Tmpv1 a_fqx(i+1,k,j) =a_fqx(i+1,k,j) +a_Tmpv1 a_fqx(i,k,j) =a_fqx(i,k,j) -a_Tmpv1 ENDDO ENDDO ENDDO !LPB[25] i_start = its i_end = MIN(ite,ide-1) j_start = jts j_end = MIN(jte,jde-1) IF(tenddec) THEN DO j =j_end, j_start, -1 DO k =ktf, kts, -1 gwalls=-rdzw(k) DO i =i_end, i_start, -1 a_Tmpv1 =gwalls*a_z_tendency(i,k,j) a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1 a_fqzl(i,k+1,j) =a_fqzl(i,k+1,j) +a_Tmpv1 a_fqz(i,k+1,j) =a_fqz(i,k+1,j) +a_Tmpv1 a_fqz(i,k,j) =a_fqz(i,k,j) -a_Tmpv1 a_z_tendency(i,k,j) = 0.0 ENDDO ENDDO ENDDO ENDIF DO j =j_end, j_start, -1 DO k =ktf, kts, -1 gwalls=-rdzw(k) DO i =i_end, i_start, -1 a_Tmpv1 =gwalls*a_tendency(i,k,j) a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1 a_fqzl(i,k+1,j) =a_fqzl(i,k+1,j) +a_Tmpv1 a_fqz(i,k+1,j) =a_fqz(i,k+1,j) +a_Tmpv1 a_fqz(i,k,j) =a_fqz(i,k,j) -a_Tmpv1 ENDDO ENDDO ENDDO !LPB[1] qmin(its-2:ite+2,kts:kte,jts-2:jte+2) =field_old(its-2:ite+2,kts:kte,jts-2:jte+2) qmax(its-2:ite+2,kts:kte,jts-2:jte+2) =field_old(its-2:ite+2,kts:kte,jts-2:jte+2) scale_in(its-2:ite+2,kts:kte,jts-2:jte+2) =1. scale_out(its-2:ite+2,kts:kte,jts-2:jte+2) =1. fqx(its-2:ite+2,kts:kte,jts-2:jte+2) =0. fqy(its-2:ite+2,kts:kte,jts-2:jte+2) =0. fqz(its-2:ite+2,kts:kte,jts-2:jte+2) =0. fqxl(its-2:ite+2,kts:kte,jts-2:jte+2) =0. fqyl(its-2:ite+2,kts:kte,jts-2:jte+2) =0. fqzl(its-2:ite+2,kts:kte,jts-2:jte+2) =0. !LPB[3] IF( horz_order == 5 ) THEN ktf =min(kte, kde-1) i_start =its-1 i_end =min(ite, ide-1) +1 j_start =jts-1 j_end =min(jte, jde-1) +1 j_start_f =j_start j_end_f =j_end+1 IF(degrade_xs) i_start =max(its-1, ids) IF(degrade_xe) i_end =min(ite+1, ide-1) IF(degrade_ys) THEN j_start =max(jts-1, jds+1) j_start_f =jds+3 ENDIF IF(degrade_ye) THEN j_end =min(jte+1, jde-2) j_end_f =jde-3 ENDIF DO j =j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k =kts, ktf DO i =i_start, i_end vel =rv(i,k,j) cr =vel fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),vel) 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) & ,field(i,k,j+1),field(i,k,j+2),vel) fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j) IF(cr.gt. 0) THEN Tmpv600(i,k,j) = qmax(i,k,j) qmax(i,k,j) =amax1(qmax(i,k,j), field_old(i,k,j-1)) Tmpv601(i,k,j) = qmin(i,k,j) qmin(i,k,j) =amin1(qmin(i,k,j), field_old(i,k,j-1)) else Tmpv602(i,k,j-1) = qmax(i,k,j-1) qmax(i,k,j-1) =amax1(qmax(i,k,j-1), field_old(i,k,j)) Tmpv603(i,k,j-1) = qmin(i,k,j-1) qmin(i,k,j-1) =amin1(qmin(i,k,j-1), field_old(i,k,j)) end IF ENDDO ENDDO ELSE IF( j == jds+1 ) THEN DO k =kts, ktf DO i =i_start, i_end vel =rv(i,k,j) cr =vel fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr) fqy(i,k,j) =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1)) fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j) IF(cr.gt. 0) THEN Tmpv604(i,k) = qmax(i,k,j) qmax(i,k,j) =amax1(qmax(i,k,j), field_old(i,k,j-1)) Tmpv605(i,k) = qmin(i,k,j) qmin(i,k,j) =amin1(qmin(i,k,j), field_old(i,k,j-1)) else Tmpv606(i,k) = qmax(i,k,j-1) qmax(i,k,j-1) =amax1(qmax(i,k,j-1), field_old(i,k,j)) Tmpv607(i,k) = qmin(i,k,j-1) qmin(i,k,j-1) =amin1(qmin(i,k,j-1), field_old(i,k,j)) end IF ENDDO ENDDO ELSE IF( j == jds+2 ) THEN DO k =kts, ktf DO i =i_start, i_end vel =rv(i,k,j) cr =vel fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr) 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) fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j) IF(cr.gt. 0) THEN Tmpv608(i,k) = qmax(i,k,j) qmax(i,k,j) =max(qmax(i,k,j), field_old(i,k,j-1)) Tmpv609(i,k) = qmin(i,k,j) qmin(i,k,j) =min(qmin(i,k,j), field_old(i,k,j-1)) else Tmpv6010(i,k) = qmax(i,k,j-1) qmax(i,k,j-1) =max(qmax(i,k,j-1), field_old(i,k,j)) Tmpv6011(i,k) = qmin(i,k,j-1) qmin(i,k,j-1) =min(qmin(i,k,j-1), field_old(i,k,j)) end IF ENDDO ENDDO ELSE IF( j == jde-1 ) THEN DO k =kts, ktf DO i =i_start, i_end vel =rv(i,k,j) cr =vel fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr) fqy(i,k,j) =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1)) fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j) IF(cr.gt. 0) THEN Tmpv6012(i,k) = qmax(i,k,j) qmax(i,k,j) =max(qmax(i,k,j), field_old(i,k,j-1)) Tmpv6013(i,k) = qmin(i,k,j) qmin(i,k,j) =min(qmin(i,k,j), field_old(i,k,j-1)) else Tmpv6014(i,k) = qmax(i,k,j-1) qmax(i,k,j-1) =max(qmax(i,k,j-1), field_old(i,k,j)) Tmpv6015(i,k) = qmin(i,k,j-1) qmin(i,k,j-1) =min(qmin(i,k,j-1), field_old(i,k,j)) end IF ENDDO ENDDO ELSE IF( j == jde-2 ) THEN DO k =kts, ktf DO i =i_start, i_end vel =rv(i,k,j) cr =vel fqyl(i,k,j) =vel*flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr) 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) fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j) IF(cr.gt. 0) THEN Tmpv6016(i,k) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i,k,j-1)) qmax(i,k,j) =Tmpv001 Tmpv6017(i,k) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i,k,j-1)) qmin(i,k,j) =Tmpv001 else Tmpv6018(i,k) = qmax(i,k,j-1) qmax(i,k,j-1) =max(qmax(i,k,j-1), field_old(i,k,j)) Tmpv6019(i,k) = qmin(i,k,j-1) qmin(i,k,j-1) =min(qmin(i,k,j-1), field_old(i,k,j)) end IF ENDDO ENDDO ENDIF ENDDO i_start =its-1 i_end =min(ite, ide-1) +1 i_start_f =i_start i_end_f =i_end+1 j_start =jts-1 j_end =min(jte, jde-1) +1 IF(degrade_ys) j_start =max(jts-1, jds) IF(degrade_ye) j_end =min(jte+1, jde-1) IF(degrade_xs) THEN i_start =max(ids+1, its-1) i_start_f =ids+3 ENDIF IF(degrade_xe) THEN i_end =min(ide-2, ite+1) i_end_f =ide-3 ENDIF DO j =j_start, j_end DO k =kts, ktf DO i =i_start_f, i_end_f vel =ru(i,k,j) cr =vel fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr) 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) & ,field(i+1,k,j),field(i+2,k,j),vel) fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j) IF(cr.gt. 0) THEN Tmpv700(i,k,j) = qmax(i,k,j) qmax(i,k,j) =max(qmax(i,k,j), field_old(i-1,k,j)) Tmpv701(i,k,j) = qmin(i,k,j) qmin(i,k,j) =min(qmin(i,k,j), field_old(i-1,k,j)) else Tmpv702(i-1,k,j) = qmax(i-1,k,j) qmax(i-1,k,j) =max(qmax(i-1,k,j), field_old(i,k,j)) Tmpv703(i-1,k,j) = qmin(i-1,k,j) qmin(i-1,k,j) =min(qmin(i-1,k,j), field_old(i,k,j)) end IF ENDDO ENDDO IF( degrade_xs ) THEN DO i =i_start, i_start_f-1 IF(i == ids+1) THEN DO k =kts, ktf vel =ru(i,k,j) cr =vel fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr) fqx(i,k,j) =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j)) Tmpv001 =fqx(i,k,j) -fqxl(i,k,j) fqx(i,k,j) =Tmpv001 IF(cr.gt. 0) THEN Tmpv704(k,j) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j)) qmax(i,k,j) =Tmpv001 Tmpv705(k,j) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j)) qmin(i,k,j) =Tmpv001 else Tmpv706(k,j) = qmax(i-1,k,j) Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j)) qmax(i-1,k,j) =Tmpv001 Tmpv707(k,j) = qmin(i-1,k,j) Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j)) qmin(i-1,k,j) =Tmpv001 end IF ENDDO ENDIF IF(i == ids+2) THEN DO k =kts, ktf vel =ru(i,k,j) cr =vel fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr) 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) fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j) IF(cr.gt. 0) THEN Tmpv708(k,j) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j)) qmax(i,k,j) =Tmpv001 Tmpv709(k,j) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j)) qmin(i,k,j) =Tmpv001 else Tmpv710(k,j) = qmax(i-1,k,j) Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j)) qmax(i-1,k,j) =Tmpv001 Tmpv711(k,j) = qmin(i-1,k,j) Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j)) qmin(i-1,k,j) =Tmpv001 end IF ENDDO ENDIF ENDDO ENDIF IF( degrade_xe ) THEN DO i =i_end_f+1, i_end+1 IF( i == ide-1 ) THEN DO k =kts, ktf vel =ru(i,k,j) cr =vel fqxl(i,k,j) =vel*flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr) fqx(i,k,j) =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j)) fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j) IF(cr.gt. 0) THEN Tmpv712(k,j) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j)) qmax(i,k,j) =Tmpv001 Tmpv713(k,j) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j)) qmin(i,k,j) =Tmpv001 else Tmpv714(k,j) = qmax(i-1,k,j) Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j)) qmax(i-1,k,j) =Tmpv001 Tmpv715(k,j) = qmin(i-1,k,j) Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j)) qmin(i-1,k,j) =Tmpv001 end IF ENDDO ENDIF IF( i == ide-2 ) THEN DO k =kts, ktf vel =ru(i,k,j) cr =vel Tmpv001 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr) Tmpv002 =vel*Tmpv001 fqxl(i,k,j) =Tmpv002 Tmpv001 =flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel) Tmpv002 =vel*Tmpv001 fqx(i,k,j) =Tmpv002 Tmpv001 =fqx(i,k,j) -fqxl(i,k,j) fqx(i,k,j) =Tmpv001 IF(cr.gt. 0) THEN Tmpv716(k,j) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i-1,k,j)) qmax(i,k,j) =Tmpv001 Tmpv717(k,j) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i-1,k,j)) qmin(i,k,j) =Tmpv001 else Tmpv718(k,j) = qmax(i-1,k,j) Tmpv001 =max(qmax(i-1,k,j), field_old(i,k,j)) qmax(i-1,k,j) =Tmpv001 Tmpv719(k,j) = qmin(i-1,k,j) Tmpv001 =min(qmin(i-1,k,j), field_old(i,k,j)) qmin(i-1,k,j) =Tmpv001 end IF ENDDO ENDIF ENDDO ENDIF ENDDO ELSE ENDIF i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) !LPB[22] IF(vert_order == 3) THEN DO j =j_start, j_end DO i =i_start, i_end fqz(i,1,j) =0. fqzl(i,1,j) =0. fqz(i,kde,j) =0. fqzl(i,kde,j) =0. ENDDO DO k =kts+2, ktf-1 DO i =i_start, i_end vel =rom(i,k,j) cr =-vel fqzl(i,k,j) =vel*flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr) 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) fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j) IF(cr.gt. 0) THEN Tmpv800(i,k,j) = qmax(i,k,j) qmax(i,k,j) =max(qmax(i,k,j), field_old(i,k-1,j)) Tmpv801(i,k,j) = qmin(i,k,j) qmin(i,k,j) =min(qmin(i,k,j), field_old(i,k-1,j)) else Tmpv802(i,k-1,j) = qmax(i,k-1,j) qmax(i,k-1,j) =max(qmax(i,k-1,j), field_old(i,k,j)) Tmpv803(i,k-1,j) = qmin(i,k-1,j) qmin(i,k-1,j) =min(qmin(i,k-1,j), field_old(i,k,j)) end IF ENDDO ENDDO DO i =i_start, i_end k =kts+1 vel =rom(i,k,j) cr =-vel fqzl(i,k,j) =vel*flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr) fqz(i,k,j) =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j)) Tmpv001 =fqz(i,k,j) -fqzl(i,k,j) fqz(i,k,j) =Tmpv001 IF(cr.gt. 0) THEN Tmpv804(i,j) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i,k-1,j)) qmax(i,k,j) =Tmpv001 Tmpv805(i,j) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i,k-1,j)) qmin(i,k,j) =Tmpv001 else Tmpv806(i,j) = qmax(i,k-1,j) Tmpv001 =max(qmax(i,k-1,j), field_old(i,k,j)) qmax(i,k-1,j) =Tmpv001 Tmpv807(i,j) = qmin(i,k-1,j) Tmpv001 =min(qmin(i,k-1,j), field_old(i,k,j)) qmin(i,k-1,j) =Tmpv001 end IF k =ktf vel =rom(i,k,j) cr =-vel fqzl(i,k,j) =vel*flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr) fqz(i,k,j) =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j)) fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j) IF(cr.gt. 0) THEN Tmpv808(i,j) = qmax(i,k,j) Tmpv001 =max(qmax(i,k,j), field_old(i,k-1,j)) qmax(i,k,j) =Tmpv001 Tmpv809(i,j) = qmin(i,k,j) Tmpv001 =min(qmin(i,k,j), field_old(i,k-1,j)) qmin(i,k,j) =Tmpv001 else Tmpv810(i,j) = qmax(i,k-1,j) qmax(i,k-1,j) =max(qmax(i,k-1,j), field_old(i,k,j)) Tmpv811(i,j) = qmin(i,k-1,j) qmin(i,k-1,j) =min(qmin(i,k-1,j), field_old(i,k,j)) end IF ENDDO ENDDO ELSE ENDIF !LPB[23] IF(mono_limit) THEN i_start =its-1 Tmpv001 =min(ite, ide-1) +1 i_end =Tmpv001 j_start =jts-1 Tmpv001 =min(jte, jde-1) +1 j_end =Tmpv001 IF(degrade_xs) THEN i_start =max(its-1, ids) END IF IF(degrade_xe) THEN i_end =min(ite+1, ide-1) END IF IF(degrade_ys) THEN j_start =max(jts-1, jds) END IF IF(degrade_ye) THEN j_end =min(jte+1, jde-1) END IF IF(config_flags%specified .or. config_flags%nested) THEN IF(degrade_xs) THEN i_start =max(its-1, ids+1) END IF IF(degrade_xe) THEN i_end =min(ite+1, ide-2) END IF IF(degrade_ys) THEN j_start =max(jts-1, jds+1) END IF IF(degrade_ye) THEN j_end =min(jte+1, jde-2) END IF END IF IF(config_flags%open_xs) THEN IF(degrade_xs) THEN i_start =max(its-1, ids+1) END IF END IF IF(config_flags%open_xe) THEN IF(degrade_xe) THEN i_end =min(ite+1, ide-2) END IF END IF IF(config_flags%open_ys) THEN IF(degrade_ys) THEN j_start =max(jts-1, jds+1) END IF END IF IF(config_flags%open_ye) THEN IF(degrade_ye) THEN j_end =min(jte+1, jde-2) END IF END IF DO j =j_start, j_end DO k =kts, ktf DO i =i_start, i_end Tmpv001 =(mub(i,j) +mu_old(i,j))*field_old(i,k,j) Tmpv002 =fqxl(i+1,k,j) -fqxl(i,k,j) Tmpv003 =rdx*Tmpv002 Tmpv004 =fqyl(i,k,j+1) -fqyl(i,k,j) Tmpv005 =rdy*Tmpv004 Tmpv006 =Tmpv003 +Tmpv005 Tmpv007 =msftx(i,j)*msfty(i,j)*Tmpv006 Tmpv008 =fqzl(i,k+1,j) -fqzl(i,k,j) Tmpv009 =msfty(i,j)*rdzw(k)*Tmpv008 ph_upwind =Tmpv001 -dt*(Tmpv007 +Tmpv009) Tmpv001 =min(0., fqx(i+1,k,j)) -max(0., fqx(i,k,j)) Tmpv002 =rdx*Tmpv001 Tmpv003 =min(0., fqy(i,k,j+1)) -max(0., fqy(i,k,j)) Tmpv004 =rdy*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =(msftx(i,j)*msfty(i,j))*Tmpv005 Tmpv007 =max(0., fqz(i,k+1,j)) -min(0., fqz(i,k,j)) Tmpv008 =msfty(i,j)*rdzw(k)*Tmpv007 Tmpv009 =Tmpv006 +Tmpv008 Tmpv010 =-dt*Tmpv009 flux_in =Tmpv010 Tmpv2400(i,k,j) =flux_in Tmpv001 =mut(i,j)*qmax(i,k,j) Tmpv002 =Tmpv001 -ph_upwind ph_hi =Tmpv002 Tmpv2401(i,k,j) =ph_hi IF( flux_in .gt. ph_hi ) THEN Tmpv001 =ph_hi/(flux_in +eps) Tmpv2402(i,k,j) =Tmpv001 scale_in(i,k,j) =max(0., Tmpv2402(i,k,j)) END IF Tmpv001 =max(0., fqx(i+1,k,j)) -min(0., fqx(i,k,j)) Tmpv002 =rdx*Tmpv001 Tmpv003 =max(0., fqy(i,k,j+1)) -min(0., fqy(i,k,j)) Tmpv004 =rdy*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =(msftx(i,j)*msfty(i,j))*Tmpv005 Tmpv007 =min(0., fqz(i,k+1,j)) -max(0., fqz(i,k,j)) Tmpv008 =msfty(i,j)*rdzw(k)*Tmpv007 Tmpv009 =Tmpv006 +Tmpv008 Tmpv010 =dt*Tmpv009 flux_out =Tmpv010 Tmpv2403(i,k,j) =flux_out Tmpv001 =mut(i,j)*qmin(i,k,j) Tmpv002 =ph_upwind -Tmpv001 ph_low =Tmpv002 Tmpv2404(i,k,j) =ph_low IF( flux_out .gt. ph_low ) THEN Tmpv001 =ph_low/(flux_out +eps) Tmpv2405(i,k,j) =Tmpv001 scale_out(i,k,j) =max(0., Tmpv2405(i,k,j)) END IF ENDDO ENDDO ENDDO DO j =j_end, j_start, -1 DO k =ktf, kts+1, -1 DO i =i_end, i_start, -1 IF( fqz (i,k,j) .lt. 0.) THEN a_Tmpv2 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 a_Tmpv1 =fqz(i,k,j)*a_Tmpv2 a_fqz(i,k,j) =a_fqz(i,k,j) +min(scale_in(i,k,j), scale_out(i,k-1,j))*a_Tmpv2 a_scale_in(i,k,j) =a_scale_in(i,k,j) +(1.0 -sign(1.0, scale_in(i,k,j) & -scale_out(i,k-1,j)))*0.5*1.0*a_Tmpv1 a_scale_out(i,k-1,j) =a_scale_out(i,k-1,j) +(1.0 +sign(1.0, scale_in(i,k,j) & -scale_out(i,k-1,j)))*0.5*1.0*a_Tmpv1 ELSE a_Tmpv2 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 a_Tmpv1 =fqz(i,k,j)*a_Tmpv2 a_fqz(i,k,j) =a_fqz(i,k,j) +min(scale_out(i,k,j), scale_in(i,k-1,j))*a_Tmpv2 a_scale_out(i,k,j) =a_scale_out(i,k,j) +(1.0 -sign(1.0, scale_out(i,k,j) & -scale_in(i,k-1,j)))*0.5*1.0*a_Tmpv1 a_scale_in(i,k-1,j) =a_scale_in(i,k-1,j) +(1.0 +sign(1.0, scale_out(i,k,j) & -scale_in(i,k-1,j)))*0.5*1.0*a_Tmpv1 ENDIF ENDDO ENDDO ENDDO DO j =j_end+1, j_start, -1 DO k =ktf, kts, -1 DO i =i_end, i_start, -1 IF( fqy (i,k,j) .gt. 0.) THEN a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 a_Tmpv1 =fqy(i,k,j)*a_Tmpv2 a_fqy(i,k,j) =a_fqy(i,k,j) +min(scale_in(i,k,j), scale_out(i,k,j-1))*a_Tmpv2 a_scale_in(i,k,j) =a_scale_in(i,k,j) +(1.0 -sign(1.0, scale_in(i,k,j) & -scale_out(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_scale_out(i,k,j-1) =a_scale_out(i,k,j-1) +(1.0 +sign(1.0, scale_in(i,k,j) & -scale_out(i,k,j-1)))*0.5*1.0*a_Tmpv1 ELSE a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 a_Tmpv1 =fqy(i,k,j)*a_Tmpv2 a_fqy(i,k,j) =a_fqy(i,k,j) +min(scale_out(i,k,j), scale_in(i,k,j-1))*a_Tmpv2 a_scale_out(i,k,j) =a_scale_out(i,k,j) +(1.0 -sign(1.0, scale_out(i,k,j) & -scale_in(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_scale_in(i,k,j-1) =a_scale_in(i,k,j-1) +(1.0 +sign(1.0, scale_out(i,k,j) & -scale_in(i,k,j-1)))*0.5*1.0*a_Tmpv1 ENDIF ENDDO ENDDO ENDDO DO j =j_end, j_start, -1 DO k =ktf, kts, -1 DO i =i_end+1, i_start, -1 IF( fqx (i,k,j) .gt. 0.) THEN a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 a_Tmpv1 =fqx(i,k,j)*a_Tmpv2 a_fqx(i,k,j) =a_fqx(i,k,j) +min(scale_in(i,k,j), scale_out(i-1,k,j))*a_Tmpv2 a_scale_in(i,k,j) =a_scale_in(i,k,j) +(1.0 -sign(1.0, scale_in(i,k,j) & -scale_out(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_scale_out(i-1,k,j) =a_scale_out(i-1,k,j) +(1.0 +sign(1.0, scale_in(i,k,j) & -scale_out(i-1,k,j)))*0.5*1.0*a_Tmpv1 ELSE a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 a_Tmpv1 =fqx(i,k,j)*a_Tmpv2 a_fqx(i,k,j) =a_fqx(i,k,j) +min(scale_out(i,k,j), scale_in(i-1,k,j))*a_Tmpv2 a_scale_out(i,k,j) =a_scale_out(i,k,j) +(1.0 -sign(1.0, scale_out(i,k,j) & -scale_in(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_scale_in(i-1,k,j) =a_scale_in(i-1,k,j) +(1.0 +sign(1.0, scale_out(i,k,j) & -scale_in(i-1,k,j)))*0.5*1.0*a_Tmpv1 ENDIF ENDDO ENDDO ENDDO DO j =j_end, j_start, -1 DO k =ktf, kts, -1 DO i =i_end, i_start, -1 flux_out = Tmpv2403(i,k,j) ph_low = Tmpv2404(i,k,j) IF( flux_out .gt. ph_low ) THEN a_Tmpv1 = (1.0 +(-1.0)*sign(1.0, 0. -Tmpv2405(i,k,j)))*0.5*a_scale_out(i,k,j) a_scale_out(i,k,j) =0.0 a_ph_low =a_ph_low +a_Tmpv1/(flux_out +eps) a_flux_out =a_flux_out -ph_low/((flux_out +eps)*(flux_out +eps))*a_Tmpv1 END IF a_Tmpv2 =a_ph_low a_ph_low =0.0 a_ph_upwind =a_ph_upwind +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_mut(i,j) =a_mut(i,j) +qmin(i,k,j)*a_Tmpv1 a_qmin(i,k,j) =a_qmin(i,k,j) +mut(i,j)*a_Tmpv1 a_Tmpv10 =a_flux_out a_flux_out =0.0 a_Tmpv9 =dt*a_Tmpv10 a_Tmpv6 =a_Tmpv9 a_Tmpv8 =a_Tmpv9 a_Tmpv7 =msfty(i,j)*rdzw(k)*a_Tmpv8 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 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 a_Tmpv5 =(msftx(i,j)*msfty(i,j))*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =rdy*a_Tmpv4 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 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 a_Tmpv1 =rdx*a_Tmpv2 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 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 flux_in =Tmpv2400(i,k,j) ph_hi =Tmpv2401(i,k,j) IF( flux_in .gt. ph_hi ) THEN a_Tmpv1 = (1.0 +(-1.0)*sign(1.0, 0. -Tmpv2402(i,k,j)))*0.5*a_scale_in(i,k,j) a_scale_in(i,k,j) =0.0 a_ph_hi =a_ph_hi +a_Tmpv1/(flux_in +eps) a_flux_in =a_flux_in -ph_hi/((flux_in +eps)*(flux_in +eps))*a_Tmpv1 END IF a_Tmpv2 =a_ph_hi a_ph_hi =0.0 a_Tmpv1 =a_Tmpv2 a_ph_upwind =a_ph_upwind -a_Tmpv2 a_mut(i,j) =a_mut(i,j) +qmax(i,k,j)*a_Tmpv1 a_qmax(i,k,j) =a_qmax(i,k,j) +mut(i,j)*a_Tmpv1 a_Tmpv10 =a_flux_in a_flux_in =0.0 a_Tmpv9 =-dt*a_Tmpv10 a_Tmpv6 =a_Tmpv9 a_Tmpv8 =a_Tmpv9 a_Tmpv7 =msfty(i,j)*rdzw(k)*a_Tmpv8 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 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 a_Tmpv5 =(msftx(i,j)*msfty(i,j))*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =rdy*a_Tmpv4 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 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 a_Tmpv1 =rdx*a_Tmpv2 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 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 a_Tmpv12 =a_ph_upwind a_ph_upwind =0.0 a_Tmpv1 =a_Tmpv12 a_Tmpv11 =-a_Tmpv12 a_Tmpv10 =dt*a_Tmpv11 a_Tmpv7 =a_Tmpv10 a_Tmpv9 =a_Tmpv10 a_Tmpv8 =msfty(i,j)*rdzw(k)*a_Tmpv9 a_fqzl(i,k+1,j) =a_fqzl(i,k+1,j) +a_Tmpv8 a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv8 a_Tmpv6 =msftx(i,j)*msfty(i,j)*a_Tmpv7 a_Tmpv3 =a_Tmpv6 a_Tmpv5 =a_Tmpv6 a_Tmpv4 =rdy*a_Tmpv5 a_fqyl(i,k,j+1) =a_fqyl(i,k,j+1) +a_Tmpv4 a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_Tmpv4 a_Tmpv2 =rdx*a_Tmpv3 a_fqxl(i+1,k,j) =a_fqxl(i+1,k,j) +a_Tmpv2 a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_Tmpv2 a_mu_old(i,j) =a_mu_old(i,j) +field_old(i,k,j)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(mub(i,j) +mu_old(i,j))*a_Tmpv1 ENDDO ENDDO ENDDO END IF !LPB[22] i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(vert_order == 3) THEN DO j =j_end, j_start, -1 DO i =i_end, i_start, -1 k =ktf vel = rom(i,k,j) cr = -vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv808(i,j) qmin(i,k,j) = Tmpv809(i,j) a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1 else qmax(i,k-1,j) = Tmpv810(i,j) qmin(i,k-1,j) = Tmpv811(i,j) a_Tmpv1 =a_qmin(i,k-1,j) a_qmin(i,k-1,j) =0.0 a_qmin(i,k-1,j) =a_qmin(i,k-1,j) +(1.0 -sign(1.0, qmin(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k-1,j) a_qmax(i,k-1,j) =0.0 a_qmax(i,k-1,j) =a_qmax(i,k-1,j) +(1.0 +sign(1.0, qmax(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_Tmpv1 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 a_fqz(i,k,j) =a_fqz(i,k,j) +a_Tmpv1 a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1 a_Tmpv2 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 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 a_Tmpv1 =rom(i,k,j)*a_Tmpv2 a_field(i,k,j) =a_field(i,k,j) +fzm(k)*a_Tmpv1 a_field(i,k-1,j) =a_field(i,k-1,j) +fzp(k)*a_Tmpv1 a_Tmpv2 =a_fqzl(i,k,j) a_fqzl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k-1,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k-1,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +Diff_flux_upwind(field_old(i,k-1,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel -a_cr a_cr =0.0 a_rom(i,k,j) =a_rom(i,k,j) +a_vel a_vel =0.0 k =kts+1 vel = rom(i,k,j) cr = -vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv804(i,j) qmin(i,k,j) = Tmpv805(i,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1 else qmax(i,k-1,j) = Tmpv806(i,j) qmin(i,k-1,j) = Tmpv807(i,j) a_Tmpv1 =a_qmin(i,k-1,j) a_qmin(i,k-1,j) =0.0 a_qmin(i,k-1,j) =a_qmin(i,k-1,j) +(1.0 -sign(1.0, qmin(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k-1,j) a_qmax(i,k-1,j) =0.0 a_qmax(i,k-1,j) =a_qmax(i,k-1,j) +(1.0 +sign(1.0, qmax(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_Tmpv1 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 a_fqz(i,k,j) =a_fqz(i,k,j) +a_Tmpv1 a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_Tmpv1 a_Tmpv2 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 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 a_Tmpv1 =rom(i,k,j)*a_Tmpv2 a_field(i,k,j) =a_field(i,k,j) +fzm(k)*a_Tmpv1 a_field(i,k-1,j) =a_field(i,k-1,j) +fzp(k)*a_Tmpv1 a_Tmpv2 =a_fqzl(i,k,j) a_fqzl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k-1,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k-1,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +Diff_flux_upwind(field_old(i,k-1,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel -a_cr a_cr =0.0 a_rom(i,k,j) =a_rom(i,k,j) +a_vel a_vel =0.0 ENDDO DO k =ktf-1, kts+2, -1 DO i =i_end, i_start, -1 vel = rom(i,k,j) cr = -vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv800(i,k,j) qmin(i,k,j) = Tmpv801(i,k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k-1,j)))*0.5*1.0*a_Tmpv1 else qmax(i,k-1,j) = Tmpv802(i,k-1,j) qmin(i,k-1,j) = Tmpv803(i,k-1,j) a_Tmpv1 =a_qmin(i,k-1,j) a_qmin(i,k-1,j) =0.0 a_qmin(i,k-1,j) =a_qmin(i,k-1,j) +(1.0 -sign(1.0, qmin(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k-1,j) a_qmax(i,k-1,j) =0.0 a_qmax(i,k-1,j) =a_qmax(i,k-1,j) +(1.0 +sign(1.0, qmax(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k-1,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqzl(i,k,j) =a_fqzl(i,k,j) -a_fqz(i,k,j) a_Tmpv2 =a_fqz(i,k,j) a_fqz(i,k,j) =0.0 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 a_Tmpv1 =vel*a_Tmpv2 a_vel =a_vel -Diff_flux3(field(i,k-2,j),0.0,field(i,k-1,j),0.0,field(i,k,j) & ,0.0,field(i,k+1,j),0.0,-vel,1.0)*a_Tmpv1 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, & j),0.0,field(i,k,j),0.0,field(i,k+1,j),1.0,-vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i,k-2,j),0.0,field(i,k-1,j) & ,0.0,field(i,k,j),1.0,field(i,k+1,j),0.0,-vel,0.0)*a_Tmpv1 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, & j),1.0,field(i,k,j),0.0,field(i,k+1,j),0.0,-vel,0.0)*a_Tmpv1 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, & j),0.0,field(i,k,j),0.0,field(i,k+1,j),0.0,-vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqzl(i,k,j) a_fqzl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k-1,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k-1,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k-1,j) =a_field_old(i,k-1,j) +Diff_flux_upwind(field_old(i,k-1,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel -a_cr a_cr =0.0 a_rom(i,k,j) =a_rom(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO DO i =i_end, i_start, -1 a_fqzl(i,kde,j) =0.0 a_fqz(i,kde,j) =0.0 a_fqzl(i,1,j) =0.0 a_fqz(i,1,j) =0.0 ENDDO ENDDO ELSE ENDIF !LPB[12] i_start =its i_end =min(ite, ide-1) j_start =jts j_end =min(jte, jde-1) !LPB[11] IF( (config_flags%open_ye) .and. (jte == jde)) THEN DO i =i_end, i_start, -1 DO k =ktf, kts, -1 gwalls =0.5*(rv(i,k,jte-1) +rv(i,k,jte)) vb =max(gwalls, 0.) a_Tmpv7 =a_tendency(i,k,j_end) a_tendency(i,k,j_end) =0.0 a_tendency(i,k,j_end) =a_tendency(i,k,j_end) +a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_Tmpv5 =rdy*a_Tmpv6 a_field(i,k,j_end) =a_field(i,k,j_end) +(rv(i,k,jte) -rv(i,k,jte-1))*a_Tmpv5 a_Tmpv3 =field(i,k,j_end)*a_Tmpv5 a_rv(i,k,jte) =a_rv(i,k,jte) +a_Tmpv3 a_rv(i,k,jte-1) =a_rv(i,k,jte-1) -a_Tmpv3 a_vb =a_vb +(field_old(i,k,j_end) -field_old(i,k,j_end-1))*a_Tmpv5 a_Tmpv1 =vb*a_Tmpv5 a_field_old(i,k,j_end) =a_field_old(i,k,j_end) +a_Tmpv1 a_field_old(i,k,j_end-1) =a_field_old(i,k,j_end-1) -a_Tmpv1 a_Tmpv2 = (1.0 +(1.0)*sign(1.0, gwalls-0.))*0.5*a_vb a_vb =0.0 a_Tmpv1 =0.5*a_Tmpv2 a_rv(i,k,jte-1) =a_rv(i,k,jte-1) +a_Tmpv1 a_rv(i,k,jte) =a_rv(i,k,jte) +a_Tmpv1 ENDDO ENDDO ENDIF !LPB[9] IF( (config_flags%open_ys) .and. (jts == jds) ) THEN DO i =i_end, i_start, -1 DO k =ktf, kts, -1 gwalls =0.5*(rv(i,k,jts) +rv(i,k,jts+1)) vb =min(gwalls, 0.) a_Tmpv7 =a_tendency(i,k,jts) a_tendency(i,k,jts) =0.0 a_tendency(i,k,jts) =a_tendency(i,k,jts) +a_Tmpv7 a_Tmpv5 =-rdy*a_Tmpv7 a_field(i,k,jts) =a_field(i,k,jts) +(rv(i,k,jts+1) -rv(i,k,jts))*a_Tmpv5 a_Tmpv3 =field(i,k,jts)*a_Tmpv5 a_rv(i,k,jts+1) =a_rv(i,k,jts+1) +a_Tmpv3 a_rv(i,k,jts) =a_rv(i,k,jts) -a_Tmpv3 a_vb =a_vb +(field_old(i,k,jts+1) -field_old(i,k,jts))*a_Tmpv5 a_Tmpv1 =vb*a_Tmpv5 a_field_old(i,k,jts+1) =a_field_old(i,k,jts+1) +a_Tmpv1 a_field_old(i,k,jts) =a_field_old(i,k,jts) -a_Tmpv1 a_Tmpv2 = (1.0 -(1.0)*sign(1.0, gwalls-0.))*0.5*a_vb a_vb =0.0 a_Tmpv1 =0.5*a_Tmpv2 a_rv(i,k,jts) =a_rv(i,k,jts) +a_Tmpv1 a_rv(i,k,jts+1) =a_rv(i,k,jts+1) +a_Tmpv1 ENDDO ENDDO ENDIF !LPB[7] IF( (config_flags%open_xe) .and. (ite == ide) ) THEN DO j =j_end, j_start, -1 DO k =ktf, kts, -1 gwalls=0.5*(ru(ite-1,k,j) +ru(ite,k,j)) ub =max(gwalls, 0.) a_Tmpv7 =a_tendency(i_end,k,j) a_tendency(i_end,k,j) =0.0 a_tendency(i_end,k,j) =a_tendency(i_end,k,j) +a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_Tmpv5 =rdx*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_field(i_end,k,j) =a_field(i_end,k,j) +(ru(ite,k,j) -ru(ite-1,k,j))*a_Tmpv4 a_Tmpv3 =field(i_end,k,j)*a_Tmpv4 a_ru(ite,k,j) =a_ru(ite,k,j) +a_Tmpv3 a_ru(ite-1,k,j) =a_ru(ite-1,k,j) -a_Tmpv3 a_ub =a_ub +(field_old(i_end,k,j) -field_old(i_end-1,k,j))*a_Tmpv2 a_Tmpv1 =ub*a_Tmpv2 a_field_old(i_end,k,j) =a_field_old(i_end,k,j) +a_Tmpv1 a_field_old(i_end-1,k,j) =a_field_old(i_end-1,k,j) -a_Tmpv1 a_Tmpv2 = (1.0 +(1.0)*sign(1.0, gwalls-0.))*0.5*a_ub a_ub =0.0 a_Tmpv1 =0.5*a_Tmpv2 a_ru(ite-1,k,j) =a_ru(ite-1,k,j) +a_Tmpv1 a_ru(ite,k,j) =a_ru(ite,k,j) +a_Tmpv1 ENDDO ENDDO ENDIF !LPB[5] IF( (config_flags%open_xs) .and. (its == ids) ) THEN DO j =j_end, j_start, -1 DO k =ktf, kts, -1 gwalls =0.5*(ru(its,k,j) +ru(its+1,k,j)) ub =min(gwalls, 0.) a_Tmpv7 =a_tendency(its,k,j) a_tendency(its,k,j) =0.0 a_tendency(its,k,j) =a_tendency(its,k,j) +a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_Tmpv5 =rdx*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_field(its,k,j) =a_field(its,k,j) +(ru(its+1,k,j) -ru(its,k,j))*a_Tmpv4 a_Tmpv3 =field(its,k,j)*a_Tmpv4 a_ru(its+1,k,j) =a_ru(its+1,k,j) +a_Tmpv3 a_ru(its,k,j) =a_ru(its,k,j) -a_Tmpv3 a_ub =a_ub +(field_old(its+1,k,j) -field_old(its,k,j))*a_Tmpv2 a_Tmpv1 =ub*a_Tmpv2 a_field_old(its+1,k,j) =a_field_old(its+1,k,j) +a_Tmpv1 a_field_old(its,k,j) =a_field_old(its,k,j) -a_Tmpv1 a_Tmpv2 = (1.0 -(1.0)*sign(1.0, gwalls -0.))*0.5*a_ub a_ub =0.0 a_Tmpv1 =0.5*a_Tmpv2 a_ru(its,k,j) =a_ru(its,k,j) +a_Tmpv1 a_ru(its+1,k,j) =a_ru(its+1,k,j) +a_Tmpv1 ENDDO ENDDO ENDIF !LPB[3] IF( horz_order == 5 ) THEN ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 i_start_f = i_start i_end_f = i_end+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) IF(degrade_xs) then i_start = MAX(ids+1,its-1) i_start_f = ids+3 ENDIF IF(degrade_xe) then i_end = MIN(ide-2,ite+1) i_end_f = ide-3 ENDIF DO j =j_end, j_start, -1 IF( degrade_xe ) THEN DO i =i_end+1, i_end_f+1, -1 IF( i == ide-2 ) THEN DO k =ktf, kts, -1 vel =ru(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv716(k,j) qmin(i,k,j) = Tmpv717(k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 ELSE qmax(i-1,k,j) = Tmpv718(k,j) qmin(i-1,k,j) = Tmpv719(k,j) a_Tmpv1 =a_qmin(i-1,k,j) a_qmin(i-1,k,j) =0.0 a_qmin(i-1,k,j) =a_qmin(i-1,k,j) +(1.0 -sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i-1,k,j) a_qmax(i-1,k,j) =0.0 a_qmax(i-1,k,j) =a_qmax(i-1,k,j) +(1.0 +sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 END IF a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j) a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 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 a_Tmpv1 =vel*a_Tmpv2 a_vel =a_vel +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j),0.0,field(i,k,j) & ,0.0,field(i+1,k,j),0.0,vel,1.0)*a_Tmpv1 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, & j),0.0,field(i,k,j),0.0,field(i+1,k,j),1.0,vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j) & ,0.0,field(i,k,j),1.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1 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, & j),1.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1 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, & j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqxl(i,k,j) a_fqxl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_ru(i,k,j) =a_ru(i,k,j) +a_vel a_vel =0.0 ENDDO ENDIF IF( i == ide-1 ) THEN DO k =ktf, kts, -1 vel =ru(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv712(k,j) qmin(i,k,j) = Tmpv713(k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 else qmax(i-1,k,j) = Tmpv714(k,j) qmin(i-1,k,j) = Tmpv715(k,j) a_Tmpv1 =a_qmin(i-1,k,j) a_qmin(i-1,k,j) =0.0 a_qmin(i-1,k,j) =a_qmin(i-1,k,j) +(1.0 -sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i-1,k,j) a_qmax(i-1,k,j) =0.0 a_qmax(i-1,k,j) =a_qmax(i-1,k,j) +(1.0 +sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j) a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 a_ru(i,k,j) =a_ru(i,k,j) +0.5*(field(i,k,j) +field(i-1,k,j))*a_Tmpv2 a_Tmpv1 =0.5*(ru(i,k,j))*a_Tmpv2 a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1 a_field(i-1,k,j) =a_field(i-1,k,j) +a_Tmpv1 a_Tmpv2 =a_fqxl(i,k,j) a_fqxl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_ru(i,k,j) =a_ru(i,k,j) +a_vel a_vel =0.0 ENDDO ENDIF ENDDO ENDIF IF( degrade_xs ) THEN DO i =i_start_f-1, i_start, -1 IF(i == ids+2) THEN DO k =ktf, kts, -1 vel =ru(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv708(k,j) qmin(i,k,j) = Tmpv709(k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 else qmax(i-1,k,j) = Tmpv710(k,j) qmin(i-1,k,j) = Tmpv711(k,j) a_Tmpv1 =a_qmin(i-1,k,j) a_qmin(i-1,k,j) =0.0 a_qmin(i-1,k,j) =a_qmin(i-1,k,j) +(1.0 -sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i-1,k,j) a_qmax(i-1,k,j) =0.0 a_qmax(i-1,k,j) =a_qmax(i-1,k,j) +(1.0 +sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j) a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 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 a_Tmpv1 =vel*a_Tmpv2 a_vel =a_vel +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j),0.0,field(i,k,j) & ,0.0,field(i+1,k,j),0.0,vel,1.0)*a_Tmpv1 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, & j),0.0,field(i,k,j),0.0,field(i+1,k,j),1.0,vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i-2,k,j),0.0,field(i-1,k,j) & ,0.0,field(i,k,j),1.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1 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, & j),1.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1 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, & j),0.0,field(i,k,j),0.0,field(i+1,k,j),0.0,vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqxl(i,k,j) a_fqxl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_ru(i,k,j) =a_ru(i,k,j) +a_vel a_vel =0.0 ENDDO ENDIF IF(i == ids+1) THEN DO k =ktf, kts, -1 vel =ru(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv704(k,j) qmin(i,k,j) = Tmpv705(k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 else qmax(i-1,k,j) = Tmpv706(k,j) qmin(i-1,k,j) = Tmpv707(k,j) a_Tmpv1 =a_qmin(i-1,k,j) a_qmin(i-1,k,j) =0.0 a_qmin(i-1,k,j) =a_qmin(i-1,k,j) +(1.0 -sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i-1,k,j) a_qmax(i-1,k,j) =0.0 a_qmax(i-1,k,j) =a_qmax(i-1,k,j) +(1.0 +sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j) a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 a_ru(i,k,j) =a_ru(i,k,j) +0.5*(field(i,k,j)+field(i-1,k,j))*a_Tmpv2 a_Tmpv1 =0.5*(ru(i,k,j))*a_Tmpv2 a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1 a_field(i-1,k,j) =a_field(i-1,k,j) +a_Tmpv1 a_Tmpv2 =a_fqxl(i,k,j) a_fqxl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_ru(i,k,j) =a_ru(i,k,j) +a_vel a_vel =0.0 ENDDO ENDIF ENDDO ENDIF DO k =ktf, kts, -1 DO i =i_end_f, i_start_f, -1 vel =ru(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv700(i,k,j) qmin(i,k,j) = Tmpv701(i,k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i-1,k,j)))*0.5*1.0*a_Tmpv1 else qmax(i-1,k,j) = Tmpv702(i-1,k,j) qmin(i-1,k,j) = Tmpv703(i-1,k,j) a_Tmpv1 =a_qmin(i-1,k,j) a_qmin(i-1,k,j) =0.0 a_qmin(i-1,k,j) =a_qmin(i-1,k,j) +(1.0 -sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i-1,k,j) a_qmax(i-1,k,j) =0.0 a_qmax(i-1,k,j) =a_qmax(i-1,k,j) +(1.0 +sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i-1,k,j) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqxl(i,k,j) =a_fqxl(i,k,j) -a_fqx(i,k,j) a_Tmpv2 =a_fqx(i,k,j) a_fqx(i,k,j) =0.0 a_vel =a_vel +flux5(field(i-3,k,j),field(i-2,k,j),field(i-1,k,j),field(i,k,j) & ,field(i+1,k,j),field(i+2,k,j),vel)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 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) & ,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 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, & 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) & ,1.0,vel,0.0)*a_Tmpv1 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, & 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) & ,0.0,vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux5(field(i-3,k,j),0.0,field(i-2,k,j) & ,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) & ,0.0,vel,0.0)*a_Tmpv1 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, & 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) & ,0.0,vel,0.0)*a_Tmpv1 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, & 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) & ,0.0,vel,0.0)*a_Tmpv1 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, & 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) & ,0.0,vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqxl(i,k,j) a_fqxl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i-1,k,j),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i-1,k,j) =a_field_old(i-1,k,j) +Diff_flux_upwind(field_old(i-1,k,j) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_ru(i,k,j) =a_ru(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO ENDDO ktf=MIN(kte,kde-1) i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 j_start_f = j_start j_end_f = j_end+1 IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) then j_start = MAX(jts-1,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then j_end = MIN(jte+1,jde-2) j_end_f = jde-3 ENDIF DO j =j_end+1, j_start, -1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN DO k =ktf, kts, -1 DO i =i_end, i_start, -1 vel =rv(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv600(i,k,j) qmin(i,k,j) = Tmpv601(i,k,j) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 else qmax(i,k,j-1) = Tmpv602(i,k,j-1) qmin(i,k,j-1) = Tmpv603(i,k,j-1) a_Tmpv1 =a_qmin(i,k,j-1) a_qmin(i,k,j-1) =0.0 a_qmin(i,k,j-1) =a_qmin(i,k,j-1) +(1.0 -sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k,j-1) a_qmax(i,k,j-1) =0.0 a_qmax(i,k,j-1) =a_qmax(i,k,j-1) +(1.0 +sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j) a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 a_vel =a_vel +flux5(field(i,k,j-3),field(i,k,j-2),field(i,k,j-1),field(i,k,j) & ,field(i,k,j+1),field(i,k,j+2),vel)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 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) & ,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 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- & 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) & ,1.0,vel,0.0)*a_Tmpv1 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- & 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) & ,0.0,vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux5(field(i,k,j-3),0.0,field(i,k,j-2) & ,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) & ,0.0,vel,0.0)*a_Tmpv1 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- & 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) & ,0.0,vel,0.0)*a_Tmpv1 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- & 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) & ,0.0,vel,0.0)*a_Tmpv1 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- & 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) & ,0.0,vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqyl(i,k,j) a_fqyl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),vel)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_vel =a_vel +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j) & ,0.0,vel,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1) & ,0.0,field_old(i,k,j),1.0,vel,0.0)*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1) & ,1.0,field_old(i,k,j),0.0,vel,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_rv(i,k,j) =a_rv(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO ELSE IF( j == jds+1 ) THEN DO k =ktf, kts, -1 DO i =i_end, i_start, -1 vel =rv(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv604(i,k) qmin(i,k,j) = Tmpv605(i,k) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 else qmax(i,k,j-1) = Tmpv606(i,k) qmin(i,k,j-1) = Tmpv607(i,k) a_Tmpv1 =a_qmin(i,k,j-1) a_qmin(i,k,j-1) =0.0 a_qmin(i,k,j-1) =a_qmin(i,k,j-1) +(1.0 -sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k,j-1) a_qmax(i,k,j-1) =0.0 a_qmax(i,k,j-1) =a_qmax(i,k,j-1) +(1.0 +sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j) a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 a_rv(i,k,j) =a_rv(i,k,j) +0.5*(field(i,k,j) +field(i,k,j-1))*a_Tmpv2 a_Tmpv1 =0.5*rv(i,k,j)*a_Tmpv2 a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1 a_field(i,k,j-1) =a_field(i,k,j-1) +a_Tmpv1 a_Tmpv2 =a_fqyl(i,k,j) a_fqyl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_rv(i,k,j) =a_rv(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO ELSE IF( j == jds+2 ) THEN DO k =ktf, kts, -1 DO i =i_end, i_start, -1 vel =rv(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv608(i,k) qmin(i,k,j) = Tmpv609(i,k) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 else qmax(i,k,j-1) = Tmpv6010(i,k) qmin(i,k,j-1) = Tmpv6011(i,k) a_Tmpv1 =a_qmin(i,k,j-1) a_qmin(i,k,j-1) =0.0 a_qmin(i,k,j-1) =a_qmin(i,k,j-1) +(1.0 -sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k,j-1) a_qmax(i,k,j-1) =0.0 a_qmax(i,k,j-1) =a_qmax(i,k,j-1) +(1.0 +sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j) a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 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 a_Tmpv1 =vel*a_Tmpv2 a_vel =a_vel +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1),0.0,field(i,k,j) & ,0.0,field(i,k,j+1),0.0,vel,1.0)*a_Tmpv1 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- & 1),0.0,field(i,k,j),0.0,field(i,k,j+1),1.0,vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1) & ,0.0,field(i,k,j),1.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1 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- & 1),1.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1 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- & 1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqyl(i,k,j) a_fqyl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_rv(i,k,j) =a_rv(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO ELSE IF( j == jde-1 ) THEN DO k =ktf, kts, -1 DO i =i_end, i_start, -1 vel =rv(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv6012(i,k) qmin(i,k,j) = Tmpv6013(i,k) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 else qmax(i,k,j-1) = Tmpv6014(i,k) qmin(i,k,j-1) = Tmpv6015(i,k) a_Tmpv1 =a_qmin(i,k,j-1) a_qmin(i,k,j-1) =0.0 a_qmin(i,k,j-1) =a_qmin(i,k,j-1) +(1.0 -sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k,j-1) a_qmax(i,k,j-1) =0.0 a_qmax(i,k,j-1) =a_qmax(i,k,j-1) +(1.0 +sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j) a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 a_rv(i,k,j) =a_rv(i,k,j) +0.5*(field(i,k,j) +field(i,k,j-1))*a_Tmpv2 a_Tmpv1 =0.5*rv(i,k,j)*a_Tmpv2 a_field(i,k,j) =a_field(i,k,j) +a_Tmpv1 a_field(i,k,j-1) =a_field(i,k,j-1) +a_Tmpv1 a_Tmpv2 =a_fqyl(i,k,j) a_fqyl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_rv(i,k,j) =a_rv(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO ELSE IF( j == jde-2 ) THEN DO k =ktf, kts, -1 DO i =i_end, i_start, -1 vel =rv(i,k,j) cr =vel IF(cr.gt. 0) THEN qmax(i,k,j) = Tmpv6016(i,k) qmin(i,k,j) = Tmpv6017(i,k) a_Tmpv1 =a_qmax(i,k,j) a_qmax(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 -sign(1.0, qmax(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmin(i,k,j) a_qmin(i,k,j) =0.0 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) & ))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +(1.0 +sign(1.0, qmin(i,k,j) & -field_old(i,k,j-1)))*0.5*1.0*a_Tmpv1 else qmax(i,k,j-1) = Tmpv6018(i,k) qmin(i,k,j-1) = Tmpv6019(i,k) a_Tmpv1 =a_qmin(i,k,j-1) a_qmin(i,k,j-1) =0.0 a_qmin(i,k,j-1) =a_qmin(i,k,j-1) +(1.0 -sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 +sign(1.0, qmin(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_Tmpv1 =a_qmax(i,k,j-1) a_qmax(i,k,j-1) =0.0 a_qmax(i,k,j-1) =a_qmax(i,k,j-1) +(1.0 +sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +(1.0 -sign(1.0, qmax(i,k,j-1) & -field_old(i,k,j)))*0.5*1.0*a_Tmpv1 end IF a_fqyl(i,k,j) =a_fqyl(i,k,j) -a_fqy(i,k,j) a_Tmpv2 =a_fqy(i,k,j) a_fqy(i,k,j) =0.0 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 a_Tmpv1 =vel*a_Tmpv2 a_vel =a_vel +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1),0.0,field(i,k,j) & ,0.0,field(i,k,j+1),0.0,vel,1.0)*a_Tmpv1 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- & 1),0.0,field(i,k,j),0.0,field(i,k,j+1),1.0,vel,0.0)*a_Tmpv1 a_field(i,k,j) =a_field(i,k,j) +Diff_flux3(field(i,k,j-2),0.0,field(i,k,j-1) & ,0.0,field(i,k,j),1.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1 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- & 1),1.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1 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- & 1),0.0,field(i,k,j),0.0,field(i,k,j+1),0.0,vel,0.0)*a_Tmpv1 a_Tmpv2 =a_fqyl(i,k,j) a_fqyl(i,k,j) =0.0 a_vel =a_vel +flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)*a_Tmpv2 a_Tmpv1 =vel*a_Tmpv2 a_cr =a_cr +Diff_flux_upwind(field_old(i,k,j-1),0.0,field_old(i,k,j) & ,0.0,cr,1.0)*a_Tmpv1 a_field_old(i,k,j) =a_field_old(i,k,j) +Diff_flux_upwind(field_old(i,k,j-1) & ,0.0,field_old(i,k,j),1.0,cr,0.0)*a_Tmpv1 a_field_old(i,k,j-1) =a_field_old(i,k,j-1) +Diff_flux_upwind(field_old(i,k,j-1) & ,1.0,field_old(i,k,j),0.0,cr,0.0)*a_Tmpv1 a_vel =a_vel +a_cr a_cr =0.0 a_rv(i,k,j) =a_rv(i,k,j) +a_vel a_vel =0.0 ENDDO ENDDO ENDIF ENDDO ENDIF !LPB[1] DO j =jte+2, jts-2, -1 DO k =kte, kts, -1 DO i =ite+2, its-2, -1 a_field_old(i,k,j) =a_field_old(i,k,j) +a_qmax(i,k,j) a_field_old(i,k,j) =a_field_old(i,k,j) +a_qmin(i,k,j) ENDDO ENDDO ENDDO END SUBROUTINE a_advect_scalar_mono ! Generated by TAPENADE (INRIA, Ecuador team) ! Tapenade 3.12 (r6213) - 13 Oct 2016 10:54 ! ! Differentiation of advect_scalar_weno in reverse (adjoint) mode: ! gradient of useful results: rom field tendency ru rv field_old ! with respect to varying inputs: rom field tendency ru rv field_old ! RW status of diff variables: rom:incr field:incr tendency:in-out ! ru:incr rv:incr field_old:incr SUBROUTINE A_ADVECT_SCALAR_WENO(field, fieldb, field_old, field_oldb, & & tendency, tendencyb, ru, rub, rv, rvb, rom, romb, mut, time_step, & & config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx& & , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, & & kme, its, ite, jts, jte, kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, & & field_old, ru, rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: fieldb, field_oldb, rub& & , rvb, romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax INTEGER, PARAMETER :: is=0, js=0, ks=0 REAL :: mrdx, mrdy, ub, vb, vw REAL :: ubb, vbb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL, DIMENSION(its-is:ite+1, kts:kte) :: fqx REAL, DIMENSION(its-is:ite+1, kts:kte) :: fqxb ! REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb INTEGER :: horz_order, vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp REAL :: dir, vv REAL :: ue, uw, vs, vn, wb, wt REAL, PARAMETER :: f30=7./12., f31=1./12. REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60. INTEGER :: kt, kb REAL :: qim2, qim1, qi, qip1, qip2 REAL :: qim2b, qim1b, qib, qip1b, qip2b DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, & & sumwk DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b& & , wi2b, sumwkb DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=& & 3.d0/10.d0, eps=1.0d-28 INTEGER, PARAMETER :: pw=2 ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified DOUBLE PRECISION :: temp DOUBLE PRECISION :: temp0 DOUBLE PRECISION :: temp1 DOUBLE PRECISION :: tempb DOUBLE PRECISION :: tempb0 REAL :: tempb1 REAL :: tempb2 REAL :: tempb3 REAL :: tempb4 REAL :: tempb5 REAL :: tempb6 REAL :: tempb7 REAL :: temp2 REAL :: temp3 REAL :: temp4 REAL :: tempb8 REAL :: tempb9 REAL :: tempb10 REAL :: tempb11 REAL :: temp5 REAL :: temp6 REAL :: temp7 REAL :: tempb12 REAL :: tempb13 REAL :: tempb14 DOUBLE PRECISION :: temp8 DOUBLE PRECISION :: temp9 DOUBLE PRECISION :: temp10 DOUBLE PRECISION :: tempb15 DOUBLE PRECISION :: tempb16 REAL :: tempb17 REAL :: tempb18 REAL :: tempb19 REAL :: tempb20 REAL :: tempb21 REAL :: tempb22 REAL :: tempb23 REAL :: temp11 REAL :: temp12 REAL :: temp13 REAL :: tempb24 REAL :: tempb25 REAL :: tempb26 REAL :: tempb27 REAL :: temp14 REAL :: temp15 REAL :: temp16 REAL :: tempb28 REAL :: tempb29 REAL :: tempb30 REAL :: tempb31 REAL :: tempb32 REAL :: tempb33 REAL :: tempb34 REAL :: tempb35 REAL :: tempb36 REAL :: tempb37 REAL :: tempb38 DOUBLE PRECISION :: temp17 DOUBLE PRECISION :: temp18 DOUBLE PRECISION :: temp19 DOUBLE PRECISION :: tempb39 DOUBLE PRECISION :: tempb40 REAL :: tempb41 REAL :: tempb42 REAL :: tempb43 REAL :: tempb44 REAL :: tempb45 REAL :: tempb46 REAL :: temp20 REAL :: temp21 REAL :: temp22 REAL :: temp23 REAL :: temp24 REAL :: temp25 REAL :: tempb47 REAL :: tempb48 REAL :: tempb49 REAL :: tempb50 REAL :: tempb51 REAL :: tempb52 REAL :: tempb53 REAL :: tempb54 INTEGER :: branch INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF ! config_flags%h_sca_adv_order horz_order = 5 ! config_flags%v_sca_adv_order ! begin with horizontal flux divergence ! here is the choice of flux operators IF (horz_order .EQ. 5) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. & & its .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. & & ite .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. & & jts .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. & & jte .LT. jde - 4) degrade_ye = .false. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF ! check for U IF (is .EQ. 1) THEN i_start = its i_end = ite IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN CALL PUSHCONTROL1B(1) i_start = its ELSE CALL PUSHCONTROL1B(1) i_start = ids + 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 1 .GT. ite) THEN CALL PUSHCONTROL1B(1) i_end = ite ELSE CALL PUSHCONTROL1B(1) i_end = ide - 1 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) THEN CALL PUSHCONTROL1B(1) i_end = ite ELSE CALL PUSHCONTROL1B(1) END IF ELSE CALL PUSHCONTROL1B(0) END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN CALL PUSHCONTROL1B(0) j_start = jds + 1 ELSE CALL PUSHCONTROL1B(0) j_start = jts END IF j_start_f = jds + 3 ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN CALL PUSHCONTROL1B(0) j_end = jde - 2 ELSE CALL PUSHCONTROL1B(0) j_end = jte END IF j_end_f = jde - 3 ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN CALL PUSHCONTROL1B(1) j_end = jde - 1 ELSE CALL PUSHCONTROL1B(1) j_end = jte END IF ELSE CALL PUSHCONTROL1B(0) END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from10 = j_start j_loop_y_flux_5:DO j=ad_from10,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from = i_start DO i=ad_from,i_end ! vel = rv(i,k,j) vel = 0.5*(rv(i, k, j)+rv(i-is, k-ks, j-js)) IF (vel*SIGN(1, time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = field(i, k, j+1) CALL PUSHREAL8(qip1) qip1 = field(i, k, j) CALL PUSHREAL8(qi) qi = field(i, k, j-1) CALL PUSHREAL8(qim1) qim1 = field(i, k, j-2) CALL PUSHREAL8(qim2) qim2 = field(i, k, j-3) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = field(i, k, j-2) CALL PUSHREAL8(qip1) qip1 = field(i, k, j-1) CALL PUSHREAL8(qi) qi = field(i, k, j) CALL PUSHREAL8(qim1) qim1 = field(i, k, j+1) CALL PUSHREAL8(qim2) qim2 = field(i, k, j+2) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+& & 3.*qi)**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+& & 3.*qi)**2 END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! fqy( i, k, jp1 ) = vel*flux5( & ! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & ! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency IF (is .EQ. 0) THEN ! Comments on polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from4 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) END DO CALL PUSHCONTROL4B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN DO k=kts,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO CALL PUSHCONTROL4B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) END DO CALL PUSHCONTROL4B(2) ELSE CALL PUSHCONTROL4B(3) END IF ELSE IF (is .EQ. 1) THEN ! (j > j_start) will miss the u(,,jds) tendency IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from7 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from7) END DO CALL PUSHCONTROL4B(4) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN ! This would be seen by (j > j_start) but we need to zero out the NP tendency DO k=kts,ktf ad_from8 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from8) END DO CALL PUSHCONTROL4B(5) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from9 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO CALL PUSHCONTROL4B(6) ELSE CALL PUSHCONTROL4B(7) END IF ELSE CALL PUSHCONTROL4B(8) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from10) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN CALL PUSHCONTROL1B(1) i_start_f = ids + 3 ELSE CALL PUSHCONTROL1B(1) i_start_f = i_start + 2 END IF ELSE CALL PUSHCONTROL1B(0) END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN CALL PUSHCONTROL1B(1) i_end = ite ELSE CALL PUSHCONTROL1B(1) i_end = ide - 2 END IF i_end_f = ide - 3 ELSE CALL PUSHCONTROL1B(0) END IF ad_from14 = j_start ! compute fluxes DO j=ad_from14,j_end ! 5th or 6th order flux DO k=kts,ktf DO i=i_start_f,i_end_f ! vel = ru(i,k,j) vel = 0.5*(ru(i, k, j)+ru(i-is, k-ks, j-js)) IF (vel*SIGN(1, time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = field(i+1, k, j) CALL PUSHREAL8(qip1) qip1 = field(i, k, j) CALL PUSHREAL8(qi) qi = field(i-1, k, j) CALL PUSHREAL8(qim1) qim1 = field(i-2, k, j) CALL PUSHREAL8(qim2) qim2 = field(i-3, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = field(i-2, k, j) CALL PUSHREAL8(qip1) qip1 = field(i-1, k, j) CALL PUSHREAL8(qi) qi = field(i, k, j) CALL PUSHREAL8(qim1) qim1 = field(i+1, k, j) CALL PUSHREAL8(qim2) qim2 = field(i+2, k, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*& & qi)**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*& & qi)**2 END DO END DO ! fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & ! field(i-1,k,j), field(i ,k,j), & ! field(i+1,k,j), field(i+2,k,j), & ! vel ) ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from11 = i_start DO i=ad_from11,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from11) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF ! x flux-divergence into tendency IF (is .EQ. 0) THEN DO k=kts,ktf ad_from12 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) END DO CALL PUSHCONTROL2B(2) ELSE IF (is .EQ. 1) THEN DO k=kts,ktf ad_from13 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) END DO CALL PUSHCONTROL2B(1) ELSE CALL PUSHCONTROL2B(0) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from14) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! compute x (u) conditions for v, w, or scalar IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from15 = j_start DO j=ad_from15,j_end DO k=kts,ktf IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(its, k, j)+ru(its+1, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from15) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from16 = j_start DO j=ad_from16,j_end DO k=kts,ktf IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from16) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from17 = i_start DO i=ad_from17,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from17) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from18 = i_start DO i=ad_from18,i_end DO k=kts,ktf IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte)) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from18) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my) ! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my) ! So we don't need to make a correction for advect_scalar i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN CALL PUSHINTEGER4(j_end) j_end = jde - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(j_end) j_end = jte CALL PUSHCONTROL1B(1) END IF DO j=j_start,j_end DO k=kts+3,ktf-2 DO i=i_start,i_end ! vel = rom(i,k,j) vel = 0.5*(rom(i, k, j)+rom(i-is, k-ks, j-js)) IF (-(vel*SIGN(1, time_step)) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = field(i, k+1, j) CALL PUSHREAL8(qip1) qip1 = field(i, k, j) CALL PUSHREAL8(qi) qi = field(i, k-1, j) CALL PUSHREAL8(qim1) qim1 = field(i, k-2, j) CALL PUSHREAL8(qim2) qim2 = field(i, k-3, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = field(i, k-2, j) CALL PUSHREAL8(qip1) qip1 = field(i, k-1, j) CALL PUSHREAL8(qi) qi = field(i, k, j) CALL PUSHREAL8(qim1) qim1 = field(i, k+1, j) CALL PUSHREAL8(qim2) qim2 = field(i, k+2, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf tempb47 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb47 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb47 vfluxb(i, k) = 0.0 k = ktf - 1 vel = rom(i, k, j) temp23 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-& & field(i, k-1, j)) temp25 = SIGN(1., -vel) temp24 = temp25/12. tempb48 = vel*vfluxb(i, k) tempb49 = 7.*tempb48/12. tempb50 = temp24*tempb48 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, & & j)+field(i, k-2, j))/12.+temp24*temp23)*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + tempb49 - 3.*tempb50 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb50 + tempb49 fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb50 - tempb48/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb50 - tempb48/12. vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb k = kts + 2 vel = rom(i, k, j) temp20 = field(i, k+1, j) - field(i, k-2, j) - 3.*(field(i, k, j)-& & field(i, k-1, j)) temp22 = SIGN(1., -vel) temp21 = temp22/12. tempb51 = vel*vfluxb(i, k) tempb52 = 7.*tempb51/12. tempb53 = temp21*tempb51 velb = (7.*((field(i, k, j)+field(i, k-1, j))/12.)-(field(i, k+1, & & j)+field(i, k-2, j))/12.+temp21*temp20)*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + tempb52 - 3.*tempb53 fieldb(i, k-1, j) = fieldb(i, k-1, j) + 3.*tempb53 + tempb52 fieldb(i, k+1, j) = fieldb(i, k+1, j) + tempb53 - tempb51/12. fieldb(i, k-2, j) = fieldb(i, k-2, j) - tempb53 - tempb51/12. vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + velb k = kts + 1 tempb54 = rom(i, k, j)*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + (fzm(k)*field(i, k, j)+fzp(k)*& & field(i, k-1, j))*vfluxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + fzm(k)*tempb54 fieldb(i, k-1, j) = fieldb(i, k-1, j) + fzp(k)*tempb54 vfluxb(i, k) = 0.0 END DO DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rom(i, k, j)+rom(i-is, k-ks, j-js)) tempb39 = vel*vfluxb(i, k)/sumwk tempb40 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk f0b = wi0*tempb39 f1b = wi1*tempb39 f2b = wi2*tempb39 velb = tempb40 sumwkb = -(vel*tempb40/sumwk) wi0b = sumwkb + f0*tempb39 wi1b = sumwkb + f1*tempb39 wi2b = sumwkb + f2*tempb39 vfluxb(i, k) = 0.0 temp19 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp19**2) END IF temp18 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp18**2) END IF temp17 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp17**2) END IF CALL POPREAL8(beta2) tempb41 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb42 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb42 - f2b/6. + tempb41 CALL POPREAL8(beta1) tempb43 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb46 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb43 - tempb46 + f1b/3. + 5.*f2b/6. - 4.*tempb42 - 2.& & *tempb41 CALL POPREAL8(beta0) tempb45 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb44 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb43 + 11.*f0b/6. + 5.*f1b/6. + 3.*tempb44 & & + tempb45 + 3.*tempb42 + tempb41 qim1b = tempb46 - 4.*tempb44 - 7.*f0b/6. - f1b/6. - 2.*tempb45 +& & tempb43 qim2b = f0b/3. + tempb44 + tempb45 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) fieldb(i, k-3, j) = fieldb(i, k-3, j) + qim2b CALL POPREAL8(qim1) fieldb(i, k-2, j) = fieldb(i, k-2, j) + qim1b CALL POPREAL8(qi) fieldb(i, k-1, j) = fieldb(i, k-1, j) + qib CALL POPREAL8(qip1) fieldb(i, k, j) = fieldb(i, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i, k+1, j) = fieldb(i, k+1, j) + qip2b ELSE CALL POPREAL8(qim2) fieldb(i, k+2, j) = fieldb(i, k+2, j) + qim2b CALL POPREAL8(qim1) fieldb(i, k+1, j) = fieldb(i, k+1, j) + qim1b CALL POPREAL8(qi) fieldb(i, k, j) = fieldb(i, k, j) + qib CALL POPREAL8(qip1) fieldb(i, k-1, j) = fieldb(i, k-1, j) + qip1b CALL POPREAL8(qip2) fieldb(i, k-2, j) = fieldb(i, k-2, j) + qip2b END IF romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-is, k-ks, j-js) = romb(i-is, k-ks, j-js) + 0.5*velb END DO END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(j_end) ELSE CALL POPINTEGER4(j_end) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO i=ad_to18,ad_from18,-1 DO k=ktf,kts,-1 tempb37 = -(rdy*tendencyb(i, k, j_end)) tempb38 = field(i, k, j_end)*tempb37 vbb = (field_old(i, k, j_end)-field_old(i, k, j_end-1))*tempb37 field_oldb(i, k, j_end) = field_oldb(i, k, j_end) + vb*tempb37 field_oldb(i, k, j_end-1) = field_oldb(i, k, j_end-1) - vb*& & tempb37 fieldb(i, k, j_end) = fieldb(i, k, j_end) + (rv(i, k, jte)-rv(i& & , k, jte-1))*tempb37 rvb(i, k, jte) = rvb(i, k, jte) + tempb38 rvb(i, k, jte-1) = rvb(i, k, jte-1) - tempb38 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte-1) = rvb(i, k, jte-1) + 0.5*vbb rvb(i, k, jte) = rvb(i, k, jte) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO i=ad_to17,ad_from17,-1 DO k=ktf,kts,-1 tempb35 = -(rdy*tendencyb(i, k, jts)) tempb36 = field(i, k, jts)*tempb35 vbb = (field_old(i, k, jts+1)-field_old(i, k, jts))*tempb35 field_oldb(i, k, jts+1) = field_oldb(i, k, jts+1) + vb*tempb35 field_oldb(i, k, jts) = field_oldb(i, k, jts) - vb*tempb35 fieldb(i, k, jts) = fieldb(i, k, jts) + (rv(i, k, jts+1)-rv(i, k& & , jts))*tempb35 rvb(i, k, jts+1) = rvb(i, k, jts+1) + tempb36 rvb(i, k, jts) = rvb(i, k, jts) - tempb36 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts) = rvb(i, k, jts) + 0.5*vbb rvb(i, k, jts+1) = rvb(i, k, jts+1) + 0.5*vbb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO j=ad_to16,ad_from16,-1 DO k=ktf,kts,-1 tempb33 = -(rdx*tendencyb(i_end, k, j)) tempb34 = field(i_end, k, j)*tempb33 ubb = (field_old(i_end, k, j)-field_old(i_end-1, k, j))*tempb33 field_oldb(i_end, k, j) = field_oldb(i_end, k, j) + ub*tempb33 field_oldb(i_end-1, k, j) = field_oldb(i_end-1, k, j) - ub*& & tempb33 fieldb(i_end, k, j) = fieldb(i_end, k, j) + (ru(ite, k, j)-ru(& & ite-1, k, j))*tempb33 rub(ite, k, j) = rub(ite, k, j) + tempb34 rub(ite-1, k, j) = rub(ite-1, k, j) - tempb34 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(ite-1, k, j) = rub(ite-1, k, j) + 0.5*ubb rub(ite, k, j) = rub(ite, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO j=ad_to15,ad_from15,-1 DO k=ktf,kts,-1 tempb31 = -(rdx*tendencyb(its, k, j)) tempb32 = field(its, k, j)*tempb31 ubb = (field_old(its+1, k, j)-field_old(its, k, j))*tempb31 field_oldb(its+1, k, j) = field_oldb(its+1, k, j) + ub*tempb31 field_oldb(its, k, j) = field_oldb(its, k, j) - ub*tempb31 fieldb(its, k, j) = fieldb(its, k, j) + (ru(its+1, k, j)-ru(its& & , k, j))*tempb31 rub(its+1, k, j) = rub(its+1, k, j) + tempb32 rub(its, k, j) = rub(its, k, j) - tempb32 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(its, k, j) = rub(its, k, j) + 0.5*ubb rub(its+1, k, j) = rub(its+1, k, j) + 0.5*ubb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN fqxb = 0.0 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO j=ad_to14,ad_from14,-1 CALL POPCONTROL2B(branch) IF (branch .NE. 0) THEN IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 mrdx = msfux(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_to11) DO i=ad_to11,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = ru(i, k, j) temp14 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp16 = SIGN(1., vel) temp15 = temp16/12. tempb28 = vel*fqxb(i, k) tempb29 = 7.*tempb28/12. tempb30 = temp15*tempb28 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.+temp15*temp14)*fqxb(i, & & k) fieldb(i, k, j) = fieldb(i, k, j) + tempb29 - 3.*tempb30 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb30 + & & tempb29 fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb30 - tempb28/& & 12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb30 - tempb28/& & 12. fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 tempb27 = 0.5*ru(i, k, j)*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + tempb27 fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb27 fqxb(i, k) = 0.0 END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from11) DO i=i_start_f-1,ad_from11,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = ru(i, k, j) temp11 = field(i+1, k, j) - field(i-2, k, j) - 3.*(field(i& & , k, j)-field(i-1, k, j)) temp13 = SIGN(1., vel) temp12 = temp13/12. tempb24 = vel*fqxb(i, k) tempb25 = 7.*tempb24/12. tempb26 = temp12*tempb24 velb = (7.*((field(i, k, j)+field(i-1, k, j))/12.)-(field(& & i+1, k, j)+field(i-2, k, j))/12.+temp12*temp11)*fqxb(i, & & k) fieldb(i, k, j) = fieldb(i, k, j) + tempb25 - 3.*tempb26 fieldb(i-1, k, j) = fieldb(i-1, k, j) + 3.*tempb26 + & & tempb25 fieldb(i+1, k, j) = fieldb(i+1, k, j) + tempb26 - tempb24/& & 12. fieldb(i-2, k, j) = fieldb(i-2, k, j) - tempb26 - tempb24/& & 12. fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 tempb23 = 0.5*ru(i, k, j)*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + 0.5*(field(i, k, j)+field(i-& & 1, k, j))*fqxb(i, k) fieldb(i, k, j) = fieldb(i, k, j) + tempb23 fieldb(i-1, k, j) = fieldb(i-1, k, j) + tempb23 fqxb(i, k) = 0.0 END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(ru(i, k, j)+ru(i-is, k-ks, j-js)) tempb15 = vel*fqxb(i, k)/sumwk tempb16 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk f0b = wi0*tempb15 f1b = wi1*tempb15 f2b = wi2*tempb15 velb = tempb16 sumwkb = -(vel*tempb16/sumwk) wi0b = sumwkb + f0*tempb15 wi1b = sumwkb + f1*tempb15 wi2b = sumwkb + f2*tempb15 fqxb(i, k) = 0.0 temp10 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp10**2) END IF temp9 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp9**2) END IF temp8 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp8**2) END IF CALL POPREAL8(beta2) tempb17 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb18 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb18 - f2b/6. + tempb17 CALL POPREAL8(beta1) tempb19 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb22 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb19 - tempb22 + f1b/3. + 5.*f2b/6. - 4.*tempb18 - & & 2.*tempb17 CALL POPREAL8(beta0) tempb21 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb20 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb19 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & tempb20 + tempb21 + 3.*tempb18 + tempb17 qim1b = tempb22 - 4.*tempb20 - 7.*f0b/6. - f1b/6. - 2.*tempb21& & + tempb19 qim2b = f0b/3. + tempb20 + tempb21 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) fieldb(i-3, k, j) = fieldb(i-3, k, j) + qim2b CALL POPREAL8(qim1) fieldb(i-2, k, j) = fieldb(i-2, k, j) + qim1b CALL POPREAL8(qi) fieldb(i-1, k, j) = fieldb(i-1, k, j) + qib CALL POPREAL8(qip1) fieldb(i, k, j) = fieldb(i, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i+1, k, j) = fieldb(i+1, k, j) + qip2b ELSE CALL POPREAL8(qim2) fieldb(i+2, k, j) = fieldb(i+2, k, j) + qim2b CALL POPREAL8(qim1) fieldb(i+1, k, j) = fieldb(i+1, k, j) + qim1b CALL POPREAL8(qi) fieldb(i, k, j) = fieldb(i, k, j) + qib CALL POPREAL8(qip1) fieldb(i-1, k, j) = fieldb(i-1, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i-2, k, j) = fieldb(i-2, k, j) + qip2b END IF rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-is, k-ks, j-js) = rub(i-is, k-ks, j-js) + 0.5*velb END DO END DO END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) fqyb = 0.0 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO j=ad_to10,ad_from10,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL4B(branch) IF (branch .LT. 4) THEN IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k& & , j-1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k& & , j-1) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF ELSE IF (branch .LT. 6) THEN IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO i=ad_to7,ad_from7,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j& & -1) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO i=ad_to8,ad_from8,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j& & -1) END DO END DO END IF ELSE IF (branch .EQ. 6) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rv(i, k, j)+rv(i-is, k-ks, j-js)) tempb = vel*fqyb(i, k, jp1)/sumwk tempb0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk f0b = wi0*tempb f1b = wi1*tempb f2b = wi2*tempb velb = tempb0 sumwkb = -(vel*tempb0/sumwk) wi0b = sumwkb + f0*tempb wi1b = sumwkb + f1*tempb wi2b = sumwkb + f2*tempb fqyb(i, k, jp1) = 0.0 temp1 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. & & INT(pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2) END IF temp0 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. & & INT(pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2) END IF temp = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. & & INT(pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2) END IF CALL POPREAL8(beta2) tempb1 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb2 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb2 - f2b/6. + tempb1 CALL POPREAL8(beta1) tempb3 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb6 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb3 - tempb6 + f1b/3. + 5.*f2b/6. - 4.*tempb2 -& & 2.*tempb1 CALL POPREAL8(beta0) tempb5 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb4 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb3 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & tempb4 + tempb5 + 3.*tempb2 + tempb1 qim1b = tempb6 - 4.*tempb4 - 7.*f0b/6. - f1b/6. - 2.*& & tempb5 + tempb3 qim2b = f0b/3. + tempb4 + tempb5 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) fieldb(i, k, j-3) = fieldb(i, k, j-3) + qim2b CALL POPREAL8(qim1) fieldb(i, k, j-2) = fieldb(i, k, j-2) + qim1b CALL POPREAL8(qi) fieldb(i, k, j-1) = fieldb(i, k, j-1) + qib CALL POPREAL8(qip1) fieldb(i, k, j) = fieldb(i, k, j) + qip1b CALL POPREAL8(qip2) fieldb(i, k, j+1) = fieldb(i, k, j+1) + qip2b ELSE CALL POPREAL8(qim2) fieldb(i, k, j+2) = fieldb(i, k, j+2) + qim2b CALL POPREAL8(qim1) fieldb(i, k, j+1) = fieldb(i, k, j+1) + qim1b CALL POPREAL8(qi) fieldb(i, k, j) = fieldb(i, k, j) + qib CALL POPREAL8(qip1) fieldb(i, k, j-1) = fieldb(i, k, j-1) + qip1b CALL POPREAL8(qip2) fieldb(i, k, j-2) = fieldb(i, k, j-2) + qip2b END IF rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-is, k-ks, j-js) = rvb(i-is, k-ks, j-js) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 tempb7 = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i& & , k, j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + tempb7 fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb7 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 vel = rv(i, k, j) temp2 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i& & , k, j)-field(i, k, j-1)) temp4 = SIGN(1., vel) temp3 = temp4/12. tempb8 = vel*fqyb(i, k, jp1) tempb9 = 7.*tempb8/12. tempb10 = temp3*tempb8 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(& & i, k, j+1)+field(i, k, j-2))/12.+temp3*temp2)*fqyb(i, k& & , jp1) fieldb(i, k, j) = fieldb(i, k, j) + tempb9 - 3.*tempb10 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb10 + & & tempb9 fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb10 - tempb8/& & 12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb10 - tempb8/& & 12. fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 tempb11 = 0.5*rv(i, k, j)*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + 0.5*(field(i, k, j)+field(i, k& & , j-1))*fqyb(i, k, jp1) fieldb(i, k, j) = fieldb(i, k, j) + tempb11 fieldb(i, k, j-1) = fieldb(i, k, j-1) + tempb11 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = rv(i, k, j) temp5 = field(i, k, j+1) - field(i, k, j-2) - 3.*(field(i, k& & , j)-field(i, k, j-1)) temp7 = SIGN(1., vel) temp6 = temp7/12. tempb12 = vel*fqyb(i, k, jp1) tempb13 = 7.*tempb12/12. tempb14 = temp6*tempb12 velb = (7.*((field(i, k, j)+field(i, k, j-1))/12.)-(field(i& & , k, j+1)+field(i, k, j-2))/12.+temp6*temp5)*fqyb(i, k, & & jp1) fieldb(i, k, j) = fieldb(i, k, j) + tempb13 - 3.*tempb14 fieldb(i, k, j-1) = fieldb(i, k, j-1) + 3.*tempb14 + tempb13 fieldb(i, k, j+1) = fieldb(i, k, j+1) + tempb14 - tempb12/& & 12. fieldb(i, k, j-2) = fieldb(i, k, j-2) - tempb14 - tempb12/& & 12. fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + velb END DO END DO END IF END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) END IF END IF END SUBROUTINE A_ADVECT_SCALAR_WENO ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.6 (r4165) - 21 sep 2011 20:54 ! ! Differentiation of advect_weno_u in reverse (adjoint) mode: ! gradient of useful results: rom u tendency u_old ru rv ! mut ! with respect to varying inputs: rom u tendency u_old ru rv ! mut ! RW status of diff variables: rom:incr u:incr tendency:in-out ! u_old:incr ru:incr rv:incr mut:incr SUBROUTINE A_ADVECT_WENO_U(u, ub0, u_old, u_oldb, tendency, tendencyb, & & ru, rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux& & , msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, & & ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, & & jte, kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru& & , rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ub0, u_oldb, rub, rvb, & & romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, jms:jme) :: mutb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip INTEGER :: jp1, jp0, jtmp REAL :: dir, vv REAL :: ue, vs, vn, wb, wt REAL, PARAMETER :: f30=7./12., f31=1./12. REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60. INTEGER :: kt, kb REAL :: qim2, qim1, qi, qip1, qip2 REAL :: qim2b, qim1b, qib, qip1b, qip2b DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, & & sumwk DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b& & , wi2b, sumwkb DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=& & 3.d0/10.d0, eps=1.0d-18 INTEGER, PARAMETER :: pw=2 INTEGER :: horz_order, vert_order REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp REAL :: ubb, vbb, vwb, dvmb, dvpb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified INTEGER :: branch INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: temp3 INTEGER :: temp29 REAL :: temp2 REAL :: temp28 DOUBLE PRECISION :: temp1 REAL :: temp27 DOUBLE PRECISION :: temp0 DOUBLE PRECISION :: temp13b REAL :: temp26 REAL :: temp21b INTEGER :: temp25 REAL :: temp24 DOUBLE PRECISION :: temp23 DOUBLE PRECISION :: temp22 DOUBLE PRECISION :: temp21 REAL :: temp20 REAL :: temp13b5 REAL :: temp13b4 DOUBLE PRECISION :: temp24b REAL :: temp13b3 REAL :: temp32b REAL :: temp13b2 REAL :: temp13b1 DOUBLE PRECISION :: temp13b0 REAL :: tempb4 REAL :: temp21b10 REAL :: tempb3 REAL :: temp28b1 REAL :: tempb2 REAL :: temp28b0 REAL :: tempb1 REAL :: tempb0 INTRINSIC MAX INTRINSIC SIGN REAL :: temp2b5 REAL :: temp2b4 REAL :: temp19 REAL :: temp2b3 INTEGER :: temp18 REAL :: temp2b2 REAL :: temp17 REAL :: temp2b1 REAL :: temp16 DOUBLE PRECISION :: temp2b0 REAL :: temp6b REAL :: temp15 INTEGER :: temp14 REAL :: temp13 REAL :: temp21b9 DOUBLE PRECISION :: temp12 REAL :: temp21b8 DOUBLE PRECISION :: temp11 REAL :: temp21b7 DOUBLE PRECISION :: temp10 REAL :: temp21b6 REAL :: temp21b5 REAL :: temp21b4 REAL :: temp21b3 REAL :: temp21b2 REAL :: temp21b1 REAL :: temp21b0 REAL :: tempb REAL :: temp24b5 DOUBLE PRECISION :: temp2b REAL :: temp24b4 REAL :: temp24b3 REAL :: temp24b2 REAL :: temp24b1 DOUBLE PRECISION :: temp24b0 REAL :: temp17b3 REAL :: temp17b2 REAL :: temp17b1 REAL :: temp17b0 REAL :: temp31 REAL :: temp30 REAL :: temp17b INTRINSIC MIN REAL :: temp28b REAL :: temp6b3 REAL :: temp6b2 REAL :: temp6b1 DOUBLE PRECISION :: temp REAL :: temp6b0 REAL :: temp9 REAL :: temp10b4 REAL :: temp32b0 REAL :: temp8 REAL :: temp10b3 INTEGER :: temp7 REAL :: temp10b REAL :: temp10b2 REAL :: temp6 REAL :: temp10b1 REAL :: temp5 REAL :: temp10b0 REAL :: temp4 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. ! set order for vertical and horzontal flux operators IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF ! begin with horizontal flux divergence ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF( horz_order == 5 ) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its & & .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite & & .LT. ide - 2) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts & & .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte & & .LT. jde - 4) degrade_ye = .false. !--------------- y - advection first i_start = its i_end = ite IF (config_flags%open_xs .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_xe .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from7 = j_start j_loop_y_flux_5:DO j=ad_from7,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN ! use full stencil DO k=kts,ktf ad_from = i_start DO i=ad_from,i_end vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = u(i, k, j+1) CALL PUSHREAL8(qip1) qip1 = u(i, k, j) CALL PUSHREAL8(qi) qi = u(i, k, j-1) CALL PUSHREAL8(qim1) qim1 = u(i, k, j-2) CALL PUSHREAL8(qim2) qim2 = u(i, k, j-3) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = u(i, k, j-2) CALL PUSHREAL8(qip1) qip1 = u(i, k, j-1) CALL PUSHREAL8(qi) qi = u(i, k, j) CALL PUSHREAL8(qim1) qim1 = u(i, k, j+1) CALL PUSHREAL8(qim2) qim2 = u(i, k, j+2) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*& & qi)**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*& & qi)**2 END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! fqy( i, k, jp1 ) = vel*flux5( & ! u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), & ! u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel ) ! we must be close to some boundary where we need to reduce the order of the stencil ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN ! 3rd order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! (j > j_start) will miss the u(,,jds) tendency IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from4 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN ! This would be seen by (j > j_start) but we need to zero out the NP tendency DO k=kts,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code DO k=kts,ktf ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from7) ! next, x - flux divergence i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF i_start_f = ids + 3 END IF IF (degrade_xe) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF i_end_f = ide - 2 END IF ad_from9 = j_start ! compute fluxes DO j=ad_from9,j_end ! 5th or 6th order flux DO k=kts,ktf CALL PUSHINTEGER4(i) DO i=i_start_f,i_end_f vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = u(i+1, k, j) CALL PUSHREAL8(qip1) qip1 = u(i, k, j) CALL PUSHREAL8(qi) qi = u(i-1, k, j) CALL PUSHREAL8(qim1) qim1 = u(i-2, k, j) CALL PUSHREAL8(qim2) qim2 = u(i-3, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = u(i-2, k, j) CALL PUSHREAL8(qip1) qip1 = u(i-1, k, j) CALL PUSHREAL8(qi) qi = u(i, k, j) CALL PUSHREAL8(qim1) qim1 = u(i+1, k, j) CALL PUSHREAL8(qim2) qim2 = u(i+2, k, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO ! fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j), & ! u(i-1,k,j), u(i ,k,j), & ! u(i+1,k,j), u(i+2,k,j), & ! vel ) ! lower order fluxes close to boundaries (if not periodic or symmetric) ! specified uses upstream normal wind at boundaries IF (degrade_xs) THEN IF (i_start .EQ. ids + 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ids + 1 DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i-1, k, j) IF (specified .AND. u(i, k, j) .LT. 0.) THEN ub = u(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF CALL PUSHINTEGER4(i) i = ids + 2 CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN IF (i_end .EQ. ide - 1) THEN CALL PUSHINTEGER4(i) ! second order flux next to the boundary i = ide DO k=kts,ktf CALL PUSHREAL8(ub) ub = u(i, k, j) IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN ub = u(i-1, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF DO k=kts,ktf CALL PUSHINTEGER4(i) END DO CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from8 = i_start CALL PUSHINTEGER4(i) i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from8) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from9) ! radiative lateral boundary condition in x for normal velocity (u) IF (config_flags%open_xs .AND. its .EQ. ids) THEN j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ad_from10 = j_start DO j=ad_from10,j_end DO k=kts,ktf IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = ru(its, k, j) - cb*mut(its, j) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from10) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ad_from11 = j_start DO j=ad_from11,j_end DO k=kts,ktf IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = ru(ite, k, j) + cb*mut(ite-1, j) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from11) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb') ! first, set to index ranges i_start = its IF (ite .GT. ide) THEN i_end = ide ELSE i_end = ite END IF imin = ids imax = ide - 1 IF (config_flags%open_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF imin = ids END IF IF (config_flags%open_xe) THEN IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF imax = ide - 1 END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from12 = i_start CALL PUSHINTEGER4(i) DO i=ad_from12,i_end CALL PUSHREAL8(mrdy) ! ADT eqn 44, 2nd term on RHS mrdy = msfux(i, jts)*rdy IF (imax .GT. i) THEN CALL PUSHINTEGER4(ip) ip = i CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(ip) ip = imax CALL PUSHCONTROL1B(1) END IF IF (imin .LT. i - 1) THEN CALL PUSHINTEGER4(im) im = i - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(im) im = imin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts)) IF (vw .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from13 = i_start CALL PUSHINTEGER4(i) DO i=ad_from13,i_end CALL PUSHREAL8(mrdy) ! ADT eqn 44, 2nd term on RHS mrdy = msfux(i, jte-1)*rdy IF (imax .GT. i) THEN CALL PUSHINTEGER4(ip) ip = i CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(ip) ip = imax CALL PUSHCONTROL1B(1) END IF IF (imin .LT. i - 1) THEN CALL PUSHINTEGER4(im) im = i - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(im) im = imin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte)) IF (vw .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from13) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w) ! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my) ! Since 'my' (map scale factor in y-direction) isn't a function of z, ! this is what we need, so leave unchanged in advect_u i_start = its i_end = ite j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its) ! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite) IF (config_flags%open_ys .OR. specified) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF END IF IF (config_flags%open_ye .OR. specified) THEN IF (ide - 1 .GT. ite) THEN i_end = ite ELSE i_end = ide - 1 END IF END IF IF (config_flags%periodic_x) i_start = its IF (config_flags%periodic_x) i_end = ite ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j=j_start,j_end DO k=kts+3,ktf-2 CALL PUSHINTEGER4(i) DO i=i_start,i_end vel = 0.5*(rom(i-1, k, j)+rom(i, k, j)) IF (-vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = u(i, k+1, j) CALL PUSHREAL8(qip1) qip1 = u(i, k, j) CALL PUSHREAL8(qi) qi = u(i, k-1, j) CALL PUSHREAL8(qim1) qim1 = u(i, k-2, j) CALL PUSHREAL8(qim2) qim2 = u(i, k-3, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = u(i, k-2, j) CALL PUSHREAL8(qip1) qip1 = u(i, k-1, j) CALL PUSHREAL8(qi) qi = u(i, k, j) CALL PUSHREAL8(qim1) qim1 = u(i, k+1, j) CALL PUSHREAL8(qim2) qim2 = u(i, k+2, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO CALL PUSHINTEGER4(i) CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzw(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzw(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp32b = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, k) temp32b0 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp32b romb(i-1, k, j) = romb(i-1, k, j) + temp32b ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp32b0 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp32b0 vfluxb(i, k) = 0.0 k = ktf - 1 vel = 0.5*(rom(i, k, j)+rom(i-1, k, j)) temp28 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, j)& & ) temp31 = SIGN(1., -vel) temp30 = temp31/12.0 temp29 = SIGN(1, time_step) temp28b = vel*vfluxb(i, k) temp28b0 = temp28b/12.0 temp28b1 = temp29*temp30*temp28b velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))/& & 12.0+temp29*(temp30*temp28))*vfluxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp28b0 - 3.*temp28b1 ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp28b1 + 7.*temp28b0 ub0(i, k+1, j) = ub0(i, k+1, j) + temp28b1 - temp28b0 ub0(i, k-2, j) = ub0(i, k-2, j) - temp28b1 - temp28b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i-1, k, j)) temp24 = u(i, k+1, j) - u(i, k-2, j) - 3.*(u(i, k, j)-u(i, k-1, j)& & ) temp27 = SIGN(1., -vel) temp26 = temp27/12.0 temp25 = SIGN(1, time_step) temp24b1 = vel*vfluxb(i, k) temp24b2 = temp24b1/12.0 temp24b3 = temp25*temp26*temp24b1 velb = ((7.*(u(i, k, j)+u(i, k-1, j))-u(i, k+1, j)-u(i, k-2, j))/& & 12.0+temp25*(temp26*temp24))*vfluxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp24b2 - 3.*temp24b3 ub0(i, k-1, j) = ub0(i, k-1, j) + 3.*temp24b3 + 7.*temp24b2 ub0(i, k+1, j) = ub0(i, k+1, j) + temp24b3 - temp24b2 ub0(i, k-2, j) = ub0(i, k-2, j) - temp24b3 - temp24b2 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb k = kts + 1 temp24b4 = 0.5*(fzm(k)*u(i, k, j)+fzp(k)*u(i, k-1, j))*vfluxb(i, k& & ) temp24b5 = 0.5*(rom(i, k, j)+rom(i-1, k, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp24b4 romb(i-1, k, j) = romb(i-1, k, j) + temp24b4 ub0(i, k, j) = ub0(i, k, j) + fzm(k)*temp24b5 ub0(i, k-1, j) = ub0(i, k-1, j) + fzp(k)*temp24b5 vfluxb(i, k) = 0.0 END DO CALL POPINTEGER4(i) DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rom(i-1, k, j)+rom(i, k, j)) temp24b = vel*vfluxb(i, k)/sumwk temp24b0 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk f0b = wi0*temp24b f1b = wi1*temp24b f2b = wi2*temp24b velb = temp24b0 sumwkb = -(vel*temp24b0/sumwk) wi0b = sumwkb + f0*temp24b wi1b = sumwkb + f1*temp24b wi2b = sumwkb + f2*temp24b vfluxb(i, k) = 0.0 temp23 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp23**2) END IF temp22 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp22**2) END IF temp21 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp21**2) END IF CALL POPREAL8(beta2) temp21b5 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp21b6 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp21b6 - f2b/6. + temp21b5 CALL POPREAL8(beta1) temp21b7 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp21b10 = 2*(qim1-qip1)*beta1b/4. qip1b = temp21b7 - temp21b10 + f1b/3. + 5.*f2b/6. - 4.*temp21b6 & & - 2.*temp21b5 CALL POPREAL8(beta0) temp21b9 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp21b8 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp21b7 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp21b8 + temp21b9 + 3.*temp21b6 + temp21b5 qim1b = temp21b10 - 4.*temp21b8 - 7.*f0b/6. - f1b/6. - 2.*& & temp21b9 + temp21b7 qim2b = f0b/3. + temp21b8 + temp21b9 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) ub0(i, k-3, j) = ub0(i, k-3, j) + qim2b CALL POPREAL8(qim1) ub0(i, k-2, j) = ub0(i, k-2, j) + qim1b CALL POPREAL8(qi) ub0(i, k-1, j) = ub0(i, k-1, j) + qib CALL POPREAL8(qip1) ub0(i, k, j) = ub0(i, k, j) + qip1b CALL POPREAL8(qip2) ub0(i, k+1, j) = ub0(i, k+1, j) + qip2b ELSE CALL POPREAL8(qim2) ub0(i, k+2, j) = ub0(i, k+2, j) + qim2b CALL POPREAL8(qim1) ub0(i, k+1, j) = ub0(i, k+1, j) + qim1b CALL POPREAL8(qi) ub0(i, k, j) = ub0(i, k, j) + qib CALL POPREAL8(qip1) ub0(i, k-1, j) = ub0(i, k-1, j) + qip1b CALL POPREAL8(qip2) ub0(i, k-2, j) = ub0(i, k-2, j) + qip2b END IF romb(i-1, k, j) = romb(i-1, k, j) + 0.5*velb romb(i, k, j) = romb(i, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO i=ad_to13,ad_from13,-1 DO k=ktf,kts,-1 dvm = rv(ip, k, jte) - rv(ip, k, jte-1) dvp = rv(im, k, jte) - rv(im, k, jte-1) temp21b3 = -(mrdy*tendencyb(i, k, jte-1)) temp21b4 = 0.5*u(i, k, jte-1)*temp21b3 vbb = (u_old(i, k, jte-1)-u_old(i, k, jte-2))*temp21b3 u_oldb(i, k, jte-1) = u_oldb(i, k, jte-1) + vb*temp21b3 u_oldb(i, k, jte-2) = u_oldb(i, k, jte-2) - vb*temp21b3 ub0(i, k, jte-1) = ub0(i, k, jte-1) + 0.5*(dvm+dvp)*temp21b3 dvmb = temp21b4 dvpb = temp21b4 rvb(im, k, jte) = rvb(im, k, jte) + dvpb rvb(im, k, jte-1) = rvb(im, k, jte-1) - dvpb rvb(ip, k, jte) = rvb(ip, k, jte) + dvmb rvb(ip, k, jte-1) = rvb(ip, k, jte-1) - dvmb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF rvb(ip, k, jte) = rvb(ip, k, jte) + 0.5*vwb rvb(im, k, jte) = rvb(im, k, jte) + 0.5*vwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(im) ELSE CALL POPINTEGER4(im) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ip) ELSE CALL POPINTEGER4(ip) END IF CALL POPREAL8(mrdy) END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 DO k=ktf,kts,-1 dvm = rv(ip, k, jts+1) - rv(ip, k, jts) dvp = rv(im, k, jts+1) - rv(im, k, jts) temp21b1 = -(mrdy*tendencyb(i, k, jts)) temp21b2 = 0.5*u(i, k, jts)*temp21b1 vbb = (u_old(i, k, jts+1)-u_old(i, k, jts))*temp21b1 u_oldb(i, k, jts+1) = u_oldb(i, k, jts+1) + vb*temp21b1 u_oldb(i, k, jts) = u_oldb(i, k, jts) - vb*temp21b1 ub0(i, k, jts) = ub0(i, k, jts) + 0.5*(dvm+dvp)*temp21b1 dvmb = temp21b2 dvpb = temp21b2 rvb(im, k, jts+1) = rvb(im, k, jts+1) + dvpb rvb(im, k, jts) = rvb(im, k, jts) - dvpb rvb(ip, k, jts+1) = rvb(ip, k, jts+1) + dvmb rvb(ip, k, jts) = rvb(ip, k, jts) - dvmb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF rvb(ip, k, jts) = rvb(ip, k, jts) + 0.5*vwb rvb(im, k, jts) = rvb(im, k, jts) + 0.5*vwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(im) ELSE CALL POPINTEGER4(im) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ip) ELSE CALL POPINTEGER4(ip) END IF CALL POPREAL8(mrdy) END DO CALL POPINTEGER4(i) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO j=ad_to11,ad_from11,-1 DO k=ktf,kts,-1 temp21b0 = -(rdx*tendencyb(ite, k, j)) ubb = (u_old(ite, k, j)-u_old(ite-1, k, j))*temp21b0 u_oldb(ite, k, j) = u_oldb(ite, k, j) + ub*temp21b0 u_oldb(ite-1, k, j) = u_oldb(ite-1, k, j) - ub*temp21b0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(ite, k, j) = rub(ite, k, j) + ubb mutb(ite-1, j) = mutb(ite-1, j) + cb*ubb END IF END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO j=ad_to10,ad_from10,-1 DO k=ktf,kts,-1 temp21b = -(rdx*tendencyb(its, k, j)) ubb = (u_old(its+1, k, j)-u_old(its, k, j))*temp21b u_oldb(its+1, k, j) = u_oldb(its+1, k, j) + ub*temp21b u_oldb(its, k, j) = u_oldb(its, k, j) - ub*temp21b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) ELSE CALL POPREAL8(ub) rub(its, k, j) = rub(its, k, j) + ubb mutb(its, j) = mutb(its, j) - cb*ubb END IF END DO END DO END IF fqxb = 0.0 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO j=ad_to9,ad_from9,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO i=ad_to8,ad_from8,-1 mrdx = msfux(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 i = ide - 1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp17 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1, k, & & j)) temp20 = SIGN(1., vel) temp19 = temp20/12.0 temp18 = SIGN(1, time_step) temp17b1 = vel*fqxb(i, k) temp17b2 = temp17b1/12.0 temp17b3 = temp18*temp19*temp17b1 velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, j))& & /12.0+temp18*(temp19*temp17))*fqxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp17b2 - 3.*temp17b3 ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp17b3 + 7.*temp17b2 ub0(i+1, k, j) = ub0(i+1, k, j) + temp17b3 - temp17b2 ub0(i-2, k, j) = ub0(i-2, k, j) - temp17b3 - temp17b2 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb CALL POPINTEGER4(i) END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 temp17b = 0.25*(u(i-1, k, j)+ub)*fqxb(i, k) temp17b0 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp17b rub(i-1, k, j) = rub(i-1, k, j) + temp17b ub0(i-1, k, j) = ub0(i-1, k, j) + temp17b0 ubb = temp17b0 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i-1, k, j) = ub0(i-1, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i, k, j) = ub0(i, k, j) + ubb END DO CALL POPINTEGER4(i) END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp13 = u(i+1, k, j) - u(i-2, k, j) - 3.*(u(i, k, j)-u(i-1, k, & & j)) temp16 = SIGN(1., vel) temp15 = temp16/12.0 temp14 = SIGN(1, time_step) temp13b3 = vel*fqxb(i, k) temp13b4 = temp13b3/12.0 temp13b5 = temp14*temp15*temp13b3 velb = ((7.*(u(i, k, j)+u(i-1, k, j))-u(i+1, k, j)-u(i-2, k, j))& & /12.0+temp14*(temp15*temp13))*fqxb(i, k) ub0(i, k, j) = ub0(i, k, j) + 7.*temp13b4 - 3.*temp13b5 ub0(i-1, k, j) = ub0(i-1, k, j) + 3.*temp13b5 + 7.*temp13b4 ub0(i+1, k, j) = ub0(i+1, k, j) + temp13b5 - temp13b4 ub0(i-2, k, j) = ub0(i-2, k, j) - temp13b5 - temp13b4 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp13b1 = 0.25*(u(i, k, j)+ub)*fqxb(i, k) temp13b2 = 0.25*(ru(i, k, j)+ru(i-1, k, j))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp13b1 rub(i-1, k, j) = rub(i-1, k, j) + temp13b1 ub0(i, k, j) = ub0(i, k, j) + temp13b2 ubb = temp13b2 fqxb(i, k) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN ub0(i, k, j) = ub0(i, k, j) + ubb ubb = 0.0 END IF CALL POPREAL8(ub) ub0(i-1, k, j) = ub0(i-1, k, j) + ubb END DO CALL POPINTEGER4(i) END IF END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(ru(i, k, j)+ru(i-1, k, j)) temp13b = vel*fqxb(i, k)/sumwk temp13b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk f0b = wi0*temp13b f1b = wi1*temp13b f2b = wi2*temp13b velb = temp13b0 sumwkb = -(vel*temp13b0/sumwk) wi0b = sumwkb + f0*temp13b wi1b = sumwkb + f1*temp13b wi2b = sumwkb + f2*temp13b fqxb(i, k) = 0.0 temp12 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp12**2) END IF temp11 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp11**2) END IF temp10 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp10**2) END IF CALL POPREAL8(beta2) temp10b = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp10b0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp10b0 - f2b/6. + temp10b CALL POPREAL8(beta1) temp10b1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp10b4 = 2*(qim1-qip1)*beta1b/4. qip1b = temp10b1 - temp10b4 + f1b/3. + 5.*f2b/6. - 4.*temp10b0 -& & 2.*temp10b CALL POPREAL8(beta0) temp10b3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp10b2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp10b1 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp10b2 + temp10b3 + 3.*temp10b0 + temp10b qim1b = temp10b4 - 4.*temp10b2 - 7.*f0b/6. - f1b/6. - 2.*& & temp10b3 + temp10b1 qim2b = f0b/3. + temp10b2 + temp10b3 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) ub0(i-3, k, j) = ub0(i-3, k, j) + qim2b CALL POPREAL8(qim1) ub0(i-2, k, j) = ub0(i-2, k, j) + qim1b CALL POPREAL8(qi) ub0(i-1, k, j) = ub0(i-1, k, j) + qib CALL POPREAL8(qip1) ub0(i, k, j) = ub0(i, k, j) + qip1b CALL POPREAL8(qip2) ub0(i+1, k, j) = ub0(i+1, k, j) + qip2b ELSE CALL POPREAL8(qim2) ub0(i+2, k, j) = ub0(i+2, k, j) + qim2b CALL POPREAL8(qim1) ub0(i+1, k, j) = ub0(i+1, k, j) + qim1b CALL POPREAL8(qi) ub0(i, k, j) = ub0(i, k, j) + qib CALL POPREAL8(qip1) ub0(i-1, k, j) = ub0(i-1, k, j) + qip1b CALL POPREAL8(qip2) ub0(i-2, k, j) = ub0(i-2, k, j) + qip2b END IF rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i-1, k, j) = rub(i-1, k, j) + 0.5*velb END DO CALL POPINTEGER4(i) END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO j=ad_to7,ad_from7,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 mrdy = msfux(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp2b = vel*fqyb(i, k, jp1)/sumwk temp2b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk f0b = wi0*temp2b f1b = wi1*temp2b f2b = wi2*temp2b velb = temp2b0 sumwkb = -(vel*temp2b0/sumwk) wi0b = sumwkb + f0*temp2b wi1b = sumwkb + f1*temp2b wi2b = sumwkb + f2*temp2b fqyb(i, k, jp1) = 0.0 temp1 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2) END IF temp0 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2) END IF temp = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2) END IF CALL POPREAL8(beta2) tempb = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb0 - f2b/6. + tempb CALL POPREAL8(beta1) tempb1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb4 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb1 - tempb4 + f1b/3. + 5.*f2b/6. - 4.*tempb0 - & & 2.*tempb CALL POPREAL8(beta0) tempb3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb1 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & tempb2 + tempb3 + 3.*tempb0 + tempb qim1b = tempb4 - 4.*tempb2 - 7.*f0b/6. - f1b/6. - 2.*tempb3 & & + tempb1 qim2b = f0b/3. + tempb2 + tempb3 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) ub0(i, k, j-3) = ub0(i, k, j-3) + qim2b CALL POPREAL8(qim1) ub0(i, k, j-2) = ub0(i, k, j-2) + qim1b CALL POPREAL8(qi) ub0(i, k, j-1) = ub0(i, k, j-1) + qib CALL POPREAL8(qip1) ub0(i, k, j) = ub0(i, k, j) + qip1b CALL POPREAL8(qip2) ub0(i, k, j+1) = ub0(i, k, j+1) + qip2b ELSE CALL POPREAL8(qim2) ub0(i, k, j+2) = ub0(i, k, j+2) + qim2b CALL POPREAL8(qim1) ub0(i, k, j+1) = ub0(i, k, j+1) + qim1b CALL POPREAL8(qi) ub0(i, k, j) = ub0(i, k, j) + qib CALL POPREAL8(qip1) ub0(i, k, j-1) = ub0(i, k, j-1) + qip1b CALL POPREAL8(qip2) ub0(i, k, j-2) = ub0(i, k, j-2) + qip2b END IF rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 temp2b1 = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp2b2 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp2b1 rvb(i-1, k, j) = rvb(i-1, k, j) + temp2b1 ub0(i, k, j) = ub0(i, k, j) + temp2b2 ub0(i, k, j-1) = ub0(i, k, j-1) + temp2b2 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp2 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, k& & , j-1)) temp5 = SIGN(1., vel) temp4 = temp5/12.0 temp3 = SIGN(1, time_step) temp2b3 = vel*fqyb(i, k, jp1) temp2b4 = temp2b3/12.0 temp2b5 = temp3*temp4*temp2b3 velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, j& & -2))/12.0+temp3*(temp4*temp2))*fqyb(i, k, jp1) ub0(i, k, j) = ub0(i, k, j) + 7.*temp2b4 - 3.*temp2b5 ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp2b5 + 7.*temp2b4 ub0(i, k, j+1) = ub0(i, k, j+1) + temp2b5 - temp2b4 ub0(i, k, j-2) = ub0(i, k, j-2) - temp2b5 - temp2b4 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp6b = 0.25*(u(i, k, j)+u(i, k, j-1))*fqyb(i, k, jp1) temp6b0 = 0.25*(rv(i, k, j)+rv(i-1, k, j))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp6b rvb(i-1, k, j) = rvb(i-1, k, j) + temp6b ub0(i, k, j) = ub0(i, k, j) + temp6b0 ub0(i, k, j-1) = ub0(i, k, j-1) + temp6b0 fqyb(i, k, jp1) = 0.0 END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = 0.5*(rv(i, k, j)+rv(i-1, k, j)) temp6 = u(i, k, j+1) - u(i, k, j-2) - 3.*(u(i, k, j)-u(i, k, j& & -1)) temp9 = SIGN(1., vel) temp8 = temp9/12.0 temp7 = SIGN(1, time_step) temp6b1 = vel*fqyb(i, k, jp1) temp6b2 = temp6b1/12.0 temp6b3 = temp7*temp8*temp6b1 velb = ((7.*(u(i, k, j)+u(i, k, j-1))-u(i, k, j+1)-u(i, k, j-2& & ))/12.0+temp7*(temp8*temp6))*fqyb(i, k, jp1) ub0(i, k, j) = ub0(i, k, j) + 7.*temp6b2 - 3.*temp6b3 ub0(i, k, j-1) = ub0(i, k, j-1) + 3.*temp6b3 + 7.*temp6b2 ub0(i, k, j+1) = ub0(i, k, j+1) + temp6b3 - temp6b2 ub0(i, k, j-2) = ub0(i, k, j-2) - temp6b3 - temp6b2 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i-1, k, j) = rvb(i-1, k, j) + 0.5*velb END DO END DO END IF END DO END SUBROUTINE A_ADVECT_WENO_U ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.6 (r4165) - 21 sep 2011 20:54 ! ! Differentiation of advect_weno_v in reverse (adjoint) mode: ! gradient of useful results: rom tendency v v_old ru rv ! mut ! with respect to varying inputs: rom tendency v v_old ru rv ! mut ! RW status of diff variables: rom:incr tendency:in-out v:incr ! v_old:incr ru:incr rv:incr mut:incr SUBROUTINE A_ADVECT_WENO_V(v, vb0, v_old, v_oldb, tendency, tendencyb, & & ru, rub, rv, rvb, rom, romb, mut, mutb, time_step, config_flags, msfux& & , msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, & & ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, & & jte, kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru& & , rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: vb0, v_oldb, rub, rvb, & & romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, jms:jme) :: mutb REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: dir, vv REAL :: ue, vs, vn, wb, wt REAL, PARAMETER :: f30=7./12., f31=1./12. REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60. INTEGER :: kt, kb REAL :: qim2, qim1, qi, qip1, qip2 REAL :: qim2b, qim1b, qib, qip1b, qip2b DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, & & sumwk DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b& & , wi2b, sumwkb DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=& & 3.d0/10.d0, eps=1.0d-18 INTEGER, PARAMETER :: pw=2 REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum REAL :: ubb, vbb, uwb, dupb, dumb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb INTEGER :: horz_order INTEGER :: vert_order LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified INTEGER :: branch INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: temp3 INTEGER :: temp29 REAL :: temp2 REAL :: temp28 DOUBLE PRECISION :: temp1 REAL :: temp27 DOUBLE PRECISION :: temp0 DOUBLE PRECISION :: temp13b REAL :: temp26 REAL :: temp21b INTEGER :: temp25 REAL :: temp24 DOUBLE PRECISION :: temp23 DOUBLE PRECISION :: temp22 DOUBLE PRECISION :: temp21 REAL :: temp20 REAL :: temp13b5 REAL :: temp13b4 DOUBLE PRECISION :: temp24b REAL :: temp13b3 REAL :: temp32b REAL :: temp13b2 REAL :: temp13b1 DOUBLE PRECISION :: temp13b0 REAL :: tempb4 REAL :: temp21b10 REAL :: tempb3 REAL :: temp28b1 REAL :: tempb2 REAL :: temp28b0 REAL :: tempb1 REAL :: tempb0 INTRINSIC MAX INTRINSIC SIGN REAL :: temp2b5 REAL :: temp2b4 REAL :: temp19 REAL :: temp2b3 INTEGER :: temp18 REAL :: temp2b2 REAL :: temp17 REAL :: temp2b1 REAL :: temp16 DOUBLE PRECISION :: temp2b0 REAL :: temp6b REAL :: temp15 INTEGER :: temp14 REAL :: temp13 REAL :: temp21b9 DOUBLE PRECISION :: temp12 REAL :: temp21b8 DOUBLE PRECISION :: temp11 REAL :: temp21b7 DOUBLE PRECISION :: temp10 REAL :: temp21b6 REAL :: temp21b5 REAL :: temp21b4 REAL :: temp21b3 REAL :: temp21b2 REAL :: temp21b1 REAL :: temp21b0 REAL :: tempb REAL :: temp24b5 DOUBLE PRECISION :: temp2b REAL :: temp24b4 REAL :: temp24b3 REAL :: temp24b2 REAL :: temp24b1 DOUBLE PRECISION :: temp24b0 REAL :: temp17b3 REAL :: temp17b2 REAL :: temp17b1 REAL :: temp17b0 REAL :: temp31 REAL :: temp30 REAL :: temp17b INTRINSIC MIN REAL :: temp28b REAL :: temp6b3 REAL :: temp6b2 REAL :: temp6b1 DOUBLE PRECISION :: temp REAL :: temp6b0 REAL :: temp32b1 REAL :: temp9 REAL :: temp10b4 REAL :: temp32b0 REAL :: temp8 REAL :: temp10b3 INTEGER :: temp7 REAL :: temp10b REAL :: temp10b2 REAL :: temp6 REAL :: temp10b1 REAL :: temp5 REAL :: temp10b0 REAL :: temp4 specified = .false. IF (config_flags%specified .OR. config_flags%nested) specified = & & .true. IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF ! here is the choice of flux operators ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF( horz_order == 5 ) THEN ! 5th order horizontal flux calculation ! This code is EXACTLY the same as the 6th order code ! EXCEPT the 5th order and 3rd operators are used in ! place of the 6th and 4th order operators ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its & & .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite & & .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts & & .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte & & .LT. jde - 3) degrade_ye = .false. !--------------- y - advection first i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF j_end_f = jde - 2 END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from7 = j_start j_loop_y_flux_5:DO j=ad_from7,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN DO k=kts,ktf ad_from = i_start DO i=ad_from,i_end vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = v(i, k, j+1) CALL PUSHREAL8(qip1) qip1 = v(i, k, j) CALL PUSHREAL8(qi) qi = v(i, k, j-1) CALL PUSHREAL8(qim1) qim1 = v(i, k, j-2) CALL PUSHREAL8(qim2) qim2 = v(i, k, j-3) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = v(i, k, j-2) CALL PUSHREAL8(qip1) qip1 = v(i, k, j-1) CALL PUSHREAL8(qi) qi = v(i, k, j) CALL PUSHREAL8(qim1) qim1 = v(i, k, j+1) CALL PUSHREAL8(qim2) qim2 = v(i, k, j+2) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*& & qi)**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*& & qi)**2 END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! fqy( i, k, jp1 ) = vel*flux5( & ! v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), & ! v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel ) ! we must be close to some boundary where we need to reduce the order of the stencil ! specified uses upstream normal wind at boundaries ! 2nd order flux next to south boundary DO k=kts,ktf ad_from0 = i_start DO i=ad_from0,i_end CALL PUSHREAL8(vb) vb = v(i, k, j-1) IF (specified .AND. v(i, k, j) .LT. 0.) THEN vb = v(i, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) END DO CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde) THEN ! 2nd order flux next to north boundary DO k=kts,ktf ad_from2 = i_start DO i=ad_from2,i_end CALL PUSHREAL8(vb) vb = v(i, k, j) IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN vb = v(i, k, j-1) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) END DO CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 1) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf ad_from3 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments on polar boundary conditions ! No advection over the poles means tendencies (held from jds [S. pole] ! to jde [N pole], i.e., on v grid) must be zero at poles ! [tendency(jds) and tendency(jde)=0] IF (config_flags%polar .AND. j .EQ. jds + 1) THEN DO k=kts,ktf ad_from4 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN ! If j_end were set to jde in a special if statement apart from ! degrade_ye, then we would hit the next conditional. But since ! we want the tendency to be zero anyway, not looping to jde+1 ! will produce the same effect. DO k=kts,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! Normal code DO k=kts,ktf ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from7) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from10 = j_start ! compute fluxes DO j=ad_from10,j_end ! 5th or 6th order flux DO k=kts,ktf DO i=i_start_f,i_end_f vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = v(i+1, k, j) CALL PUSHREAL8(qip1) qip1 = v(i, k, j) CALL PUSHREAL8(qi) qi = v(i-1, k, j) CALL PUSHREAL8(qim1) qim1 = v(i-2, k, j) CALL PUSHREAL8(qim2) qim2 = v(i-3, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = v(i-2, k, j) CALL PUSHREAL8(qip1) qip1 = v(i-1, k, j) CALL PUSHREAL8(qi) qi = v(i, k, j) CALL PUSHREAL8(qim1) qim1 = v(i+1, k, j) CALL PUSHREAL8(qim2) qim2 = v(i+2, k, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO ! fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j), & ! v(i-1,k,j), v(i ,k,j), & ! v(i+1,k,j), v(i+2,k,j), & ! vel ) ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from8 = i_start DO i=ad_from8,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from8) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! x flux-divergence into tendency DO k=kts,ktf ad_from9 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from10) ! Comments on polar boundary condition ! Force tendency=0 at NP and SP ! We keep setting this everywhere, but it can't hurt... IF (config_flags%polar .AND. jts .EQ. jds) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%polar .AND. jte .EQ. jde) THEN CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF ! radiative lateral boundary condition in y for normal velocity (v) IF (config_flags%open_ys .AND. jts .EQ. jds) THEN i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF ad_from11 = i_start DO i=ad_from11,i_end DO k=kts,ktf IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = rv(i, k, jts) - cb*mut(i, jts) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from11) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF ad_from12 = i_start DO i=ad_from12,i_end DO k=kts,ktf IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = rv(i, k, jte) + cb*mut(i, jte-1) CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from12) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges j_start = jts IF (jte .GT. jde) THEN j_end = jde ELSE j_end = jte END IF jmin = jds jmax = jde - 1 IF (config_flags%open_ys) THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF jmin = jds END IF IF (config_flags%open_ye) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF jmax = jde - 1 END IF ! compute x (u) conditions for v, w, or scalar IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from13 = j_start DO j=ad_from13,j_end CALL PUSHREAL8(mrdx) ! ADT eqn 45, 1st term on RHS mrdx = msfvy(its, j)*rdx IF (jmax .GT. j) THEN CALL PUSHINTEGER4(jp) jp = j CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jp) jp = jmax CALL PUSHCONTROL1B(1) END IF IF (jmin .LT. j - 1) THEN CALL PUSHINTEGER4(jm) jm = j - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jm) jm = jmin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf uw = 0.5*(ru(its, k, jp)+ru(its, k, jm)) IF (uw .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from13) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from14 = j_start DO j=ad_from14,j_end CALL PUSHREAL8(mrdx) ! ADT eqn 45, 1st term on RHS mrdx = msfvy(ite-1, j)*rdx IF (jmax .GT. j) THEN CALL PUSHINTEGER4(jp) jp = j CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jp) jp = jmax CALL PUSHCONTROL1B(1) END IF IF (jmin .LT. j - 1) THEN CALL PUSHINTEGER4(jm) jm = j - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(jm) jm = jmin CALL PUSHCONTROL1B(1) END IF DO k=kts,ktf uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm)) IF (uw .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from14) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w) ! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my) ! We therefore need to make a correction for advect_v ! since 'my' (map scale factor in y direction) isn't a function of z, ! we can do this using *(my/mx) (see eqn. 45 for example) i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts j_end = jte ! Polar boundary conditions are like open or specified ! We don't want to calculate vertical v tendencies at the N or S pole IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) & & THEN IF (jds + 1 .LT. jts) THEN j_start = jts ELSE j_start = jds + 1 END IF END IF IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) & & THEN IF (jde - 1 .GT. jte) THEN j_end = jte ELSE j_end = jde - 1 END IF END IF ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j=j_start,j_end DO k=kts+3,ktf-2 DO i=i_start,i_end vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) IF (-vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = v(i, k+1, j) CALL PUSHREAL8(qip1) qip1 = v(i, k, j) CALL PUSHREAL8(qi) qi = v(i, k-1, j) CALL PUSHREAL8(qim1) qim1 = v(i, k-2, j) CALL PUSHREAL8(qim2) qim2 = v(i, k-3, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = v(i, k-2, j) CALL PUSHREAL8(qip1) qip1 = v(i, k-1, j) CALL PUSHREAL8(qi) qi = v(i, k, j) CALL PUSHREAL8(qim1) qim1 = v(i, k+1, j) CALL PUSHREAL8(qim2) qim2 = v(i, k+2, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO CALL PUSHINTEGER4(k) END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO k=ktf,kts,-1 DO i=i_end,i_start,-1 temp32b1 = -(msfvy(i, j)*rdzw(k)*tendencyb(i, k, j)/msfvx(i, j)) vfluxb(i, k+1) = vfluxb(i, k+1) + temp32b1 vfluxb(i, k) = vfluxb(i, k) - temp32b1 END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf temp32b = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, k) temp32b0 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp32b romb(i, k, j-1) = romb(i, k, j-1) + temp32b vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp32b0 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp32b0 vfluxb(i, k) = 0.0 k = ktf - 1 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp28 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, j)& & ) temp31 = SIGN(1., -vel) temp30 = temp31/12.0 temp29 = SIGN(1, time_step) temp28b = vel*vfluxb(i, k) temp28b0 = temp28b/12.0 temp28b1 = temp29*temp30*temp28b velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))/& & 12.0+temp29*(temp30*temp28))*vfluxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp28b0 - 3.*temp28b1 vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp28b1 + 7.*temp28b0 vb0(i, k+1, j) = vb0(i, k+1, j) + temp28b1 - temp28b0 vb0(i, k-2, j) = vb0(i, k-2, j) - temp28b1 - temp28b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp24 = v(i, k+1, j) - v(i, k-2, j) - 3.*(v(i, k, j)-v(i, k-1, j)& & ) temp27 = SIGN(1., -vel) temp26 = temp27/12.0 temp25 = SIGN(1, time_step) temp24b1 = vel*vfluxb(i, k) temp24b2 = temp24b1/12.0 temp24b3 = temp25*temp26*temp24b1 velb = ((7.*(v(i, k, j)+v(i, k-1, j))-v(i, k+1, j)-v(i, k-2, j))/& & 12.0+temp25*(temp26*temp24))*vfluxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp24b2 - 3.*temp24b3 vb0(i, k-1, j) = vb0(i, k-1, j) + 3.*temp24b3 + 7.*temp24b2 vb0(i, k+1, j) = vb0(i, k+1, j) + temp24b3 - temp24b2 vb0(i, k-2, j) = vb0(i, k-2, j) - temp24b3 - temp24b2 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb k = kts + 1 temp24b4 = 0.5*(fzm(k)*v(i, k, j)+fzp(k)*v(i, k-1, j))*vfluxb(i, k& & ) temp24b5 = 0.5*(rom(i, k, j)+rom(i, k, j-1))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp24b4 romb(i, k, j-1) = romb(i, k, j-1) + temp24b4 vb0(i, k, j) = vb0(i, k, j) + fzm(k)*temp24b5 vb0(i, k-1, j) = vb0(i, k-1, j) + fzp(k)*temp24b5 vfluxb(i, k) = 0.0 END DO DO k=ktf-2,kts+3,-1 DO i=i_end,i_start,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rom(i, k, j)+rom(i, k, j-1)) temp24b = vel*vfluxb(i, k)/sumwk temp24b0 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk f0b = wi0*temp24b f1b = wi1*temp24b f2b = wi2*temp24b velb = temp24b0 sumwkb = -(vel*temp24b0/sumwk) wi0b = sumwkb + f0*temp24b wi1b = sumwkb + f1*temp24b wi2b = sumwkb + f2*temp24b vfluxb(i, k) = 0.0 temp23 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp23**2) END IF temp22 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp22**2) END IF temp21 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp21**2) END IF CALL POPREAL8(beta2) temp21b5 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp21b6 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp21b6 - f2b/6. + temp21b5 CALL POPREAL8(beta1) temp21b7 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp21b10 = 2*(qim1-qip1)*beta1b/4. qip1b = temp21b7 - temp21b10 + f1b/3. + 5.*f2b/6. - 4.*temp21b6 & & - 2.*temp21b5 CALL POPREAL8(beta0) temp21b9 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp21b8 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp21b7 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp21b8 + temp21b9 + 3.*temp21b6 + temp21b5 qim1b = temp21b10 - 4.*temp21b8 - 7.*f0b/6. - f1b/6. - 2.*& & temp21b9 + temp21b7 qim2b = f0b/3. + temp21b8 + temp21b9 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) vb0(i, k-3, j) = vb0(i, k-3, j) + qim2b CALL POPREAL8(qim1) vb0(i, k-2, j) = vb0(i, k-2, j) + qim1b CALL POPREAL8(qi) vb0(i, k-1, j) = vb0(i, k-1, j) + qib CALL POPREAL8(qip1) vb0(i, k, j) = vb0(i, k, j) + qip1b CALL POPREAL8(qip2) vb0(i, k+1, j) = vb0(i, k+1, j) + qip2b ELSE CALL POPREAL8(qim2) vb0(i, k+2, j) = vb0(i, k+2, j) + qim2b CALL POPREAL8(qim1) vb0(i, k+1, j) = vb0(i, k+1, j) + qim1b CALL POPREAL8(qi) vb0(i, k, j) = vb0(i, k, j) + qib CALL POPREAL8(qip1) vb0(i, k-1, j) = vb0(i, k-1, j) + qip1b CALL POPREAL8(qip2) vb0(i, k-2, j) = vb0(i, k-2, j) + qip2b END IF romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k, j-1) = romb(i, k, j-1) + 0.5*velb END DO END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO j=ad_to14,ad_from14,-1 DO k=ktf,kts,-1 dum = ru(ite, k, jm) - ru(ite-1, k, jm) dup = ru(ite, k, jp) - ru(ite-1, k, jp) temp21b3 = -(mrdx*tendencyb(ite-1, k, j)) temp21b4 = 0.5*v(ite-1, k, j)*temp21b3 ubb = (v_old(ite-1, k, j)-v_old(ite-2, k, j))*temp21b3 v_oldb(ite-1, k, j) = v_oldb(ite-1, k, j) + ub*temp21b3 v_oldb(ite-2, k, j) = v_oldb(ite-2, k, j) - ub*temp21b3 vb0(ite-1, k, j) = vb0(ite-1, k, j) + 0.5*(dup+dum)*temp21b3 dupb = temp21b4 dumb = temp21b4 rub(ite, k, jm) = rub(ite, k, jm) + dumb rub(ite-1, k, jm) = rub(ite-1, k, jm) - dumb rub(ite, k, jp) = rub(ite, k, jp) + dupb rub(ite-1, k, jp) = rub(ite-1, k, jp) - dupb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF rub(ite, k, jp) = rub(ite, k, jp) + 0.5*uwb rub(ite, k, jm) = rub(ite, k, jm) + 0.5*uwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jm) ELSE CALL POPINTEGER4(jm) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jp) ELSE CALL POPINTEGER4(jp) END IF CALL POPREAL8(mrdx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from13) CALL POPINTEGER4(ad_to13) DO j=ad_to13,ad_from13,-1 DO k=ktf,kts,-1 dum = ru(its+1, k, jm) - ru(its, k, jm) dup = ru(its+1, k, jp) - ru(its, k, jp) temp21b1 = -(mrdx*tendencyb(its, k, j)) temp21b2 = 0.5*v(its, k, j)*temp21b1 ubb = (v_old(its+1, k, j)-v_old(its, k, j))*temp21b1 v_oldb(its+1, k, j) = v_oldb(its+1, k, j) + ub*temp21b1 v_oldb(its, k, j) = v_oldb(its, k, j) - ub*temp21b1 vb0(its, k, j) = vb0(its, k, j) + 0.5*(dup+dum)*temp21b1 dupb = temp21b2 dumb = temp21b2 rub(its+1, k, jm) = rub(its+1, k, jm) + dumb rub(its, k, jm) = rub(its, k, jm) - dumb rub(its+1, k, jp) = rub(its+1, k, jp) + dupb rub(its, k, jp) = rub(its, k, jp) - dupb CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF rub(its, k, jp) = rub(its, k, jp) + 0.5*uwb rub(its, k, jm) = rub(its, k, jm) + 0.5*uwb END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jm) ELSE CALL POPINTEGER4(jm) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(jp) ELSE CALL POPINTEGER4(jp) END IF CALL POPREAL8(mrdx) END DO END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO i=ad_to12,ad_from12,-1 DO k=ktf,kts,-1 temp21b0 = -(rdy*tendencyb(i, k, jte)) vbb = (v_old(i, k, jte)-v_old(i, k, jte-1))*temp21b0 v_oldb(i, k, jte) = v_oldb(i, k, jte) + vb*temp21b0 v_oldb(i, k, jte-1) = v_oldb(i, k, jte-1) - vb*temp21b0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jte) = rvb(i, k, jte) + vbb mutb(i, jte-1) = mutb(i, jte-1) + cb*vbb END IF END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO i=ad_to11,ad_from11,-1 DO k=ktf,kts,-1 temp21b = -(rdy*tendencyb(i, k, jts)) vbb = (v_old(i, k, jts+1)-v_old(i, k, jts))*temp21b v_oldb(i, k, jts+1) = v_oldb(i, k, jts+1) + vb*temp21b v_oldb(i, k, jts) = v_oldb(i, k, jts) - vb*temp21b CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) ELSE CALL POPREAL8(vb) rvb(i, k, jts) = rvb(i, k, jts) + vbb mutb(i, jts) = mutb(i, jts) - cb*vbb END IF END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO i=ite,its,-1 DO k=ktf,kts,-1 tendencyb(i, k, jte) = 0.0 END DO END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO i=ite,its,-1 DO k=ktf,kts,-1 tendencyb(i, k, jts) = 0.0 END DO END DO END IF fqxb = 0.0 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO j=ad_to10,ad_from10,-1 DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 mrdx = msfvy(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to8) DO i=ad_to8,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp17 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(i-1& & , k, j)) temp20 = SIGN(1., vel) temp19 = temp20/12.0 temp18 = SIGN(1, time_step) temp17b1 = vel*fqxb(i, k) temp17b2 = temp17b1/12.0 temp17b3 = temp18*temp19*temp17b1 velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k& & , j))/12.0+temp18*(temp19*temp17))*fqxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp17b2 - 3.*temp17b3 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp17b3 + 7.*temp17b2 vb0(i+1, k, j) = vb0(i+1, k, j) + temp17b3 - temp17b2 vb0(i-2, k, j) = vb0(i-2, k, j) - temp17b3 - temp17b2 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp17b = 0.25*(v(i_end+1, k, j)+v(i_end, k, j))*fqxb(i, k) temp17b0 = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*fqxb& & (i, k) rub(i_end+1, k, j) = rub(i_end+1, k, j) + temp17b rub(i_end+1, k, j-1) = rub(i_end+1, k, j-1) + temp17b vb0(i_end+1, k, j) = vb0(i_end+1, k, j) + temp17b0 vb0(i_end, k, j) = vb0(i_end, k, j) + temp17b0 fqxb(i, k) = 0.0 END DO END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from8) DO i=i_start_f-1,ad_from8,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN DO k=ktf,kts,-1 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp13 = v(i+1, k, j) - v(i-2, k, j) - 3.*(v(i, k, j)-v(i-1& & , k, j)) temp16 = SIGN(1., vel) temp15 = temp16/12.0 temp14 = SIGN(1, time_step) temp13b3 = vel*fqxb(i, k) temp13b4 = temp13b3/12.0 temp13b5 = temp14*temp15*temp13b3 velb = ((7.*(v(i, k, j)+v(i-1, k, j))-v(i+1, k, j)-v(i-2, k& & , j))/12.0+temp14*(temp15*temp13))*fqxb(i, k) vb0(i, k, j) = vb0(i, k, j) + 7.*temp13b4 - 3.*temp13b5 vb0(i-1, k, j) = vb0(i-1, k, j) + 3.*temp13b5 + 7.*temp13b4 vb0(i+1, k, j) = vb0(i+1, k, j) + temp13b5 - temp13b4 vb0(i-2, k, j) = vb0(i-2, k, j) - temp13b5 - temp13b4 fqxb(i, k) = 0.0 rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 temp13b1 = 0.25*(v(i, k, j)+v(i-1, k, j))*fqxb(i, k) temp13b2 = 0.25*(ru(i, k, j)+ru(i, k, j-1))*fqxb(i, k) rub(i, k, j) = rub(i, k, j) + temp13b1 rub(i, k, j-1) = rub(i, k, j-1) + temp13b1 vb0(i, k, j) = vb0(i, k, j) + temp13b2 vb0(i-1, k, j) = vb0(i-1, k, j) + temp13b2 fqxb(i, k) = 0.0 END DO END IF END DO END IF DO k=ktf,kts,-1 DO i=i_end_f,i_start_f,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(ru(i, k, j)+ru(i, k, j-1)) temp13b = vel*fqxb(i, k)/sumwk temp13b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk f0b = wi0*temp13b f1b = wi1*temp13b f2b = wi2*temp13b velb = temp13b0 sumwkb = -(vel*temp13b0/sumwk) wi0b = sumwkb + f0*temp13b wi1b = sumwkb + f1*temp13b wi2b = sumwkb + f2*temp13b fqxb(i, k) = 0.0 temp12 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp12**2) END IF temp11 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp11**2) END IF temp10 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp10**2) END IF CALL POPREAL8(beta2) temp10b = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp10b0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp10b0 - f2b/6. + temp10b CALL POPREAL8(beta1) temp10b1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp10b4 = 2*(qim1-qip1)*beta1b/4. qip1b = temp10b1 - temp10b4 + f1b/3. + 5.*f2b/6. - 4.*temp10b0 -& & 2.*temp10b CALL POPREAL8(beta0) temp10b3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp10b2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp10b1 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp10b2 + temp10b3 + 3.*temp10b0 + temp10b qim1b = temp10b4 - 4.*temp10b2 - 7.*f0b/6. - f1b/6. - 2.*& & temp10b3 + temp10b1 qim2b = f0b/3. + temp10b2 + temp10b3 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) vb0(i-3, k, j) = vb0(i-3, k, j) + qim2b CALL POPREAL8(qim1) vb0(i-2, k, j) = vb0(i-2, k, j) + qim1b CALL POPREAL8(qi) vb0(i-1, k, j) = vb0(i-1, k, j) + qib CALL POPREAL8(qip1) vb0(i, k, j) = vb0(i, k, j) + qip1b CALL POPREAL8(qip2) vb0(i+1, k, j) = vb0(i+1, k, j) + qip2b ELSE CALL POPREAL8(qim2) vb0(i+2, k, j) = vb0(i+2, k, j) + qim2b CALL POPREAL8(qim1) vb0(i+1, k, j) = vb0(i+1, k, j) + qim1b CALL POPREAL8(qi) vb0(i, k, j) = vb0(i, k, j) + qib CALL POPREAL8(qip1) vb0(i-1, k, j) = vb0(i-1, k, j) + qip1b CALL POPREAL8(qip2) vb0(i-2, k, j) = vb0(i-2, k, j) + qip2b END IF rub(i, k, j) = rub(i, k, j) + 0.5*velb rub(i, k, j-1) = rub(i, k, j-1) + 0.5*velb END DO END DO END DO fqyb = 0.0 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO j=ad_to7,ad_from7,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 tendencyb(i, k, j-1) = 0.0 END DO END DO END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 mrdy = msfvy(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1) END DO END DO END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp2b = vel*fqyb(i, k, jp1)/sumwk temp2b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk f0b = wi0*temp2b f1b = wi1*temp2b f2b = wi2*temp2b velb = temp2b0 sumwkb = -(vel*temp2b0/sumwk) wi0b = sumwkb + f0*temp2b wi1b = sumwkb + f1*temp2b wi2b = sumwkb + f2*temp2b fqyb(i, k, jp1) = 0.0 temp1 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2) END IF temp0 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2) END IF temp = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2) END IF CALL POPREAL8(beta2) tempb = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb0 - f2b/6. + tempb CALL POPREAL8(beta1) tempb1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb4 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb1 - tempb4 + f1b/3. + 5.*f2b/6. - 4.*tempb0 - & & 2.*tempb CALL POPREAL8(beta0) tempb3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb1 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & tempb2 + tempb3 + 3.*tempb0 + tempb qim1b = tempb4 - 4.*tempb2 - 7.*f0b/6. - f1b/6. - 2.*tempb3 & & + tempb1 qim2b = f0b/3. + tempb2 + tempb3 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) vb0(i, k, j-3) = vb0(i, k, j-3) + qim2b CALL POPREAL8(qim1) vb0(i, k, j-2) = vb0(i, k, j-2) + qim1b CALL POPREAL8(qi) vb0(i, k, j-1) = vb0(i, k, j-1) + qib CALL POPREAL8(qip1) vb0(i, k, j) = vb0(i, k, j) + qip1b CALL POPREAL8(qip2) vb0(i, k, j+1) = vb0(i, k, j+1) + qip2b ELSE CALL POPREAL8(qim2) vb0(i, k, j+2) = vb0(i, k, j+2) + qim2b CALL POPREAL8(qim1) vb0(i, k, j+1) = vb0(i, k, j+1) + qim1b CALL POPREAL8(qi) vb0(i, k, j) = vb0(i, k, j) + qib CALL POPREAL8(qip1) vb0(i, k, j-1) = vb0(i, k, j-1) + qip1b CALL POPREAL8(qip2) vb0(i, k, j-2) = vb0(i, k, j-2) + qip2b END IF rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO ELSE IF (branch .EQ. 1) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 temp2b1 = 0.25*(v(i, k, j)+vb)*fqyb(i, k, jp1) temp2b2 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp2b1 rvb(i, k, j-1) = rvb(i, k, j-1) + temp2b1 vb0(i, k, j) = vb0(i, k, j) + temp2b2 vbb = temp2b2 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j) = vb0(i, k, j) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j-1) = vb0(i, k, j-1) + vbb END DO END DO ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp2 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, k& & , j-1)) temp5 = SIGN(1., vel) temp4 = temp5/12.0 temp3 = SIGN(1, time_step) temp2b3 = vel*fqyb(i, k, jp1) temp2b4 = temp2b3/12.0 temp2b5 = temp3*temp4*temp2b3 velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, j& & -2))/12.0+temp3*(temp4*temp2))*fqyb(i, k, jp1) vb0(i, k, j) = vb0(i, k, j) + 7.*temp2b4 - 3.*temp2b5 vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp2b5 + 7.*temp2b4 vb0(i, k, j+1) = vb0(i, k, j+1) + temp2b5 - temp2b4 vb0(i, k, j-2) = vb0(i, k, j-2) - temp2b5 - temp2b4 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF ELSE IF (branch .EQ. 3) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp6b = 0.25*(vb+v(i, k, j-1))*fqyb(i, k, jp1) temp6b0 = 0.25*(rv(i, k, j)+rv(i, k, j-1))*fqyb(i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + temp6b rvb(i, k, j-1) = rvb(i, k, j-1) + temp6b vbb = temp6b0 vb0(i, k, j-1) = vb0(i, k, j-1) + temp6b0 fqyb(i, k, jp1) = 0.0 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN vb0(i, k, j-1) = vb0(i, k, j-1) + vbb vbb = 0.0 END IF CALL POPREAL8(vb) vb0(i, k, j) = vb0(i, k, j) + vbb END DO END DO ELSE IF (branch .EQ. 4) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = 0.5*(rv(i, k, j)+rv(i, k, j-1)) temp6 = v(i, k, j+1) - v(i, k, j-2) - 3.*(v(i, k, j)-v(i, k, j& & -1)) temp9 = SIGN(1., vel) temp8 = temp9/12.0 temp7 = SIGN(1, time_step) temp6b1 = vel*fqyb(i, k, jp1) temp6b2 = temp6b1/12.0 temp6b3 = temp7*temp8*temp6b1 velb = ((7.*(v(i, k, j)+v(i, k, j-1))-v(i, k, j+1)-v(i, k, j-2& & ))/12.0+temp7*(temp8*temp6))*fqyb(i, k, jp1) vb0(i, k, j) = vb0(i, k, j) + 7.*temp6b2 - 3.*temp6b3 vb0(i, k, j-1) = vb0(i, k, j-1) + 3.*temp6b3 + 7.*temp6b2 vb0(i, k, j+1) = vb0(i, k, j+1) + temp6b3 - temp6b2 vb0(i, k, j-2) = vb0(i, k, j-2) - temp6b3 - temp6b2 fqyb(i, k, jp1) = 0.0 rvb(i, k, j) = rvb(i, k, j) + 0.5*velb rvb(i, k, j-1) = rvb(i, k, j-1) + 0.5*velb END DO END DO END IF END DO END SUBROUTINE A_ADVECT_WENO_V ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.6 (r4165) - 21 sep 2011 20:54 ! ! Differentiation of advect_weno_w in reverse (adjoint) mode: ! gradient of useful results: rom tendency w ru rv w_old ! with respect to varying inputs: rom tendency w ru rv w_old ! RW status of diff variables: rom:incr tendency:in-out w:incr ! ru:incr rv:incr w_old:incr SUBROUTINE A_ADVECT_WENO_W(w, wb0, w_old, w_oldb, tendency, tendencyb, & & ru, rub, rv, rvb, rom, romb, mut, time_step, config_flags, msfux, & & msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide& & , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte& & , kts, kte) IMPLICIT NONE ! Input data TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru& & , rv, rom REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: wb0, w_oldb, rub, rvb, & & romb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu REAL, INTENT(IN) :: rdx, rdy INTEGER, INTENT(IN) :: time_step ! Local data INTEGER :: i, j, k, itf, jtf, ktf INTEGER :: i_start, i_end, j_start, j_end INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw REAL :: ubb, vbb, uwb, vwb REAL, DIMENSION(its:ite, kts:kte) :: vflux REAL, DIMENSION(its:ite, kts:kte) :: vfluxb REAL :: dir, vv REAL :: ue, vs, vn, wb, wt REAL, PARAMETER :: f30=7./12., f31=1./12. REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60. INTEGER :: kt, kb REAL :: qim2, qim1, qi, qip1, qip2 REAL :: qim2b, qim1b, qib, qip1b, qip2b DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, & & sumwk DOUBLE PRECISION :: beta0b, beta1b, beta2b, f0b, f1b, f2b, wi0b, wi1b& & , wi2b, sumwkb DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=& & 3.d0/10.d0, eps=1.0d-18 INTEGER, PARAMETER :: pw=2 INTEGER :: horz_order, vert_order REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx REAL, DIMENSION(its:ite+1, kts:kte) :: fqxb REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyb LOGICAL :: degrade_xs, degrade_ys LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp ! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6 REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel REAL :: velb LOGICAL :: specified INTEGER :: branch INTEGER :: ad_from INTEGER :: ad_to INTEGER :: ad_from0 INTEGER :: ad_to0 INTEGER :: ad_from1 INTEGER :: ad_to1 INTEGER :: ad_from2 INTEGER :: ad_to2 INTEGER :: ad_from3 INTEGER :: ad_to3 INTEGER :: ad_from4 INTEGER :: ad_to4 INTEGER :: ad_from5 INTEGER :: ad_to5 INTEGER :: ad_from6 INTEGER :: ad_to6 INTEGER :: ad_from7 INTEGER :: ad_to7 INTEGER :: ad_from8 INTEGER :: ad_to8 INTEGER :: ad_from9 INTEGER :: ad_to9 INTEGER :: ad_from10 INTEGER :: ad_to10 INTEGER :: ad_from11 INTEGER :: ad_to11 INTEGER :: ad_from12 INTEGER :: ad_to12 INTEGER :: ad_from13 INTEGER :: ad_to13 INTEGER :: ad_from14 INTEGER :: ad_to14 INTEGER :: ad_from15 INTEGER :: ad_to15 INTEGER :: ad_from16 INTEGER :: ad_to16 INTEGER :: ad_from17 INTEGER :: ad_to17 INTEGER :: ad_from18 INTEGER :: ad_to18 INTEGER :: ad_from19 INTEGER :: ad_to19 INTEGER :: ad_from20 INTEGER :: ad_to20 INTEGER :: ad_from21 INTEGER :: ad_to21 INTEGER :: ad_from22 INTEGER :: ad_to22 INTEGER :: ad_from23 INTEGER :: ad_to23 DOUBLE PRECISION :: temp3 REAL :: temp29 REAL :: temp43b40 DOUBLE PRECISION :: temp2 INTEGER :: temp28 DOUBLE PRECISION :: temp1 REAL :: temp27 DOUBLE PRECISION :: temp0 REAL :: temp13b DOUBLE PRECISION :: temp26 REAL :: temp21b DOUBLE PRECISION :: temp25 DOUBLE PRECISION :: temp24 DOUBLE PRECISION :: temp23 REAL :: temp35b5 REAL :: temp9b1 DOUBLE PRECISION :: temp22 REAL :: temp35b4 REAL :: temp9b0 DOUBLE PRECISION :: temp21 REAL :: temp35b3 REAL :: temp20 REAL :: temp35b2 REAL :: temp13b5 REAL :: temp35b1 REAL :: temp13b4 DOUBLE PRECISION :: temp24b REAL :: temp35b0 REAL :: temp13b3 REAL :: temp13b2 REAL :: temp53 REAL :: temp13b1 REAL :: temp52 REAL :: temp13b0 INTEGER :: temp51 REAL :: temp50 REAL :: tempb4 REAL :: tempb3 DOUBLE PRECISION :: temp27b REAL :: tempb2 REAL :: temp35b REAL :: tempb1 REAL :: temp43b REAL :: tempb0 REAL :: temp43b39 INTRINSIC MAX REAL :: temp43b38 REAL :: temp43b37 REAL :: temp43b36 INTRINSIC SIGN REAL :: temp43b35 REAL :: temp43b34 DOUBLE PRECISION :: temp46b REAL :: temp43b33 REAL :: temp54b REAL :: temp2b6 REAL :: temp43b32 REAL :: temp2b5 REAL :: temp43b31 REAL :: temp2b4 REAL :: temp19 REAL :: temp43b30 REAL :: temp2b3 INTEGER :: temp18 REAL :: temp2b2 REAL :: temp17 REAL :: temp43b9 REAL :: temp50b1 REAL :: temp2b1 REAL :: temp16 REAL :: temp43b8 REAL :: temp50b0 DOUBLE PRECISION :: temp2b0 REAL :: temp15 REAL :: temp43b7 INTEGER :: temp14 REAL :: temp43b6 REAL :: temp13 REAL :: temp43b5 REAL :: temp12 REAL :: temp43b4 REAL :: temp49 REAL :: temp11 REAL :: temp43b3 REAL :: temp48 INTEGER :: temp10 REAL :: temp43b2 INTEGER :: temp47 REAL :: temp43b1 REAL :: temp46 REAL :: temp9b REAL :: temp21b4 REAL :: temp43b0 DOUBLE PRECISION :: temp45 REAL :: temp21b3 REAL :: temp31b DOUBLE PRECISION :: temp44 REAL :: temp21b2 DOUBLE PRECISION :: temp43 REAL :: temp5b7 REAL :: temp21b1 REAL :: temp42 REAL :: temp5b6 REAL :: temp21b0 REAL :: temp41 REAL :: temp5b5 INTEGER :: temp40 REAL :: temp5b4 REAL :: temp5b3 REAL :: temp5b2 REAL :: temp5b1 DOUBLE PRECISION :: temp5b0 REAL :: temp50b REAL :: tempb REAL :: temp43b29 REAL :: temp31b1 REAL :: temp43b28 REAL :: temp46b5 REAL :: temp31b0 REAL :: temp43b27 REAL :: temp46b4 REAL :: temp43b26 REAL :: temp46b3 REAL :: temp24b6 REAL :: temp43b25 REAL :: temp46b2 REAL :: temp24b5 REAL :: temp43b24 REAL :: temp46b1 DOUBLE PRECISION :: temp2b REAL :: temp24b4 REAL :: temp43b23 DOUBLE PRECISION :: temp46b0 REAL :: temp24b3 REAL :: temp43b22 REAL :: temp24b2 REAL :: temp43b21 REAL :: temp24b1 REAL :: temp43b20 DOUBLE PRECISION :: temp24b0 DOUBLE PRECISION :: temp5b REAL :: temp39b1 REAL :: temp39b0 REAL :: temp39 REAL :: temp17b1 REAL :: temp38 REAL :: temp17b0 REAL :: temp37 INTEGER :: temp36 REAL :: temp27b7 REAL :: temp35 REAL :: temp27b6 REAL :: temp34 REAL :: temp27b5 REAL :: temp33 REAL :: temp27b4 INTEGER :: temp32 REAL :: temp27b3 REAL :: temp31 REAL :: temp27b2 REAL :: temp30 REAL :: temp17b REAL :: temp27b1 DOUBLE PRECISION :: temp27b0 REAL :: temp43b19 INTRINSIC MIN REAL :: temp43b18 REAL :: temp43b17 REAL :: temp43b16 REAL :: temp43b15 REAL :: temp43b14 REAL :: temp43b13 REAL :: temp54b0 DOUBLE PRECISION :: temp REAL :: temp43b12 REAL :: temp43b11 REAL :: temp43b10 REAL :: temp9 REAL :: temp8 REAL :: temp39b REAL :: temp7 INTEGER :: temp6 REAL :: temp5 DOUBLE PRECISION :: temp4 IF (kte .GT. kde - 1) THEN ktf = kde - 1 ELSE ktf = kte END IF ! here is the choice of flux operators ! begin with horizontal flux divergence ! horizontal_order_test : IF( horz_order == 6 ) THEN ! ELSE IF (horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application ! of the higher order flux stencils degrade_xs = .true. degrade_xe = .true. degrade_ys = .true. degrade_ye = .true. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its & & .GT. ids + 3) degrade_xs = .false. IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite & & .LT. ide - 3) degrade_xe = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts & & .GT. jds + 3) degrade_ys = .false. IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte & & .LT. jde - 4) degrade_ye = .false. !--------------- y - advection first i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary j_start_f = j_start j_end_f = j_end + 1 IF (degrade_ys) THEN IF (jts .LT. jds + 1) THEN j_start = jds + 1 ELSE j_start = jts END IF j_start_f = jds + 3 END IF IF (degrade_ye) THEN IF (jte .GT. jde - 2) THEN j_end = jde - 2 ELSE j_end = jte END IF j_end_f = jde - 3 END IF IF (config_flags%polar) THEN IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF END IF ! compute fluxes, 5th or 6th order jp1 = 2 jp0 = 1 ad_from12 = j_start j_loop_y_flux_5:DO j=ad_from12,j_end+1 IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN CALL PUSHINTEGER4(k) DO k=kts+1,ktf ad_from = i_start DO i=ad_from,i_end CALL PUSHREAL8(vel) vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = w(i, k, j+1) CALL PUSHREAL8(qip1) qip1 = w(i, k, j) CALL PUSHREAL8(qi) qi = w(i, k, j-1) CALL PUSHREAL8(qim1) qim1 = w(i, k, j-2) CALL PUSHREAL8(qim2) qim2 = w(i, k, j-3) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = w(i, k, j-2) CALL PUSHREAL8(qip1) qip1 = w(i, k, j-1) CALL PUSHREAL8(qi) qi = w(i, k, j) CALL PUSHREAL8(qim1) qim1 = w(i, k, j+1) CALL PUSHREAL8(qim2) qim2 = w(i, k, j+2) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*& & qi)**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*& & qi)**2 END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from) END DO ! fqy( i, k, jp1 ) = vel*flux5( & ! w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & ! w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) k = ktf + 1 ad_from0 = i_start DO i=ad_from0,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = w(i, k, j+1) CALL PUSHREAL8(qip1) qip1 = w(i, k, j) CALL PUSHREAL8(qi) qi = w(i, k, j-1) CALL PUSHREAL8(qim1) qim1 = w(i, k, j-2) CALL PUSHREAL8(qim2) qim2 = w(i, k, j-3) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = w(i, k, j-2) CALL PUSHREAL8(qip1) qip1 = w(i, k, j-1) CALL PUSHREAL8(qi) qi = w(i, k, j) CALL PUSHREAL8(qim1) qim1 = w(i, k, j+1) CALL PUSHREAL8(qim2) qim2 = w(i, k, j+2) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from0) CALL PUSHCONTROL3B(0) ELSE IF (j .EQ. jds + 1) THEN ! fqy( i, k, jp1 ) = vel*flux5( & ! w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), & ! w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel ) CALL PUSHINTEGER4(k) ! 2nd order flux next to south boundary DO k=kts+1,ktf ad_from1 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from1) END DO k = ktf + 1 ad_from2 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from2) CALL PUSHCONTROL3B(1) ELSE IF (j .EQ. jds + 2) THEN CALL PUSHINTEGER4(k) ! third of 4th order flux 2 in from south boundary DO k=kts+1,ktf ad_from3 = i_start DO i=ad_from3,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from3) END DO k = ktf + 1 ad_from4 = i_start DO i=ad_from4,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from4) CALL PUSHCONTROL3B(2) ELSE IF (j .EQ. jde - 1) THEN CALL PUSHINTEGER4(k) ! 2nd order flux next to north boundary DO k=kts+1,ktf ad_from5 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from5) END DO k = ktf + 1 ad_from6 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from6) CALL PUSHCONTROL3B(3) ELSE IF (j .EQ. jde - 2) THEN CALL PUSHINTEGER4(k) ! 3rd or 4th order flux 2 in from north boundary DO k=kts+1,ktf ad_from7 = i_start DO i=ad_from7,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from7) END DO k = ktf + 1 ad_from8 = i_start DO i=ad_from8,i_end CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j) END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from8) CALL PUSHCONTROL3B(4) ELSE CALL PUSHCONTROL3B(5) END IF ! y flux-divergence into tendency ! Comments for polar boundary conditions ! Same process as for advect_u - tendencies run from jds to jde-1 ! (latitudes are as for u grid, longitudes are displaced) ! Therefore: flow is only from one side for points next to poles IF (config_flags%polar .AND. j .EQ. jds + 1) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from9 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from9) END DO CALL PUSHCONTROL2B(0) ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN CALL PUSHINTEGER4(k) DO k=kts,ktf ad_from10 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from10) END DO CALL PUSHCONTROL2B(1) ELSE IF (j .GT. j_start) THEN ! normal code CALL PUSHINTEGER4(k) DO k=kts+1,ktf+1 ad_from11 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from11) END DO CALL PUSHCONTROL2B(2) ELSE CALL PUSHCONTROL2B(3) END IF jtmp = jp1 CALL PUSHINTEGER4(jp1) jp1 = jp0 CALL PUSHINTEGER4(jp0) jp0 = jtmp END DO j_loop_y_flux_5 CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from12) ! next, x - flux divergence i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF ! higher order flux has a 5 or 7 point stencil, so compute ! bounds so we can switch to second order flux close to the boundary i_start_f = i_start i_end_f = i_end + 1 IF (degrade_xs) THEN IF (ids + 1 .LT. its) THEN i_start = its ELSE i_start = ids + 1 END IF IF (i_start + 2 .GT. ids + 3) THEN i_start_f = ids + 3 ELSE i_start_f = i_start + 2 END IF END IF IF (degrade_xe) THEN IF (ide - 2 .GT. ite) THEN i_end = ite ELSE i_end = ide - 2 END IF i_end_f = ide - 3 END IF ad_from15 = j_start ! compute fluxes DO j=ad_from15,j_end CALL PUSHINTEGER4(k) ! 5th or 6th order flux DO k=kts+1,ktf DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = w(i+1, k, j) CALL PUSHREAL8(qip1) qip1 = w(i, k, j) CALL PUSHREAL8(qi) qi = w(i-1, k, j) CALL PUSHREAL8(qim1) qim1 = w(i-2, k, j) CALL PUSHREAL8(qim2) qim2 = w(i-3, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = w(i-2, k, j) CALL PUSHREAL8(qip1) qip1 = w(i-1, k, j) CALL PUSHREAL8(qi) qi = w(i, k, j) CALL PUSHREAL8(qim1) qim1 = w(i+1, k, j) CALL PUSHREAL8(qim2) qim2 = w(i+2, k, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO ! fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & ! w(i-1,k,j), w(i ,k,j), & ! w(i+1,k,j), w(i+2,k,j), & ! vel ) k = ktf + 1 DO i=i_start_f,i_end_f CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) IF (vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = w(i+1, k, j) CALL PUSHREAL8(qip1) qip1 = w(i, k, j) CALL PUSHREAL8(qi) qi = w(i-1, k, j) CALL PUSHREAL8(qim1) qim1 = w(i-2, k, j) CALL PUSHREAL8(qim2) qim2 = w(i-3, k, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = w(i-2, k, j) CALL PUSHREAL8(qip1) qip1 = w(i-1, k, j) CALL PUSHREAL8(qi) qi = w(i, k, j) CALL PUSHREAL8(qim1) qim1 = w(i+1, k, j) CALL PUSHREAL8(qim2) qim2 = w(i+2, k, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi)& & **2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi)& & **2 END DO ! fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), & ! w(i-1,k,j), w(i ,k,j), & ! w(i+1,k,j), w(i+2,k,j), & ! vel ) ! lower order fluxes close to boundaries (if not periodic or symmetric) IF (degrade_xs) THEN ad_from13 = i_start DO i=ad_from13,i_start_f-1 IF (i .EQ. ids + 1) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ids + 2) THEN CALL PUSHINTEGER4(k) ! third order DO k=kts+1,ktf CALL PUSHREAL8(vel) END DO k = ktf + 1 CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(ad_from13) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (degrade_xe) THEN DO i=i_end_f+1,i_end+1 IF (i .EQ. ide - 1) THEN CALL PUSHINTEGER4(k) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (i .EQ. ide - 2) THEN CALL PUSHINTEGER4(k) ! third order flux one in from the boundary DO k=kts+1,ktf CALL PUSHREAL8(vel) END DO k = ktf + 1 CALL PUSHREAL8(vel) vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF CALL PUSHINTEGER4(k) ! x flux-divergence into tendency DO k=kts+1,ktf+1 ad_from14 = i_start i = i_end + 1 CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from14) END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from15) ! pick up the the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. ! first, set to index ranges i_start = its IF (ite .GT. ide - 1) THEN i_end = ide - 1 ELSE i_end = ite END IF j_start = jts IF (jte .GT. jde - 1) THEN j_end = jde - 1 ELSE j_end = jte END IF IF (config_flags%open_xs .AND. its .EQ. ids) THEN ad_from16 = j_start DO j=ad_from16,j_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its& & , k-1, j)+ru(its+1, k-1, j))) IF (uw .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from16) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from17 = j_start DO j=ad_from17,j_end uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-& & 1)*(ru(its, k-2, j)+ru(its+1, k-2, j))) IF (uw .GT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from17) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_xe .AND. ite .EQ. ide) THEN ad_from18 = j_start DO j=ad_from18,j_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-& & 1, k-1, j)+ru(ite, k-1, j))) IF (uw .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from18) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from19 = j_start DO j=ad_from19,j_end uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-& & 1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j))) IF (uw .LT. 0.) THEN CALL PUSHREAL8(ub) ub = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(ub) ub = uw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(j - 1) CALL PUSHINTEGER4(ad_from19) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ys .AND. jts .EQ. jds) THEN ad_from20 = i_start DO i=ad_from20,i_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k& & -1, jts)+rv(i, k-1, jts+1))) IF (vw .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from20) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from21 = i_start DO i=ad_from21,i_end vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-& & 1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1))) IF (vw .GT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from21) CALL PUSHCONTROL1B(0) ELSE CALL PUSHCONTROL1B(1) END IF IF (config_flags%open_ye .AND. jte .EQ. jde) THEN ad_from22 = i_start DO i=ad_from22,i_end CALL PUSHINTEGER4(k) DO k=kts+1,ktf vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k& & -1, jte-1)+rv(i, k-1, jte))) IF (vw .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from22) CALL PUSHINTEGER4(k) k = ktf + 1 ad_from23 = i_start DO i=ad_from23,i_end vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-& & 1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte))) IF (vw .LT. 0.) THEN CALL PUSHREAL8(vb) vb = 0. CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(vb) vb = vw CALL PUSHCONTROL1B(1) END IF END DO CALL PUSHINTEGER4(i - 1) CALL PUSHINTEGER4(ad_from23) CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF !-------------------- vertical advection ! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my) ! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my) ! Therefore we don't need to make a correction for advect_w i_start = its IF (ite .GT. ide - 1) THEN CALL PUSHINTEGER4(i_end) i_end = ide - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(i_end) i_end = ite CALL PUSHCONTROL1B(1) END IF j_start = jts IF (jte .GT. jde - 1) THEN CALL PUSHINTEGER4(j_end) j_end = jde - 1 CALL PUSHCONTROL1B(0) ELSE CALL PUSHINTEGER4(j_end) j_end = jte CALL PUSHCONTROL1B(1) END IF ! vert_order_test : IF (vert_order == 6) THEN ! ELSE IF (vert_order == 5) THEN DO j=j_start,j_end CALL PUSHINTEGER4(k) DO k=kts+3,ktf-1 DO i=i_start,i_end CALL PUSHREAL8(vel) vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) IF (-vel*sign(1,time_step) .GE. 0.0) THEN CALL PUSHREAL8(qip2) qip2 = w(i, k+1, j) CALL PUSHREAL8(qip1) qip1 = w(i, k, j) CALL PUSHREAL8(qi) qi = w(i, k-1, j) CALL PUSHREAL8(qim1) qim1 = w(i, k-2, j) CALL PUSHREAL8(qim2) qim2 = w(i, k-3, j) CALL PUSHCONTROL1B(0) ELSE CALL PUSHREAL8(qip2) qip2 = w(i, k-2, j) CALL PUSHREAL8(qip1) qip1 = w(i, k-1, j) CALL PUSHREAL8(qi) qi = w(i, k, j) CALL PUSHREAL8(qim1) qim1 = w(i, k+1, j) CALL PUSHREAL8(qim2) qim2 = w(i, k+2, j) CALL PUSHCONTROL1B(1) END IF CALL PUSHREAL8(f0) f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi CALL PUSHREAL8(f1) f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1 CALL PUSHREAL8(f2) f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2 CALL PUSHREAL8(beta0) beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi& & )**2 CALL PUSHREAL8(beta1) beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2 CALL PUSHREAL8(beta2) beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi& & )**2 END DO END DO ! vflux(i,k) = vel*flux5( & ! w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), & ! w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel ) DO i=i_start,i_end CALL PUSHREAL8(vel) END DO CALL PUSHINTEGER4(k) ! pick up flux contribution for w at the lid, wcs. 13 march 2004 k = ktf + 1 END DO vfluxb = 0.0 DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 vfluxb(i, k) = vfluxb(i, k) + rdzu(k-1)*2.*tendencyb(i, k, j) END DO DO k=ktf,kts+1,-1 DO i=i_end,i_start,-1 vfluxb(i, k+1) = vfluxb(i, k+1) - rdzu(k)*tendencyb(i, k, j) vfluxb(i, k) = vfluxb(i, k) + rdzu(k)*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) DO i=i_end,i_start,-1 k = ktf + 1 temp54b = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp54b0 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp54b romb(i, k-1, j) = romb(i, k-1, j) + temp54b wb0(i, k, j) = wb0(i, k, j) + temp54b0 wb0(i, k-1, j) = wb0(i, k-1, j) + temp54b0 vfluxb(i, k) = 0.0 k = ktf vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp50 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, j)& & ) temp53 = SIGN(1., -vel) temp52 = temp53/12.0 temp51 = SIGN(1, time_step) temp50b = vel*vfluxb(i, k) temp50b0 = temp50b/12.0 temp50b1 = temp51*temp52*temp50b velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))/& & 12.0+temp51*(temp52*temp50))*vfluxb(i, k) wb0(i, k, j) = wb0(i, k, j) + 7.*temp50b0 - 3.*temp50b1 wb0(i, k-1, j) = wb0(i, k-1, j) + 3.*temp50b1 + 7.*temp50b0 wb0(i, k+1, j) = wb0(i, k+1, j) + temp50b1 - temp50b0 wb0(i, k-2, j) = wb0(i, k-2, j) - temp50b1 - temp50b0 vfluxb(i, k) = 0.0 romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb k = kts + 2 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp46 = w(i, k+1, j) - w(i, k-2, j) - 3.*(w(i, k, j)-w(i, k-1, j)& & ) temp49 = SIGN(1., -vel) temp48 = temp49/12.0 temp47 = SIGN(1, time_step) temp46b1 = vel*vfluxb(i, k) temp46b2 = temp46b1/12.0 temp46b3 = temp47*temp48*temp46b1 velb = ((7.*(w(i, k, j)+w(i, k-1, j))-w(i, k+1, j)-w(i, k-2, j))/& & 12.0+temp47*(temp48*temp46))*vfluxb(i, k) wb0(i, k, j) = wb0(i, k, j) + 7.*temp46b2 - 3.*temp46b3 wb0(i, k-1, j) = wb0(i, k-1, j) + 3.*temp46b3 + 7.*temp46b2 wb0(i, k+1, j) = wb0(i, k+1, j) + temp46b3 - temp46b2 wb0(i, k-2, j) = wb0(i, k-2, j) - temp46b3 - temp46b2 vfluxb(i, k) = 0.0 CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb k = kts + 1 temp46b4 = 0.25*(w(i, k, j)+w(i, k-1, j))*vfluxb(i, k) temp46b5 = 0.25*(rom(i, k, j)+rom(i, k-1, j))*vfluxb(i, k) romb(i, k, j) = romb(i, k, j) + temp46b4 romb(i, k-1, j) = romb(i, k-1, j) + temp46b4 wb0(i, k, j) = wb0(i, k, j) + temp46b5 wb0(i, k-1, j) = wb0(i, k-1, j) + temp46b5 vfluxb(i, k) = 0.0 END DO DO k=ktf-1,kts+3,-1 DO i=i_end,i_start,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = 0.5*(rom(i, k, j)+rom(i, k-1, j)) temp46b = vel*vfluxb(i, k)/sumwk temp46b0 = (wi0*f0+wi1*f1+wi2*f2)*vfluxb(i, k)/sumwk f0b = wi0*temp46b f1b = wi1*temp46b f2b = wi2*temp46b velb = temp46b0 sumwkb = -(vel*temp46b0/sumwk) wi0b = sumwkb + f0*temp46b wi1b = sumwkb + f1*temp46b wi2b = sumwkb + f2*temp46b vfluxb(i, k) = 0.0 temp45 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp45**2) END IF temp44 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp44**2) END IF temp43 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp43**2) END IF CALL POPREAL8(beta2) temp43b35 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp43b36 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp43b36 - f2b/6. + temp43b35 CALL POPREAL8(beta1) temp43b37 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp43b40 = 2*(qim1-qip1)*beta1b/4. qip1b = temp43b37 - temp43b40 + f1b/3. + 5.*f2b/6. - 4.*& & temp43b36 - 2.*temp43b35 CALL POPREAL8(beta0) temp43b39 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp43b38 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp43b37 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp43b38 + temp43b39 + 3.*temp43b36 + temp43b35 qim1b = temp43b40 - 4.*temp43b38 - 7.*f0b/6. - f1b/6. - 2.*& & temp43b39 + temp43b37 qim2b = f0b/3. + temp43b38 + temp43b39 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) wb0(i, k-3, j) = wb0(i, k-3, j) + qim2b CALL POPREAL8(qim1) wb0(i, k-2, j) = wb0(i, k-2, j) + qim1b CALL POPREAL8(qi) wb0(i, k-1, j) = wb0(i, k-1, j) + qib CALL POPREAL8(qip1) wb0(i, k, j) = wb0(i, k, j) + qip1b CALL POPREAL8(qip2) wb0(i, k+1, j) = wb0(i, k+1, j) + qip2b ELSE CALL POPREAL8(qim2) wb0(i, k+2, j) = wb0(i, k+2, j) + qim2b CALL POPREAL8(qim1) wb0(i, k+1, j) = wb0(i, k+1, j) + qim1b CALL POPREAL8(qi) wb0(i, k, j) = wb0(i, k, j) + qib CALL POPREAL8(qip1) wb0(i, k-1, j) = wb0(i, k-1, j) + qip1b CALL POPREAL8(qip2) wb0(i, k-2, j) = wb0(i, k-2, j) + qip2b END IF CALL POPREAL8(vel) romb(i, k, j) = romb(i, k, j) + 0.5*velb romb(i, k-1, j) = romb(i, k-1, j) + 0.5*velb END DO END DO CALL POPINTEGER4(k) END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(j_end) ELSE CALL POPINTEGER4(j_end) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(i_end) ELSE CALL POPINTEGER4(i_end) END IF CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_from23) CALL POPINTEGER4(ad_to23) DO i=ad_to23,ad_from23,-1 temp43b31 = -(rdy*tendencyb(i, k, j_end)) temp43b32 = w(i, k, j_end)*temp43b31 temp43b33 = (2.-fzm(k-1))*temp43b32 temp43b34 = -(fzp(k-1)*temp43b32) vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp43b31 w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp43b31 w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp43b31 wb0(i, k, j_end) = wb0(i, k, j_end) + ((2.-fzm(k-1))*(rv(i, k-1, & & jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, jte& & -1)))*temp43b31 rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp43b33 rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - temp43b33 rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp43b34 rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) - temp43b34 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp43b29 = 0.5*(2.-fzm(k-1))*vwb temp43b30 = -(0.5*fzp(k-1)*vwb) rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + temp43b29 rvb(i, k-1, jte) = rvb(i, k-1, jte) + temp43b29 rvb(i, k-2, jte-1) = rvb(i, k-2, jte-1) + temp43b30 rvb(i, k-2, jte) = rvb(i, k-2, jte) + temp43b30 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from22) CALL POPINTEGER4(ad_to22) DO i=ad_to22,ad_from22,-1 DO k=ktf,kts+1,-1 temp43b27 = -(rdy*tendencyb(i, k, j_end)) temp43b28 = w(i, k, j_end)*temp43b27 vbb = (w_old(i, k, j_end)-w_old(i, k, j_end-1))*temp43b27 w_oldb(i, k, j_end) = w_oldb(i, k, j_end) + vb*temp43b27 w_oldb(i, k, j_end-1) = w_oldb(i, k, j_end-1) - vb*temp43b27 wb0(i, k, j_end) = wb0(i, k, j_end) + (fzm(k)*(rv(i, k, jte)-rv(& & i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte-1)))*& & temp43b27 rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp43b28 rvb(i, k, jte-1) = rvb(i, k, jte-1) - fzm(k)*temp43b28 rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp43b28 rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) - fzp(k)*temp43b28 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp43b26 = 0.5*vwb rvb(i, k, jte-1) = rvb(i, k, jte-1) + fzm(k)*temp43b26 rvb(i, k, jte) = rvb(i, k, jte) + fzm(k)*temp43b26 rvb(i, k-1, jte-1) = rvb(i, k-1, jte-1) + fzp(k)*temp43b26 rvb(i, k-1, jte) = rvb(i, k-1, jte) + fzp(k)*temp43b26 END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from21) CALL POPINTEGER4(ad_to21) DO i=ad_to21,ad_from21,-1 temp43b22 = -(rdy*tendencyb(i, k, jts)) temp43b23 = w(i, k, jts)*temp43b22 temp43b24 = (2.-fzm(k-1))*temp43b23 temp43b25 = -(fzp(k-1)*temp43b23) vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp43b22 w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp43b22 w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp43b22 wb0(i, k, jts) = wb0(i, k, jts) + ((2.-fzm(k-1))*(rv(i, k-1, jts+1& & )-rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))& & *temp43b22 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp43b24 rvb(i, k-1, jts) = rvb(i, k-1, jts) - temp43b24 rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp43b25 rvb(i, k-2, jts) = rvb(i, k-2, jts) - temp43b25 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp43b20 = 0.5*(2.-fzm(k-1))*vwb temp43b21 = -(0.5*fzp(k-1)*vwb) rvb(i, k-1, jts) = rvb(i, k-1, jts) + temp43b20 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + temp43b20 rvb(i, k-2, jts) = rvb(i, k-2, jts) + temp43b21 rvb(i, k-2, jts+1) = rvb(i, k-2, jts+1) + temp43b21 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from20) CALL POPINTEGER4(ad_to20) DO i=ad_to20,ad_from20,-1 DO k=ktf,kts+1,-1 temp43b18 = -(rdy*tendencyb(i, k, jts)) temp43b19 = w(i, k, jts)*temp43b18 vbb = (w_old(i, k, jts+1)-w_old(i, k, jts))*temp43b18 w_oldb(i, k, jts+1) = w_oldb(i, k, jts+1) + vb*temp43b18 w_oldb(i, k, jts) = w_oldb(i, k, jts) - vb*temp43b18 wb0(i, k, jts) = wb0(i, k, jts) + (fzm(k)*(rv(i, k, jts+1)-rv(i& & , k, jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))*& & temp43b18 rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp43b19 rvb(i, k, jts) = rvb(i, k, jts) - fzm(k)*temp43b19 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp43b19 rvb(i, k-1, jts) = rvb(i, k-1, jts) - fzp(k)*temp43b19 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(vb) vwb = 0.0 ELSE CALL POPREAL8(vb) vwb = vbb END IF temp43b17 = 0.5*vwb rvb(i, k, jts) = rvb(i, k, jts) + fzm(k)*temp43b17 rvb(i, k, jts+1) = rvb(i, k, jts+1) + fzm(k)*temp43b17 rvb(i, k-1, jts) = rvb(i, k-1, jts) + fzp(k)*temp43b17 rvb(i, k-1, jts+1) = rvb(i, k-1, jts+1) + fzp(k)*temp43b17 END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from19) CALL POPINTEGER4(ad_to19) DO j=ad_to19,ad_from19,-1 temp43b13 = -(rdx*tendencyb(i_end, k, j)) temp43b14 = w(i_end, k, j)*temp43b13 temp43b15 = (2.-fzm(k-1))*temp43b14 temp43b16 = -(fzp(k-1)*temp43b14) ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp43b13 w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp43b13 w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp43b13 wb0(i_end, k, j) = wb0(i_end, k, j) + ((2.-fzm(k-1))*(ru(ite, k-1& & , j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-2& & , j)))*temp43b13 rub(ite, k-1, j) = rub(ite, k-1, j) + temp43b15 rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - temp43b15 rub(ite, k-2, j) = rub(ite, k-2, j) + temp43b16 rub(ite-1, k-2, j) = rub(ite-1, k-2, j) - temp43b16 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp43b11 = 0.5*(2.-fzm(k-1))*uwb temp43b12 = -(0.5*fzp(k-1)*uwb) rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + temp43b11 rub(ite, k-1, j) = rub(ite, k-1, j) + temp43b11 rub(ite-1, k-2, j) = rub(ite-1, k-2, j) + temp43b12 rub(ite, k-2, j) = rub(ite, k-2, j) + temp43b12 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from18) CALL POPINTEGER4(ad_to18) DO j=ad_to18,ad_from18,-1 DO k=ktf,kts+1,-1 temp43b9 = -(rdx*tendencyb(i_end, k, j)) temp43b10 = w(i_end, k, j)*temp43b9 ubb = (w_old(i_end, k, j)-w_old(i_end-1, k, j))*temp43b9 w_oldb(i_end, k, j) = w_oldb(i_end, k, j) + ub*temp43b9 w_oldb(i_end-1, k, j) = w_oldb(i_end-1, k, j) - ub*temp43b9 wb0(i_end, k, j) = wb0(i_end, k, j) + (fzm(k)*(ru(ite, k, j)-ru(& & ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j)))*& & temp43b9 rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp43b10 rub(ite-1, k, j) = rub(ite-1, k, j) - fzm(k)*temp43b10 rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp43b10 rub(ite-1, k-1, j) = rub(ite-1, k-1, j) - fzp(k)*temp43b10 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp43b8 = 0.5*uwb rub(ite-1, k, j) = rub(ite-1, k, j) + fzm(k)*temp43b8 rub(ite, k, j) = rub(ite, k, j) + fzm(k)*temp43b8 rub(ite-1, k-1, j) = rub(ite-1, k-1, j) + fzp(k)*temp43b8 rub(ite, k-1, j) = rub(ite, k-1, j) + fzp(k)*temp43b8 END DO CALL POPINTEGER4(k) END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from17) CALL POPINTEGER4(ad_to17) DO j=ad_to17,ad_from17,-1 temp43b4 = -(rdx*tendencyb(its, k, j)) temp43b5 = w(its, k, j)*temp43b4 temp43b6 = (2.-fzm(k-1))*temp43b5 temp43b7 = -(fzp(k-1)*temp43b5) ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp43b4 w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp43b4 w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp43b4 wb0(its, k, j) = wb0(its, k, j) + ((2.-fzm(k-1))*(ru(its+1, k-1, j& & )-ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))& & *temp43b4 rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp43b6 rub(its, k-1, j) = rub(its, k-1, j) - temp43b6 rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp43b7 rub(its, k-2, j) = rub(its, k-2, j) - temp43b7 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp43b2 = 0.5*(2.-fzm(k-1))*uwb temp43b3 = -(0.5*fzp(k-1)*uwb) rub(its, k-1, j) = rub(its, k-1, j) + temp43b2 rub(its+1, k-1, j) = rub(its+1, k-1, j) + temp43b2 rub(its, k-2, j) = rub(its, k-2, j) + temp43b3 rub(its+1, k-2, j) = rub(its+1, k-2, j) + temp43b3 END DO CALL POPINTEGER4(k) CALL POPINTEGER4(ad_from16) CALL POPINTEGER4(ad_to16) DO j=ad_to16,ad_from16,-1 DO k=ktf,kts+1,-1 temp43b0 = -(rdx*tendencyb(its, k, j)) temp43b1 = w(its, k, j)*temp43b0 ubb = (w_old(its+1, k, j)-w_old(its, k, j))*temp43b0 w_oldb(its+1, k, j) = w_oldb(its+1, k, j) + ub*temp43b0 w_oldb(its, k, j) = w_oldb(its, k, j) - ub*temp43b0 wb0(its, k, j) = wb0(its, k, j) + (fzm(k)*(ru(its+1, k, j)-ru(& & its, k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))*& & temp43b0 rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp43b1 rub(its, k, j) = rub(its, k, j) - fzm(k)*temp43b1 rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp43b1 rub(its, k-1, j) = rub(its, k-1, j) - fzp(k)*temp43b1 CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(ub) uwb = 0.0 ELSE CALL POPREAL8(ub) uwb = ubb END IF temp43b = 0.5*uwb rub(its, k, j) = rub(its, k, j) + fzm(k)*temp43b rub(its+1, k, j) = rub(its+1, k, j) + fzm(k)*temp43b rub(its, k-1, j) = rub(its, k-1, j) + fzp(k)*temp43b rub(its+1, k-1, j) = rub(its+1, k-1, j) + fzp(k)*temp43b END DO CALL POPINTEGER4(k) END DO END IF fqxb = 0.0 CALL POPINTEGER4(ad_from15) CALL POPINTEGER4(ad_to15) DO j=ad_to15,ad_from15,-1 DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from14) CALL POPINTEGER4(ad_to14) DO i=ad_to14,ad_from14,-1 mrdx = msftx(i, j)*rdx fqxb(i+1, k) = fqxb(i+1, k) - mrdx*tendencyb(i, k, j) fqxb(i, k) = fqxb(i, k) + mrdx*tendencyb(i, k, j) END DO END DO CALL POPINTEGER4(k) CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN CALL POPINTEGER4(ad_to13) DO i=ad_to13,i_end_f+1,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp39 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1, k& & , j)) temp42 = SIGN(1., vel) temp41 = temp42/12.0 temp40 = SIGN(1, time_step) temp39b = vel*fqxb(i, k) temp39b0 = temp39b/12.0 temp39b1 = temp40*temp41*temp39b velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j& & ))/12.0+temp40*(temp41*temp39))*fqxb(i, k) wb0(i, k, j) = wb0(i, k, j) + 7.*temp39b0 - 3.*temp39b1 wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp39b1 + 7.*temp39b0 wb0(i+1, k, j) = wb0(i+1, k, j) + temp39b1 - temp39b0 wb0(i-2, k, j) = wb0(i-2, k, j) - temp39b1 - temp39b0 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb DO k=ktf,kts+1,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp35 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1& & , k, j)) temp38 = SIGN(1., vel) temp37 = temp38/12.0 temp36 = SIGN(1, time_step) temp35b3 = vel*fqxb(i, k) temp35b4 = temp35b3/12.0 temp35b5 = temp36*temp37*temp35b3 velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))/12.0+temp36*(temp37*temp35))*fqxb(i, k) wb0(i, k, j) = wb0(i, k, j) + 7.*temp35b4 - 3.*temp35b5 wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp35b5 + 7.*temp35b4 wb0(i+1, k, j) = wb0(i+1, k, j) + temp35b5 - temp35b4 wb0(i-2, k, j) = wb0(i-2, k, j) - temp35b5 - temp35b4 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp35b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp35b2 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2& & , j))*fqxb(i, k) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp35b1 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp35b1 wb0(i, k, j) = wb0(i, k, j) + temp35b2 wb0(i-1, k, j) = wb0(i-1, k, j) + temp35b2 fqxb(i, k) = 0.0 DO k=ktf,kts+1,-1 temp35b = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp35b0 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*& & fqxb(i, k) rub(i, k, j) = rub(i, k, j) + fzm(k)*temp35b rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp35b wb0(i, k, j) = wb0(i, k, j) + temp35b0 wb0(i-1, k, j) = wb0(i-1, k, j) + temp35b0 fqxb(i, k) = 0.0 END DO CALL POPINTEGER4(k) END IF END DO END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from13) DO i=i_start_f-1,ad_from13,-1 CALL POPCONTROL1B(branch) IF (branch .NE. 0) THEN k = ktf + 1 temp31 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1, k& & , j)) temp34 = SIGN(1., vel) temp33 = temp34/12.0 temp32 = SIGN(1, time_step) temp31b = vel*fqxb(i, k) temp31b0 = temp31b/12.0 temp31b1 = temp32*temp33*temp31b velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k, j& & ))/12.0+temp32*(temp33*temp31))*fqxb(i, k) wb0(i, k, j) = wb0(i, k, j) + 7.*temp31b0 - 3.*temp31b1 wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp31b1 + 7.*temp31b0 wb0(i+1, k, j) = wb0(i+1, k, j) + temp31b1 - temp31b0 wb0(i-2, k, j) = wb0(i-2, k, j) - temp31b1 - temp31b0 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb DO k=ktf,kts+1,-1 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp27 = w(i+1, k, j) - w(i-2, k, j) - 3.*(w(i, k, j)-w(i-1& & , k, j)) temp30 = SIGN(1., vel) temp29 = temp30/12.0 temp28 = SIGN(1, time_step) temp27b5 = vel*fqxb(i, k) temp27b6 = temp27b5/12.0 temp27b7 = temp28*temp29*temp27b5 velb = ((7.*(w(i, k, j)+w(i-1, k, j))-w(i+1, k, j)-w(i-2, k& & , j))/12.0+temp28*(temp29*temp27))*fqxb(i, k) wb0(i, k, j) = wb0(i, k, j) + 7.*temp27b6 - 3.*temp27b7 wb0(i-1, k, j) = wb0(i-1, k, j) + 3.*temp27b7 + 7.*temp27b6 wb0(i+1, k, j) = wb0(i+1, k, j) + temp27b7 - temp27b6 wb0(i-2, k, j) = wb0(i-2, k, j) - temp27b7 - temp27b6 fqxb(i, k) = 0.0 CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN k = ktf + 1 temp27b3 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp27b4 = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2& & , j))*fqxb(i, k) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*temp27b3 rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*temp27b3 wb0(i, k, j) = wb0(i, k, j) + temp27b4 wb0(i-1, k, j) = wb0(i-1, k, j) + temp27b4 fqxb(i, k) = 0.0 DO k=ktf,kts+1,-1 temp27b1 = 0.5*(w(i, k, j)+w(i-1, k, j))*fqxb(i, k) temp27b2 = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*& & fqxb(i, k) rub(i, k, j) = rub(i, k, j) + fzm(k)*temp27b1 rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*temp27b1 wb0(i, k, j) = wb0(i, k, j) + temp27b2 wb0(i-1, k, j) = wb0(i-1, k, j) + temp27b2 fqxb(i, k) = 0.0 END DO CALL POPINTEGER4(k) END IF END DO END IF k = ktf + 1 DO i=i_end_f,i_start_f,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 temp27b = vel*fqxb(i, k)/sumwk temp27b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk f0b = wi0*temp27b f1b = wi1*temp27b f2b = wi2*temp27b velb = temp27b0 sumwkb = -(vel*temp27b0/sumwk) wi0b = sumwkb + f0*temp27b wi1b = sumwkb + f1*temp27b wi2b = sumwkb + f2*temp27b fqxb(i, k) = 0.0 temp26 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw))& & ) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp26**2) END IF temp25 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw))& & ) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp25**2) END IF temp24 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw))& & ) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp24**2) END IF CALL POPREAL8(beta2) temp24b1 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp24b2 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp24b2 - f2b/6. + temp24b1 CALL POPREAL8(beta1) temp24b3 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp24b6 = 2*(qim1-qip1)*beta1b/4. qip1b = temp24b3 - temp24b6 + f1b/3. + 5.*f2b/6. - 4.*temp24b2 - & & 2.*temp24b1 CALL POPREAL8(beta0) temp24b5 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp24b4 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp24b3 + 11.*f0b/6. + 5.*f1b/6. + 3.*temp24b4 & & + temp24b5 + 3.*temp24b2 + temp24b1 qim1b = temp24b6 - 4.*temp24b4 - 7.*f0b/6. - f1b/6. - 2.*temp24b5 & & + temp24b3 qim2b = f0b/3. + temp24b4 + temp24b5 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) wb0(i-3, k, j) = wb0(i-3, k, j) + qim2b CALL POPREAL8(qim1) wb0(i-2, k, j) = wb0(i-2, k, j) + qim1b CALL POPREAL8(qi) wb0(i-1, k, j) = wb0(i-1, k, j) + qib CALL POPREAL8(qip1) wb0(i, k, j) = wb0(i, k, j) + qip1b CALL POPREAL8(qip2) wb0(i+1, k, j) = wb0(i+1, k, j) + qip2b ELSE CALL POPREAL8(qim2) wb0(i+2, k, j) = wb0(i+2, k, j) + qim2b CALL POPREAL8(qim1) wb0(i+1, k, j) = wb0(i+1, k, j) + qim1b CALL POPREAL8(qi) wb0(i, k, j) = wb0(i, k, j) + qib CALL POPREAL8(qip1) wb0(i-1, k, j) = wb0(i-1, k, j) + qip1b CALL POPREAL8(qip2) wb0(i-2, k, j) = wb0(i-2, k, j) + qip2b END IF CALL POPREAL8(vel) rub(i, k-1, j) = rub(i, k-1, j) + (2.-fzm(k-1))*velb rub(i, k-2, j) = rub(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 DO i=i_end_f,i_start_f,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j) temp24b = vel*fqxb(i, k)/sumwk temp24b0 = (wi0*f0+wi1*f1+wi2*f2)*fqxb(i, k)/sumwk f0b = wi0*temp24b f1b = wi1*temp24b f2b = wi2*temp24b velb = temp24b0 sumwkb = -(vel*temp24b0/sumwk) wi0b = sumwkb + f0*temp24b wi1b = sumwkb + f1*temp24b wi2b = sumwkb + f2*temp24b fqxb(i, k) = 0.0 temp23 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp23**2) END IF temp22 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp22**2) END IF temp21 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(pw)& & )) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp21**2) END IF CALL POPREAL8(beta2) temp21b = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp21b0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp21b0 - f2b/6. + temp21b CALL POPREAL8(beta1) temp21b1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp21b4 = 2*(qim1-qip1)*beta1b/4. qip1b = temp21b1 - temp21b4 + f1b/3. + 5.*f2b/6. - 4.*temp21b0 -& & 2.*temp21b CALL POPREAL8(beta0) temp21b3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp21b2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp21b1 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp21b2 + temp21b3 + 3.*temp21b0 + temp21b qim1b = temp21b4 - 4.*temp21b2 - 7.*f0b/6. - f1b/6. - 2.*& & temp21b3 + temp21b1 qim2b = f0b/3. + temp21b2 + temp21b3 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) wb0(i-3, k, j) = wb0(i-3, k, j) + qim2b CALL POPREAL8(qim1) wb0(i-2, k, j) = wb0(i-2, k, j) + qim1b CALL POPREAL8(qi) wb0(i-1, k, j) = wb0(i-1, k, j) + qib CALL POPREAL8(qip1) wb0(i, k, j) = wb0(i, k, j) + qip1b CALL POPREAL8(qip2) wb0(i+1, k, j) = wb0(i+1, k, j) + qip2b ELSE CALL POPREAL8(qim2) wb0(i+2, k, j) = wb0(i+2, k, j) + qim2b CALL POPREAL8(qim1) wb0(i+1, k, j) = wb0(i+1, k, j) + qim1b CALL POPREAL8(qi) wb0(i, k, j) = wb0(i, k, j) + qib CALL POPREAL8(qip1) wb0(i-1, k, j) = wb0(i-1, k, j) + qip1b CALL POPREAL8(qip2) wb0(i-2, k, j) = wb0(i-2, k, j) + qip2b END IF CALL POPREAL8(vel) rub(i, k, j) = rub(i, k, j) + fzm(k)*velb rub(i, k-1, j) = rub(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END DO fqyb = 0.0 CALL POPINTEGER4(ad_from12) CALL POPINTEGER4(ad_to12) DO j=ad_to12,ad_from12,-1 CALL POPINTEGER4(jp0) CALL POPINTEGER4(jp1) CALL POPCONTROL2B(branch) IF (branch .LT. 2) THEN IF (branch .EQ. 0) THEN DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from9) CALL POPINTEGER4(ad_to9) DO i=ad_to9,ad_from9,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1& & ) END DO END DO CALL POPINTEGER4(k) ELSE DO k=ktf,kts,-1 CALL POPINTEGER4(ad_from10) CALL POPINTEGER4(ad_to10) DO i=ad_to10,ad_from10,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1& & ) END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 2) THEN DO k=ktf+1,kts+1,-1 CALL POPINTEGER4(ad_from11) CALL POPINTEGER4(ad_to11) DO i=ad_to11,ad_from11,-1 mrdy = msftx(i, j-1)*rdy fqyb(i, k, jp1) = fqyb(i, k, jp1) - mrdy*tendencyb(i, k, j-1) fqyb(i, k, jp0) = fqyb(i, k, jp0) + mrdy*tendencyb(i, k, j-1) END DO END DO CALL POPINTEGER4(k) END IF CALL POPCONTROL3B(branch) IF (branch .LT. 3) THEN IF (branch .EQ. 0) THEN CALL POPINTEGER4(ad_from0) CALL POPINTEGER4(ad_to0) DO i=ad_to0,ad_from0,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 temp5b = vel*fqyb(i, k, jp1)/sumwk temp5b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk f0b = wi0*temp5b f1b = wi1*temp5b f2b = wi2*temp5b velb = temp5b0 sumwkb = -(vel*temp5b0/sumwk) wi0b = sumwkb + f0*temp5b wi1b = sumwkb + f1*temp5b wi2b = sumwkb + f2*temp5b fqyb(i, k, jp1) = 0.0 temp4 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp4**2) END IF temp3 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp3**2) END IF temp2 = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT(& & pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp2**2) END IF CALL POPREAL8(beta2) temp2b1 = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. temp2b2 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = temp2b2 - f2b/6. + temp2b1 CALL POPREAL8(beta1) temp2b3 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. temp2b6 = 2*(qim1-qip1)*beta1b/4. qip1b = temp2b3 - temp2b6 + f1b/3. + 5.*f2b/6. - 4.*temp2b2 - & & 2.*temp2b1 CALL POPREAL8(beta0) temp2b5 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. temp2b4 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*temp2b3 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & temp2b4 + temp2b5 + 3.*temp2b2 + temp2b1 qim1b = temp2b6 - 4.*temp2b4 - 7.*f0b/6. - f1b/6. - 2.*temp2b5& & + temp2b3 qim2b = f0b/3. + temp2b4 + temp2b5 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) wb0(i, k, j-3) = wb0(i, k, j-3) + qim2b CALL POPREAL8(qim1) wb0(i, k, j-2) = wb0(i, k, j-2) + qim1b CALL POPREAL8(qi) wb0(i, k, j-1) = wb0(i, k, j-1) + qib CALL POPREAL8(qip1) wb0(i, k, j) = wb0(i, k, j) + qip1b CALL POPREAL8(qip2) wb0(i, k, j+1) = wb0(i, k, j+1) + qip2b ELSE CALL POPREAL8(qim2) wb0(i, k, j+2) = wb0(i, k, j+2) + qim2b CALL POPREAL8(qim1) wb0(i, k, j+1) = wb0(i, k, j+1) + qim1b CALL POPREAL8(qi) wb0(i, k, j) = wb0(i, k, j) + qib CALL POPREAL8(qip1) wb0(i, k, j-1) = wb0(i, k, j-1) + qip1b CALL POPREAL8(qip2) wb0(i, k, j-2) = wb0(i, k, j-2) + qip2b END IF CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from) CALL POPINTEGER4(ad_to) DO i=ad_to,ad_from,-1 wi0 = gi0/(eps+beta0)**pw wi1 = gi1/(eps+beta1)**pw wi2 = gi2/(eps+beta2)**pw sumwk = wi0 + wi1 + wi2 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp2b = vel*fqyb(i, k, jp1)/sumwk temp2b0 = (wi0*f0+wi1*f1+wi2*f2)*fqyb(i, k, jp1)/sumwk f0b = wi0*temp2b f1b = wi1*temp2b f2b = wi2*temp2b velb = temp2b0 sumwkb = -(vel*temp2b0/sumwk) wi0b = sumwkb + f0*temp2b wi1b = sumwkb + f1*temp2b wi2b = sumwkb + f2*temp2b fqyb(i, k, jp1) = 0.0 temp1 = (eps+beta2)**pw IF (eps + beta2 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta2b = 0.0 ELSE beta2b = -(gi2*pw*(eps+beta2)**(pw-1)*wi2b/temp1**2) END IF temp0 = (eps+beta1)**pw IF (eps + beta1 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta1b = 0.0 ELSE beta1b = -(gi1*pw*(eps+beta1)**(pw-1)*wi1b/temp0**2) END IF temp = (eps+beta0)**pw IF (eps + beta0 .LE. 0.0 .AND. (pw .EQ. 0.0 .OR. pw .NE. INT& & (pw))) THEN beta0b = 0.0 ELSE beta0b = -(gi0*pw*(eps+beta0)**(pw-1)*wi0b/temp**2) END IF CALL POPREAL8(beta2) tempb = 13.*2*(qi-2.*qip1+qip2)*beta2b/12. tempb0 = 2*(qip2-4.*qip1+3.*qi)*beta2b/4. qip2b = tempb0 - f2b/6. + tempb CALL POPREAL8(beta1) tempb1 = 13.*2*(qim1-2.*qi+qip1)*beta1b/12. tempb4 = 2*(qim1-qip1)*beta1b/4. qip1b = tempb1 - tempb4 + f1b/3. + 5.*f2b/6. - 4.*tempb0 - & & 2.*tempb CALL POPREAL8(beta0) tempb3 = 13.*2*(qim2-2.*qim1+qi)*beta0b/12. tempb2 = 2*(qim2-4.*qim1+3.*qi)*beta0b/4. qib = f2b/3. - 2.*tempb1 + 11.*f0b/6. + 5.*f1b/6. + 3.*& & tempb2 + tempb3 + 3.*tempb0 + tempb qim1b = tempb4 - 4.*tempb2 - 7.*f0b/6. - f1b/6. - 2.*tempb3 & & + tempb1 qim2b = f0b/3. + tempb2 + tempb3 CALL POPREAL8(f2) CALL POPREAL8(f1) CALL POPREAL8(f0) CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN CALL POPREAL8(qim2) wb0(i, k, j-3) = wb0(i, k, j-3) + qim2b CALL POPREAL8(qim1) wb0(i, k, j-2) = wb0(i, k, j-2) + qim1b CALL POPREAL8(qi) wb0(i, k, j-1) = wb0(i, k, j-1) + qib CALL POPREAL8(qip1) wb0(i, k, j) = wb0(i, k, j) + qip1b CALL POPREAL8(qip2) wb0(i, k, j+1) = wb0(i, k, j+1) + qip2b ELSE CALL POPREAL8(qim2) wb0(i, k, j+2) = wb0(i, k, j+2) + qim2b CALL POPREAL8(qim1) wb0(i, k, j+1) = wb0(i, k, j+1) + qim1b CALL POPREAL8(qi) wb0(i, k, j) = wb0(i, k, j) + qib CALL POPREAL8(qip1) wb0(i, k, j-1) = wb0(i, k, j-1) + qip1b CALL POPREAL8(qip2) wb0(i, k, j-2) = wb0(i, k, j-2) + qip2b END IF CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 1) THEN CALL POPINTEGER4(ad_from2) CALL POPINTEGER4(ad_to2) DO i=ad_to2,ad_from2,-1 temp5b3 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp5b4 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2& & , j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp5b3 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp5b3 wb0(i, k, j) = wb0(i, k, j) + temp5b4 wb0(i, k, j-1) = wb0(i, k, j-1) + temp5b4 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from1) CALL POPINTEGER4(ad_to1) DO i=ad_to1,ad_from1,-1 temp5b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp5b2 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*fqyb& & (i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp5b1 rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp5b1 wb0(i, k, j) = wb0(i, k, j) + temp5b2 wb0(i, k, j-1) = wb0(i, k, j-1) + temp5b2 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE CALL POPINTEGER4(ad_from4) CALL POPINTEGER4(ad_to4) DO i=ad_to4,ad_from4,-1 temp9 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, j& & -1)) temp12 = SIGN(1., vel) temp11 = temp12/12.0 temp10 = SIGN(1, time_step) temp9b = vel*fqyb(i, k, jp1) temp9b0 = temp9b/12.0 temp9b1 = temp10*temp11*temp9b velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2& & ))/12.0+temp10*(temp11*temp9))*fqyb(i, k, jp1) wb0(i, k, j) = wb0(i, k, j) + 7.*temp9b0 - 3.*temp9b1 wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp9b1 + 7.*temp9b0 wb0(i, k, j+1) = wb0(i, k, j+1) + temp9b1 - temp9b0 wb0(i, k, j-2) = wb0(i, k, j-2) - temp9b1 - temp9b0 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from3) CALL POPINTEGER4(ad_to3) DO i=ad_to3,ad_from3,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp5 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k& & , j-1)) temp8 = SIGN(1., vel) temp7 = temp8/12.0 temp6 = SIGN(1, time_step) temp5b5 = vel*fqyb(i, k, jp1) temp5b6 = temp5b5/12.0 temp5b7 = temp6*temp7*temp5b5 velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j& & -2))/12.0+temp6*(temp7*temp5))*fqyb(i, k, jp1) wb0(i, k, j) = wb0(i, k, j) + 7.*temp5b6 - 3.*temp5b7 wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp5b7 + 7.*temp5b6 wb0(i, k, j+1) = wb0(i, k, j+1) + temp5b7 - temp5b6 wb0(i, k, j-2) = wb0(i, k, j-2) - temp5b7 - temp5b6 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF ELSE IF (branch .EQ. 3) THEN CALL POPINTEGER4(ad_from6) CALL POPINTEGER4(ad_to6) DO i=ad_to6,ad_from6,-1 temp13b1 = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp13b2 = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, & & j))*fqyb(i, k, jp1) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*temp13b1 rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*temp13b1 wb0(i, k, j) = wb0(i, k, j) + temp13b2 wb0(i, k, j-1) = wb0(i, k, j-1) + temp13b2 fqyb(i, k, jp1) = 0.0 END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from5) CALL POPINTEGER4(ad_to5) DO i=ad_to5,ad_from5,-1 temp13b = 0.5*(w(i, k, j)+w(i, k, j-1))*fqyb(i, k, jp1) temp13b0 = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*fqyb(& & i, k, jp1) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*temp13b rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*temp13b wb0(i, k, j) = wb0(i, k, j) + temp13b0 wb0(i, k, j-1) = wb0(i, k, j-1) + temp13b0 fqyb(i, k, jp1) = 0.0 END DO END DO CALL POPINTEGER4(k) ELSE IF (branch .EQ. 4) THEN CALL POPINTEGER4(ad_from8) CALL POPINTEGER4(ad_to8) DO i=ad_to8,ad_from8,-1 temp17 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, j-& & 1)) temp20 = SIGN(1., vel) temp19 = temp20/12.0 temp18 = SIGN(1, time_step) temp17b = vel*fqyb(i, k, jp1) temp17b0 = temp17b/12.0 temp17b1 = temp18*temp19*temp17b velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2))& & /12.0+temp18*(temp19*temp17))*fqyb(i, k, jp1) wb0(i, k, j) = wb0(i, k, j) + 7.*temp17b0 - 3.*temp17b1 wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp17b1 + 7.*temp17b0 wb0(i, k, j+1) = wb0(i, k, j+1) + temp17b1 - temp17b0 wb0(i, k, j-2) = wb0(i, k, j-2) - temp17b1 - temp17b0 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k-1, j) = rvb(i, k-1, j) + (2.-fzm(k-1))*velb rvb(i, k-2, j) = rvb(i, k-2, j) - fzp(k-1)*velb END DO DO k=ktf,kts+1,-1 CALL POPINTEGER4(ad_from7) CALL POPINTEGER4(ad_to7) DO i=ad_to7,ad_from7,-1 vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j) temp13 = w(i, k, j+1) - w(i, k, j-2) - 3.*(w(i, k, j)-w(i, k, & & j-1)) temp16 = SIGN(1., vel) temp15 = temp16/12.0 temp14 = SIGN(1, time_step) temp13b3 = vel*fqyb(i, k, jp1) temp13b4 = temp13b3/12.0 temp13b5 = temp14*temp15*temp13b3 velb = ((7.*(w(i, k, j)+w(i, k, j-1))-w(i, k, j+1)-w(i, k, j-2& & ))/12.0+temp14*(temp15*temp13))*fqyb(i, k, jp1) wb0(i, k, j) = wb0(i, k, j) + 7.*temp13b4 - 3.*temp13b5 wb0(i, k, j-1) = wb0(i, k, j-1) + 3.*temp13b5 + 7.*temp13b4 wb0(i, k, j+1) = wb0(i, k, j+1) + temp13b5 - temp13b4 wb0(i, k, j-2) = wb0(i, k, j-2) - temp13b5 - temp13b4 fqyb(i, k, jp1) = 0.0 CALL POPREAL8(vel) rvb(i, k, j) = rvb(i, k, j) + fzm(k)*velb rvb(i, k-1, j) = rvb(i, k-1, j) + fzp(k)*velb END DO END DO CALL POPINTEGER4(k) END IF END DO CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) CALL POPCONTROL1B(branch) END SUBROUTINE A_ADVECT_WENO_W END MODULE a_module_advect_em