! ====================================================================================== ! 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 REAL, DIMENSION( ims:ime, jms:jme ) & :: hpbl REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) & :: dlk REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) & :: xkmv_meso,xkmh_t !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, & hpbl,dlk,xkmv_meso, & defor11,defor22,defor12,zx,zy, & 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 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) & :: tke_buoy_tend, tke_shear_tend REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) & :: l_scale REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) & :: nlflux, dlk REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) & :: xkmh_t REAL, DIMENSION( ims:ime, jms:jme ) & :: hpbl !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, & nlflux, & 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, & hpbl, dlk, l_scale, & 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) :: & u_h_tend,& v_h_tend 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