! ======================================================================================
! This file was generated by the version 4.3.7 of ADG on 08/10/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_diffusion_em
USE a_module_bc, only: a_set_physical_bc3d
USE module_state_description, only: p_m23, p_m13, p_m22, p_m33, p_r23, p_r13, p_r12, p_m12, p_m11
USE module_big_step_utilities_em, only: grid_config_rec_type, param_first_scalar, p_qv, p_qi, p_qc
USE module_model_constants
USE module_diffusion_em ! Added by Ning Pan, 2010-08-10
CONTAINS
SUBROUTINE a_cal_deform_and_div(config_flags,u,a_u,v,a_v,w,a_w,div,a_div, &
defor11,a_defor11,defor22,a_defor22,defor33,a_defor33,defor12,a_defor12, &
defor13,a_defor13,defor23,a_defor23,nba_rij,a_nba_rij,n_nba_rij,u_base,v_base, &
msfux,msfuy,msfvx,msfvy,msftx,msfty,rdx,rdy,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp, &
cf1,cf2,cf3,zx,a_zx,zy,a_zy,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: rdx,rdy,cf1,cf2,cf3
REAL,DIMENSION(kms:kme) :: fnm,fnp,dn,dnw,u_base,v_base
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,a_u,v,a_v,w,a_w,zx,a_zx,zy, &
a_zy,rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor22,a_defor22, &
defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,div,a_div
INTEGER :: n_nba_rij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_rij) :: nba_rij,a_nba_rij
INTEGER :: i,j,k,ktf,ktes1,ktes2,i_start,i_end,j_start,j_end
REAL :: tmp,a_tmp,tmpzx,a_tmpzx,tmpzy,a_tmpzy,tmpzeta_z,a_tmpzeta_z,cft1, &
a_cft1,cft2,a_cft2
REAL,DIMENSION(its:ite,jts:jte) :: mm,a_mm,zzavg,a_zzavg,zeta_zd12,a_zeta_zd12
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: tmp1,a_tmp1,hat,a_hat,hatavg, &
a_hatavg
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb5_hatavg
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb12_hatavg
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb35_hatavg
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb40_hatavg
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb60_hatavg
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb2_hat
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb9_hat
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb32_hat
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb37_hat
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb54_hat
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
REAL,DIMENSION(its:ite,jts:jte) :: Keep_Lpb1_mm
REAL,DIMENSION(its:ite,jts:jte) :: Keep_Lpb31_mm
REAL,DIMENSION(its:ite,jts:jte) :: Keep_Lpb53_mm
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb35_tmp1
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb40_tmp1
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb60_tmp1
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb6_tmp1
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: Keep_Lpb13_tmp1
REAL,DIMENSION(max(jds+1,jts):min(jde-1,jte)) :: Keep_Lpb35_tmpzy
REAL,DIMENSION(max(jds+1,jts):min(jde-1,jte)) :: Keep_Lpb40_tmpzx
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007
REAL,DIMENSION(its:max0(min(ite,ide-1),ite)) :: Tmpv200
REAL,DIMENSION(its:max0(min(ite,ide-1),ite)) :: Tmpv201
REAL,DIMENSION(its:max0(min(ite,ide-1),ite,min(ite,ide)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:max0(min(ite,ide-1),ite,min(ite,ide)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:max0(min(ite,ide-1),ite,min(ite,ide)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv302
REAL,DIMENSION(its:ite,kts:min(kte,kde-1)) :: Tmpv303
REAL,DIMENSION(its:max0(ite,min(ite,ide),min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1),max(jds+1,jts):max0(min(jde-1,jte),min(jte,jde))) :: Tmpv400
REAL,DIMENSION(its:max0(ite,min(ite,ide),min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1),max(jds+1,jts):max0(min(jde-1,jte),min(jte,jde))) :: Tmpv401
REAL,DIMENSION(its:max0(ite,min(ite,ide),min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1),max(jds+1,jts):max0(min(jde-1,jte),min(jte,jde))) :: Tmpv402
REAL,DIMENSION(its:max0(min(ite,ide),min(ite,ide-1)),kts+1:min(kte,kde-1) &
,max(jds+1,jts):min(jte,jde)) :: Tmpv403
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktes1 = kte-1
ktes2 = kte-2
cft2 = - 0.5 * dnw(ktes1) / dn(ktes1)
cft1 = 1.0 - cft2
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[1]
DO j = j_start, j_end
DO i = i_start, i_end
mm(i,j) = msftx(i,j) * msfty(i,j)
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
Keep_Lpb1_mm =mm
!LPB[2]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end+1
hat(i,k,j) = u(i,k,j) / msfuy(i,j)
END DO
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
! Keep_Lpb2_hat =hat ! Remarked by Ning Pan, 2010-08-31
!LPB[3]
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
hatavg(i,k,j) = 0.5 * &
( fnm(k) * ( hat(i,k ,j) + hat(i+1, k,j) ) + &
fnp(k) * ( hat(i,k-1,j) + hat(i+1,k-1,j) ) )
END DO
END DO
END DO
!LPB[4]
DO j = j_start, j_end
DO i = i_start, i_end
hatavg(i,1,j) = 0.5 * ( &
cf1 * hat(i ,1,j) + &
cf2 * hat(i ,2,j) + &
cf3 * hat(i ,3,j) + &
cf1 * hat(i+1,1,j) + &
cf2 * hat(i+1,2,j) + &
cf3 * hat(i+1,3,j) )
hatavg(i,kte,j) = 0.5 * ( &
cft1 * ( hat(i,ktes1,j) + hat(i+1,ktes1,j) ) + &
cft2 * ( hat(i,ktes2,j) + hat(i+1,ktes2,j) ) )
END DO
END DO
!LPB[5]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
tmpzx = 0.25 * ( &
zx(i,k ,j) + zx(i+1,k ,j) + &
zx(i,k+1,j) + zx(i+1,k+1,j) )
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Keep_Lpb5_hatavg(i,k,j) =hatavg(i,k+1,j) - hatavg(i,k,j)
tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *tmpzx * rdzw(i,k,j)
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-31 : LPB[6]-[8]
!LPB[6]
! DO j = j_start, j_end
!REVISED! BY WALLS
!! DO k=kts, min(kte,kde-1)
!! DO i=its, min(ite,ide-1)
! DO k=kts, ktf
! DO i=i_start, i_end
! Keep_Lpb6_tmp1(i,k,j) =tmp1(i,k,j)
! END DO
! END DO
! DO k = kts, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = mm(i,j) * ( rdx * ( hat(i+1,k,j) - hat(i,k,j) ) - &
! tmp1(i,k,j))
! END DO
! END DO
! END DO
!LPB[7]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! defor11(i,k,j) = 2.0 * tmp1(i,k,j)
! END DO
! END DO
! END DO
!LPB[8]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! div(i,k,j) = tmp1(i,k,j)
! END DO
! END DO
! END DO
!LPB[9]
DO j = j_start, j_end+1
DO k = kts, ktf
DO i = i_start, i_end
IF ((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
hat(i,k,j) = 0.
ELSE
hat(i,k,j) = v(i,k,j) / msfvx(i,j)
ENDIF
END DO
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
! Keep_Lpb9_hat =hat ! Remarked by Ning Pan, 2010-08-31
!LPB[10]
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
hatavg(i,k,j) = 0.5 * ( &
fnm(k) * ( hat(i,k ,j) + hat(i,k ,j+1) ) + &
fnp(k) * ( hat(i,k-1,j) + hat(i,k-1,j+1) ) )
END DO
END DO
END DO
!LPB[11]
DO j = j_start, j_end
DO i = i_start, i_end
hatavg(i,1,j) = 0.5 * ( &
cf1 * hat(i,1,j ) + &
cf2 * hat(i,2,j ) + &
cf3 * hat(i,3,j ) + &
cf1 * hat(i,1,j+1) + &
cf2 * hat(i,2,j+1) + &
cf3 * hat(i,3,j+1) )
hatavg(i,kte,j) = 0.5 * ( &
cft1 * ( hat(i,ktes1,j) + hat(i,ktes1,j+1) ) + &
cft2 * ( hat(i,ktes2,j) + hat(i,ktes2,j+1) ) )
END DO
END DO
!LPB[12]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
tmpzy = 0.25 * ( &
zy(i,k ,j) + zy(i,k ,j+1) + &
zy(i,k+1,j) + zy(i,k+1,j+1) )
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Keep_Lpb12_hatavg(i,k,j) =hatavg(i,k+1,j) - hatavg(i,k,j)
tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * tmpzy * rdzw(i,k,j)
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-31 : LPB[13]-[18]
!LPB[13]
! DO j = j_start, j_end
! DO k=kts, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! Keep_Lpb13_tmp1(i,k,j) =tmp1(i,k,j)
! END DO
! END DO
! DO k = kts, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = mm(i,j) * ( &
! rdy * ( hat(i,k,j+1) - hat(i,k,j) ) - tmp1(i,k,j) )
! END DO
! END DO
! END DO
!LPB[14]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! defor22(i,k,j) = 2.0 * tmp1(i,k,j)
! END DO
! END DO
! END DO
!LPB[15]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! div(i,k,j) = div(i,k,j) + tmp1(i,k,j)
! END DO
! END DO
! END DO
!LPB[16]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = ( w(i,k+1,j) - w(i,k,j) ) * rdzw(i,k,j)
! END DO
! END DO
! END DO
!LPB[17]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! defor33(i,k,j) = 2.0 * tmp1(i,k,j)
! END DO
! END DO
! END DO
!LPB[18]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! div(i,k,j) = div(i,k,j) + tmp1(i,k,j)
! END DO
! END DO
! END DO
!LPB[19]
i_start = its
i_end = ite
j_start = jts
j_end = jte
!LPB[20]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[21]
!LPB[22]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-1, ite )
!LPB[23]
!LPB[24]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[25]
!LPB[26]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-1, jte )
!LPB[27]
!LPB[28]
IF ( config_flags%periodic_x ) i_start = its
!LPB[29]
!LPB[30]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[31]
DO j = j_start, j_end
DO i = i_start, i_end
mm(i,j) = 0.25 * ( msfux(i,j-1) + msfux(i,j) ) * ( msfvy(i-1,j) + msfvy(i,j) )
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
Keep_Lpb31_mm =mm
!LPB[32]
DO j =j_start-1, j_end
DO k =kts, ktf
DO i =i_start, i_end
hat(i,k,j) = u(i,k,j) / msfux(i,j)
END DO
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
! Keep_Lpb32_hat =hat ! Remarked by Ning Pan, 2010-08-31
!LPB[33]
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
hatavg(i,k,j) = 0.5 * ( &
fnm(k) * ( hat(i,k ,j-1) + hat(i,k ,j) ) + &
fnp(k) * ( hat(i,k-1,j-1) + hat(i,k-1,j) ) )
END DO
END DO
END DO
!LPB[34]
DO j = j_start, j_end
DO i = i_start, i_end
hatavg(i,1,j) = 0.5 * ( &
cf1 * hat(i,1,j-1) + &
cf2 * hat(i,2,j-1) + &
cf3 * hat(i,3,j-1) + &
cf1 * hat(i,1,j ) + &
cf2 * hat(i,2,j ) + &
cf3 * hat(i,3,j ) )
hatavg(i,kte,j) = 0.5 * ( &
cft1 * ( hat(i,ktes1,j-1) + hat(i,ktes1,j) ) + &
cft2 * ( hat(i,ktes2,j-1) + hat(i,ktes2,j) ) )
END DO
END DO
!LPB[35]
DO j = j_start, j_end
! Keep_Lpb35_tmpzy(j) =tmpzy ! Remarked by Ning Pan, 2010-08-31
DO k = kts, ktf
DO i = i_start, i_end
tmpzy = 0.25 * ( &
zy(i-1,k ,j) + zy(i,k ,j) + &
zy(i-1,k+1,j) + zy(i,k+1,j) )
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Keep_Lpb35_hatavg(i,k,j) =hatavg(i,k+1,j) - hatavg(i,k,j)
tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * &
0.25 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) + &
rdzw(i-1,k,j-1) + rdzw(i,k,j-1) )
END DO
END DO
END DO
!BIG ERRORS, ADDED BY WALLS
! Keep_Lpb35_tmp1 =tmp1 ! Remarked by Ning Pan, 2010-08-31
! Remarked by Ning Pan, 2010-08-31 : LPB[36]
!LPB[36]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! defor12(i,k,j) = mm(i,j) * ( &
! rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) )
! END DO
! END DO
! END DO
!LPB[37]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start-1, i_end
hat(i,k,j) = v(i,k,j) / msfvy(i,j)
END DO
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
! Keep_Lpb37_hat =hat ! Remarked by Ning Pan, 2010-08-31
!LPB[38]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end
hatavg(i,k,j) = 0.5 * ( &
fnm(k) * ( hat(i-1,k ,j) + hat(i,k ,j) ) + &
fnp(k) * ( hat(i-1,k-1,j) + hat(i,k-1,j) ) )
END DO
END DO
END DO
!LPB[39]
DO j = j_start, j_end
DO i = i_start, i_end
hatavg(i,1,j) = 0.5 * ( &
cf1 * hat(i-1,1,j) + &
cf2 * hat(i-1,2,j) + &
cf3 * hat(i-1,3,j) + &
cf1 * hat(i ,1,j) + &
cf2 * hat(i ,2,j) + &
cf3 * hat(i ,3,j) )
hatavg(i,kte,j) = 0.5 * ( &
cft1 * ( hat(i,ktes1,j) + hat(i-1,ktes1,j) ) + &
cft2 * ( hat(i,ktes2,j) + hat(i-1,ktes2,j) ) )
END DO
END DO
!LPB[40]
DO j = j_start, j_end
! Keep_Lpb40_tmpzx(j) =tmpzx ! Remarked by Ning Pan, 2010-08-31
DO k = kts, ktf
DO i = i_start, i_end
tmpzx = 0.25 * ( &
zx(i,k ,j-1) + zx(i,k ,j) + &
zx(i,k+1,j-1) + zx(i,k+1,j) )
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Keep_Lpb40_hatavg(i,k,j) =hatavg(i,k+1,j) - hatavg(i,k,j)
tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * &
0.25 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) + &
rdzw(i-1,k,j-1) + rdzw(i-1,k,j) )
END DO
END DO
END DO
!BIG ERRORS, ADDED BY WALLS
! Keep_Lpb40_tmp1 =tmp1 ! Remarked by Ning Pan, 2010-08-31
!LPB[41]
! Remarked by Ning Pan, 2010-08-31
!LPB[42]
! IF ( config_flags%sfs_opt .GT. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! nba_rij(i,k,j,P_r12) = defor12(i,k,j) - &
! mm(i,j) * ( &
! rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
! defor12(i,k,j) = defor12(i,k,j) + &
! mm(i,j) * ( &
! rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
! END DO
! END DO
! END DO
! IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor12(ids,k,j) = defor12(ids+1,k,j)
! nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor12(i,k,jds) = defor12(i,k,jds+1)
! nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor12(ide,k,j) = defor12(ide-1,k,j)
! nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor12(i,k,jde) = defor12(i,k,jde-1)
! nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12)
! END DO
! END DO
! END IF
! ELSE
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! defor12(i,k,j) = defor12(i,k,j) + &
! mm(i,j) * ( &
! rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
! END DO
! END DO
! END DO
! IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor12(ids,k,j) = defor12(ids+1,k,j)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor12(i,k,jds) = defor12(i,k,jds+1)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor12(ide,k,j) = defor12(ide-1,k,j)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor12(i,k,jde) = defor12(i,k,jde-1)
! END DO
! END DO
! END IF
! ENDIF
!LPB[43]
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[44]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[45]
!LPB[46]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[47]
!LPB[48]
IF ( config_flags%periodic_x ) i_start = its
!LPB[49]
!LPB[50]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide )
!LPB[51]
!LPB[52]
IF ( config_flags%periodic_y ) j_end = MIN( jte, jde )
!LPB[53]
DO j = jts, jte
DO i = its, ite
mm(i,j) = msfux(i,j) * msfuy(i,j)
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
Keep_Lpb53_mm =mm
!LPB[54]
DO j = j_start, j_end
DO k = kts, kte
DO i = i_start, i_end
hat(i,k,j) = w(i,k,j) / msfty(i,j)
END DO
END DO
END DO
!LPB[55]
i = i_start-1
!LPB[56]
DO j = j_start, MIN( jte, jde-1 )
DO k = kts, kte
hat(i,k,j) = w(i,k,j) / msfty(i,j)
END DO
END DO
!LPB[57]
j = j_start-1
!LPB[58]
DO k = kts, kte
DO i = i_start, MIN( ite, ide-1 )
hat(i,k,j) = w(i,k,j) / msfty(i,j)
END DO
END DO
!BIG ERRORS, REVISED BY WALLS
! Keep_Lpb54_hat =hat ! Remarked by Ning Pan, 2010-08-31
!LPB[59]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
hatavg(i,k,j) = 0.25 * ( &
hat(i ,k ,j) + &
hat(i ,k+1,j) + &
hat(i-1,k ,j) + &
hat(i-1,k+1,j) )
END DO
END DO
END DO
!LPB[60]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Keep_Lpb60_hatavg(i,k,j) =hatavg(i,k,j) - hatavg(i,k-1,j)
tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zx(i,k,j) * &
0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) )
END DO
END DO
END DO
!BIG ERRORS, ADDED BY WALLS
! Keep_Lpb60_tmp1 =tmp1 ! Remarked by Ning Pan, 2010-08-31
! Remarked by Ning Pan, 2010-08-31 : LPB[61]-[66]
!LPB[61]
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! defor13(i,k,j) = mm(i,j) * ( &
! rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
! END DO
! END DO
! END DO
!LPB[62]
! DO j = j_start, j_end
! DO i = i_start, i_end
! defor13(i,kts,j ) = 0.0
! defor13(i,ktf+1,j) = 0.0
! END DO
! END DO
!LPB[63]
!LPB[64]
! IF ( config_flags%mix_full_fields ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = ( u(i,k,j) - u(i,k-1,j) ) * &
! 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) )
! END DO
! END DO
! END DO
! ELSE
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = ( u(i,k,j) - u_base(k) - u(i,k-1,j) + u_base(k-1) ) * &
! 0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) )
! END DO
! END DO
! END DO
! END IF
!LPB[65]
!LPB[66]
! IF ( config_flags%sfs_opt .GT. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! nba_rij(i,k,j,P_r13) = tmp1(i,k,j) - defor13(i,k,j)
! defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j)
! END DO
! END DO
! END DO
! DO j = j_start, j_end
! DO i = i_start, i_end
! nba_rij(i,kts ,j,P_r13) = 0.0
! nba_rij(i,ktf+1,j,P_r13) = 0.0
! END DO
! END DO
! ELSE
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j)
! END DO
! END DO
! END DO
! ENDIF
!LPB[67]
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[68]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[69]
!LPB[70]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[71]
!LPB[72]
IF ( config_flags%periodic_y ) j_end = MIN( jte, jde )
!LPB[73]
!LPB[74]
IF ( config_flags%periodic_x ) i_start = its
!LPB[75]
!LPB[76]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!LPB[77]
DO j = jts, jte
DO i = its, ite
mm(i,j) = msfvx(i,j) * msfvy(i,j)
END DO
END DO
!LPB[78]
DO j = j_start, j_end
DO k = kts, kte
DO i = i_start, i_end
hat(i,k,j) = w(i,k,j) / msftx(i,j)
END DO
END DO
END DO
!LPB[79]
i = i_start-1
!LPB[80]
DO j = j_start, MIN( jte, jde-1 )
DO k = kts, kte
hat(i,k,j) = w(i,k,j) / msftx(i,j)
END DO
END DO
!LPB[81]
j = j_start-1
!LPB[82]
DO k = kts, kte
DO i = i_start, MIN( ite, ide-1 )
hat(i,k,j) = w(i,k,j) / msftx(i,j)
END DO
END DO
!LPB[83]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
hatavg(i,k,j) = 0.25 * ( &
hat(i,k ,j ) + &
hat(i,k+1,j ) + &
hat(i,k ,j-1) + &
hat(i,k+1,j-1) )
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-31 : LPB[84]-[86]
!LPB[84]
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zy(i,k,j) * &
! 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) )
! END DO
! END DO
! END DO
!LPB[85]
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! defor23(i,k,j) = mm(i,j) * ( &
! rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) )
! END DO
! END DO
! END DO
!!LPB[86]
! DO j = j_start, j_end
! DO i = i_start, i_end
! defor23(i,kts,j ) = 0.0
! defor23(i,ktf+1,j) = 0.0
! END DO
! END DO
!!LPB[87]
!!LPB[88]
! IF ( config_flags%mix_full_fields ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = ( v(i,k,j) - v(i,k-1,j) ) * &
! 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) )
! END DO
! END DO
! END DO
! ELSE
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tmp1(i,k,j) = ( v(i,k,j) - v_base(k) - v(i,k-1,j) + v_base(k-1) ) * &
! 0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) )
! END DO
! END DO
! END DO
! END IF
!!LPB[89]
!!LPB[90]
!
! IF ( config_flags%sfs_opt .GT. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j)
! defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j)
! END DO
! END DO
! END DO
! DO j = j_start, j_end
! DO i = i_start, i_end
! nba_rij(i,kts ,j,P_r23) = 0.0
! nba_rij(i,ktf+1,j,P_r23) = 0.0
! END DO
! END DO
! IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor13(ids,k,j) = defor13(ids+1,k,j)
! defor23(ids,k,j) = defor23(ids+1,k,j)
! nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13)
! nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor13(i,k,jds) = defor13(i,k,jds+1)
! defor23(i,k,jds) = defor23(i,k,jds+1)
! nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13)
! nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor13(ide,k,j) = defor13(ide-1,k,j)
! defor23(ide,k,j) = defor23(ide-1,k,j)
! nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13)
! nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor13(i,k,jde) = defor13(i,k,jde-1)
! defor23(i,k,jde) = defor23(i,k,jde-1)
! nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13)
! nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23)
! END DO
! END DO
! END IF
! ELSE
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j)
! END DO
! END DO
! END DO
! IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor13(ids,k,j) = defor13(ids+1,k,j)
! defor23(ids,k,j) = defor23(ids+1,k,j)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor13(i,k,jds) = defor13(i,k,jds+1)
! defor23(i,k,jds) = defor23(i,k,jds+1)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j = jts, jte
! DO k = kts, kte
! defor13(ide,k,j) = defor13(ide-1,k,j)
! defor23(ide,k,j) = defor23(ide-1,k,j)
! END DO
! END DO
! END IF
! IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k = kts, kte
! DO i = its, ite
! defor13(i,k,jde) = defor13(i,k,jde-1)
! defor23(i,k,jde) = defor23(i,k,jde-1)
! END DO
! END DO
! END IF
! ENDIF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
a_tmp =0.0
a_tmpzx =0.0
a_tmpzy =0.0
a_tmpzeta_z =0.0
! Remarked by Ning Pan, 2010-08-31
! a_cft1 =0.0
! a_cft2 =0.0
! Remarked by Ning Pan, 2010-08-31
! Do K1_ADJ =jts, jte
! Do K0_ADJ =its, ite
! a_mm(K0_ADJ,K1_ADJ) =0.0
! End Do
! End Do
! Remarked by Ning Pan, 2010-08-31
! Do K1_ADJ =jts, jte
! Do K0_ADJ =its, ite
! a_zzavg(K0_ADJ,K1_ADJ) =0.0
! End Do
! End Do
! Remarked by Ning Pan, 2010-08-31
! Do K1_ADJ =jts, jte
! Do K0_ADJ =its, ite
! a_zeta_zd12(K0_ADJ,K1_ADJ) =0.0
! End Do
! End Do
Do K2_ADJ =jts-2, jte+2
Do K1_ADJ =kts, kte
Do K0_ADJ =its-2, ite+2
a_tmp1(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_hat(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_hatavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[90]
! IF( config_flags%sfs_opt .GT. 0 ) THEN
! DO j =j_start, j_end
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =tmp1(i,k,j) -defor23(i,k,j)
! nba_rij(i,k,j,P_r23) =Tmpv001
! Tmpv001 =defor23(i,k,j) +tmp1(i,k,j)
! defor23(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
! DO j =j_start, j_end
! DO i =i_start, i_end
! nba_rij(i,kts,j,P_r23) =0.0
! nba_rij(i,ktf+1,j,P_r23) =0.0
! ENDDO
! ENDDO
! IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor13(ids,k,j) =defor13(ids+1,k,j)
! defor23(ids,k,j) =defor23(ids+1,k,j)
! nba_rij(ids,k,j,P_r13) =nba_rij(ids+1,k,j,P_r13)
! nba_rij(ids,k,j,P_r23) =nba_rij(ids+1,k,j,P_r23)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor13(i,k,jds) =defor13(i,k,jds+1)
! defor23(i,k,jds) =defor23(i,k,jds+1)
! nba_rij(i,k,jds,P_r13) =nba_rij(i,k,jds+1,P_r13)
! nba_rij(i,k,jds,P_r23) =nba_rij(i,k,jds+1,P_r23)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor13(ide,k,j) =defor13(ide-1,k,j)
! defor23(ide,k,j) =defor23(ide-1,k,j)
! nba_rij(ide,k,j,P_r13) =nba_rij(ide-1,k,j,P_r13)
! nba_rij(ide,k,j,P_r23) =nba_rij(ide-1,k,j,P_r23)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor13(i,k,jde) =defor13(i,k,jde-1)
! defor23(i,k,jde) =defor23(i,k,jde-1)
! nba_rij(i,k,jde,P_r13) =nba_rij(i,k,jde-1,P_r13)
! nba_rij(i,k,jde,P_r23) =nba_rij(i,k,jde-1,P_r23)
! ENDDO
! ENDDO
! END IF
! ELSE
! DO j =j_start, j_end
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =defor23(i,k,j) +tmp1(i,k,j)
! defor23(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
! IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor13(ids,k,j) =defor13(ids+1,k,j)
! defor23(ids,k,j) =defor23(ids+1,k,j)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor13(i,k,jds) =defor13(i,k,jds+1)
! defor23(i,k,jds) =defor23(i,k,jds+1)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor13(ide,k,j) =defor13(ide-1,k,j)
! defor23(ide,k,j) =defor23(ide-1,k,j)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor13(i,k,jde) =defor13(i,k,jde-1)
! defor23(i,k,jde) =defor23(i,k,jde-1)
! ENDDO
! ENDDO
! END IF
! ENDIF
IF( config_flags%sfs_opt .GT. 0 ) THEN
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_nba_rij(i,k,jde-1,P_r23) =a_nba_rij(i,k,jde-1,P_r23) +a_nba_rij(i,k,jde,P_r23)
a_nba_rij(i,k,jde,P_r23) =0.0
a_nba_rij(i,k,jde-1,P_r13) =a_nba_rij(i,k,jde-1,P_r13) +a_nba_rij(i,k,jde,P_r13)
a_nba_rij(i,k,jde,P_r13) =0.0
a_defor23(i,k,jde-1) =a_defor23(i,k,jde-1) +a_defor23(i,k,jde)
a_defor23(i,k,jde) =0.0
a_defor13(i,k,jde-1) =a_defor13(i,k,jde-1) +a_defor13(i,k,jde)
a_defor13(i,k,jde) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_nba_rij(ide-1,k,j,P_r23) =a_nba_rij(ide-1,k,j,P_r23) +a_nba_rij(ide,k,j,P_r23)
a_nba_rij(ide,k,j,P_r23) =0.0
a_nba_rij(ide-1,k,j,P_r13) =a_nba_rij(ide-1,k,j,P_r13) +a_nba_rij(ide,k,j,P_r13)
a_nba_rij(ide,k,j,P_r13) =0.0
a_defor23(ide-1,k,j) =a_defor23(ide-1,k,j) +a_defor23(ide,k,j)
a_defor23(ide,k,j) =0.0
a_defor13(ide-1,k,j) =a_defor13(ide-1,k,j) +a_defor13(ide,k,j)
a_defor13(ide,k,j) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_nba_rij(i,k,jds+1,P_r23) =a_nba_rij(i,k,jds+1,P_r23) +a_nba_rij(i,k,jds,P_r23)
a_nba_rij(i,k,jds,P_r23) =0.0
a_nba_rij(i,k,jds+1,P_r13) =a_nba_rij(i,k,jds+1,P_r13) +a_nba_rij(i,k,jds,P_r13)
a_nba_rij(i,k,jds,P_r13) =0.0
a_defor23(i,k,jds+1) =a_defor23(i,k,jds+1) +a_defor23(i,k,jds)
a_defor23(i,k,jds) =0.0
a_defor13(i,k,jds+1) =a_defor13(i,k,jds+1) +a_defor13(i,k,jds)
a_defor13(i,k,jds) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_nba_rij(ids+1,k,j,P_r23) =a_nba_rij(ids+1,k,j,P_r23) +a_nba_rij(ids,k,j,P_r23)
a_nba_rij(ids,k,j,P_r23) =0.0
a_nba_rij(ids+1,k,j,P_r13) =a_nba_rij(ids+1,k,j,P_r13) +a_nba_rij(ids,k,j,P_r13)
a_nba_rij(ids,k,j,P_r13) =0.0
a_defor23(ids+1,k,j) =a_defor23(ids+1,k,j) +a_defor23(ids,k,j)
a_defor23(ids,k,j) =0.0
a_defor13(ids+1,k,j) =a_defor13(ids+1,k,j) +a_defor13(ids,k,j)
a_defor13(ids,k,j) =0.0
ENDDO
ENDDO
END IF
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
a_nba_rij(i,ktf+1,j,P_r23) =0.0
a_nba_rij(i,kts,j,P_r23) =0.0
ENDDO
ENDDO
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_defor23(i,k,j)
a_defor23(i,k,j) =0.0
a_defor23(i,k,j) =a_defor23(i,k,j) +a_Tmpv1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
a_Tmpv1 =a_nba_rij(i,k,j,P_r23)
a_nba_rij(i,k,j,P_r23) =0.0
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
a_defor23(i,k,j) =a_defor23(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_defor23(i,k,jde-1) =a_defor23(i,k,jde-1) +a_defor23(i,k,jde)
a_defor23(i,k,jde) =0.0
a_defor13(i,k,jde-1) =a_defor13(i,k,jde-1) +a_defor13(i,k,jde)
a_defor13(i,k,jde) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_defor23(ide-1,k,j) =a_defor23(ide-1,k,j) +a_defor23(ide,k,j)
a_defor23(ide,k,j) =0.0
a_defor13(ide-1,k,j) =a_defor13(ide-1,k,j) +a_defor13(ide,k,j)
a_defor13(ide,k,j) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_defor23(i,k,jds+1) =a_defor23(i,k,jds+1) +a_defor23(i,k,jds)
a_defor23(i,k,jds) =0.0
a_defor13(i,k,jds+1) =a_defor13(i,k,jds+1) +a_defor13(i,k,jds)
a_defor13(i,k,jds) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_defor23(ids+1,k,j) =a_defor23(ids+1,k,j) +a_defor23(ids,k,j)
a_defor23(ids,k,j) =0.0
a_defor13(ids+1,k,j) =a_defor13(ids+1,k,j) +a_defor13(ids,k,j)
a_defor13(ids,k,j) =0.0
ENDDO
ENDDO
END IF
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_defor23(i,k,j)
a_defor23(i,k,j) =0.0
a_defor23(i,k,j) =a_defor23(i,k,j) +a_Tmpv1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[89]
!LPB[88]
IF( config_flags%mix_full_fields ) THEN
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =v(i,k,j) -v(i,k-1,j)
Tmpv002 =Tmpv001*0.5
Tmpv003 =rdz(i,k,j) +rdz(i,k,j-1)
Tmpv400(i,k,j) =Tmpv002
Tmpv401(i,k,j) =Tmpv003
! Remarked by Ning Pan, 2010-08-31
! Tmpv004 =Tmpv400(i,k,j)*Tmpv401(i,k,j)
! tmp1(i,k,j) =Tmpv004
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =v(i,k,j) -v_base(k) -v(i,k-1,j)
Tmpv002 =Tmpv001 +v_base(k-1)
Tmpv003 =Tmpv002*0.5
Tmpv004 =rdz(i,k,j) +rdz(i,k,j-1)
Tmpv402(i,k,j) =Tmpv003
Tmpv403(i,k,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-31
! Tmpv005 =Tmpv402(i,k,j)*Tmpv403(i,k,j)
! tmp1(i,k,j) =Tmpv005
ENDDO
ENDDO
ENDDO
END IF
IF( config_flags%mix_full_fields ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv2 =Tmpv401(i,k,j)*a_Tmpv4
a_Tmpv3 =Tmpv400(i,k,j)*a_Tmpv4
a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv3
a_rdz(i,k,j-1) =a_rdz(i,k,j-1) +a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv1
a_v(i,k-1,j) =a_v(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv5 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv3 =Tmpv403(i,k,j)*a_Tmpv5
a_Tmpv4 =Tmpv402(i,k,j)*a_Tmpv5
a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv4
a_rdz(i,k,j-1) =a_rdz(i,k,j-1) +a_Tmpv4
a_Tmpv2 =0.5*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv1
a_v(i,k-1,j) =a_v(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
END IF
!LPB[87]
!LPB[86]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! defor23(i,kts,j) =0.0
! defor23(i,ktf+1,j) =0.0
! ENDDO
DO i =i_end, i_start, -1
a_defor23(i,ktf+1,j) =0.0
a_defor23(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[85]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) -hat(i,k,j-1)
! Tmpv002 =rdy*Tmpv001
! Tmpv003 =Tmpv002 -tmp1(i,k,j)
! Tmpv300(i,k) =Tmpv003
! Tmpv004 =mm(i,j)*Tmpv300(i,k)
! defor23(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_defor23(i,k,j)
a_defor23(i,k,j) =0.0
! a_mm(i,j) =a_mm(i,j) +Tmpv300(i,k)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdy*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i,k,j-1) =a_hat(i,k,j-1) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[84]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =hatavg(i,k,j) -hatavg(i,k-1,j)
Tmpv300(i,k) =Tmpv001
Tmpv002 =Tmpv300(i,k)*zy(i,k,j)
Tmpv003 =Tmpv002*0.5
Tmpv004 =rdz(i,k,j) +rdz(i,k,j-1)
Tmpv301(i,k) =Tmpv003
Tmpv302(i,k) =Tmpv004
! Remarked by Ning Pan, 2010-08-31
! Tmpv005 =Tmpv301(i,k)*Tmpv302(i,k)
! tmp1(i,k,j) =Tmpv005
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv5 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv3 =Tmpv302(i,k)*a_Tmpv5
a_Tmpv4 =Tmpv301(i,k)*a_Tmpv5
a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv4
a_rdz(i,k,j-1) =a_rdz(i,k,j-1) +a_Tmpv4
a_Tmpv2 =0.5*a_Tmpv3
a_Tmpv1 =zy(i,k,j)*a_Tmpv2
a_zy(i,k,j) =a_zy(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_hatavg(i,k,j) =a_hatavg(i,k,j) +a_Tmpv1
a_hatavg(i,k-1,j) =a_hatavg(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!BIG ERRORS, ADDED BY WALLS
! tmp1 =Keep_Lpb60_tmp1 ! Remarked by Ning Pan, 2010-08-31
!LPB[83]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) +hat(i,k+1,j)
! Tmpv002 =Tmpv001 +hat(i,k,j-1)
! Tmpv003 =Tmpv002 +hat(i,k+1,j-1)
! Tmpv004 =0.25*Tmpv003
! hatavg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_hatavg(i,k,j)
a_hatavg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_hat(i,k+1,j-1) =a_hat(i,k+1,j-1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_hat(i,k,j-1) =a_hat(i,k,j-1) +a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i,k+1,j) =a_hat(i,k+1,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!ADDED BY WALLS
!FROM LPB[81]
j =j_start-1
!LPB[82]
DO k =kte, kts, -1
! DO i =i_start, min(ite, ide-1)
! hat(i,k,j) =w(i,k,j)/msftx(i,j)
! ENDDO
DO i =min(ite, ide-1), i_start, -1
a_w(i,k,j) =a_w(i,k,j) +1.0/msftx(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
!LPB[81]
! j =j_start-1
!ADDED BY WALLS
!FROM LPB[79]
i =i_start-1
!LPB[80]
DO j =min(jte, jde-1), j_start, -1
! DO k =kts, kte
! hat(i,k,j) =w(i,k,j)/msftx(i,j)
! ENDDO
DO k =kte, kts, -1
a_w(i,k,j) =a_w(i,k,j) +1.0/msftx(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
!LPB[79]
! i =i_start-1
!LPB[78]
DO j =j_end, j_start, -1
! DO k =kts, kte
! DO i =i_start, i_end
! hat(i,k,j) =w(i,k,j)/msftx(i,j)
! ENDDO
! ENDDO
DO k =kte, kts, -1
DO i =i_end, i_start, -1
a_w(i,k,j) =a_w(i,k,j) +1.0/msftx(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!BIG ERRORS, REVISED BY WALLS
! hat =Keep_Lpb54_hat ! Remarked by Ning Pan, 2010-08-31
!LPB[77]
! Remarked by Ning Pan, 2010-08-31
! DO j =jte, jts, -1
!! DO i =its, ite
!! mm(i,j) =msfvx(i,j)*msfvy(i,j)
!! ENDDO
! DO i =ite, its, -1
! a_mm(i,j) =0.0
! ENDDO
! ENDDO
!BIG ERRORS, REVISED BY WALLS
mm =Keep_Lpb53_mm
!LPB[76]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[75]
!LPB[74]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[73]
!LPB[72]
! IF( config_flags%periodic_y ) THEN
! j_end =min(jte, jde)
! END IF
! IF( config_flags%periodic_y ) THEN
! END IF
!LPB[71]
!LPB[70]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[69]
!LPB[68]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[67]
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
!ADDED BY WALLS
!FROM LPB[43]
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!FROM LPB[44]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!FROM LPB[45]
!FROM LPB[46]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!FROM LPB[47]
!FROM LPB[48]
IF ( config_flags%periodic_x ) i_start = its
!FROM LPB[49]
!FROM LPB[50]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide )
!FROM LPB[51]
!FROM LPB[52]
IF ( config_flags%periodic_y ) j_end = MIN( jte, jde )
!LPB[66]
! IF( config_flags%sfs_opt .GT. 0 ) THEN
! DO j =j_start, j_end
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =tmp1(i,k,j) -defor13(i,k,j)
! nba_rij(i,k,j,P_r13) =Tmpv001
! Tmpv001 =defor13(i,k,j) +tmp1(i,k,j)
! defor13(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
! DO j =j_start, j_end
! DO i =i_start, i_end
! nba_rij(i,kts,j,P_r13) =0.0
! nba_rij(i,ktf+1,j,P_r13) =0.0
! ENDDO
! ENDDO
! ELSE
! DO j =j_start, j_end
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =defor13(i,k,j) +tmp1(i,k,j)
! defor13(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
! ENDIF
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
a_nba_rij(i,ktf+1,j,P_r13) =0.0
a_nba_rij(i,kts,j,P_r13) =0.0
ENDDO
ENDDO
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_defor13(i,k,j)
a_defor13(i,k,j) =0.0
a_defor13(i,k,j) =a_defor13(i,k,j) +a_Tmpv1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
a_Tmpv1 =a_nba_rij(i,k,j,P_r13)
a_nba_rij(i,k,j,P_r13) =0.0
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
a_defor13(i,k,j) =a_defor13(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_defor13(i,k,j)
a_defor13(i,k,j) =0.0
a_defor13(i,k,j) =a_defor13(i,k,j) +a_Tmpv1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[65]
!LPB[64]
IF( config_flags%mix_full_fields ) THEN
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =u(i,k,j) -u(i,k-1,j)
Tmpv002 =Tmpv001*0.5
Tmpv003 =rdz(i,k,j) +rdz(i-1,k,j)
Tmpv400(i,k,j) =Tmpv002
Tmpv401(i,k,j) =Tmpv003
! Remarked by Ning Pan, 2010-08-31
! Tmpv004 =Tmpv400(i,k,j)*Tmpv401(i,k,j)
! tmp1(i,k,j) =Tmpv004
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =u(i,k,j) -u_base(k) -u(i,k-1,j)
Tmpv002 =Tmpv001 +u_base(k-1)
Tmpv003 =Tmpv002*0.5
Tmpv004 =rdz(i,k,j) +rdz(i-1,k,j)
Tmpv402(i,k,j) =Tmpv003
Tmpv403(i,k,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-31
! Tmpv005 =Tmpv402(i,k,j)*Tmpv403(i,k,j)
! tmp1(i,k,j) =Tmpv005
ENDDO
ENDDO
ENDDO
END IF
IF( config_flags%mix_full_fields ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv2 =Tmpv401(i,k,j)*a_Tmpv4
a_Tmpv3 =Tmpv400(i,k,j)*a_Tmpv4
a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv3
a_rdz(i-1,k,j) =a_rdz(i-1,k,j) +a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i,k-1,j) =a_u(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv5 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv3 =Tmpv403(i,k,j)*a_Tmpv5
a_Tmpv4 =Tmpv402(i,k,j)*a_Tmpv5
a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv4
a_rdz(i-1,k,j) =a_rdz(i-1,k,j) +a_Tmpv4
a_Tmpv2 =0.5*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i,k-1,j) =a_u(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
END IF
!LPB[63]
!LPB[62]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! defor13(i,kts,j) =0.0
! defor13(i,ktf+1,j) =0.0
! ENDDO
DO i =i_end, i_start, -1
a_defor13(i,ktf+1,j) =0.0
a_defor13(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[61]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) -hat(i-1,k,j)
! Tmpv002 =rdx*Tmpv001
! Tmpv003 =Tmpv002 -tmp1(i,k,j)
! Tmpv300(i,k) =Tmpv003
! Tmpv004 =mm(i,j)*Tmpv300(i,k)
! defor13(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_defor13(i,k,j)
a_defor13(i,k,j) =0.0
! a_mm(i,j) =a_mm(i,j) +Tmpv300(i,k)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdx*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i-1,k,j) =a_hat(i-1,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[60]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
! Tmpv001 =hatavg(i,k,j) -hatavg(i,k-1,j)
Tmpv001 =Keep_Lpb60_hatavg(i,k,j)
Tmpv300(i,k) =Tmpv001
Tmpv002 =Tmpv300(i,k)*zx(i,k,j)
Tmpv003 =Tmpv002*0.5
Tmpv004 =rdz(i,k,j) +rdz(i-1,k,j)
Tmpv301(i,k) =Tmpv003
Tmpv302(i,k) =Tmpv004
! Remarked by Ning Pan, 2010-08-31
! Tmpv005 =Tmpv301(i,k)*Tmpv302(i,k)
! tmp1(i,k,j) =Tmpv005
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv5 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv3 =Tmpv302(i,k)*a_Tmpv5
a_Tmpv4 =Tmpv301(i,k)*a_Tmpv5
a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv4
a_rdz(i-1,k,j) =a_rdz(i-1,k,j) +a_Tmpv4
a_Tmpv2 =0.5*a_Tmpv3
a_Tmpv1 =zx(i,k,j)*a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_hatavg(i,k,j) =a_hatavg(i,k,j) +a_Tmpv1
a_hatavg(i,k-1,j) =a_hatavg(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!BIG ERRORS, ADDED BY WALLS
! tmp1 =Keep_Lpb40_tmp1 ! Remarked by Ning Pan, 2010-08-31
!LPB[59]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) +hat(i,k+1,j)
! Tmpv002 =Tmpv001 +hat(i-1,k,j)
! Tmpv003 =Tmpv002 +hat(i-1,k+1,j)
! Tmpv004 =0.25*Tmpv003
! hatavg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_hatavg(i,k,j)
a_hatavg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_hat(i-1,k+1,j) =a_hat(i-1,k+1,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_hat(i-1,k,j) =a_hat(i-1,k,j) +a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i,k+1,j) =a_hat(i,k+1,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!ADDED BY WALLS
!FROM LPB[57]
j = j_start-1
!LPB[58]
DO k =kte, kts, -1
! DO i =i_start, min(ite, ide-1)
! hat(i,k,j) =w(i,k,j)/msfty(i,j)
! ENDDO
DO i =min(ite, ide-1), i_start, -1
a_w(i,k,j) =a_w(i,k,j) +1.0/msfty(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
!LPB[57]
! j =j_start-1
!ADDED BY WALLS
!FROM LPB[55]
i = i_start-1
!LPB[56]
DO j =min(jte, jde-1), j_start, -1
! DO k =kts, kte
! hat(i,k,j) =w(i,k,j)/msfty(i,j)
! ENDDO
DO k =kte, kts, -1
a_w(i,k,j) =a_w(i,k,j) +1.0/msfty(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
!LPB[55]
! i =i_start-1
!LPB[54]
DO j =j_end, j_start, -1
! DO k =kts, kte
! DO i =i_start, i_end
! hat(i,k,j) =w(i,k,j)/msfty(i,j)
! ENDDO
! ENDDO
DO k =kte, kts, -1
DO i =i_end, i_start, -1
a_w(i,k,j) =a_w(i,k,j) +1.0/msfty(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!BIG ERRORS, REVISED BY WALLS
! hat =Keep_Lpb37_hat ! Remarked by Ning Pan, 2010-08-31
!LPB[53]
! Remarked by Ning Pan, 2010-08-31
! DO j =jte, jts, -1
!! DO i =its, ite
!! mm(i,j) =msfux(i,j)*msfuy(i,j)
!! ENDDO
! DO i =ite, its, -1
! a_mm(i,j) =0.0
! ENDDO
! ENDDO
!BIG ERRORS, REVISED BY WALLS
mm =Keep_Lpb31_mm
!LPB[52]
! IF( config_flags%periodic_y ) THEN
! j_end =min(jte, jde)
! END IF
! IF( config_flags%periodic_y ) THEN
! END IF
!LPB[51]
!LPB[50]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[49]
!LPB[48]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[47]
!LPB[46]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[45]
!LPB[44]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[43]
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
!ADDED BY WALLS
!FROM LPB[19]
i_start = its
i_end = ite
j_start = jts
j_end = jte
!FROM LPB[20]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!FROM LPB[21]
!FROM LPB[22]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-1, ite )
!FROM LPB[23]
!FROM LPB[24]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!FROM LPB[25]
!FROM LPB[26]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-1, jte )
!FROM LPB[27]
!FROM LPB[28]
IF ( config_flags%periodic_x ) i_start = its
!FROM LPB[29]
!FROM LPB[30]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[42]
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =hat(i,k,j) -hat(i-1,k,j)
Tmpv002 =rdx*Tmpv001
Tmpv003 =Tmpv002 -tmp1(i,k,j)
Tmpv400(i,k,j) =Tmpv003
! Remarked by Ning Pan, 2010-08-31
! Tmpv004 =mm(i,j)*Tmpv400(i,k,j)
! Tmpv005 =defor12(i,k,j) -Tmpv004
! nba_rij(i,k,j,P_r12) =Tmpv005
Tmpv001 =hat(i,k,j) -hat(i-1,k,j)
Tmpv002 =rdx*Tmpv001
Tmpv003 =Tmpv002 -tmp1(i,k,j)
Tmpv401(i,k,j) =Tmpv003
! Remarked by Ning Pan, 2010-08-31
! Tmpv004 =mm(i,j)*Tmpv401(i,k,j)
! Tmpv005 =defor12(i,k,j) +Tmpv004
! defor12(i,k,j) =Tmpv005
ENDDO
ENDDO
ENDDO
! Remarked by Ning Pan, 2010-08-31
! IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor12(ids,k,j) =defor12(ids+1,k,j)
! nba_rij(ids,k,j,P_r12) =nba_rij(ids+1,k,j,P_r12)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor12(i,k,jds) =defor12(i,k,jds+1)
! nba_rij(i,k,jds,P_r12) =nba_rij(i,k,jds+1,P_r12)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor12(ide,k,j) =defor12(ide-1,k,j)
! nba_rij(ide,k,j,P_r12) =nba_rij(ide-1,k,j,P_r12)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor12(i,k,jde) =defor12(i,k,jde-1)
! nba_rij(i,k,jde,P_r12) =nba_rij(i,k,jde-1,P_r12)
! ENDDO
! ENDDO
! END IF
! ELSE
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) -hat(i-1,k,j)
! Tmpv002 =rdx*Tmpv001
! Tmpv003 =Tmpv002 -tmp1(i,k,j)
! Tmpv402(i,k,j) =Tmpv003
! Tmpv004 =mm(i,j)*Tmpv402(i,k,j)
! Tmpv005 =defor12(i,k,j) +Tmpv004
! defor12(i,k,j) =Tmpv005
! ENDDO
! ENDDO
! ENDDO
! IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor12(ids,k,j) =defor12(ids+1,k,j)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor12(i,k,jds) =defor12(i,k,jds+1)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
! DO j =jts, jte
! DO k =kts, kte
! defor12(ide,k,j) =defor12(ide-1,k,j)
! ENDDO
! ENDDO
! END IF
! IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
! DO k =kts, kte
! DO i =its, ite
! defor12(i,k,jde) =defor12(i,k,jde-1)
! ENDDO
! ENDDO
! END IF
ENDIF
IF( config_flags%sfs_opt .GT. 0 ) THEN
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_nba_rij(i,k,jde-1,P_r12) =a_nba_rij(i,k,jde-1,P_r12) +a_nba_rij(i,k,jde,P_r12)
a_nba_rij(i,k,jde,P_r12) =0.0
a_defor12(i,k,jde-1) =a_defor12(i,k,jde-1) +a_defor12(i,k,jde)
a_defor12(i,k,jde) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_nba_rij(ide-1,k,j,P_r12) =a_nba_rij(ide-1,k,j,P_r12) +a_nba_rij(ide,k,j,P_r12)
a_nba_rij(ide,k,j,P_r12) =0.0
a_defor12(ide-1,k,j) =a_defor12(ide-1,k,j) +a_defor12(ide,k,j)
a_defor12(ide,k,j) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_nba_rij(i,k,jds+1,P_r12) =a_nba_rij(i,k,jds+1,P_r12) +a_nba_rij(i,k,jds,P_r12)
a_nba_rij(i,k,jds,P_r12) =0.0
a_defor12(i,k,jds+1) =a_defor12(i,k,jds+1) +a_defor12(i,k,jds)
a_defor12(i,k,jds) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_nba_rij(ids+1,k,j,P_r12) =a_nba_rij(ids+1,k,j,P_r12) +a_nba_rij(ids,k,j,P_r12)
a_nba_rij(ids,k,j,P_r12) =0.0
a_defor12(ids+1,k,j) =a_defor12(ids+1,k,j) +a_defor12(ids,k,j)
a_defor12(ids,k,j) =0.0
ENDDO
ENDDO
END IF
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv5 =a_defor12(i,k,j)
a_defor12(i,k,j) =0.0
a_defor12(i,k,j) =a_defor12(i,k,j) +a_Tmpv5
a_Tmpv4 =a_Tmpv5
! a_mm(i,j) =a_mm(i,j) +Tmpv401(i,k,j)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdx*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i-1,k,j) =a_hat(i-1,k,j) -a_Tmpv1
a_Tmpv5 =a_nba_rij(i,k,j,P_r12)
a_nba_rij(i,k,j,P_r12) =0.0
a_defor12(i,k,j) =a_defor12(i,k,j) +a_Tmpv5
a_Tmpv4 =-a_Tmpv5
! a_mm(i,j) =a_mm(i,j) +Tmpv400(i,k,j)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdx*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i-1,k,j) =a_hat(i-1,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_defor12(i,k,jde-1) =a_defor12(i,k,jde-1) +a_defor12(i,k,jde)
a_defor12(i,k,jde) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_defor12(ide-1,k,j) =a_defor12(ide-1,k,j) +a_defor12(ide,k,j)
a_defor12(ide,k,j) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
DO k =kte, kts, -1
DO i =ite, its, -1
a_defor12(i,k,jds+1) =a_defor12(i,k,jds+1) +a_defor12(i,k,jds)
a_defor12(i,k,jds) =0.0
ENDDO
ENDDO
END IF
IF( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
DO j =jte, jts, -1
DO k =kte, kts, -1
a_defor12(ids+1,k,j) =a_defor12(ids+1,k,j) +a_defor12(ids,k,j)
a_defor12(ids,k,j) =0.0
ENDDO
ENDDO
END IF
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv5 =a_defor12(i,k,j)
a_defor12(i,k,j) =0.0
a_defor12(i,k,j) =a_defor12(i,k,j) +a_Tmpv5
a_Tmpv4 =a_Tmpv5
! a_mm(i,j) =a_mm(i,j) +Tmpv402(i,k,j)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdx*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i-1,k,j) =a_hat(i-1,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[41]
!LPB[40]
DO j =j_end, j_start, -1
! tmpzx =Keep_Lpb40_tmpzx(j) ! Remarked by Ning Pan, 2010-08-31
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =zx(i,k,j-1) +zx(i,k,j)
Tmpv002 =Tmpv001 +zx(i,k+1,j-1)
Tmpv003 =Tmpv002 +zx(i,k+1,j)
Tmpv004 =0.25*Tmpv003
tmpzx =Tmpv004
Tmpv300(i,k) =tmpzx
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
! Tmpv001 =hatavg(i,k+1,j) -hatavg(i,k,j)
Tmpv001 =Keep_Lpb40_hatavg(i,k,j)
Tmpv002 =Tmpv001*0.25
Tmpv301(i,k) =Tmpv002
Tmpv003 =Tmpv301(i,k)*tmpzx
Tmpv004 =rdzw(i,k,j) +rdzw(i,k,j-1)
Tmpv005 =Tmpv004 +rdzw(i-1,k,j-1)
Tmpv006 =Tmpv005 +rdzw(i-1,k,j)
Tmpv302(i,k) =Tmpv003
Tmpv303(i,k) =Tmpv006
! Remarked by Ning Pan, 2010-08-31
! Tmpv007 =Tmpv302(i,k)*Tmpv303(i,k)
! tmp1(i,k,j) =Tmpv007
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
tmpzx =Tmpv300(i,k)
a_Tmpv7 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv3 =Tmpv303(i,k)*a_Tmpv7
a_Tmpv6 =Tmpv302(i,k)*a_Tmpv7
a_Tmpv5 =a_Tmpv6
a_rdzw(i-1,k,j) =a_rdzw(i-1,k,j) +a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_rdzw(i-1,k,j-1) =a_rdzw(i-1,k,j-1) +a_Tmpv5
a_rdzw(i,k,j) =a_rdzw(i,k,j) +a_Tmpv4
a_rdzw(i,k,j-1) =a_rdzw(i,k,j-1) +a_Tmpv4
a_Tmpv2 =tmpzx*a_Tmpv3
a_tmpzx =a_tmpzx +Tmpv301(i,k)*a_Tmpv3
a_Tmpv1 =0.25*a_Tmpv2
a_hatavg(i,k+1,j) =a_hatavg(i,k+1,j) +a_Tmpv1
a_hatavg(i,k,j) =a_hatavg(i,k,j) -a_Tmpv1
! tmpzx =Tmpv300(i,k)
a_Tmpv4 =a_tmpzx
a_tmpzx =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zx(i,k+1,j) =a_zx(i,k+1,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zx(i,k+1,j-1) =a_zx(i,k+1,j-1) +a_Tmpv2
a_zx(i,k,j-1) =a_zx(i,k,j-1) +a_Tmpv1
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!BIG ERRORS, ADDED BY WALLS
! tmp1 =Keep_Lpb35_tmp1 ! Remarked by Ning Pan, 2010-08-31
!LPB[39]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO i =i_start, i_end
! Tmpv001 =cf1*hat(i-1,1,j) +cf2*hat(i-1,2,j)
! Tmpv002 =Tmpv001 +cf3*hat(i-1,3,j)
! Tmpv003 =Tmpv002 +cf1*hat(i,1,j)
! Tmpv004 =Tmpv003 +cf2*hat(i,2,j)
! Tmpv005 =Tmpv004 +cf3*hat(i,3,j)
! Tmpv006 =0.5*Tmpv005
! hatavg(i,1,j) =Tmpv006
! Tmpv001 =hat(i,ktes1,j) +hat(i-1,ktes1,j)
! Tmpv200(i) =Tmpv001
! Tmpv002 =cft1*Tmpv200(i)
! Tmpv003 =hat(i,ktes2,j) +hat(i-1,ktes2,j)
! Tmpv201(i) =Tmpv003
! Tmpv004 =cft2*Tmpv201(i)
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,kte,j) =Tmpv006
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,kte,j)
a_hatavg(i,kte,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
! a_cft2 =a_cft2 +Tmpv201(i)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =cft2*a_Tmpv4
a_hat(i,ktes2,j) =a_hat(i,ktes2,j) +a_Tmpv3
a_hat(i-1,ktes2,j) =a_hat(i-1,ktes2,j) +a_Tmpv3
! a_cft1 =a_cft1 +Tmpv200(i)*a_Tmpv2 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv1 =cft1*a_Tmpv2
a_hat(i,ktes1,j) =a_hat(i,ktes1,j) +a_Tmpv1
a_hat(i-1,ktes1,j) =a_hat(i-1,ktes1,j) +a_Tmpv1
a_Tmpv6 =a_hatavg(i,1,j)
a_hatavg(i,1,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_hat(i,3,j) =a_hat(i,3,j) +cf3*a_Tmpv5
a_Tmpv3 =a_Tmpv4
a_hat(i,2,j) =a_hat(i,2,j) +cf2*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_hat(i,1,j) =a_hat(i,1,j) +cf1*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_hat(i-1,3,j) =a_hat(i-1,3,j) +cf3*a_Tmpv2
a_hat(i-1,1,j) =a_hat(i-1,1,j) +cf1*a_Tmpv1
a_hat(i-1,2,j) =a_hat(i-1,2,j) +cf2*a_Tmpv1
ENDDO
ENDDO
!LPB[38]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i-1,k,j) +hat(i,k,j)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =hat(i-1,k-1,j) +hat(i,k-1,j)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,k,j)
a_hatavg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_hat(i-1,k-1,j) =a_hat(i-1,k-1,j) +a_Tmpv3
a_hat(i,k-1,j) =a_hat(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_hat(i-1,k,j) =a_hat(i-1,k,j) +a_Tmpv1
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[37]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start-1, i_end
! hat(i,k,j) =v(i,k,j)/msfvy(i,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start-1, -1
a_v(i,k,j) =a_v(i,k,j) +1.0/msfvy(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!BIG ERRORS, REVISED BY WALLS
! hat =Keep_Lpb32_hat ! Remarked by Ning Pan, 2010-08-31
!LPB[36]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) -hat(i,k,j-1)
! Tmpv002 =rdy*Tmpv001
! Tmpv003 =Tmpv002 -tmp1(i,k,j)
! Tmpv300(i,k) =Tmpv003
! Tmpv004 =mm(i,j)*Tmpv300(i,k)
! defor12(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_defor12(i,k,j)
a_defor12(i,k,j) =0.0
! a_mm(i,j) =a_mm(i,j) +Tmpv300(i,k)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdy*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i,k,j-1) =a_hat(i,k,j-1) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[35]
DO j =j_end, j_start, -1
! tmpzy =Keep_Lpb35_tmpzy(j) ! Remarked by Ning Pan, 2010-08-31
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =zy(i-1,k,j) +zy(i,k,j)
Tmpv002 =Tmpv001 +zy(i-1,k+1,j)
Tmpv003 =Tmpv002 +zy(i,k+1,j)
Tmpv004 =0.25*Tmpv003
tmpzy =Tmpv004
Tmpv300(i,k) =tmpzy
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
! Tmpv001 =hatavg(i,k+1,j) -hatavg(i,k,j)
Tmpv001 =Keep_Lpb35_hatavg(i,k,j)
Tmpv002 =Tmpv001*0.25
Tmpv301(i,k) =Tmpv002
Tmpv003 =Tmpv301(i,k)*tmpzy
Tmpv004 =rdzw(i,k,j) +rdzw(i-1,k,j)
Tmpv005 =Tmpv004 +rdzw(i-1,k,j-1)
Tmpv006 =Tmpv005 +rdzw(i,k,j-1)
Tmpv302(i,k) =Tmpv003
Tmpv303(i,k) =Tmpv006
! Remarked by Ning Pan, 2010-08-31
! Tmpv007 =Tmpv302(i,k)*Tmpv303(i,k)
! tmp1(i,k,j) =Tmpv007
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
tmpzy =Tmpv300(i,k)
a_Tmpv7 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv3 =Tmpv303(i,k)*a_Tmpv7
a_Tmpv6 =Tmpv302(i,k)*a_Tmpv7
a_Tmpv5 =a_Tmpv6
a_rdzw(i,k,j-1) =a_rdzw(i,k,j-1) +a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_rdzw(i-1,k,j-1) =a_rdzw(i-1,k,j-1) +a_Tmpv5
a_rdzw(i,k,j) =a_rdzw(i,k,j) +a_Tmpv4
a_rdzw(i-1,k,j) =a_rdzw(i-1,k,j) +a_Tmpv4
a_Tmpv2 =tmpzy*a_Tmpv3
a_tmpzy =a_tmpzy +Tmpv301(i,k)*a_Tmpv3
a_Tmpv1 =0.25*a_Tmpv2
a_hatavg(i,k+1,j) =a_hatavg(i,k+1,j) +a_Tmpv1
a_hatavg(i,k,j) =a_hatavg(i,k,j) -a_Tmpv1
! tmpzy =Tmpv300(i,k)
a_Tmpv4 =a_tmpzy
a_tmpzy =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zy(i,k+1,j) =a_zy(i,k+1,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zy(i-1,k+1,j) =a_zy(i-1,k+1,j) +a_Tmpv2
a_zy(i-1,k,j) =a_zy(i-1,k,j) +a_Tmpv1
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[34]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO i =i_start, i_end
! Tmpv001 =cf1*hat(i,1,j-1) +cf2*hat(i,2,j-1)
! Tmpv002 =Tmpv001 +cf3*hat(i,3,j-1)
! Tmpv003 =Tmpv002 +cf1*hat(i,1,j)
! Tmpv004 =Tmpv003 +cf2*hat(i,2,j)
! Tmpv005 =Tmpv004 +cf3*hat(i,3,j)
! Tmpv006 =0.5*Tmpv005
! hatavg(i,1,j) =Tmpv006
! Tmpv001 =hat(i,ktes1,j-1) +hat(i,ktes1,j)
! Tmpv200(i) =Tmpv001
! Tmpv002 =cft1*Tmpv200(i)
! Tmpv003 =hat(i,ktes2,j-1) +hat(i,ktes2,j)
! Tmpv201(i) =Tmpv003
! Tmpv004 =cft2*Tmpv201(i)
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,kte,j) =Tmpv006
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,kte,j)
a_hatavg(i,kte,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
! a_cft2 =a_cft2 +Tmpv201(i)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =cft2*a_Tmpv4
a_hat(i,ktes2,j-1) =a_hat(i,ktes2,j-1) +a_Tmpv3
a_hat(i,ktes2,j) =a_hat(i,ktes2,j) +a_Tmpv3
! a_cft1 =a_cft1 +Tmpv200(i)*a_Tmpv2 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv1 =cft1*a_Tmpv2
a_hat(i,ktes1,j-1) =a_hat(i,ktes1,j-1) +a_Tmpv1
a_hat(i,ktes1,j) =a_hat(i,ktes1,j) +a_Tmpv1
a_Tmpv6 =a_hatavg(i,1,j)
a_hatavg(i,1,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_hat(i,3,j) =a_hat(i,3,j) +cf3*a_Tmpv5
a_Tmpv3 =a_Tmpv4
a_hat(i,2,j) =a_hat(i,2,j) +cf2*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_hat(i,1,j) =a_hat(i,1,j) +cf1*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_hat(i,3,j-1) =a_hat(i,3,j-1) +cf3*a_Tmpv2
a_hat(i,1,j-1) =a_hat(i,1,j-1) +cf1*a_Tmpv1
a_hat(i,2,j-1) =a_hat(i,2,j-1) +cf2*a_Tmpv1
ENDDO
ENDDO
!LPB[33]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j-1) +hat(i,k,j)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =hat(i,k-1,j-1) +hat(i,k-1,j)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,k,j)
a_hatavg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_hat(i,k-1,j-1) =a_hat(i,k-1,j-1) +a_Tmpv3
a_hat(i,k-1,j) =a_hat(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_hat(i,k,j-1) =a_hat(i,k,j-1) +a_Tmpv1
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[32]
DO j =j_end, j_start-1, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! hat(i,k,j) =u(i,k,j)/msfux(i,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_u(i,k,j) =a_u(i,k,j) +1.0/msfux(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!BIG ERRORS, REVISED BY WALLS
! hat =Keep_Lpb9_hat ! Remarked by Ning Pan, 2010-08-31
!LPB[31]
! Remarked by Ning Pan, 2010-08-31
! DO j =j_end, j_start, -1
!! DO i =i_start, i_end
!! mm(i,j) =0.25*(msfux(i,j-1)+msfux(i,j))*(msfvy(i-1,j)+msfvy(i,j))
!! ENDDO
! DO i =i_end, i_start, -1
! a_mm(i,j) =0.0
! ENDDO
! ENDDO
!BIG ERRORS, REVISED BY WALLS
mm =Keep_Lpb1_mm
!LPB[30]
! IF( config_flags%periodic_x ) THEN
! i_end =ite
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[29]
!LPB[28]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[27]
!LPB[26]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_end =min(jde-1, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[25]
!LPB[24]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[23]
!LPB[22]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_end =min(ide-1, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[21]
!LPB[20]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[19]
! i_start =its
! i_end =ite
! j_start =jts
! j_end =jte
!ADDED BY WALLS
!FROM LPB[0]
! Remarked by Ning Pan, 2010-08-31
! ktes1 = kte-1
! ktes2 = kte-2
! cft2 = - 0.5 * dnw(ktes1) / dn(ktes1)
! cft1 = 1.0 - cft2
! ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[18]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =div(i,k,j) +tmp1(i,k,j)
! div(i,k,j) =Tmpv001
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_div(i,k,j)
a_div(i,k,j) =0.0
a_div(i,k,j) =a_div(i,k,j) +a_Tmpv1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[17]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! defor33(i,k,j) =2.0*tmp1(i,k,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +2.0*a_defor33(i,k,j)
a_defor33(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!LPB[16]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =w(i,k+1,j) -w(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-31
! Tmpv002 =Tmpv300(i,k)*rdzw(i,k,j)
! tmp1(i,k,j) =Tmpv002
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv2 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv1 =rdzw(i,k,j)*a_Tmpv2
a_rdzw(i,k,j) =a_rdzw(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_w(i,k+1,j) =a_w(i,k+1,j) +a_Tmpv1
a_w(i,k,j) =a_w(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[15]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =div(i,k,j) +tmp1(i,k,j)
! div(i,k,j) =Tmpv001
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_div(i,k,j)
a_div(i,k,j) =0.0
a_div(i,k,j) =a_div(i,k,j) +a_Tmpv1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! defor22(i,k,j) =2.0*tmp1(i,k,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +2.0*a_defor22(i,k,j)
a_defor22(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO k=kts, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! tmp1(i,k,j) =Keep_Lpb13_tmp1(i,k,j)
! END DO
! END DO
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j+1) -hat(i,k,j)
! Tmpv002 =rdy*Tmpv001
! Tmpv003 =Tmpv002 -tmp1(i,k,j)
! Tmpv300(i,k) =Tmpv003
! Tmpv004 =mm(i,j)*Tmpv300(i,k)
! tmp1(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
! a_mm(i,j) =a_mm(i,j) +Tmpv300(i,k)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdy*a_Tmpv2
a_hat(i,k,j+1) =a_hat(i,k,j+1) +a_Tmpv1
a_hat(i,k,j) =a_hat(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =zy(i,k,j) +zy(i,k,j+1)
Tmpv002 =Tmpv001 +zy(i,k+1,j)
Tmpv003 =Tmpv002 +zy(i,k+1,j+1)
Tmpv004 =0.25*Tmpv003
tmpzy =Tmpv004
Tmpv300(i,k) =tmpzy
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
! Tmpv001 =hatavg(i,k+1,j) -hatavg(i,k,j)
Tmpv001 =Keep_Lpb12_hatavg(i,k,j)
Tmpv301(i,k) =Tmpv001
Tmpv002 =Tmpv301(i,k)*tmpzy
Tmpv302(i,k) =Tmpv002
! Remarked by Ning Pan, 2010-08-31
! Tmpv003 =Tmpv302(i,k)*rdzw(i,k,j)
! tmp1(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
!REVISED BY WALLS
tmpzy =Tmpv300(i,k)
a_Tmpv3 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv2 =rdzw(i,k,j)*a_Tmpv3
a_rdzw(i,k,j) =a_rdzw(i,k,j) +Tmpv302(i,k)*a_Tmpv3
a_Tmpv1 =tmpzy*a_Tmpv2
a_tmpzy =a_tmpzy +Tmpv301(i,k)*a_Tmpv2
a_hatavg(i,k+1,j) =a_hatavg(i,k+1,j) +a_Tmpv1
a_hatavg(i,k,j) =a_hatavg(i,k,j) -a_Tmpv1
! tmpzy =Tmpv300(i,k)
a_Tmpv4 =a_tmpzy
a_tmpzy =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zy(i,k+1,j+1) =a_zy(i,k+1,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zy(i,k+1,j) =a_zy(i,k+1,j) +a_Tmpv2
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
a_zy(i,k,j+1) =a_zy(i,k,j+1) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[11]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO i =i_start, i_end
! Tmpv001 =cf1*hat(i,1,j) +cf2*hat(i,2,j)
! Tmpv002 =Tmpv001 +cf3*hat(i,3,j)
! Tmpv003 =Tmpv002 +cf1*hat(i,1,j+1)
! Tmpv004 =Tmpv003 +cf2*hat(i,2,j+1)
! Tmpv005 =Tmpv004 +cf3*hat(i,3,j+1)
! Tmpv006 =0.5*Tmpv005
! hatavg(i,1,j) =Tmpv006
! Tmpv001 =hat(i,ktes1,j) +hat(i,ktes1,j+1)
! Tmpv200(i) =Tmpv001
! Tmpv002 =cft1*Tmpv200(i)
! Tmpv003 =hat(i,ktes2,j) +hat(i,ktes2,j+1)
! Tmpv201(i) =Tmpv003
! Tmpv004 =cft2*Tmpv201(i)
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,kte,j) =Tmpv006
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,kte,j)
a_hatavg(i,kte,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
! a_cft2 =a_cft2 +Tmpv201(i)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =cft2*a_Tmpv4
a_hat(i,ktes2,j) =a_hat(i,ktes2,j) +a_Tmpv3
a_hat(i,ktes2,j+1) =a_hat(i,ktes2,j+1) +a_Tmpv3
! a_cft1 =a_cft1 +Tmpv200(i)*a_Tmpv2 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv1 =cft1*a_Tmpv2
a_hat(i,ktes1,j) =a_hat(i,ktes1,j) +a_Tmpv1
a_hat(i,ktes1,j+1) =a_hat(i,ktes1,j+1) +a_Tmpv1
a_Tmpv6 =a_hatavg(i,1,j)
a_hatavg(i,1,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_hat(i,3,j+1) =a_hat(i,3,j+1) +cf3*a_Tmpv5
a_Tmpv3 =a_Tmpv4
a_hat(i,2,j+1) =a_hat(i,2,j+1) +cf2*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_hat(i,1,j+1) =a_hat(i,1,j+1) +cf1*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_hat(i,3,j) =a_hat(i,3,j) +cf3*a_Tmpv2
a_hat(i,1,j) =a_hat(i,1,j) +cf1*a_Tmpv1
a_hat(i,2,j) =a_hat(i,2,j) +cf2*a_Tmpv1
ENDDO
ENDDO
!LPB[10]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) +hat(i,k,j+1)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =hat(i,k-1,j) +hat(i,k-1,j+1)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,k,j)
a_hatavg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_hat(i,k-1,j) =a_hat(i,k-1,j) +a_Tmpv3
a_hat(i,k-1,j+1) =a_hat(i,k-1,j+1) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i,k,j+1) =a_hat(i,k,j+1) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[9]
DO j =j_end+1, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! IF((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
! hat(i,k,j) =0.
! ELSE
! hat(i,k,j) =v(i,k,j)/msfvx(i,j)
! ENDIF
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
IF((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
a_hat(i,k,j) =0.0
ELSE
a_v(i,k,j) =a_v(i,k,j) +1.0/msfvx(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDIF
ENDDO
ENDDO
ENDDO
!BIG ERRORS, REVISED BY WALLS
! hat =Keep_Lpb2_hat ! Remarked by Ning Pan, 2010-08-31
!LPB[8]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! div(i,k,j) =tmp1(i,k,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +a_div(i,k,j)
a_div(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!LPB[7]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! defor11(i,k,j) =2.0*tmp1(i,k,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_tmp1(i,k,j) =a_tmp1(i,k,j) +2.0*a_defor11(i,k,j)
a_defor11(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!LPB[6]
DO j =j_end, j_start, -1
!REVISED BY WALLS
! DO k=kts, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! Remarked by Ning Pan, 2010-08-31
! DO k=kts, ktf
! DO i=i_start, i_end
! tmp1(i,k,j) =Keep_Lpb6_tmp1(i,k,j)
! END DO
! END DO
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i+1,k,j) -hat(i,k,j)
! Tmpv002 =rdx*Tmpv001
! Tmpv003 =Tmpv002 -tmp1(i,k,j)
! Tmpv300(i,k) =Tmpv003
! Tmpv004 =mm(i,j)*Tmpv300(i,k)
! tmp1(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
! a_mm(i,j) =a_mm(i,j) +Tmpv300(i,k)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =mm(i,j)*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp1(i,k,j) =a_tmp1(i,k,j) -a_Tmpv3
a_Tmpv1 =rdx*a_Tmpv2
a_hat(i+1,k,j) =a_hat(i+1,k,j) +a_Tmpv1
a_hat(i,k,j) =a_hat(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[5]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =zx(i,k,j) +zx(i+1,k,j)
Tmpv002 =Tmpv001 +zx(i,k+1,j)
Tmpv003 =Tmpv002 +zx(i+1,k+1,j)
Tmpv004 =0.25*Tmpv003
tmpzx =Tmpv004
Tmpv300(i,k) =tmpzx
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
! Tmpv001 =hatavg(i,k+1,j) -hatavg(i,k,j)
Tmpv001 =Keep_Lpb5_hatavg(i,k,j)
Tmpv301(i,k) =Tmpv001
Tmpv002 =Tmpv301(i,k)*tmpzx
Tmpv302(i,k) =Tmpv002
! Remarked by Ning Pan, 2010-08-31
! Tmpv003 =Tmpv302(i,k)*rdzw(i,k,j)
! tmp1(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
tmpzx =Tmpv300(i,k)
a_Tmpv3 =a_tmp1(i,k,j)
a_tmp1(i,k,j) =0.0
a_Tmpv2 =rdzw(i,k,j)*a_Tmpv3
a_rdzw(i,k,j) =a_rdzw(i,k,j) +Tmpv302(i,k)*a_Tmpv3
a_Tmpv1 =tmpzx*a_Tmpv2
a_tmpzx =a_tmpzx +Tmpv301(i,k)*a_Tmpv2
a_hatavg(i,k+1,j) =a_hatavg(i,k+1,j) +a_Tmpv1
a_hatavg(i,k,j) =a_hatavg(i,k,j) -a_Tmpv1
! tmpzx =Tmpv300(i,k)
a_Tmpv4 =a_tmpzx
a_tmpzx =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zx(i+1,k+1,j) =a_zx(i+1,k+1,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zx(i,k+1,j) =a_zx(i,k+1,j) +a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
a_zx(i+1,k,j) =a_zx(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[4]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-31
! DO i =i_start, i_end
! Tmpv001 =cf1*hat(i,1,j) +cf2*hat(i,2,j)
! Tmpv002 =Tmpv001 +cf3*hat(i,3,j)
! Tmpv003 =Tmpv002 +cf1*hat(i+1,1,j)
! Tmpv004 =Tmpv003 +cf2*hat(i+1,2,j)
! Tmpv005 =Tmpv004 +cf3*hat(i+1,3,j)
! Tmpv006 =0.5*Tmpv005
! hatavg(i,1,j) =Tmpv006
! Tmpv001 =hat(i,ktes1,j) +hat(i+1,ktes1,j)
! Tmpv200(i) =Tmpv001
! Tmpv002 =cft1*Tmpv200(i)
! Tmpv003 =hat(i,ktes2,j) +hat(i+1,ktes2,j)
! Tmpv201(i) =Tmpv003
! Tmpv004 =cft2*Tmpv201(i)
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,kte,j) =Tmpv006
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,kte,j)
a_hatavg(i,kte,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
! a_cft2 =a_cft2 +Tmpv201(i)*a_Tmpv4 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv3 =cft2*a_Tmpv4
a_hat(i,ktes2,j) =a_hat(i,ktes2,j) +a_Tmpv3
a_hat(i+1,ktes2,j) =a_hat(i+1,ktes2,j) +a_Tmpv3
! a_cft1 =a_cft1 +Tmpv200(i)*a_Tmpv2 ! Remarked by Ning Pan, 2010-08-31
a_Tmpv1 =cft1*a_Tmpv2
a_hat(i,ktes1,j) =a_hat(i,ktes1,j) +a_Tmpv1
a_hat(i+1,ktes1,j) =a_hat(i+1,ktes1,j) +a_Tmpv1
a_Tmpv6 =a_hatavg(i,1,j)
a_hatavg(i,1,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_hat(i+1,3,j) =a_hat(i+1,3,j) +cf3*a_Tmpv5
a_Tmpv3 =a_Tmpv4
a_hat(i+1,2,j) =a_hat(i+1,2,j) +cf2*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_hat(i+1,1,j) =a_hat(i+1,1,j) +cf1*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_hat(i,3,j) =a_hat(i,3,j) +cf3*a_Tmpv2
a_hat(i,1,j) =a_hat(i,1,j) +cf1*a_Tmpv1
a_hat(i,2,j) =a_hat(i,2,j) +cf2*a_Tmpv1
ENDDO
ENDDO
!LPB[3]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =hat(i,k,j) +hat(i+1,k,j)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =hat(i,k-1,j) +hat(i+1,k-1,j)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! hatavg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_hatavg(i,k,j)
a_hatavg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_hat(i,k-1,j) =a_hat(i,k-1,j) +a_Tmpv3
a_hat(i+1,k-1,j) =a_hat(i+1,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_hat(i,k,j) =a_hat(i,k,j) +a_Tmpv1
a_hat(i+1,k,j) =a_hat(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[2]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end+1
! hat(i,k,j) =u(i,k,j)/msfuy(i,j)
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end+1, i_start, -1
a_u(i,k,j) =a_u(i,k,j) +1.0/msfuy(i,j)*a_hat(i,k,j)
a_hat(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!LPB[1]
! Remarked by Ning Pan, 2010-08-31
! DO j =j_end, j_start, -1
!! DO i =i_start, i_end
!! mm(i,j) =msftx(i,j)*msfty(i,j)
!! ENDDO
! DO i =i_end, i_start, -1
! a_mm(i,j) =0.0
! ENDDO
! ENDDO
!LPB[0]
! ktes1 =kte-1
! ktes2 =kte-2
! cft2 =-0.5*dnw(ktes1)/dn(ktes1)
! cft1 =1.0 -cft2
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
! Remarked by Ning Pan, 2010-08-31
! a_cft2 =a_cft2 -a_cft1
! a_cft1 =0.0
! a_cft2 =0.0
END SUBROUTINE a_cal_deform_and_div
SUBROUTINE a_calculate_km_kh(config_flags,dt,dampcoef,zdamp,damp_opt,xkmh,a_xkmh, &
xkmv,a_xkmv,xkhh,a_xkhh,xkhv,a_xkhv,BN2,a_BN2,khdif,kvdif,div,a_div, &
defor11,a_defor11,defor22,a_defor22,defor33,a_defor33,defor12,a_defor12, &
defor13,a_defor13,defor23,a_defor23,tke,a_tke,p8w,a_p8w,t8w,a_t8w,theta, &
a_theta,t,a_t,p,a_p,moist,a_moist,dn,dnw,dx,dy,rdz,a_rdz,rdzw,a_rdzw, &
isotropic,n_moist,cf1,cf2,cf3,warm_rain,mix_upper_bound,msftx,msfty,zx,a_zx,zy,a_zy,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
INTEGER :: n_moist,damp_opt,isotropic,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,its,ite,jts,jte,kts,kte
LOGICAL :: warm_rain
REAL :: dx,dy,zdamp,dt,dampcoef,cf1,cf2,cf3,khdif,kvdif
REAL,DIMENSION(kms:kme) :: dnw,dn
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,a_moist
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmv,a_xkmv,xkmh,a_xkmh,xkhv,a_xkhv, &
xkhh,a_xkhh,BN2,a_BN2
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor22,a_defor22, &
defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,div, &
a_div,rdz,a_rdz,rdzw,a_rdzw,p8w,a_p8w,t8w,a_t8w,theta,a_theta,t,a_t,p,a_p,zx,a_zx,zy,a_zy
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,a_tke
REAL :: mix_upper_bound
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k!,km_opt
! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb3_xkmh
! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb3_xkhh
! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb3_xkmv
! REAL,DIMENSION(1,ims:ime,kms:kme,jms:jme) :: Keep_Lpb3_xkhv
INTEGER :: IX1,IX2,IX3
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv400
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv401
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv402
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv403
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv404
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv405
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv406
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv407
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv408
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv409
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv4010
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
CALL calculate_N2( config_flags, BN2, moist, &
theta, t, p, p8w, t8w, &
dnw, dn, rdz, rdzw, &
n_moist, cf1, cf2, cf3, warm_rain, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!LPB[1]
! km_opt =config_flags%km_opt
! km_opt =3
!REVISED BY WALLS
km_coef: SELECT CASE( config_flags%km_opt )
! km_coef: SELECT CASE( km_opt )
CASE (1)
CALL isotropic_km( config_flags, xkmh, xkmv, &
xkhh, xkhv, khdif, kvdif, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
CASE (2)
CALL tke_km( config_flags, xkmh, xkmv, &
xkhh, xkhv, BN2, tke, p8w, t8w, theta, &
rdz, rdzw, dx, dy, dt, isotropic, &
mix_upper_bound, msftx, msfty, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
CASE (3)
CALL smag_km( config_flags, xkmh, xkmv, &
xkhh, xkhv, BN2, div, &
defor11, defor22, defor33, &
defor12, defor13, defor23, &
rdzw, dx, dy, dt, isotropic, &
mix_upper_bound, msftx, msfty, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
CASE (4)
CALL smag2d_km( config_flags, xkmh, xkmv, &
xkhh, xkhv, defor11, defor22, defor12, &
rdzw, dx, dy, msftx, msfty, &
zx, zy, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
CASE DEFAULT
CALL wrf_error_fatal( 'Please choose diffusion coefficient scheme' )
END SELECT km_coef
!LPB[2]
!!LPB[3]
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb3_xkmh(IX1,IX2,IX3) =xkmh(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb3_xkhh(IX1,IX2,IX3) =xkhh(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb3_xkmv(IX1,IX2,IX3) =xkmv(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb3_xkhv(IX1,IX2,IX3) =xkhv(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
! IF ( damp_opt .eq. 1 ) THEN
! CALL cal_dampkm( config_flags, xkmh, xkhh, xkmv, xkhv, &
! dx, dy, dt, dampcoef, rdz, rdzw, zdamp, &
! msftx, msfty, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! END IF
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[3]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmh(IX1,IX2,IX3) =Keep_Lpb3_xkmh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhh(IX1,IX2,IX3) =Keep_Lpb3_xkhh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmv(IX1,IX2,IX3) =Keep_Lpb3_xkmv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhv(IX1,IX2,IX3) =Keep_Lpb3_xkhv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! IF( damp_opt .eq. 1 ) THEN
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv400(IX1,IX2,IX3) =xkmh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv401(IX1,IX2,IX3) =xkhh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv402(IX1,IX2,IX3) =xkmv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv403(IX1,IX2,IX3) =xkhv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL cal_dampkm(config_flags,xkmh,xkhh,xkmv,xkhv,dx,dy,dt,dampcoef,rdz,rdzw,zdamp, &
! msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! END IF
IF( damp_opt .eq. 1 ) THEN
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhv(IX1,IX2,IX3) =Tmpv403(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmv(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhh(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmh(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_cal_dampkm(config_flags,xkmh,a_xkmh,xkhh,a_xkhh,xkmv,a_xkmv,xkhv, &
a_xkhv,dx,dy,dt,dampcoef,rdz,a_rdz,rdzw,a_rdzw,zdamp,msftx,msfty,ids,ide,jds, &
jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
END IF
!LPB[2]
! Remarked by Ning Pan, 2010-08-18 : recalculation of LPB[1]
!LPB[1]
! SELECT CASE (config_flags%km_opt)
!! SELECT CASE (km_opt)
! CASE(1)
! CALL isotropic_km(config_flags,xkmh,xkmv,xkhh,xkhv,khdif,kvdif,ids,ide,jds,jde, &
! kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! CASE(2)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv400(IX1,IX2,IX3) =xkmh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv401(IX1,IX2,IX3) =xkmv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv402(IX1,IX2,IX3) =xkhh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL tke_km(config_flags,xkmh,xkmv,xkhh,xkhv,BN2,tke,p8w,t8w,theta,rdz,rdzw,dx,dy, &
! dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
! kme,its,ite,jts,jte,kts,kte)
! CASE(3)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv403(IX1,IX2,IX3) =xkmh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv404(IX1,IX2,IX3) =xkmv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv405(IX1,IX2,IX3) =xkhh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv406(IX1,IX2,IX3) =xkhv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL smag_km(config_flags,xkmh,xkmv,xkhh,xkhv,BN2,div,defor11,defor22,defor33, &
! defor12,defor13,defor23,rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide, &
! jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! CASE(4)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv407(IX1,IX2,IX3) =xkmh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv408(IX1,IX2,IX3) =xkmv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv409(IX1,IX2,IX3) =xkhh(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv4010(IX1,IX2,IX3) =xkhv(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL smag2d_km(config_flags,xkmh,xkmv,xkhh,xkhv,defor11,defor22,defor12,rdzw,dx, &
! dy,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! CASE DEFAULT
! CALL wrf_error_fatal('Please choose diffusion coefficient scheme')
!REVISED! BY WALLS
!! END SELECT km_coef
! END SELECT
SELECT CASE (config_flags%km_opt)
! SELECT CASE (km_opt)
CASE(1)
CALL a_isotropic_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv, &
a_xkhv,khdif,kvdif,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CASE(2)
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhh(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmv(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmh(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_tke_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv, &
a_xkhv,BN2,a_BN2,tke,a_tke,p8w,a_p8w,t8w,a_t8w,theta,a_theta,rdz,a_rdz, &
rdzw,a_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CASE(3)
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhv(IX1,IX2,IX3) =Tmpv406(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhh(IX1,IX2,IX3) =Tmpv405(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmv(IX1,IX2,IX3) =Tmpv404(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmh(IX1,IX2,IX3) =Tmpv403(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_smag_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv, &
a_xkhv,BN2,a_BN2,div,a_div,defor11,a_defor11,defor22,a_defor22,defor33, &
a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,rdzw, &
a_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,ids,ide,jds,jde,kds,kde,ims, &
ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CASE(4)
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhv(IX1,IX2,IX3) =Tmpv4010(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkhh(IX1,IX2,IX3) =Tmpv409(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmv(IX1,IX2,IX3) =Tmpv408(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-18
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! xkmh(IX1,IX2,IX3) =Tmpv407(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_smag2d_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv, &
a_xkhv,defor11,a_defor11,defor22,a_defor22,defor12,a_defor12,rdzw,a_rdzw, &
dx,dy,msftx,msfty,zx,a_zx,zy,a_zy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CASE DEFAULT
!REVISED BY WALLS
! CALL a_wrf_error_fatal('Please choose diffusion coefficient scheme')
CALL wrf_error_fatal('Please choose diffusion coefficient scheme')
!REVISED BY WALLS
! END SELECT km_coef
END SELECT
!LPB[0]
! Remarked by Ning Pan, 2010-08-18
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
!DELETED BY WALLS
! CALL calculate_N2(config_flags,BN2,moist,theta,t,p,p8w,t8w,dnw,dn,rdz,rdzw, &
! n_moist,cf1,cf2,cf3,warm_rain,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
! ite,jts,jte,kts,kte)
!REVISED BY WALLS
! CALL a_calculate_N2(config_flags,BN2,a_BN2,moist,a_moist,theta,a_theta,t, &
! a_t,p,a_p,p8w,a_p8w,t8w,a_t8w,dnw,dn,rdz,a_rdz,rdzw,a_rdzw,n_moist,cf1, &
! cf2,cf3,,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CALL a_calculate_N2(config_flags,BN2,a_BN2,moist,a_moist,theta,a_theta,t, &
a_t,p,a_p,p8w,a_p8w,t8w,a_t8w,dnw,dn,rdz,a_rdz,rdzw,a_rdzw,n_moist,cf1, &
cf2,cf3,warm_rain,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
END SUBROUTINE a_calculate_km_kh
SUBROUTINE a_cal_dampkm(config_flags,xkmh,a_xkmh,xkhh,a_xkhh,xkmv,a_xkmv, &
xkhv,a_xkhv,dx,dy,dt,dampcoef,rdz,a_rdz,rdzw,a_rdzw,zdamp,msftx,msfty,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: zdamp,dx,dy,dt,dampcoef
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,a_xkmh,xkhh,a_xkhh,xkmv,a_xkmv, &
xkhv,a_xkhv
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i_start,i_end,j_start,j_end,ktf,ktfm1,i,j,k
REAL :: kmmax,kmmvmax,a_kmmvmax,degrad90,dz,a_dz,tmp,a_tmp
REAL :: ds
REAL,DIMENSION(its:ite) :: deltaz,a_deltaz
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dampk,a_dampk,dampkv,a_dampkv
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002
!REVISED BY WALLS
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS) :: Tmpv200
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS) :: Tmpv201
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS) :: Tmpv202
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS,kts:min(kte,kde-1)-1) :: Tmpv300
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS,kts:min(kte,kde-1)-1) :: Tmpv301
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS,kts:min(kte,kde-1)-1) :: Tmpv302
! REAL,DIMENSION(REVISEDBYWALLS:REVISEDBYWALLS,kts:min(kte,kde-1)-1) :: Tmpv303
REAL,DIMENSION(its:MIN(ite,ide-1)) :: Tmpv200
REAL,DIMENSION(its:MIN(ite,ide-1)) :: Tmpv201
REAL,DIMENSION(its:MIN(ite,ide-1)) :: Tmpv202
REAL,DIMENSION(its:MIN(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv300
REAL,DIMENSION(its:MIN(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv301
REAL,DIMENSION(its:MIN(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv302
REAL,DIMENSION(its:MIN(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv303
REAL,DIMENSION(its:MIN(ite,ide-1),kts:min(kte,kde-1)-1) :: Tmpv304
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = min(kte,kde-1)
ktfm1 = ktf-1
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF(config_flags%specified .OR. config_flags%nested)THEN
i_start = MAX(i_start,ids+config_flags%spec_bdy_width-1)
i_end = MIN(i_end,ide-config_flags%spec_bdy_width)
j_start = MAX(j_start,jds+config_flags%spec_bdy_width-1)
j_end = MIN(j_end,jde-config_flags%spec_bdy_width)
ENDIF
!LPB[2]
kmmax=dx*dx/dt
degrad90=DEGRAD*90.
!LPB[3]
DO j = j_start, j_end
k=ktf
DO i = i_start, i_end
ds = MIN(dx/msftx(i,j),dy/msfty(i,j))
kmmax=ds*ds/dt
dz = 1./rdzw(i,k,j)
deltaz(i) = 0.5*dz
kmmvmax=dz*dz/dt
tmp=min(deltaz(i)/zdamp,1.)
dampk(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef
dampkv(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax*dampcoef
dampkv(i,k,j)=min(dampkv(i,k,j),dampk(i,k,j))
ENDDO
DO k = ktfm1,kts,-1
DO i = i_start, i_end
ds = MIN(dx/msftx(i,j),dy/msfty(i,j))
kmmax=ds*ds/dt
dz = 1./rdz(i,k,j)
deltaz(i) = deltaz(i) + dz
dz = 1./rdzw(i,k,j)
kmmvmax=dz*dz/dt
tmp=min(deltaz(i)/zdamp,1.)
dampk(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef
dampkv(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax*dampcoef
dampkv(i,k,j)=min(dampkv(i,k,j),dampk(i,k,j))
ENDDO
ENDDO
ENDDO
!!LPB[4]
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! xkmh(i,k,j)=max(xkmh(i,k,j),dampk(i,k,j))
! xkhh(i,k,j)=max(xkhh(i,k,j),dampk(i,k,j))
! xkmv(i,k,j)=max(xkmv(i,k,j),dampkv(i,k,j))
! xkhv(i,k,j)=max(xkhv(i,k,j),dampkv(i,k,j))
! ENDDO
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
a_kmmvmax =0.0
a_dz =0.0
a_tmp =0.0
Do K0_ADJ =its, ite
a_deltaz(K0_ADJ) =0.0
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_dampk(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_dampkv(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[4]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =max(xkmh(i,k,j), dampk(i,k,j))
! xkmh(i,k,j) =Tmpv001
! Tmpv001 =max(xkhh(i,k,j), dampk(i,k,j))
! xkhh(i,k,j) =Tmpv001
! Tmpv001 =max(xkmv(i,k,j), dampkv(i,k,j))
! xkmv(i,k,j) =Tmpv001
! Tmpv001 =max(xkhv(i,k,j), dampkv(i,k,j))
! xkhv(i,k,j) =Tmpv001
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_xkhv(i,k,j) =a_xkhv(i,k,j) +(1.0 +sign(1.0, xkhv(i,k,j) -dampkv(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_dampkv(i,k,j) =a_dampkv(i,k,j) +(1.0 -sign(1.0, xkhv(i,k,j) -dampkv(i,k,j)) &
)*0.5*1.0*a_Tmpv1
a_Tmpv1 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +(1.0 +sign(1.0, xkmv(i,k,j) -dampkv(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_dampkv(i,k,j) =a_dampkv(i,k,j) +(1.0 -sign(1.0, xkmv(i,k,j) -dampkv(i,k,j)) &
)*0.5*1.0*a_Tmpv1
a_Tmpv1 =a_xkhh(i,k,j)
a_xkhh(i,k,j) =0.0
a_xkhh(i,k,j) =a_xkhh(i,k,j) +(1.0 +sign(1.0, xkhh(i,k,j) -dampk(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_dampk(i,k,j) =a_dampk(i,k,j) +(1.0 -sign(1.0, xkhh(i,k,j) -dampk(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_Tmpv1 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +(1.0 +sign(1.0, xkmh(i,k,j) -dampk(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_dampk(i,k,j) =a_dampk(i,k,j) +(1.0 -sign(1.0, xkmh(i,k,j) -dampk(i,k,j))) &
*0.5*1.0*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[3]
DO j =j_end, j_start, -1
k =ktf
DO i =i_start, i_end
ds =min(dx/msftx(i,j), dy/msfty(i,j))
kmmax =ds*ds/dt
dz =1./rdzw(i,k,j)
Tmpv200(i) =dz
deltaz(i) =0.5*dz
kmmvmax =dz*dz/dt
Tmpv201(i) =kmmvmax
tmp =min(deltaz(i)/zdamp, 1.)
Tmpv202(i) =tmp
dampk(i,k,j) =cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef
Tmpv001 =cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax
Tmpv002 =Tmpv001*dampcoef
dampkv(i,k,j) =Tmpv002
Tmpv001 =min(dampkv(i,k,j), dampk(i,k,j))
dampkv(i,k,j) =Tmpv001
ENDDO
DO k =ktfm1, kts, -1
DO i =i_start, i_end
ds =min(dx/msftx(i,j), dy/msfty(i,j))
kmmax =ds*ds/dt
dz =1./rdz(i,k,j)
Tmpv300(i,k) =dz
Tmpv001 =deltaz(i) +dz
deltaz(i) =Tmpv001
dz =1./rdzw(i,k,j)
Tmpv301(i,k) =dz
kmmvmax =dz*dz/dt
Tmpv302(i,k) =kmmvmax
tmp =min(deltaz(i)/zdamp, 1.)
Tmpv303(i,k) =tmp
Tmpv304(i,k) =deltaz(i)
dampk(i,k,j) =cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef
Tmpv001 =cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax
Tmpv002 =Tmpv001*dampcoef
dampkv(i,k,j) =Tmpv002
Tmpv001 =min(dampkv(i,k,j), dampk(i,k,j))
dampkv(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =kts, ktfm1, 1
DO i =i_end, i_start, -1
!ADDED BY WALLS
ds =min(dx/msftx(i,j), dy/msfty(i,j))
kmmax =ds*ds/dt
kmmvmax =Tmpv302(i,k)
tmp =Tmpv303(i,k)
deltaz(i)=Tmpv304(i,k)
dz =Tmpv301(i,k)
a_Tmpv1 =a_dampkv(i,k,j)
a_dampkv(i,k,j) =0.0
a_dampkv(i,k,j) =a_dampkv(i,k,j) +(1.0 -sign(1.0, dampkv(i,k,j) -dampk(i,k,j) &
))*0.5*1.0*a_Tmpv1
a_dampk(i,k,j) =a_dampk(i,k,j) +(1.0 +sign(1.0, dampkv(i,k,j) -dampk(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_Tmpv2 =a_dampkv(i,k,j)
a_dampkv(i,k,j) =0.0
a_Tmpv1 =dampcoef*a_Tmpv2
a_tmp =a_tmp -2.0*cos(degrad90*tmp)*degrad90*sin(degrad90*tmp)*kmmvmax*a_Tmpv1
a_kmmvmax =a_kmmvmax +cos(degrad90*tmp)*cos(degrad90*tmp)*a_Tmpv1
a_tmp =a_tmp -2.0*cos(degrad90*tmp)*degrad90*sin(degrad90*tmp)*kmmax*dampcoef* &
a_dampk(i,k,j)
a_dampk(i,k,j) =0.0
! tmp =Tmpv303(i,k)
a_deltaz(i) =a_deltaz(i) +(1.0/zdamp -(1.0/zdamp)*sign(1.0, deltaz(i) &
/zdamp -1.))*0.5*a_tmp
a_tmp =0.0
! kmmvmax =Tmpv302(i,k)
a_dz =a_dz +2.0*dz/dt*a_kmmvmax
a_kmmvmax =0.0
! dz =Tmpv301(i,k)
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_dz
a_dz =0.0
a_Tmpv1 =a_deltaz(i)
a_deltaz(i) =0.0
a_deltaz(i) =a_deltaz(i) +a_Tmpv1
a_dz =a_dz +a_Tmpv1
dz =Tmpv300(i,k)
a_rdz(i,k,j) =a_rdz(i,k,j) -1./(rdz(i,k,j)*rdz(i,k,j))*a_dz
a_dz =0.0
ENDDO
ENDDO
!ADDED BY WALLS
k =ktf
DO i =i_end, i_start, -1
!ADDED BY WALLS
ds =min(dx/msftx(i,j), dy/msfty(i,j))
kmmax =ds*ds/dt
tmp =Tmpv202(i)
kmmvmax =Tmpv201(i)
dz =Tmpv200(i)
!ADDED BY WALLS
deltaz(i) =0.5*dz
a_Tmpv1 =a_dampkv(i,k,j)
a_dampkv(i,k,j) =0.0
a_dampkv(i,k,j) =a_dampkv(i,k,j) +(1.0 -sign(1.0, dampkv(i,k,j) -dampk(i,k,j) &
))*0.5*1.0*a_Tmpv1
a_dampk(i,k,j) =a_dampk(i,k,j) +(1.0 +sign(1.0, dampkv(i,k,j) -dampk(i,k,j))) &
*0.5*1.0*a_Tmpv1
a_Tmpv2 =a_dampkv(i,k,j)
a_dampkv(i,k,j) =0.0
a_Tmpv1 =dampcoef*a_Tmpv2
a_tmp =a_tmp -2.0*cos(degrad90*tmp)*degrad90*sin(degrad90*tmp)*kmmvmax*a_Tmpv1
a_kmmvmax =a_kmmvmax +cos(degrad90*tmp)*cos(degrad90*tmp)*a_Tmpv1
a_tmp =a_tmp -2.0*cos(degrad90*tmp)*degrad90*sin(degrad90*tmp)*kmmax*dampcoef* &
a_dampk(i,k,j)
a_dampk(i,k,j) =0.0
a_deltaz(i) =a_deltaz(i) +(1.0/zdamp -(1.0/zdamp)*sign(1.0, deltaz(i) &
/zdamp -1.))*0.5*a_tmp
a_tmp =0.0
a_dz =a_dz +2.0*dz/dt*a_kmmvmax
a_kmmvmax =0.0
a_dz =a_dz +0.5*a_deltaz(i)
a_deltaz(i) =0.0
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_dz
a_dz =0.0
ENDDO
ENDDO
!LPB[2]
! kmmax =dx*dx/dt
! degrad90 =DEGRAD*90.
!LPB[1]
! IF(config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(i_start, ids +config_flags%spec_bdy_width -1)
! i_end =min(i_end, ide -config_flags%spec_bdy_width)
! j_start =max(j_start, jds +config_flags%spec_bdy_width -1)
! j_end =min(j_end, jde -config_flags%spec_bdy_width)
! ENDIF
IF(config_flags%specified .OR. config_flags%nested) THEN
ENDIF
!LPB[0]
! ktf =min(kte, kde-1)
! ktfm1 =ktf-1
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_cal_dampkm
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of calculate_n2 in reverse (adjoint) mode:
! gradient of useful results: p t t8w bn2 theta rdzw rdz
! moist p8w
! with respect to varying inputs: p t t8w bn2 theta rdzw rdz
! moist p8w
! RW status of diff variables: p:incr t:incr t8w:incr bn2:in-out
! theta:incr rdzw:incr rdz:incr moist:incr p8w:incr
SUBROUTINE A_CALCULATE_N2(config_flags, bn2, bn2b, moist, moistb, theta&
& , thetab, t, tb, p, pb, p8w, p8wb, t8w, t8wb, dnw, dn, rdz, rdzb, rdzw&
& , rdzwb, n_moist, cf1, cf2, cf3, warm_rain, ids, ide, jds, jde, kds, &
& kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
! end of MARTA/WCS change
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: n_moist, ids, ide, jds, jde, kds, kde, ims, ime&
& , jms, jme, kms, kme, its, ite, jts, jte, kts, kte
LOGICAL, INTENT(IN) :: warm_rain
REAL, INTENT(IN) :: cf1, cf2, cf3
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: bn2
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: bn2b
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdz, rdzw, &
& theta, t, p, p8w, t8w
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rdzb, rdzwb, thetab, tb&
& , pb, p8wb, t8wb
REAL, DIMENSION(kms:kme), INTENT(IN) :: dnw, dn
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(INOUT) :: &
& moist
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist) :: moistb
! Local variables.
INTEGER :: i, j, k, ktf, ispe, ktes1, ktes2, i_start, i_end, j_start, &
& j_end
REAL :: coefa, thetaep1, thetaem1, qc_cr, es, tc, qlpqi, qsw, qsi, &
& tmpdz, xlvqv, thetaesfc, thetasfc, qvtop, qvsfc, thetatop, thetaetop
REAL :: coefab, thetaep1b, thetaem1b, esb, tcb, tmpdzb, xlvqvb, &
& thetaesfcb, thetasfcb, qvsfcb
REAL, DIMENSION(its:ite, jts:jte) :: tmp1sfc, tmp1top
REAL, DIMENSION(its:ite, jts:jte) :: tmp1sfcb
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: tmp1, qvs, qctmp
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: tmp1b, qvsb
INTEGER :: branch
REAL :: temp3
REAL :: temp2
REAL :: temp1
REAL :: temp0
REAL :: temp7b
REAL :: temp21b
REAL :: temp22
REAL :: temp9b0
REAL :: temp21
REAL :: temp20
REAL :: temp0b
REAL :: temp19
REAL :: temp18
REAL :: temp17
REAL :: temp16
REAL :: temp15
REAL :: temp20b
REAL :: temp14
REAL :: temp13
REAL :: temp12
REAL :: temp11
REAL :: temp10
REAL :: temp15b
REAL :: temp9b
REAL :: temp21b0
REAL :: temp18b
REAL :: tempb
REAL :: temp14b0
REAL :: temp0b0
REAL :: temp2b
REAL :: temp5b
REAL :: temp14b
REAL :: temp22b
REAL :: temp22b4
REAL :: temp22b3
REAL :: temp22b2
REAL :: temp22b1
REAL :: temp22b0
REAL :: temp1b
REAL :: temp
REAL :: temp9
REAL :: temp10b4
REAL :: temp8
REAL :: temp10b3
REAL :: temp7
REAL :: temp10b
REAL :: temp1b0
REAL :: temp10b2
REAL :: temp6
REAL :: temp10b1
REAL :: temp5
REAL :: temp10b0
REAL :: temp4
! End declarations.
!-----------------------------------------------------------------------
! in Kg/Kg
qc_cr = 0.00001
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
IF ((config_flags%open_xs .OR. config_flags%specified) .OR. &
& config_flags%nested) 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. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
IF ((config_flags%open_ys .OR. config_flags%specified) .OR. &
& config_flags%nested) 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. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
IF (p_qc .GT. param_first_scalar) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
qctmp(i, k, j) = moist(i, k, j, p_qc)
END DO
END DO
END DO
ELSE
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
qctmp(i, k, j) = 0.0
END DO
END DO
END DO
END IF
DO j=jts,jte
DO k=kts,kte
DO i=its,ite
tmp1(i, k, j) = 0.0
END DO
END DO
END DO
DO j=jts,jte
DO i=its,ite
tmp1sfc(i, j) = 0.0
END DO
END DO
DO ispe=param_first_scalar,n_moist
IF ((ispe .EQ. p_qv .OR. ispe .EQ. p_qc) .OR. ispe .EQ. p_qi) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
tmp1(i, k, j) = tmp1(i, k, j) + moist(i, k, j, ispe)
END DO
END DO
END DO
DO j=j_start,j_end
DO i=i_start,i_end
tmp1sfc(i, j) = tmp1sfc(i, j) + cf1*moist(i, 1, j, ispe) + cf2&
& *moist(i, 2, j, ispe) + cf3*moist(i, 3, j, ispe)
END DO
END DO
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
! Calculate saturation mixing ratio.
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
tc = t(i, k, j) - svpt0
CALL PUSHREAL8(es)
es = 1000.0*svp1*EXP(svp2*tc/(t(i, k, j)-svp3))
qvs(i, k, j) = ep_2*es/(p(i, k, j)-es)
END DO
END DO
END DO
DO j=j_start,j_end
DO k=kts+1,ktf-1
DO i=i_start,i_end
IF (moist(i, k, j, p_qv) .GE. qvs(i, k, j) .OR. qctmp(i, k, j) &
& .GE. qc_cr) THEN
xlvqv = xlv*moist(i, k, j, p_qv)
CALL PUSHREAL8(coefa)
coefa = (1.0+xlvqv/r_d/t(i, k, j))/(1.0+xlv*xlvqv/cp/r_v/t(i, &
& k, j)/t(i, k, j))/theta(i, k, j)
CALL PUSHREAL8(thetaep1)
thetaep1 = theta(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+&
& 1, j))
CALL PUSHREAL8(thetaem1)
thetaem1 = theta(i, k-1, j)*(1.0+xlv*qvs(i, k-1, j)/cp/t(i, k-&
& 1, j))
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
END DO
END DO
k = kts
DO j=j_start,j_end
DO i=i_start,i_end
tmpdz = 1.0/rdz(i, k+1, j) + 0.5/rdzw(i, k, j)
thetasfc = t8w(i, kts, j)/(p8w(i, k, j)/p1000mb)**(r_d/cp)
IF (moist(i, k, j, p_qv) .GE. qvs(i, k, j) .OR. qctmp(i, k, j) &
& .GE. qc_cr) THEN
CALL PUSHREAL8(qvsfc)
xlvqv = xlv*moist(i, k, j, p_qv)
CALL PUSHREAL8(coefa)
coefa = (1.0+xlvqv/r_d/t(i, k, j))/(1.0+xlv*xlvqv/cp/r_v/t(i, k&
& , j)/t(i, k, j))/theta(i, k, j)
CALL PUSHREAL8(thetaep1)
thetaep1 = theta(i, k+1, j)*(1.0+xlv*qvs(i, k+1, j)/cp/t(i, k+1&
& , j))
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(qvsfc)
qvsfc = cf1*moist(i, 1, j, p_qv) + cf2*moist(i, 2, j, p_qv) + &
& cf3*moist(i, 3, j, p_qv)
! BN2(i,k,j) = g * ( ( theta(i,k+1,j) - thetasfc ) / &
! theta(i,k,j) / tmpdz + &
! 1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) / &
! tmpdz - &
! ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz )
!...... MARTA: change in computation of BN2 at the surface, WCS 040331
! controlare come calcola rdzw
! end of MARTA/WCS change
CALL PUSHCONTROL1B(0)
END IF
END DO
END DO
DO j=j_end,j_start,-1
DO i=i_end,i_start,-1
bn2b(i, ktf-1, j) = bn2b(i, ktf-1, j) + bn2b(i, ktf, j)
bn2b(i, ktf, j) = 0.0
END DO
END DO
tmp1b = 0.0
tmp1sfcb = 0.0
qvsb = 0.0
DO j=j_end,j_start,-1
DO i=i_end,i_start,-1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
tmpdz = 1./rdzw(i, k, j)
temp22 = theta(i, k, j)
temp22b0 = g*bn2b(i, k, j)
temp22b1 = temp22b0/(temp22*tmpdz)
temp22b2 = -((theta(i, k+1, j)-theta(i, k, j))*temp22b1/(temp22*&
& tmpdz))
temp22b3 = 1.61*temp22b0/tmpdz
temp22b4 = -(temp22b0/tmpdz)
thetab(i, k+1, j) = thetab(i, k+1, j) + temp22b1
thetab(i, k, j) = thetab(i, k, j) + tmpdz*temp22b2 - temp22b1
tmpdzb = temp22*temp22b2 - (moist(i, k+1, j, p_qv)-qvsfc)*&
& temp22b3/tmpdz - (tmp1(i, k+1, j)-tmp1sfc(i, j))*temp22b4/&
& tmpdz
moistb(i, k+1, j, p_qv) = moistb(i, k+1, j, p_qv) + temp22b3
qvsfcb = -temp22b3
tmp1b(i, k+1, j) = tmp1b(i, k+1, j) + temp22b4
tmp1sfcb(i, j) = tmp1sfcb(i, j) - temp22b4
bn2b(i, k, j) = 0.0
rdzwb(i, k, j) = rdzwb(i, k, j) - tmpdzb/rdzw(i, k, j)**2
CALL POPREAL8(qvsfc)
moistb(i, 1, j, p_qv) = moistb(i, 1, j, p_qv) + cf1*qvsfcb
moistb(i, 2, j, p_qv) = moistb(i, 2, j, p_qv) + cf2*qvsfcb
moistb(i, 3, j, p_qv) = moistb(i, 3, j, p_qv) + cf3*qvsfcb
tmpdzb = 0.0
thetasfcb = 0.0
ELSE
tmpdz = 1.0/rdz(i, k+1, j) + 0.5/rdzw(i, k, j)
thetasfc = t8w(i, kts, j)/(p8w(i, k, j)/p1000mb)**(r_d/cp)
qvsfc = cf1*qvs(i, 1, j) + cf2*qvs(i, 2, j) + cf3*qvs(i, 3, j)
thetaesfc = thetasfc*(1.0+xlv*qvsfc/cp/t8w(i, kts, j))
temp21 = coefa/tmpdz
temp21b = g*bn2b(i, k, j)
temp21b0 = (thetaep1-thetaesfc)*temp21b/tmpdz
temp22b = -(temp21b/tmpdz)
thetaep1b = temp21*temp21b
thetaesfcb = -(temp21*temp21b)
coefab = temp21b0
tmpdzb = -((tmp1(i, k+1, j)-tmp1sfc(i, j))*temp22b/tmpdz) - &
& temp21*temp21b0
tmp1b(i, k+1, j) = tmp1b(i, k+1, j) + temp22b
tmp1sfcb(i, j) = tmp1sfcb(i, j) - temp22b
bn2b(i, k, j) = 0.0
temp20 = cp*t8w(i, kts, j)
temp20b = xlv*thetasfc*thetaesfcb/temp20
thetasfcb = (xlv*(qvsfc/temp20)+1.0)*thetaesfcb
qvsfcb = temp20b
t8wb(i, kts, j) = t8wb(i, kts, j) - qvsfc*cp*temp20b/temp20
CALL POPREAL8(thetaep1)
temp19 = cp*t(i, k+1, j)
temp18 = qvs(i, k+1, j)/temp19
temp18b = xlv*theta(i, k+1, j)*thetaep1b/temp19
thetab(i, k+1, j) = thetab(i, k+1, j) + (xlv*temp18+1.0)*&
& thetaep1b
qvsb(i, k+1, j) = qvsb(i, k+1, j) + temp18b
tb(i, k+1, j) = tb(i, k+1, j) - temp18*cp*temp18b
xlvqv = xlv*moist(i, k, j, p_qv)
CALL POPREAL8(coefa)
temp17 = cp*r_v*t(i, k, j)**2
temp15 = xlvqv/temp17
temp14 = (xlv*temp15+1.0)*theta(i, k, j)
temp14b = coefab/temp14
temp16 = r_d*t(i, k, j)
temp14b0 = -((xlvqv/temp16+1.0)*temp14b/temp14)
temp15b = xlv*theta(i, k, j)*temp14b0/temp17
xlvqvb = temp15b + temp14b/temp16
tb(i, k, j) = tb(i, k, j) - cp*r_v*temp15*2*t(i, k, j)*temp15b -&
& xlvqv*r_d*temp14b/temp16**2
thetab(i, k, j) = thetab(i, k, j) + (xlv*temp15+1.0)*temp14b0
moistb(i, k, j, p_qv) = moistb(i, k, j, p_qv) + xlv*xlvqvb
CALL POPREAL8(qvsfc)
qvsb(i, 1, j) = qvsb(i, 1, j) + cf1*qvsfcb
qvsb(i, 2, j) = qvsb(i, 2, j) + cf2*qvsfcb
qvsb(i, 3, j) = qvsb(i, 3, j) + cf3*qvsfcb
END IF
temp13 = r_d/cp
temp12 = p8w(i, k, j)/p1000mb
temp11 = temp12**temp13
t8wb(i, kts, j) = t8wb(i, kts, j) + thetasfcb/temp11
IF (.NOT.(temp12 .LE. 0.0 .AND. (temp13 .EQ. 0.0 .OR. temp13 .NE. &
& INT(temp13)))) p8wb(i, k, j) = p8wb(i, k, j) - temp13*temp12**&
& (temp13-1)*t8w(i, kts, j)*thetasfcb/(temp11**2*p1000mb)
rdzb(i, k+1, j) = rdzb(i, k+1, j) - tmpdzb/rdz(i, k+1, j)**2
rdzwb(i, k, j) = rdzwb(i, k, j) - 0.5*tmpdzb/rdzw(i, k, j)**2
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf-1,kts+1,-1
DO i=i_end,i_start,-1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
tmpdz = 1.0/rdz(i, k, j) + 1.0/rdz(i, k+1, j)
temp10 = theta(i, k, j)
temp10b0 = g*bn2b(i, k, j)
temp10b1 = temp10b0/(temp10*tmpdz)
temp10b2 = -((theta(i, k+1, j)-theta(i, k-1, j))*temp10b1/(&
& temp10*tmpdz))
temp10b3 = 1.61*temp10b0/tmpdz
temp10b4 = -(temp10b0/tmpdz)
thetab(i, k+1, j) = thetab(i, k+1, j) + temp10b1
thetab(i, k-1, j) = thetab(i, k-1, j) - temp10b1
thetab(i, k, j) = thetab(i, k, j) + tmpdz*temp10b2
tmpdzb = temp10*temp10b2 - (moist(i, k+1, j, p_qv)-moist(i, k-&
& 1, j, p_qv))*temp10b3/tmpdz - (tmp1(i, k+1, j)-tmp1(i, k-1, &
& j))*temp10b4/tmpdz
moistb(i, k+1, j, p_qv) = moistb(i, k+1, j, p_qv) + temp10b3
moistb(i, k-1, j, p_qv) = moistb(i, k-1, j, p_qv) - temp10b3
tmp1b(i, k+1, j) = tmp1b(i, k+1, j) + temp10b4
tmp1b(i, k-1, j) = tmp1b(i, k-1, j) - temp10b4
bn2b(i, k, j) = 0.0
ELSE
tmpdz = 1.0/rdz(i, k, j) + 1.0/rdz(i, k+1, j)
temp9 = coefa/tmpdz
temp9b = g*bn2b(i, k, j)
temp9b0 = (thetaep1-thetaem1)*temp9b/tmpdz
temp10b = -(temp9b/tmpdz)
thetaep1b = temp9*temp9b
thetaem1b = -(temp9*temp9b)
coefab = temp9b0
tmpdzb = -((tmp1(i, k+1, j)-tmp1(i, k-1, j))*temp10b/tmpdz) - &
& temp9*temp9b0
tmp1b(i, k+1, j) = tmp1b(i, k+1, j) + temp10b
tmp1b(i, k-1, j) = tmp1b(i, k-1, j) - temp10b
bn2b(i, k, j) = 0.0
CALL POPREAL8(thetaem1)
temp8 = cp*t(i, k-1, j)
temp7 = qvs(i, k-1, j)/temp8
temp7b = xlv*theta(i, k-1, j)*thetaem1b/temp8
thetab(i, k-1, j) = thetab(i, k-1, j) + (xlv*temp7+1.0)*&
& thetaem1b
qvsb(i, k-1, j) = qvsb(i, k-1, j) + temp7b
tb(i, k-1, j) = tb(i, k-1, j) - temp7*cp*temp7b
CALL POPREAL8(thetaep1)
temp6 = cp*t(i, k+1, j)
temp5 = qvs(i, k+1, j)/temp6
temp5b = xlv*theta(i, k+1, j)*thetaep1b/temp6
thetab(i, k+1, j) = thetab(i, k+1, j) + (xlv*temp5+1.0)*&
& thetaep1b
qvsb(i, k+1, j) = qvsb(i, k+1, j) + temp5b
tb(i, k+1, j) = tb(i, k+1, j) - temp5*cp*temp5b
xlvqv = xlv*moist(i, k, j, p_qv)
CALL POPREAL8(coefa)
temp4 = cp*r_v*t(i, k, j)**2
temp2 = xlvqv/temp4
temp1 = (xlv*temp2+1.0)*theta(i, k, j)
temp1b = coefab/temp1
temp3 = r_d*t(i, k, j)
temp1b0 = -((xlvqv/temp3+1.0)*temp1b/temp1)
temp2b = xlv*theta(i, k, j)*temp1b0/temp4
xlvqvb = temp2b + temp1b/temp3
tb(i, k, j) = tb(i, k, j) - cp*r_v*temp2*2*t(i, k, j)*temp2b -&
& xlvqv*r_d*temp1b/temp3**2
thetab(i, k, j) = thetab(i, k, j) + (xlv*temp2+1.0)*temp1b0
moistb(i, k, j, p_qv) = moistb(i, k, j, p_qv) + xlv*xlvqvb
END IF
rdzb(i, k, j) = rdzb(i, k, j) - tmpdzb/rdz(i, k, j)**2
rdzb(i, k+1, j) = rdzb(i, k+1, j) - tmpdzb/rdz(i, k+1, j)**2
END DO
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf,kts,-1
DO i=i_end,i_start,-1
temp0 = p(i, k, j) - es
temp0b = ep_2*qvsb(i, k, j)/temp0
temp0b0 = -(es*temp0b/temp0)
esb = temp0b - temp0b0
pb(i, k, j) = pb(i, k, j) + temp0b0
qvsb(i, k, j) = 0.0
tc = t(i, k, j) - svpt0
CALL POPREAL8(es)
temp = t(i, k, j) - svp3
tempb = svp2*EXP(svp2*(tc/temp))*svp1*1000.0*esb/temp
tcb = tempb
tb(i, k, j) = tb(i, k, j) + tcb - tc*tempb/temp
END DO
END DO
END DO
DO ispe=n_moist,param_first_scalar,-1
CALL POPCONTROL1B(branch)
IF (branch .NE. 0) THEN
DO j=j_end,j_start,-1
DO i=i_end,i_start,-1
moistb(i, 1, j, ispe) = moistb(i, 1, j, ispe) + cf1*tmp1sfcb(i&
& , j)
moistb(i, 2, j, ispe) = moistb(i, 2, j, ispe) + cf2*tmp1sfcb(i&
& , j)
moistb(i, 3, j, ispe) = moistb(i, 3, j, ispe) + cf3*tmp1sfcb(i&
& , j)
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf,kts,-1
DO i=i_end,i_start,-1
moistb(i, k, j, ispe) = moistb(i, k, j, ispe) + tmp1b(i, k, &
& j)
END DO
END DO
END DO
END IF
END DO
END SUBROUTINE A_CALCULATE_N2
SUBROUTINE a_isotropic_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh, &
xkhv,a_xkhv,khdif,kvdif,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: khdif,kvdif
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh, &
xkhv,a_xkhv
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
REAL :: khdif3,kvdif3
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!ADDED BY WALLS
ktf = kte
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
! khdif3=khdif*3.
! kvdif3=kvdif*3.
khdif3=khdif/prandtl
kvdif3=kvdif/prandtl
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[1]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! xkmh(i,k,j) =khdif
! xkmv(i,k,j) =kvdif
! xkhh(i,k,j) =khdif3
! xkhv(i,k,j) =kvdif3
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_xkhv(i,k,j) =0.0
a_xkhh(i,k,j) =0.0
a_xkmv(i,k,j) =0.0
a_xkmh(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
!LPB[0]
! ktf =kte
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
! khdif3 =khdif/prandtl
! kvdif3 =kvdif/prandtl
END SUBROUTINE a_isotropic_km
SUBROUTINE a_smag_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv, &
a_xkhv,BN2,a_BN2,div,a_div,defor11,a_defor11,defor22,a_defor22,defor33, &
a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,rdzw, &
a_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: dx,dy,dt,mix_upper_bound
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: BN2,a_BN2,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh, &
xkhv,a_xkhv
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor22,a_defor22, &
defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,div,a_div
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
REAL :: deltas,a_deltas,tmp,a_tmp,pr,a_pr,mlen_h,a_mlen_h,mlen_v,a_mlen_v, &
c_s,a_c_s
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: def2,a_def2
REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb15_tmp
REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb16_tmp
! REAL,DIMENSION(1) :: Keep_Lpb18_tmp
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv400
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv401
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv402
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv403
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv404
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv405
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv406
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv407
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv408
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv409
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4010
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4011
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4012
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4013
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4014
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4015
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4016
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4017
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4018
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4019
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4020
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4021
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4022
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4023
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4024
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4025
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4026
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4027
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)) &
:: Tmpv4028
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = min(kte,kde-1)
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!LPB[12]
pr = prandtl
c_s = config_flags%c_s
!LPB[13]
do j=j_start,j_end
do k=kts,ktf
do i=i_start,i_end
def2(i,k,j)=0.5*(defor11(i,k,j)*defor11(i,k,j) + &
defor22(i,k,j)*defor22(i,k,j) + &
defor33(i,k,j)*defor33(i,k,j))
enddo
enddo
enddo
!LPB[14]
do j=j_start,j_end
do k=kts,ktf
do i=i_start,i_end
tmp=0.25*(defor12(i ,k,j)+defor12(i ,k,j+1)+ &
defor12(i+1,k,j)+defor12(i+1,k,j+1))
def2(i,k,j)=def2(i,k,j)+tmp*tmp
enddo
enddo
enddo
!LPB[15]
do j=j_start,j_end
Keep_Lpb15_tmp(j) =tmp
do k=kts,ktf
do i=i_start,i_end
tmp=0.25*(defor13(i ,k+1,j)+defor13(i ,k,j)+ &
defor13(i+1,k+1,j)+defor13(i+1,k,j))
def2(i,k,j)=def2(i,k,j)+tmp*tmp
enddo
enddo
enddo
!LPB[16]
do j=j_start,j_end
Keep_Lpb16_tmp(j) =tmp
do k=kts,ktf
do i=i_start,i_end
tmp=0.25*(defor23(i,k+1,j )+defor23(i,k,j )+ &
defor23(i,k+1,j+1)+defor23(i,k,j+1))
def2(i,k,j)=def2(i,k,j)+tmp*tmp
enddo
enddo
enddo
!LPB[17]
!!LPB[18]
! ! Keep_Lpb18_tmp =tmp
! IF (isotropic .EQ. 0) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j))
! mlen_v= 1./rdzw(i,k,j)
! tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr)
! tmp=tmp**0.5
! xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h )
! xkmh(i,k,j)=min(xkmh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt )
! xkmv(i,k,j)=max(c_s*c_s*mlen_v*mlen_v*tmp, 1.0E-6*mlen_v*mlen_v )
! xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt )
! xkhh(i,k,j)=xkmh(i,k,j)/pr
! xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt )
! xkhv(i,k,j)=xkmv(i,k,j)/pr
! xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt )
! ENDDO
! ENDDO
! ENDDO
! ELSE
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! deltas=(dx/msftx(i,j) * dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
! tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr)
! tmp=tmp**0.5
! xkmh(i,k,j)=max(c_s*c_s*deltas*deltas*tmp, 1.0E-6*deltas*deltas )
! xkmh(i,k,j)=min(xkmh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt )
! xkmv(i,k,j)=xkmh(i,k,j)
! xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt )
! xkhh(i,k,j)=xkmh(i,k,j)/pr
! xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt )
! xkhv(i,k,j)=xkmv(i,k,j)/pr
! xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt )
! ENDDO
! ENDDO
! ENDDO
! ENDIF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
a_deltas =0.0
a_tmp =0.0
a_pr =0.0
a_mlen_h =0.0
a_mlen_v =0.0
a_c_s =0.0
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_def2(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[18]
! tmp =Keep_Lpb18_tmp
IF(isotropic .EQ. 0) THEN
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
mlen_h =sqrt(dx/msftx(i,j)*dy/msfty(i,j))
Tmpv400(i,k,j) =mlen_h
mlen_v =1./rdzw(i,k,j)
Tmpv401(i,k,j) =mlen_v
Tmpv001 =BN2(i,k,j)/pr
Tmpv002 =def2(i,k,j) -Tmpv001
Tmpv402(i,k,j) =Tmpv002
tmp =max(0., Tmpv402(i,k,j))
Tmpv403(i,k,j) =tmp
tmp =tmp**0.5
Tmpv404(i,k,j) =tmp
Tmpv001 =c_s*c_s*mlen_h
Tmpv405(i,k,j) =Tmpv001
Tmpv002 =Tmpv405(i,k,j)*mlen_h
Tmpv406(i,k,j) =Tmpv002
Tmpv003 =Tmpv406(i,k,j)*tmp
Tmpv407(i,k,j) =Tmpv003
Tmpv408(i,k,j) =Tmpv407(i,k,j)
Tmpv004 =max(Tmpv408(i,k,j), 1.0E-6*mlen_h*mlen_h)
Tmpv409(i,k,j) =xkmh(i,k,j)
xkmh(i,k,j) =Tmpv004
Tmpv001 =min(xkmh(i,k,j), mix_upper_bound*mlen_h*mlen_h/dt)
Tmpv4010(i,k,j) =xkmh(i,k,j)
xkmh(i,k,j) =Tmpv001
Tmpv001 =c_s*c_s*mlen_v
Tmpv4011(i,k,j) =Tmpv001
Tmpv002 =Tmpv4011(i,k,j)*mlen_v
Tmpv4012(i,k,j) =Tmpv002
Tmpv003 =Tmpv4012(i,k,j)*tmp
Tmpv4013(i,k,j) =Tmpv003
Tmpv4014(i,k,j) =Tmpv4013(i,k,j)
Tmpv004 =max(Tmpv4014(i,k,j), 1.0E-6*mlen_v*mlen_v)
Tmpv4015(i,k,j) =xkmv(i,k,j)
xkmv(i,k,j) =Tmpv004
Tmpv001 =min(xkmv(i,k,j), mix_upper_bound*mlen_v*mlen_v/dt)
Tmpv4016(i,k,j) =xkmv(i,k,j)
xkmv(i,k,j) =Tmpv001
Tmpv001 =xkmh(i,k,j)/pr
xkhh(i,k,j) =Tmpv001
Tmpv001 =min(xkhh(i,k,j), mix_upper_bound*mlen_h*mlen_h/dt)
xkhh(i,k,j) =Tmpv001
Tmpv001 =xkmv(i,k,j)/pr
xkhv(i,k,j) =Tmpv001
Tmpv001 =min(xkhv(i,k,j), mix_upper_bound*mlen_v*mlen_v/dt)
xkhv(i,k,j) =Tmpv001
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
deltas =(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
Tmpv4017(i,k,j) =deltas
Tmpv001 =BN2(i,k,j)/pr
Tmpv002 =def2(i,k,j) -Tmpv001
Tmpv4018(i,k,j) =Tmpv002
tmp =max(0., Tmpv4018(i,k,j))
Tmpv4019(i,k,j) =tmp
tmp =tmp**0.5
Tmpv4020(i,k,j) =tmp
Tmpv001 =c_s*c_s*deltas
Tmpv4021(i,k,j) =Tmpv001
Tmpv002 =Tmpv4021(i,k,j)*deltas
Tmpv4022(i,k,j) =Tmpv002
Tmpv003 =Tmpv4022(i,k,j)*tmp
Tmpv4023(i,k,j) =Tmpv003
Tmpv4024(i,k,j) =Tmpv4023(i,k,j)
Tmpv004 =max(Tmpv4024(i,k,j), 1.0E-6*deltas*deltas)
Tmpv4025(i,k,j) =xkmh(i,k,j)
xkmh(i,k,j) =Tmpv004
Tmpv4026(i,k,j) =xkmh(i,k,j)
xkmh(i,k,j) =min(xkmh(i,k,j), mix_upper_bound*dx/msftx(i,j)*dy/msfty(i,j)/dt)
Tmpv4027(i,k,j) =xkmv(i,k,j)
xkmv(i,k,j) =xkmh(i,k,j)
Tmpv4028(i,k,j) =xkmv(i,k,j)
xkmv(i,k,j) =min(xkmv(i,k,j), mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt)
Tmpv001 =xkmh(i,k,j)/pr
xkhh(i,k,j) =Tmpv001
xkhh(i,k,j) =min(xkhh(i,k,j), mix_upper_bound*dx/msftx(i,j)*dy/msfty(i,j)/dt)
Tmpv001 =xkmv(i,k,j)/pr
xkhv(i,k,j) =Tmpv001
xkhv(i,k,j) =min(xkhv(i,k,j), mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt)
ENDDO
ENDDO
ENDDO
ENDIF
IF(isotropic .EQ. 0) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
!ADDED BY WALLS
tmp =Tmpv404(i,k,j)
mlen_v =Tmpv401(i,k,j)
mlen_h =Tmpv400(i,k,j)
a_Tmpv1 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_xkhv(i,k,j) =a_xkhv(i,k,j) +(1.0 -sign(1.0, xkhv(i,k,j) -mix_upper_bound* &
mlen_v*mlen_v/dt))*0.5*1.0*a_Tmpv1
a_mlen_v =a_mlen_v +(1.0 +sign(1.0, xkhv(i,k,j) -mix_upper_bound*mlen_v* &
mlen_v/dt))*0.5*(mix_upper_bound*mlen_v +mix_upper_bound*mlen_v)/dt*a_Tmpv1
a_Tmpv1 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +a_Tmpv1/pr
a_pr =a_pr -xkmv(i,k,j)/(pr*pr)*a_Tmpv1
a_Tmpv1 =a_xkhh(i,k,j)
a_xkhh(i,k,j) =0.0
a_xkhh(i,k,j) =a_xkhh(i,k,j) +(1.0 -sign(1.0, xkhh(i,k,j) -mix_upper_bound* &
mlen_h*mlen_h/dt))*0.5*1.0*a_Tmpv1
a_mlen_h =a_mlen_h +(1.0 +sign(1.0, xkhh(i,k,j) -mix_upper_bound*mlen_h* &
mlen_h/dt))*0.5*(mix_upper_bound*mlen_h +mix_upper_bound*mlen_h)/dt*a_Tmpv1
a_Tmpv1 =a_xkhh(i,k,j)
a_xkhh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +a_Tmpv1/pr
a_pr =a_pr -xkmh(i,k,j)/(pr*pr)*a_Tmpv1
xkmv(i,k,j) =Tmpv4016(i,k,j)
a_Tmpv1 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +(1.0 -sign(1.0, xkmv(i,k,j) -mix_upper_bound* &
mlen_v*mlen_v/dt))*0.5*1.0*a_Tmpv1
a_mlen_v =a_mlen_v +(1.0 +sign(1.0, xkmv(i,k,j) -mix_upper_bound*mlen_v* &
mlen_v/dt))*0.5*(mix_upper_bound*mlen_v +mix_upper_bound*mlen_v)/dt*a_Tmpv1
xkmv(i,k,j) =Tmpv4015(i,k,j)
a_Tmpv4 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_Tmpv3 =(1.0 +sign(1.0, Tmpv4014(i,k,j) -1.0E-6*mlen_v*mlen_v))*0.5*a_Tmpv4
a_mlen_v =a_mlen_v +(1.0 -sign(1.0, Tmpv4014(i,k,j) -1.0E-6*mlen_v*mlen_v)) &
*0.5*(1.0E-6*mlen_v +1.0E-6*mlen_v)*a_Tmpv4
a_Tmpv2 =tmp*a_Tmpv3
a_tmp =a_tmp +Tmpv4012(i,k,j)*a_Tmpv3
a_Tmpv1 =mlen_v*a_Tmpv2
a_mlen_v =a_mlen_v +Tmpv4011(i,k,j)*a_Tmpv2
a_c_s =a_c_s +2.0*c_s*mlen_v*a_Tmpv1
a_mlen_v =a_mlen_v +c_s*c_s*a_Tmpv1
xkmh(i,k,j) =Tmpv4010(i,k,j)
a_Tmpv1 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +(1.0 -sign(1.0, xkmh(i,k,j) -mix_upper_bound* &
mlen_h*mlen_h/dt))*0.5*1.0*a_Tmpv1
a_mlen_h =a_mlen_h +(1.0 +sign(1.0, xkmh(i,k,j) -mix_upper_bound*mlen_h* &
mlen_h/dt))*0.5*(mix_upper_bound*mlen_h +mix_upper_bound*mlen_h)/dt*a_Tmpv1
xkmh(i,k,j) =Tmpv409(i,k,j)
a_Tmpv4 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_Tmpv3 =(1.0 +sign(1.0, Tmpv408(i,k,j) -1.0E-6*mlen_h*mlen_h))*0.5*a_Tmpv4
a_mlen_h =a_mlen_h +(1.0 -sign(1.0, Tmpv408(i,k,j) -1.0E-6*mlen_h*mlen_h)) &
*0.5*(1.0E-6*mlen_h +1.0E-6*mlen_h)*a_Tmpv4
a_Tmpv2 =tmp*a_Tmpv3
a_tmp =a_tmp +Tmpv406(i,k,j)*a_Tmpv3
a_Tmpv1 =mlen_h*a_Tmpv2
a_mlen_h =a_mlen_h +Tmpv405(i,k,j)*a_Tmpv2
a_c_s =a_c_s +2.0*c_s*mlen_h*a_Tmpv1
a_mlen_h =a_mlen_h +c_s*c_s*a_Tmpv1
! tmp =Tmpv404(i,k,j)
tmp =Tmpv403(i,k,j)
IF(tmp.NE.0.0) THEN
a_tmp =0.5*1.0*tmp**(0.5 -1)*a_tmp
ELSE
a_tmp =0.0
END IF
! tmp =Tmpv403(i,k,j)
!REVISED BY WALLS
! (1.0 +(-1.0)*sign(1.0, 0. -Tmpv402(i,k,j)))*0.5* =a_tmp
a_Tmpv2 =(1.0 +(-1.0)*sign(1.0, 0. -Tmpv402(i,k,j)))*0.5*a_tmp
a_tmp =0.0
a_def2(i,k,j) =a_def2(i,k,j) +a_Tmpv2
a_Tmpv1 =-a_Tmpv2
a_BN2(i,k,j) =a_BN2(i,k,j) +a_Tmpv1/pr
a_pr =a_pr -BN2(i,k,j)/(pr*pr)*a_Tmpv1
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_mlen_v
a_mlen_v =0.0
a_mlen_h =0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
deltas =Tmpv4017(i,k,j)
tmp =Tmpv4020(i,k,j)
a_Tmpv1 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_xkhv(i,k,j) =a_xkhv(i,k,j) +(1.0 -sign(1.0, xkhv(i,k,j) -mix_upper_bound/ &
rdzw(i,k,j)/rdzw(i,k,j)/dt))*0.5*1.0*a_Tmpv1
a_rdzw(i,k,j) =a_rdzw(i,k,j) +(1.0 +sign(1.0, xkhv(i,k,j) -mix_upper_bound/ &
rdzw(i,k,j)/rdzw(i,k,j)/dt))*0.5*(-mix_upper_bound/(rdzw(i,k,j)*rdzw(i,k,j)) &
*rdzw(i,k,j) -mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))/dt*a_Tmpv1
a_Tmpv1 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +a_Tmpv1/pr
a_pr =a_pr -xkmv(i,k,j)/(pr*pr)*a_Tmpv1
a_xkhh(i,k,j) =(1.0 -(1.0)*sign(1.0, xkhh(i,k,j) -mix_upper_bound*dx/msftx(i,j) &
*dy/msfty(i,j)/dt))*0.5*a_xkhh(i,k,j)
a_Tmpv1 =a_xkhh(i,k,j)
a_xkhh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +a_Tmpv1/pr
a_pr =a_pr -xkmh(i,k,j)/(pr*pr)*a_Tmpv1
xkmv(i,k,j) =Tmpv4028(i,k,j)
a_Tmpv1 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +(1.0 -sign(1.0, xkmv(i,k,j) -mix_upper_bound/ &
rdzw(i,k,j)/rdzw(i,k,j)/dt))*0.5*1.0*a_Tmpv1
a_rdzw(i,k,j) =a_rdzw(i,k,j) +(1.0 +sign(1.0, xkmv(i,k,j) -mix_upper_bound/ &
rdzw(i,k,j)/rdzw(i,k,j)/dt))*0.5*(-mix_upper_bound/(rdzw(i,k,j)*rdzw(i,k,j)) &
*rdzw(i,k,j) -mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))/dt*a_Tmpv1
xkmv(i,k,j) =Tmpv4027(i,k,j)
a_xkmh(i,k,j) =a_xkmh(i,k,j) +a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
xkmh(i,k,j) =Tmpv4026(i,k,j)
a_xkmh(i,k,j) =(1.0 -(1.0)*sign(1.0, xkmh(i,k,j) -mix_upper_bound*dx/msftx(i,j) &
*dy/msfty(i,j)/dt))*0.5*a_xkmh(i,k,j)
xkmh(i,k,j) =Tmpv4025(i,k,j)
a_Tmpv4 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_Tmpv3 =(1.0 +sign(1.0, Tmpv4024(i,k,j) -1.0E-6*deltas*deltas))*0.5*a_Tmpv4
a_deltas =a_deltas +(1.0 -sign(1.0, Tmpv4024(i,k,j) -1.0E-6*deltas*deltas)) &
*0.5*(1.0E-6*deltas +1.0E-6*deltas)*a_Tmpv4
a_Tmpv2 =tmp*a_Tmpv3
a_tmp =a_tmp +Tmpv4022(i,k,j)*a_Tmpv3
a_Tmpv1 =deltas*a_Tmpv2
a_deltas =a_deltas +Tmpv4021(i,k,j)*a_Tmpv2
a_c_s =a_c_s +2.0*c_s*deltas*a_Tmpv1
a_deltas =a_deltas +c_s*c_s*a_Tmpv1
tmp =Tmpv4019(i,k,j)
IF(tmp.NE.0.0) THEN
a_tmp =0.5*1.0*tmp**(0.5 -1)*a_tmp
ELSE
a_tmp =0.0
END IF
!REVISED BY WALLS
! (1.0 +(-1.0)*sign(1.0, 0. -Tmpv4018(i,k,j)))*0.5* =a_tmp
a_Tmpv2 =(1.0 +(-1.0)*sign(1.0, 0. -Tmpv4018(i,k,j)))*0.5*a_tmp
a_tmp =0.0
a_def2(i,k,j) =a_def2(i,k,j) +a_Tmpv2
a_Tmpv1 =-a_Tmpv2
a_BN2(i,k,j) =a_BN2(i,k,j) +a_Tmpv1/pr
a_pr =a_pr -BN2(i,k,j)/(pr*pr)*a_Tmpv1
a_rdzw(i,k,j) =a_rdzw(i,k,j) -dx/msftx(i,j)*dy/msfty(i,j)/(rdzw(i,k,j) &
*rdzw(i,k,j))*0.33333333*(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1)*a_deltas
a_deltas =0.0
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[17]
!LPB[16]
DO j =j_end, j_start, -1
tmp =Keep_Lpb16_tmp(j)
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =defor23(i,k+1,j) +defor23(i,k,j)
Tmpv002 =Tmpv001 +defor23(i,k+1,j+1)
Tmpv003 =Tmpv002 +defor23(i,k,j+1)
Tmpv004 =0.25*Tmpv003
Tmpv300(i,k) =tmp
tmp =Tmpv004
Tmpv001 =def2(i,k,j) +tmp*tmp
def2(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_def2(i,k,j)
a_def2(i,k,j) =0.0
a_def2(i,k,j) =a_def2(i,k,j) +a_Tmpv1
a_tmp =a_tmp +2.0*tmp*a_Tmpv1
tmp =Tmpv300(i,k)
a_Tmpv4 =a_tmp
a_tmp =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_defor23(i,k,j+1) =a_defor23(i,k,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_defor23(i,k+1,j+1) =a_defor23(i,k+1,j+1) +a_Tmpv2
a_defor23(i,k+1,j) =a_defor23(i,k+1,j) +a_Tmpv1
a_defor23(i,k,j) =a_defor23(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[15]
DO j =j_end, j_start, -1
tmp =Keep_Lpb15_tmp(j)
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =defor13(i,k+1,j) +defor13(i,k,j)
Tmpv002 =Tmpv001 +defor13(i+1,k+1,j)
Tmpv003 =Tmpv002 +defor13(i+1,k,j)
Tmpv004 =0.25*Tmpv003
Tmpv300(i,k) =tmp
tmp =Tmpv004
Tmpv001 =def2(i,k,j) +tmp*tmp
def2(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_def2(i,k,j)
a_def2(i,k,j) =0.0
a_def2(i,k,j) =a_def2(i,k,j) +a_Tmpv1
a_tmp =a_tmp +2.0*tmp*a_Tmpv1
tmp =Tmpv300(i,k)
a_Tmpv4 =a_tmp
a_tmp =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_defor13(i+1,k,j) =a_defor13(i+1,k,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_defor13(i+1,k+1,j) =a_defor13(i+1,k+1,j) +a_Tmpv2
a_defor13(i,k+1,j) =a_defor13(i,k+1,j) +a_Tmpv1
a_defor13(i,k,j) =a_defor13(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =defor12(i,k,j) +defor12(i,k,j+1)
Tmpv002 =Tmpv001 +defor12(i+1,k,j)
Tmpv003 =Tmpv002 +defor12(i+1,k,j+1)
Tmpv004 =0.25*Tmpv003
Tmpv300(i,k) =tmp
tmp =Tmpv004
Tmpv001 =def2(i,k,j) +tmp*tmp
def2(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_def2(i,k,j)
a_def2(i,k,j) =0.0
a_def2(i,k,j) =a_def2(i,k,j) +a_Tmpv1
a_tmp =a_tmp +2.0*tmp*a_Tmpv1
tmp =Tmpv300(i,k)
a_Tmpv4 =a_tmp
a_tmp =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_defor12(i+1,k,j+1) =a_defor12(i+1,k,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_defor12(i+1,k,j) =a_defor12(i+1,k,j) +a_Tmpv2
a_defor12(i,k,j) =a_defor12(i,k,j) +a_Tmpv1
a_defor12(i,k,j+1) =a_defor12(i,k,j+1) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =defor11(i,k,j)*defor11(i,k,j) +defor22(i,k,j)*defor22(i,k,j)
! Tmpv002 =Tmpv001 +defor33(i,k,j)*defor33(i,k,j)
! Tmpv003 =0.5*Tmpv002
! def2(i,k,j) =Tmpv003
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_def2(i,k,j)
a_def2(i,k,j) =0.0
a_Tmpv2 =0.5*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_defor33(i,k,j) =a_defor33(i,k,j) +2.0*defor33(i,k,j)*a_Tmpv2
a_defor11(i,k,j) =a_defor11(i,k,j) +2.0*defor11(i,k,j)*a_Tmpv1
a_defor22(i,k,j) =a_defor22(i,k,j) +2.0*defor22(i,k,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! pr =prandtl
! c_s =config_flags%c_s
!REVISED BY WALLS
! a_config_flags%c_s =a_config_flags%c_s +a_c_s
a_c_s =0.0
a_pr =0.0
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_smag_km
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.10 (r5363) - 9 Sep 2014 09:54
!
! Differentiation of smag2d_km in reverse (adjoint) mode:
! gradient of useful results: defor11 defor12 zx zy xkmh
! defor22 xkmv rdzw xkhh xkhv
! with respect to varying inputs: defor11 defor12 zx zy xkmh
! defor22 xkmv rdzw xkhh xkhv
! RW status of diff variables: defor11:incr defor12:incr zx:incr
! zy:incr xkmh:in-out defor22:incr xkmv:in-out rdzw:incr
! xkhh:in-out xkhv:in-out
SUBROUTINE A_SMAG2D_KM(config_flags, xkmh, xkmhb, xkmv, xkmvb, xkhh, &
& xkhhb, xkhv, xkhvb, defor11, defor11b, defor22, defor22b, defor12, &
& defor12b, rdzw, rdzwb, dx, dy, msftx, msfty, zx, zxb, zy, zyb, ids, &
& ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, &
& jte, kts, kte)
IMPLICIT NONE
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, INTENT(IN) :: dx, dy
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rdzw, zx, zy
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rdzwb, zxb, zyb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmh, &
& xkmv, xkhh, xkhv
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmhb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: defor11, &
& defor22, defor12
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: defor11b, defor22b, &
& defor12b
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msftx, msfty
! LOCAL VARS
INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
REAL :: deltas, tmp, pr, mlen_h, c_s
REAL :: tmpb
REAL :: dxm, dym, tmpzx, tmpzy, alpha, def_limit
REAL :: tmpzxb, tmpzyb, alphab
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: def2
REAL, DIMENSION(its:ite, kts:kte, jts:jte) :: def2b
INTEGER :: branch
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkhhb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkhvb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmvb
REAL :: abs1b
REAL :: tempb6
REAL :: tempb5
REAL :: tempb4
REAL :: tempb3
REAL :: abs4b
REAL :: tempb2
REAL :: tempb1
REAL :: tempb0
REAL :: abs7b
REAL :: x1
REAL :: abs0b
REAL :: abs3b
REAL :: tempb
REAL :: abs6b
REAL :: x1b
REAL :: abs7
REAL :: abs6
REAL :: abs5
REAL :: abs4
REAL :: abs3
REAL :: abs2
REAL :: abs1
REAL :: abs0
REAL :: abs2b
REAL :: abs5b
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
IF ((config_flags%open_xs .OR. config_flags%specified) .OR. &
& config_flags%nested) 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. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
IF ((config_flags%open_ys .OR. config_flags%specified) .OR. &
& config_flags%nested) 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. config_flags%specified) .OR. &
& config_flags%nested) THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
pr = prandtl
c_s = config_flags%c_s
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
def2(i, k, j) = 0.25*((defor11(i, k, j)-defor22(i, k, j))*(&
& defor11(i, k, j)-defor22(i, k, j)))
CALL PUSHREAL8(tmp)
tmp = 0.25*(defor12(i, k, j)+defor12(i, k, j+1)+defor12(i+1, k, &
& j)+defor12(i+1, k, j+1))
def2(i, k, j) = def2(i, k, j) + tmp*tmp
END DO
END DO
END DO
!
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
CALL PUSHREAL8(mlen_h)
mlen_h = SQRT(dx/msftx(i, j)*dy/msfty(i, j))
CALL PUSHREAL8(tmp)
tmp = SQRT(def2(i, k, j))
! xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h )
xkmh(i, k, j) = c_s*c_s*mlen_h*mlen_h*tmp
IF (xkmh(i, k, j) .GT. 10.*mlen_h) THEN
xkmh(i, k, j) = 10.*mlen_h
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
xkmh(i, k, j) = xkmh(i, k, j)
END IF
xkhh(i, k, j) = xkmh(i, k, j)/pr
IF (config_flags%diff_opt .EQ. 2) THEN
! jd: reduce diffusion coefficient by slope factor (modified by JB August 2014)
dxm = dx/msftx(i, j)
dym = dy/msfty(i, j)
IF (zx(i, k, j) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs0)
abs0 = zx(i, k, j)
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(abs0)
abs0 = -zx(i, k, j)
CALL PUSHCONTROL1B(0)
END IF
IF (zx(i+1, k, j) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs2)
abs2 = zx(i+1, k, j)
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(abs2)
abs2 = -zx(i+1, k, j)
CALL PUSHCONTROL1B(0)
END IF
IF (zx(i, k+1, j) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs4)
abs4 = zx(i, k+1, j)
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(abs4)
abs4 = -zx(i, k+1, j)
CALL PUSHCONTROL1B(0)
END IF
IF (zx(i+1, k+1, j) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs6)
abs6 = zx(i+1, k+1, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHREAL8(abs6)
abs6 = -zx(i+1, k+1, j)
CALL PUSHCONTROL1B(1)
END IF
tmpzx = 0.25*(abs0+abs2+abs4+abs6)*rdzw(i, k, j)*dxm
IF (zy(i, k, j) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs1)
abs1 = zy(i, k, j)
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(abs1)
abs1 = -zy(i, k, j)
CALL PUSHCONTROL1B(0)
END IF
IF (zy(i, k, j+1) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs3)
abs3 = zy(i, k, j+1)
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(abs3)
abs3 = -zy(i, k, j+1)
CALL PUSHCONTROL1B(0)
END IF
IF (zy(i, k+1, j) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs5)
abs5 = zy(i, k+1, j)
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHREAL8(abs5)
abs5 = -zy(i, k+1, j)
CALL PUSHCONTROL1B(0)
END IF
IF (zy(i, k+1, j+1) .GE. 0.0_8) THEN
CALL PUSHREAL8(abs7)
abs7 = zy(i, k+1, j+1)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHREAL8(abs7)
abs7 = -zy(i, k+1, j+1)
CALL PUSHCONTROL1B(1)
END IF
tmpzy = 0.25*(abs1+abs3+abs5+abs7)*rdzw(i, k, j)*dym
x1 = SQRT(tmpzx*tmpzx + tmpzy*tmpzy)
IF (x1 .LT. 1.0) THEN
CALL PUSHREAL8(alpha)
alpha = 1.0
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHREAL8(alpha)
alpha = x1
CALL PUSHCONTROL1B(1)
END IF
IF (10.0/mlen_h .LT. 1.e-3) THEN
def_limit = 1.e-3
ELSE
def_limit = 10.0/mlen_h
END IF
IF (tmp .GT. def_limit) THEN
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
END DO
END DO
def2b = 0.0_8
DO j=j_end,j_start,-1
DO k=ktf,kts,-1
DO i=i_end,i_start,-1
CALL POPCONTROL1B(branch)
IF (branch .NE. 0) THEN
xkmhb(i, k, j) = xkmhb(i, k, j) + xkhhb(i, k, j)/pr
xkhhb(i, k, j) = 0.0_8
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
tempb6 = xkmhb(i, k, j)/alpha**2
alphab = -(xkmh(i, k, j)*2*tempb6/alpha)
xkmhb(i, k, j) = tempb6
ELSE
alphab = -(xkmh(i, k, j)*xkmhb(i, k, j)/alpha**2)
xkmhb(i, k, j) = xkmhb(i, k, j)/alpha
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(alpha)
x1b = 0.0_8
ELSE
CALL POPREAL8(alpha)
x1b = alphab
END IF
dxm = dx/msftx(i, j)
dym = dy/msfty(i, j)
tmpzx = 0.25*(abs0+abs2+abs4+abs6)*rdzw(i, k, j)*dxm
tmpzy = 0.25*(abs1+abs3+abs5+abs7)*rdzw(i, k, j)*dym
IF (tmpzx**2 + tmpzy**2 .EQ. 0.0_8) THEN
tempb3 = 0.0_8
ELSE
tempb3 = x1b/(2.0*SQRT(tmpzx**2+tmpzy**2))
END IF
tmpzxb = 2*tmpzx*tempb3
tmpzyb = 2*tmpzy*tempb3
tempb4 = dym*0.25*tmpzyb
tempb5 = rdzw(i, k, j)*tempb4
abs1b = tempb5
abs3b = tempb5
abs5b = tempb5
abs7b = tempb5
rdzwb(i, k, j) = rdzwb(i, k, j) + (abs1+abs3+abs5+abs7)*tempb4
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs7)
zyb(i, k+1, j+1) = zyb(i, k+1, j+1) + abs7b
ELSE
CALL POPREAL8(abs7)
zyb(i, k+1, j+1) = zyb(i, k+1, j+1) - abs7b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs5)
zyb(i, k+1, j) = zyb(i, k+1, j) - abs5b
ELSE
CALL POPREAL8(abs5)
zyb(i, k+1, j) = zyb(i, k+1, j) + abs5b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs3)
zyb(i, k, j+1) = zyb(i, k, j+1) - abs3b
ELSE
CALL POPREAL8(abs3)
zyb(i, k, j+1) = zyb(i, k, j+1) + abs3b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs1)
zyb(i, k, j) = zyb(i, k, j) - abs1b
ELSE
CALL POPREAL8(abs1)
zyb(i, k, j) = zyb(i, k, j) + abs1b
END IF
tempb1 = dxm*0.25*tmpzxb
tempb2 = rdzw(i, k, j)*tempb1
abs0b = tempb2
abs2b = tempb2
abs4b = tempb2
abs6b = tempb2
rdzwb(i, k, j) = rdzwb(i, k, j) + (abs0+abs2+abs4+abs6)*tempb1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs6)
zxb(i+1, k+1, j) = zxb(i+1, k+1, j) + abs6b
ELSE
CALL POPREAL8(abs6)
zxb(i+1, k+1, j) = zxb(i+1, k+1, j) - abs6b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs4)
zxb(i, k+1, j) = zxb(i, k+1, j) - abs4b
ELSE
CALL POPREAL8(abs4)
zxb(i, k+1, j) = zxb(i, k+1, j) + abs4b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs2)
zxb(i+1, k, j) = zxb(i+1, k, j) - abs2b
ELSE
CALL POPREAL8(abs2)
zxb(i+1, k, j) = zxb(i+1, k, j) + abs2b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(abs0)
zxb(i, k, j) = zxb(i, k, j) - abs0b
ELSE
CALL POPREAL8(abs0)
zxb(i, k, j) = zxb(i, k, j) + abs0b
END IF
END IF
xkhvb(i, k, j) = 0.0_8
xkmhb(i, k, j) = xkmhb(i, k, j) + xkhhb(i, k, j)/pr
xkhhb(i, k, j) = 0.0_8
xkmvb(i, k, j) = 0.0_8
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) xkmhb(i, k, j) = 0.0_8
tmpb = mlen_h**2*c_s**2*xkmhb(i, k, j)
xkmhb(i, k, j) = 0.0_8
CALL POPREAL8(tmp)
IF (.NOT.def2(i, k, j) .EQ. 0.0_8) def2b(i, k, j) = def2b(i, k, &
& j) + tmpb/(2.0*SQRT(def2(i, k, j)))
CALL POPREAL8(mlen_h)
END DO
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf,kts,-1
DO i=i_end,i_start,-1
tmpb = 2*tmp*def2b(i, k, j)
CALL POPREAL8(tmp)
tempb = 0.25*tmpb
defor12b(i, k, j) = defor12b(i, k, j) + tempb
defor12b(i, k, j+1) = defor12b(i, k, j+1) + tempb
defor12b(i+1, k, j) = defor12b(i+1, k, j) + tempb
defor12b(i+1, k, j+1) = defor12b(i+1, k, j+1) + tempb
tempb0 = 0.25*2*(defor11(i, k, j)-defor22(i, k, j))*def2b(i, k, &
& j)
defor11b(i, k, j) = defor11b(i, k, j) + tempb0
defor22b(i, k, j) = defor22b(i, k, j) - tempb0
def2b(i, k, j) = 0.0_8
END DO
END DO
END DO
END SUBROUTINE A_SMAG2D_KM
SUBROUTINE a_phy_bc(config_flags,div,a_div,defor11,a_defor11,defor22, &
a_defor22,defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23, &
a_defor23,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv,a_xkhv,tke,a_tke, &
RUBLTEN,a_RUBLTEN,RVBLTEN,a_RVBLTEN,RUCUTEN,a_RUCUTEN,RVCUTEN,a_RVCUTEN,RUSHTEN,a_RUSHTEN,RVSHTEN,a_RVSHTEN, &
ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
kme,ips,ipe,jps,jpe,kps,kpe,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
TYPE(grid_config_rec_type) :: config_flags
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe,kps,kpe, &
its,ite,jts,jte,kts,kte
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: RUBLTEN,a_RUBLTEN,RVBLTEN,a_RVBLTEN, &
RUCUTEN,a_RUCUTEN,RVCUTEN,a_RVCUTEN,RUSHTEN,a_RUSHTEN,RVSHTEN,a_RVSHTEN, &
defor11,a_defor11,defor22,a_defor22,defor33,a_defor33,defor12,a_defor12, &
defor13,a_defor13,defor23,a_defor23,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh, &
xkhv,a_xkhv,tke,a_tke,div,a_div
IF(config_flags%diff_opt .eq. 2) THEN
CALL a_set_physical_bc3d( a_defor23 , 'f', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_defor13 , 'e', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_defor12 , 'd', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_defor33 , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_defor22 , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_defor11 , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_div , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_xkhv , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_xkmv , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
ENDIF
CALL a_set_physical_bc3d( a_xkhh , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_xkmh , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
IF(config_flags%shcu_physics .GT. 0) THEN
CALL a_set_physical_bc3d( a_RVSHTEN , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_RUSHTEN , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
ENDIF
IF(config_flags%cu_physics .GT. 0) THEN
CALL a_set_physical_bc3d( a_RVCUTEN , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_RUCUTEN , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
ENDIF
IF(config_flags%bl_pbl_physics .GT. 0) THEN
CALL a_set_physical_bc3d( a_RVBLTEN , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
CALL a_set_physical_bc3d( a_RUBLTEN , 't', config_flags, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe, &
its, ite, jts, jte, kts, kte )
ENDIF
END SUBROUTINE a_phy_bc
SUBROUTINE a_tke_km(config_flags,xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh,xkhv, &
a_xkhv,bn2,a_bn2,tke,a_tke,p8w,a_p8w,t8w,a_t8w,theta,a_theta,rdz,a_rdz, &
rdzw,a_rdzw,dx,dy,dt,isotropic,mix_upper_bound,msftx,msfty,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: dx,dy,dt
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,a_tke,p8w,a_p8w,t8w,a_t8w,theta, &
a_theta,rdz,a_rdz,rdzw,a_rdzw,bn2,a_bn2
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkmh,a_xkmh,xkmv,a_xkmv,xkhh,a_xkhh, &
xkhv,a_xkhv
REAL :: mix_upper_bound
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,a_l_scale
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dthrdn,a_dthrdn
REAL :: deltas,a_deltas,tmp,a_tmp,mlen_s,a_mlen_s,mlen_h,a_mlen_h,mlen_v, &
a_mlen_v,tmpdz,a_tmpdz,thetasfc,a_thetasfc,thetatop,a_thetatop,minkx, &
a_minkx,pr_inv,a_pr_inv,pr_inv_h,a_pr_inv_h,pr_inv_v,a_pr_inv_v,c_k,a_c_k
INTEGER :: i_start,i_end,j_start,j_end,ktf,i,j,k
REAL,PARAMETER :: tke_seed_value =1.e-06
REAL :: tke_seed
REAL,PARAMETER :: epsilon =1.e-10
! Remarked by Ning Pan, 2010-08-13
! REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb16_tmpdz
! REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb18_tmpdz
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004
REAL,ALLOCATABLE,DIMENSION(:) :: Tmpv200
REAL,ALLOCATABLE,DIMENSION(:) :: Tmpv201
REAL,ALLOCATABLE,DIMENSION(:,:) :: Tmpv300
REAL,ALLOCATABLE,DIMENSION(:,:) :: Tmpv301
REAL,ALLOCATABLE,DIMENSION(:,:,:) :: &
Tmpv400, &
Tmpv401, Tmpv402, Tmpv403, Tmpv404, Tmpv405, Tmpv406, Tmpv407, Tmpv408, Tmpv409, Tmpv4010, &
Tmpv4011, Tmpv4012, Tmpv4013, Tmpv4014, Tmpv4015, Tmpv4016, Tmpv4017, Tmpv4018, Tmpv4019, Tmpv4020, &
Tmpv4021, Tmpv4022, Tmpv4023, Tmpv4024, Tmpv4025, Tmpv4026, Tmpv4027, Tmpv4028, Tmpv4029, Tmpv4030, &
Tmpv4031
REAL :: g_Sqrt
ALLOCATE (Tmpv200(its:min(ite,ide-1)))
ALLOCATE (Tmpv201(its:min(ite,ide-1)))
ALLOCATE (Tmpv300(its:min(ite,ide-1),kts+1:min(kte,kde-1)-1))
ALLOCATE (Tmpv301(its:min(ite,ide-1),kts+1:min(kte,kde-1)-1))
ALLOCATE (Tmpv400(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv401(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv402(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv403(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv404(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv405(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv406(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv407(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv408(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv409(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4010(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4011(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4012(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4013(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4014(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4015(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4016(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4017(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4018(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4019(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4020(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4021(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4022(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4023(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4024(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4025(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4026(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4027(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4028(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4029(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4030(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
ALLOCATE (Tmpv4031(its:min(ite,ide-1),kts:min(kte,kde-1),max(jds+1,jts):min(jde-2,jte)))
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-2, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-2, jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!LPB[12]
c_k = config_flags%c_k
tke_seed = tke_seed_value
!LPB[13]
if( (config_flags%tke_drag_coefficient .gt. epsilon) .or. &
(config_flags%tke_heat_flux .gt. epsilon) ) tke_seed = 0.
!LPB[14]
DO j = j_start, j_end
DO k = kts+1, ktf-1
DO i = i_start, i_end
tmpdz = 1.0/rdz(i,k+1,j) + 1.0/rdz(i,k,j)
dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz
END DO
END DO
END DO
!LPB[15]
k = kts
!LPB[16]
DO j = j_start, j_end
! Keep_Lpb16_tmpdz(j) =tmpdz ! Remarked by Ning Pan, 2010-08-13
DO i = i_start, i_end
tmpdz = 1.0/rdzw(i,k+1,j) + 1.0/rdzw(i,k,j)
thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp )
dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz
END DO
END DO
!LPB[17]
k = ktf
!LPB[18]
DO j = j_start, j_end
! Keep_Lpb18_tmpdz(j) =tmpdz ! Remarked by Ning Pan, 2010-08-13
DO i = i_start, i_end
tmpdz = 1.0 / rdz(i,k,j) + 0.5 / rdzw(i,k,j)
thetatop = T8w(i,kde,j) / ( p8w(i,kde,j) / p1000mb )**( R_d / Cp )
dthrdn(i,k,j) = ( thetatop - theta(i,k-1,j) ) / tmpdz
END DO
END DO
!LPB[19]
!!LPB[20]
! IF ( isotropic .EQ. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! mlen_h = SQRT( dx/msftx(i,j) * dy/msfty(i,j) )
! tmp = SQRT( MAX( tke(i,k,j), tke_seed ) )
! deltas = 1.0 / rdzw(i,k,j)
! mlen_v = deltas
! IF ( dthrdn(i,k,j) .GT. 0.) THEN
! mlen_s = 0.76 * tmp / ( ABS( g / theta(i,k,j) * dthrdn(i,k,j) ) )**0.5
! mlen_v = MIN( mlen_v, mlen_s )
! END IF
! xkmh(i,k,j) = MAX( c_k * tmp * mlen_h, 1.0E-6 * mlen_h * mlen_h )
! xkmh(i,k,j) = MIN( xkmh(i,k,j), mix_upper_bound * mlen_h *mlen_h / dt )
! xkmv(i,k,j) = MAX( c_k * tmp * mlen_v, 1.0E-6 * deltas * deltas )
! xkmv(i,k,j) = MIN( xkmv(i,k,j), mix_upper_bound * deltas *deltas / dt )
! pr_inv_h = 1./prandtl
! pr_inv_v = 1.0 + 2.0 * mlen_v / deltas
! xkhh(i,k,j) = xkmh(i,k,j) * pr_inv_h
! xkhv(i,k,j) = xkmv(i,k,j) * pr_inv_v
! END DO
! END DO
! END DO
! ELSE
! CALL calc_l_scale( config_flags, tke, BN2, l_scale, &
! i_start, i_end, ktf, j_start, j_end, &
! dx, dy, rdzw, msftx, msfty, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tmp = SQRT( MAX( tke(i,k,j), tke_seed ) )
! deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
! xkmh(i,k,j) = c_k * tmp * l_scale(i,k,j)
! xkmh(i,k,j) = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) &
! / dt, xkmh(i,k,j) )
! xkmv(i,k,j) = c_k * tmp * l_scale(i,k,j)
! xkmv(i,k,j) = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt , xkmv(i,k,j) )
! pr_inv = 1.0 + 2.0 * l_scale(i,k,j) / deltas
! xkhh(i,k,j) = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) &
! / dt, xkmh(i,k,j) * pr_inv )
! xkhv(i,k,j) = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) &
! / dt, xkmv(i,k,j) * pr_inv )
! END DO
! END DO
! END DO
! END IF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_l_scale(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_dthrdn(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
a_deltas =0.0
a_tmp =0.0
a_mlen_s =0.0
a_mlen_h =0.0
a_mlen_v =0.0
a_tmpdz =0.0
a_thetasfc =0.0
a_thetatop =0.0
a_minkx =0.0
a_pr_inv =0.0
a_pr_inv_h =0.0
a_pr_inv_v =0.0
a_c_k =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[20]
!ADDED BY WALLS
!isotropic =1
IF( isotropic .EQ. 0 ) THEN
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
mlen_h =sqrt(dx/msftx(i,j)*dy/msfty(i,j))
Tmpv400(i,k,j) =mlen_h
tmp =sqrt(max(tke(i,k,j), tke_seed))
Tmpv401(i,k,j) =tmp
deltas =1.0/rdzw(i,k,j)
Tmpv402(i,k,j) =deltas
mlen_v =deltas
! Tmpv403(i,k,j) =mlen_v ! Remarked by Ning Pan, 2010-08-13
IF( dthrdn(i,k,j) .GT. 0.) THEN
Tmpv001 =g/theta(i,k,j)*dthrdn(i,k,j)
Tmpv404(i,k,j) =Tmpv001
Tmpv002 =abs(Tmpv404(i,k,j))
Tmpv405(i,k,j) =Tmpv002
Tmpv003 =Tmpv405(i,k,j)**0.5
Tmpv406(i,k,j) =Tmpv003
Tmpv004 =0.76*tmp/Tmpv406(i,k,j)
mlen_s =Tmpv004
!REVISED AND ADDED BY WALLS
Tmpv4020(i,k,j) =mlen_s
Tmpv407(i,k,j) =mlen_v
Tmpv001 =min(mlen_v, mlen_s)
mlen_v =Tmpv001
END IF
Tmpv001 =c_k*tmp
Tmpv408(i,k,j) =Tmpv001
Tmpv002 =Tmpv408(i,k,j)*mlen_h
Tmpv409(i,k,j) =Tmpv002
Tmpv4010(i,k,j) =Tmpv409(i,k,j)
Tmpv003 =max(Tmpv4010(i,k,j), 1.0E-6*mlen_h*mlen_h)
xkmh(i,k,j) =Tmpv003
Tmpv4011(i,k,j) =xkmh(i,k,j)
Tmpv001 =min(xkmh(i,k,j), mix_upper_bound*mlen_h*mlen_h/dt)
xkmh(i,k,j) =Tmpv001
Tmpv4012(i,k,j) =xkmh(i,k,j)
Tmpv403(i,k,j) =mlen_v ! Added by Ning Pan, 2010-08-13
Tmpv001 =c_k*tmp
Tmpv4013(i,k,j) =Tmpv001
Tmpv002 =Tmpv4013(i,k,j)*mlen_v
Tmpv4014(i,k,j) =Tmpv002
Tmpv4015(i,k,j) =Tmpv4014(i,k,j)
Tmpv003 =max(Tmpv4015(i,k,j), 1.0E-6*deltas*deltas)
xkmv(i,k,j) =Tmpv003
Tmpv4016(i,k,j) =xkmv(i,k,j)
Tmpv001 =min(xkmv(i,k,j), mix_upper_bound*deltas*deltas/dt)
xkmv(i,k,j) =Tmpv001
Tmpv4017(i,k,j) =xkmv(i,k,j)
pr_inv_h =1./prandtl
Tmpv4018(i,k,j) =pr_inv_h
Tmpv001 =2.0*mlen_v/deltas
Tmpv002 =1.0 +Tmpv001
pr_inv_v =Tmpv002
Tmpv4019(i,k,j) =pr_inv_v
Tmpv001 =xkmh(i,k,j)*pr_inv_h
xkhh(i,k,j) =Tmpv001
Tmpv001 =xkmv(i,k,j)*pr_inv_v
xkhv(i,k,j) =Tmpv001
ENDDO
ENDDO
ENDDO
ELSE
CALL calc_l_scale(config_flags,tke,BN2,l_scale,i_start,i_end,ktf,j_start,j_end,dx, &
dy,rdzw,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
tmp =sqrt(max(tke(i,k,j), tke_seed))
Tmpv4020(i,k,j) =tmp
deltas =(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
Tmpv4021(i,k,j) =deltas
Tmpv001 =c_k*tmp
Tmpv4022(i,k,j) =Tmpv001
Tmpv002 =Tmpv4022(i,k,j)*l_scale(i,k,j)
! Tmpv4023(i,k,j) =xkmh(i,k,j) ! Remarked by Ning Pan, 2010-08-13
xkmh(i,k,j) =Tmpv002
Tmpv4024(i,k,j) =xkmh(i,k,j)
xkmh(i,k,j) =min(mix_upper_bound*dx/msftx(i,j)*dy/msfty(i,j)/dt, xkmh(i,k,j))
Tmpv001 =c_k*tmp
Tmpv4025(i,k,j) =Tmpv001
Tmpv002 =Tmpv4025(i,k,j)*l_scale(i,k,j)
! Tmpv4026(i,k,j) =xkmv(i,k,j) ! Remarked by Ning Pan, 2010-08-13
xkmv(i,k,j) =Tmpv002
Tmpv4027(i,k,j) =xkmv(i,k,j)
xkmv(i,k,j) =min(mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt, xkmv(i,k,j))
Tmpv001 =2.0*l_scale(i,k,j)/deltas
Tmpv002 =1.0 +Tmpv001
pr_inv =Tmpv002
Tmpv4028(i,k,j) =pr_inv
Tmpv001 =xkmh(i,k,j)*pr_inv
Tmpv4029(i,k,j) =Tmpv001
xkhh(i,k,j) =min(mix_upper_bound*dx/msftx(i,j)*dy/msfty(i,j)/dt, Tmpv4029(i,k,j))
Tmpv001 =xkmv(i,k,j)*pr_inv
Tmpv4030(i,k,j) =Tmpv001
xkhv(i,k,j) =min(mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt, Tmpv4030(i,k,j))
ENDDO
ENDDO
ENDDO
END IF
IF( isotropic .EQ. 0 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
!ADDED BY WALLS
mlen_h =Tmpv400(i,k,j)
tmp =Tmpv401(i,k,j)
deltas =Tmpv402(i,k,j)
mlen_v =Tmpv403(i,k,j)
pr_inv_v =Tmpv4019(i,k,j)
pr_inv_h =Tmpv4018(i,k,j)
xkmv(i,k,j) =Tmpv4017(i,k,j)
xkmh(i,k,j) =Tmpv4012(i,k,j)
a_Tmpv1 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +pr_inv_v*a_Tmpv1
a_pr_inv_v =a_pr_inv_v +xkmv(i,k,j)*a_Tmpv1
a_Tmpv1 =a_xkhh(i,k,j)
a_xkhh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +pr_inv_h*a_Tmpv1
a_pr_inv_h =a_pr_inv_h +xkmh(i,k,j)*a_Tmpv1
a_Tmpv2 =a_pr_inv_v
a_pr_inv_v =0.0
a_Tmpv1 =a_Tmpv2
a_mlen_v =a_mlen_v +2.0/deltas*a_Tmpv1
a_deltas =a_deltas -2.0*mlen_v/(deltas*deltas)*a_Tmpv1
a_pr_inv_h =0.0
xkmv(i,k,j) =Tmpv4016(i,k,j)
a_Tmpv1 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_xkmv(i,k,j) =a_xkmv(i,k,j) +(1.0 -sign(1.0, xkmv(i,k,j) -mix_upper_bound* &
deltas*deltas/dt))*0.5*1.0*a_Tmpv1
a_deltas =a_deltas +(1.0 +sign(1.0, xkmv(i,k,j) -mix_upper_bound*deltas* &
deltas/dt))*0.5*(mix_upper_bound*deltas +mix_upper_bound*deltas)/dt*a_Tmpv1
a_Tmpv3 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_Tmpv2 =(1.0 +sign(1.0, Tmpv4015(i,k,j) -1.0E-6*deltas*deltas))*0.5*a_Tmpv3
a_deltas =a_deltas +(1.0 -sign(1.0, Tmpv4015(i,k,j) -1.0E-6*deltas*deltas)) &
*0.5*(1.0E-6*deltas +1.0E-6*deltas)*a_Tmpv3
a_Tmpv1 =mlen_v*a_Tmpv2
a_mlen_v =a_mlen_v +Tmpv4013(i,k,j)*a_Tmpv2
a_c_k =a_c_k +tmp*a_Tmpv1
a_tmp =a_tmp +c_k*a_Tmpv1
xkmh(i,k,j) =Tmpv4011(i,k,j)
a_Tmpv1 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +(1.0 -sign(1.0, xkmh(i,k,j) -mix_upper_bound* &
mlen_h*mlen_h/dt))*0.5*1.0*a_Tmpv1
a_mlen_h =a_mlen_h +(1.0 +sign(1.0, xkmh(i,k,j) -mix_upper_bound*mlen_h* &
mlen_h/dt))*0.5*(mix_upper_bound*mlen_h +mix_upper_bound*mlen_h)/dt*a_Tmpv1
a_Tmpv3 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_Tmpv2 =(1.0 +sign(1.0, Tmpv4010(i,k,j) -1.0E-6*mlen_h*mlen_h))*0.5*a_Tmpv3
a_mlen_h =a_mlen_h +(1.0 -sign(1.0, Tmpv4010(i,k,j) -1.0E-6*mlen_h*mlen_h)) &
*0.5*(1.0E-6*mlen_h +1.0E-6*mlen_h)*a_Tmpv3
a_Tmpv1 =mlen_h*a_Tmpv2
a_mlen_h =a_mlen_h +Tmpv408(i,k,j)*a_Tmpv2
a_c_k =a_c_k +tmp*a_Tmpv1
a_tmp =a_tmp +c_k*a_Tmpv1
IF( dthrdn(i,k,j) .GT. 0.) THEN
!REVISED AND ADDED BY WALLS
mlen_s =Tmpv4020(i,k,j)
mlen_v =Tmpv407(i,k,j)
!MOVE FROM BELOW
a_Tmpv1 =a_mlen_v
a_mlen_v =0.0
a_mlen_v =a_mlen_v +(1.0 -sign(1.0, mlen_v -mlen_s))*0.5*1.0*a_Tmpv1
a_mlen_s =a_mlen_s +(1.0 +sign(1.0, mlen_v -mlen_s))*0.5*1.0*a_Tmpv1
a_Tmpv4 =a_mlen_s
a_mlen_s =0.0
a_tmp =a_tmp +0.76/Tmpv406(i,k,j)*a_Tmpv4
a_Tmpv3 =-0.76*tmp/(Tmpv406(i,k,j)*Tmpv406(i,k,j))*a_Tmpv4
a_Tmpv2 =0.5*Tmpv405(i,k,j)**(0.5 -1)*a_Tmpv3
a_Tmpv1 =sign(1.0, Tmpv404(i,k,j))*a_Tmpv2
a_theta(i,k,j) =a_theta(i,k,j) -g/(theta(i,k,j)*theta(i,k,j))*dthrdn(i,k,j)*a_Tmpv1
a_dthrdn(i,k,j) =a_dthrdn(i,k,j) +g/theta(i,k,j)*a_Tmpv1
!MOVE LINES TO ABOVE
! a_Tmpv1 =a_mlen_v
! a_mlen_v =0.0
! a_mlen_v =a_mlen_v +(1.0 -sign(1.0, mlen_v -mlen_s))*0.5*1.0*a_Tmpv1
! a_mlen_s =a_mlen_s +(1.0 +sign(1.0, mlen_v -mlen_s))*0.5*1.0*a_Tmpv1
END IF
! mlen_v =Tmpv403(i,k,j)
a_deltas =a_deltas +a_mlen_v
a_mlen_v =0.0
! deltas =Tmpv402(i,k,j)
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1.0/(rdzw(i,k,j)*rdzw(i,k,j))*a_deltas
a_deltas =0.0
! tmp =Tmpv401(i,k,j)
a_tke(i,k,j) =a_tke(i,k,j) +g_Sqrt((1.0 +(1.0)*sign(1.0, tke(i,k,j) &
-tke_seed))*0.5, max(tke(i,k,j), tke_seed))*a_tmp
a_tmp =0.0
! mlen_h =Tmpv400(i,k,j)
a_mlen_h =0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
tmp =Tmpv4020(i,k,j)
deltas =Tmpv4021(i,k,j)
pr_inv =Tmpv4028(i,k,j)
!DELETED BY WALLS
! (1.0 -(-1.0)*sign(1.0, mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt -Tmpv4030(i,k,j) &
! ))*0.5* =a_xkhv(i,k,j)
a_Tmpv2 =a_xkhv(i,k,j)
a_xkhv(i,k,j) =0.0
a_rdzw(i,k,j) =a_rdzw(i,k,j) +(1.0 -sign(1.0, mix_upper_bound/rdzw(i,k,j) &
/rdzw(i,k,j)/dt -Tmpv4030(i,k,j)))*0.5*(-mix_upper_bound/(rdzw(i,k,j)*rdzw(i,k,j)) &
*rdzw(i,k,j) -mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))/dt*a_Tmpv2
a_Tmpv1 =(1.0 +sign(1.0, mix_upper_bound/rdzw(i,k,j)/rdzw(i,k,j)/dt -Tmpv4030(i, &
k,j)))*0.5*a_Tmpv2
a_xkmv(i,k,j) =a_xkmv(i,k,j) +pr_inv*a_Tmpv1
a_pr_inv =a_pr_inv +xkmv(i,k,j)*a_Tmpv1
!REVISED BY WALLS
! (1.0 -(-1.0)*sign(1.0, mix_upper_bound*dx/msftx(i,j)*dy/msfty(i,j)/dt -Tmpv4029(i, &
! k,j)))*0.5* =a_xkhh(i,k,j)
a_Tmpv1 =(1.0 -(-1.0)*sign(1.0, mix_upper_bound*dx/msftx(i,j)*dy/msfty(i,j)/dt -Tmpv4029(i, &
k,j)))*0.5*a_xkhh(i,k,j)
a_xkhh(i,k,j) =0.0
a_xkmh(i,k,j) =a_xkmh(i,k,j) +pr_inv*a_Tmpv1
a_pr_inv =a_pr_inv +xkmh(i,k,j)*a_Tmpv1
a_Tmpv2 =a_pr_inv
a_pr_inv =0.0
a_Tmpv1 =a_Tmpv2
a_l_scale(i,k,j) =a_l_scale(i,k,j) +2.0/deltas*a_Tmpv1
a_deltas =a_deltas -2.0*l_scale(i,k,j)/(deltas*deltas)*a_Tmpv1
xkmv(i,k,j) =Tmpv4027(i,k,j)
a_Tmpv1 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_rdzw(i,k,j) =a_rdzw(i,k,j) +(1.0 -sign(1.0, mix_upper_bound/rdzw(i,k,j) &
/rdzw(i,k,j)/dt -xkmv(i,k,j)))*0.5*(-mix_upper_bound/(rdzw(i,k,j)*rdzw(i,k,j)) &
*rdzw(i,k,j) -mix_upper_bound/rdzw(i,k,j))/(rdzw(i,k,j)*rdzw(i,k,j))/dt*a_Tmpv1
a_xkmv(i,k,j) =a_xkmv(i,k,j) +(1.0 +sign(1.0, mix_upper_bound/rdzw(i,k,j) &
/rdzw(i,k,j)/dt -xkmv(i,k,j)))*0.5*1.0*a_Tmpv1
! xkmv(i,k,j) =Tmpv4026(i,k,j) ! Remarked by Ning Pan, 2010-08-13
a_Tmpv2 =a_xkmv(i,k,j)
a_xkmv(i,k,j) =0.0
a_Tmpv1 =l_scale(i,k,j)*a_Tmpv2
a_l_scale(i,k,j) =a_l_scale(i,k,j) +Tmpv4025(i,k,j)*a_Tmpv2
a_c_k =a_c_k +tmp*a_Tmpv1
a_tmp =a_tmp +c_k*a_Tmpv1
xkmh(i,k,j) =Tmpv4024(i,k,j)
a_xkmh(i,k,j) =(1.0 -(-1.0)*sign(1.0, mix_upper_bound*dx/msftx(i,j) &
*dy/msfty(i,j)/dt -xkmh(i,k,j)))*0.5*a_xkmh(i,k,j)
! xkmh(i,k,j) =Tmpv4023(i,k,j) ! Remarked by Ning Pan, 2010-08-13
a_Tmpv2 =a_xkmh(i,k,j)
a_xkmh(i,k,j) =0.0
a_Tmpv1 =l_scale(i,k,j)*a_Tmpv2
a_l_scale(i,k,j) =a_l_scale(i,k,j) +Tmpv4022(i,k,j)*a_Tmpv2
a_c_k =a_c_k +tmp*a_Tmpv1
a_tmp =a_tmp +c_k*a_Tmpv1
a_rdzw(i,k,j) =a_rdzw(i,k,j) -dx/msftx(i,j)*dy/msfty(i,j)/(rdzw(i,k,j) &
*rdzw(i,k,j))*0.33333333*(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1)*a_deltas
a_deltas =0.0
a_tke(i,k,j) =a_tke(i,k,j) +g_Sqrt((1.0 +(1.0)*sign(1.0, tke(i,k,j) &
-tke_seed))*0.5, max(tke(i,k,j), tke_seed))*a_tmp
a_tmp =0.0
ENDDO
ENDDO
ENDDO
CALL a_calc_l_scale(config_flags,tke,a_tke,BN2,a_BN2,l_scale,a_l_scale, &
i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,a_rdzw,msftx,msfty,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
END IF
!LPB[19]
!ADDED BY WALLS
!FROM LPB[17]
k = ktf
!LPB[18]
DO j =j_end, j_start, -1
! tmpdz =Keep_Lpb18_tmpdz(j) ! Remarked by Ning Pan, 2010-08-13
DO i =i_start, i_end
tmpdz =1.0/rdz(i,k,j)+0.5/rdzw(i,k,j)
Tmpv200(i) =tmpdz
Tmpv001 =T8w(i,kde,j)/(p8w(i,kde,j)/p1000mb)**(R_d/Cp)
thetatop =Tmpv001
Tmpv001 =thetatop -theta(i,k-1,j)
Tmpv201(i) =Tmpv001
! Remarked by Ning Pan, 2010-08-13
! Tmpv002 =Tmpv201(i)/tmpdz
! dthrdn(i,k,j) =Tmpv002
ENDDO
DO i =i_end, i_start, -1
tmpdz =Tmpv200(i)
a_Tmpv2 =a_dthrdn(i,k,j)
a_dthrdn(i,k,j) =0.0
a_Tmpv1 =a_Tmpv2/tmpdz
a_tmpdz =a_tmpdz -Tmpv201(i)/(tmpdz*tmpdz)*a_Tmpv2
a_thetatop =a_thetatop +a_Tmpv1
a_theta(i,k-1,j) =a_theta(i,k-1,j) -a_Tmpv1
a_Tmpv1 =a_thetatop
a_thetatop =0.0
a_T8w(i,kde,j) =a_T8w(i,kde,j) +a_Tmpv1/(p8w(i,kde,j)/p1000mb)**(R_d/Cp)
a_p8w(i,kde,j) =a_p8w(i,kde,j) -(R_d/Cp)*1.0/p1000mb*(p8w(i,kde,j)/p1000mb) &
**((R_d/Cp) -1)*T8w(i,kde,j)/((p8w(i,kde,j)/p1000mb)**(R_d/Cp)*(p8w(i,kde,j)/p1000mb) &
**(R_d/Cp))*a_Tmpv1
a_Tmpv1 =a_tmpdz
a_tmpdz =0.0
a_rdz(i,k,j) =a_rdz(i,k,j) -1.0/(rdz(i,k,j)*rdz(i,k,j))*a_Tmpv1
a_rdzw(i,k,j) =a_rdzw(i,k,j) -0.5/(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
ENDDO
ENDDO
!LPB[17]
! k =ktf
!ADDED BY WALLS
!FROM LPB[15]
k = kts
!LPB[16]
DO j =j_end, j_start, -1
! tmpdz =Keep_Lpb16_tmpdz(j) ! Remarked by Ning Pan, 2010-08-13
DO i =i_start, i_end
tmpdz =1.0/rdzw(i,k+1,j) + 1.0/rdzw(i,k,j)
Tmpv200(i) =tmpdz
Tmpv001 =T8w(i,kts,j)/(p8w(i,k,j)/p1000mb)**(R_d/Cp)
thetasfc =Tmpv001
Tmpv001 =theta(i,k+1,j) -thetasfc
Tmpv201(i) =Tmpv001
! Remarked by Ning Pan, 2010-08-13
! Tmpv002 =Tmpv201(i)/tmpdz
! dthrdn(i,k,j) =Tmpv002
ENDDO
DO i =i_end, i_start, -1
tmpdz =Tmpv200(i)
a_Tmpv2 =a_dthrdn(i,k,j)
a_dthrdn(i,k,j) =0.0
a_Tmpv1 =a_Tmpv2/tmpdz
a_tmpdz =a_tmpdz -Tmpv201(i)/(tmpdz*tmpdz)*a_Tmpv2
a_theta(i,k+1,j) =a_theta(i,k+1,j) +a_Tmpv1
a_thetasfc =a_thetasfc -a_Tmpv1
a_Tmpv1 =a_thetasfc
a_thetasfc =0.0
a_T8w(i,kts,j) =a_T8w(i,kts,j) +a_Tmpv1/(p8w(i,k,j)/p1000mb)**(R_d/Cp)
a_p8w(i,k,j) =a_p8w(i,k,j) -(R_d/Cp)*1.0/p1000mb*(p8w(i,k,j)/p1000mb) &
**((R_d/Cp) -1)*T8w(i,kts,j)/((p8w(i,k,j)/p1000mb)**(R_d/Cp)*(p8w(i,k,j)/p1000mb) &
**(R_d/Cp))*a_Tmpv1
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Tmpv001 =(rdzw(i,k+1,j)+rdzw(i,k,j))
a_Tmpv2 =a_tmpdz
a_tmpdz =0.0
a_Tmpv1 =-(1.0)*a_Tmpv2/(Tmpv001*Tmpv001)
!hcl a_rdzw(i,k+1,j) =a_rdzw(i,k+1,j) +a_Tmpv1
!hcl a_rdzw(i,k,j) =a_rdzw(i,k,j) +a_Tmpv1
a_rdzw(i,k+1,j) =a_rdzw(i,k+1,j) - a_tmpv2/(rdzw(i,k+1,j)*rdzw(i,k+1,j))
a_rdzw(i,k,j) =a_rdzw(i,k,j) - a_tmpv2/(rdzw(i,k,j)*rdzw(i,k,j))
ENDDO
ENDDO
!LPB[15]
! k =kts
!LPB[14]
DO j =j_end, j_start, -1
DO k =kts+1, ktf-1
DO i =i_start, i_end
tmpdz = 1.0/rdz(i,k+1,j) + 1.0/rdz(i,k,j)
Tmpv300(i,k) =tmpdz
Tmpv001 =theta(i,k+1,j) -theta(i,k-1,j)
Tmpv301(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-13
! Tmpv002 =Tmpv301(i,k)/tmpdz
! dthrdn(i,k,j) =Tmpv002
ENDDO
ENDDO
DO k =ktf-1, kts+1, -1
DO i =i_end, i_start, -1
tmpdz =Tmpv300(i,k)
a_Tmpv2 =a_dthrdn(i,k,j)
a_dthrdn(i,k,j) =0.0
a_Tmpv1 =a_Tmpv2/tmpdz
a_tmpdz =a_tmpdz -Tmpv301(i,k)/(tmpdz*tmpdz)*a_Tmpv2
a_theta(i,k+1,j) =a_theta(i,k+1,j) +a_Tmpv1
a_theta(i,k-1,j) =a_theta(i,k-1,j) -a_Tmpv1
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
!BIG ERRORS, ADDED BY WALLS
Tmpv001 =(rdz(i,k+1,j)+rdz(i,k,j))
a_Tmpv2 =a_tmpdz
a_tmpdz =0.0
a_Tmpv1 =-(1.0)*a_Tmpv2/(Tmpv001*Tmpv001)
!hcl a_rdz(i,k+1,j) =a_rdz(i,k+1,j) +a_Tmpv1
!hcl a_rdz(i,k,j) =a_rdz(i,k,j) +a_Tmpv1
a_rdz(i,k+1,j) =a_rdz(i,k+1,j) - a_tmpv2/(rdz(i,k+1,j)*rdz(i,k+1,j))
a_rdz(i,k,j) =a_rdz(i,k,j) - a_tmpv2/(rdz(i,k,j)*rdz(i,k,j))
ENDDO
ENDDO
ENDDO
!LPB[13]
! IF( (config_flags%tke_drag_coefficient .gt. epsilon) .or. (config_flags%tke_heat_flux .gt. epsilon) ) THEN
! tke_seed =0.
! END IF
! IF( (config_flags%tke_drag_coefficient .gt. epsilon) .or. &
! (config_flags%tke_heat_flux .gt. epsilon) ) THEN
! END IF
!LPB[12]
! c_k =config_flags%c_k
! tke_seed =tke_seed_value
!REVISED BY WALLS
! a_config_flags%c_k =a_config_flags%c_k +a_c_k
a_c_k =0.0
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
DEALLOCATE ( Tmpv200, Tmpv201, Tmpv300, Tmpv301, &
Tmpv400, &
Tmpv401, Tmpv402, Tmpv403, Tmpv404, Tmpv405, Tmpv406, Tmpv407, Tmpv408, Tmpv409, Tmpv4010, &
Tmpv4011, Tmpv4012, Tmpv4013, Tmpv4014, Tmpv4015, Tmpv4016, Tmpv4017, Tmpv4018, Tmpv4019, Tmpv4020, &
Tmpv4021, Tmpv4022, Tmpv4023, Tmpv4024, Tmpv4025, Tmpv4026, Tmpv4027, Tmpv4028, Tmpv4029, Tmpv4030, &
Tmpv4031 )
END SUBROUTINE a_tke_km
SUBROUTINE a_tke_rhs(tendency,a_tendency,BN2,a_BN2,config_flags,defor11, &
a_defor11,defor22,a_defor22,defor33,a_defor33,defor12,a_defor12,defor13, &
a_defor13,defor23,a_defor23,u,a_u,v,a_v,w,a_w,div,a_div,tke,a_tke,mu, &
a_mu,c1,c2,theta,a_theta,p,a_p,p8w,a_p8w,t8w,a_t8w,z,a_z,fnm,fnp,cf1,cf2,cf3, &
msftx,msfty,xkmh,a_xkmh,xkmv,a_xkmv,xkhv,a_xkhv,rdx,rdy,dx,dy,dt,zx,a_zx,zy, &
a_zy,rdz,a_rdz,rdzw,a_rdzw,dn,dnw,isotropic,hfx,a_hfx,qfx,a_qfx,qv,a_qv, &
ust,a_ust,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: cf1,cf2,cf3,dt,rdx,rdy,dx,dy
REAL,DIMENSION(kms:kme) :: fnm,fnp,dnw,dn
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor22,a_defor22, &
defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,div, &
a_div,BN2,a_BN2,tke,a_tke,xkmh,a_xkmh,xkmv,a_xkmv,xkhv,a_xkhv,zx,a_zx, &
zy,a_zy,u,a_u,v,a_v,w,a_w,theta,a_theta,p,a_p,p8w,a_p8w,t8w,a_t8w,z, &
a_z,rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
real, dimension(kms:kme) :: c1, c2
REAL,DIMENSION(ims:ime,jms:jme) :: hfx,a_hfx,ust,a_ust,qfx,a_qfx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: qv,a_qv,rho,a_rho
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_tendency
INTEGER :: IX1,IX2,IX3
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv400
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv401
REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv402
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
! Remarked by Ning Pan, 2010-08-13
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_tendency(IX1,IX2,IX3) =tendency(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL tke_shear( tendency, config_flags, &
defor11, defor22, defor33, &
defor12, defor13, defor23, &
u, v, w, tke, ust, mu, &
c1, c2, fnm, fnp, &
cf1, cf2, cf3, msftx, msfty, &
xkmh, xkmv, &
rdx, rdy, zx, zy, rdz, rdzw, dnw, dn, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
CALL tke_buoyancy( tendency, config_flags, mu, c1, c2, &
tke, xkhv, BN2, theta, dt, &
hfx, qfx, qv, rho, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
CALL tke_dissip( tendency, config_flags, mu, c1, c2, &
tke, bn2, theta, p8w, t8w, z, &
dx, dy,rdz, rdzw, isotropic, &
msftx, msfty, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!!LPB[12]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = max( tendency(i,k,j), -mu(i,j) * max( 0.0 , tke(i,k,j) ) / dt )
! END DO
! END DO
! END DO
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[12]
DO j =j_end, j_start, -1
! Remarks removed by Ning Pan, 2010-08-13
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =-mu(i,j)*max(0.0, tke(i,k,j))
Tmpv002 =Tmpv001/dt
Tmpv300(i,k) =Tmpv002
Tmpv301(i,k) =Tmpv300(i,k)
! Tmpv003 =max(tendency(i,k,j), Tmpv301(i,k))
! tendency(i,k,j) =Tmpv003
! Remarks removed by Ning Pan, 2010-08-13
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +(1.0 +sign(1.0, tendency(i,k,j) &
-Tmpv301(i,k)))*0.5*1.0*a_Tmpv3
a_Tmpv2 =(1.0 -sign(1.0, tendency(i,k,j) -Tmpv301(i,k)))*0.5*a_Tmpv3
a_Tmpv1 =a_Tmpv2/dt
a_mu(i,j) =a_mu(i,j) -max(0.0, tke(i,k,j))*a_Tmpv1
a_tke(i,k,j) =a_tke(i,k,j) -mu(i,j)*(1.0 +(-1.0)*sign(1.0, 0.0 -tke(i,k,j))) &
*0.5*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! Remarked by Ning Pan, 2010-08-13
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tendency(IX1,IX2,IX3) =Keep_Lpb0_tendency(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv400(IX1,IX2,IX3) =tendency(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL tke_shear(tendency,config_flags,defor11,defor22,defor33,defor12,defor13, &
! defor23,u,v,w,tke,ust,mu,fnm,fnp,cf1,cf2,cf3,msftx,msfty,xkmh,xkmv,rdx,rdy,zx,zy,rdz, &
! rdzw,dnw,dn,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv401(IX1,IX2,IX3) =tendency(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL tke_buoyancy(tendency,config_flags,mu,tke,xkhv,BN2,theta,dt,hfx,qfx,qv,rho, &
! ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv402(IX1,IX2,IX3) =tendency(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL tke_dissip(tendency,config_flags,mu,tke,bn2,theta,p8w,t8w,z,dx,dy,rdz,rdzw, &
! isotropic,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
! jte,kts,kte)
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tendency(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_tke_dissip(tendency,a_tendency,config_flags,mu,a_mu,tke,a_tke,bn2, &
a_bn2,theta,a_theta,p8w,a_p8w,t8w,a_t8w,z,a_z,dx,dy,rdz,a_rdz,rdzw, &
a_rdzw,isotropic,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-13
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tendency(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_tke_buoyancy(tendency,a_tendency,config_flags,mu,a_mu,tke,a_tke, &
xkhv,a_xkhv,BN2,a_BN2,theta,a_theta,dt,hfx,a_hfx,qfx,a_qfx,qv,a_qv,rho, &
a_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-13
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tendency(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_tke_shear(tendency,a_tendency,config_flags,defor11,a_defor11,defor22, &
a_defor22,defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23, &
a_defor23,u,a_u,v,a_v,w,a_w,tke,a_tke,ust,a_ust,mu,a_mu,fnm,fnp,cf1, &
cf2,cf3,msftx,msfty,xkmh,a_xkmh,xkmv,a_xkmv,rdx,rdy,zx,a_zx,zy,a_zy,rdz, &
a_rdz,rdzw,a_rdzw,dnw,dn,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
END SUBROUTINE a_tke_rhs
SUBROUTINE a_calc_l_scale(config_flags,tke,a_tke,BN2,a_BN2,l_scale,a_l_scale, &
i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,a_rdzw,msftx,msfty,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
INTEGER :: i_start,i_end,ktf,j_start,j_end,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) :: BN2,a_BN2,tke,a_tke,rdzw,a_rdzw
REAL :: dx,dy
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,a_l_scale
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
INTEGER :: i,j,k
REAL :: deltas,a_deltas,tmp,a_tmp
REAL :: a_Tmpv1,Tmpv001
REAL,DIMENSION(i_start:i_end,kts:ktf) :: Tmpv300
REAL,DIMENSION(i_start:i_end,kts:ktf) :: Tmpv301,Tmpv302,Tmpv303 ! Added by Ning Pan, 2010-08-12
REAL :: g_Sqrt
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!!LPB[0]
! DO j = j_start, j_end
!
! DO k = kts, ktf
! DO i = i_start, i_end
! deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
! l_scale(i,k,j) = deltas
! IF ( BN2(i,k,j) .gt. 1.0e-6 ) THEN
! tmp = SQRT( MAX( tke(i,k,j), 1.0e-6 ) )
! l_scale(i,k,j) = 0.76 * tmp / SQRT( BN2(i,k,j) )
! l_scale(i,k,j) = MIN( l_scale(i,k,j), deltas)
! l_scale(i,k,j) = MAX( l_scale(i,k,j), 0.001 * deltas )
! END IF
! END DO
! END DO
! END DO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
a_deltas =0.0
a_tmp =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[0]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
deltas =(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
Tmpv301(i,k) = deltas ! Added by Ning Pan, 2010-08-13
l_scale(i,k,j) =deltas
IF( BN2(i,k,j) .gt. 1.0e-6 ) THEN
! Revised by Ning Pan, 2010-08-12
! Tmpv300(i,k) =tmp
! tmp =sqrt(max(tke(i,k,j), 1.0e-6))
tmp =sqrt(max(tke(i,k,j), 1.0e-6))
Tmpv300(i,k) =tmp
Tmpv001 =0.76*tmp/sqrt(BN2(i,k,j))
l_scale(i,k,j) =Tmpv001
Tmpv302(i,k) = l_scale(i,k,j) ! Added by Ning Pan, 2010-08-12
Tmpv001 =min(l_scale(i,k,j), deltas)
l_scale(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-13
! Tmpv001 =max(l_scale(i,k,j), 0.001*deltas)
! l_scale(i,k,j) =Tmpv001
END IF
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
IF( BN2(i,k,j) .gt. 1.0e-6 ) THEN
deltas = Tmpv301(i,k) ! Added by Ning Pan, 2010-08-13
a_Tmpv1 =a_l_scale(i,k,j)
a_l_scale(i,k,j) =0.0
a_l_scale(i,k,j) =a_l_scale(i,k,j) +(1.0 +sign(1.0, l_scale(i,k,j) &
-0.001*deltas))*0.5*1.0*a_Tmpv1
a_deltas =a_deltas +(1.0 -sign(1.0, l_scale(i,k,j) -0.001*deltas))*0.5*0.001*a_Tmpv1
l_scale(i,k,j) = Tmpv302(i,k) ! Added by Ning Pan, 2010-08-12
a_Tmpv1 =a_l_scale(i,k,j)
a_l_scale(i,k,j) =0.0
a_l_scale(i,k,j) =a_l_scale(i,k,j) +(1.0 -sign(1.0, l_scale(i,k,j) -deltas)) &
*0.5*1.0*a_Tmpv1
a_deltas =a_deltas +(1.0 +sign(1.0, l_scale(i,k,j) -deltas))*0.5*1.0*a_Tmpv1
tmp =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-12
a_Tmpv1 =a_l_scale(i,k,j)
a_l_scale(i,k,j) =0.0
a_tmp =a_tmp +0.76/sqrt(BN2(i,k,j))*a_Tmpv1
a_BN2(i,k,j) =a_BN2(i,k,j) -g_Sqrt(1.0, BN2(i,k,j))*0.76*tmp/(sqrt(BN2(i,k, &
j))*sqrt(BN2(i,k,j)))*a_Tmpv1
! tmp =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-12
a_tke(i,k,j) =a_tke(i,k,j) +g_Sqrt((1.0 +(1.0)*sign(1.0, tke(i,k,j) &
-1.0e-6))*0.5, max(tke(i,k,j), 1.0e-6))*a_tmp
a_tmp =0.0
END IF
a_deltas =a_deltas +a_l_scale(i,k,j)
a_l_scale(i,k,j) =0.0
a_rdzw(i,k,j) =a_rdzw(i,k,j) -dx/msftx(i,j)*dy/msfty(i,j)/(rdzw(i,k,j) &
*rdzw(i,k,j))*0.33333333*(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1)*a_deltas
a_deltas =0.0
ENDDO
ENDDO
ENDDO
END SUBROUTINE a_calc_l_scale
SUBROUTINE a_tke_buoyancy(tendency,a_tendency,config_flags,mu,a_mu,tke,a_tke, &
xkhv,a_xkhv,BN2,a_BN2,theta,a_theta,dt,hfx,a_hfx,qfx,a_qfx,qv,a_qv,rho, &
a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: dt
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhv,a_xkhv,tke,a_tke,BN2,a_BN2, &
theta,a_theta
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: qv,a_qv,rho,a_rho
REAL,DIMENSION(ims:ime,jms:jme) :: hfx,a_hfx,qfx,a_qfx
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
REAL :: heat_flux,a_heat_flux,heat_flux0,a_heat_flux0
REAL :: cpm,a_cpm
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,max(jds+1,jts)):max0(min(kte,kde-1) &
,min(jde-2,jte))) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv302
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv303
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv304
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv305
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested ) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested ) i_end = MIN( ide-2, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested ) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested ) j_end = MIN( jde-2, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!LPB[12]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end
tendency(i,k,j) = tendency(i,k,j) - mu(i,j) * xkhv(i,k,j) * BN2(i,k,j)
END DO
END DO
END DO
!LPB[13]
!!LPB[14]
! hflux: SELECT CASE( config_flags%isfflx )
! CASE (0,2)
! heat_flux0 = config_flags%tke_heat_flux
! K=KTS
! DO j = j_start, j_end
! DO i = i_start, i_end
! heat_flux = heat_flux0
! tendency(i,k,j)= tendency(i,k,j) - &
! mu(i,j)*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2.
! ENDDO
! ENDDO
! CASE (1)
! K=KTS
! DO j = j_start, j_end
! DO i = i_start, i_end
! cpm = cp * (1. + 0.8*qv(i,k,j))
! heat_flux = (hfx(i,j)/cpm)/rho(i,k,j)
! tendency(i,k,j)= tendency(i,k,j) - &
! mu(i,j)*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2.
! ENDDO
! ENDDO
! CASE DEFAULT
! CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
! END SELECT hflux
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
a_heat_flux =0.0
! a_heat_flux0 =0.0 ! Remarked by Ning Pan, 2010-08-12
a_cpm =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[14]
SELECT CASE (config_flags%isfflx)
CASE(0,2)
heat_flux0 =config_flags%tke_heat_flux
K =KTS
DO j =j_start, j_end
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-12
! Tmpv300(i,j) =heat_flux
! heat_flux =heat_flux0
heat_flux =heat_flux0
Tmpv300(i,j) =heat_flux
Tmpv001 =xkhv(i,k,j)*BN2(i,k,j)
Tmpv002 =(g/theta(i,k,j))*heat_flux
Tmpv003 =Tmpv001 -Tmpv002
Tmpv301(i,j) =Tmpv003
! Remarked by Ning Pan, 2010-08-12
! Tmpv004 =mu(i,j)*Tmpv301(i,j)
! Tmpv005 =Tmpv004/2.
! Tmpv006 =tendency(i,k,j) -Tmpv005
! tendency(i,k,j) =Tmpv006
ENDDO
ENDDO
CASE(1)
K =KTS
DO j =j_start, j_end
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-12
! Tmpv302(i,j) =cpm
! cpm =cp*(1. +0.8*qv(i,k,j))
cpm =cp*(1. +0.8*qv(i,k,j))
Tmpv302(i,j) =cpm
Tmpv001 =hfx(i,j)/cpm
Tmpv303(i,j) =Tmpv001
Tmpv002 =Tmpv303(i,j)/rho(i,k,j)
! Revised by Ning Pan, 2010-08-12
! Tmpv304(i,j) =heat_flux
! heat_flux =Tmpv002
heat_flux =Tmpv002
Tmpv304(i,j) =heat_flux
Tmpv001 =xkhv(i,k,j)*BN2(i,k,j)
Tmpv002 =(g/theta(i,k,j))*heat_flux
Tmpv003 =Tmpv001 -Tmpv002
Tmpv305(i,j) =Tmpv003
Tmpv004 =mu(i,j)*Tmpv305(i,j)
Tmpv005 =Tmpv004/2.
Tmpv006 =tendency(i,k,j) -Tmpv005
tendency(i,k,j) =Tmpv006
ENDDO
ENDDO
CASE DEFAULT
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-12
! END SELECT hflux
END SELECT
SELECT CASE (config_flags%isfflx)
CASE(0,2)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
heat_flux =Tmpv300(i,j) ! Added by Ning Pan, 2010-08-12
a_Tmpv6 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv4 =a_Tmpv5/2.
a_mu(i,j) =a_mu(i,j) +Tmpv301(i,j)*a_Tmpv4
a_Tmpv3 =mu(i,j)*a_Tmpv4
a_Tmpv1 =a_Tmpv3
a_Tmpv2 =-a_Tmpv3
a_theta(i,k,j) =a_theta(i,k,j) -g/(theta(i,k,j)*theta(i,k,j))*heat_flux*a_Tmpv2
a_heat_flux =a_heat_flux +(g/theta(i,k,j))*a_Tmpv2
a_xkhv(i,k,j) =a_xkhv(i,k,j) +BN2(i,k,j)*a_Tmpv1
a_BN2(i,k,j) =a_BN2(i,k,j) +xkhv(i,k,j)*a_Tmpv1
! heat_flux =Tmpv300(i,j) ! Remarked by Ning Pan, 2010-08-12
! a_heat_flux0 =a_heat_flux0 +a_heat_flux ! Remarked by Ning Pan, 2010-08-12
a_heat_flux =0.0
ENDDO
ENDDO
! Remarked by Ning Pan, 2010-08-12
! a_config_flags%tke_heat_flux =a_config_flags%tke_heat_flux +a_heat_flux0
! a_heat_flux0 =0.0
CASE(1)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
! Added by Ning Pan, 2010-08-12
cpm =Tmpv302(i,j)
heat_flux =Tmpv304(i,j)
a_Tmpv6 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv4 =a_Tmpv5/2.
a_mu(i,j) =a_mu(i,j) +Tmpv305(i,j)*a_Tmpv4
a_Tmpv3 =mu(i,j)*a_Tmpv4
a_Tmpv1 =a_Tmpv3
a_Tmpv2 =-a_Tmpv3
a_theta(i,k,j) =a_theta(i,k,j) -g/(theta(i,k,j)*theta(i,k,j))*heat_flux*a_Tmpv2
a_heat_flux =a_heat_flux +(g/theta(i,k,j))*a_Tmpv2
a_xkhv(i,k,j) =a_xkhv(i,k,j) +BN2(i,k,j)*a_Tmpv1
a_BN2(i,k,j) =a_BN2(i,k,j) +xkhv(i,k,j)*a_Tmpv1
! heat_flux =Tmpv304(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv2 =a_heat_flux
a_heat_flux =0.0
a_Tmpv1 =a_Tmpv2/rho(i,k,j)
a_rho(i,k,j) =a_rho(i,k,j) -Tmpv303(i,j)/(rho(i,k,j)*rho(i,k,j))*a_Tmpv2
a_hfx(i,j) =a_hfx(i,j) +a_Tmpv1/cpm
a_cpm =a_cpm -hfx(i,j)/(cpm*cpm)*a_Tmpv1
! cpm =Tmpv302(i,j) ! Remarked by Ning Pan, 2010-08-12
a_qv(i,k,j) =a_qv(i,k,j) +cp*0.8*a_cpm
a_cpm =0.0
ENDDO
ENDDO
CASE DEFAULT
! Revised by Ning Pan, 2010-08-12
! CALL a_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-12
! END SELECT hflux
END SELECT
!LPB[13]
!LPB[12]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =mu(i,j)*xkhv(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
! Tmpv002 =Tmpv300(i,k)*BN2(i,k,j)
! Tmpv003 =tendency(i,k,j) -Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =-a_Tmpv3
a_Tmpv1 =BN2(i,k,j)*a_Tmpv2
a_BN2(i,k,j) =a_BN2(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +xkhv(i,k,j)*a_Tmpv1
a_xkhv(i,k,j) =a_xkhv(i,k,j) +mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested ) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested ) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested ) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested ) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_tke_buoyancy
SUBROUTINE a_tke_dissip(tendency,a_tendency,config_flags,mu,a_mu,tke,a_tke, &
bn2,a_bn2,theta,a_theta,p8w,a_p8w,t8w,a_t8w,z,a_z,dx,dy,rdz,a_rdz,rdzw, &
a_rdzw,isotropic,msftx,msfty,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: isotropic
REAL :: dx,dy
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tke,a_tke,bn2,a_bn2,theta,a_theta, &
p8w,a_p8w,t8w,a_t8w,z,a_z,rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: dthrdn,a_dthrdn
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: l_scale,a_l_scale
REAL,DIMENSION(its:ite) :: sumtke,a_sumtke,sumtkez,a_sumtkez
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL :: disp_len,a_disp_len,deltas,a_deltas,coefc,a_coefc,tmpdz,a_tmpdz, &
len_s,a_len_s,thetasfc,a_thetasfc,thetatop,a_thetatop,len_0,a_len_0,tketmp, &
a_tketmp,tmp,a_tmp,ce1,a_ce1,ce2,a_ce2,c_k,a_c_k
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv302
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv303
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv304
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv305
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv306
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
c_k = config_flags%c_k
ce1 = ( c_k / 0.10 ) * 0.19
ce2 = max( 0.0 , 0.93 - ce1 )
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-2, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-2, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!LPB[12]
CALL calc_l_scale( config_flags, tke, BN2, l_scale, &
i_start, i_end, ktf, j_start, j_end, &
dx, dy, rdzw, msftx, msfty, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!!LPB[13]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
! tketmp = MAX( tke(i,k,j), 1.0e-6 )
! IF ( k .eq. kts .or. k .eq. ktf ) then
! coefc = 3.9
! ELSE
! coefc = ce1 + ce2 * l_scale(i,k,j) / deltas
! END IF
! tendency(i,k,j) = tendency(i,k,j) - &
! mu(i,j) * coefc * tketmp**1.5 / l_scale(i,k,j)
! END DO
! END DO
! END DO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
! Remarked by Ning Pan, 2010-08-12
! Do K2_ADJ =jts, jte
! Do K1_ADJ =kts, kte
! Do K0_ADJ =its, ite
! a_dthrdn(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
! End Do
! End Do
! End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_l_scale(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
! Remarked by Ning Pan, 2010-08-12
! Do K0_ADJ =its, ite
! a_sumtke(K0_ADJ) =0.0
! End Do
! Do K0_ADJ =its, ite
! a_sumtkez(K0_ADJ) =0.0
! End Do
! a_disp_len =0.0
a_deltas =0.0
a_coefc =0.0
! Remarked by Ning Pan, 2010-08-12
! a_tmpdz =0.0
! a_len_s =0.0
! a_thetasfc =0.0
! a_thetatop =0.0
! a_len_0 =0.0
a_tketmp =0.0
! Remarked by Ning Pan, 2010-08-12
! a_tmp =0.0
! a_ce1 =0.0
! a_ce2 =0.0
! a_c_k =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[13]
DO j =j_end, j_start, -1
! Revised by Ning Pan, 2010-08-12
! DO k =kts, ktf
! DO i =i_start, i_end
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
! Tmpv300(i,k) =deltas
deltas =(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
! Tmpv301(i,k) =tketmp
tketmp =max(tke(i,k,j), 1.0e-6)
IF( k .eq. kts .or. k .eq. ktf ) THEN
! Tmpv302(i,k) =coefc
coefc =3.9
ELSE
Tmpv001 =ce2*l_scale(i,k,j)
Tmpv303(i,k) =Tmpv001
Tmpv002 =Tmpv303(i,k)/deltas
Tmpv003 =ce1 +Tmpv002
! Tmpv304(i,k) =coefc
coefc =Tmpv003
END IF
Tmpv001 =mu(i,j)*coefc
Tmpv305(i,k) =Tmpv001
Tmpv002 =Tmpv305(i,k)*tketmp**1.5
Tmpv306(i,k) =Tmpv002
! Remarked by Ning Pan, 2010-08-12
! Tmpv003 =Tmpv306(i,k)/l_scale(i,k,j)
! Tmpv004 =tendency(i,k,j) -Tmpv003
! tendency(i,k,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-12
! ENDDO
! ENDDO
! Remarked by Ning Pan, 2010-08-12
! DO k =ktf, kts, -1
! DO i =i_end, i_start, -1
a_Tmpv4 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv4
a_Tmpv3 =-a_Tmpv4
a_Tmpv2 =a_Tmpv3/l_scale(i,k,j)
a_l_scale(i,k,j) =a_l_scale(i,k,j) -Tmpv306(i,k)/(l_scale(i,k,j) &
*l_scale(i,k,j))*a_Tmpv3
a_Tmpv1 =tketmp**1.5*a_Tmpv2
a_tketmp =a_tketmp +1.5*1.0*tketmp**(1.5 -1)*Tmpv305(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +coefc*a_Tmpv1
a_coefc =a_coefc +mu(i,j)*a_Tmpv1
IF( k .eq. kts .or. k .eq. ktf ) THEN
! coefc =Tmpv302(i,k)
a_coefc =0.0
ELSE
! coefc =Tmpv304(i,k)
a_Tmpv3 =a_coefc
a_coefc =0.0
! a_ce1 =a_ce1 +a_Tmpv3 ! Remarked by Ning Pan, 2010-08-12
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =a_Tmpv2/deltas
a_deltas =a_deltas -Tmpv303(i,k)/(deltas*deltas)*a_Tmpv2
! a_ce2 =a_ce2 +l_scale(i,k,j)*a_Tmpv1 ! Remarked by Ning Pan, 2010-08-12
a_l_scale(i,k,j) =a_l_scale(i,k,j) +ce2*a_Tmpv1
END IF
! tketmp =Tmpv301(i,k)
a_tke(i,k,j) =a_tke(i,k,j) +(1.0 +(1.0)*sign(1.0, tke(i,k,j) -1.0e-6))*0.5*a_tketmp
a_tketmp =0.0
! deltas =Tmpv300(i,k)
a_rdzw(i,k,j) =a_rdzw(i,k,j) -dx/msftx(i,j)*dy/msfty(i,j)/(rdzw(i,k,j) &
*rdzw(i,k,j))*0.33333333*(dx/msftx(i,j)*dy/msfty(i,j)/rdzw(i,k,j))**(0.33333333 -1)*a_deltas
a_deltas =0.0
ENDDO
ENDDO
ENDDO
!LPB[12]
! CALL calc_l_scale(config_flags,tke,BN2,l_scale,i_start,i_end,ktf,j_start,j_end,dx, &
! dy,rdzw,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
CALL a_calc_l_scale(config_flags,tke,a_tke,BN2,a_BN2,l_scale,a_l_scale, &
i_start,i_end,ktf,j_start,j_end,dx,dy,rdzw,a_rdzw,msftx,msfty,ids,ide,jds,jde,kds, &
kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! c_k =config_flags%c_k
! ce1 =(c_k/0.10)*0.19
! ce2 =max(0.0, 0.93 -ce1)
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
! Remarked by Ning Pan, 2010-08-12
! a_ce1 =a_ce1 +(-1.0 +(--1.0)*sign(1.0, 0.0 -0.93 -ce1))*0.5*a_ce2
! a_ce2 =0.0
! a_c_k =a_c_k +1.0/0.10*0.19*a_ce1
! a_ce1 =0.0
! a_config_flags%c_k =a_config_flags%c_k +a_c_k
! a_c_k =0.0
END SUBROUTINE a_tke_dissip
SUBROUTINE a_tke_shear(tendency,a_tendency,config_flags,defor11,a_defor11, &
defor22,a_defor22,defor33,a_defor33,defor12,a_defor12,defor13,a_defor13, &
defor23,a_defor23,u,a_u,v,a_v,w,a_w,tke,a_tke,ust,a_ust,mu,a_mu,fnm, &
fnp,cf1,cf2,cf3,msftx,msfty,xkmh,a_xkmh,xkmv,a_xkmv,rdx,rdy,zx,a_zx,zy,a_zy, &
rdz,a_rdz,rdzw,a_rdzw,dn,dnw,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL :: cf1,cf2,cf3,rdx,rdy
REAL,DIMENSION(kms:kme) :: fnm,fnp,dn,dnw
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor22,a_defor22, &
defor33,a_defor33,defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,tke, &
a_tke,xkmh,a_xkmh,xkmv,a_xkmv,zx,a_zx,zy,a_zy,u,a_u,v,a_v,w,a_w,rdz, &
a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
REAL,DIMENSION(ims:ime,jms:jme) :: ust,a_ust
INTEGER :: i,j,k,ktf,ktes1,ktes2,i_start,i_end,j_start,j_end,is_ext,ie_ext,js_ext,je_ext
REAL :: mtau,a_mtau
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: avg,a_avg,titau,a_titau,tmp2,a_tmp2
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: titau12,a_titau12,tmp1,a_tmp1,zxavg, &
a_zxavg,zyavg,a_zyavg
REAL :: absU,a_absU,cd0,a_cd0,Cd,a_Cd
! REAL,DIMENSION(1) :: Keep_Lpb29_absU
! REAL,DIMENSION(1) :: Keep_Lpb29_Cd
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
REAL,DIMENSION(its:min(ite,ide-1),min0(kts,max(jds+1,jts)):max0(min(kte,kde-1) &
,min(jde-2,jte))) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv302
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv303
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv304
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv305
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv306
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv307
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv308
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv309
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3010
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3011
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3012
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3013
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3014
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3015
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3016
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3017
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3018
REAL,DIMENSION(its:min(ite,ide-1),max(jds+1,jts):min(jde-2,jte)) :: Tmpv3019
REAL :: g_Sqrt
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
ktes1 = kte-1
ktes2 = kte-2
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested ) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested ) i_end = MIN( ide-2, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested ) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested ) j_end = MIN( jde-2, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
! Remarked by Ning Pan, 2010-08-12 : LPB[12]-[28]
!LPB[12]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! zxavg(i,k,j) = 0.25 * ( zx(i,k ,j) + zx(i+1,k ,j) + &
! zx(i,k+1,j) + zx(i+1,k+1,j) )
! zyavg(i,k,j) = 0.25 * ( zy(i,k ,j) + zy(i,k ,j+1) + &
! zy(i,k+1,j) + zy(i,k+1,j+1) )
! END DO
! END DO
! END DO
!LPB[13]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = tendency(i,k,j) + 0.5 * &
! mu(i,j) * xkmh(i,k,j) * ( ( defor11(i,k,j) )**2 )
! END DO
! END DO
! END DO
!LPB[14]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = tendency(i,k,j) + 0.5 * &
! mu(i,j) * xkmh(i,k,j) * ( ( defor22(i,k,j) )**2 )
! END DO
! END DO
! END DO
!LPB[15]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = tendency(i,k,j) + 0.5 * &
! mu(i,j) * xkmv(i,k,j) * ( ( defor33(i,k,j) )**2 )
! END DO
! END DO
! END DO
!LPB[16]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! avg(i,k,j) = 0.25 * &
! ( ( defor12(i ,k,j)**2 ) + ( defor12(i ,k,j+1)**2 ) + &
! ( defor12(i+1,k,j)**2 ) + ( defor12(i+1,k,j+1)**2 ) )
! END DO
! END DO
! END DO
!LPB[17]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = tendency(i,k,j) + mu(i,j) * xkmh(i,k,j) * avg(i,k,j)
! END DO
! END DO
! END DO
!LPB[18]
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end+1
! tmp2(i,k,j) = defor13(i,k,j)
! END DO
! END DO
! END DO
!LPB[19]
! DO j = j_start, j_end
! DO i = i_start, i_end+1
! tmp2(i,kts ,j) = 0.0
! tmp2(i,ktf+1,j) = 0.0
! END DO
! END DO
!LPB[20]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! avg(i,k,j) = 0.25 * &
! ( ( tmp2(i ,k+1,j)**2 ) + ( tmp2(i ,k,j)**2 ) + &
! ( tmp2(i+1,k+1,j)**2 ) + ( tmp2(i+1,k,j)**2 ) )
! END DO
! END DO
! END DO
!LPB[21]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = tendency(i,k,j) + mu(i,j) * xkmv(i,k,j) * avg(i,k,j)
! END DO
! END DO
! END DO
!LPB[22]
! K=KTS
!LPB[23]
! uflux: SELECT CASE( config_flags%isfflx )
! CASE (0)
! cd0 = config_flags%tke_drag_coefficient
! DO j = j_start, j_end
! DO i = i_start, i_end
! absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)
! Cd = cd0
! tendency(i,k,j) = tendency(i,k,j) + &
! mu(i,j)*( (u(i,k,j)+u(i+1,k,j))*0.5* &
! Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 )
! END DO
! END DO
! CASE (1,2)
! DO j = j_start, j_end
! DO i = i_start, i_end
! absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)+epsilon
! Cd = (ust(i,j)**2)/(absU**2)
! tendency(i,k,j) = tendency(i,k,j) + &
! mu(i,j)*( (u(i,k,j)+u(i+1,k,j))*0.5* &
! Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 )
! END DO
! END DO
! CASE DEFAULT
! CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
! END SELECT uflux
!LPB[24]
! DO j = j_start, j_end+1
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tmp2(i,k,j) = defor23(i,k,j)
! END DO
! END DO
! END DO
!LPB[25]
! DO j = j_start, j_end+1
! DO i = i_start, i_end
! tmp2(i,kts, j) = 0.0
! tmp2(i,ktf+1,j) = 0.0
! END DO
! END DO
!LPB[26]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! avg(i,k,j) = 0.25 * &
! ( ( tmp2(i,k+1,j )**2 ) + ( tmp2(i,k,j )**2) + &
! ( tmp2(i,k+1,j+1)**2 ) + ( tmp2(i,k,j+1)**2) )
! END DO
! END DO
! END DO
!LPB[27]
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! tendency(i,k,j) = tendency(i,k,j) + mu(i,j) * xkmv(i,k,j) * avg(i,k,j)
! END DO
! END DO
! END DO
!LPB[28]
! K=KTS
!!LPB[29]
! ! Keep_Lpb29_absU(1) =absU
! ! Keep_Lpb29_Cd(1) =Cd
! vflux: SELECT CASE( config_flags%isfflx )
! CASE (0)
! cd0 = config_flags%tke_drag_coefficient
! DO j = j_start, j_end
! DO i = i_start, i_end
! absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)
! Cd = cd0
! tendency(i,k,j) = tendency(i,k,j) + &
! mu(i,j)*( (v(i,k,j)+v(i,k,j+1))*0.5* &
! Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 )
! END DO
! END DO
! CASE (1,2)
! DO j = j_start, j_end
! DO i = i_start, i_end
! absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)+epsilon
! Cd = (ust(i,j)**2)/(absU**2)
! tendency(i,k,j) = tendency(i,k,j) + &
! mu(i,j)*( (v(i,k,j)+v(i,k,j+1))*0.5* &
! Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 )
! END DO
! END DO
! CASE DEFAULT
! CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
! END SELECT vflux
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
a_mtau =0.0
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_tmp2(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_titau12(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_tmp1(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_zxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_zyavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
a_absU =0.0
! a_cd0 =0.0 ! Remarked by Ning Pan, 2010-08-12
a_Cd =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
K=KTS ! Added by Ning Pan, 2010-08-12
!LPB[29]
! absU =Keep_Lpb29_absU(1)
! Cd =Keep_Lpb29_Cd(1)
SELECT CASE (config_flags%isfflx)
CASE(0)
cd0 =config_flags%tke_drag_coefficient
DO j =j_start, j_end
DO i =i_start, i_end
Tmpv001 =u(i,k,j) +u(i+1,k,j)
Tmpv300(i,j) =Tmpv001
Tmpv002 =Tmpv300(i,j)**2
Tmpv003 =v(i,k,j) +v(i,k,j+1)
Tmpv301(i,j) =Tmpv003
Tmpv004 =Tmpv301(i,j)**2
Tmpv005 =Tmpv002 +Tmpv004
Tmpv302(i,j) =Tmpv005
Tmpv006 =sqrt(Tmpv302(i,j))
Tmpv007 =0.5*Tmpv006
! Revised by Ning Pan, 2010-08-12
! Tmpv303(i,j) =absU
! absU =Tmpv007
absU =Tmpv007
Tmpv303(i,j) =absU
! Revised by Ning Pan, 2010-08-12
! Tmpv304(i,j) =Cd
! Cd =cd0
Cd =cd0
Tmpv304(i,j) =Cd
Tmpv001 =v(i,k,j) +v(i,k,j+1)
Tmpv002 =Tmpv001*0.5
Tmpv305(i,j) =Tmpv002
Tmpv003 =Tmpv305(i,j)*Cd
Tmpv306(i,j) =Tmpv003
Tmpv004 =Tmpv306(i,j)*absU
Tmpv005 =defor23(i,kts+1,j) +defor23(i,kts+1,j+1)
Tmpv307(i,j) =Tmpv004
Tmpv308(i,j) =Tmpv005
Tmpv006 =Tmpv307(i,j)*Tmpv308(i,j)
Tmpv007 =Tmpv006*0.5
Tmpv309(i,j) =Tmpv007
! Remarked by Ning Pan, 2010-08-12
! Tmpv008 =mu(i,j)*Tmpv309(i,j)
! Tmpv009 =tendency(i,k,j) +Tmpv008
! tendency(i,k,j) =Tmpv009
ENDDO
ENDDO
CASE(1,2)
DO j =j_start, j_end
DO i =i_start, i_end
Tmpv001 =u(i,k,j) +u(i+1,k,j)
Tmpv3010(i,j) =Tmpv001
Tmpv002 =Tmpv3010(i,j)**2
Tmpv003 =v(i,k,j) +v(i,k,j+1)
Tmpv3011(i,j) =Tmpv003
Tmpv004 =Tmpv3011(i,j)**2
Tmpv005 =Tmpv002 +Tmpv004
Tmpv3012(i,j) =Tmpv005
Tmpv006 =sqrt(Tmpv3012(i,j))
Tmpv007 =0.5*Tmpv006
Tmpv008 =Tmpv007 +epsilon
! Revised by Ning Pan, 2010-08-12
! Tmpv3013(i,j) =absU
! absU =Tmpv008
absU =Tmpv008
Tmpv3013(i,j) =absU
Tmpv001 =(ust(i,j)**2)/(absU**2)
! Revised by Ning Pan, 2010-08-12
! Tmpv3014(i,j) =Cd
! Cd =Tmpv001
Cd =Tmpv001
Tmpv3014(i,j) =Cd
Tmpv001 =v(i,k,j) +v(i,k,j+1)
Tmpv002 =Tmpv001*0.5
Tmpv3015(i,j) =Tmpv002
Tmpv003 =Tmpv3015(i,j)*Cd
Tmpv3016(i,j) =Tmpv003
Tmpv004 =Tmpv3016(i,j)*absU
Tmpv005 =defor23(i,kts+1,j) +defor23(i,kts+1,j+1)
Tmpv3017(i,j) =Tmpv004
Tmpv3018(i,j) =Tmpv005
Tmpv006 =Tmpv3017(i,j)*Tmpv3018(i,j)
Tmpv007 =Tmpv006*0.5
Tmpv3019(i,j) =Tmpv007
! Remarked by Ning Pan, 2010-08-12
! Tmpv008 =mu(i,j)*Tmpv3019(i,j)
! Tmpv009 =tendency(i,k,j) +Tmpv008
! tendency(i,k,j) =Tmpv009
ENDDO
ENDDO
CASE DEFAULT
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-12
! END SELECT vflux
END SELECT
SELECT CASE (config_flags%isfflx)
CASE(0)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
! Added by Ning Pan, 2010-08-12
absU =Tmpv303(i,j)
Cd =Tmpv304(i,j)
a_Tmpv9 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv9
a_Tmpv8 =a_Tmpv9
a_mu(i,j) =a_mu(i,j) +Tmpv309(i,j)*a_Tmpv8
a_Tmpv7 =mu(i,j)*a_Tmpv8
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv4 =Tmpv308(i,j)*a_Tmpv6
a_Tmpv5 =Tmpv307(i,j)*a_Tmpv6
a_defor23(i,kts+1,j) =a_defor23(i,kts+1,j) +a_Tmpv5
a_defor23(i,kts+1,j+1) =a_defor23(i,kts+1,j+1) +a_Tmpv5
a_Tmpv3 =absU*a_Tmpv4
a_absU =a_absU +Tmpv306(i,j)*a_Tmpv4
a_Tmpv2 =Cd*a_Tmpv3
a_Cd =a_Cd +Tmpv305(i,j)*a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv1
a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
! Cd =Tmpv304(i,j) ! Remarked by Ning Pan, 2010-08-12
! a_cd0 =a_cd0 +a_Cd ! ! Remarked by Ning Pan, 2010-08-12
a_Cd =0.0
! absU =Tmpv303(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv7 =a_absU
a_absU =0.0
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv5 =g_Sqrt(1.0, Tmpv302(i,j))*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =2.0*Tmpv301(i,j)*a_Tmpv4
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv3
a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv3
a_Tmpv1 =2.0*Tmpv300(i,j)*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
! Remarked by Ning Pan, 2010-08-12
! a_config_flags%tke_drag_coefficient =a_config_flags%tke_drag_coefficient +a_cd0
! a_cd0 =0.0
CASE(1,2)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
! Added by Ning Pan, 2010-08-12
absU =Tmpv3013(i,j)
Cd =Tmpv3014(i,j)
a_Tmpv9 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv9
a_Tmpv8 =a_Tmpv9
a_mu(i,j) =a_mu(i,j) +Tmpv3019(i,j)*a_Tmpv8
a_Tmpv7 =mu(i,j)*a_Tmpv8
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv4 =Tmpv3018(i,j)*a_Tmpv6
a_Tmpv5 =Tmpv3017(i,j)*a_Tmpv6
a_defor23(i,kts+1,j) =a_defor23(i,kts+1,j) +a_Tmpv5
a_defor23(i,kts+1,j+1) =a_defor23(i,kts+1,j+1) +a_Tmpv5
a_Tmpv3 =absU*a_Tmpv4
a_absU =a_absU +Tmpv3016(i,j)*a_Tmpv4
a_Tmpv2 =Cd*a_Tmpv3
a_Cd =a_Cd +Tmpv3015(i,j)*a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv1
a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv1
! Cd =Tmpv3014(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv1 =a_Cd
a_Cd =0.0
a_ust(i,j) =a_ust(i,j) +2.0*ust(i,j)/(absU**2)*a_Tmpv1
a_absU =a_absU -2.0*absU*(ust(i,j)**2)/((absU**2)*(absU**2))*a_Tmpv1
! absU =Tmpv3013(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv8 =a_absU
a_absU =0.0
a_Tmpv7 =a_Tmpv8
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv5 =g_Sqrt(1.0, Tmpv3012(i,j))*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =2.0*Tmpv3011(i,j)*a_Tmpv4
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv3
a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv3
a_Tmpv1 =2.0*Tmpv3010(i,j)*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
CASE DEFAULT
! Revised by Ning Pan, 2010-08-12
! CALL a_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-12
! END SELECT vflux
END SELECT
!LPB[28]
! K =KTS
! Added by Ning Pan, 2010-08-12: LPB[24]-[26]
!LPB[24]
DO j = j_start, j_end+1
DO k = kts+1, ktf
DO i = i_start, i_end
tmp2(i,k,j) = defor23(i,k,j)
END DO
END DO
END DO
!LPB[25]
DO j = j_start, j_end+1
DO i = i_start, i_end
tmp2(i,kts, j) = 0.0
tmp2(i,ktf+1,j) = 0.0
END DO
END DO
!LPB[26]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
avg(i,k,j) = 0.25 * &
( ( tmp2(i,k+1,j )**2 ) + ( tmp2(i,k,j )**2) + &
( tmp2(i,k+1,j+1)**2 ) + ( tmp2(i,k,j+1)**2) )
END DO
END DO
END DO
!LPB[27]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =mu(i,j)*xkmv(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
! Tmpv002 =Tmpv300(i,k)*avg(i,k,j)
! Tmpv003 =tendency(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =avg(i,k,j)*a_Tmpv2
a_avg(i,k,j) =a_avg(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +xkmv(i,k,j)*a_Tmpv1
a_xkmv(i,k,j) =a_xkmv(i,k,j) +mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[26]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =(tmp2(i,k+1,j)**2) +(tmp2(i,k,j)**2)
! Tmpv002 =Tmpv001 +(tmp2(i,k+1,j+1)**2)
! Tmpv003 =Tmpv002 +(tmp2(i,k,j+1)**2)
! Tmpv004 =0.25*Tmpv003
! avg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_avg(i,k,j)
a_avg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp2(i,k,j+1) =a_tmp2(i,k,j+1) +2.0*tmp2(i,k,j+1)*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_tmp2(i,k+1,j+1) =a_tmp2(i,k+1,j+1) +2.0*tmp2(i,k+1,j+1)*a_Tmpv2
a_tmp2(i,k+1,j) =a_tmp2(i,k+1,j) +2.0*tmp2(i,k+1,j)*a_Tmpv1
a_tmp2(i,k,j) =a_tmp2(i,k,j) +2.0*tmp2(i,k,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[25]
DO j =j_end+1, j_start, -1
! DO i =i_start, i_end
! tmp2(i,kts,j) =0.0
! tmp2(i,ktf+1,j) =0.0
! ENDDO
DO i =i_end, i_start, -1
a_tmp2(i,ktf+1,j) =0.0
a_tmp2(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[24]
DO j =j_end+1, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! tmp2(i,k,j) =defor23(i,k,j)
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_defor23(i,k,j) =a_defor23(i,k,j) +a_tmp2(i,k,j)
a_tmp2(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
K=KTS ! Added by Ning Pan, 2010-08-12
!LPB[23]
SELECT CASE (config_flags%isfflx)
CASE(0)
cd0 =config_flags%tke_drag_coefficient
DO j =j_start, j_end
DO i =i_start, i_end
Tmpv001 =u(i,k,j) +u(i+1,k,j)
Tmpv300(i,j) =Tmpv001
Tmpv002 =Tmpv300(i,j)**2
Tmpv003 =v(i,k,j) +v(i,k,j+1)
Tmpv301(i,j) =Tmpv003
Tmpv004 =Tmpv301(i,j)**2
Tmpv005 =Tmpv002 +Tmpv004
Tmpv302(i,j) =Tmpv005
Tmpv006 =sqrt(Tmpv302(i,j))
Tmpv007 =0.5*Tmpv006
! Revised by Ning Pan, 2010-08-12
! Tmpv303(i,j) =absU
! absU =Tmpv007
absU =Tmpv007
Tmpv303(i,j) =absU
! Revised by Ning Pan, 2010-08-12
! Tmpv304(i,j) =Cd
! Cd =cd0
Cd =cd0
Tmpv304(i,j) =Cd
Tmpv001 =u(i,k,j) +u(i+1,k,j)
Tmpv002 =Tmpv001*0.5
Tmpv305(i,j) =Tmpv002
Tmpv003 =Tmpv305(i,j)*Cd
Tmpv306(i,j) =Tmpv003
Tmpv004 =Tmpv306(i,j)*absU
Tmpv005 =defor13(i,kts+1,j) +defor13(i+1,kts+1,j)
Tmpv307(i,j) =Tmpv004
Tmpv308(i,j) =Tmpv005
Tmpv006 =Tmpv307(i,j)*Tmpv308(i,j)
Tmpv007 =Tmpv006*0.5
Tmpv309(i,j) =Tmpv007
! Remarked by Ning Pan, 2010-08-12
! Tmpv008 =mu(i,j)*Tmpv309(i,j)
! Tmpv009 =tendency(i,k,j) +Tmpv008
! tendency(i,k,j) =Tmpv009
ENDDO
ENDDO
CASE(1,2)
DO j =j_start, j_end
DO i =i_start, i_end
Tmpv001 =u(i,k,j) +u(i+1,k,j)
Tmpv3010(i,j) =Tmpv001
Tmpv002 =Tmpv3010(i,j)**2
Tmpv003 =v(i,k,j) +v(i,k,j+1)
Tmpv3011(i,j) =Tmpv003
Tmpv004 =Tmpv3011(i,j)**2
Tmpv005 =Tmpv002 +Tmpv004
Tmpv3012(i,j) =Tmpv005
Tmpv006 =sqrt(Tmpv3012(i,j))
Tmpv007 =0.5*Tmpv006
Tmpv008 =Tmpv007 +epsilon
! Revised by Ning Pan, 2010-08-12
! Tmpv3013(i,j) =absU
! absU =Tmpv008
absU =Tmpv008
Tmpv3013(i,j) =absU
Tmpv001 =(ust(i,j)**2)/(absU**2)
! Revised by Ning Pan, 2010-08-12
! Tmpv3014(i,j) =Cd
! Cd =Tmpv001
Cd =Tmpv001
Tmpv3014(i,j) =Cd
Tmpv001 =u(i,k,j) +u(i+1,k,j)
Tmpv002 =Tmpv001*0.5
Tmpv3015(i,j) =Tmpv002
Tmpv003 =Tmpv3015(i,j)*Cd
Tmpv3016(i,j) =Tmpv003
Tmpv004 =Tmpv3016(i,j)*absU
Tmpv005 =defor13(i,kts+1,j) +defor13(i+1,kts+1,j)
Tmpv3017(i,j) =Tmpv004
Tmpv3018(i,j) =Tmpv005
Tmpv006 =Tmpv3017(i,j)*Tmpv3018(i,j)
Tmpv007 =Tmpv006*0.5
Tmpv3019(i,j) =Tmpv007
! Remarked by Ning Pan, 2010-08-12
! Tmpv008 =mu(i,j)*Tmpv3019(i,j)
! Tmpv009 =tendency(i,k,j) +Tmpv008
! tendency(i,k,j) =Tmpv009
ENDDO
ENDDO
CASE DEFAULT
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-12
! END SELECT uflux
END SELECT
SELECT CASE (config_flags%isfflx)
CASE(0)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
! Added by Ning Pan, 2010-08-12
absU =Tmpv303(i,j)
Cd =Tmpv304(i,j)
a_Tmpv9 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv9
a_Tmpv8 =a_Tmpv9
a_mu(i,j) =a_mu(i,j) +Tmpv309(i,j)*a_Tmpv8
a_Tmpv7 =mu(i,j)*a_Tmpv8
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv4 =Tmpv308(i,j)*a_Tmpv6
a_Tmpv5 =Tmpv307(i,j)*a_Tmpv6
a_defor13(i,kts+1,j) =a_defor13(i,kts+1,j) +a_Tmpv5
a_defor13(i+1,kts+1,j) =a_defor13(i+1,kts+1,j) +a_Tmpv5
a_Tmpv3 =absU*a_Tmpv4
a_absU =a_absU +Tmpv306(i,j)*a_Tmpv4
a_Tmpv2 =Cd*a_Tmpv3
a_Cd =a_Cd +Tmpv305(i,j)*a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
! Cd =Tmpv304(i,j) ! Remarked by Ning Pan, 2010-08-12
! a_cd0 =a_cd0 +a_Cd ! Remarked by Ning Pan, 2010-08-12
a_Cd =0.0
! absU =Tmpv303(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv7 =a_absU
a_absU =0.0
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv5 =g_Sqrt(1.0, Tmpv302(i,j))*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =2.0*Tmpv301(i,j)*a_Tmpv4
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv3
a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv3
a_Tmpv1 =2.0*Tmpv300(i,j)*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
! Remarked by Ning Pan, 2010-08-12
! a_config_flags%tke_drag_coefficient =a_config_flags%tke_drag_coefficient +a_cd0
! a_cd0 =0.0
CASE(1,2)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
! Added by Ning Pan, 2010-08-12
absU =Tmpv3013(i,j)
Cd =Tmpv3014(i,j)
a_Tmpv9 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv9
a_Tmpv8 =a_Tmpv9
a_mu(i,j) =a_mu(i,j) +Tmpv3019(i,j)*a_Tmpv8
a_Tmpv7 =mu(i,j)*a_Tmpv8
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv4 =Tmpv3018(i,j)*a_Tmpv6
a_Tmpv5 =Tmpv3017(i,j)*a_Tmpv6
a_defor13(i,kts+1,j) =a_defor13(i,kts+1,j) +a_Tmpv5
a_defor13(i+1,kts+1,j) =a_defor13(i+1,kts+1,j) +a_Tmpv5
a_Tmpv3 =absU*a_Tmpv4
a_absU =a_absU +Tmpv3016(i,j)*a_Tmpv4
a_Tmpv2 =Cd*a_Tmpv3
a_Cd =a_Cd +Tmpv3015(i,j)*a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
! Cd =Tmpv3014(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv1 =a_Cd
a_Cd =0.0
a_ust(i,j) =a_ust(i,j) +2.0*ust(i,j)/(absU**2)*a_Tmpv1
a_absU =a_absU -2.0*absU*(ust(i,j)**2)/((absU**2)*(absU**2))*a_Tmpv1
! absU =Tmpv3013(i,j) ! Remarked by Ning Pan, 2010-08-12
a_Tmpv8 =a_absU
a_absU =0.0
a_Tmpv7 =a_Tmpv8
a_Tmpv6 =0.5*a_Tmpv7
a_Tmpv5 =g_Sqrt(1.0, Tmpv3012(i,j))*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =2.0*Tmpv3011(i,j)*a_Tmpv4
a_v(i,k,j) =a_v(i,k,j) +a_Tmpv3
a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv3
a_Tmpv1 =2.0*Tmpv3010(i,j)*a_Tmpv2
a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1
a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
CASE DEFAULT
! Revised by Ning Pan, 2010-08-12
! CALL a_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-12
! END SELECT uflux
END SELECT
!LPB[22]
! K =KTS
! Added by Ning Pan, 2010-08-12 : LPB[18]-[20]
!LPB[18]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end+1
tmp2(i,k,j) = defor13(i,k,j)
END DO
END DO
END DO
!LPB[19]
DO j = j_start, j_end
DO i = i_start, i_end+1
tmp2(i,kts ,j) = 0.0
tmp2(i,ktf+1,j) = 0.0
END DO
END DO
!LPB[20]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
avg(i,k,j) = 0.25 * &
( ( tmp2(i ,k+1,j)**2 ) + ( tmp2(i ,k,j)**2 ) + &
( tmp2(i+1,k+1,j)**2 ) + ( tmp2(i+1,k,j)**2 ) )
END DO
END DO
END DO
!LPB[21]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =mu(i,j)*xkmv(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
Tmpv002 =Tmpv300(i,k)*avg(i,k,j)
Tmpv003 =tendency(i,k,j) +Tmpv002
tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =avg(i,k,j)*a_Tmpv2
a_avg(i,k,j) =a_avg(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +xkmv(i,k,j)*a_Tmpv1
a_xkmv(i,k,j) =a_xkmv(i,k,j) +mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[20]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =(tmp2(i,k+1,j)**2) +(tmp2(i,k,j)**2)
! Tmpv002 =Tmpv001 +(tmp2(i+1,k+1,j)**2)
! Tmpv003 =Tmpv002 +(tmp2(i+1,k,j)**2)
! Tmpv004 =0.25*Tmpv003
! avg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_avg(i,k,j)
a_avg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_tmp2(i+1,k,j) =a_tmp2(i+1,k,j) +2.0*tmp2(i+1,k,j)*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_tmp2(i+1,k+1,j) =a_tmp2(i+1,k+1,j) +2.0*tmp2(i+1,k+1,j)*a_Tmpv2
a_tmp2(i,k+1,j) =a_tmp2(i,k+1,j) +2.0*tmp2(i,k+1,j)*a_Tmpv1
a_tmp2(i,k,j) =a_tmp2(i,k,j) +2.0*tmp2(i,k,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[19]
DO j =j_end, j_start, -1
! DO i =i_start, i_end+1
! tmp2(i,kts,j) =0.0
! tmp2(i,ktf+1,j) =0.0
! ENDDO
DO i =i_end+1, i_start, -1
a_tmp2(i,ktf+1,j) =0.0
a_tmp2(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[18]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end+1
! tmp2(i,k,j) =defor13(i,k,j)
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end+1, i_start, -1
a_defor13(i,k,j) =a_defor13(i,k,j) +a_tmp2(i,k,j)
a_tmp2(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
! Added by Ning Pan, 2010-08-12 : LPB[16]
!LPB[16]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
avg(i,k,j) = 0.25 * &
( ( defor12(i ,k,j)**2 ) + ( defor12(i ,k,j+1)**2 ) + &
( defor12(i+1,k,j)**2 ) + ( defor12(i+1,k,j+1)**2 ) )
END DO
END DO
END DO
!LPB[17]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =mu(i,j)*xkmh(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
! Tmpv002 =Tmpv300(i,k)*avg(i,k,j)
! Tmpv003 =tendency(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =avg(i,k,j)*a_Tmpv2
a_avg(i,k,j) =a_avg(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +xkmh(i,k,j)*a_Tmpv1
a_xkmh(i,k,j) =a_xkmh(i,k,j) +mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[16]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =(defor12(i,k,j)**2) +(defor12(i,k,j+1)**2)
! Tmpv002 =Tmpv001 +(defor12(i+1,k,j)**2)
! Tmpv003 =Tmpv002 +(defor12(i+1,k,j+1)**2)
! Tmpv004 =0.25*Tmpv003
! avg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_avg(i,k,j)
a_avg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_defor12(i+1,k,j+1) =a_defor12(i+1,k,j+1) +2.0*defor12(i+1,k,j+1)*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_defor12(i+1,k,j) =a_defor12(i+1,k,j) +2.0*defor12(i+1,k,j)*a_Tmpv2
a_defor12(i,k,j) =a_defor12(i,k,j) +2.0*defor12(i,k,j)*a_Tmpv1
a_defor12(i,k,j+1) =a_defor12(i,k,j+1) +2.0*defor12(i,k,j+1)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[15]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =0.5*mu(i,j)*xkmv(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
! Tmpv002 =Tmpv300(i,k)*((defor33(i,k,j))**2)
! Tmpv003 =tendency(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =((defor33(i,k,j))**2)*a_Tmpv2
a_defor33(i,k,j) =a_defor33(i,k,j) +2.0*(defor33(i,k,j))*Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +0.5*xkmv(i,k,j)*a_Tmpv1
a_xkmv(i,k,j) =a_xkmv(i,k,j) +0.5*mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =0.5*mu(i,j)*xkmh(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
! Tmpv002 =Tmpv300(i,k)*((defor22(i,k,j))**2)
! Tmpv003 =tendency(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =((defor22(i,k,j))**2)*a_Tmpv2
a_defor22(i,k,j) =a_defor22(i,k,j) +2.0*(defor22(i,k,j))*Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +0.5*xkmh(i,k,j)*a_Tmpv1
a_xkmh(i,k,j) =a_xkmh(i,k,j) +0.5*mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =0.5*mu(i,j)*xkmh(i,k,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-12
! Tmpv002 =Tmpv300(i,k)*((defor11(i,k,j))**2)
! Tmpv003 =tendency(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =((defor11(i,k,j))**2)*a_Tmpv2
a_defor11(i,k,j) =a_defor11(i,k,j) +2.0*(defor11(i,k,j))*Tmpv300(i,k)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +0.5*xkmh(i,k,j)*a_Tmpv1
a_xkmh(i,k,j) =a_xkmh(i,k,j) +0.5*mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =zx(i,k,j) +zx(i+1,k,j)
! Tmpv002 =Tmpv001 +zx(i,k+1,j)
! Tmpv003 =Tmpv002 +zx(i+1,k+1,j)
! Tmpv004 =0.25*Tmpv003
! zxavg(i,k,j) =Tmpv004
! Tmpv001 =zy(i,k,j) +zy(i,k,j+1)
! Tmpv002 =Tmpv001 +zy(i,k+1,j)
! Tmpv003 =Tmpv002 +zy(i,k+1,j+1)
! Tmpv004 =0.25*Tmpv003
! zyavg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_zyavg(i,k,j)
a_zyavg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zy(i,k+1,j+1) =a_zy(i,k+1,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zy(i,k+1,j) =a_zy(i,k+1,j) +a_Tmpv2
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
a_zy(i,k,j+1) =a_zy(i,k,j+1) +a_Tmpv1
a_Tmpv4 =a_zxavg(i,k,j)
a_zxavg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zx(i+1,k+1,j) =a_zx(i+1,k+1,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zx(i,k+1,j) =a_zx(i,k+1,j) +a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
a_zx(i+1,k,j) =a_zx(i+1,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested ) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested ) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested ) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested ) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! ktes1 =kte-1
! ktes2 =kte-2
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_tke_shear
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of compute_diff_metrics in reverse (adjoint) mode:
! gradient of useful results: zx zy z rdzw rdz ph
! with respect to varying inputs: zx zy z rdzw rdz ph
! RW status of diff variables: zx:in-out zy:in-out z:in-out rdzw:in-out
! rdz:in-out ph:incr
SUBROUTINE A_COMPUTE_DIFF_METRICS(config_flags, ph, phb0, phb, z, zb, &
& rdz, rdzb, rdzw, rdzwb, zx, zxb, zy, zyb, rdx, rdy, ids, ide, jds, jde&
& , kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte&
&)
IMPLICIT NONE
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) :: ph, phb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: phb0
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rdz, rdzw, zx, zy, z
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rdzb, rdzwb, zxb, zyb, &
& zb
REAL, INTENT(IN) :: rdx, rdy
! Local variables.
REAL, DIMENSION(its - 1:ite, kts:kte, jts - 1:jte) :: z_at_w
REAL, DIMENSION(its-1:ite, kts:kte, jts-1:jte) :: z_at_wb
INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
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_from5
INTEGER :: branch
REAL :: temp1
REAL :: temp0
INTEGER :: min1
REAL :: temp0b
REAL :: temp2b5
REAL :: temp2b4
REAL :: temp2b3
REAL :: temp2b2
REAL :: temp2b1
REAL :: temp2b0
REAL :: tempb
REAL :: temp2b
REAL :: temp1b
INTEGER :: max4
REAL :: temp
INTEGER :: max3
INTEGER :: max2
INTEGER :: max1
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
! Bug fix, WCS, 22 april 2002.
! We need rdzw in halo for average to u and v points.
j_start = jts - 1
j_end = jte
ad_from3 = j_start
! Begin with dz computations.
DO j=ad_from3,j_end
IF (jte .GT. jde - 1) THEN
min1 = jde - 1
ELSE
min1 = jte
END IF
IF (j_start .GE. jts .AND. j_end .LE. min1) THEN
i_start = its - 1
i_end = ite
ELSE
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
! Compute z at w points for rdz and rdzw computations. We'll switch z
! to z at p points before returning
DO k=1,kte
ad_from = i_start
! Bug fix, WCS, 22 april 2002
DO i=ad_from,i_end
z_at_w(i, k, j) = (ph(i, k, j)+phb(i, k, j))/g
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from)
END DO
DO k=1,ktf
ad_from0 = i_start
i = i_end + 1
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from0)
END DO
DO k=2,ktf
ad_from1 = i_start
i = i_end + 1
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from1)
END DO
ad_from2 = i_start
! Bug fix, WCS, 22 april 2002; added the following code
i = i_end + 1
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from2)
END DO
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from3)
! End bug fix.
! Now compute zx and zy; we'll assume that the halo for ph and phb is
! properly filled.
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
DO j=j_start,j_end
DO k=1,kte
IF (ids + 1 .LT. its) THEN
max1 = its
ELSE
max1 = ids + 1
END IF
ad_from4 = max1
i = i_end + 1
CALL PUSHINTEGER4(ad_from4)
END DO
END DO
DO j=j_start,j_end
DO k=1,kte
IF (ids + 1 .LT. its) THEN
max2 = its
ELSE
max2 = ids + 1
END IF
ad_from5 = max2
i = i_end + 1
CALL PUSHINTEGER4(ad_from5)
END DO
END DO
IF (jds + 1 .LT. jts) THEN
max3 = jts
ELSE
max3 = jds + 1
END IF
DO j=max3,j_end
DO k=1,kte
i = i_end + 1
END DO
END DO
IF (jds + 1 .LT. jts) THEN
max4 = jts
ELSE
max4 = jds + 1
END IF
DO j=max4,j_end
DO k=1,kte
i = i_end + 1
END DO
END DO
! Some b.c. on zx and zy.
IF (.NOT.config_flags%periodic_x) THEN
IF (ite .EQ. ide) THEN
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (its .EQ. ids) THEN
CALL PUSHCONTROL2B(0)
ELSE
CALL PUSHCONTROL2B(1)
END IF
ELSE
IF (ite .EQ. ide) THEN
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (its .EQ. ids) THEN
CALL PUSHCONTROL2B(2)
ELSE
CALL PUSHCONTROL2B(3)
END IF
END IF
IF (.NOT.config_flags%periodic_y) THEN
IF (jte .EQ. jde) THEN
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (jts .EQ. jds) THEN
CALL PUSHCONTROL2B(3)
ELSE
CALL PUSHCONTROL2B(2)
END IF
ELSE
IF (jte .EQ. jde) THEN
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (jts .EQ. jds) THEN
CALL PUSHCONTROL2B(1)
ELSE
CALL PUSHCONTROL2B(0)
END IF
END IF
! Calculate z at p points.
DO j=j_start,j_end
DO k=1,ktf
CALL PUSHINTEGER4(i)
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf,1,-1
DO i=i_end,i_start,-1
temp2b5 = 0.5*zb(i, k, j)/g
phb0(i, k, j) = phb0(i, k, j) + temp2b5
phb0(i, k+1, j) = phb0(i, k+1, j) + temp2b5
zb(i, k, j) = 0.0
END DO
CALL POPINTEGER4(i)
END DO
END DO
CALL POPCONTROL2B(branch)
IF (branch .LT. 2) THEN
IF (branch .NE. 0) THEN
DO k=ktf,1,-1
DO i =i_end, i_start, -1
temp2b4 = rdy*zyb(i, k, jds)/g
phb0(i, k, jds) = phb0(i, k, jds) + temp2b4
phb0(i, k, jds-1) = phb0(i, k, jds-1) - temp2b4
END DO
END DO
DO k=ktf,1,-1
DO i =i_end, i_start, -1
zyb(i, k, jds) = 0.0
END DO
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO k=ktf,1,-1
DO i =i_end, i_start, -1
temp2b3 = rdy*zyb(i, k, jde)/g
phb0(i, k, jde) = phb0(i, k, jde) + temp2b3
phb0(i, k, jde-1) = phb0(i, k, jde-1) - temp2b3
END DO
END DO
DO k=ktf,1,-1
DO i =i_end, i_start, -1
zyb(i, k, jde) = 0.0
END DO
END DO
END IF
ELSE
IF (branch .NE. 2) THEN
DO k=ktf,1,-1
DO i=i_end,i_start,-1
zyb(i, k, jds) = 0.0
END DO
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO k=ktf,1,-1
DO i=i_end,i_start,-1
zyb(i, k, jde) = 0.0
END DO
END DO
END IF
END IF
CALL POPCONTROL2B(branch)
IF (branch .LT. 2) THEN
IF (branch .EQ. 0) THEN
DO j=j_end,j_start,-1
DO k=ktf,1,-1
zxb(ids, k, j) = 0.0
END DO
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=j_end,j_start,-1
DO k=ktf,1,-1
zxb(ide, k, j) = 0.0
END DO
END DO
END IF
ELSE
IF (branch .EQ. 2) THEN
DO j=j_end,j_start,-1
DO k=ktf,1,-1
temp2b2 = rdx*zxb(ids, k, j)/g
phb0(ids, k, j) = phb0(ids, k, j) + temp2b2
phb0(ids-1, k, j) = phb0(ids-1, k, j) - temp2b2
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf,1,-1
zxb(ids, k, j) = 0.0
END DO
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=j_end,j_start,-1
DO k=ktf,1,-1
temp2b1 = rdx*zxb(ide, k, j)/g
phb0(ide, k, j) = phb0(ide, k, j) + temp2b1
phb0(ide-1, k, j) = phb0(ide-1, k, j) - temp2b1
END DO
END DO
DO j=j_end,j_start,-1
DO k=ktf,1,-1
zxb(ide, k, j) = 0.0
END DO
END DO
END IF
END IF
DO j=j_end,max4,-1
DO k=kte,1,-1
DO i=i_end,i_start,-1
temp2b0 = rdy*zyb(i, k, j)/g
phb0(i, k, j) = phb0(i, k, j) + temp2b0
phb0(i, k, j-1) = phb0(i, k, j-1) - temp2b0
END DO
END DO
END DO
DO j=j_end,max3,-1
DO k=kte,1,-1
DO i=i_end,i_start,-1
zyb(i, k, j) = 0.0
END DO
END DO
END DO
DO j=j_end,j_start,-1
DO k=kte,1,-1
CALL POPINTEGER4(ad_from5)
DO i=i_end,ad_from5,-1
temp2b = rdx*zxb(i, k, j)/g
phb0(i, k, j) = phb0(i, k, j) + temp2b
phb0(i-1, k, j) = phb0(i-1, k, j) - temp2b
END DO
END DO
END DO
DO j=j_end,j_start,-1
DO k=kte,1,-1
CALL POPINTEGER4(ad_from4)
DO i=i_end,ad_from4,-1
zxb(i, k, j) = 0.0
END DO
END DO
END DO
z_at_wb = 0.0
CALL POPINTEGER4(ad_from3)
CALL POPINTEGER4(ad_to3)
DO j=ad_to3,ad_from3,-1
CALL POPINTEGER4(ad_from2)
CALL POPINTEGER4(ad_to2)
DO i=ad_to2,ad_from2,-1
temp1 = z_at_w(i, 2, j) - z_at_w(i, 1, j)
temp1b = -(2.*rdzb(i, 1, j)/temp1**2)
z_at_wb(i, 2, j) = z_at_wb(i, 2, j) + temp1b
z_at_wb(i, 1, j) = z_at_wb(i, 1, j) - temp1b
rdzb(i, 1, j) = 0.0
END DO
DO k=ktf,2,-1
CALL POPINTEGER4(ad_from1)
CALL POPINTEGER4(ad_to1)
DO i=ad_to1,ad_from1,-1
temp0 = z_at_w(i, k+1, j) - z_at_w(i, k-1, j)
temp0b = -(2.0*rdzb(i, k, j)/temp0**2)
z_at_wb(i, k+1, j) = z_at_wb(i, k+1, j) + temp0b
z_at_wb(i, k-1, j) = z_at_wb(i, k-1, j) - temp0b
rdzb(i, k, j) = 0.0
END DO
END DO
DO k=ktf,1,-1
CALL POPINTEGER4(ad_from0)
CALL POPINTEGER4(ad_to0)
DO i=ad_to0,ad_from0,-1
temp = z_at_w(i, k+1, j) - z_at_w(i, k, j)
tempb = -(rdzwb(i, k, j)/temp**2)
z_at_wb(i, k+1, j) = z_at_wb(i, k+1, j) + tempb
z_at_wb(i, k, j) = z_at_wb(i, k, j) - tempb
rdzwb(i, k, j) = 0.0
END DO
END DO
DO k=kte,1,-1
CALL POPINTEGER4(ad_from)
CALL POPINTEGER4(ad_to)
DO i=ad_to,ad_from,-1
phb0(i, k, j) = phb0(i, k, j) + z_at_wb(i, k, j)/g
z_at_wb(i, k, j) = 0.0
END DO
END DO
END DO
END SUBROUTINE A_COMPUTE_DIFF_METRICS
SUBROUTINE a_horizontal_diffusion_2(rt_tendf,a_rt_tendf,ru_tendf,a_ru_tendf, &
rv_tendf,a_rv_tendf,rw_tendf,a_rw_tendf,tke_tendf,a_tke_tendf,moist_tendf, &
! Revised by Ning Pan, 2010-08-10
! a_moist_tendf,n_moist,chem_tendf,a_chem_tendf,n_chem,scalar_tendf,a_scalar_tend &
! f,n_scalar,tracer_tendf,a_tracer_tendf,n_tracer,thp,a_thp,theta,a_theta,mu, &
a_moist_tendf,n_moist,chem_tendf,a_chem_tendf,n_chem,scalar_tendf,a_scalar_tend&
&f,n_scalar,tracer_tendf,a_tracer_tendf,n_tracer,thp,a_thp,theta,a_theta,mu, &
a_mu,tke,a_tke,config_flags,defor11,a_defor11,defor22,a_defor22,defor12, &
a_defor12,defor13,a_defor13,defor23,a_defor23,nba_mij,a_nba_mij,n_nba_mij, &
div,a_div,moist,a_moist,chem,a_chem,scalar,a_scalar,tracer,a_tracer,msfux, &
msfuy,msfvx,msfvy,msftx,msfty,xkmh,a_xkmh,xkhh,a_xkhh,km_opt,rdx,rdy,rdz,a_rdz, &
rdzw,a_rdzw,fnm,fnp,cf1,cf2,cf3,zx,a_zx,zy,a_zy,dn,dnw,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: n_moist,n_chem,n_scalar,n_tracer,km_opt
REAL :: cf1,cf2,cf3
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty,mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rt_tendf,a_rt_tendf,ru_tendf, &
a_ru_tendf,rv_tendf,a_rv_tendf,rw_tendf,a_rw_tendf,tke_tendf,a_tke_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist_tendf,a_moist_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem_tendf,a_chem_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar_tendf,a_scalar_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer_tendf,a_tracer_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,a_moist
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem,a_chem
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar,a_scalar
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer,a_tracer
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor22,a_defor22, &
defor12,a_defor12,defor13,a_defor13,defor23,a_defor23,div,a_div,xkmh, &
a_xkmh,xkhh,a_xkhh,zx,a_zx,zy,a_zy,theta,a_theta,thp,a_thp,tke,a_tke, &
rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL :: rdx,rdy
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
INTEGER :: im,ic,is
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_ru_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb0_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb1_nba_mij ! Added by Ning Pan, 2010-08-11
! Remarked by Ning Pan, 2010-08-11
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_rv_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_rw_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_rt_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_tke_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist,ims:ime,kms:kme,jms:jme,n_moist) &
! :: Keep_Lpb3_moist_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem,ims:ime,kms:kme,jms:jme,n_chem) &
! :: Keep_Lpb5_chem_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer,ims:ime,kms:kme,jms:jme,n_tracer) &
! :: Keep_Lpb7_tracer_tendf
!! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar,ims:ime,kms:kme,jms:jme,n_scalar) &
!! :: Keep_Lpb9_scalar_tendf
! INTEGER :: IX1,IX2,IX3,IX4
! Remarked by Ning Pan, 2010-08-11
! REAL :: Tmpv_1
! REAL,DIMENSION(PARAM_FIRST_SCALAR:max0(n_moist,n_chem,n_tracer,n_scalar)) :: Tmpv200
! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv400
! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv401
! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv402
! REAL,DIMENSION(jms:jme,kms:kme,ims:ime) :: Tmpv403
! REAL,DIMENSION(n_nba_mij,jms:jme,kms:kme,ims:ime) :: Tmpv500
! REAL,DIMENSION(n_nba_mij,jms:jme,kms:kme,ims:ime) :: Tmpv501
! REAL,DIMENSION(n_nba_mij,jms:jme,kms:kme,ims:ime) :: Tmpv502
!PART II: CALCULATIONS OF B. S. TRAJECTORY
! Remarked by Ning Pan, 2010-08-11: LPB[0]-[7]
!LPB[0]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_ru_tendf(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_rv_tendf(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_rw_tendf(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_rt_tendf(IX1,IX2,IX3) =rt_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL horizontal_diffusion_u_2( ru_tendf, mu, config_flags, &
! defor11, defor12, div, &
! nba_mij, n_nba_mij, &
! tke(ims,kms,jms), &
! msfux, msfuy, xkmh, rdx, rdy, fnm, fnp, &
! zx, zy, rdzw, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! CALL horizontal_diffusion_v_2( rv_tendf, mu, config_flags, &
! defor12, defor22, div, &
! nba_mij, n_nba_mij, &
! tke(ims,kms,jms), &
! msfvx, msfvy, xkmh, rdx, rdy, fnm, fnp, &
! zx, zy, rdzw, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! CALL horizontal_diffusion_w_2( rw_tendf, mu, config_flags, &
! defor13, defor23, div, &
! nba_mij, n_nba_mij, &
! tke(ims,kms,jms), &
! msftx, msfty, xkmh, rdx, rdy, fnm, fnp, &
! zx, zy, rdz, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! CALL horizontal_diffusion_s ( rt_tendf, mu, config_flags, thp, &
! msftx, msfty, msfux, msfuy, &
! msfvx, msfvy, xkhh, rdx, rdy, &
! fnm, fnp, cf1, cf2, cf3, &
! zx, zy, rdz, rdzw, dnw, dn, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
!LPB[1]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb1_tke_tendf(IX1,IX2,IX3) =tke_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! IF (km_opt .eq. 2) &
! CALL horizontal_diffusion_s ( tke_tendf(ims,kms,jms), &
! mu, config_flags, &
! tke(ims,kms,jms), &
! msftx, msfty, msfux, msfuy, &
! msfvx, msfvy, xkhh, rdx, rdy, &
! fnm, fnp, cf1, cf2, cf3, &
! zx, zy, rdz, rdzw, dnw, dn, &
! .true., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
!LPB[2]
!LPB[3]
! DO IX4=1,n_moist
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb3_moist_tendf(IX1,IX2,IX3,IX4) =moist_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN
! moist_loop: do im = PARAM_FIRST_SCALAR, n_moist
! CALL horizontal_diffusion_s( moist_tendf(ims,kms,jms,im), &
! mu, config_flags, &
! moist(ims,kms,jms,im), &
! msftx, msfty, msfux, msfuy, &
! msfvx, msfvy, xkhh, rdx, rdy, &
! fnm, fnp, cf1, cf2, cf3, &
! zx, zy, rdz, rdzw, dnw, dn, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO moist_loop
! ENDIF
!LPB[4]
!LPB[5]
! DO IX4=1,n_chem
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb5_chem_tendf(IX1,IX2,IX3,IX4) =chem_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN
! chem_loop: do ic = PARAM_FIRST_SCALAR, n_chem
! CALL horizontal_diffusion_s( chem_tendf(ims,kms,jms,ic), &
! mu, config_flags, &
! chem(ims,kms,jms,ic), &
! msftx, msfty, msfux, msfuy, &
! msfvx, msfvy, xkhh, rdx, rdy, &
! fnm, fnp, cf1, cf2, cf3, &
! zx, zy, rdz, rdzw, dnw, dn, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO chem_loop
! ENDIF
!LPB[6]
!LPB[7]
! DO IX4=1,n_tracer
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb7_tracer_tendf(IX1,IX2,IX3,IX4) =tracer_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN
! tracer_loop: do ic = PARAM_FIRST_SCALAR, n_tracer
! CALL horizontal_diffusion_s( tracer_tendf(ims,kms,jms,ic), &
! mu, config_flags, &
! tracer(ims,kms,jms,ic), &
! msftx, msfty, msfux, msfuy, &
! msfvx, msfvy, xkhh, rdx, rdy, &
! fnm, fnp, cf1, cf2, cf3, &
! zx, zy, rdz, rdzw, dnw, dn, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO tracer_loop
! ENDIF
!LPB[8]
!!LPB[9]
!! DO IX4=1,n_scalar
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb9_scalar_tendf(IX1,IX2,IX3,IX4) =scalar_tendf(IX1,IX2,IX3,IX4)
!! END DO
!! END DO
!! END DO
!! END DO
!
! IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN
! scalar_loop: do is = PARAM_FIRST_SCALAR, n_scalar
! CALL horizontal_diffusion_s( scalar_tendf(ims,kms,jms,is), &
! mu, config_flags, &
! scalar(ims,kms,jms,is), &
! msftx, msfty, msfux, msfuy, &
! msfvx, msfvy, xkhh, rdx, rdy, &
! fnm, fnp, cf1, cf2, cf3, &
! zx, zy, rdz, rdzw, dnw, dn, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO scalar_loop
! ENDIF
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[9]
! DO IX4=1,n_scalar
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! scalar_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb9_scalar_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
! DO is =PARAM_FIRST_SCALAR, n_scalar
! Tmpv200(is) =scalar_tendf(ims,kms,jms,is)
! CALL horizontal_diffusion_s(scalar_tendf(ims,kms,jms,is),mu,config_flags,scalar( &
! ims,kms,jms,is),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3, &
! zx,zy,rdz,rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
! ite,jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
DO is =n_scalar, PARAM_FIRST_SCALAR, -1
! scalar_tendf(ims,kms,jms,is) =Tmpv200(is) ! Remarked by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_s(scalar_tendf(ims,kms,jms,is),a_scalar_tendf(ims, &
kms,jms,is),mu,a_mu,config_flags,scalar(ims,kms,jms,is),a_scalar(ims,kms,jms,is) &
,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
! Revised by Ning Pan, 2010-08-10
! a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,,ids,ide,jds,jde,kds,kde,ims,ime, &
a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[8]
!LPB[7]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_tracer
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tracer_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb7_tracer_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
! DO ic =PARAM_FIRST_SCALAR, n_tracer
! Tmpv200(ic) =tracer_tendf(ims,kms,jms,ic)
! CALL horizontal_diffusion_s(tracer_tendf(ims,kms,jms,ic),mu,config_flags,tracer( &
! ims,kms,jms,ic),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3, &
! zx,zy,rdz,rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
! ite,jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
DO ic =n_tracer, PARAM_FIRST_SCALAR, -1
! tracer_tendf(ims,kms,jms,ic) =Tmpv200(ic) ! Remarked by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_s(tracer_tendf(ims,kms,jms,ic),a_tracer_tendf(ims, &
kms,jms,ic),mu,a_mu,config_flags,tracer(ims,kms,jms,ic),a_tracer(ims,kms,jms,ic) &
,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
! Revised by Ning Pan, 2010-08-10
! a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,,ids,ide,jds,jde,kds,kde,ims,ime, &
a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[6]
!LPB[5]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_chem
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! chem_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb5_chem_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
! DO ic =PARAM_FIRST_SCALAR, n_chem
! Tmpv200(ic) =chem_tendf(ims,kms,jms,ic)
! CALL horizontal_diffusion_s(chem_tendf(ims,kms,jms,ic),mu,config_flags,chem(ims, &
! kms,jms,ic),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
! zy,rdz,rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
! jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
DO ic =n_chem, PARAM_FIRST_SCALAR, -1
! chem_tendf(ims,kms,jms,ic) =Tmpv200(ic) ! Remarked by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_s(chem_tendf(ims,kms,jms,ic),a_chem_tendf(ims,kms, &
jms,ic),mu,a_mu,config_flags,chem(ims,kms,jms,ic),a_chem(ims,kms,jms,ic) &
,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
! Revised by Ning Pan, 2010-08-10
! a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,,ids,ide,jds,jde,kds,kde,ims,ime, &
a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[4]
!LPB[3]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_moist
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! moist_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb3_moist_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
! DO im =PARAM_FIRST_SCALAR, n_moist
! Tmpv200(im) =moist_tendf(ims,kms,jms,im)
! CALL horizontal_diffusion_s(moist_tendf(ims,kms,jms,im),mu,config_flags,moist(ims, &
! kms,jms,im),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
! zy,rdz,rdzw,dnw,dn,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
! jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
DO im =n_moist, PARAM_FIRST_SCALAR, -1
! moist_tendf(ims,kms,jms,im) =Tmpv200(im) ! Remarked by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_s(moist_tendf(ims,kms,jms,im),a_moist_tendf(ims, &
kms,jms,im),mu,a_mu,config_flags,moist(ims,kms,jms,im),a_moist(ims,kms,jms,im) &
,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx, &
! Revised by Ning Pan, 2010-08-10
! a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,,ids,ide,jds,jde,kds,kde,ims,ime, &
a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[2]
!LPB[1]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tke_tendf(IX1,IX2,IX3) =Keep_Lpb1_tke_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! IF(km_opt .eq. 2) THEN
! Tmpv_1 =tke_tendf(ims,kms,jms)
! CALL horizontal_diffusion_s(tke_tendf(ims,kms,jms),mu,config_flags,tke(ims,kms, &
! jms),msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx,zy,rdz, &
! rdzw,dnw,dn,.true.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! END IF
IF(km_opt .eq. 2) THEN
! tke_tendf(ims,kms,jms) =Tmpv_1 ! Remarked by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_s(tke_tendf(ims,kms,jms),a_tke_tendf(ims,kms,jms) &
,mu,a_mu,config_flags,tke(ims,kms,jms),a_tke(ims,kms,jms),msftx,msfty,msfux, &
msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx,a_zx,zy,a_zy,rdz, &
! Revised by Ning Pan, 2010-08-10
! a_rdz,rdzw,a_rdzw,dnw,dn,,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,.true.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
ite,jts,jte,kts,kte)
END IF
!LPB[0]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! ru_tendf(IX1,IX2,IX3) =Keep_Lpb0_ru_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb0_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rv_tendf(IX1,IX2,IX3) =Keep_Lpb0_rv_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rw_tendf(IX1,IX2,IX3) =Keep_Lpb0_rw_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rt_tendf(IX1,IX2,IX3) =Keep_Lpb0_rt_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-11
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv400(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-11
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv500(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
Keep_Lpb0_nba_mij = nba_mij ! Added by Ning Pan, 2010-08-11
CALL horizontal_diffusion_u_2(ru_tendf,config_flags,defor11,defor12,div, &
nba_mij,n_nba_mij,tke(ims,kms,jms),msfux,msfuy,xkmh,rdx,rdy,fnm,fnp,dnw,zx,zy,rdzw,rho,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11: useless recomputation
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv401(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv501(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
Keep_Lpb1_nba_mij = nba_mij ! Added by Ning Pan, 2010-08-11
CALL horizontal_diffusion_v_2(rv_tendf,config_flags,defor12,defor22,div, &
nba_mij,n_nba_mij,tke(ims,kms,jms),msfvx,msfvy,xkmh,rdx,rdy,fnm,fnp,dnw,zx,zy,rdzw,rho,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv402(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv502(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! CALL horizontal_diffusion_w_2(rw_tendf,mu,config_flags,defor13,defor23,div, &
! nba_mij,n_nba_mij,tke(ims,kms,jms),msftx,msfty,xkmh,rdx,rdy,fnm,fnp,dn,zx,zy,rdz,rho,ids, &
! ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv403(IX1,IX2,IX3) =rt_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL horizontal_diffusion_s(rt_tendf,mu,config_flags,thp,msftx,msfty,msfux,msfuy, &
! msfvx,msfvy,xkhh,rdx,rdy,fnm,fnp,cf1,cf2,cf3,zx,zy,rdz,rdzw,dnw,dn,rho,.false.,ids,ide, &
! jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rt_tendf(IX1,IX2,IX3) =Tmpv403(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_horizontal_diffusion_s(rt_tendf,a_rt_tendf,mu,a_mu,config_flags,thp, &
a_thp,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1,cf2, &
! Revised by Ning Pan, 2010-08-10
! cf3,zx,a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,,ids,ide,jds,jde,kds,kde, &
cf3,zx,a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Tmpv502(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rw_tendf(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_horizontal_diffusion_w_2(rw_tendf,a_rw_tendf,mu,a_mu,config_flags, &
defor13,a_defor13,defor23,a_defor23,div,a_div,nba_mij,a_nba_mij,n_nba_mij, &
tke(ims,kms,jms),a_tke(ims,kms,jms),msftx,msfty,xkmh,a_xkmh,rdx,rdy,fnm,fnp,zx, &
a_zx,zy,a_zy,rdz,a_rdz,rho,a_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Tmpv501(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rv_tendf(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
! END DO
! END DO
! END DO
nba_mij = Keep_Lpb1_nba_mij ! Added by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_v_2(rv_tendf,a_rv_tendf,mu,a_mu,config_flags, &
defor12,a_defor12,defor22,a_defor22,div,a_div,nba_mij,a_nba_mij,n_nba_mij, &
tke(ims,kms,jms),a_tke(ims,kms,jms),msfvx,msfvy,xkmh,a_xkmh,rdx,rdy,fnm,fnp,zx, &
a_zx,zy,a_zy,rdzw,a_rdzw,rho,a_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Tmpv500(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-11
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! ru_tendf(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
! END DO
! END DO
! END DO
nba_mij = Keep_Lpb0_nba_mij ! Added by Ning Pan, 2010-08-11
CALL a_horizontal_diffusion_u_2(ru_tendf,a_ru_tendf,mu,a_mu,config_flags, &
defor11,a_defor11,defor12,a_defor12,div,a_div,nba_mij,a_nba_mij,n_nba_mij, &
tke(ims,kms,jms),a_tke(ims,kms,jms),msfux,msfuy,xkmh,a_xkmh,rdx,rdy,fnm,fnp,zx, &
a_zx,zy,a_zy,rdzw,a_rdzw,rho,a_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
ite,jts,jte,kts,kte)
END SUBROUTINE a_horizontal_diffusion_2
SUBROUTINE a_horizontal_diffusion_u_2(tendency,a_tendency,mu,a_mu,config_flags, &
defor11,a_defor11,defor12,a_defor12,div,a_div,nba_mij,a_nba_mij,n_nba_mij, &
tke,a_tke,msfux,msfuy,xkmh,a_xkmh,rdx,rdy,fnm,fnp,zx,a_zx,zy,a_zy,rdzw, &
a_rdzw,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor11,a_defor11,defor12,a_defor12, &
div,a_div,tke,a_tke,xkmh,a_xkmh,zx,a_zx,zy,a_zy
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,a_titau1avg,titau2avg, &
a_titau2avg,titau1,a_titau1,titau2,a_titau2,xkxavg,a_xkxavg,rravg,a_rravg
REAL :: mrdx,a_mrdx,mrdy,a_mrdy,rcoup,a_rcoup
REAL :: tmpzy,a_tmpzy,tmpzeta_z,a_tmpzeta_z
REAL :: term1,a_term1,term2,a_term2,term3,a_term3
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
INTEGER :: IX1,IX2,IX3,IX4
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
REAL :: Tmpv_1,Tmpv_2
REAL,DIMENSION(its:ite,min0(kts+1,kts):min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:ite,min0(kts+1,kts):min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:ite,min0(kts+1,kts):min(kte,kde-1)) :: Tmpv302
REAL,DIMENSION(its:ite,min0(kts+1,kts):min(kte,kde-1)) :: Tmpv303
REAL,DIMENSION(its:ite,min0(kts+1,kts):min(kte,kde-1)) :: Tmpv304
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = ite
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-1,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
is_ext=1
ie_ext=0
js_ext=0
je_ext=0
CALL cal_titau_11_22_33( config_flags, titau1, &
tke, xkmh, defor11, &
nba_mij(ims,kms,jms,P_m11), rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
is_ext=0
ie_ext=0
js_ext=0
je_ext=1
CALL cal_titau_12_21( config_flags, titau2, &
xkmh, defor12, &
nba_mij(ims,kms,jms,P_m12), rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!LPB[13]
DO j = j_start, j_end
DO k = kts+1,ktf
DO i = i_start, i_end
titau1avg(i,k,j)=0.5*(fnm(k)*(titau1(i-1,k ,j)+titau1(i,k ,j))+ &
fnp(k)*(titau1(i-1,k-1,j)+titau1(i,k-1,j)))
titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k ,j+1)+titau2(i,k ,j))+ &
fnp(k)*(titau2(i,k-1,j+1)+titau2(i,k-1,j)))
tmpzy = 0.25*( zy(i-1,k,j )+zy(i,k,j )+ &
zy(i-1,k,j+1)+zy(i,k,j+1) )
titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j)
titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j = j_start, j_end
DO i = i_start, i_end
titau1avg(i,kts,j)=0.
titau1avg(i,ktf+1,j)=0.
titau2avg(i,kts,j)=0.
titau2avg(i,ktf+1,j)=0.
ENDDO
ENDDO
!!LPB[15]
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! mrdx=msfux(i,j)*rdx
! mrdy=msfuy(i,j)*rdy
! tendency(i,k,j)=tendency(i,k,j)- &
! (mrdx*(titau1(i,k,j )-titau1(i-1,k,j))+ &
! mrdy*(titau2(i,k,j+1)-titau2(i,k,j ))- &
! msfuy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j)-titau1avg(i,k,j))+ &
! (titau2avg(i,k+1,j)-titau2avg(i,k,j)) &
! ) )
! ENDDO
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau1avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau2avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau1(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau2(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_rravg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
! Remarked by Ning Pan, 2010-08-10
! a_mrdx =0.0
! a_mrdy =0.0
! a_rcoup =0.0
a_tmpzy =0.0
! Remarked by Ning Pan, 2010-08-10
! a_tmpzeta_z =0.0
! a_term1 =0.0
! a_term2 =0.0
! a_term3 =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[15]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =mrdx
! mrdx =msfux(i,j)*rdx
mrdx =msfux(i,j)*rdx
Tmpv300(i,k) =mrdx
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =mrdy
! mrdy =msfuy(i,j)*rdy
mrdy =msfuy(i,j)*rdy
Tmpv301(i,k) =mrdy
Tmpv001 =titau1(i,k,j) -titau1(i-1,k,j)
Tmpv302(i,k) =Tmpv001
Tmpv002 =mrdx*Tmpv302(i,k)
Tmpv003 =titau2(i,k,j+1) -titau2(i,k,j)
Tmpv303(i,k) =Tmpv003
Tmpv004 =mrdy*Tmpv303(i,k)
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =titau1avg(i,k+1,j) -titau1avg(i,k,j)
Tmpv007 =titau2avg(i,k+1,j) -titau2avg(i,k,j)
Tmpv008 =Tmpv006 +Tmpv007
Tmpv304(i,k) =Tmpv008
! Remarked by Ning Pan, 2010-08-10
! Tmpv009 =msfuy(i,j)*rdzw(i,k,j)*Tmpv304(i,k)
! Tmpv010 =Tmpv005 -Tmpv009
! Tmpv011 =tendency(i,k,j) -Tmpv010
! tendency(i,k,j) =Tmpv011
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
mrdx =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
mrdy =Tmpv301(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv11 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv11
a_Tmpv10 =-a_Tmpv11
a_Tmpv5 =a_Tmpv10
a_Tmpv9 =-a_Tmpv10
a_rdzw(i,k,j) =a_rdzw(i,k,j) +msfuy(i,j)*Tmpv304(i,k)*a_Tmpv9
a_Tmpv8 =msfuy(i,j)*rdzw(i,k,j)*a_Tmpv9
a_Tmpv6 =a_Tmpv8
a_Tmpv7 =a_Tmpv8
a_titau2avg(i,k+1,j) =a_titau2avg(i,k+1,j) +a_Tmpv7
a_titau2avg(i,k,j) =a_titau2avg(i,k,j) -a_Tmpv7
a_titau1avg(i,k+1,j) =a_titau1avg(i,k+1,j) +a_Tmpv6
a_titau1avg(i,k,j) =a_titau1avg(i,k,j) -a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_mrdy =a_mrdy +Tmpv303(i,k)*a_Tmpv4
a_Tmpv3 =mrdy*a_Tmpv4
a_titau2(i,k,j+1) =a_titau2(i,k,j+1) +a_Tmpv3
a_titau2(i,k,j) =a_titau2(i,k,j) -a_Tmpv3
a_mrdx =a_mrdx +Tmpv302(i,k)*a_Tmpv2
a_Tmpv1 =mrdx*a_Tmpv2
a_titau1(i,k,j) =a_titau1(i,k,j) +a_Tmpv1
a_titau1(i-1,k,j) =a_titau1(i-1,k,j) -a_Tmpv1
! Remarked by Ning Pan, 2010-08-10
! mrdy =Tmpv301(i,k)
! a_mrdy =0.0
! mrdx =Tmpv300(i,k)
! a_mrdx =0.0
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! titau1avg(i,kts,j) =0.
! titau1avg(i,ktf+1,j) =0.
! titau2avg(i,kts,j) =0.
! titau2avg(i,ktf+1,j) =0.
! ENDDO
DO i =i_end, i_start, -1
a_titau2avg(i,ktf+1,j) =0.0
a_titau2avg(i,kts,j) =0.0
a_titau1avg(i,ktf+1,j) =0.0
a_titau1avg(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =titau1(i-1,k,j) +titau1(i,k,j)
Tmpv002 =fnm(k)*Tmpv001
Tmpv003 =titau1(i-1,k-1,j) +titau1(i,k-1,j)
Tmpv004 =fnp(k)*Tmpv003
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =0.5*Tmpv005
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =titau1avg(i,k,j)
! titau1avg(i,k,j) =Tmpv006
titau1avg(i,k,j) =Tmpv006
Tmpv300(i,k) =titau1avg(i,k,j)
Tmpv001 =titau2(i,k,j+1) +titau2(i,k,j)
Tmpv002 =fnm(k)*Tmpv001
Tmpv003 =titau2(i,k-1,j+1) +titau2(i,k-1,j)
Tmpv004 =fnp(k)*Tmpv003
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =0.5*Tmpv005
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =titau2avg(i,k,j)
! titau2avg(i,k,j) =Tmpv006
titau2avg(i,k,j) =Tmpv006
Tmpv301(i,k) =titau2avg(i,k,j)
Tmpv001 =zy(i-1,k,j) +zy(i,k,j)
Tmpv002 =Tmpv001 +zy(i-1,k,j+1)
Tmpv003 =Tmpv002 +zy(i,k,j+1)
Tmpv004 =0.25*Tmpv003
! Revised by Ning Pan, 2010-08-10
! Tmpv302(i,k) =tmpzy
! tmpzy =Tmpv004
tmpzy =Tmpv004
Tmpv302(i,k) =tmpzy
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =titau1avg(i,k,j)*zx(i,k,j)
! Tmpv303(i,k) =titau1avg(i,k,j)
! titau1avg(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =titau2avg(i,k,j)*tmpzy
! Tmpv304(i,k) =titau2avg(i,k,j)
! titau2avg(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
tmpzy =Tmpv302(i,k) ! Added by Ning Pan, 2010-08-10
! Revised by Ning Pan, 2010-08-10
! titau2avg(i,k,j) =Tmpv304(i,k)
titau2avg(i,k,j) =Tmpv301(i,k)
a_Tmpv1 =a_titau2avg(i,k,j)
a_titau2avg(i,k,j) =0.0
a_titau2avg(i,k,j) =a_titau2avg(i,k,j) +tmpzy*a_Tmpv1
a_tmpzy =a_tmpzy +titau2avg(i,k,j)*a_Tmpv1
! Revised by Ning Pan, 2010-08-10
! titau1avg(i,k,j) =Tmpv303(i,k)
titau1avg(i,k,j) =Tmpv300(i,k)
a_Tmpv1 =a_titau1avg(i,k,j)
a_titau1avg(i,k,j) =0.0
a_titau1avg(i,k,j) =a_titau1avg(i,k,j) +zx(i,k,j)*a_Tmpv1
a_zx(i,k,j) =a_zx(i,k,j) +titau1avg(i,k,j)*a_Tmpv1
! tmpzy =Tmpv302(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv4 =a_tmpzy
a_tmpzy =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zy(i,k,j+1) =a_zy(i,k,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zy(i-1,k,j+1) =a_zy(i-1,k,j+1) +a_Tmpv2
a_zy(i-1,k,j) =a_zy(i-1,k,j) +a_Tmpv1
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
! titau2avg(i,k,j) =Tmpv301(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv6 =a_titau2avg(i,k,j)
a_titau2avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_titau2(i,k-1,j+1) =a_titau2(i,k-1,j+1) +a_Tmpv3
a_titau2(i,k-1,j) =a_titau2(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_titau2(i,k,j+1) =a_titau2(i,k,j+1) +a_Tmpv1
a_titau2(i,k,j) =a_titau2(i,k,j) +a_Tmpv1
! titau1avg(i,k,j) =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv6 =a_titau1avg(i,k,j)
a_titau1avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_titau1(i-1,k-1,j) =a_titau1(i-1,k-1,j) +a_Tmpv3
a_titau1(i,k-1,j) =a_titau1(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_titau1(i-1,k,j) =a_titau1(i-1,k,j) +a_Tmpv1
a_titau1(i,k,j) =a_titau1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-10
! is_ext =1
! ie_ext =0
! js_ext =0
! je_ext =0
! Tmpv_1 =nba_mij(ims,kms,jms,P_m11)
! CALL cal_titau_11_22_33(config_flags,titau1,mu,tke,xkmh,defor11,nba_mij(ims,kms, &
! jms,P_m11),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
! kme,its,ite,jts,jte,kts,kte)
! is_ext =0
! ie_ext =0
! js_ext =0
! je_ext =1
! Tmpv_2 =nba_mij(ims,kms,jms,P_m12)
! CALL cal_titau_12_21(config_flags,titau2,mu,xkmh,defor12,nba_mij(ims,kms,jms, &
! P_m12),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
! its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m12) =Tmpv_2
! Added by Ning Pan, 2010-08-10
is_ext =0
ie_ext =0
js_ext =0
je_ext =1
CALL a_cal_titau_12_21(config_flags,titau2,a_titau2,mu,a_mu,xkmh,a_xkmh, &
defor12,a_defor12,nba_mij(ims,kms,jms,P_m12),a_nba_mij(ims,kms,jms,P_m12) &
,rho, a_rho &
,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m11) =Tmpv_1 ! Remarked by Ning Pan, 2010-08-10
! Added by Ning Pan, 2010-08-10
is_ext=1
ie_ext=0
js_ext=0
je_ext=0
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
CALL a_cal_titau_11_22_33(config_flags,titau1,a_titau1,mu,a_mu,tke,a_tke, &
xkmh,a_xkmh,defor11,a_defor11,nba_mij(ims,kms,jms,P_m11),a_nba_mij(ims,kms,jms, &
P_m11),rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =ite
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-1, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =ite
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_horizontal_diffusion_u_2
SUBROUTINE a_horizontal_diffusion_v_2(tendency,a_tendency,mu,a_mu,config_flags, &
defor12,a_defor12,defor22,a_defor22,div,a_div,nba_mij,a_nba_mij,n_nba_mij, &
tke,a_tke,msfvx,msfvy,xkmh,a_xkmh,rdx,rdy,fnm,fnp,zx,a_zx,zy,a_zy,rdzw, &
a_rdzw,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(ims:ime,jms:jme) :: msfvx,msfvy,mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor12,a_defor12,defor22,a_defor22, &
div,a_div,tke,a_tke,xkmh,a_xkmh,zx,a_zx,zy,a_zy,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,a_titau1avg,titau2avg, &
a_titau2avg,titau1,a_titau1,titau2,a_titau2,xkxavg,a_xkxavg,rravg,a_rravg
REAL :: mrdx,a_mrdx,mrdy,a_mrdy,rcoup,a_rcoup
REAL :: tmpzx,a_tmpzx,tmpzeta_z,a_tmpzeta_z
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
INTEGER :: IX1,IX2,IX3,IX4
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
REAL :: Tmpv_1,Tmpv_2
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv302
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv303
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv304
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = jte
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-1,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
is_ext=0
ie_ext=1
js_ext=0
je_ext=0
CALL cal_titau_12_21( config_flags, titau1, &
xkmh, defor12, &
nba_mij(ims,kms,jms,P_m12), rho, &
is_ext,ie_ext,js_ext,je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
is_ext=0
ie_ext=0
js_ext=1
je_ext=0
CALL cal_titau_11_22_33( config_flags, titau2, &
tke, xkmh, defor22, &
nba_mij(ims,kms,jms,P_m22), rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!LPB[13]
DO j = j_start, j_end
DO k = kts+1,ktf
DO i = i_start, i_end
titau1avg(i,k,j)=0.5*(fnm(k)*(titau1(i+1,k ,j)+titau1(i,k ,j))+ &
fnp(k)*(titau1(i+1,k-1,j)+titau1(i,k-1,j)))
titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k ,j-1)+titau2(i,k ,j))+ &
fnp(k)*(titau2(i,k-1,j-1)+titau2(i,k-1,j)))
tmpzx = 0.25*( zx(i,k,j )+zx(i+1,k,j )+ &
zx(i,k,j-1)+zx(i+1,k,j-1) )
titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx
titau2avg(i,k,j)=titau2avg(i,k,j)*zy(i,k,j)
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j = j_start, j_end
DO i = i_start, i_end
titau1avg(i,kts,j)=0.
titau1avg(i,ktf+1,j)=0.
titau2avg(i,kts,j)=0.
titau2avg(i,ktf+1,j)=0.
ENDDO
ENDDO
!!LPB[15]
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! mrdx=msfvx(i,j)*rdx
! mrdy=msfvy(i,j)*rdy
! tendency(i,k,j)=tendency(i,k,j)- &
! (mrdy*(titau2(i ,k,j)-titau2(i,k,j-1))+ &
! mrdx*(titau1(i+1,k,j)-titau1(i,k,j ))- &
! msfvy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j)-titau1avg(i,k,j))+ &
! (titau2avg(i,k+1,j)-titau2avg(i,k,j)) &
! ) &
! )
! ENDDO
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau1avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau2avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau1(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau2(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_rravg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
! Remarked by Ning Pan, 2010-08-10
! a_mrdx =0.0
! a_mrdy =0.0
! a_rcoup =0.0
a_tmpzx =0.0
! a_tmpzeta_z =0.0 ! Remarked by Ning Pan, 2010-08-10
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[15]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =mrdx
! mrdx =msfvx(i,j)*rdx
mrdx =msfvx(i,j)*rdx
Tmpv300(i,k) =mrdx
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =mrdy
! mrdy =msfvy(i,j)*rdy
mrdy =msfvy(i,j)*rdy
Tmpv301(i,k) =mrdy
Tmpv001 =titau2(i,k,j) -titau2(i,k,j-1)
Tmpv302(i,k) =Tmpv001
Tmpv002 =mrdy*Tmpv302(i,k)
Tmpv003 =titau1(i+1,k,j) -titau1(i,k,j)
Tmpv303(i,k) =Tmpv003
Tmpv004 =mrdx*Tmpv303(i,k)
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =titau1avg(i,k+1,j) -titau1avg(i,k,j)
Tmpv007 =titau2avg(i,k+1,j) -titau2avg(i,k,j)
Tmpv008 =Tmpv006 +Tmpv007
Tmpv304(i,k) =Tmpv008
! Remarked by Ning Pan, 2010-08-10
! Tmpv009 =msfvy(i,j)*rdzw(i,k,j)*Tmpv304(i,k)
! Tmpv010 =Tmpv005 -Tmpv009
! Tmpv011 =tendency(i,k,j) -Tmpv010
! tendency(i,k,j) =Tmpv011
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
mrdx =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
mrdy =Tmpv301(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv11 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv11
a_Tmpv10 =-a_Tmpv11
a_Tmpv5 =a_Tmpv10
a_Tmpv9 =-a_Tmpv10
a_rdzw(i,k,j) =a_rdzw(i,k,j) +msfvy(i,j)*Tmpv304(i,k)*a_Tmpv9
a_Tmpv8 =msfvy(i,j)*rdzw(i,k,j)*a_Tmpv9
a_Tmpv6 =a_Tmpv8
a_Tmpv7 =a_Tmpv8
a_titau2avg(i,k+1,j) =a_titau2avg(i,k+1,j) +a_Tmpv7
a_titau2avg(i,k,j) =a_titau2avg(i,k,j) -a_Tmpv7
a_titau1avg(i,k+1,j) =a_titau1avg(i,k+1,j) +a_Tmpv6
a_titau1avg(i,k,j) =a_titau1avg(i,k,j) -a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_mrdx =a_mrdx +Tmpv303(i,k)*a_Tmpv4
a_Tmpv3 =mrdx*a_Tmpv4
a_titau1(i+1,k,j) =a_titau1(i+1,k,j) +a_Tmpv3
a_titau1(i,k,j) =a_titau1(i,k,j) -a_Tmpv3
a_mrdy =a_mrdy +Tmpv302(i,k)*a_Tmpv2
a_Tmpv1 =mrdy*a_Tmpv2
a_titau2(i,k,j) =a_titau2(i,k,j) +a_Tmpv1
a_titau2(i,k,j-1) =a_titau2(i,k,j-1) -a_Tmpv1
! Remarked by Ning Pan, 2010-08-10
! mrdy =Tmpv301(i,k)
! a_mrdy =0.0
! mrdx =Tmpv300(i,k)
! a_mrdx =0.0
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! titau1avg(i,kts,j) =0.
! titau1avg(i,ktf+1,j) =0.
! titau2avg(i,kts,j) =0.
! titau2avg(i,ktf+1,j) =0.
! ENDDO
DO i =i_end, i_start, -1
a_titau2avg(i,ktf+1,j) =0.0
a_titau2avg(i,kts,j) =0.0
a_titau1avg(i,ktf+1,j) =0.0
a_titau1avg(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =titau1(i+1,k,j) +titau1(i,k,j)
Tmpv002 =fnm(k)*Tmpv001
Tmpv003 =titau1(i+1,k-1,j) +titau1(i,k-1,j)
Tmpv004 =fnp(k)*Tmpv003
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =0.5*Tmpv005
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =titau1avg(i,k,j)
! titau1avg(i,k,j) =Tmpv006
titau1avg(i,k,j) =Tmpv006
Tmpv300(i,k) =titau1avg(i,k,j)
Tmpv001 =titau2(i,k,j-1) +titau2(i,k,j)
Tmpv002 =fnm(k)*Tmpv001
Tmpv003 =titau2(i,k-1,j-1) +titau2(i,k-1,j)
Tmpv004 =fnp(k)*Tmpv003
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =0.5*Tmpv005
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =titau2avg(i,k,j)
! titau2avg(i,k,j) =Tmpv006
titau2avg(i,k,j) =Tmpv006
Tmpv301(i,k) =titau2avg(i,k,j)
Tmpv001 =zx(i,k,j) +zx(i+1,k,j)
Tmpv002 =Tmpv001 +zx(i,k,j-1)
Tmpv003 =Tmpv002 +zx(i+1,k,j-1)
Tmpv004 =0.25*Tmpv003
! Revised by Ning Pan, 2010-08-10
! Tmpv302(i,k) =tmpzx
! tmpzx =Tmpv004
tmpzx =Tmpv004
Tmpv302(i,k) =tmpzx
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =titau1avg(i,k,j)*tmpzx
! Tmpv303(i,k) =titau1avg(i,k,j)
! titau1avg(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =titau2avg(i,k,j)*zy(i,k,j)
! Tmpv304(i,k) =titau2avg(i,k,j)
! titau2avg(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
! Revised by Ning Pan, 2010-08-10
! titau2avg(i,k,j) =Tmpv304(i,k)
titau2avg(i,k,j) =Tmpv301(i,k)
a_Tmpv1 =a_titau2avg(i,k,j)
a_titau2avg(i,k,j) =0.0
a_titau2avg(i,k,j) =a_titau2avg(i,k,j) +zy(i,k,j)*a_Tmpv1
a_zy(i,k,j) =a_zy(i,k,j) +titau2avg(i,k,j)*a_Tmpv1
tmpzx =Tmpv302(i,k) ! Added by Ning Pan, 2010-08-10
! Revised by Ning Pan, 2010-08-10
! titau1avg(i,k,j) =Tmpv303(i,k)
titau1avg(i,k,j) =Tmpv300(i,k)
a_Tmpv1 =a_titau1avg(i,k,j)
a_titau1avg(i,k,j) =0.0
a_titau1avg(i,k,j) =a_titau1avg(i,k,j) +tmpzx*a_Tmpv1
a_tmpzx =a_tmpzx +titau1avg(i,k,j)*a_Tmpv1
! tmpzx =Tmpv302(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv4 =a_tmpzx
a_tmpzx =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zx(i+1,k,j-1) =a_zx(i+1,k,j-1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zx(i,k,j-1) =a_zx(i,k,j-1) +a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
a_zx(i+1,k,j) =a_zx(i+1,k,j) +a_Tmpv1
! titau2avg(i,k,j) =Tmpv301(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv6 =a_titau2avg(i,k,j)
a_titau2avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_titau2(i,k-1,j-1) =a_titau2(i,k-1,j-1) +a_Tmpv3
a_titau2(i,k-1,j) =a_titau2(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_titau2(i,k,j-1) =a_titau2(i,k,j-1) +a_Tmpv1
a_titau2(i,k,j) =a_titau2(i,k,j) +a_Tmpv1
! titau1avg(i,k,j) =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv6 =a_titau1avg(i,k,j)
a_titau1avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_titau1(i+1,k-1,j) =a_titau1(i+1,k-1,j) +a_Tmpv3
a_titau1(i,k-1,j) =a_titau1(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_titau1(i+1,k,j) =a_titau1(i+1,k,j) +a_Tmpv1
a_titau1(i,k,j) =a_titau1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-10
! is_ext =0
! ie_ext =1
! js_ext =0
! je_ext =0
! Tmpv_1 =nba_mij(ims,kms,jms,P_m12)
! CALL cal_titau_12_21(config_flags,titau1,mu,xkmh,defor12,nba_mij(ims,kms,jms, &
! P_m12),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
! its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-10
! is_ext =0
! ie_ext =0
! js_ext =1
! je_ext =0
! Tmpv_2 =nba_mij(ims,kms,jms,P_m22)
! CALL cal_titau_11_22_33(config_flags,titau2,mu,tke,xkmh,defor22,nba_mij(ims,kms, &
! jms,P_m22),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
! kme,its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m22) =Tmpv_2
! Added by Ning Pan, 2010-08-10
is_ext =0
ie_ext =0
js_ext =1
je_ext =0
CALL a_cal_titau_11_22_33(config_flags,titau2,a_titau2,mu,a_mu,tke,a_tke, &
xkmh,a_xkmh,defor22,a_defor22,nba_mij(ims,kms,jms,P_m22),a_nba_mij(ims,kms,jms, &
P_m22),rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m12) =Tmpv_1 ! Remarked by Ning Pan, 2010-08-10
! Added by Ning Pan, 2010-08-10
is_ext =0
ie_ext =1
js_ext =0
je_ext =0
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
CALL a_cal_titau_12_21(config_flags,titau1,a_titau1,mu,a_mu,xkmh,a_xkmh, &
defor12,a_defor12,nba_mij(ims,kms,jms,P_m12),a_nba_mij(ims,kms,jms,P_m12) &
,rho,a_rho &
,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-1, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =jte
END SUBROUTINE a_horizontal_diffusion_v_2
SUBROUTINE a_horizontal_diffusion_w_2(tendency,a_tendency,mu,a_mu,config_flags, &
defor13,a_defor13,defor23,a_defor23,div,a_div,nba_mij,a_nba_mij,n_nba_mij, &
tke,a_tke,msftx,msfty,xkmh,a_xkmh,rdx,rdy,fnm,fnp,zx,a_zx,zy,a_zy,rdz, &
a_rdz,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(ims:ime,jms:jme) :: msftx,msfty,mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,a_defor13,defor23,a_defor23, &
div,a_div,tke,a_tke,xkmh,a_xkmh,zx,a_zx,zy,a_zy,rdz,a_rdz
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau1avg,a_titau1avg,titau2avg, &
a_titau2avg,titau1,a_titau1,titau2,a_titau2,xkxavg,a_xkxavg,rravg,a_rravg
REAL :: mrdx,a_mrdx,mrdy,a_mrdy,rcoup,a_rcoup
REAL :: tmpzx,a_tmpzx,tmpzy,a_tmpzy,tmpzeta_z,a_tmpzeta_z
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
INTEGER :: IX1,IX2,IX3,IX4
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
REAL :: Tmpv_1,Tmpv_2
REAL,DIMENSION(its:min(ite,ide-1),min0(kts,kts+1):min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),min0(kts,kts+1):min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),min0(kts,kts+1):min(kte,kde-1)) :: Tmpv302
REAL,DIMENSION(its:min(ite,ide-1),min0(kts,kts+1):min(kte,kde-1)) :: Tmpv303
REAL,DIMENSION(its:min(ite,ide-1),min0(kts,kts+1):min(kte,kde-1)) :: Tmpv304
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv305
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
is_ext=0
ie_ext=1
js_ext=0
je_ext=0
CALL cal_titau_13_31( config_flags, titau1, defor13, &
nba_mij(ims,kms,jms,P_m13), &
xkmh, fnm, fnp, rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
is_ext=0
ie_ext=0
js_ext=0
je_ext=1
CALL cal_titau_23_32( config_flags, titau2, defor23, &
nba_mij(ims,kms,jms,P_m23), &
xkmh, fnm, fnp, rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!LPB[13]
DO j = j_start, j_end
DO k = kts,ktf
DO i = i_start, i_end
titau1avg(i,k,j)=0.25*(titau1(i+1,k+1,j)+titau1(i,k+1,j)+ &
titau1(i+1,k ,j)+titau1(i,k ,j))
titau2avg(i,k,j)=0.25*(titau2(i,k+1,j+1)+titau2(i,k+1,j)+ &
titau2(i,k ,j+1)+titau2(i,k ,j))
tmpzx =0.25*( zx(i,k ,j)+zx(i+1,k ,j)+ &
zx(i,k+1,j)+zx(i+1,k+1,j) )
tmpzy =0.25*( zy(i,k ,j)+zy(i,k ,j+1)+ &
zy(i,k+1,j)+zy(i,k+1,j+1) )
titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx
titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j = j_start, j_end
DO i = i_start, i_end
titau1avg(i,ktf+1,j)=0.
titau2avg(i,ktf+1,j)=0.
ENDDO
ENDDO
!!LPB[15]
! DO j = j_start, j_end
! DO k = kts+1,ktf
! DO i = i_start, i_end
! mrdx=msftx(i,j)*rdx
! mrdy=msfty(i,j)*rdy
! tendency(i,k,j)=tendency(i,k,j)- &
! (mrdx*(titau1(i+1,k,j)-titau1(i,k,j))+ &
! mrdy*(titau2(i,k,j+1)-titau2(i,k,j))- &
! msfty(i,j)*rdz(i,k,j)*(titau1avg(i,k,j)-titau1avg(i,k-1,j)+ &
! titau2avg(i,k,j)-titau2avg(i,k-1,j) &
! ) &
! )
! ENDDO
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau1avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau2avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau1(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau2(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_rravg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
! Remarked by Ning Pan, 2010-08-10
! a_mrdx =0.0
! a_mrdy =0.0
! a_rcoup =0.0
a_tmpzx =0.0
a_tmpzy =0.0
! a_tmpzeta_z =0.0 ! Remarked by Ning Pan, 2010-08-10
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[15]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =mrdx
! mrdx =msftx(i,j)*rdx
mrdx =msftx(i,j)*rdx
Tmpv300(i,k) =mrdx
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =mrdy
! mrdy =msfty(i,j)*rdy
mrdy =msfty(i,j)*rdy
Tmpv301(i,k) =mrdy
Tmpv001 =titau1(i+1,k,j) -titau1(i,k,j)
Tmpv302(i,k) =Tmpv001
Tmpv002 =mrdx*Tmpv302(i,k)
Tmpv003 =titau2(i,k,j+1) -titau2(i,k,j)
Tmpv303(i,k) =Tmpv003
Tmpv004 =mrdy*Tmpv303(i,k)
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =titau1avg(i,k,j) -titau1avg(i,k-1,j)
Tmpv007 =Tmpv006 +titau2avg(i,k,j)
Tmpv008 =Tmpv007 -titau2avg(i,k-1,j)
Tmpv304(i,k) =Tmpv008
! Remarked by Ning Pan, 2010-08-10
! Tmpv009 =msfty(i,j)*rdz(i,k,j)*Tmpv304(i,k)
! Tmpv010 =Tmpv005 -Tmpv009
! Tmpv011 =tendency(i,k,j) -Tmpv010
! tendency(i,k,j) =Tmpv011
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
mrdx =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
mrdy =Tmpv301(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv11 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv11
a_Tmpv10 =-a_Tmpv11
a_Tmpv5 =a_Tmpv10
a_Tmpv9 =-a_Tmpv10
a_rdz(i,k,j) =a_rdz(i,k,j) +msfty(i,j)*Tmpv304(i,k)*a_Tmpv9
a_Tmpv8 =msfty(i,j)*rdz(i,k,j)*a_Tmpv9
a_Tmpv7 =a_Tmpv8
a_titau2avg(i,k-1,j) =a_titau2avg(i,k-1,j) -a_Tmpv8
a_Tmpv6 =a_Tmpv7
a_titau2avg(i,k,j) =a_titau2avg(i,k,j) +a_Tmpv7
a_titau1avg(i,k,j) =a_titau1avg(i,k,j) +a_Tmpv6
a_titau1avg(i,k-1,j) =a_titau1avg(i,k-1,j) -a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_mrdy =a_mrdy +Tmpv303(i,k)*a_Tmpv4
a_Tmpv3 =mrdy*a_Tmpv4
a_titau2(i,k,j+1) =a_titau2(i,k,j+1) +a_Tmpv3
a_titau2(i,k,j) =a_titau2(i,k,j) -a_Tmpv3
a_mrdx =a_mrdx +Tmpv302(i,k)*a_Tmpv2
a_Tmpv1 =mrdx*a_Tmpv2
a_titau1(i+1,k,j) =a_titau1(i+1,k,j) +a_Tmpv1
a_titau1(i,k,j) =a_titau1(i,k,j) -a_Tmpv1
! Remarked by Ning Pan, 2010-08-10
! mrdy =Tmpv301(i,k)
! a_mrdy =0.0
! mrdx =Tmpv300(i,k)
! a_mrdx =0.0
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! titau1avg(i,ktf+1,j) =0.
! titau2avg(i,ktf+1,j) =0.
! ENDDO
DO i =i_end, i_start, -1
a_titau2avg(i,ktf+1,j) =0.0
a_titau1avg(i,ktf+1,j) =0.0
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =titau1(i+1,k+1,j) +titau1(i,k+1,j)
Tmpv002 =Tmpv001 +titau1(i+1,k,j)
Tmpv003 =Tmpv002 +titau1(i,k,j)
Tmpv004 =0.25*Tmpv003
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =titau1avg(i,k,j)
! titau1avg(i,k,j) =Tmpv004
titau1avg(i,k,j) =Tmpv004
Tmpv300(i,k) =titau1avg(i,k,j)
Tmpv001 =titau2(i,k+1,j+1) +titau2(i,k+1,j)
Tmpv002 =Tmpv001 +titau2(i,k,j+1)
Tmpv003 =Tmpv002 +titau2(i,k,j)
Tmpv004 =0.25*Tmpv003
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =titau2avg(i,k,j)
! titau2avg(i,k,j) =Tmpv004
titau2avg(i,k,j) =Tmpv004
Tmpv301(i,k) =titau2avg(i,k,j)
Tmpv001 =zx(i,k,j) +zx(i+1,k,j)
Tmpv002 =Tmpv001 +zx(i,k+1,j)
Tmpv003 =Tmpv002 +zx(i+1,k+1,j)
Tmpv004 =0.25*Tmpv003
! Revised by Ning Pan, 2010-08-10
! Tmpv302(i,k) =tmpzx
! tmpzx =Tmpv004
tmpzx =Tmpv004
Tmpv302(i,k) =tmpzx
Tmpv001 =zy(i,k,j) +zy(i,k,j+1)
Tmpv002 =Tmpv001 +zy(i,k+1,j)
Tmpv003 =Tmpv002 +zy(i,k+1,j+1)
Tmpv004 =0.25*Tmpv003
! Revised by Ning Pan, 2010-08-10
! Tmpv303(i,k) =tmpzy
! tmpzy =Tmpv004
tmpzy =Tmpv004
Tmpv303(i,k) =tmpzy
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =titau1avg(i,k,j)*tmpzx
! Tmpv304(i,k) =titau1avg(i,k,j)
! titau1avg(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =titau2avg(i,k,j)*tmpzy
! Tmpv305(i,k) =titau2avg(i,k,j)
! titau2avg(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
tmpzy =Tmpv303(i,k) ! Added by Ning Pan, 2010-08-10
! Revised by Ning Pan, 2010-08-10
! titau2avg(i,k,j) =Tmpv305(i,k)
titau2avg(i,k,j) =Tmpv301(i,k)
a_Tmpv1 =a_titau2avg(i,k,j)
a_titau2avg(i,k,j) =0.0
a_titau2avg(i,k,j) =a_titau2avg(i,k,j) +tmpzy*a_Tmpv1
a_tmpzy =a_tmpzy +titau2avg(i,k,j)*a_Tmpv1
tmpzx =Tmpv302(i,k) ! Added by Ning Pan, 2010-08-10
! Revised by Ning Pan, 2010-08-10
! titau1avg(i,k,j) =Tmpv304(i,k)
titau1avg(i,k,j) =Tmpv300(i,k)
a_Tmpv1 =a_titau1avg(i,k,j)
a_titau1avg(i,k,j) =0.0
a_titau1avg(i,k,j) =a_titau1avg(i,k,j) +tmpzx*a_Tmpv1
a_tmpzx =a_tmpzx +titau1avg(i,k,j)*a_Tmpv1
! tmpzy =Tmpv303(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv4 =a_tmpzy
a_tmpzy =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zy(i,k+1,j+1) =a_zy(i,k+1,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zy(i,k+1,j) =a_zy(i,k+1,j) +a_Tmpv2
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
a_zy(i,k,j+1) =a_zy(i,k,j+1) +a_Tmpv1
! tmpzx =Tmpv302(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv4 =a_tmpzx
a_tmpzx =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_zx(i+1,k+1,j) =a_zx(i+1,k+1,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_zx(i,k+1,j) =a_zx(i,k+1,j) +a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
a_zx(i+1,k,j) =a_zx(i+1,k,j) +a_Tmpv1
! titau2avg(i,k,j) =Tmpv301(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv4 =a_titau2avg(i,k,j)
a_titau2avg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_titau2(i,k,j) =a_titau2(i,k,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_titau2(i,k,j+1) =a_titau2(i,k,j+1) +a_Tmpv2
a_titau2(i,k+1,j+1) =a_titau2(i,k+1,j+1) +a_Tmpv1
a_titau2(i,k+1,j) =a_titau2(i,k+1,j) +a_Tmpv1
! titau1avg(i,k,j) =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv4 =a_titau1avg(i,k,j)
a_titau1avg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_titau1(i,k,j) =a_titau1(i,k,j) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_titau1(i+1,k,j) =a_titau1(i+1,k,j) +a_Tmpv2
a_titau1(i+1,k+1,j) =a_titau1(i+1,k+1,j) +a_Tmpv1
a_titau1(i,k+1,j) =a_titau1(i,k+1,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-10
! is_ext =0
! ie_ext =1
! js_ext =0
! je_ext =0
! Tmpv_1 =nba_mij(ims,kms,jms,P_m13)
! CALL cal_titau_13_31(config_flags,titau1,defor13,nba_mij(ims,kms,jms,P_m13) &
! ,mu,xkmh,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
! kms,kme,its,ite,jts,jte,kts,kte)
! is_ext =0
! ie_ext =0
! js_ext =0
! je_ext =1
! Tmpv_2 =nba_mij(ims,kms,jms,P_m23)
! CALL cal_titau_23_32(config_flags,titau2,defor23,nba_mij(ims,kms,jms,P_m23) &
! ,mu,xkmh,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
! kms,kme,its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m23) =Tmpv_2
! Added by Ning Pan, 2010-08-10
is_ext =0
ie_ext =0
js_ext =0
je_ext =1
CALL a_cal_titau_23_32(config_flags,titau2,a_titau2,defor23,a_defor23, &
nba_mij(ims,kms,jms,P_m23),a_nba_mij(ims,kms,jms,P_m23),mu,a_mu,xkmh,a_xkmh, &
fnm,fnp,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m13) =Tmpv_1 ! Remarked by Ning Pan, 2010-08-10
! Added by Ning Pan, 2010-08-10
is_ext =0
ie_ext =1
js_ext =0
je_ext =0
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
CALL a_cal_titau_13_31(config_flags,titau1,a_titau1,defor13,a_defor13, &
nba_mij(ims,kms,jms,P_m13),a_nba_mij(ims,kms,jms,P_m13),mu,a_mu,xkmh,a_xkmh, &
fnm,fnp,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_horizontal_diffusion_w_2
SUBROUTINE a_horizontal_diffusion_s(tendency,a_tendency,mu,a_mu,config_flags, &
var,a_var,msftx,msfty,msfux,msfuy,msfvx,msfvy,xkhh,a_xkhh,rdx,rdy,fnm,fnp,cf1, &
cf2,cf3,zx,a_zx,zy,a_zy,rdz,a_rdz,rdzw,a_rdzw,dnw,dn,rho,a_rho,doing_tke,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
LOGICAL :: doing_tke
REAL :: cf1,cf2,cf3
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,jms:jme) :: msfux
REAL,DIMENSION(ims:ime,jms:jme) :: msfuy
REAL,DIMENSION(ims:ime,jms:jme) :: msfvx
REAL,DIMENSION(ims:ime,jms:jme) :: msfvy
REAL,DIMENSION(ims:ime,jms:jme) :: msftx
REAL,DIMENSION(ims:ime,jms:jme) :: msfty
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhh,a_xkhh,rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var,a_var,zx,a_zx,zy,a_zy
REAL :: rdx,rdy
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: H1avg,a_H1avg,H2avg,a_H2avg, &
H1,a_H1,H2,a_H2,xkxavg,a_xkxavg
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tmptendf,a_tmptendf
REAL :: mrdx,a_mrdx,mrdy,a_mrdy,rcoup,a_rcoup
REAL :: tmpzx,a_tmpzx,tmpzy,a_tmpzy,tmpzeta_z,a_tmpzeta_z,rdzu,a_rdzu,rdzv,a_rdzv
INTEGER :: ktes1,ktes2
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: Keep_Lpb22_H1avg
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: Keep_Lpb22_H2avg
REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb22_tmpzx
REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb22_tmpzy
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,a_Tmpv13,Tmpv013, &
a_Tmpv14,Tmpv014,a_Tmpv15,Tmpv015,a_Tmpv16,Tmpv016,a_Tmpv17,Tmpv017, &
a_Tmpv18,Tmpv018,a_Tmpv19,Tmpv019,a_Tmpv20,Tmpv020
REAL,DIMENSION(its:max0(min(ite,ide-1)+1,min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:max0(min(ite,ide-1)+1,min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:max0(min(ite,ide-1)+1,min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv302
REAL,DIMENSION(its:max0(min(ite,ide-1)+1,min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv303
REAL,DIMENSION(its:max0(min(ite,ide-1)+1,min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv304
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv305
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv306
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv307
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv308
REAL,DIMENSION(its:min(ite,ide-1),kts:min(kte,kde-1)) :: Tmpv309
! Added by Ning Pan, 2010-08-10
REAL,DIMENSION(its:max0(min(ite,ide-1)+1,min(ite,ide-1)),min0(kts,kts+1) &
:min(kte,kde-1)) :: Tmpv3010, Tmpv3011
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
ktes1=kte-1
ktes2=kte-2
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
!LPB[12]
!LPB[13]
! Remarked by Ning Pan, 2010-08-10
! IF ( doing_tke ) THEN
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! tmptendf(i,k,j)=tendency(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ENDIF
!LPB[14]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end + 1
xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j))
ENDDO
ENDDO
ENDDO
!LPB[15]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end + 1
H1avg(i,k,j)=0.5*(fnm(k)*(var(i-1,k ,j)+var(i,k ,j))+ &
fnp(k)*(var(i-1,k-1,j)+var(i,k-1,j)))
ENDDO
ENDDO
ENDDO
!LPB[16]
DO j = j_start, j_end
DO i = i_start, i_end + 1
H1avg(i,kts ,j)=0.5*(cf1*var(i ,1,j)+cf2*var(i ,2,j)+ &
cf3*var(i ,3,j)+cf1*var(i-1,1,j)+ &
cf2*var(i-1,2,j)+cf3*var(i-1,3,j))
H1avg(i,ktf+1,j)=0.5*(var(i,ktes1,j)+(var(i,ktes1,j)- &
var(i,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)+ &
var(i-1,ktes1,j)+(var(i-1,ktes1,j)- &
var(i-1,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1))
ENDDO
ENDDO
!LPB[17]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end + 1
tmpzx = 0.5*( zx(i,k,j)+ zx(i,k+1,j))
rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j))
H1(i,k,j)=-msfuy(i,j)*xkxavg(i,k,j)*( &
rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx* &
(H1avg(i,k+1,j)-H1avg(i,k,j))*rdzu )
ENDDO
ENDDO
ENDDO
!LPB[18]
DO j = j_start, j_end + 1
DO k = kts, ktf
DO i = i_start, i_end
xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j))
ENDDO
ENDDO
ENDDO
!LPB[19]
DO j = j_start, j_end + 1
DO k = kts+1, ktf
DO i = i_start, i_end
H2avg(i,k,j)=0.5*(fnm(k)*(var(i,k ,j-1)+var(i,k ,j))+ &
fnp(k)*(var(i,k-1,j-1)+var(i,k-1,j)))
ENDDO
ENDDO
ENDDO
!LPB[20]
DO j = j_start, j_end + 1
DO i = i_start, i_end
H2avg(i,kts ,j)=0.5*(cf1*var(i,1,j )+cf2*var(i ,2,j)+ &
cf3*var(i,3,j )+cf1*var(i,1,j-1)+ &
cf2*var(i,2,j-1)+cf3*var(i,3,j-1))
H2avg(i,ktf+1,j)=0.5*(var(i,ktes1,j)+(var(i,ktes1,j)- &
var(i,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)+ &
var(i,ktes1,j-1)+(var(i,ktes1,j-1)- &
var(i,ktes2,j-1))*0.5*dnw(ktes1)/dn(ktes1))
ENDDO
ENDDO
!LPB[21]
DO j = j_start, j_end + 1
DO k = kts, ktf
DO i = i_start, i_end
tmpzy = 0.5*( zy(i,k,j)+ zy(i,k+1,j))
rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1))
H2(i,k,j)=-msfvy(i,j)*xkxavg(i,k,j)*( &
rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy* &
(H2avg(i ,k+1,j)-H2avg(i,k,j))*rdzv)
ENDDO
ENDDO
ENDDO
! Added by Ning Pan, 2010-08-10
DO j = j_start, j_end
DO k = kts, ktf+1
DO i = i_start, i_end+1
Keep_Lpb22_H1avg(i,k,j) =H1avg(i,k,j)
END DO
END DO
END DO
DO j = j_start, j_end+1
DO k = kts, ktf+1
DO i = i_start, i_end
Keep_Lpb22_H2avg(i,k,j) =H2avg(i,k,j)
END DO
END DO
END DO
!LPB[22]
DO j = j_start, j_end
! Remarked by Ning Pan, 2010-08-10
! DO k=kts+1, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! Keep_Lpb22_H1avg(i,k,j) =H1avg(i,k,j)
! END DO
! END DO
! DO k=kts+1, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! Keep_Lpb22_H2avg(i,k,j) =H2avg(i,k,j)
! END DO
! END DO
! Keep_Lpb22_tmpzx(j) =tmpzx
! Keep_Lpb22_tmpzy(j) =tmpzy
DO k = kts+1, ktf
DO i = i_start, i_end
H1avg(i,k,j)=0.5*(fnm(k)*(H1(i+1,k ,j)+H1(i,k ,j))+ &
fnp(k)*(H1(i+1,k-1,j)+H1(i,k-1,j)))
H2avg(i,k,j)=0.5*(fnm(k)*(H2(i,k ,j+1)+H2(i,k ,j))+ &
fnp(k)*(H2(i,k-1,j+1)+H2(i,k-1,j)))
tmpzx = 0.5*( zx(i,k,j)+ zx(i+1,k,j ))
tmpzy = 0.5*( zy(i,k,j)+ zy(i ,k,j+1))
H1avg(i,k,j)=H1avg(i,k,j)*tmpzx
H2avg(i,k,j)=H2avg(i,k,j)*tmpzy
ENDDO
ENDDO
ENDDO
!LPB[23]
DO j = j_start, j_end
DO i = i_start, i_end
H1avg(i,kts ,j)=0.
H1avg(i,ktf+1,j)=0.
H2avg(i,kts ,j)=0.
H2avg(i,ktf+1,j)=0.
ENDDO
ENDDO
!!LPB[24]
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! mrdx=msftx(i,j)*rdx
! mrdy=msfty(i,j)*rdy
! tendency(i,k,j)=tendency(i,k,j)- &
! (mrdx*0.5*((mu(i+1,j)+mu(i,j))*H1(i+1,k,j)- &
! (mu(i-1,j)+mu(i,j))*H1(i ,k,j))+ &
! mrdy*0.5*((mu(i,j+1)+mu(i,j))*H2(i,k,j+1)- &
! (mu(i,j-1)+mu(i,j))*H2(i,k,j ))- &
! msfty(i,j)*mu(i,j)*(H1avg(i,k+1,j)-H1avg(i,k,j)+ &
! H2avg(i,k+1,j)-H2avg(i,k,j) &
! )*rdzw(i,k,j) &
! )
! ENDDO
! ENDDO
! ENDDO
!!LPB[25]
!!LPB[26]
! IF ( doing_tke ) THEN
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! tendency(i,k,j)=tmptendf(i,k,j)+2.* &
! (tendency(i,k,j)-tmptendf(i,k,j))
! ENDDO
! ENDDO
! ENDDO
! ENDIF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_H1avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_H2avg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_H1(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_H2(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_tmptendf(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
! Remarked by Ning Pan, 2010-08-10
! a_mrdx =0.0
! a_mrdy =0.0
! a_rcoup =0.0
a_tmpzx =0.0
a_tmpzy =0.0
! a_tmpzeta_z =0.0 ! Remarked by Ning Pan, 2010-08-10
a_rdzu =0.0
a_rdzv =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[26]
! IF( doing_tke ) THEN
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =tendency(i,k,j) -tmptendf(i,k,j)
! Tmpv002 =2.*Tmpv001
! Tmpv003 =tmptendf(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
! ENDDO
! ENDDO
! ENDDO
! ENDIF
IF( doing_tke ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tmptendf(i,k,j) =a_tmptendf(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =2.*a_Tmpv2
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv1
a_tmptendf(i,k,j) =a_tmptendf(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[25]
!LPB[24]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =mrdx
! mrdx =msftx(i,j)*rdx
mrdx =msftx(i,j)*rdx
Tmpv300(i,k) =mrdx
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =mrdy
! mrdy =msfty(i,j)*rdy
mrdy =msfty(i,j)*rdy
Tmpv301(i,k) =mrdy
Tmpv001 =mu(i+1,j) +mu(i,j)
Tmpv302(i,k) =Tmpv001
Tmpv002 =Tmpv302(i,k)*H1(i+1,k,j)
Tmpv003 =mu(i-1,j) +mu(i,j)
Tmpv303(i,k) =Tmpv003
Tmpv004 =Tmpv303(i,k)*H1(i,k,j)
Tmpv005 =Tmpv002 -Tmpv004
Tmpv304(i,k) =Tmpv005
Tmpv006 =mrdx*0.5*Tmpv304(i,k)
Tmpv007 =mu(i,j+1) +mu(i,j)
Tmpv305(i,k) =Tmpv007
Tmpv008 =Tmpv305(i,k)*H2(i,k,j+1)
Tmpv009 =mu(i,j-1) +mu(i,j)
Tmpv306(i,k) =Tmpv009
Tmpv010 =Tmpv306(i,k)*H2(i,k,j)
Tmpv011 =Tmpv008 -Tmpv010
Tmpv307(i,k) =Tmpv011
Tmpv012 =mrdy*0.5*Tmpv307(i,k)
Tmpv013 =Tmpv006 +Tmpv012
Tmpv014 =H1avg(i,k+1,j) -H1avg(i,k,j)
Tmpv015 =Tmpv014 +H2avg(i,k+1,j)
Tmpv016 =Tmpv015 -H2avg(i,k,j)
Tmpv308(i,k) =Tmpv016
Tmpv017 =msfty(i,j)*mu(i,j)*Tmpv308(i,k)
Tmpv309(i,k) =Tmpv017
! Remarked by Ning Pan, 2010-08-10
! Tmpv018 =Tmpv309(i,k)*rdzw(i,k,j)
! Tmpv019 =Tmpv013 -Tmpv018
! Tmpv020 =tendency(i,k,j) -Tmpv019
! tendency(i,k,j) =Tmpv020
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
mrdx =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
mrdy =Tmpv301(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv20 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv20
a_Tmpv19 =-a_Tmpv20
a_Tmpv13 =a_Tmpv19
a_Tmpv18 =-a_Tmpv19
a_Tmpv17 =rdzw(i,k,j)*a_Tmpv18
a_rdzw(i,k,j) =a_rdzw(i,k,j) +Tmpv309(i,k)*a_Tmpv18
a_mu(i,j) =a_mu(i,j) +msfty(i,j)*Tmpv308(i,k)*a_Tmpv17
a_Tmpv16 =msfty(i,j)*mu(i,j)*a_Tmpv17
a_Tmpv15 =a_Tmpv16
a_H2avg(i,k,j) =a_H2avg(i,k,j) -a_Tmpv16
a_Tmpv14 =a_Tmpv15
a_H2avg(i,k+1,j) =a_H2avg(i,k+1,j) +a_Tmpv15
a_H1avg(i,k+1,j) =a_H1avg(i,k+1,j) +a_Tmpv14
a_H1avg(i,k,j) =a_H1avg(i,k,j) -a_Tmpv14
a_Tmpv6 =a_Tmpv13
a_Tmpv12 =a_Tmpv13
a_mrdy =a_mrdy +0.5*Tmpv307(i,k)*a_Tmpv12
a_Tmpv11 =mrdy*0.5*a_Tmpv12
a_Tmpv8 =a_Tmpv11
a_Tmpv10 =-a_Tmpv11
a_Tmpv9 =H2(i,k,j)*a_Tmpv10
a_H2(i,k,j) =a_H2(i,k,j) +Tmpv306(i,k)*a_Tmpv10
a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv9
a_mu(i,j) =a_mu(i,j) +a_Tmpv9
a_Tmpv7 =H2(i,k,j+1)*a_Tmpv8
a_H2(i,k,j+1) =a_H2(i,k,j+1) +Tmpv305(i,k)*a_Tmpv8
a_mu(i,j+1) =a_mu(i,j+1) +a_Tmpv7
a_mu(i,j) =a_mu(i,j) +a_Tmpv7
a_mrdx =a_mrdx +0.5*Tmpv304(i,k)*a_Tmpv6
a_Tmpv5 =mrdx*0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =-a_Tmpv5
a_Tmpv3 =H1(i,k,j)*a_Tmpv4
a_H1(i,k,j) =a_H1(i,k,j) +Tmpv303(i,k)*a_Tmpv4
a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv3
a_mu(i,j) =a_mu(i,j) +a_Tmpv3
a_Tmpv1 =H1(i+1,k,j)*a_Tmpv2
a_H1(i+1,k,j) =a_H1(i+1,k,j) +Tmpv302(i,k)*a_Tmpv2
a_mu(i+1,j) =a_mu(i+1,j) +a_Tmpv1
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
! Remarked by Ning Pan, 2010-08-10
! mrdy =Tmpv301(i,k)
! a_mrdy =0.0
! mrdx =Tmpv300(i,k)
! a_mrdx =0.0
ENDDO
ENDDO
ENDDO
!LPB[23]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! H1avg(i,kts,j) =0.
! H1avg(i,ktf+1,j) =0.
! H2avg(i,kts,j) =0.
! H2avg(i,ktf+1,j) =0.
! ENDDO
DO i =i_end, i_start, -1
a_H2avg(i,ktf+1,j) =0.0
a_H2avg(i,kts,j) =0.0
a_H1avg(i,ktf+1,j) =0.0
a_H1avg(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[22]
DO j =j_end, j_start, -1
! Remarked by Ning Pan, 2010-08-10
! DO k=kts+1, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! H1avg(i,k,j) =Keep_Lpb22_H1avg(i,k,j)
! END DO
! END DO
! DO k=kts+1, min(kte,kde-1)
! DO i=its, min(ite,ide-1)
! H2avg(i,k,j) =Keep_Lpb22_H2avg(i,k,j)
! END DO
! END DO
! tmpzx =Keep_Lpb22_tmpzx(j)
! tmpzy =Keep_Lpb22_tmpzy(j)
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =H1(i+1,k,j) +H1(i,k,j)
Tmpv002 =fnm(k)*Tmpv001
Tmpv003 =H1(i+1,k-1,j) +H1(i,k-1,j)
Tmpv004 =fnp(k)*Tmpv003
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =0.5*Tmpv005
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =H1avg(i,k,j)
! H1avg(i,k,j) =Tmpv006
H1avg(i,k,j) =Tmpv006
Tmpv300(i,k) =H1avg(i,k,j)
Tmpv001 =H2(i,k,j+1) +H2(i,k,j)
Tmpv002 =fnm(k)*Tmpv001
Tmpv003 =H2(i,k-1,j+1) +H2(i,k-1,j)
Tmpv004 =fnp(k)*Tmpv003
Tmpv005 =Tmpv002 +Tmpv004
Tmpv006 =0.5*Tmpv005
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =H2avg(i,k,j)
! H2avg(i,k,j) =Tmpv006
H2avg(i,k,j) =Tmpv006
Tmpv301(i,k) =H2avg(i,k,j)
Tmpv001 =zx(i,k,j) +zx(i+1,k,j)
Tmpv002 =0.5*Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv302(i,k) =tmpzx
! tmpzx =Tmpv002
tmpzx =Tmpv002
Tmpv302(i,k) =tmpzx
Tmpv001 =zy(i,k,j) +zy(i,k,j+1)
Tmpv002 =0.5*Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv303(i,k) =tmpzy
! tmpzy =Tmpv002
tmpzy =Tmpv002
Tmpv303(i,k) =tmpzy
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =H1avg(i,k,j)*tmpzx
! Tmpv304(i,k) =H1avg(i,k,j)
! H1avg(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =H2avg(i,k,j)*tmpzy
! Tmpv305(i,k) =H2avg(i,k,j)
! H2avg(i,k,j) =Tmpv001
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
tmpzy =Tmpv303(i,k) ! Added by Ning Pan, 2010-08-10
! Revised by Ning Pan, 2010-08-10
! H2avg(i,k,j) =Tmpv305(i,k)
H2avg(i,k,j) =Tmpv301(i,k)
a_Tmpv1 =a_H2avg(i,k,j)
a_H2avg(i,k,j) =0.0
a_H2avg(i,k,j) =a_H2avg(i,k,j) +tmpzy*a_Tmpv1
a_tmpzy =a_tmpzy +H2avg(i,k,j)*a_Tmpv1
tmpzx =Tmpv302(i,k) ! Added by Ning Pan, 2010-08-10
! Revised by Ning Pan, 2010-08-10
! H1avg(i,k,j) =Tmpv304(i,k)
H1avg(i,k,j) =Tmpv300(i,k)
a_Tmpv1 =a_H1avg(i,k,j)
a_H1avg(i,k,j) =0.0
a_H1avg(i,k,j) =a_H1avg(i,k,j) +tmpzx*a_Tmpv1
a_tmpzx =a_tmpzx +H1avg(i,k,j)*a_Tmpv1
! tmpzy =Tmpv303(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_tmpzy
a_tmpzy =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
a_zy(i,k,j+1) =a_zy(i,k,j+1) +a_Tmpv1
! tmpzx =Tmpv302(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_tmpzx
a_tmpzx =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
a_zx(i+1,k,j) =a_zx(i+1,k,j) +a_Tmpv1
! H2avg(i,k,j) =Tmpv301(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv6 =a_H2avg(i,k,j)
a_H2avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_H2(i,k-1,j+1) =a_H2(i,k-1,j+1) +a_Tmpv3
a_H2(i,k-1,j) =a_H2(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_H2(i,k,j+1) =a_H2(i,k,j+1) +a_Tmpv1
a_H2(i,k,j) =a_H2(i,k,j) +a_Tmpv1
! H1avg(i,k,j) =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv6 =a_H1avg(i,k,j)
a_H1avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_H1(i+1,k-1,j) =a_H1(i+1,k-1,j) +a_Tmpv3
a_H1(i,k-1,j) =a_H1(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_H1(i+1,k,j) =a_H1(i+1,k,j) +a_Tmpv1
a_H1(i,k,j) =a_H1(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
! Added by Ning Pan, 2010-08-10
DO j = j_start, j_end+1
DO k = kts, ktf+1
DO i = i_start, i_end
H2avg(i,k,j) = Keep_Lpb22_H2avg(i,k,j)
END DO
END DO
END DO
!LPB[21]
DO j =j_end+1, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =zy(i,k,j) +zy(i,k+1,j)
Tmpv002 =0.5*Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =tmpzy
! tmpzy =Tmpv002
tmpzy =Tmpv002
Tmpv300(i,k) =tmpzy
Tmpv001 =1./rdzw(i,k,j) +1./rdzw(i,k,j-1)
Tmpv3010(i,k) =Tmpv001 ! Added by Ning Pan, 2010-08-10
Tmpv002 =2./Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =rdzv
! rdzv =Tmpv002
rdzv =Tmpv002
Tmpv301(i,k) =rdzv
Tmpv001 =var(i,k,j) -var(i,k,j-1)
Tmpv002 =rdy*Tmpv001
Tmpv003 =H2avg(i,k+1,j) -H2avg(i,k,j)
Tmpv302(i,k) =Tmpv003
Tmpv004 =tmpzy*Tmpv302(i,k)
Tmpv303(i,k) =Tmpv004
Tmpv005 =Tmpv303(i,k)*rdzv
Tmpv006 =Tmpv002 -Tmpv005
Tmpv304(i,k) =Tmpv006
! Remarked by Ning Pan, 2010-08-10
! Tmpv007 =-msfvy(i,j)*xkxavg(i,k,j)*Tmpv304(i,k)
! H2(i,k,j) =Tmpv007
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
! Added by Ning Pan, 2010-08-10
xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j))
tmpzy =Tmpv300(i,k)
rdzv =Tmpv301(i,k)
a_Tmpv7 =a_H2(i,k,j)
a_H2(i,k,j) =0.0
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -msfvy(i,j)*Tmpv304(i,k)*a_Tmpv7
a_Tmpv6 =-msfvy(i,j)*xkxavg(i,k,j)*a_Tmpv7
a_Tmpv2 =a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv4 =rdzv*a_Tmpv5
a_rdzv =a_rdzv +Tmpv303(i,k)*a_Tmpv5
a_tmpzy =a_tmpzy +Tmpv302(i,k)*a_Tmpv4
a_Tmpv3 =tmpzy*a_Tmpv4
a_H2avg(i,k+1,j) =a_H2avg(i,k+1,j) +a_Tmpv3
a_H2avg(i,k,j) =a_H2avg(i,k,j) -a_Tmpv3
a_Tmpv1 =rdy*a_Tmpv2
a_var(i,k,j) =a_var(i,k,j) +a_Tmpv1
a_var(i,k,j-1) =a_var(i,k,j-1) -a_Tmpv1
! rdzv =Tmpv301(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_rdzv
a_rdzv =0.0
! Revised by Ning Pan, 2010-08-10
! a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv001*Tmpv001)
a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv3010(i,k)*Tmpv3010(i,k))
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
a_rdzw(i,k,j-1) =a_rdzw(i,k,j-1) -1./(rdzw(i,k,j-1)*rdzw(i,k,j-1))*a_Tmpv1
! tmpzy =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_tmpzy
a_tmpzy =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_zy(i,k,j) =a_zy(i,k,j) +a_Tmpv1
a_zy(i,k+1,j) =a_zy(i,k+1,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[20]
DO j =j_end+1, j_start, -1
! DO i =i_start, i_end
! Tmpv001 =cf1*var(i,1,j) +cf2*var(i,2,j)
! Tmpv002 =Tmpv001 +cf3*var(i,3,j)
! Tmpv003 =Tmpv002 +cf1*var(i,1,j-1)
! Tmpv004 =Tmpv003 +cf2*var(i,2,j-1)
! Tmpv005 =Tmpv004 +cf3*var(i,3,j-1)
! Tmpv006 =0.5*Tmpv005
! H2avg(i,kts,j) =Tmpv006
! Tmpv001 =var(i,ktes1,j) -var(i,ktes2,j)
! Tmpv002 =Tmpv001*0.5
! Tmpv003 =Tmpv002*dnw(ktes1)
! Tmpv004 =Tmpv003/dn(ktes1)
! Tmpv005 =var(i,ktes1,j) +Tmpv004
! Tmpv006 =Tmpv005 +var(i,ktes1,j-1)
! Tmpv007 =var(i,ktes1,j-1) -var(i,ktes2,j-1)
! Tmpv008 =Tmpv007*0.5
! Tmpv009 =Tmpv008*dnw(ktes1)
! Tmpv010 =Tmpv009/dn(ktes1)
! Tmpv011 =Tmpv006 +Tmpv010
! Tmpv012 =0.5*Tmpv011
! H2avg(i,ktf+1,j) =Tmpv012
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv12 =a_H2avg(i,ktf+1,j)
a_H2avg(i,ktf+1,j) =0.0
a_Tmpv11 =0.5*a_Tmpv12
a_Tmpv6 =a_Tmpv11
a_Tmpv10 =a_Tmpv11
a_Tmpv9 =a_Tmpv10/dn(ktes1)
a_Tmpv8 =dnw(ktes1)*a_Tmpv9
a_Tmpv7 =0.5*a_Tmpv8
a_var(i,ktes1,j-1) =a_var(i,ktes1,j-1) +a_Tmpv7
a_var(i,ktes2,j-1) =a_var(i,ktes2,j-1) -a_Tmpv7
a_Tmpv5 =a_Tmpv6
a_var(i,ktes1,j-1) =a_var(i,ktes1,j-1) +a_Tmpv6
a_var(i,ktes1,j) =a_var(i,ktes1,j) +a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =a_Tmpv4/dn(ktes1)
a_Tmpv2 =dnw(ktes1)*a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_var(i,ktes1,j) =a_var(i,ktes1,j) +a_Tmpv1
a_var(i,ktes2,j) =a_var(i,ktes2,j) -a_Tmpv1
a_Tmpv6 =a_H2avg(i,kts,j)
a_H2avg(i,kts,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_var(i,3,j-1) =a_var(i,3,j-1) +cf3*a_Tmpv5
a_Tmpv3 =a_Tmpv4
a_var(i,2,j-1) =a_var(i,2,j-1) +cf2*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_var(i,1,j-1) =a_var(i,1,j-1) +cf1*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_var(i,3,j) =a_var(i,3,j) +cf3*a_Tmpv2
a_var(i,1,j) =a_var(i,1,j) +cf1*a_Tmpv1
a_var(i,2,j) =a_var(i,2,j) +cf2*a_Tmpv1
ENDDO
ENDDO
!LPB[19]
DO j =j_end+1, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =var(i,k,j-1) +var(i,k,j)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =var(i,k-1,j-1) +var(i,k-1,j)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! H2avg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_H2avg(i,k,j)
a_H2avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_var(i,k-1,j-1) =a_var(i,k-1,j-1) +a_Tmpv3
a_var(i,k-1,j) =a_var(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_var(i,k,j-1) =a_var(i,k,j-1) +a_Tmpv1
a_var(i,k,j) =a_var(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[18]
DO j =j_end+1, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =xkhh(i,k,j-1) +xkhh(i,k,j)
! Tmpv002 =0.5*Tmpv001
! xkxavg(i,k,j) =Tmpv002
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv2 =a_xkxavg(i,k,j)
a_xkxavg(i,k,j) =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_xkhh(i,k,j-1) =a_xkhh(i,k,j-1) +a_Tmpv1
a_xkhh(i,k,j) =a_xkhh(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
! Added by Ning Pan, 2010-08-10
DO j = j_start, j_end
DO k = kts, ktf+1
DO i = i_start, i_end+1
H1avg(i,k,j) = Keep_Lpb22_H1avg(i,k,j)
END DO
END DO
END DO
!LPB[17]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end+1
Tmpv001 =zx(i,k,j) +zx(i,k+1,j)
Tmpv002 =0.5*Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =tmpzx
! tmpzx =Tmpv002
tmpzx =Tmpv002
Tmpv300(i,k) =tmpzx
Tmpv001 =1./rdzw(i,k,j) +1./rdzw(i-1,k,j)
Tmpv3010(i,k) =Tmpv001 ! Added by Ning Pan, 2010-08-10
Tmpv002 =2./Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv301(i,k) =rdzu
! rdzu =Tmpv002
rdzu =Tmpv002
Tmpv301(i,k) =rdzu
Tmpv001 =var(i,k,j) -var(i-1,k,j)
Tmpv002 =rdx*Tmpv001
Tmpv003 =H1avg(i,k+1,j) -H1avg(i,k,j)
Tmpv302(i,k) =Tmpv003
Tmpv004 =tmpzx*Tmpv302(i,k)
Tmpv303(i,k) =Tmpv004
Tmpv005 =Tmpv303(i,k)*rdzu
Tmpv006 =Tmpv002 -Tmpv005
Tmpv304(i,k) =Tmpv006
! Remarked by Ning Pan, 2010-08-10
! Tmpv007 =-msfuy(i,j)*xkxavg(i,k,j)*Tmpv304(i,k)
! H1(i,k,j) =Tmpv007
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end+1, i_start, -1
! Added by Ning Pan, 2010-08-10
xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j))
tmpzx =Tmpv300(i,k)
rdzu =Tmpv301(i,k)
a_Tmpv7 =a_H1(i,k,j)
a_H1(i,k,j) =0.0
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -msfuy(i,j)*Tmpv304(i,k)*a_Tmpv7
a_Tmpv6 =-msfuy(i,j)*xkxavg(i,k,j)*a_Tmpv7
a_Tmpv2 =a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv4 =rdzu*a_Tmpv5
a_rdzu =a_rdzu +Tmpv303(i,k)*a_Tmpv5
a_tmpzx =a_tmpzx +Tmpv302(i,k)*a_Tmpv4
a_Tmpv3 =tmpzx*a_Tmpv4
a_H1avg(i,k+1,j) =a_H1avg(i,k+1,j) +a_Tmpv3
a_H1avg(i,k,j) =a_H1avg(i,k,j) -a_Tmpv3
a_Tmpv1 =rdx*a_Tmpv2
a_var(i,k,j) =a_var(i,k,j) +a_Tmpv1
a_var(i-1,k,j) =a_var(i-1,k,j) -a_Tmpv1
! rdzu =Tmpv301(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_rdzu
a_rdzu =0.0
! Revised by Ning Pan, 2010-08-10
! a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv001*Tmpv001)
a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv3010(i,k)*Tmpv3010(i,k))
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
a_rdzw(i-1,k,j) =a_rdzw(i-1,k,j) -1./(rdzw(i-1,k,j)*rdzw(i-1,k,j))*a_Tmpv1
! tmpzx =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_tmpzx
a_tmpzx =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_zx(i,k,j) =a_zx(i,k,j) +a_Tmpv1
a_zx(i,k+1,j) =a_zx(i,k+1,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[16]
DO j =j_end, j_start, -1
! DO i =i_start, i_end+1
! Tmpv001 =cf1*var(i,1,j) +cf2*var(i,2,j)
! Tmpv002 =Tmpv001 +cf3*var(i,3,j)
! Tmpv003 =Tmpv002 +cf1*var(i-1,1,j)
! Tmpv004 =Tmpv003 +cf2*var(i-1,2,j)
! Tmpv005 =Tmpv004 +cf3*var(i-1,3,j)
! Tmpv006 =0.5*Tmpv005
! H1avg(i,kts,j) =Tmpv006
! Tmpv001 =var(i,ktes1,j) -var(i,ktes2,j)
! Tmpv002 =Tmpv001*0.5
! Tmpv003 =Tmpv002*dnw(ktes1)
! Tmpv004 =Tmpv003/dn(ktes1)
! Tmpv005 =var(i,ktes1,j) +Tmpv004
! Tmpv006 =Tmpv005 +var(i-1,ktes1,j)
! Tmpv007 =var(i-1,ktes1,j) -var(i-1,ktes2,j)
! Tmpv008 =Tmpv007*0.5
! Tmpv009 =Tmpv008*dnw(ktes1)
! Tmpv010 =Tmpv009/dn(ktes1)
! Tmpv011 =Tmpv006 +Tmpv010
! Tmpv012 =0.5*Tmpv011
! H1avg(i,ktf+1,j) =Tmpv012
! ENDDO
DO i =i_end+1, i_start, -1
a_Tmpv12 =a_H1avg(i,ktf+1,j)
a_H1avg(i,ktf+1,j) =0.0
a_Tmpv11 =0.5*a_Tmpv12
a_Tmpv6 =a_Tmpv11
a_Tmpv10 =a_Tmpv11
a_Tmpv9 =a_Tmpv10/dn(ktes1)
a_Tmpv8 =dnw(ktes1)*a_Tmpv9
a_Tmpv7 =0.5*a_Tmpv8
a_var(i-1,ktes1,j) =a_var(i-1,ktes1,j) +a_Tmpv7
a_var(i-1,ktes2,j) =a_var(i-1,ktes2,j) -a_Tmpv7
a_Tmpv5 =a_Tmpv6
a_var(i-1,ktes1,j) =a_var(i-1,ktes1,j) +a_Tmpv6
a_var(i,ktes1,j) =a_var(i,ktes1,j) +a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =a_Tmpv4/dn(ktes1)
a_Tmpv2 =dnw(ktes1)*a_Tmpv3
a_Tmpv1 =0.5*a_Tmpv2
a_var(i,ktes1,j) =a_var(i,ktes1,j) +a_Tmpv1
a_var(i,ktes2,j) =a_var(i,ktes2,j) -a_Tmpv1
a_Tmpv6 =a_H1avg(i,kts,j)
a_H1avg(i,kts,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv4 =a_Tmpv5
a_var(i-1,3,j) =a_var(i-1,3,j) +cf3*a_Tmpv5
a_Tmpv3 =a_Tmpv4
a_var(i-1,2,j) =a_var(i-1,2,j) +cf2*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_var(i-1,1,j) =a_var(i-1,1,j) +cf1*a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_var(i,3,j) =a_var(i,3,j) +cf3*a_Tmpv2
a_var(i,1,j) =a_var(i,1,j) +cf1*a_Tmpv1
a_var(i,2,j) =a_var(i,2,j) +cf2*a_Tmpv1
ENDDO
ENDDO
!LPB[15]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end+1
! Tmpv001 =var(i-1,k,j) +var(i,k,j)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =var(i-1,k-1,j) +var(i,k-1,j)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! H1avg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end+1, i_start, -1
a_Tmpv6 =a_H1avg(i,k,j)
a_H1avg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_var(i-1,k-1,j) =a_var(i-1,k-1,j) +a_Tmpv3
a_var(i,k-1,j) =a_var(i,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_var(i-1,k,j) =a_var(i-1,k,j) +a_Tmpv1
a_var(i,k,j) =a_var(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[14]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end+1
! Tmpv001 =xkhh(i-1,k,j) +xkhh(i,k,j)
! Tmpv002 =0.5*Tmpv001
! xkxavg(i,k,j) =Tmpv002
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end+1, i_start, -1
a_Tmpv2 =a_xkxavg(i,k,j)
a_xkxavg(i,k,j) =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_xkhh(i-1,k,j) =a_xkhh(i-1,k,j) +a_Tmpv1
a_xkhh(i,k,j) =a_xkhh(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[13]
! IF( doing_tke ) THEN
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! tmptendf(i,k,j) =tendency(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ENDIF
IF( doing_tke ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_tendency(i,k,j) =a_tendency(i,k,j) +a_tmptendf(i,k,j)
a_tmptendf(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[12]
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! ktes1 =kte-1
! ktes2 =kte-2
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_horizontal_diffusion_s
SUBROUTINE a_vertical_diffusion_2(ru_tendf,a_ru_tendf,rv_tendf,a_rv_tendf, &
rw_tendf,a_rw_tendf,rt_tendf,a_rt_tendf,tke_tendf,a_tke_tendf,moist_tendf, &
! Revised by Ning Pan, 2010-08-10
! a_moist_tendf,n_moist,chem_tendf,a_chem_tendf,n_chem,scalar_tendf,a_scalar_tend &
! f,n_scalar,tracer_tendf,a_tracer_tendf,n_tracer,u_2,a_u_2,v_2,a_v_2,thp, &
a_moist_tendf,n_moist,chem_tendf,a_chem_tendf,n_chem,scalar_tendf,a_scalar_tend&
&f,n_scalar,tracer_tendf,a_tracer_tendf,n_tracer,u_2,a_u_2,v_2,a_v_2,thp, &
a_thp,u_base,v_base,t_base,qv_base,mu,a_mu,tke,a_tke,config_flags,defor13, &
a_defor13,defor23,a_defor23,defor33,a_defor33,nba_mij,a_nba_mij,n_nba_mij, &
div,a_div,moist,a_moist,chem,a_chem,scalar,a_scalar,tracer,a_tracer,xkmv, &
a_xkmv,xkhv,a_xkhv,km_opt,fnm,fnp,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,hfx,a_hfx, &
qfx,a_qfx,ust,a_ust,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: n_moist,n_chem,n_scalar,n_tracer,km_opt
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
REAL,DIMENSION(kms:kme) :: qv_base
REAL,DIMENSION(kms:kme) :: u_base
REAL,DIMENSION(kms:kme) :: v_base
REAL,DIMENSION(kms:kme) :: t_base
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tendf,a_ru_tendf,rv_tendf, &
a_rv_tendf,rw_tendf,a_rw_tendf,tke_tendf,a_tke_tendf,rt_tendf,a_rt_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist_tendf,a_moist_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem_tendf,a_chem_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar_tendf,a_scalar_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer_tendf,a_tracer_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist) :: moist,a_moist
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem) :: chem,a_chem
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar) :: scalar,a_scalar
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer) :: tracer,a_tracer
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,a_defor13,defor23,a_defor23, &
defor33,a_defor33,div,a_div,xkmv,a_xkmv,xkhv,a_xkhv,tke,a_tke,rdz,a_rdz, &
u_2,a_u_2,v_2,a_v_2,rdzw,a_rdzw
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho,a_rho
REAL,DIMENSION(ims:ime,jms:jme) :: hfx,a_hfx,qfx,a_qfx
REAL,DIMENSION(ims:ime,jms:jme) :: ust,a_ust
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: thp,a_thp
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var_mix,a_var_mix
INTEGER :: im,i,j,k
INTEGER :: i_start,i_end,j_start,j_end
REAL :: V0_u,a_V0_u,V0_v,a_V0_v,tao_xz,a_tao_xz,tao_yz,a_tao_yz,ustar, &
a_ustar,cd0,a_cd0
REAL :: xsfc,a_xsfc,psi1,a_psi1,vk2,a_vk2,zrough,a_zrough,lnz,a_lnz
REAL :: heat_flux,a_heat_flux,moist_flux,a_moist_flux,heat_flux0,a_heat_flux0
REAL :: cpm,a_cpm
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
! Remarked by Ning Pan, 2010-08-11
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_ru_tendf
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb0_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb1_nba_mij
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_rv_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb0_rw_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb4_rt_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,ims:ime,kms:kme,jms:jme) :: Keep_Lpb7_tke_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb9_var_mix
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_moist,ims:ime,kms:kme,jms:jme,n_moist) &
! :: Keep_Lpb9_moist_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem,ims:ime,kms:kme,jms:jme,n_chem) &
! :: Keep_Lpb11_chem_tendf
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_tracer,ims:ime,kms:kme,jms:jme,n_tracer) &
! :: Keep_Lpb13_tracer_tendf
!! REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_scalar,ims:ime,kms:kme,jms:jme,n_scalar) &
!! :: Keep_Lpb15_scalar_tendf
INTEGER :: IX1,IX2,IX3,IX4
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
REAL :: Tmpv_1
REAL,DIMENSION(PARAM_FIRST_SCALAR:max0(n_moist,n_chem,n_tracer,n_scalar)) :: Tmpv200
REAL,DIMENSION(its:max0(ite,min(ite,ide-1)),jts:min(jte,jde-1)) :: Tmpv300
REAL,DIMENSION(its:max0(ite,min(ite,ide-1)),jts:min(jte,jde-1)) :: Tmpv301
REAL,DIMENSION(its:max0(ite,min(ite,ide-1)),jts:min(jte,jde-1)) :: Tmpv302
REAL,DIMENSION(its:max0(ite,min(ite,ide-1)),jts:min(jte,jde-1)) :: Tmpv303
REAL,DIMENSION(its:max0(ite,min(ite,ide-1)),jts:min(jte,jde-1)) :: Tmpv304
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv305
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv306
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv307
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv308
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv309
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3010
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3011
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3012
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3013
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3014
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3015
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3016
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3017
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3018
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3019
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3020
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3021
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3022
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3023
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3024
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3025
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3026
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3027
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3028
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3029
REAL,DIMENSION(its:ite,jts:min(jte,jde-1)) :: Tmpv3030
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3031
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3032
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3033
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3034
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3035
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3036
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3037
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3038
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3039
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3040
REAL,DIMENSION(its:min(ite,ide-1),jts:jte) :: Tmpv3041
REAL,DIMENSION(min0(jms,its):max0(jme,min(ite,ide-1)),min0(kms,jts):max0(kme,min(jte, &
jde-1)),min0(ims,PARAM_FIRST_SCALAR):max0(ime,n_moist)) :: Tmpv400
REAL,DIMENSION(min0(jms,its):max0(jme,min(ite,ide-1)),min0(kms,jts):max0(kme,min(jte, &
jde-1)),min0(ims,PARAM_FIRST_SCALAR):max0(ime,n_moist)) :: Tmpv401
REAL,DIMENSION(min0(jms,its):max0(jme,min(ite,ide-1)),min0(kms,jts):max0(kme,min(jte, &
jde-1)),min0(ims,PARAM_FIRST_SCALAR):max0(ime,n_moist)) :: Tmpv402
REAL,DIMENSION(its:min(ite,ide-1),jts:min(jte,jde-1),PARAM_FIRST_SCALAR:n_moist) :: Tmpv403
REAL,DIMENSION(min0(1,its):max0(n_nba_mij,min(ite, ide-1)),min0(jms,kts) &
:max0(jme,kte-1),min0(kms,jts):max0(kme,min(jte, jde-1)),min0(ims,PARAM_FIRST_SCALAR) &
:max0(ime,n_moist)) :: Tmpv500
REAL,DIMENSION(min0(1,its):max0(n_nba_mij,min(ite, ide-1)),min0(jms,kts) &
:max0(jme,kte-1),min0(kms,jts):max0(kme,min(jte, jde-1)),min0(ims,PARAM_FIRST_SCALAR) &
:max0(ime,n_moist)) :: Tmpv501
REAL,DIMENSION(n_nba_mij,jms:jme,kms:kme,ims:ime) :: Tmpv502
REAL :: g_Sqrt
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_ru_tendf(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_rv_tendf(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb0_rw_tendf(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!! Remarked by Ning Pan, 2010-08-10: r3997-r4319
! CALL vertical_diffusion_u_2( ru_tendf, config_flags, mu, &
! defor13, xkmv, &
! nba_mij, n_nba_mij, &
! dnw, rdzw, fnm, fnp, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! CALL vertical_diffusion_v_2( rv_tendf, config_flags, mu, &
! defor23, xkmv, &
! nba_mij, n_nba_mij, &
! dnw, rdzw, fnm, fnp, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! CALL vertical_diffusion_w_2( rw_tendf, config_flags, mu, &
! defor33, tke(ims,kms,jms), &
! nba_mij, n_nba_mij, &
! div, xkmv, &
! dn, rdz, &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
!LPB[1]
! vflux: SELECT CASE( config_flags%isfflx )
! CASE (0)
! cd0 = config_flags%tke_drag_coefficient
! DO j = j_start, j_end
! DO i = i_start, ite
! V0_u=0.
! tao_xz=0.
! V0_u= sqrt((u_2(i,kts,j)**2) + &
! (((v_2(i ,kts,j )+ &
! v_2(i ,kts,j+1)+ &
! v_2(i-1,kts,j )+ &
! v_2(i-1,kts,j+1))/4)**2))+epsilon
! tao_xz=cd0*V0_u*u_2(i,kts,j)
! ru_tendf(i,kts,j)=ru_tendf(i,kts,j) &
! -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j))
! ENDDO
! ENDDO
! DO j = j_start, jte
! DO i = i_start, i_end
! V0_v=0.
! tao_yz=0.
! V0_v= sqrt((v_2(i,kts,j)**2) + &
! (((u_2(i ,kts,j )+ &
! u_2(i ,kts,j-1)+ &
! u_2(i+1,kts,j )+ &
! u_2(i+1,kts,j-1))/4)**2))+epsilon
! tao_yz=cd0*V0_v*v_2(i,kts,j)
! rv_tendf(i,kts,j)=rv_tendf(i,kts,j) &
! -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1))
! ENDDO
! ENDDO
! CASE (1,2)
! DO j = j_start, j_end
! DO i = i_start, ite
! V0_u=0.
! tao_xz=0.
! V0_u= sqrt((u_2(i,kts,j)**2) + &
! (((v_2(i ,kts,j )+ &
! v_2(i ,kts,j+1)+ &
! v_2(i-1,kts,j )+ &
! v_2(i-1,kts,j+1))/4)**2))+epsilon
! ustar=0.5*(ust(i,j)+ust(i-1,j))
! tao_xz=ustar*ustar*u_2(i,kts,j)/V0_u
! ru_tendf(i,kts,j)=ru_tendf(i,kts,j) &
! -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j))
! ENDDO
! ENDDO
! DO j = j_start, jte
! DO i = i_start, i_end
! V0_v=0.
! tao_yz=0.
! V0_v= sqrt((v_2(i,kts,j)**2) + &
! (((u_2(i ,kts,j )+ &
! u_2(i ,kts,j-1)+ &
! u_2(i+1,kts,j )+ &
! u_2(i+1,kts,j-1))/4)**2))+epsilon
! ustar=0.5*(ust(i,j)+ust(i,j-1))
! tao_yz=ustar*ustar*v_2(i,kts,j)/V0_v
! rv_tendf(i,kts,j)=rv_tendf(i,kts,j) &
! -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1))
! ENDDO
! ENDDO
! CASE DEFAULT
! CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
! END SELECT vflux
!LPB[2]
!LPB[3]
! IF ( config_flags%mix_full_fields ) THEN
! DO j=jts,min(jte,jde-1)
! DO k=kts,kte-1
! DO i=its,min(ite,ide-1)
! var_mix(i,k,j) = thp(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ELSE
! DO j=jts,min(jte,jde-1)
! DO k=kts,kte-1
! DO i=its,min(ite,ide-1)
! var_mix(i,k,j) = thp(i,k,j) - t_base(k)
! ENDDO
! ENDDO
! ENDDO
! END IF
!LPB[4]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb4_rt_tendf(IX1,IX2,IX3) =rt_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL vertical_diffusion_s( rt_tendf, config_flags, var_mix, mu, xkhv, &
! dn, dnw, rdz, rdzw, fnm, fnp, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
!LPB[5]
! hflux: SELECT CASE( config_flags%isfflx )
! CASE (0,2)
! heat_flux = config_flags%tke_heat_flux
! DO j = j_start, j_end
! DO i = i_start, i_end
! cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
! hfx(i,j)=heat_flux*cp*rho(i,1,j) ! provided for output only
! rt_tendf(i,kts,j)=rt_tendf(i,kts,j) &
! +mu(i,j)*heat_flux*rdzw(i,kts,j)
! ENDDO
! ENDDO
! CASE (1)
! DO j = j_start, j_end
! DO i = i_start, i_end
! cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
! heat_flux = hfx(i,j)/cpm/rho(i,1,j)
! rt_tendf(i,kts,j)=rt_tendf(i,kts,j) &
! +mu(i,j)*heat_flux*rdzw(i,kts,j)
! ENDDO
! ENDDO
! CASE DEFAULT
! CALL wrf_error_fatal( 'isfflx value invalid for iff_opt=2' )
! END SELECT hflux
!LPB[6]
!LPB[7]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb7_tke_tendf(IX1,IX2,IX3) =tke_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! If (km_opt .eq. 2) then
! CALL vertical_diffusion_s( tke_tendf(ims,kms,jms), &
! config_flags, tke(ims,kms,jms), &
! mu, xkhv, &
! dn, dnw, rdz, rdzw, fnm, fnp, &
! .true., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! endif
!LPB[8]
!LPB[9]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb9_var_mix(IX1,IX2,IX3) =var_mix(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_moist
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb9_moist_tendf(IX1,IX2,IX3,IX4) =moist_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX4=1,n_moist
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb9_moist_tendf(IX1,IX2,IX3,IX4) =moist_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN
! moist_loop: do im = PARAM_FIRST_SCALAR, n_moist
! IF ( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
! DO j=jts,min(jte,jde-1)
! DO k=kts,kte-1
! DO i=its,min(ite,ide-1)
! var_mix(i,k,j) = moist(i,k,j,im) - qv_base(k)
! ENDDO
! ENDDO
! ENDDO
! ELSE
! DO j=jts,min(jte,jde-1)
! DO k=kts,kte-1
! DO i=its,min(ite,ide-1)
! var_mix(i,k,j) = moist(i,k,j,im)
! ENDDO
! ENDDO
! ENDDO
! END IF
! CALL vertical_diffusion_s( moist_tendf(ims,kms,jms,im), &
! config_flags, var_mix, &
! mu, xkhv, &
! dn, dnw, rdz, rdzw, fnm, fnp, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! qflux: SELECT CASE( config_flags%isfflx )
! CASE (0)
! CASE (1,2)
! IF ( im == P_QV ) THEN
! DO j = j_start, j_end
! DO i = i_start, i_end
! moist_flux = qfx(i,j)/rho(i,1,j)/(1.+moist(i,kts,j,P_QV))
! moist_tendf(i,kts,j,im)=moist_tendf(i,kts,j,im) &
! +mu(i,j)*moist_flux*rdzw(i,kts,j)
! ENDDO
! ENDDO
! ENDIF
! CASE DEFAULT
! CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
! END SELECT qflux
! ENDDO moist_loop
! ENDIF
!LPB[10]
!LPB[11]
! DO IX4=1,n_chem
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb11_chem_tendf(IX1,IX2,IX3,IX4) =chem_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN
! chem_loop: do im = PARAM_FIRST_SCALAR, n_chem
! CALL vertical_diffusion_s( chem_tendf(ims,kms,jms,im), &
! config_flags, chem(ims,kms,jms,im), &
! mu, xkhv, &
! dn, dnw, rdz, rdzw, fnm, fnp, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO chem_loop
! ENDIF
!LPB[12]
!LPB[13]
! DO IX4=1,n_tracer
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Keep_Lpb13_tracer_tendf(IX1,IX2,IX3,IX4) =tracer_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN
! tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer
! CALL vertical_diffusion_s( tracer_tendf(ims,kms,jms,im), &
! config_flags, tracer(ims,kms,jms,im), &
! mu, xkhv, &
! dn, dnw, rdz, rdzw, fnm, fnp, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO tracer_loop
! ENDIF
!LPB[14]
!!LPB[15]
!! DO IX4=1,n_scalar
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb15_scalar_tendf(IX1,IX2,IX3,IX4) =scalar_tendf(IX1,IX2,IX3,IX4)
!! END DO
!! END DO
!! END DO
!! END DO
!
! IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN
! scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar
! CALL vertical_diffusion_s( scalar_tendf(ims,kms,jms,im), &
! config_flags, scalar(ims,kms,jms,im), &
! mu, xkhv, &
! dn, dnw, rdz, rdzw, fnm, fnp, &
! .false., &
! ids, ide, jds, jde, kds, kde, &
! ims, ime, jms, jme, kms, kme, &
! its, ite, jts, jte, kts, kte )
! ENDDO scalar_loop
! ENDIF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jms, jme
Do K1_ADJ =kms, kme
Do K0_ADJ =ims, ime
a_var_mix(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
a_V0_u =0.0
a_V0_v =0.0
a_tao_xz =0.0
a_tao_yz =0.0
a_ustar =0.0
! Remarked by Ning Pan, 2010-08-11
! a_cd0 =0.0
! a_xsfc =0.0
! a_psi1 =0.0
! a_vk2 =0.0
! a_zrough =0.0
! a_lnz =0.0
a_heat_flux =0.0
a_moist_flux =0.0
! a_heat_flux0 =0.0 ! Remarked by Ning Pan, 2010-08-11
a_cpm =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[15]
! DO IX4=1,n_scalar
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! scalar_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb15_scalar_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
! DO im =PARAM_FIRST_SCALAR, n_scalar
! Tmpv200(im) =scalar_tendf(ims,kms,jms,im)
! CALL vertical_diffusion_s(scalar_tendf(ims,kms,jms,im),config_flags,scalar(ims, &
! kms,jms,im),mu,xkhv,dn,dnw,rdz,rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
! jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_scalar .ge. PARAM_FIRST_SCALAR) THEN
DO im =n_scalar, PARAM_FIRST_SCALAR, -1
! scalar_tendf(ims,kms,jms,im) =Tmpv200(im) ! Remarked by Ning Pan, 2010-08-11
CALL a_vertical_diffusion_s(scalar_tendf(ims,kms,jms,im),a_scalar_tendf(ims, &
kms,jms,im),config_flags,scalar(ims,kms,jms,im),a_scalar(ims,kms,jms,im) &
! Revised by Ning Pan, 2010-08-10
! ,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,,ids,ide,jds,jde, &
,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,rho,a_rho,.false.,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[14]
!LPB[13]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_tracer
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tracer_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb13_tracer_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
! DO im =PARAM_FIRST_SCALAR, n_tracer
! Tmpv200(im) =tracer_tendf(ims,kms,jms,im)
! CALL vertical_diffusion_s(tracer_tendf(ims,kms,jms,im),config_flags,tracer(ims, &
! kms,jms,im),mu,xkhv,dn,dnw,rdz,rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
! jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_tracer .ge. PARAM_FIRST_SCALAR) THEN
DO im =n_tracer, PARAM_FIRST_SCALAR, -1
! tracer_tendf(ims,kms,jms,im) =Tmpv200(im) ! Remarked by Ning Pan, 2010-08-11
CALL a_vertical_diffusion_s(tracer_tendf(ims,kms,jms,im),a_tracer_tendf(ims, &
kms,jms,im),config_flags,tracer(ims,kms,jms,im),a_tracer(ims,kms,jms,im) &
! Revised by Ning Pan, 2010-08-10
! ,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,,ids,ide,jds,jde, &
,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,rho,a_rho,.false.,ids,ide,jds,jde, &
kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[12]
!LPB[11]
! Remarked by Ning Pan, 2010-08-10
! DO IX4=1,n_chem
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! chem_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb11_chem_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
! DO im =PARAM_FIRST_SCALAR, n_chem
! Tmpv200(im) =chem_tendf(ims,kms,jms,im)
! CALL vertical_diffusion_s(chem_tendf(ims,kms,jms,im),config_flags,chem(ims,kms, &
! jms,im),mu,xkhv,dn,dnw,rdz,rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
! jme,kms,kme,its,ite,jts,jte,kts,kte)
! ENDDO
! ENDIF
IF(n_chem .ge. PARAM_FIRST_SCALAR) THEN
DO im =n_chem, PARAM_FIRST_SCALAR, -1
! chem_tendf(ims,kms,jms,im) =Tmpv200(im) ! Remarked by Ning Pan, 2010-08-11
CALL a_vertical_diffusion_s(chem_tendf(ims,kms,jms,im),a_chem_tendf(ims,kms, &
jms,im),config_flags,chem(ims,kms,jms,im),a_chem(ims,kms,jms,im),mu,a_mu,xkhv, &
! Revised by Ning Pan, 2010-08-10
! a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,,ids,ide,jds,jde,kds,kde,ims,ime, &
a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
ENDDO
ENDIF
!LPB[10]
!LPB[9]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! var_mix(IX1,IX2,IX3) =Keep_Lpb9_var_mix(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_moist
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! moist_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb9_moist_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX4=1,n_moist
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! moist_tendf(IX1,IX2,IX3,IX4) =Keep_Lpb9_moist_tendf(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
DO im =PARAM_FIRST_SCALAR, n_moist
IF( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
DO j =jts, min(jte, jde-1)
DO k =kts, kte-1
DO i =its, min(ite, ide-1)
! Tmpv500(i,k,j,im) =var_mix(i,k,j) ! Remarked by Ning Pan, 2010-08-11
var_mix(i,k,j) =moist(i,k,j,im) -qv_base(k)
ENDDO
ENDDO
ENDDO
ELSE
DO j =jts, min(jte, jde-1)
DO k =kts, kte-1
DO i =its, min(ite, ide-1)
! Tmpv501(i,k,j,im) =var_mix(i,k,j) ! Remarked by Ning Pan, 2010-08-11
var_mix(i,k,j) =moist(i,k,j,im)
ENDDO
ENDDO
ENDDO
END IF
! Remarked by Ning Pan, 2010-08-10
! Tmpv200(im) =moist_tendf(ims,kms,jms,im)
! CALL vertical_diffusion_s(moist_tendf(ims,kms,jms,im),config_flags,var_mix,mu, &
! xkhv,dn,dnw,rdz,rdzw,fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
! its,ite,jts,jte,kts,kte)
SELECT CASE (config_flags%isfflx)
CASE(0)
CASE(1,2)
IF( im == P_QV ) THEN
DO j =j_start, j_end
DO i =i_start, i_end
Tmpv001 =qfx(i,j)/rho(i,1,j)
Tmpv400(i,j,im) =Tmpv001
Tmpv002 =Tmpv400(i,j,im)/(1. +moist(i,kts,j,P_QV))
! Revised by Ning Pan, 2010-08-11
! Tmpv401(i,j,im) =moist_flux
! moist_flux =Tmpv002
moist_flux =Tmpv002
Tmpv401(i,j,im) =moist_flux
Tmpv001 =mu(i,j)*moist_flux
Tmpv402(i,j,im) =Tmpv001
! Remarked by Ning Pan, 2010-08-11
! Tmpv002 =Tmpv402(i,j,im)*rdzw(i,kts,j)
! Tmpv003 =moist_tendf(i,kts,j,im) +Tmpv002
! Tmpv403(i,j,im) =moist_tendf(i,kts,j,im)
! moist_tendf(i,kts,j,im) =Tmpv003
ENDDO
ENDDO
ENDIF
CASE DEFAULT
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-10
! END SELECT qflux
END SELECT
ENDDO
ENDIF
IF(n_moist .ge. PARAM_FIRST_SCALAR) THEN
DO im =n_moist, PARAM_FIRST_SCALAR, -1
SELECT CASE (config_flags%isfflx)
CASE(0)
CASE(1,2)
IF( im == P_QV ) THEN
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
! moist_tendf(i,kts,j,im) =Tmpv403(i,j,im) ! Remarked by Ning Pan, 2010-08-11
! Added by Ning Pan, 2010-08-11
moist_flux =Tmpv401(i,j,im)
a_Tmpv3 =a_moist_tendf(i,kts,j,im)
a_moist_tendf(i,kts,j,im) =0.0
a_moist_tendf(i,kts,j,im) =a_moist_tendf(i,kts,j,im) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =rdzw(i,kts,j)*a_Tmpv2
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +Tmpv402(i,j,im)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +moist_flux*a_Tmpv1
a_moist_flux =a_moist_flux +mu(i,j)*a_Tmpv1
! moist_flux =Tmpv401(i,j,im) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv2 =a_moist_flux
a_moist_flux =0.0
a_Tmpv1 =a_Tmpv2/(1. +moist(i,kts,j,P_QV))
a_moist(i,kts,j,P_QV) =a_moist(i,kts,j,P_QV) -Tmpv400(i,j,im)/((1. +moist(i, &
kts,j,P_QV))*(1. +moist(i,kts,j,P_QV)))*a_Tmpv2
a_qfx(i,j) =a_qfx(i,j) +a_Tmpv1/rho(i,1,j)
a_rho(i,1,j) =a_rho(i,1,j) -qfx(i,j)/(rho(i,1,j)*rho(i,1,j))*a_Tmpv1
ENDDO
ENDDO
ENDIF
CASE DEFAULT
! Revised by Ning Pan, 2010-08-10
! CALL a_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-10
! END SELECT qflux
END SELECT
! moist_tendf(ims,kms,jms,im) =Tmpv200(im) ! Remarked by Ning Pan, 2010-08-11
CALL a_vertical_diffusion_s(moist_tendf(ims,kms,jms,im),a_moist_tendf(ims,kms, &
jms,im),config_flags,var_mix,a_var_mix,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz, &
! Revised by Ning Pan, 2010-08-10
! rdzw,a_rdzw,fnm,fnp,,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
rdzw,a_rdzw,fnm,fnp,rho,a_rho,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
jte,kts,kte)
IF( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
DO j =min(jte, jde-1), jts, -1
DO k =kte-1, kts, -1
DO i =min(ite, ide-1), its, -1
! var_mix(i,k,j) =Tmpv500(i,k,j,im) ! Remarked by Ning Pan, 2010-08-11
a_moist(i,k,j,im) =a_moist(i,k,j,im) +a_var_mix(i,k,j)
a_var_mix(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j =min(jte, jde-1), jts, -1
DO k =kte-1, kts, -1
DO i =min(ite, ide-1), its, -1
! var_mix(i,k,j) =Tmpv501(i,k,j,im) ! Remarked by Ning Pan, 2010-08-11
a_moist(i,k,j,im) =a_moist(i,k,j,im) +a_var_mix(i,k,j)
a_var_mix(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
END IF
ENDDO
ENDIF
!LPB[8]
!LPB[7]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! tke_tendf(IX1,IX2,IX3) =Keep_Lpb7_tke_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! IF(km_opt .eq. 2) THEN
! Tmpv_1 =tke_tendf(ims,kms,jms)
! CALL vertical_diffusion_s(tke_tendf(ims,kms,jms),config_flags,tke(ims,kms,jms) &
! ,mu,xkhv,dn,dnw,rdz,rdzw,fnm,fnp,.true.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
! kme,its,ite,jts,jte,kts,kte)
! endif
IF(km_opt .eq. 2) THEN
! tke_tendf(ims,kms,jms) =Tmpv_1 ! Remarked by Ning Pan, 2010-08-11
CALL a_vertical_diffusion_s(tke_tendf(ims,kms,jms),a_tke_tendf(ims,kms,jms) &
,config_flags,tke(ims,kms,jms),a_tke(ims,kms,jms),mu,a_mu,xkhv,a_xkhv,dn,dnw, &
! Revised by Ning Pan, 2010-08-10
! rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,rho,a_rho,.true.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
endif
!LPB[6]
!LPB[5]
SELECT CASE (config_flags%isfflx)
CASE(0,2)
heat_flux =config_flags%tke_heat_flux
DO j =j_start, j_end
DO i =i_start, i_end
Tmpv001 =mu(i,j)*heat_flux
Tmpv300(i,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-11
! Tmpv002 =Tmpv300(i,j)*rdzw(i,kts,j)
! Tmpv003 =rt_tendf(i,kts,j) +Tmpv002
! rt_tendf(i,kts,j) =Tmpv003
ENDDO
ENDDO
CASE(1)
DO j =j_start, j_end
DO i =i_start, i_end
! Revised by Ning Pan, 2010-08-11
! Tmpv301(i,j) =cpm
! cpm =cp*(1. +0.8*moist(i,kts,j,P_QV))
cpm =cp*(1. +0.8*moist(i,kts,j,P_QV))
Tmpv301(i,j) =cpm
Tmpv001 =hfx(i,j)/cpm
Tmpv302(i,j) =Tmpv001
Tmpv002 =Tmpv302(i,j)/rho(i,1,j)
! Revised by Ning Pan, 2010-08-11
! Tmpv303(i,j) =heat_flux
! heat_flux =Tmpv002
heat_flux =Tmpv002
Tmpv303(i,j) =heat_flux
Tmpv001 =mu(i,j)*heat_flux
Tmpv304(i,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-11
! Tmpv002 =Tmpv304(i,j)*rdzw(i,kts,j)
! Tmpv003 =rt_tendf(i,kts,j) +Tmpv002
! rt_tendf(i,kts,j) =Tmpv003
ENDDO
ENDDO
CASE DEFAULT
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-10
! END SELECT hflux
END SELECT
SELECT CASE (config_flags%isfflx)
CASE(0,2)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_rt_tendf(i,kts,j)
a_rt_tendf(i,kts,j) =0.0
a_rt_tendf(i,kts,j) =a_rt_tendf(i,kts,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =rdzw(i,kts,j)*a_Tmpv2
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +Tmpv300(i,j)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +heat_flux*a_Tmpv1
! a_heat_flux =a_heat_flux +mu(i,j)*a_Tmpv1 ! Remarked by Ning Pan, 2010-08-11
ENDDO
ENDDO
! Remarked by Ning Pan, 2010-08-10
! a_config_flags%tke_heat_flux =a_config_flags%tke_heat_flux +a_heat_flux
a_heat_flux =0.0
CASE(1)
DO j =j_end, j_start, -1
DO i =i_end, i_start, -1
heat_flux =Tmpv303(i,j) ! Added by Ning Pan, 2010-08-11
a_Tmpv3 =a_rt_tendf(i,kts,j)
a_rt_tendf(i,kts,j) =0.0
a_rt_tendf(i,kts,j) =a_rt_tendf(i,kts,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =rdzw(i,kts,j)*a_Tmpv2
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +Tmpv304(i,j)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +heat_flux*a_Tmpv1
a_heat_flux =a_heat_flux +mu(i,j)*a_Tmpv1
! heat_flux =Tmpv303(i,j) ! Remarked by Ning Pan, 2010-08-11
cpm =Tmpv301(i,j) ! Added by Ning Pan, 2010-08-11
a_Tmpv2 =a_heat_flux
a_heat_flux =0.0
a_Tmpv1 =a_Tmpv2/rho(i,1,j)
a_rho(i,1,j) =a_rho(i,1,j) -Tmpv302(i,j)/(rho(i,1,j)*rho(i,1,j))*a_Tmpv2
a_hfx(i,j) =a_hfx(i,j) +a_Tmpv1/cpm
a_cpm =a_cpm -hfx(i,j)/(cpm*cpm)*a_Tmpv1
! cpm =Tmpv301(i,j) ! Remarked by Ning Pan, 2010-08-11
a_moist(i,kts,j,P_QV) =a_moist(i,kts,j,P_QV) +cp*0.8*a_cpm
a_cpm =0.0
ENDDO
ENDDO
CASE DEFAULT
! Revised by Ning Pan, 2010-08-10
! CALL a_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-10
! END SELECT hflux
END SELECT
!LPB[4]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rt_tendf(IX1,IX2,IX3) =Keep_Lpb4_rt_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv400(IX1,IX2,IX3) =rt_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! CALL vertical_diffusion_s(rt_tendf,config_flags,var_mix,mu,xkhv,dn,dnw,rdz,rdzw, &
! fnm,fnp,.false.,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rt_tendf(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Added by Ning Pan, 2010-08-11
var_mix = 0.0
IF( config_flags%mix_full_fields ) THEN
DO j =jts, min(jte, jde-1)
DO k =kts, kte-1
DO i =its, min(ite, ide-1)
var_mix(i,k,j) =thp(i,k,j)
ENDDO
ENDDO
ENDDO
ELSE
DO j =jts, min(jte, jde-1)
DO k =kts, kte-1
DO i =its, min(ite, ide-1)
var_mix(i,k,j) =thp(i,k,j) -t_base(k)
ENDDO
ENDDO
ENDDO
END IF
CALL a_vertical_diffusion_s(rt_tendf,a_rt_tendf,config_flags,var_mix, &
! Revised by Ning Pan, 2010-08-10
! a_var_mix,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,,ids, &
a_var_mix,mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,rho,a_rho,.false.,ids, &
ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
!LPB[3]
! IF( config_flags%mix_full_fields ) THEN
! DO j =jts, min(jte, jde-1)
! DO k =kts, kte-1
! DO i =its, min(ite, ide-1)
! var_mix(i,k,j) =thp(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ELSE
! DO j =jts, min(jte, jde-1)
! DO k =kts, kte-1
! DO i =its, min(ite, ide-1)
! var_mix(i,k,j) =thp(i,k,j) -t_base(k)
! ENDDO
! ENDDO
! ENDDO
! END IF
IF( config_flags%mix_full_fields ) THEN
DO j =min(jte, jde-1), jts, -1
DO k =kte-1, kts, -1
DO i =min(ite, ide-1), its, -1
a_thp(i,k,j) =a_thp(i,k,j) +a_var_mix(i,k,j)
a_var_mix(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j =min(jte, jde-1), jts, -1
DO k =kte-1, kts, -1
DO i =min(ite, ide-1), its, -1
a_thp(i,k,j) =a_thp(i,k,j) +a_var_mix(i,k,j)
a_var_mix(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
END IF
!LPB[2]
!LPB[1]
SELECT CASE (config_flags%isfflx)
CASE(0)
cd0 =config_flags%tke_drag_coefficient
DO j =j_start, j_end
DO i =i_start, ite
! Tmpv300(i,j) =V0_u ! Remarked by Ning Pan, 2010-08-11
V0_u =0.
! Tmpv301(i,j) =tao_xz ! Remarked by Ning Pan, 2010-08-11
tao_xz =0.
Tmpv001 =v_2(i,kts,j) +v_2(i,kts,j+1)
Tmpv002 =Tmpv001 +v_2(i-1,kts,j)
Tmpv003 =Tmpv002 +v_2(i-1,kts,j+1)
Tmpv004 =Tmpv003/4
Tmpv302(i,j) =Tmpv004
Tmpv005 =Tmpv302(i,j)**2
Tmpv006 =(u_2(i,kts,j)**2) +Tmpv005
Tmpv303(i,j) =Tmpv006
Tmpv007 =sqrt(Tmpv303(i,j))
Tmpv008 =Tmpv007 +epsilon
! Revised by Ning Pan, 2010-08-11
! Tmpv304(i,j) =V0_u
! V0_u =Tmpv008
V0_u =Tmpv008
Tmpv304(i,j) =V0_u
Tmpv001 =cd0*V0_u
Tmpv305(i,j) =Tmpv001
Tmpv002 =Tmpv305(i,j)*u_2(i,kts,j)
! Revised by Ning Pan, 2010-08-11
! Tmpv306(i,j) =tao_xz
! tao_xz =Tmpv002
tao_xz =Tmpv002
Tmpv306(i,j) =tao_xz
Tmpv001 =mu(i,j) +mu(i-1,j)
Tmpv002 =0.25*Tmpv001
Tmpv307(i,j) =Tmpv002
Tmpv003 =Tmpv307(i,j)*tao_xz
Tmpv004 =rdzw(i,kts,j) +rdzw(i-1,kts,j)
Tmpv308(i,j) =Tmpv003
Tmpv309(i,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-11
! Tmpv005 =Tmpv308(i,j)*Tmpv309(i,j)
! Tmpv006 =ru_tendf(i,kts,j) -Tmpv005
! ru_tendf(i,kts,j) =Tmpv006
ENDDO
ENDDO
DO j =j_start, jte
DO i =i_start, i_end
! Tmpv3010(i,j) =V0_v ! Remarked by Ning Pan, 2010-08-11
V0_v =0.
! Tmpv3011(i,j) =tao_yz ! Remarked by Ning Pan, 2010-08-11
tao_yz =0.
Tmpv001 =u_2(i,kts,j) +u_2(i,kts,j-1)
Tmpv002 =Tmpv001 +u_2(i+1,kts,j)
Tmpv003 =Tmpv002 +u_2(i+1,kts,j-1)
Tmpv004 =Tmpv003/4
Tmpv3012(i,j) =Tmpv004
Tmpv005 =Tmpv3012(i,j)**2
Tmpv006 =(v_2(i,kts,j)**2) +Tmpv005
Tmpv3013(i,j) =Tmpv006
Tmpv007 =sqrt(Tmpv3013(i,j))
Tmpv008 =Tmpv007 +epsilon
! Revised by Ning Pan, 2010-08-11
! Tmpv3014(i,j) =V0_v
! V0_v =Tmpv008
V0_v =Tmpv008
Tmpv3014(i,j) =V0_v
Tmpv001 =cd0*V0_v
Tmpv3015(i,j) =Tmpv001
Tmpv002 =Tmpv3015(i,j)*v_2(i,kts,j)
! Revised by Ning Pan, 2010-08-11
! Tmpv3016(i,j) =tao_yz
! tao_yz =Tmpv002
tao_yz =Tmpv002
Tmpv3016(i,j) =tao_yz
Tmpv001 =mu(i,j) +mu(i,j-1)
Tmpv002 =0.25*Tmpv001
Tmpv3017(i,j) =Tmpv002
Tmpv003 =Tmpv3017(i,j)*tao_yz
Tmpv004 =rdzw(i,kts,j) +rdzw(i,kts,j-1)
Tmpv3018(i,j) =Tmpv003
Tmpv3019(i,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-11
! Tmpv005 =Tmpv3018(i,j)*Tmpv3019(i,j)
! Tmpv006 =rv_tendf(i,kts,j) -Tmpv005
! rv_tendf(i,kts,j) =Tmpv006
ENDDO
ENDDO
CASE(1,2)
DO j =j_start, j_end
DO i =i_start, ite
! Tmpv3020(i,j) =V0_u ! Remarked by Ning Pan, 2010-08-11
V0_u =0.
! Tmpv3021(i,j) =tao_xz ! Remarked by Ning Pan, 2010-08-11
tao_xz =0.
Tmpv001 =v_2(i,kts,j) +v_2(i,kts,j+1)
Tmpv002 =Tmpv001 +v_2(i-1,kts,j)
Tmpv003 =Tmpv002 +v_2(i-1,kts,j+1)
Tmpv004 =Tmpv003/4
Tmpv3022(i,j) =Tmpv004
Tmpv005 =Tmpv3022(i,j)**2
Tmpv006 =(u_2(i,kts,j)**2) +Tmpv005
Tmpv3023(i,j) =Tmpv006
Tmpv007 =sqrt(Tmpv3023(i,j))
Tmpv008 =Tmpv007 +epsilon
! Revised by Ning Pan, 2010-08-11
! Tmpv3024(i,j) =V0_u
! V0_u =Tmpv008
V0_u =Tmpv008
Tmpv3024(i,j) =V0_u
Tmpv001 =ust(i,j) +ust(i-1,j)
Tmpv002 =0.5*Tmpv001
! Revised by Ning Pan, 2010-08-11
! Tmpv3025(i,j) =ustar
! ustar =Tmpv002
ustar =Tmpv002
Tmpv3025(i,j) =ustar
Tmpv001 =ustar*ustar*u_2(i,kts,j)
Tmpv3026(i,j) =Tmpv001
Tmpv002 =Tmpv3026(i,j)/V0_u
! Revised by Ning Pan, 2010-08-11
! Tmpv3027(i,j) =tao_xz
! tao_xz =Tmpv002
tao_xz =Tmpv002
Tmpv3027(i,j) =tao_xz
Tmpv001 =mu(i,j) +mu(i-1,j)
Tmpv002 =0.25*Tmpv001
Tmpv3028(i,j) =Tmpv002
Tmpv003 =Tmpv3028(i,j)*tao_xz
Tmpv004 =rdzw(i,kts,j) +rdzw(i-1,kts,j)
Tmpv3029(i,j) =Tmpv003
Tmpv3030(i,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-11
! Tmpv005 =Tmpv3029(i,j)*Tmpv3030(i,j)
! Tmpv006 =ru_tendf(i,kts,j) -Tmpv005
! ru_tendf(i,kts,j) =Tmpv006
ENDDO
ENDDO
DO j =j_start, jte
DO i =i_start, i_end
! Tmpv3031(i,j) =V0_v ! Remakred by Ning Pan, 2010-08-11
V0_v =0.
! Tmpv3032(i,j) =tao_yz ! Remarked by Ning Pan, 2010-08-11
tao_yz =0.
Tmpv001 =u_2(i,kts,j) +u_2(i,kts,j-1)
Tmpv002 =Tmpv001 +u_2(i+1,kts,j)
Tmpv003 =Tmpv002 +u_2(i+1,kts,j-1)
Tmpv004 =Tmpv003/4
Tmpv3033(i,j) =Tmpv004
Tmpv005 =Tmpv3033(i,j)**2
Tmpv006 =(v_2(i,kts,j)**2) +Tmpv005
Tmpv3034(i,j) =Tmpv006
Tmpv007 =sqrt(Tmpv3034(i,j))
Tmpv008 =Tmpv007 +epsilon
! Revised by Ning Pan, 2010-08-11
! Tmpv3035(i,j) =V0_v
! V0_v =Tmpv008
V0_v =Tmpv008
Tmpv3035(i,j) =V0_v
Tmpv001 =ust(i,j) +ust(i,j-1)
Tmpv002 =0.5*Tmpv001
! Revised by Ning Pan, 2010-08-11
! Tmpv3036(i,j) =ustar
! ustar =Tmpv002
ustar =Tmpv002
Tmpv3036(i,j) =ustar
Tmpv001 =ustar*ustar*v_2(i,kts,j)
Tmpv3037(i,j) =Tmpv001
Tmpv002 =Tmpv3037(i,j)/V0_v
! Revised by Ning Pan, 2010-08-11
! Tmpv3038(i,j) =tao_yz
! tao_yz =Tmpv002
tao_yz =Tmpv002
Tmpv3038(i,j) =tao_yz
Tmpv001 =mu(i,j) +mu(i,j-1)
Tmpv002 =0.25*Tmpv001
Tmpv3039(i,j) =Tmpv002
Tmpv003 =Tmpv3039(i,j)*tao_yz
Tmpv004 =rdzw(i,kts,j) +rdzw(i,kts,j-1)
Tmpv3040(i,j) =Tmpv003
Tmpv3041(i,j) =Tmpv004
! Remarked by Ning Pan, 2010-08-11
! Tmpv005 =Tmpv3040(i,j)*Tmpv3041(i,j)
! Tmpv006 =rv_tendf(i,kts,j) -Tmpv005
! rv_tendf(i,kts,j) =Tmpv006
ENDDO
ENDDO
CASE DEFAULT
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-10
! END SELECT vflux
END SELECT
SELECT CASE (config_flags%isfflx)
CASE(0)
DO j =jte, j_start, -1
DO i =i_end, i_start, -1
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
a_tao_yz = -a_nba_mij(i, kts, j, p_m23)
a_nba_mij(i, kts, j, p_m23) = 0.0
ELSE
a_tao_yz = 0.0
ENDIF
tao_yz =Tmpv3016(i,j) ! Added by Ning Pan, 2010-08-11
a_Tmpv6 =a_rv_tendf(i,kts,j)
a_rv_tendf(i,kts,j) =0.0
a_rv_tendf(i,kts,j) =a_rv_tendf(i,kts,j) +a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv3 =Tmpv3019(i,j)*a_Tmpv5
a_Tmpv4 =Tmpv3018(i,j)*a_Tmpv5
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +a_Tmpv4
a_rdzw(i,kts,j-1) =a_rdzw(i,kts,j-1) +a_Tmpv4
a_Tmpv2 =tao_yz*a_Tmpv3
a_tao_yz =a_tao_yz +Tmpv3017(i,j)*a_Tmpv3
a_Tmpv1 =0.25*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
! tao_yz =Tmpv3016(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv2 =a_tao_yz
a_tao_yz =0.0
a_Tmpv1 =v_2(i,kts,j)*a_Tmpv2
a_v_2(i,kts,j) =a_v_2(i,kts,j) +Tmpv3015(i,j)*a_Tmpv2
! a_cd0 =a_cd0 +V0_v*a_Tmpv1 ! Remarked by Ning Pan, 2010-08-11
a_V0_v =a_V0_v +cd0*a_Tmpv1
! V0_v =Tmpv3014(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv8 =a_V0_v
a_V0_v =0.0
a_Tmpv7 =a_Tmpv8
a_Tmpv6 =g_Sqrt(1.0, Tmpv3013(i,j))*a_Tmpv7
a_v_2(i,kts,j) =a_v_2(i,kts,j) +2.0*v_2(i,kts,j)*a_Tmpv6
a_Tmpv5 =a_Tmpv6
a_Tmpv4 =2.0*Tmpv3012(i,j)*a_Tmpv5
a_Tmpv3 =a_Tmpv4/4
a_Tmpv2 =a_Tmpv3
a_u_2(i+1,kts,j-1) =a_u_2(i+1,kts,j-1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_u_2(i+1,kts,j) =a_u_2(i+1,kts,j) +a_Tmpv2
a_u_2(i,kts,j) =a_u_2(i,kts,j) +a_Tmpv1
a_u_2(i,kts,j-1) =a_u_2(i,kts,j-1) +a_Tmpv1
! tao_yz =Tmpv3011(i,j) ! Remarked by Ning Pan, 2010-08-11
a_tao_yz =0.0
! V0_v =Tmpv3010(i,j) ! Remarked by Ning Pan, 2010-08-11
a_V0_v =0.0
ENDDO
ENDDO
DO j =j_end, j_start, -1
DO i =ite, i_start, -1
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
a_tao_xz = -a_nba_mij(i, kts, j, p_m13)
a_nba_mij(i, kts, j, p_m13) = 0.0
ELSE
a_tao_xz = 0.0
ENDIF
tao_xz =Tmpv306(i,j) ! Added by Ning Pan, 2010-08-11
a_Tmpv6 =a_ru_tendf(i,kts,j)
a_ru_tendf(i,kts,j) =0.0
a_ru_tendf(i,kts,j) =a_ru_tendf(i,kts,j) +a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv3 =Tmpv309(i,j)*a_Tmpv5
a_Tmpv4 =Tmpv308(i,j)*a_Tmpv5
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +a_Tmpv4
a_rdzw(i-1,kts,j) =a_rdzw(i-1,kts,j) +a_Tmpv4
a_Tmpv2 =tao_xz*a_Tmpv3
a_tao_xz =a_tao_xz +Tmpv307(i,j)*a_Tmpv3
a_Tmpv1 =0.25*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
! tao_xz =Tmpv306(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv2 =a_tao_xz
a_tao_xz =0.0
a_Tmpv1 =u_2(i,kts,j)*a_Tmpv2
a_u_2(i,kts,j) =a_u_2(i,kts,j) +Tmpv305(i,j)*a_Tmpv2
! a_cd0 =a_cd0 +V0_u*a_Tmpv1 ! Remarked by Ning Pan, 2010-08-11
a_V0_u =a_V0_u +cd0*a_Tmpv1
! V0_u =Tmpv304(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv8 =a_V0_u
a_V0_u =0.0
a_Tmpv7 =a_Tmpv8
a_Tmpv6 =g_Sqrt(1.0, Tmpv303(i,j))*a_Tmpv7
a_u_2(i,kts,j) =a_u_2(i,kts,j) +2.0*u_2(i,kts,j)*a_Tmpv6
a_Tmpv5 =a_Tmpv6
a_Tmpv4 =2.0*Tmpv302(i,j)*a_Tmpv5
a_Tmpv3 =a_Tmpv4/4
a_Tmpv2 =a_Tmpv3
a_v_2(i-1,kts,j+1) =a_v_2(i-1,kts,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_v_2(i-1,kts,j) =a_v_2(i-1,kts,j) +a_Tmpv2
a_v_2(i,kts,j) =a_v_2(i,kts,j) +a_Tmpv1
a_v_2(i,kts,j+1) =a_v_2(i,kts,j+1) +a_Tmpv1
! tao_xz =Tmpv301(i,j) ! Remarked by Ning Pan, 2010-08-11
a_tao_xz =0.0
! V0_u =Tmpv300(i,j) ! Remarked by Ning Pan, 2010-08-11
a_V0_u =0.0
ENDDO
ENDDO
! a_config_flags%tke_drag_coefficient =a_config_flags%tke_drag_coefficient +a_cd0
! a_cd0 =0.0 ! Remarked by Ning Pan, 2010-08-11
CASE(1,2)
DO j =jte, j_start, -1
DO i =i_end, i_start, -1
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
a_tao_yz = -a_nba_mij(i, kts, j, p_m23)
a_nba_mij(i, kts, j, p_m23) = 0.0
ELSE
a_tao_yz = 0.0
ENDIF
tao_yz =Tmpv3038(i,j) ! Added by Ning Pan, 2010-08-11
a_Tmpv6 =a_rv_tendf(i,kts,j)
a_rv_tendf(i,kts,j) =0.0
a_rv_tendf(i,kts,j) =a_rv_tendf(i,kts,j) +a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv3 =Tmpv3041(i,j)*a_Tmpv5
a_Tmpv4 =Tmpv3040(i,j)*a_Tmpv5
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +a_Tmpv4
a_rdzw(i,kts,j-1) =a_rdzw(i,kts,j-1) +a_Tmpv4
a_Tmpv2 =tao_yz*a_Tmpv3
a_tao_yz =a_tao_yz +Tmpv3039(i,j)*a_Tmpv3
a_Tmpv1 =0.25*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
! tao_yz =Tmpv3038(i,j) ! Remarked by Ning Pan, 2010-08-11
! Added by Ning Pan, 2010-08-11
V0_v =Tmpv3035(i,j)
ustar =Tmpv3036(i,j)
a_Tmpv2 =a_tao_yz
a_tao_yz =0.0
a_Tmpv1 =a_Tmpv2/V0_v
a_V0_v =a_V0_v -Tmpv3037(i,j)/(V0_v*V0_v)*a_Tmpv2
a_ustar =a_ustar +2.0*ustar*v_2(i,kts,j)*a_Tmpv1
a_v_2(i,kts,j) =a_v_2(i,kts,j) +ustar*ustar*a_Tmpv1
! ustar =Tmpv3036(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv2 =a_ustar
a_ustar =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_ust(i,j) =a_ust(i,j) +a_Tmpv1
a_ust(i,j-1) =a_ust(i,j-1) +a_Tmpv1
! V0_v =Tmpv3035(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv8 =a_V0_v
a_V0_v =0.0
a_Tmpv7 =a_Tmpv8
a_Tmpv6 =g_Sqrt(1.0, Tmpv3034(i,j))*a_Tmpv7
a_v_2(i,kts,j) =a_v_2(i,kts,j) +2.0*v_2(i,kts,j)*a_Tmpv6
a_Tmpv5 =a_Tmpv6
a_Tmpv4 =2.0*Tmpv3033(i,j)*a_Tmpv5
a_Tmpv3 =a_Tmpv4/4
a_Tmpv2 =a_Tmpv3
a_u_2(i+1,kts,j-1) =a_u_2(i+1,kts,j-1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_u_2(i+1,kts,j) =a_u_2(i+1,kts,j) +a_Tmpv2
a_u_2(i,kts,j) =a_u_2(i,kts,j) +a_Tmpv1
a_u_2(i,kts,j-1) =a_u_2(i,kts,j-1) +a_Tmpv1
! tao_yz =Tmpv3032(i,j) ! Remarked by Ning Pan, 2010-08-11
a_tao_yz =0.0
! V0_v =Tmpv3031(i,j) ! Remarked by Ning Pan, 2010-08-11
a_V0_v =0.0
ENDDO
ENDDO
DO j =j_end, j_start, -1
DO i =ite, i_start, -1
IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
a_tao_xz = -a_nba_mij(i, kts, j, p_m13)
a_nba_mij(i, kts, j, p_m13) = 0.0
ELSE
a_tao_xz = 0.0
ENDIF
tao_xz =Tmpv3027(i,j) ! Added by Ning Pan, 2010-08-11
a_Tmpv6 =a_ru_tendf(i,kts,j)
a_ru_tendf(i,kts,j) =0.0
a_ru_tendf(i,kts,j) =a_ru_tendf(i,kts,j) +a_Tmpv6
a_Tmpv5 =-a_Tmpv6
a_Tmpv3 =Tmpv3030(i,j)*a_Tmpv5
a_Tmpv4 =Tmpv3029(i,j)*a_Tmpv5
a_rdzw(i,kts,j) =a_rdzw(i,kts,j) +a_Tmpv4
a_rdzw(i-1,kts,j) =a_rdzw(i-1,kts,j) +a_Tmpv4
a_Tmpv2 =tao_xz*a_Tmpv3
a_tao_xz =a_tao_xz +Tmpv3028(i,j)*a_Tmpv3
a_Tmpv1 =0.25*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
! tao_xz =Tmpv3027(i,j) ! Remarked by Ning Pan, 2010-08-11
! Added by Ning Pan, 2010-08-11
V0_u =Tmpv3024(i,j)
ustar =Tmpv3025(i,j)
a_Tmpv2 =a_tao_xz
a_tao_xz =0.0
a_Tmpv1 =a_Tmpv2/V0_u
a_V0_u =a_V0_u -Tmpv3026(i,j)/(V0_u*V0_u)*a_Tmpv2
a_ustar =a_ustar +2.0*ustar*u_2(i,kts,j)*a_Tmpv1
a_u_2(i,kts,j) =a_u_2(i,kts,j) +ustar*ustar*a_Tmpv1
! ustar =Tmpv3025(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv2 =a_ustar
a_ustar =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_ust(i,j) =a_ust(i,j) +a_Tmpv1
a_ust(i-1,j) =a_ust(i-1,j) +a_Tmpv1
! V0_u =Tmpv3024(i,j) ! Remarked by Ning Pan, 2010-08-11
a_Tmpv8 =a_V0_u
a_V0_u =0.0
a_Tmpv7 =a_Tmpv8
a_Tmpv6 =g_Sqrt(1.0, Tmpv3023(i,j))*a_Tmpv7
a_u_2(i,kts,j) =a_u_2(i,kts,j) +2.0*u_2(i,kts,j)*a_Tmpv6
a_Tmpv5 =a_Tmpv6
a_Tmpv4 =2.0*Tmpv3022(i,j)*a_Tmpv5
a_Tmpv3 =a_Tmpv4/4
a_Tmpv2 =a_Tmpv3
a_v_2(i-1,kts,j+1) =a_v_2(i-1,kts,j+1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_v_2(i-1,kts,j) =a_v_2(i-1,kts,j) +a_Tmpv2
a_v_2(i,kts,j) =a_v_2(i,kts,j) +a_Tmpv1
a_v_2(i,kts,j+1) =a_v_2(i,kts,j+1) +a_Tmpv1
! tao_xz =Tmpv3021(i,j) ! Remarked by Ning Pan, 2010-08-11
a_tao_xz =0.0
! V0_u =Tmpv3020(i,j) ! Remarked by Ning Pan, 2010-08-11
a_V0_u =0.0
ENDDO
ENDDO
CASE DEFAULT
! Revised by Ning Pan, 2010-08-10
! CALL a_wrf_error_fatal('isfflx value invalid for diff_opt=2')
CALL wrf_error_fatal('isfflx value invalid for diff_opt=2')
! Revised by Ning Pan, 2010-08-10
! END SELECT vflux
END SELECT
!LPB[0]
! Remarked by Ning Pan, 2010-08-10
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! ru_tendf(IX1,IX2,IX3) =Keep_Lpb0_ru_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb0_nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rv_tendf(IX1,IX2,IX3) =Keep_Lpb0_rv_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rw_tendf(IX1,IX2,IX3) =Keep_Lpb0_rw_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! Remarked by Ning Pan, 2010-08-11
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv400(IX1,IX2,IX3) =ru_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv500(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
Keep_Lpb0_nba_mij = nba_mij
CALL vertical_diffusion_u_2(ru_tendf,config_flags,defor13,xkmv,nba_mij, &
n_nba_mij,dnw,rdzw,fnm,fnp,rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv401(IX1,IX2,IX3) =rv_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv501(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
Keep_Lpb1_nba_mij = nba_mij
CALL vertical_diffusion_v_2(rv_tendf,config_flags,defor23,xkmv,nba_mij, &
n_nba_mij,dnw,rdzw,fnm,fnp,rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
jts,jte,kts,kte)
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv402(IX1,IX2,IX3) =rw_tendf(IX1,IX2,IX3)
! END DO
! END DO
! END DO
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! Tmpv502(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! CALL vertical_diffusion_w_2(rw_tendf,config_flags,defor33,tke(ims,kms,jms) &
! ,nba_mij,n_nba_mij,div,xkmv,dn,rdz,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
! its,ite,jts,jte,kts,kte)
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Tmpv502(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rw_tendf(IX1,IX2,IX3) =Tmpv402(IX1,IX2,IX3)
! END DO
! END DO
! END DO
CALL a_vertical_diffusion_w_2(rw_tendf,a_rw_tendf,config_flags,mu,a_mu, &
defor33,a_defor33,tke(ims,kms,jms),a_tke(ims,kms,jms),nba_mij,a_nba_mij, &
n_nba_mij,div,a_div,xkmv,a_xkmv,dn,rdz,a_rdz,rho,a_rho,ids,ide,jds,jde,kds,kde,ims,ime, &
jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Tmpv501(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! rv_tendf(IX1,IX2,IX3) =Tmpv401(IX1,IX2,IX3)
! END DO
! END DO
! END DO
nba_mij = Keep_Lpb1_nba_mij
CALL a_vertical_diffusion_v_2(rv_tendf,a_rv_tendf,config_flags,mu,a_mu, &
defor23,a_defor23,xkmv,a_xkmv,nba_mij,a_nba_mij,n_nba_mij,dnw,rdzw,a_rdzw, &
fnm,fnp,rho,a_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
! Remarked by Ning Pan, 2010-08-11
! DO IX4=1,n_nba_mij
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! nba_mij(IX1,IX2,IX3,IX4) =Tmpv500(IX1,IX2,IX3,IX4)
! END DO
! END DO
! END DO
! END DO
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! ru_tendf(IX1,IX2,IX3) =Tmpv400(IX1,IX2,IX3)
! END DO
! END DO
! END DO
nba_mij = Keep_Lpb0_nba_mij
CALL a_vertical_diffusion_u_2(ru_tendf,a_ru_tendf,config_flags,mu,a_mu, &
defor13,a_defor13,xkmv,a_xkmv,nba_mij,a_nba_mij,n_nba_mij,dnw,rdzw,a_rdzw, &
fnm,fnp,rho,a_rho,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
END SUBROUTINE a_vertical_diffusion_2
SUBROUTINE a_vertical_diffusion_u_2(tendency,a_tendency,config_flags,mu,a_mu, &
defor13,a_defor13,xkmv,a_xkmv,nba_mij,a_nba_mij,n_nba_mij,dnw,rdzw,a_rdzw, &
fnm,fnp,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor13,a_defor13,xkmv,a_xkmv,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,a_titau3
REAL,DIMENSION(its:ite,jts:jte) :: zzavg,a_zzavg
REAL :: rdzu,a_rdzu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
! REAL,DIMENSION(max(jds+1,jts):min(jde-2,jte)) :: Keep_Lpb14_rdzu
INTEGER :: IX1,IX2,IX3,IX4
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003
REAL :: Tmpv_1
REAL,DIMENSION(its:ite) :: Tmpv200
REAL,DIMENSION(its:ite) :: Tmpv201 ! Added by Ning Pan, 2010-08-10
REAL,DIMENSION(its:ite,kts+1:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:ite,kts+1:min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:ite,kts+1:min(kte,kde-1)) :: Tmpv302 ! Added by Ning Pan, 2010-08-10
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = ite
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-1,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
is_ext=0
ie_ext=0
js_ext=0
je_ext=0
CALL cal_titau_13_31( config_flags, titau3, defor13, &
nba_mij(ims,kms,jms,P_m13), &
xkmv, fnm, fnp, rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!LPB[13]
! Remarked by Ning Pan, 2010-08-10
! DO j = j_start, j_end
! DO k=kts+1,ktf
! DO i = i_start, i_end
! rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j))
! tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)-titau3(i,k,j))
! ENDDO
! ENDDO
! ENDDO
!!LPB[14]
! DO j = j_start, j_end
! ! Keep_Lpb14_rdzu(j) =rdzu
! k=kts
! DO i = i_start, i_end
! rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j))
! tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j))
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau3(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K1_ADJ =jts, jte
Do K0_ADJ =its, ite
a_zzavg(K0_ADJ,K1_ADJ) =0.0
End Do
End Do
a_rdzu =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[14]
DO j =j_end, j_start, -1
! rdzu =Keep_Lpb14_rdzu(j)
k =kts
DO i =i_start, i_end
Tmpv001 =1./rdzw(i,k,j) +1./rdzw(i-1,k,j)
Tmpv201(i) =Tmpv001 ! Added by Ning Pan, 2010-08-10
Tmpv002 =2./Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv200(i) =rdzu
! rdzu =Tmpv002
rdzu =Tmpv002
Tmpv200(i) =rdzu
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =rdzu*(titau3(i,k+1,j))
! Tmpv002 =tendency(i,k,j) -Tmpv001
! tendency(i,k,j) =Tmpv002
ENDDO
DO i =i_end, i_start, -1
rdzu =Tmpv200(i) ! Added by Ning Pan, 2010-08-10
a_Tmpv2 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv2
a_Tmpv1 =-a_Tmpv2
a_rdzu =a_rdzu +(titau3(i,k+1,j))*a_Tmpv1
a_titau3(i,k+1,j) =a_titau3(i,k+1,j) +rdzu*a_Tmpv1
! rdzu =Tmpv200(i) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_rdzu
a_rdzu =0.0
! Revised by Ning Pan, 2010-08-10
! a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv001*Tmpv001)
a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv201(i)*Tmpv201(i))
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
a_rdzw(i-1,k,j) =a_rdzw(i-1,k,j) -1./(rdzw(i-1,k,j)*rdzw(i-1,k,j))*a_Tmpv1
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =1./rdzw(i,k,j) +1./rdzw(i-1,k,j)
Tmpv302(i,k) =Tmpv001 ! Added by Ning Pan, 2010-08-10
Tmpv002 =2./Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =rdzu
! rdzu =Tmpv002
rdzu =Tmpv002
Tmpv300(i,k) =rdzu
Tmpv001 =titau3(i,k+1,j) -titau3(i,k,j)
Tmpv301(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =rdzu*Tmpv301(i,k)
! Tmpv003 =tendency(i,k,j) -Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
rdzu =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =-a_Tmpv3
a_rdzu =a_rdzu +Tmpv301(i,k)*a_Tmpv2
a_Tmpv1 =rdzu*a_Tmpv2
a_titau3(i,k+1,j) =a_titau3(i,k+1,j) +a_Tmpv1
a_titau3(i,k,j) =a_titau3(i,k,j) -a_Tmpv1
! rdzu =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_rdzu
a_rdzu =0.0
! Revised by Ning Pan, 2010-08-10
! a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv001*Tmpv001)
a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv302(i,k)*Tmpv302(i,k))
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
a_rdzw(i-1,k,j) =a_rdzw(i-1,k,j) -1./(rdzw(i-1,k,j)*rdzw(i-1,k,j))*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-10
! is_ext =0
! ie_ext =0
! js_ext =0
! je_ext =0
! Tmpv_1 =nba_mij(ims,kms,jms,P_m13)
! CALL cal_titau_13_31(config_flags,titau3,defor13,nba_mij(ims,kms,jms,P_m13) &
! ,mu,xkmv,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
! kms,kme,its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m13) =Tmpv_1
CALL a_cal_titau_13_31(config_flags,titau3,a_titau3,defor13,a_defor13, &
nba_mij(ims,kms,jms,P_m13),a_nba_mij(ims,kms,jms,P_m13),mu,a_mu,xkmv,a_xkmv, &
fnm,fnp,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =ite
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-1, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =ite
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_vertical_diffusion_u_2
SUBROUTINE a_vertical_diffusion_v_2(tendency,a_tendency,config_flags,mu,a_mu, &
defor23,a_defor23,xkmv,a_xkmv,nba_mij,a_nba_mij,n_nba_mij,dnw,rdzw,a_rdzw, &
fnm,fnp,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor23,a_defor23,xkmv,a_xkmv,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,a_titau3
REAL,DIMENSION(its:ite,jts:jte) :: zzavg,a_zzavg
REAL :: rdzv,a_rdzv
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
! REAL,DIMENSION(max(jds+1,jts):min(jde-1,jte)) :: Keep_Lpb14_rdzv
INTEGER :: IX1,IX2,IX3,IX4
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003
REAL :: Tmpv_1
REAL,DIMENSION(its:min(ite,ide-1)) :: Tmpv200
REAL,DIMENSION(its:min(ite,ide-1)) :: Tmpv201 ! Added by Ning Pan, 2010-08-10
REAL,DIMENSION(its:min(ite,ide-1),kts+1:min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),kts+1:min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),kts+1:min(kte,kde-1)) :: Tmpv302 ! Added by Ning Pan, 2010-08-10
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = jte
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-1,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
is_ext=0
ie_ext=0
js_ext=0
je_ext=0
CALL cal_titau_23_32( config_flags, titau3, defor23, &
nba_mij(ims,kms,jms,P_m23), &
xkmv, fnm, fnp, rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!LPB[13]
! Remarked by Ning Pan, 2010-08-10
! DO j = j_start, j_end
! DO k = kts+1,ktf
! DO i = i_start, i_end
! rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1))
! tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)-titau3(i,k,j))
! ENDDO
! ENDDO
! ENDDO
!!LPB[14]
! DO j = j_start, j_end
! ! Keep_Lpb14_rdzv(j) =rdzv
! k=kts
! DO i = i_start, i_end
! rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1))
! tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j))
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau3(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K1_ADJ =jts, jte
Do K0_ADJ =its, ite
a_zzavg(K0_ADJ,K1_ADJ) =0.0
End Do
End Do
a_rdzv =0.0
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[14]
DO j =j_end, j_start, -1
! rdzv =Keep_Lpb14_rdzv(j)
k =kts
DO i =i_start, i_end
Tmpv001 =1./rdzw(i,k,j) +1./rdzw(i,k,j-1)
Tmpv201(i) =Tmpv001 ! Added by Ning Pan, 2010-08-10
Tmpv002 =2./Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv200(i) =rdzv
! rdzv =Tmpv002
rdzv =Tmpv002
Tmpv200(i) =rdzv
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =rdzv*(titau3(i,k+1,j))
! Tmpv002 =tendency(i,k,j) -Tmpv001
! tendency(i,k,j) =Tmpv002
ENDDO
DO i =i_end, i_start, -1
rdzv =Tmpv200(i) ! Added by Ning Pan, 2010-08-10
a_Tmpv2 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv2
a_Tmpv1 =-a_Tmpv2
a_rdzv =a_rdzv +(titau3(i,k+1,j))*a_Tmpv1
a_titau3(i,k+1,j) =a_titau3(i,k+1,j) +rdzv*a_Tmpv1
! rdzv =Tmpv200(i) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_rdzv
a_rdzv =0.0
! Revised by Ning Pan, 2010-08-10
! a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv001*Tmpv001)
a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv201(i)*Tmpv201(i))
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
a_rdzw(i,k,j-1) =a_rdzw(i,k,j-1) -1./(rdzw(i,k,j-1)*rdzw(i,k,j-1))*a_Tmpv1
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =1./rdzw(i,k,j) +1./rdzw(i,k,j-1)
Tmpv302(i,k) =Tmpv001 ! Added by Ning Pan, 2010-08-10
Tmpv002 =2./Tmpv001
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =rdzv
! rdzv =Tmpv002
rdzv =Tmpv002
Tmpv300(i,k) =rdzv
Tmpv001 =titau3(i,k+1,j) -titau3(i,k,j)
Tmpv301(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =rdzv*Tmpv301(i,k)
! Tmpv003 =tendency(i,k,j) -Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
rdzv =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =-a_Tmpv3
a_rdzv =a_rdzv +Tmpv301(i,k)*a_Tmpv2
a_Tmpv1 =rdzv*a_Tmpv2
a_titau3(i,k+1,j) =a_titau3(i,k+1,j) +a_Tmpv1
a_titau3(i,k,j) =a_titau3(i,k,j) -a_Tmpv1
! rdzv =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv2 =a_rdzv
a_rdzv =0.0
! Revised by Ning Pan, 2010-08-10
! a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv001*Tmpv001)
a_Tmpv1 =-(2.)*a_Tmpv2/(Tmpv302(i,k)*Tmpv302(i,k))
a_rdzw(i,k,j) =a_rdzw(i,k,j) -1./(rdzw(i,k,j)*rdzw(i,k,j))*a_Tmpv1
a_rdzw(i,k,j-1) =a_rdzw(i,k,j-1) -1./(rdzw(i,k,j-1)*rdzw(i,k,j-1))*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-10
! is_ext =0
! ie_ext =0
! js_ext =0
! je_ext =0
! Tmpv_1 =nba_mij(ims,kms,jms,P_m23)
! CALL cal_titau_23_32(config_flags,titau3,defor23,nba_mij(ims,kms,jms,P_m23) &
! ,mu,xkmv,fnm,fnp,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
! kms,kme,its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m23) =Tmpv_1
CALL a_cal_titau_23_32(config_flags,titau3,a_titau3,defor23,a_defor23, &
nba_mij(ims,kms,jms,P_m23),a_nba_mij(ims,kms,jms,P_m23),mu,a_mu,xkmv,a_xkmv, &
fnm,fnp,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-1, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =jte
END SUBROUTINE a_vertical_diffusion_v_2
SUBROUTINE a_vertical_diffusion_w_2(tendency,a_tendency,config_flags,mu,a_mu, &
defor33,a_defor33,tke,a_tke,nba_mij,a_nba_mij,n_nba_mij,div,a_div,xkmv, &
a_xkmv,dn,rdz,a_rdz,rho,a_rho,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor33,a_defor33,tke,a_tke,div, &
a_div,xkmv,a_xkmv,rdz,a_rdz
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
INTEGER :: n_nba_mij
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: nba_mij,a_nba_mij
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau3,a_titau3
REAL,DIMENSION(ims:ime,kms:kme,jms:jme,n_nba_mij) :: Keep_Lpb12_nba_mij
INTEGER :: IX1,IX2,IX3,IX4
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003
REAL :: Tmpv_1
REAL,DIMENSION(its:min(ite,ide-1),kts+1:min(kte,kde-1)) :: Tmpv300
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4) =nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
is_ext=0
ie_ext=0
js_ext=0
je_ext=0
CALL cal_titau_11_22_33( config_flags, titau3, &
tke, xkmv, defor33, &
nba_mij(ims,kms,jms,P_m33), rho, &
is_ext, ie_ext, js_ext, je_ext, &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!!LPB[13]
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! tendency(i,k,j)=tendency(i,k,j)-rdz(i,k,j)*(titau3(i,k,j)-titau3(i,k-1,j))
! ENDDO
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_titau3(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[13]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =titau3(i,k,j) -titau3(i,k-1,j)
Tmpv300(i,k) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =rdz(i,k,j)*Tmpv300(i,k)
! Tmpv003 =tendency(i,k,j) -Tmpv002
! tendency(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv3
a_Tmpv2 =-a_Tmpv3
a_rdz(i,k,j) =a_rdz(i,k,j) +Tmpv300(i,k)*a_Tmpv2
a_Tmpv1 =rdz(i,k,j)*a_Tmpv2
a_titau3(i,k,j) =a_titau3(i,k,j) +a_Tmpv1
a_titau3(i,k-1,j) =a_titau3(i,k-1,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
DO IX4=1,n_nba_mij
DO IX3=jms,jme
DO IX2=kms,kme
DO IX1=ims,ime
nba_mij(IX1,IX2,IX3,IX4) =Keep_Lpb12_nba_mij(IX1,IX2,IX3,IX4)
END DO
END DO
END DO
END DO
! Remarked by Ning Pan, 2010-08-10
! is_ext =0
! ie_ext =0
! js_ext =0
! je_ext =0
! Tmpv_1 =nba_mij(ims,kms,jms,P_m33)
! CALL cal_titau_11_22_33(config_flags,titau3,mu,tke,xkmv,defor33,nba_mij(ims,kms, &
! jms,P_m33),is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms, &
! kme,its,ite,jts,jte,kts,kte)
! nba_mij(ims,kms,jms,P_m33) =Tmpv_1
CALL a_cal_titau_11_22_33(config_flags,titau3,a_titau3,mu,a_mu,tke,a_tke, &
xkmv,a_xkmv,defor33,a_defor33,nba_mij(ims,kms,jms,P_m33),a_nba_mij(ims,kms,jms, &
P_m33),rho,a_rho,is_ext,ie_ext,js_ext,je_ext,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, &
its,ite,jts,jte,kts,kte)
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_vertical_diffusion_w_2
SUBROUTINE a_vertical_diffusion_s(tendency,a_tendency,config_flags,var,a_var, &
mu,a_mu,xkhv,a_xkhv,dn,dnw,rdz,a_rdz,rdzw,a_rdzw,fnm,fnp,rho,a_rho,doing_tke,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
LOGICAL :: doing_tke
REAL,DIMENSION(kms:kme) :: fnm
REAL,DIMENSION(kms:kme) :: fnp
REAL,DIMENSION(kms:kme) :: dn
REAL,DIMENSION(kms:kme) :: dnw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,a_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: xkhv,a_xkhv
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: var,a_var,rdz,a_rdz,rdzw,a_rdzw
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
INTEGER :: i,j,k,ktf
INTEGER :: i_start,i_end,j_start,j_end
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: H3,a_H3,xkxavg,a_xkxavg,rravg,a_rravg
REAL,DIMENSION(its:ite,kts:kte,jts:jte) :: tmptendf,a_tmptendf
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv300
REAL,DIMENSION(its:min(ite,ide-1),min0(kts+1,kts):min(kte,kde-1)) :: Tmpv301
REAL,DIMENSION(its:min(ite,ide-1),kts+1:min(kte,kde-1)) :: Tmpv302
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf=MIN(kte,kde-1)
i_start = its
i_end = MIN(ite,ide-1)
j_start = jts
j_end = MIN(jte,jde-1)
!LPB[1]
IF ( config_flags%open_xs .or. config_flags%specified .or. &
config_flags%nested) i_start = MAX(ids+1,its)
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .or. config_flags%specified .or. &
config_flags%nested) i_end = MIN(ide-2,ite)
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .or. config_flags%specified .or. &
config_flags%nested) j_start = MAX(jds+1,jts)
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .or. config_flags%specified .or. &
config_flags%nested) j_end = MIN(jde-2,jte)
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
!LPB[12]
!LPB[13]
! Remarked by Ning Pan, 2010-08-10
! IF (doing_tke) THEN
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! tmptendf(i,k,j)=tendency(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ENDIF
!LPB[14]
xkxavg = 0.
!LPB[15]
DO j = j_start, j_end
DO k = kts+1,ktf
DO i = i_start, i_end
xkxavg(i,k,j)=fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j)
H3(i,k,j)=-xkxavg(i,k,j)*(var(i,k,j)-var(i,k-1,j))*rdz(i,k,j)
ENDDO
ENDDO
ENDDO
!LPB[16]
DO j = j_start, j_end
DO i = i_start, i_end
H3(i,kts,j)=0.
H3(i,ktf+1,j)=0.
ENDDO
ENDDO
!!LPB[17]
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! tendency(i,k,j)=tendency(i,k,j) &
! -mu(i,j)*(H3(i,k+1,j)-H3(i,k,j))*rdzw(i,k,j)
! ENDDO
! ENDDO
! ENDDO
!!LPB[18]
!!LPB[19]
! IF (doing_tke) THEN
! DO j = j_start, j_end
! DO k = kts,ktf
! DO i = i_start, i_end
! tendency(i,k,j)=tmptendf(i,k,j)+2.* &
! (tendency(i,k,j)-tmptendf(i,k,j))
! ENDDO
! ENDDO
! ENDDO
! ENDIF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_H3(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_rravg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K2_ADJ =jts, jte
Do K1_ADJ =kts, kte
Do K0_ADJ =its, ite
a_tmptendf(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[19]
! IF(doing_tke) THEN
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =tendency(i,k,j) -tmptendf(i,k,j)
! Tmpv002 =2.*Tmpv001
! Tmpv003 =tmptendf(i,k,j) +Tmpv002
! tendency(i,k,j) =Tmpv003
! ENDDO
! ENDDO
! ENDDO
! ENDIF
IF(doing_tke) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv3 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tmptendf(i,k,j) =a_tmptendf(i,k,j) +a_Tmpv3
a_Tmpv2 =a_Tmpv3
a_Tmpv1 =2.*a_Tmpv2
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv1
a_tmptendf(i,k,j) =a_tmptendf(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[18]
!LPB[17]
DO j =j_end, j_start, -1
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =H3(i,k+1,j) -H3(i,k,j)
Tmpv300(i,k) =Tmpv001
Tmpv002 =mu(i,j)*Tmpv300(i,k)
Tmpv301(i,k) =Tmpv002
! Remarked by Ning Pan, 2010-08-10
! Tmpv003 =Tmpv301(i,k)*rdzw(i,k,j)
! Tmpv004 =tendency(i,k,j) -Tmpv003
! tendency(i,k,j) =Tmpv004
ENDDO
ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_tendency(i,k,j)
a_tendency(i,k,j) =0.0
a_tendency(i,k,j) =a_tendency(i,k,j) +a_Tmpv4
a_Tmpv3 =-a_Tmpv4
a_Tmpv2 =rdzw(i,k,j)*a_Tmpv3
a_rdzw(i,k,j) =a_rdzw(i,k,j) +Tmpv301(i,k)*a_Tmpv3
a_mu(i,j) =a_mu(i,j) +Tmpv300(i,k)*a_Tmpv2
a_Tmpv1 =mu(i,j)*a_Tmpv2
a_H3(i,k+1,j) =a_H3(i,k+1,j) +a_Tmpv1
a_H3(i,k,j) =a_H3(i,k,j) -a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[16]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! H3(i,kts,j) =0.
! H3(i,ktf+1,j) =0.
! ENDDO
DO i =i_end, i_start, -1
a_H3(i,ktf+1,j) =0.0
a_H3(i,kts,j) =0.0
ENDDO
ENDDO
xkxavg = 0. ! Added by Ning Pan, 2010-08-10
!LPB[15]
DO j =j_end, j_start, -1
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =fnm(k)*xkhv(i,k,j) +fnp(k)*xkhv(i,k-1,j)
! Revised by Ning Pan, 2010-08-10
! Tmpv300(i,k) =xkxavg(i,k,j)
! xkxavg(i,k,j) =Tmpv001
xkxavg(i,k,j) =Tmpv001
Tmpv300(i,k) =xkxavg(i,k,j)
Tmpv001 =var(i,k,j) -var(i,k-1,j)
Tmpv301(i,k) =Tmpv001
Tmpv002 =-xkxavg(i,k,j)*Tmpv301(i,k)
Tmpv302(i,k) =Tmpv002
! Remarked by Ning Pan, 2010-08-10
! Tmpv003 =Tmpv302(i,k)*rdz(i,k,j)
! H3(i,k,j) =Tmpv003
ENDDO
ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
xkxavg(i,k,j) =Tmpv300(i,k) ! Added by Ning Pan, 2010-08-10
a_Tmpv3 =a_H3(i,k,j)
a_H3(i,k,j) =0.0
a_Tmpv2 =rdz(i,k,j)*a_Tmpv3
a_rdz(i,k,j) =a_rdz(i,k,j) +Tmpv302(i,k)*a_Tmpv3
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -Tmpv301(i,k)*a_Tmpv2
a_Tmpv1 =-xkxavg(i,k,j)*a_Tmpv2
a_var(i,k,j) =a_var(i,k,j) +a_Tmpv1
a_var(i,k-1,j) =a_var(i,k-1,j) -a_Tmpv1
! xkxavg(i,k,j) =Tmpv300(i,k) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv1 =a_xkxavg(i,k,j)
a_xkxavg(i,k,j) =0.0
a_xkhv(i,k,j) =a_xkhv(i,k,j) +fnm(k)*a_Tmpv1
a_xkhv(i,k-1,j) =a_xkhv(i,k-1,j) +fnp(k)*a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[14]
! xkxavg =0.
a_xkxavg =0.0
!LPB[13]
! IF(doing_tke) THEN
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! tmptendf(i,k,j) =tendency(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ENDIF
IF(doing_tke) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_tendency(i,k,j) =a_tendency(i,k,j) +a_tmptendf(i,k,j)
a_tmptendf(i,k,j) =0.0
ENDDO
ENDDO
ENDDO
ENDIF
!LPB[12]
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .or. config_flags%specified .or. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .or. config_flags%specified .or. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .or. config_flags%specified .or. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .or. config_flags%specified .or. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .or. config_flags%specified .or. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_vertical_diffusion_s
SUBROUTINE a_cal_titau_11_22_33(config_flags,titau,a_titau,mu,a_mu,tke,a_tke, &
xkx,a_xkx,defor,a_defor,mtau,a_mtau,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,a_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,a_defor,xkx,a_xkx,tke,a_tke
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,a_mtau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb13_mtau
INTEGER :: IX1,IX2,IX3
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002
! Revised by Ning Pan, 2010-08-10
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv400
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv401
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv402
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: Tmpv400, Tmpv401, Tmpv402
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = ite
j_start = jts
j_end = jte
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-1, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-1, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[12]
i_start = i_start - is_ext
i_end = i_end + ie_ext
j_start = j_start - js_ext
j_end = j_end + je_ext
!!LPB[13]
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb13_mtau(IX1,IX2,IX3) =mtau(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
! IF ( config_flags%sfs_opt .GT. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! titau(i,k,j) = mu(i,j) * mtau(i,k,j)
! END DO
! END DO
! END DO
! ELSE
! IF ( config_flags%m_opt .EQ. 1 ) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j)
! mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j)
! END DO
! END DO
! END DO
! ELSE
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j)
! END DO
! END DO
! END DO
! ENDIF
! ENDIF
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[13]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! mtau(IX1,IX2,IX3) =Keep_Lpb13_mtau(IX1,IX2,IX3)
! END DO
! END DO
! END DO
IF( config_flags%sfs_opt .GT. 0 ) THEN
! Remarked by Ning Pan, 2010-08-10
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =mu(i,j)*mtau(i,k,j)
! titau(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =-mu(i,j)*xkx(i,k,j)
Tmpv400(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv400(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =-xkx(i,k,j)*defor(i,k,j)
! Tmpv401(i,k,j) =mtau(i,k,j)
! mtau(i,k,j) =Tmpv001
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =-mu(i,j)*xkx(i,k,j)
Tmpv402(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv402(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_mu(i,j) =a_mu(i,j) +mtau(i,k,j)*a_Tmpv1
a_mtau(i,k,j) =a_mtau(i,k,j) +mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
! mtau(i,k,j) =Tmpv401(i,k,j) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv1 =a_mtau(i,k,j)
a_mtau(i,k,j) =0.0
a_xkx(i,k,j) =a_xkx(i,k,j) -defor(i,k,j)*a_Tmpv1
a_defor(i,k,j) =a_defor(i,k,j) -xkx(i,k,j)*a_Tmpv1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv400(i,k,j)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) -xkx(i,k,j)*a_Tmpv1
a_xkx(i,k,j) =a_xkx(i,k,j) -mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv402(i,k,j)*a_Tmpv2
a_mu(i,j) =a_mu(i,j) -xkx(i,k,j)*a_Tmpv1
a_xkx(i,k,j) =a_xkx(i,k,j) -mu(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
!LPB[12]
! i_start =i_start-is_ext
! i_end =i_end+ie_ext
! j_start =j_start-js_ext
! j_end =j_end+je_ext
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =ite
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_end =min(jde-1, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_end =min(ide-1, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =ite
! j_start =jts
! j_end =jte
END SUBROUTINE a_cal_titau_11_22_33
SUBROUTINE a_cal_titau_12_21(config_flags,titau,a_titau,mu,a_mu,xkx,a_xkx, &
defor,a_defor,mtau,a_mtau,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,a_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,a_defor,xkx,a_xkx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,a_mtau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,a_xkxavg
REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,a_muavg
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb16_mtau
INTEGER :: IX1,IX2,IX3
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004
! Revised by Ning Pan, 2010-08-10
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv400
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv401
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv402
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: Tmpv400, Tmpv401, Tmpv402
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = ite
j_start = jts
j_end = jte
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested ) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested ) i_end = MIN( ide-1, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested ) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested ) j_end = MIN( jde-1, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[12]
i_start = i_start - is_ext
i_end = i_end + ie_ext
j_start = j_start - js_ext
j_end = j_end + je_ext
!LPB[13]
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
xkxavg(i,k,j) = 0.25 * ( xkx(i-1,k,j ) + xkx(i,k,j ) + &
xkx(i-1,k,j-1) + xkx(i,k,j-1) )
END DO
END DO
END DO
!LPB[14]
DO j = j_start, j_end
DO i = i_start, i_end
muavg(i,j) = 0.25 * ( mu(i-1,j ) + mu(i,j ) + &
mu(i-1,j-1) + mu(i,j-1) )
END DO
END DO
!LPB[15]
!!LPB[16]
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb16_mtau(IX1,IX2,IX3) =mtau(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
! IF ( config_flags%sfs_opt .GT. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! titau(i,k,j) = muavg(i,j) * mtau(i,k,j)
! END DO
! END DO
! END DO
! ELSE
! IF ( config_flags%m_opt .EQ. 1 ) THEN
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j)
! mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
! END DO
! END DO
! END DO
! ELSE
! DO j = j_start, j_end
! DO k = kts, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j)
! END DO
! END DO
! END DO
! ENDIF
! ENDIF
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K1_ADJ =jts-1, jte+1
Do K0_ADJ =its-1, ite+1
a_muavg(K0_ADJ,K1_ADJ) =0.0
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[16]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! mtau(IX1,IX2,IX3) =Keep_Lpb16_mtau(IX1,IX2,IX3)
! END DO
! END DO
! END DO
IF( config_flags%sfs_opt .GT. 0 ) THEN
! Remarked by Ning Pan, 2010-08-10
! DO j =j_start, j_end
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =muavg(i,j)*mtau(i,k,j)
! titau(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =-muavg(i,j)*xkxavg(i,k,j)
Tmpv400(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv400(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =-xkxavg(i,k,j)*defor(i,k,j)
! Tmpv401(i,k,j) =mtau(i,k,j)
! mtau(i,k,j) =Tmpv001
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts, ktf
DO i =i_start, i_end
Tmpv001 =-muavg(i,j)*xkxavg(i,k,j)
Tmpv402(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv402(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_muavg(i,j) =a_muavg(i,j) +mtau(i,k,j)*a_Tmpv1
a_mtau(i,k,j) =a_mtau(i,k,j) +muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
! mtau(i,k,j) =Tmpv401(i,k,j) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv1 =a_mtau(i,k,j)
a_mtau(i,k,j) =0.0
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -defor(i,k,j)*a_Tmpv1
a_defor(i,k,j) =a_defor(i,k,j) -xkxavg(i,k,j)*a_Tmpv1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv400(i,k,j)*a_Tmpv2
a_muavg(i,j) =a_muavg(i,j) -xkxavg(i,k,j)*a_Tmpv1
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv402(i,k,j)*a_Tmpv2
a_muavg(i,j) =a_muavg(i,j) -xkxavg(i,k,j)*a_Tmpv1
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
!LPB[15]
!LPB[14]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! Tmpv001 =mu(i-1,j) +mu(i,j)
! Tmpv002 =Tmpv001 +mu(i-1,j-1)
! Tmpv003 =Tmpv002 +mu(i,j-1)
! Tmpv004 =0.25*Tmpv003
! muavg(i,j) =Tmpv004
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv4 =a_muavg(i,j)
a_muavg(i,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_mu(i-1,j-1) =a_mu(i-1,j-1) +a_Tmpv2
a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
! DO k =kts, ktf
! DO i =i_start, i_end
! Tmpv001 =xkx(i-1,k,j) +xkx(i,k,j)
! Tmpv002 =Tmpv001 +xkx(i-1,k,j-1)
! Tmpv003 =Tmpv002 +xkx(i,k,j-1)
! Tmpv004 =0.25*Tmpv003
! xkxavg(i,k,j) =Tmpv004
! ENDDO
! ENDDO
DO k =ktf, kts, -1
DO i =i_end, i_start, -1
a_Tmpv4 =a_xkxavg(i,k,j)
a_xkxavg(i,k,j) =0.0
a_Tmpv3 =0.25*a_Tmpv4
a_Tmpv2 =a_Tmpv3
a_xkx(i,k,j-1) =a_xkx(i,k,j-1) +a_Tmpv3
a_Tmpv1 =a_Tmpv2
a_xkx(i-1,k,j-1) =a_xkx(i-1,k,j-1) +a_Tmpv2
a_xkx(i-1,k,j) =a_xkx(i-1,k,j) +a_Tmpv1
a_xkx(i,k,j) =a_xkx(i,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! i_start =i_start-is_ext
! i_end =i_end+ie_ext
! j_start =j_start-js_ext
! j_end =j_end+je_ext
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =ite
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested ) THEN
! j_end =min(jde-1, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested ) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested ) THEN
! i_end =min(ide-1, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested ) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested ) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =ite
! j_start =jts
! j_end =jte
END SUBROUTINE a_cal_titau_12_21
SUBROUTINE a_cal_titau_13_31(config_flags,titau,a_titau,defor,a_defor,mtau, &
a_mtau,mu,a_mu,xkx,a_xkx,fnm,fnp,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(kms:kme) :: fnm,fnp
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,a_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,a_defor,xkx,a_xkx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,a_mtau
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,a_xkxavg
REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,a_muavg
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb16_mtau
INTEGER :: IX1,IX2,IX3
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006
! Revised by Ning Pan, 2010-08-10
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts+1:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv400
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts+1:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv401
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts+1:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv402
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: Tmpv400, Tmpv401, Tmpv402
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = ite
j_start = jts
j_end = MIN( jte, jde-1 )
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-1, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-2, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = ite
!LPB[12]
i_start = i_start - is_ext
i_end = i_end + ie_ext
j_start = j_start - js_ext
j_end = j_end + je_ext
!LPB[13]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end
xkxavg(i,k,j) = 0.5 * ( fnm(k) * ( xkx(i,k ,j) + xkx(i-1,k ,j) ) + &
fnp(k) * ( xkx(i,k-1,j) + xkx(i-1,k-1,j) ) )
END DO
END DO
END DO
!LPB[14]
DO j = j_start, j_end
DO i = i_start, i_end
muavg(i,j) = 0.5 * ( mu(i,j) + mu(i-1,j) )
END DO
END DO
!LPB[15]
!!LPB[16]
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb16_mtau(IX1,IX2,IX3) =mtau(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
! IF ( config_flags%sfs_opt .GT. 0 ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! titau(i,k,j) = muavg(i,j) * mtau(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ELSE
! IF ( config_flags%m_opt .EQ. 1 ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j)
! mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ELSE
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j)
! ENDDO
! ENDDO
! ENDDO
! ENDIF
! ENDIF
!!LPB[17]
! DO j = j_start, j_end
!
! DO i = i_start, i_end
! titau(i,kts ,j) = 0.0
! titau(i,ktf+1,j) = 0.0
! ENDDO
! ENDDO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K1_ADJ =jts-1, jte+1
Do K0_ADJ =its-1, ite+1
a_muavg(K0_ADJ,K1_ADJ) =0.0
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[17]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! titau(i,kts,j) =0.0
! titau(i,ktf+1,j) =0.0
! ENDDO
DO i =i_end, i_start, -1
a_titau(i,ktf+1,j) =0.0
a_titau(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[16]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! mtau(IX1,IX2,IX3) =Keep_Lpb16_mtau(IX1,IX2,IX3)
! END DO
! END DO
! END DO
IF( config_flags%sfs_opt .GT. 0 ) THEN
! Remarked by Ning Pan, 2010-08-10
! DO j =j_start, j_end
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =muavg(i,j)*mtau(i,k,j)
! titau(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =-muavg(i,j)*xkxavg(i,k,j)
Tmpv400(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv400(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =-xkxavg(i,k,j)*defor(i,k,j)
! Tmpv401(i,k,j) =mtau(i,k,j)
! mtau(i,k,j) =Tmpv001
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =-muavg(i,j)*xkxavg(i,k,j)
Tmpv402(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv402(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF( config_flags%sfs_opt .GT. 0 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_muavg(i,j) =a_muavg(i,j) +mtau(i,k,j)*a_Tmpv1
a_mtau(i,k,j) =a_mtau(i,k,j) +muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
! mtau(i,k,j) =Tmpv401(i,k,j) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv1 =a_mtau(i,k,j)
a_mtau(i,k,j) =0.0
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -defor(i,k,j)*a_Tmpv1
a_defor(i,k,j) =a_defor(i,k,j) -xkxavg(i,k,j)*a_Tmpv1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv400(i,k,j)*a_Tmpv2
a_muavg(i,j) =a_muavg(i,j) -xkxavg(i,k,j)*a_Tmpv1
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv402(i,k,j)*a_Tmpv2
a_muavg(i,j) =a_muavg(i,j) -xkxavg(i,k,j)*a_Tmpv1
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
!LPB[15]
!LPB[14]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! Tmpv001 =mu(i,j) +mu(i-1,j)
! Tmpv002 =0.5*Tmpv001
! muavg(i,j) =Tmpv002
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv2 =a_muavg(i,j)
a_muavg(i,j) =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv1
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =xkx(i,k,j) +xkx(i-1,k,j)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =xkx(i,k-1,j) +xkx(i-1,k-1,j)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! xkxavg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_xkxavg(i,k,j)
a_xkxavg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_xkx(i,k-1,j) =a_xkx(i,k-1,j) +a_Tmpv3
a_xkx(i-1,k-1,j) =a_xkx(i-1,k-1,j) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_xkx(i,k,j) =a_xkx(i,k,j) +a_Tmpv1
a_xkx(i-1,k,j) =a_xkx(i-1,k,j) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! i_start =i_start-is_ext
! i_end =i_end+ie_ext
! j_start =j_start-js_ext
! j_end =j_end+je_ext
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =ite
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_end =min(jde-2, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_end =min(ide-1, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =ite
! j_start =jts
! j_end =min(jte, jde-1)
END SUBROUTINE a_cal_titau_13_31
SUBROUTINE a_cal_titau_23_32(config_flags,titau,a_titau,defor,a_defor,mtau, &
a_mtau,mu,a_mu,xkx,a_xkx,fnm,fnp,rho,a_rho,is_ext,ie_ext,js_ext,je_ext,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
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
INTEGER :: is_ext,ie_ext,js_ext,je_ext
REAL,DIMENSION(kms:kme) :: fnm,fnp
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: titau,a_titau
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: defor,a_defor,xkx,a_xkx
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rho, a_rho
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: mtau,a_mtau
REAL,DIMENSION(ims:ime,jms:jme) :: mu,a_mu
INTEGER :: i,j,k,ktf,i_start,i_end,j_start,j_end
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: xkxavg,a_xkxavg
REAL,DIMENSION(its-1:ite+1,jts-1:jte+1) :: muavg,a_muavg
! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb16_mtau
INTEGER :: IX1,IX2,IX3
REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, &
a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006
! Revised by Ning Pan, 2010-08-10
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts+1:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv400
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts+1:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv401
! REAL,DIMENSION(i_start-is_ext:i_end+ie_ext,kts+1:min(kte,kde-1),j_start-js_ext:j_end+ &
! je_ext) :: Tmpv402
REAL,DIMENSION(its-1:ite+1,kts:kte,jts-1:jte+1) :: Tmpv400, Tmpv401, Tmpv402
!PART II: CALCULATIONS OF B. S. TRAJECTORY
!LPB[0]
ktf = MIN( kte, kde-1 )
i_start = its
i_end = MIN( ite, ide-1 )
j_start = jts
j_end = jte
!LPB[1]
IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
config_flags%nested) i_start = MAX( ids+1, its )
!LPB[2]
!LPB[3]
IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
config_flags%nested) i_end = MIN( ide-2, ite )
!LPB[4]
!LPB[5]
IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
config_flags%nested) j_start = MAX( jds+1, jts )
!LPB[6]
!LPB[7]
IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
config_flags%nested) j_end = MIN( jde-1, jte )
!LPB[8]
!LPB[9]
IF ( config_flags%periodic_x ) i_start = its
!LPB[10]
!LPB[11]
IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
!LPB[12]
i_start = i_start - is_ext
i_end = i_end + ie_ext
j_start = j_start - js_ext
j_end = j_end + je_ext
!LPB[13]
DO j = j_start, j_end
DO k = kts+1, ktf
DO i = i_start, i_end
xkxavg(i,k,j) = 0.5 * ( fnm(k) * ( xkx(i,k ,j) + xkx(i,k ,j-1) ) + &
fnp(k) * ( xkx(i,k-1,j) + xkx(i,k-1,j-1) ) )
END DO
END DO
END DO
!LPB[14]
DO j = j_start, j_end
DO i = i_start, i_end
muavg(i,j) = 0.5 * ( mu(i,j) + mu(i,j-1) )
END DO
END DO
!LPB[15]
!!LPB[16]
!! DO IX3=jms,jme
!! DO IX2=kms,kme
!! DO IX1=ims,ime
! ! Keep_Lpb16_mtau(IX1,IX2,IX3) =mtau(IX1,IX2,IX3)
!! END DO
!! END DO
!! END DO
! IF ( config_flags%sfs_opt .EQ. 1 ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! titau(i,k,j) = muavg(i,j) * mtau(i,k,j)
! END DO
! END DO
! END DO
! ELSE
! IF ( config_flags%m_opt .EQ. 1 ) THEN
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j)
! mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
! END DO
! END DO
! END DO
! ELSE
! DO j = j_start, j_end
! DO k = kts+1, ktf
! DO i = i_start, i_end
! titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j)
! END DO
! END DO
! END DO
! ENDIF
! ENDIF
!!LPB[17]
! DO j = j_start, j_end
!
! DO i = i_start, i_end
! titau(i,kts ,j) = 0.0
! titau(i,ktf+1,j) = 0.0
! END DO
! END DO
!PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS
Do K2_ADJ =jts-1, jte+1
Do K1_ADJ =kts, kte
Do K0_ADJ =its-1, ite+1
a_xkxavg(K0_ADJ,K1_ADJ,K2_ADJ) =0.0
End Do
End Do
End Do
Do K1_ADJ =jts-1, jte+1
Do K0_ADJ =its-1, ite+1
a_muavg(K0_ADJ,K1_ADJ) =0.0
End Do
End Do
!PART IV: REVERSE/BACKWARD ACCUMULATIONS
!LPB[17]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! titau(i,kts,j) =0.0
! titau(i,ktf+1,j) =0.0
! ENDDO
DO i =i_end, i_start, -1
a_titau(i,ktf+1,j) =0.0
a_titau(i,kts,j) =0.0
ENDDO
ENDDO
!LPB[16]
! DO IX3=jms,jme
! DO IX2=kms,kme
! DO IX1=ims,ime
! mtau(IX1,IX2,IX3) =Keep_Lpb16_mtau(IX1,IX2,IX3)
! END DO
! END DO
! END DO
IF( config_flags%sfs_opt .EQ. 1 ) THEN
! Remarked by Ning Pan, 2010-08-10
! DO j =j_start, j_end
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =muavg(i,j)*mtau(i,k,j)
! titau(i,k,j) =Tmpv001
! ENDDO
! ENDDO
! ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =-muavg(i,j)*xkxavg(i,k,j)
Tmpv400(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv400(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
! Remarked by Ning Pan, 2010-08-10
! Tmpv001 =-xkxavg(i,k,j)*defor(i,k,j)
! Tmpv401(i,k,j) =mtau(i,k,j)
! mtau(i,k,j) =Tmpv001
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_start, j_end
DO k =kts+1, ktf
DO i =i_start, i_end
Tmpv001 =-muavg(i,j)*xkxavg(i,k,j)
Tmpv402(i,k,j) =Tmpv001
! Remarked by Ning Pan, 2010-08-10
! Tmpv002 =Tmpv402(i,k,j)*defor(i,k,j)
! titau(i,k,j) =Tmpv002
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF( config_flags%sfs_opt .EQ. 1 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv1 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_muavg(i,j) =a_muavg(i,j) +mtau(i,k,j)*a_Tmpv1
a_mtau(i,k,j) =a_mtau(i,k,j) +muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
IF( config_flags%m_opt .EQ. 1 ) THEN
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
! mtau(i,k,j) =Tmpv401(i,k,j) ! Remarked by Ning Pan, 2010-08-10
a_Tmpv1 =a_mtau(i,k,j)
a_mtau(i,k,j) =0.0
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -defor(i,k,j)*a_Tmpv1
a_defor(i,k,j) =a_defor(i,k,j) -xkxavg(i,k,j)*a_Tmpv1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv400(i,k,j)*a_Tmpv2
a_muavg(i,j) =a_muavg(i,j) -xkxavg(i,k,j)*a_Tmpv1
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ELSE
DO j =j_end, j_start, -1
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv2 =a_titau(i,k,j)
a_titau(i,k,j) =0.0
a_Tmpv1 =defor(i,k,j)*a_Tmpv2
a_defor(i,k,j) =a_defor(i,k,j) +Tmpv402(i,k,j)*a_Tmpv2
a_muavg(i,j) =a_muavg(i,j) -xkxavg(i,k,j)*a_Tmpv1
a_xkxavg(i,k,j) =a_xkxavg(i,k,j) -muavg(i,j)*a_Tmpv1
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
!LPB[15]
!LPB[14]
DO j =j_end, j_start, -1
! DO i =i_start, i_end
! Tmpv001 =mu(i,j) +mu(i,j-1)
! Tmpv002 =0.5*Tmpv001
! muavg(i,j) =Tmpv002
! ENDDO
DO i =i_end, i_start, -1
a_Tmpv2 =a_muavg(i,j)
a_muavg(i,j) =0.0
a_Tmpv1 =0.5*a_Tmpv2
a_mu(i,j) =a_mu(i,j) +a_Tmpv1
a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv1
ENDDO
ENDDO
!LPB[13]
DO j =j_end, j_start, -1
! DO k =kts+1, ktf
! DO i =i_start, i_end
! Tmpv001 =xkx(i,k,j) +xkx(i,k,j-1)
! Tmpv002 =fnm(k)*Tmpv001
! Tmpv003 =xkx(i,k-1,j) +xkx(i,k-1,j-1)
! Tmpv004 =fnp(k)*Tmpv003
! Tmpv005 =Tmpv002 +Tmpv004
! Tmpv006 =0.5*Tmpv005
! xkxavg(i,k,j) =Tmpv006
! ENDDO
! ENDDO
DO k =ktf, kts+1, -1
DO i =i_end, i_start, -1
a_Tmpv6 =a_xkxavg(i,k,j)
a_xkxavg(i,k,j) =0.0
a_Tmpv5 =0.5*a_Tmpv6
a_Tmpv2 =a_Tmpv5
a_Tmpv4 =a_Tmpv5
a_Tmpv3 =fnp(k)*a_Tmpv4
a_xkx(i,k-1,j) =a_xkx(i,k-1,j) +a_Tmpv3
a_xkx(i,k-1,j-1) =a_xkx(i,k-1,j-1) +a_Tmpv3
a_Tmpv1 =fnm(k)*a_Tmpv2
a_xkx(i,k,j) =a_xkx(i,k,j) +a_Tmpv1
a_xkx(i,k,j-1) =a_xkx(i,k,j-1) +a_Tmpv1
ENDDO
ENDDO
ENDDO
!LPB[12]
! i_start =i_start-is_ext
! i_end =i_end+ie_ext
! j_start =j_start-js_ext
! j_end =j_end+je_ext
!LPB[11]
! IF( config_flags%periodic_x ) THEN
! i_end =min(ite, ide-1)
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[10]
!LPB[9]
! IF( config_flags%periodic_x ) THEN
! i_start =its
! END IF
! IF( config_flags%periodic_x ) THEN
! END IF
!LPB[8]
!LPB[7]
! IF( config_flags%open_ye .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_end =min(jde-1, jte)
! END IF
! IF( config_flags%open_ye .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[6]
!LPB[5]
! IF( config_flags%open_ys .OR. config_flags%specified .OR. config_flags%nested) THEN
! j_start =max(jds+1, jts)
! END IF
! IF( config_flags%open_ys .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[4]
!LPB[3]
! IF( config_flags%open_xe .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_end =min(ide-2, ite)
! END IF
! IF( config_flags%open_xe .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[2]
!LPB[1]
! IF( config_flags%open_xs .OR. config_flags%specified .OR. config_flags%nested) THEN
! i_start =max(ids+1, its)
! END IF
! IF( config_flags%open_xs .OR. config_flags%specified .OR. &
! config_flags%nested) THEN
! END IF
!LPB[0]
! ktf =min(kte, kde-1)
! i_start =its
! i_end =min(ite, ide-1)
! j_start =jts
! j_end =jte
END SUBROUTINE a_cal_titau_23_32
END MODULE a_module_diffusion_em