! ====================================================================================== ! This file was generated by the version 4.3.6 of ADG on 06/26/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 ! ====================================================================================== ! Ning Pan, 2010-07-10: Change Adj_ to a_ ! Ning Pan, 2010-07-11: Change the order of arguments MODULE a_module_small_step_em USE module_model_constants USE module_configure CONTAINS SUBROUTINE a_advance_all (a_u, ru_tend, a_ru_tend, a_v, rv_tend, a_rv_tend, & a_w, rw_tend, a_rw_tend, a_t, t_tend, a_t_tend, & a_mu, a_mu_tend, a_ph, ph_tend, a_ph_tend, & muu, a_muu, muv, a_muv, mut, a_mut, & msfuy, msfvx, msfty, & dts, & config_flags, spec_zone, & 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 ! religion first TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: spec_zone REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & INTENT(IN ) :: & a_u, & a_v, & a_w, & a_t, & a_ph REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & INTENT(INOUT) :: & a_ru_tend, & a_rv_tend, & a_rw_tend, & a_t_tend, & a_ph_tend REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & INTENT(IN ) :: & ru_tend, & rv_tend, & rw_tend, & t_tend, & ph_tend REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: a_mu REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: a_mu_tend REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: a_muu, & a_muv, & a_mut REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: muu, & muv, & mut REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msfuy, & msfvx, & msfty REAL, INTENT(IN ) :: dts INTEGER :: i,j,k, i_start, i_end, j_start, j_end, k_start, k_end INTEGER :: i_endu, j_endv, k_endw INTEGER :: i_start_u_tend, i_end_u_tend, j_start_v_tend, j_end_v_tend ! ! ! advance_all advances the explicit perturbation horizontal momentum ! equations (u,v) by adding in the large-timestep tendency along with ! the small timestep pressure gradient tendency. ! ! now, the real work. ! set the loop bounds taking into account boundary conditions. i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 IF ( .NOT. config_flags%periodic_x )THEN IF ( config_flags%specified .or. config_flags%nested ) then i_start = max(its,ids+1) i_end = min(ite,ide-2) ENDIF ENDIF IF ( config_flags%specified .or. config_flags%nested ) then j_start = max(jts,jds+1) j_end = min(jte,jde-2) ENDIF IF ( config_flags%non_hydrostatic ) THEN j_loop_w: DO j = j_start, j_end DO k=2,k_end+1 DO i=i_start, i_end a_ph_tend(i,k,j) = a_ph_tend(i,k,j) & + dts*msfty(i,j)/mut(i,j) * a_ph(i,k,j) a_mut(i,j) = a_mut(i,j) & - dts*msfty(i,j)*ph_tend(i,k,j)/(mut(i,j)*mut(i,j)) * a_ph(i,k,j) a_rw_tend(i,k,j) = a_rw_tend(i,k,j) & + dts*msfty(i,j)/mut(i,j) * a_w(i,k,j) a_mut(i,j) = a_mut(i,j) & - dts*msfty(i,j)*rw_tend(i,k,j)/(mut(i,j)*mut(i,j)) * a_w(i,k,j) ENDDO ENDDO ENDDO j_loop_w ENDIF i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 IF ( .NOT. config_flags%periodic_x )THEN IF ( config_flags%specified .or. config_flags%nested ) then i_start = max(its,ids+1) i_end = min(ite,ide-2) ENDIF ENDIF IF ( config_flags%specified .or. config_flags%nested ) then j_start = max(jts,jds+1) j_end = min(jte,jde-2) ENDIF DO j=j_start, j_end DO k=1,k_end DO i=i_start, i_end a_t_tend(i,k,j) = a_t_tend(i,k,j) & + dts*msfty(i,j)/mut(i,j) * a_t(i,k,j) a_mut(i,j) = a_mut(i,j) & - dts*msfty(i,j)*t_tend(i,k,j)/(mut(i,j)*mut(i,j)) * a_t(i,k,j) END DO END DO ENDDO DO j = j_start, j_end DO i=i_start, i_end a_mu_tend(i,j) = a_mu_tend(i,j)+dts * a_mu(i,j) ENDDO ENDDO IF( config_flags%nested .or. config_flags%specified ) THEN i_start = max( its,ids+spec_zone ) i_end = min( ite,ide-spec_zone-1 ) j_start = max( jts,jds+spec_zone ) j_end = min( jte,jde-spec_zone-1 ) k_start = kts k_end = min( kte, kde-1 ) i_endu = min( ite,ide-spec_zone ) j_endv = min( jte,jde-spec_zone ) k_endw = k_end IF( config_flags%periodic_x) THEN i_start = its i_end = min(ite,ide-1) i_endu = ite ENDIF ELSE i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 i_endu = ite j_endv = jte k_endw = k_end ENDIF i_start_u_tend = i_start i_end_u_tend = i_endu j_start_v_tend = j_start j_end_v_tend = j_endv IF ( config_flags%symmetric_xs .and. (its == ids) ) & i_start_u_tend = i_start_u_tend+1 IF ( config_flags%symmetric_xe .and. (ite == ide) ) & i_end_u_tend = i_end_u_tend-1 IF ( config_flags%symmetric_ys .and. (jts == jds) ) & j_start_v_tend = j_start_v_tend+1 IF ( config_flags%symmetric_ye .and. (jte == jde) ) & j_end_v_tend = j_end_v_tend-1 v_outer_j_loop: DO j = j_start_v_tend, j_end_v_tend DO k = k_start, k_end DO i = i_start, i_end a_rv_tend(i,k,j) = a_rv_tend(i,k,j) & + dts*msfvx(i,j)/muv(i,j) * a_v(i,k,j) a_muv(i,j) = a_muv(i,j) & - dts*msfvx(i,j)*rv_tend(i,k,j)/(muv(i,j)*muv(i,j)) * a_v(i,k,j) ENDDO ENDDO ENDDO v_outer_j_loop u_outer_j_loop: DO j = j_start, j_end DO k = k_start, k_end DO i = i_start_u_tend, i_end_u_tend a_ru_tend(i,k,j) = a_ru_tend(i,k,j) & + dts*msfuy(i,j)/muu(i,j) * a_u(i,k,j) a_muu(i,j) = a_muu(i,j) & - dts*msfuy(i,j)*ru_tend(i,k,j)/(muu(i,j)*muu(i,j)) * a_u(i,k,j) ENDDO ENDDO ENDDO u_outer_j_loop END SUBROUTINE a_advance_all SUBROUTINE a_save_ph_mu ( a_ph_1, a_ph_2, a_ph_save, & a_mu_1, a_mu_2, a_mu_save, & rk_step, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) IMPLICIT NONE ! religion first ! declarations for the stuff coming in INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: rk_step REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: a_ph_1 REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: a_ph_save REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: a_ph_2 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_mu_1 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_mu_save REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_mu_2 ! local variables INTEGER :: i, j, k INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end INTEGER :: i_endu, j_endv i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = min(kte,kde-1) DO j=j_start, j_end DO i=i_start, i_end a_mu_1(i,j)=a_mu_1(i,j)+a_mu_2(i,j) a_mu_2(i,j)=-a_mu_2(i,j) a_mu_2(i,j)=a_mu_2(i,j) + a_mu_save(i,j) a_mu_save(i,j)=0. ENDDO ENDDO DO j=j_start, j_end ! DO k=k_start, min(kde,kte) DO k=k_start, kde DO i=i_start, i_end a_ph_1(i,k,j) = a_ph_1(i,k,j) + a_ph_2(i,k,j) a_ph_2(i,k,j) = -a_ph_2(i,k,j) a_ph_2(i,k,j) = a_ph_2(i,k,j) + a_ph_save(i,k,j) a_ph_save(i,k,j) = 0. ENDDO ENDDO ENDDO IF ((rk_step == 1) ) THEN DO j=j_start, j_end DO i=i_start, i_end a_mu_2(i,j) = a_mu_2(i,j) + a_mu_1(i,j) a_mu_1(i,j) = 0. ENDDO ENDDO DO j=j_start, j_end DO k=k_start, min(kde,kte) DO i=i_start, i_end a_ph_2(i,k,j) = a_ph_2(i,k,j) + a_ph_1(i,k,j) a_ph_1(i,k,j) = 0. ENDDO ENDDO ENDDO END IF END SUBROUTINE a_save_ph_mu !---------------------------------------------------------------------- SUBROUTINE a_restore_ph_mu ( a_ph_2, a_ph_save, & a_mu_2, a_mu_save, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) IMPLICIT NONE ! religion first ! declarations for the stuff coming in INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: a_ph_save REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: a_ph_2 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_mu_2 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_mu_save ! local variables INTEGER :: i, j, k INTEGER :: i_start, i_end, j_start, j_end i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) DO j = j_start, j_end DO i = i_start, i_end a_mu_save(i,j) = a_mu_save(i,j) + a_mu_2(i,j) ENDDO ENDDO DO j = j_start, j_end DO k = kds, kde DO i = i_start, i_end a_ph_save(i,k,j) = a_ph_save(i,k,j) + a_ph_2(i,k,j) ENDDO ENDDO ENDDO END SUBROUTINE a_restore_ph_mu SUBROUTINE a_small_step_prep(u_1,a_u_1,u_2,a_u_2,v_1,a_v_1,v_2,a_v_2, & w_1,a_w_1,w_2,a_w_2,t_1,a_t_1,t_2,a_t_2,ph_1,a_ph_1,ph_2,a_ph_2, & mub,mu_1,a_mu_1,mu_2,a_mu_2,muu,a_muu,muus,a_muus,muv,a_muv,muvs, & a_muvs,mut,a_mut,muts,a_muts,mudf,a_mudf,u_save,a_u_save,v_save, & a_v_save,w_save,a_w_save,t_save,a_t_save,ph_save,a_ph_save,mu_save, & a_mu_save,ww,a_ww,ww_save,a_ww_save,c2a,a_c2a,pb,p,a_p,alt,a_alt, & msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,rdx,rdy,rk_step,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 INTEGER :: ids,ide,jds,jde,kds,kde INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte INTEGER :: rk_step REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_u_1,u_1,a_v_1,v_1,a_w_1,w_1, & a_t_1,t_1,a_ph_1,ph_1 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_u_save,u_save,a_v_save,v_save, & a_w_save,w_save,a_t_save,t_save,a_ph_save,ph_save REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_u_2,u_2,a_v_2,v_2,a_w_2,w_2, & a_t_2,t_2,a_ph_2,ph_2 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_c2a,c2a,a_ww_save,ww_save REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: pb,a_p,p,a_alt,alt,a_ww,ww REAL,DIMENSION(ims:ime,jms:jme) :: a_mu_1,mu_1,a_mu_2,mu_2 REAL,DIMENSION(ims:ime,jms:jme) :: mub,a_muu,muu,a_muv,muv,a_mut,mut,msfux, & msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty REAL,DIMENSION(ims:ime,jms:jme) :: a_muus,muus,a_muvs,muvs,a_muts,muts,a_mudf,mudf REAL,DIMENSION(ims:ime,jms:jme) :: a_mu_save,mu_save REAL :: rdx,rdy INTEGER :: i,j,k INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end INTEGER :: i_endu,j_endv REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb4_u_2 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb5_v_2 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb6_t_2 ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb7_w_2 REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004 REAL,DIMENSION(its:max0(ite,min(ite,ide-1)),kts:max0(min(kte,kde-1),kde)) :: Tmpv300 !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = min(kte,kde-1) i_endu = ite j_endv = jte !LPB[1] IF ((rk_step == 1) ) THEN DO j=j_start, j_end DO i=i_start, i_end mu_1(i,j)=mu_2(i,j) ww_save(i,kde,j) = 0. ww_save(i,1,j) = 0. mudf(i,j) = 0. ENDDO ENDDO DO j=j_start, j_end DO k=k_start, k_end DO i=i_start, i_endu u_1(i,k,j) = u_2(i,k,j) ENDDO ENDDO ENDDO DO j=j_start, j_endv DO k=k_start, k_end DO i=i_start, i_end v_1(i,k,j) = v_2(i,k,j) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=k_start, k_end DO i=i_start, i_end t_1(i,k,j) = t_2(i,k,j) ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=k_start, min(kde,kte) DO i=i_start, i_end w_1(i,k,j) = w_2(i,k,j) ph_1(i,k,j) = ph_2(i,k,j) ENDDO ENDDO ENDDO DO j=j_start, j_end DO i=i_start, i_end muts(i,j)=mub(i,j)+mu_2(i,j) ENDDO DO i=i_start, i_endu muus(i,j) = muu(i,j) ENDDO ENDDO DO j=j_start, j_endv DO i=i_start, i_end muvs(i,j) = muv(i,j) ENDDO ENDDO DO j=j_start, j_end DO i=i_start, i_end mu_save(i,j)=mu_2(i,j) mu_2(i,j)=mu_2(i,j)-mu_2(i,j) ENDDO ENDDO ELSE DO j=j_start, j_end DO i=i_start, i_end muts(i,j)=mub(i,j)+mu_1(i,j) ENDDO DO i=i_start, i_endu muus(i,j)=0.5*(mub(i,j)+mu_1(i,j)+mub(i-1,j)+mu_1(i-1,j)) ENDDO ENDDO DO j=j_start, j_endv DO i=i_start, i_end muvs(i,j)=0.5*(mub(i,j)+mu_1(i,j)+mub(i,j-1)+mu_1(i,j-1)) ENDDO ENDDO DO j=j_start, j_end DO i=i_start, i_end mu_save(i,j)=mu_2(i,j) mu_2(i,j)=mu_1(i,j)-mu_2(i,j) ENDDO ENDDO END IF !LPB[2] DO j=j_start, j_end DO i=i_start, i_end ww_save(i,kde,j) = 0. ww_save(i,1,j) = 0. ENDDO ENDDO !LPB[3] DO j=j_start, j_end DO k=k_start, k_end DO i=i_start, i_end c2a(i,k,j) = cpovcv*(pb(i,k,j)+p(i,k,j))/alt(i,k,j) ENDDO ENDDO ENDDO !LPB[4] DO j=j_start, j_end DO k=k_start, k_end DO i=i_start, i_endu Keep_Lpb4_u_2(i,k,j) =u_2(i,k,j) END DO END DO DO k=k_start, k_end DO i=i_start, i_endu u_save(i,k,j) = u_2(i,k,j) u_2(i,k,j) = (muus(i,j)*u_1(i,k,j)-muu(i,j)*u_2(i,k,j))/msfuy(i,j) ENDDO ENDDO ENDDO !LPB[5] DO j=j_start, j_endv DO k=k_start, k_end DO i=i_start, i_end Keep_Lpb5_v_2(i,k,j) =v_2(i,k,j) END DO END DO DO k=k_start, k_end DO i=i_start, i_end v_save(i,k,j) = v_2(i,k,j) v_2(i,k,j) = (muvs(i,j)*v_1(i,k,j)-muv(i,j)*v_2(i,k,j))*msfvx_inv(i,j) ENDDO ENDDO ENDDO !LPB[6] DO j=j_start, j_end DO k=k_start, k_end DO i=i_start, i_end Keep_Lpb6_t_2(i,k,j) =t_2(i,k,j) END DO END DO DO k=k_start, k_end DO i=i_start, i_end t_save(i,k,j) = t_2(i,k,j) t_2(i,k,j) = muts(i,j)*t_1(i,k,j)-mut(i,j)*t_2(i,k,j) ENDDO ENDDO ENDDO !!LPB[7] ! DO j=j_start, j_end !! DO k=k_start, kde !! DO i=i_start, i_end ! ! Keep_Lpb7_w_2(i,k,j) =w_2(i,k,j) !! END DO !! END DO ! DO k=k_start, kde ! DO i=i_start, i_end ! w_save(i,k,j) = w_2(i,k,j) ! w_2(i,k,j) = (muts(i,j)* w_1(i,k,j)-mut(i,j)* w_2(i,k,j))/msfty(i,j) ! ph_save(i,k,j) = ph_2(i,k,j) ! ph_2(i,k,j) = ph_1(i,k,j)-ph_2(i,k,j) ! ENDDO ! ENDDO ! ENDDO !!LPB[8] ! DO j=j_start, j_end ! DO k=k_start, kde ! DO i=i_start, i_end ! ww_save(i,k,j) = ww(i,k,j) ! ENDDO ! ENDDO ! ENDDO !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[8] DO j =j_end, j_start, -1 ! DO k =k_start, kde ! DO i =i_start, i_end ! ww_save(i,k,j) =ww(i,k,j) ! ENDDO ! ENDDO DO k =kde, k_start, -1 DO i =i_end, i_start, -1 a_ww(i,k,j) =a_ww(i,k,j) +a_ww_save(i,k,j) a_ww_save(i,k,j) =0.0 ENDDO ENDDO ENDDO !LPB[7] DO j =j_end, j_start, -1 ! DO k=k_start, kde ! DO i=i_start, i_end ! w_2(i,k,j) =Keep_Lpb7_w_2(i,k,j) ! END DO ! END DO DO k =k_start, kde DO i =i_start, i_end ! w_save(i,k,j) =w_2(i,k,j) Tmpv001 =muts(i,j)*w_1(i,k,j) Tmpv002 =mut(i,j)*w_2(i,k,j) Tmpv003 =Tmpv001 -Tmpv002 Tmpv004 =Tmpv003/msfty(i,j) Tmpv300(i,k) =w_2(i,k,j) w_2(i,k,j) =Tmpv004 ! ph_save(i,k,j) =ph_2(i,k,j) Tmpv001 =ph_1(i,k,j) -ph_2(i,k,j) ! ph_2(i,k,j) =Tmpv001 ENDDO ENDDO DO k =kde, k_start, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_ph_2(i,k,j) a_ph_2(i,k,j) =0.0 a_ph_1(i,k,j) =a_ph_1(i,k,j) +a_Tmpv1 a_ph_2(i,k,j) =a_ph_2(i,k,j) -a_Tmpv1 a_ph_2(i,k,j) =a_ph_2(i,k,j) +a_ph_save(i,k,j) a_ph_save(i,k,j) =0.0 w_2(i,k,j) =Tmpv300(i,k) a_Tmpv4 =a_w_2(i,k,j) a_w_2(i,k,j) =0.0 a_Tmpv3 =a_Tmpv4/msfty(i,j) a_Tmpv1 =a_Tmpv3 a_Tmpv2 =-a_Tmpv3 a_mut(i,j) =a_mut(i,j) +w_2(i,k,j)*a_Tmpv2 a_w_2(i,k,j) =a_w_2(i,k,j) +mut(i,j)*a_Tmpv2 a_muts(i,j) =a_muts(i,j) +w_1(i,k,j)*a_Tmpv1 a_w_1(i,k,j) =a_w_1(i,k,j) +muts(i,j)*a_Tmpv1 a_w_2(i,k,j) =a_w_2(i,k,j) +a_w_save(i,k,j) a_w_save(i,k,j) =0.0 ENDDO ENDDO ENDDO !LPB[6] DO j =j_end, j_start, -1 DO k=k_start, k_end DO i=i_start, i_end t_2(i,k,j) =Keep_Lpb6_t_2(i,k,j) END DO END DO DO k =k_start, k_end DO i =i_start, i_end ! t_save(i,k,j) =t_2(i,k,j) Tmpv001 =muts(i,j)*t_1(i,k,j) Tmpv002 =mut(i,j)*t_2(i,k,j) Tmpv003 =Tmpv001 -Tmpv002 Tmpv300(i,k) =t_2(i,k,j) t_2(i,k,j) =Tmpv003 ENDDO ENDDO DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 t_2(i,k,j) =Tmpv300(i,k) a_Tmpv3 =a_t_2(i,k,j) a_t_2(i,k,j) =0.0 a_Tmpv1 =a_Tmpv3 a_Tmpv2 =-a_Tmpv3 a_mut(i,j) =a_mut(i,j) +t_2(i,k,j)*a_Tmpv2 a_t_2(i,k,j) =a_t_2(i,k,j) +mut(i,j)*a_Tmpv2 a_muts(i,j) =a_muts(i,j) +t_1(i,k,j)*a_Tmpv1 a_t_1(i,k,j) =a_t_1(i,k,j) +muts(i,j)*a_Tmpv1 a_t_2(i,k,j) =a_t_2(i,k,j) +a_t_save(i,k,j) a_t_save(i,k,j) =0.0 ENDDO ENDDO ENDDO !LPB[5] DO j =j_endv, j_start, -1 DO k=k_start, k_end DO i=i_start, i_end v_2(i,k,j) =Keep_Lpb5_v_2(i,k,j) ! IF(a_v_2(i,k,j).NE.0.0) PRINT*, 'a_v_2(i,k,j)=', a_v_2(i,k,j) END DO END DO DO k =k_start, k_end DO i =i_start, i_end ! v_save(i,k,j) =v_2(i,k,j) Tmpv001 =muvs(i,j)*v_1(i,k,j) Tmpv002 =muv(i,j)*v_2(i,k,j) Tmpv003 =Tmpv001 -Tmpv002 Tmpv004 =Tmpv003*msfvx_inv(i,j) Tmpv300(i,k) =v_2(i,k,j) v_2(i,k,j) =Tmpv004 ENDDO ENDDO DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 v_2(i,k,j) =Tmpv300(i,k) a_Tmpv4 =a_v_2(i,k,j) a_v_2(i,k,j) =0.0 a_Tmpv3 =msfvx_inv(i,j)*a_Tmpv4 a_Tmpv1 =a_Tmpv3 a_Tmpv2 =-a_Tmpv3 a_muv(i,j) =a_muv(i,j) +v_2(i,k,j)*a_Tmpv2 a_v_2(i,k,j) =a_v_2(i,k,j) +muv(i,j)*a_Tmpv2 a_muvs(i,j) =a_muvs(i,j) +v_1(i,k,j)*a_Tmpv1 a_v_1(i,k,j) =a_v_1(i,k,j) +muvs(i,j)*a_Tmpv1 a_v_2(i,k,j) =a_v_2(i,k,j) +a_v_save(i,k,j) a_v_save(i,k,j) =0.0 ENDDO ENDDO ENDDO !LPB[4] DO j =j_end, j_start, -1 DO k=k_start, k_end DO i=i_start, i_endu u_2(i,k,j) =Keep_Lpb4_u_2(i,k,j) END DO END DO DO k =k_start, k_end DO i =i_start, i_endu ! u_save(i,k,j) =u_2(i,k,j) Tmpv001 =muus(i,j)*u_1(i,k,j) Tmpv002 =muu(i,j)*u_2(i,k,j) Tmpv003 =Tmpv001 -Tmpv002 Tmpv004 =Tmpv003/msfuy(i,j) Tmpv300(i,k) =u_2(i,k,j) u_2(i,k,j) =Tmpv004 ENDDO ENDDO DO k =k_end, k_start, -1 DO i =i_endu, i_start, -1 u_2(i,k,j) =Tmpv300(i,k) a_Tmpv4 =a_u_2(i,k,j) a_u_2(i,k,j) =0.0 a_Tmpv3 =a_Tmpv4/msfuy(i,j) a_Tmpv1 =a_Tmpv3 a_Tmpv2 =-a_Tmpv3 a_muu(i,j) =a_muu(i,j) +u_2(i,k,j)*a_Tmpv2 a_u_2(i,k,j) =a_u_2(i,k,j) +muu(i,j)*a_Tmpv2 a_muus(i,j) =a_muus(i,j) +u_1(i,k,j)*a_Tmpv1 a_u_1(i,k,j) =a_u_1(i,k,j) +muus(i,j)*a_Tmpv1 a_u_2(i,k,j) =a_u_2(i,k,j) +a_u_save(i,k,j) a_u_save(i,k,j) =0.0 ENDDO ENDDO ENDDO !LPB[3] DO j =j_end, j_start, -1 ! DO k =k_start, k_end ! DO i =i_start, i_end ! Tmpv001 =cpovcv*(pb(i,k,j) +p(i,k,j))/alt(i,k,j) ! c2a(i,k,j) =Tmpv001 ! ENDDO ! ENDDO DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_c2a(i,k,j) a_c2a(i,k,j) =0.0 a_p(i,k,j) =a_p(i,k,j) +cpovcv/alt(i,k,j)*a_Tmpv1 a_alt(i,k,j) =a_alt(i,k,j) -cpovcv*(pb(i,k,j) +p(i,k,j))/(alt(i,k,j) & *alt(i,k,j))*a_Tmpv1 ENDDO ENDDO ENDDO !LPB[2] DO j =j_end, j_start, -1 ! DO i =i_start, i_end ! ww_save(i,kde,j) =0. ! ww_save(i,1,j) =0. ! ENDDO DO i =i_end, i_start, -1 a_ww_save(i,1,j) =0.0 a_ww_save(i,kde,j) =0.0 ENDDO ENDDO !LPB[1] ! IF((rk_step == 1) ) THEN ! DO j =j_start, j_end ! DO i =i_start, i_end ! mu_1(i,j) =mu_2(i,j) ! ww_save(i,kde,j) =0. ! ww_save(i,1,j) =0. ! mudf(i,j) =0. ! ENDDO ! ENDDO ! DO j =j_start, j_end ! DO k =k_start, k_end ! DO i =i_start, i_endu ! u_1(i,k,j) =u_2(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! DO j =j_start, j_endv ! DO k =k_start, k_end ! DO i =i_start, i_end ! v_1(i,k,j) =v_2(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! DO j =j_start, j_end ! DO k =k_start, k_end ! DO i =i_start, i_end ! t_1(i,k,j) =t_2(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! DO j =j_start, j_end ! DO k =k_start, min(kde, kte) ! DO i =i_start, i_end ! w_1(i,k,j) =w_2(i,k,j) ! ph_1(i,k,j) =ph_2(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! DO j =j_start, j_end ! DO i =i_start, i_end ! muts(i,j) =mub(i,j) +mu_2(i,j) ! ENDDO ! DO i =i_start, i_endu ! muus(i,j) =muu(i,j) ! ENDDO ! ENDDO ! DO j =j_start, j_endv ! DO i =i_start, i_end ! muvs(i,j) =muv(i,j) ! ENDDO ! ENDDO ! DO j =j_start, j_end ! DO i =i_start, i_end ! mu_save(i,j) =mu_2(i,j) ! mu_2(i,j) =mu_2(i,j) -mu_2(i,j) ! ENDDO ! ENDDO ! ELSE ! DO j =j_start, j_end ! DO i =i_start, i_end ! muts(i,j) =mub(i,j) +mu_1(i,j) ! ENDDO ! DO i =i_start, i_endu ! Tmpv001 =mub(i,j) +mu_1(i,j) +mub(i-1,j) +mu_1(i-1,j) ! Tmpv002 =0.5*Tmpv001 ! muus(i,j) =Tmpv002 ! ENDDO ! ENDDO ! DO j =j_start, j_endv ! DO i =i_start, i_end ! Tmpv001 =mub(i,j) +mu_1(i,j) +mub(i,j-1) +mu_1(i,j-1) ! Tmpv002 =0.5*Tmpv001 ! muvs(i,j) =Tmpv002 ! ENDDO ! ENDDO ! DO j =j_start, j_end ! DO i =i_start, i_end ! mu_save(i,j) =mu_2(i,j) ! Tmpv001 =mu_1(i,j) -mu_2(i,j) ! mu_2(i,j) =Tmpv001 ! ENDDO ! ENDDO ! END IF IF((rk_step == 1) ) THEN DO j =j_end, j_start, -1 DO i =i_end, i_start, -1 !BIG ERROR HERE, REVISED BY WALLS ! a_mu_2(i,j) =1.0 -1.0*a_mu_2(i,j) a_mu_2(i,j) =0.0 !REVISED BY WALLS a_mu_2(i,j) =a_mu_2(i,j) +a_mu_save(i,j) a_mu_save(i,j) =0.0 ENDDO ENDDO DO j =j_endv, j_start, -1 DO i =i_end, i_start, -1 a_muv(i,j) =a_muv(i,j) +a_muvs(i,j) a_muvs(i,j) =0.0 ENDDO ENDDO DO j =j_end, j_start, -1 DO i =i_endu, i_start, -1 a_muu(i,j) =a_muu(i,j) +a_muus(i,j) a_muus(i,j) =0.0 ENDDO DO i =i_end, i_start, -1 a_mu_2(i,j) =a_mu_2(i,j) +a_muts(i,j) a_muts(i,j) =0.0 ENDDO ENDDO DO j =j_end, j_start, -1 DO k =min(kde, kte), k_start, -1 DO i =i_end, i_start, -1 a_ph_2(i,k,j) =a_ph_2(i,k,j) +a_ph_1(i,k,j) a_ph_1(i,k,j) =0.0 a_w_2(i,k,j) =a_w_2(i,k,j) +a_w_1(i,k,j) a_w_1(i,k,j) =0.0 ENDDO ENDDO ENDDO DO j =j_end, j_start, -1 DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_t_2(i,k,j) =a_t_2(i,k,j) +a_t_1(i,k,j) a_t_1(i,k,j) =0.0 ENDDO ENDDO ENDDO DO j =j_endv, j_start, -1 DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_v_2(i,k,j) =a_v_2(i,k,j) +a_v_1(i,k,j) a_v_1(i,k,j) =0.0 ENDDO ENDDO ENDDO DO j =j_end, j_start, -1 DO k =k_end, k_start, -1 DO i =i_endu, i_start, -1 a_u_2(i,k,j) =a_u_2(i,k,j) +a_u_1(i,k,j) a_u_1(i,k,j) =0.0 ENDDO ENDDO ENDDO DO j =j_end, j_start, -1 DO i =i_end, i_start, -1 a_mudf(i,j) =0.0 a_ww_save(i,1,j) =0.0 a_ww_save(i,kde,j) =0.0 a_mu_2(i,j) =a_mu_2(i,j) +a_mu_1(i,j) a_mu_1(i,j) =0.0 ENDDO ENDDO ELSE DO j =j_end, j_start, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_mu_2(i,j) a_mu_2(i,j) =0.0 a_mu_1(i,j) =a_mu_1(i,j) +a_Tmpv1 a_mu_2(i,j) =a_mu_2(i,j) -a_Tmpv1 a_mu_2(i,j) =a_mu_2(i,j) +a_mu_save(i,j) a_mu_save(i,j) =0.0 ENDDO ENDDO DO j =j_endv, j_start, -1 DO i =i_end, i_start, -1 a_Tmpv2 =a_muvs(i,j) a_muvs(i,j) =0.0 a_Tmpv1 =0.5*a_Tmpv2 a_mu_1(i,j) =a_mu_1(i,j) +a_Tmpv1 a_mu_1(i,j-1) =a_mu_1(i,j-1) +a_Tmpv1 ENDDO ENDDO DO j =j_end, j_start, -1 DO i =i_endu, i_start, -1 a_Tmpv2 =a_muus(i,j) a_muus(i,j) =0.0 a_Tmpv1 =0.5*a_Tmpv2 a_mu_1(i,j) =a_mu_1(i,j) +a_Tmpv1 a_mu_1(i-1,j) =a_mu_1(i-1,j) +a_Tmpv1 ENDDO DO i =i_end, i_start, -1 a_mu_1(i,j) =a_mu_1(i,j) +a_muts(i,j) a_muts(i,j) =0.0 ENDDO ENDDO END IF !LPB[0] ! i_start =its ! i_end =min(ite, ide-1) ! j_start =jts ! j_end =min(jte, jde-1) ! k_start =kts ! k_end =min(kte, kde-1) ! i_endu =ite ! j_endv =jte END SUBROUTINE a_small_step_prep ! Generated by TAPENADE (INRIA, Tropics team) ! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35 ! ! Differentiation of small_step_finish in reverse (adjoint) mode: ! gradient of useful results: u_save ph_save ww w_save mu_save ! muvs ph_2 u_2 h_diabatic mu_2 w_2 t_save v_save ! muts t_2 mut muu v_2 muv ww1 muus ! with respect to varying inputs: u_save ph_save ww w_save mu_save ! muvs ph_2 u_2 h_diabatic mu_2 w_2 t_save v_save ! muts t_2 mut muu v_2 muv ww1 muus ! RW status of diff variables: u_save:incr ph_save:incr ww:in-out ! w_save:incr mu_save:incr muvs:incr ph_2:in-out ! u_2:in-out h_diabatic:incr mu_2:in-out w_2:in-out ! t_save:incr v_save:incr muts:incr t_2:in-out mut:incr ! muu:incr v_2:in-out muv:incr ww1:incr muus:incr SUBROUTINE A_SMALL_STEP_FINISH(u_2, u_2b, u_1, v_2, v_2b, v_1, w_2, w_2b& & , w_1, t_2, t_2b, t_1, ph_2, ph_2b, ph_1, ww, wwb, ww1, ww1b, mu_2, & & mu_2b, mu_1, mut, mutb, muts, mutsb, muu, muub, muus, muusb, muv, muvb& & , muvs, muvsb, u_save, u_saveb, v_save, v_saveb, w_save, w_saveb, & & t_save, t_saveb, ph_save, ph_saveb, mu_save, mu_saveb, msfux, msfuy, & & msfvx, msfvy, msftx, msfty, h_diabatic, h_diabaticb, & & number_of_small_timesteps, dts, rk_step, rk_order, ids, ide, jds, jde& & , kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte& &) IMPLICIT NONE ! religion first ! stuff passed in INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte INTEGER, INTENT(IN) :: number_of_small_timesteps INTEGER, INTENT(IN) :: rk_step, rk_order REAL, INTENT(IN) :: dts REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u_1, v_1, & & w_1, t_1, ww1, ph_1 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: ww1b REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: u_2, v_2& & , w_2, t_2, ww, ph_2 REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_2b, v_2b, w_2b, t_2b, & & wwb, ph_2b REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u_save, & & v_save, w_save, t_save, ph_save, h_diabatic REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_saveb, v_saveb, & & w_saveb, t_saveb, ph_saveb, h_diabaticb REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: muus, muvs REAL, DIMENSION(ims:ime, jms:jme) :: muusb, muvsb REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mu_2, mu_1 REAL, DIMENSION(ims:ime, jms:jme) :: mu_2b REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mut, muts, muu, & & muv, mu_save REAL, DIMENSION(ims:ime, jms:jme) :: mutb, mutsb, muub, muvb, mu_saveb REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, & & msfvy, msftx, msfty ! local stuff INTEGER :: i, j, k INTEGER :: i_start, i_end, j_start, j_end, i_endu, j_endv INTEGER :: branch REAL :: tempb4 REAL :: tempb3 REAL :: tempb2 REAL :: tempb1 REAL :: tempb0 REAL :: tempb INTRINSIC MIN ! ! ! small_step_finish reconstructs the full uncoupled prognostic variables ! from the coupled perturbation variables used in the small timesteps. ! ! 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 i_endu = ite j_endv = jte IF (rk_step .LT. rk_order) THEN CALL PUSHCONTROL1B(1) ELSE CALL PUSHCONTROL1B(0) END IF DO j=j_end,j_start,-1 DO i=i_end,i_start,-1 mu_saveb(i, j) = mu_saveb(i, j) + mu_2b(i, j) END DO END DO CALL POPCONTROL1B(branch) IF (branch .EQ. 0) THEN DO j=j_end,j_start,-1 DO k=kde-1,kds,-1 DO i=i_end,i_start,-1 tempb3 = t_2b(i, k, j)/muts(i, j) tempb4 = -(dts*number_of_small_timesteps*tempb3) mutb(i, j) = mutb(i, j) + t_save(i, k, j)*tempb3 + h_diabatic(& & i, k, j)*tempb4 h_diabaticb(i, k, j) = h_diabaticb(i, k, j) + mut(i, j)*tempb4 t_saveb(i, k, j) = t_saveb(i, k, j) + mut(i, j)*tempb3 mutsb(i, j) = mutsb(i, j) - (t_2(i, k, j)-dts*& & number_of_small_timesteps*(mut(i, j)*h_diabatic(i, k, j))+& & t_save(i, k, j)*mut(i, j))*tempb3/muts(i, j) t_2b(i, k, j) = tempb3 END DO END DO END DO ELSE DO j=j_end,j_start,-1 DO k=kde-1,kds,-1 DO i=i_end,i_start,-1 tempb2 = t_2b(i, k, j)/muts(i, j) t_saveb(i, k, j) = t_saveb(i, k, j) + mut(i, j)*tempb2 mutb(i, j) = mutb(i, j) + t_save(i, k, j)*tempb2 mutsb(i, j) = mutsb(i, j) - (t_2(i, k, j)+t_save(i, k, j)*mut(& & i, j))*tempb2/muts(i, j) t_2b(i, k, j) = tempb2 END DO END DO END DO END IF DO j=j_end,j_start,-1 DO k=kde,kds,-1 DO i=i_end,i_start,-1 ww1b(i, k, j) = ww1b(i, k, j) + wwb(i, k, j) ph_saveb(i, k, j) = ph_saveb(i, k, j) + ph_2b(i, k, j) tempb1 = w_2b(i, k, j)/muts(i, j) w_saveb(i, k, j) = w_saveb(i, k, j) + mut(i, j)*tempb1 mutb(i, j) = mutb(i, j) + w_save(i, k, j)*tempb1 mutsb(i, j) = mutsb(i, j) - (msfty(i, j)*w_2(i, k, j)+w_save(i, & & k, j)*mut(i, j))*tempb1/muts(i, j) w_2b(i, k, j) = msfty(i, j)*tempb1 END DO END DO END DO DO j=j_end,j_start,-1 DO k=kde-1,kds,-1 DO i=i_endu,i_start,-1 tempb0 = u_2b(i, k, j)/muus(i, j) u_saveb(i, k, j) = u_saveb(i, k, j) + muu(i, j)*tempb0 muub(i, j) = muub(i, j) + u_save(i, k, j)*tempb0 muusb(i, j) = muusb(i, j) - (msfuy(i, j)*u_2(i, k, j)+u_save(i, & & k, j)*muu(i, j))*tempb0/muus(i, j) u_2b(i, k, j) = msfuy(i, j)*tempb0 END DO END DO END DO DO j=j_endv,j_start,-1 DO k=kde-1,kds,-1 DO i=i_end,i_start,-1 tempb = v_2b(i, k, j)/muvs(i, j) v_saveb(i, k, j) = v_saveb(i, k, j) + muv(i, j)*tempb muvb(i, j) = muvb(i, j) + v_save(i, k, j)*tempb muvsb(i, j) = muvsb(i, j) - (msfvx(i, j)*v_2(i, k, j)+v_save(i, & & k, j)*muv(i, j))*tempb/muvs(i, j) v_2b(i, k, j) = msfvx(i, j)*tempb END DO END DO END DO END SUBROUTINE A_SMALL_STEP_FINISH SUBROUTINE a_calc_p_rho(al,a_al,p,a_p,ph,a_ph,alt,a_alt,t_2,a_t_2, & t_1,a_t_1,c2a,a_c2a,pm1,a_pm1,mu,a_mu,muts,a_muts,znu,t0,rdnw,dnw, & smdiv,non_hydrostatic,step,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 INTEGER :: ids,ide,jds,jde,kds,kde INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte INTEGER :: step REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_al,al,a_p,p REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_alt,alt,a_t_2,t_2,a_t_1,t_1,a_c2a,c2a REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_ph,ph,a_pm1,pm1 REAL,DIMENSION(ims:ime,jms:jme) :: a_mu,mu,a_muts,muts REAL,DIMENSION(kms:kme) :: dnw,rdnw,znu REAL :: t0,smdiv LOGICAL :: non_hydrostatic INTEGER :: i,j,k INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end REAL :: a_ptmp,ptmp ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb1_ph INTEGER :: IX1,IX2,IX3 REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, & a_Tmpv5,Tmpv005,a_Tmpv6,Tmpv006,a_Tmpv7,Tmpv007 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv400 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv401 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv402 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv403 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv404 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv405 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv406 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv407 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv408 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv409 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv4010 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Tmpv4011 !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = min(kte,kde-1) !!LPB[1] !! DO IX3=jms,jme !! DO IX2=kms,kme !! DO IX1=ims,ime ! ! Keep_Lpb1_ph(IX1,IX2,IX3) =ph(IX1,IX2,IX3) !! END DO !! END DO !! END DO ! IF (non_hydrostatic) THEN ! DO j=j_start, j_end ! DO k=k_start, k_end ! DO i=i_start, i_end ! al(i,k,j)=-1./muts(i,j)*(alt(i,k,j)*mu(i,j) & ! +rdnw(k)*(ph(i,k+1,j)-ph(i,k,j))) ! p(i,k,j)=c2a(i,k,j)*(alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & ! /(muts(i,j)*(t0+t_1(i,k,j)))-al (i,k,j)) ! ENDDO ! ENDDO ! ENDDO ! ELSE ! DO j=j_start, j_end ! DO k=k_start, k_end ! DO i=i_start, i_end ! p(i,k,j)=mu(i,j)*znu(k) ! al(i,k,j)=alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & ! /(muts(i,j)*(t0+t_1(i,k,j)))-p(i,k,j)/c2a(i,k,j) ! ph(i,k+1,j)=ph(i,k,j)-dnw(k)*(muts(i,j)*al (i,k,j) & ! +mu(i,j)*alt(i,k,j)) ! ENDDO ! ENDDO ! ENDDO ! END IF !!LPB[2] !!LPB[3] ! ! IF (step == 0) then ! DO j=j_start, j_end ! DO k=k_start, k_end ! DO i=i_start, i_end ! pm1(i,k,j)=p(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! ELSE ! DO j=j_start, j_end ! DO k=k_start, k_end ! DO i=i_start, i_end ! ptmp = p(i,k,j) ! p(i,k,j) = p(i,k,j) + smdiv*(p(i,k,j)-pm1(i,k,j)) ! pm1(i,k,j) = ptmp ! ENDDO ! ENDDO ! ENDDO ! END IF !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS a_ptmp =0.0 !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[3] ! IF(step == 0) THEN ! DO j =j_start, j_end ! DO k =k_start, k_end ! DO i =i_start, i_end ! pm1(i,k,j) =p(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! ELSE ! DO j =j_start, j_end ! DO k =k_start, k_end ! DO i =i_start, i_end ! ptmp =p(i,k,j) ! Tmpv001 =p(i,k,j) -pm1(i,k,j) ! Tmpv002 =smdiv*Tmpv001 ! Tmpv003 =p(i,k,j) +Tmpv002 ! p(i,k,j) =Tmpv003 ! pm1(i,k,j) =ptmp ! ENDDO ! ENDDO ! ENDDO ! END IF IF(step == 0) THEN DO j =j_end, j_start, -1 DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_p(i,k,j) =a_p(i,k,j) +a_pm1(i,k,j) a_pm1(i,k,j) =0.0 ENDDO ENDDO ENDDO ELSE DO j =j_end, j_start, -1 DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_ptmp =a_ptmp +a_pm1(i,k,j) a_pm1(i,k,j) =0.0 a_Tmpv3 =a_p(i,k,j) a_p(i,k,j) =0.0 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =smdiv*a_Tmpv2 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv1 a_pm1(i,k,j) =a_pm1(i,k,j) -a_Tmpv1 a_p(i,k,j) =a_p(i,k,j) +a_ptmp a_ptmp =0.0 ENDDO ENDDO ENDDO END IF !LPB[2] !LPB[1] ! DO IX3=jms,jme ! DO IX2=kms,kme ! DO IX1=ims,ime ! ph(IX1,IX2,IX3) =Keep_Lpb1_ph(IX1,IX2,IX3) ! END DO ! END DO ! END DO IF(non_hydrostatic) THEN DO j =j_start, j_end DO k =k_start, k_end DO i =i_start, i_end Tmpv001 =alt(i,k,j)*mu(i,j) Tmpv002 =ph(i,k+1,j) -ph(i,k,j) Tmpv003 =rdnw(k)*Tmpv002 Tmpv004 =Tmpv001 +Tmpv003 Tmpv400(i,k,j) =Tmpv004 Tmpv005 =-1./muts(i,j)*Tmpv400(i,k,j) Tmpv401(i,k,j) =al(i,k,j) al(i,k,j) =Tmpv005 Tmpv001 =mu(i,j)*t_1(i,k,j) Tmpv002 =t_2(i,k,j) -Tmpv001 Tmpv402(i,k,j) =Tmpv002 Tmpv003 =alt(i,k,j)*Tmpv402(i,k,j) Tmpv004 =muts(i,j)*(t0 +t_1(i,k,j)) Tmpv403(i,k,j) =Tmpv003 Tmpv404(i,k,j) =Tmpv004 Tmpv005 =Tmpv403(i,k,j)/Tmpv404(i,k,j) Tmpv006 =Tmpv005 -al(i,k,j) Tmpv405(i,k,j) =Tmpv006 Tmpv007 =c2a(i,k,j)*Tmpv405(i,k,j) Tmpv406(i,k,j) =p(i,k,j) p(i,k,j) =Tmpv007 ENDDO ENDDO ENDDO ELSE DO j =j_start, j_end DO k =k_start, k_end DO i =i_start, i_end Tmpv407(i,k,j) =p(i,k,j) p(i,k,j) =mu(i,j)*znu(k) Tmpv001 =mu(i,j)*t_1(i,k,j) Tmpv002 =t_2(i,k,j) -Tmpv001 Tmpv408(i,k,j) =Tmpv002 Tmpv003 =alt(i,k,j)*Tmpv408(i,k,j) Tmpv004 =muts(i,j)*(t0 +t_1(i,k,j)) Tmpv409(i,k,j) =Tmpv003 Tmpv4010(i,k,j) =Tmpv004 Tmpv005 =Tmpv409(i,k,j)/Tmpv4010(i,k,j) Tmpv006 =p(i,k,j)/c2a(i,k,j) Tmpv007 =Tmpv005 -Tmpv006 Tmpv4011(i,k,j) =al(i,k,j) al(i,k,j) =Tmpv007 Tmpv001 =muts(i,j)*al(i,k,j) Tmpv002 =mu(i,j)*alt(i,k,j) Tmpv003 =Tmpv001 +Tmpv002 Tmpv004 =dnw(k)*Tmpv003 Tmpv005 =ph(i,k,j) -Tmpv004 ph(i,k+1,j) =Tmpv005 ENDDO ENDDO ENDDO END IF IF(non_hydrostatic) THEN DO j =j_end, j_start, -1 DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 p(i,k,j) =Tmpv406(i,k,j) a_Tmpv7 =a_p(i,k,j) a_p(i,k,j) =0.0 a_c2a(i,k,j) =a_c2a(i,k,j) +Tmpv405(i,k,j)*a_Tmpv7 a_Tmpv6 =c2a(i,k,j)*a_Tmpv7 a_Tmpv5 =a_Tmpv6 a_al(i,k,j) =a_al(i,k,j) -a_Tmpv6 a_Tmpv3 =a_Tmpv5/Tmpv404(i,k,j) a_Tmpv4 =-Tmpv403(i,k,j)/(Tmpv404(i,k,j)*Tmpv404(i,k,j))*a_Tmpv5 a_muts(i,j) =a_muts(i,j) +(t0 +t_1(i,k,j))*a_Tmpv4 a_t_1(i,k,j) =a_t_1(i,k,j) +muts(i,j)*a_Tmpv4 a_alt(i,k,j) =a_alt(i,k,j) +Tmpv402(i,k,j)*a_Tmpv3 a_Tmpv2 =alt(i,k,j)*a_Tmpv3 a_t_2(i,k,j) =a_t_2(i,k,j) +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_mu(i,j) =a_mu(i,j) +t_1(i,k,j)*a_Tmpv1 a_t_1(i,k,j) =a_t_1(i,k,j) +mu(i,j)*a_Tmpv1 al(i,k,j) =Tmpv401(i,k,j) a_Tmpv5 =a_al(i,k,j) a_al(i,k,j) =0.0 a_muts(i,j) =a_muts(i,j) +1./(muts(i,j)*muts(i,j))*Tmpv400(i,k,j)*a_Tmpv5 a_Tmpv4 =-1./muts(i,j)*a_Tmpv5 a_Tmpv1 =a_Tmpv4 a_Tmpv3 =a_Tmpv4 a_Tmpv2 =rdnw(k)*a_Tmpv3 a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv2 a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv2 a_alt(i,k,j) =a_alt(i,k,j) +mu(i,j)*a_Tmpv1 a_mu(i,j) =a_mu(i,j) +alt(i,k,j)*a_Tmpv1 ENDDO ENDDO ENDDO ELSE DO j =j_end, j_start, -1 DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_Tmpv5 =a_ph(i,k+1,j) a_ph(i,k+1,j) =0.0 a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv5 a_Tmpv4 =-a_Tmpv5 a_Tmpv3 =dnw(k)*a_Tmpv4 a_Tmpv1 =a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_mu(i,j) =a_mu(i,j) +alt(i,k,j)*a_Tmpv2 a_alt(i,k,j) =a_alt(i,k,j) +mu(i,j)*a_Tmpv2 a_muts(i,j) =a_muts(i,j) +al(i,k,j)*a_Tmpv1 a_al(i,k,j) =a_al(i,k,j) +muts(i,j)*a_Tmpv1 al(i,k,j) =Tmpv4011(i,k,j) a_Tmpv7 =a_al(i,k,j) a_al(i,k,j) =0.0 a_Tmpv5 =a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv6/c2a(i,k,j) a_c2a(i,k,j) =a_c2a(i,k,j) -p(i,k,j)/(c2a(i,k,j)*c2a(i,k,j))*a_Tmpv6 a_Tmpv3 =a_Tmpv5/Tmpv4010(i,k,j) a_Tmpv4 =-Tmpv409(i,k,j)/(Tmpv4010(i,k,j)*Tmpv4010(i,k,j))*a_Tmpv5 a_muts(i,j) =a_muts(i,j) +(t0 +t_1(i,k,j))*a_Tmpv4 a_t_1(i,k,j) =a_t_1(i,k,j) +muts(i,j)*a_Tmpv4 a_alt(i,k,j) =a_alt(i,k,j) +Tmpv408(i,k,j)*a_Tmpv3 a_Tmpv2 =alt(i,k,j)*a_Tmpv3 a_t_2(i,k,j) =a_t_2(i,k,j) +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_mu(i,j) =a_mu(i,j) +t_1(i,k,j)*a_Tmpv1 a_t_1(i,k,j) =a_t_1(i,k,j) +mu(i,j)*a_Tmpv1 p(i,k,j) =Tmpv407(i,k,j) a_mu(i,j) =a_mu(i,j) +znu(k)*a_p(i,k,j) a_p(i,k,j) =0.0 ENDDO ENDDO ENDDO END IF !LPB[0] ! i_start =its ! i_end =min(ite, ide-1) ! j_start =jts ! j_end =min(jte, jde-1) ! k_start =kts ! k_end =min(kte, kde-1) END SUBROUTINE a_calc_p_rho SUBROUTINE a_calc_coef_w(a,a_a,alpha,a_alpha,gamma,a_gamma,mut,a_mut, & cqw,a_cqw,rdn,rdnw,c2a,a_c2a,dts,g,epssm,top_lid,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 INTEGER :: ids,ide,jds,jde,kds,kde INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte LOGICAL :: top_lid REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_c2a,c2a,a_cqw,cqw REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_alpha,alpha,a_gamma,gamma,a_a,a REAL,DIMENSION(ims:ime,jms:jme) :: a_mut,mut REAL,DIMENSION(kms:kme) :: rdn,rdnw REAL :: epssm,dts,g REAL,DIMENSION(ims:ime) :: a_cof,cof REAL :: a_b,b,a_c,c INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end INTEGER :: ij,ijp,ijm,lid_flag REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003,a_Tmpv4,Tmpv004, & a_Tmpv5,Tmpv005 REAL,DIMENSION(ims:ime) :: Tmpv200 REAL,DIMENSION(ims:ime) :: Tmpv201 REAL,DIMENSION(ims:ime) :: Tmpv202 REAL,DIMENSION(ims:ime) :: Tmpv203 REAL,DIMENSION(ims:ime) :: Tmpv204 REAL,DIMENSION(ims:ime) :: Tmpv205 REAL,DIMENSION(ims:ime) :: Tmpv206 REAL,DIMENSION(ims:ime) :: Tmpv207 REAL,DIMENSION(its:min(ite,ide-1),3:kde-1) :: Tmpv300 REAL,DIMENSION(its:min(ite,ide-1),3:kde-1) :: Tmpv301 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv302 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv303 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv304 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv305 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv306 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv307 REAL,DIMENSION(its:min(ite,ide-1),2:kde-1) :: Tmpv308 !REVISED BY WALLS !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 lid_flag=1 !LPB[1] IF(top_lid)lid_flag=0 !!LPB[2] ! outer_j_loop: DO j = j_start, j_end ! DO i = i_start, i_end ! cof(i) = (.5*dts*g*(1.+epssm)/mut(i,j))**2 ! a(i, 2 ,j) = 0. ! a(i,kde,j) =-2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j)*lid_flag ! gamma(i,1 ,j) = 0. ! ENDDO ! DO k=3,kde-1 ! DO i=i_start, i_end ! a(i,k,j) = -cqw(i,k,j)*cof(i)*rdn(k)* rdnw(k-1)*c2a(i,k-1,j) ! ENDDO ! ENDDO ! DO k=2,kde-1 ! DO i=i_start, i_end ! b = 1.+cqw(i,k,j)*cof(i)*rdn(k)*(rdnw(k )*c2a(i,k,j ) & ! +rdnw(k-1)*c2a(i,k-1,j)) ! c = -cqw(i,k,j)*cof(i)*rdn(k)*rdnw(k )*c2a(i,k,j ) ! alpha(i,k,j) = 1./(b-a(i,k,j)*gamma(i,k-1,j)) ! gamma(i,k,j) = c*alpha(i,k,j) ! ENDDO ! ENDDO ! DO i=i_start, i_end ! b = 1.+2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j) ! c = 0. ! alpha(i,kde,j) = 1./(b-a(i,kde,j)*gamma(i,kde-1,j)) ! gamma(i,kde,j) = c*alpha(i,kde,j) ! ENDDO ! ENDDO outer_j_loop !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS Do K0_ADJ =ims, ime a_cof(K0_ADJ) =0.0 End Do a_b =0.0 a_c =0.0 !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[2] DO j =j_end, j_start, -1 DO i =i_start, i_end Tmpv200(i) =cof(i) cof(i) =(.5*dts*g*(1.+epssm)/mut(i,j))**2 Tmpv201(i) =a(i,2,j) a(i,2,j) =0. Tmpv001 =-2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j) Tmpv002 =Tmpv001*lid_flag Tmpv202(i) =a(i,kde,j) a(i,kde,j) =Tmpv002 Tmpv203(i) =gamma(i,1,j) gamma(i,1,j) =0. ENDDO DO k =3, kde-1 DO i =i_start, i_end Tmpv001 =-cqw(i,k,j)*cof(i) Tmpv002 =Tmpv001*rdn(k) Tmpv003 =Tmpv002*rdnw(k-1) Tmpv300(i,k) =Tmpv003 Tmpv004 =Tmpv300(i,k)*c2a(i,k-1,j) Tmpv301(i,k) =a(i,k,j) a(i,k,j) =Tmpv004 ENDDO ENDDO DO k =2, kde-1 DO i =i_start, i_end Tmpv001 =cqw(i,k,j)*cof(i) Tmpv002 =Tmpv001*rdn(k) Tmpv003 =rdnw(k)*c2a(i,k,j) +rdnw(k-1)*c2a(i,k-1,j) Tmpv302(i,k) =Tmpv002 Tmpv303(i,k) =Tmpv003 Tmpv004 =Tmpv302(i,k)*Tmpv303(i,k) Tmpv005 =1. +Tmpv004 b =Tmpv005 Tmpv001 =-cqw(i,k,j)*cof(i) Tmpv002 =Tmpv001*rdn(k) Tmpv003 =Tmpv002*rdnw(k) Tmpv304(i,k) =Tmpv003 Tmpv004 =Tmpv304(i,k)*c2a(i,k,j) ! Tmpv305(i,k) =c c =Tmpv004 Tmpv305(i,k) =c !REVISED BY WALLS Tmpv001 =a(i,k,j)*gamma(i,k-1,j) Tmpv002 =b -Tmpv001 Tmpv308(i,k) =Tmpv002 !REVISED BY WALLS Tmpv003 =1./Tmpv002 Tmpv306(i,k) =alpha(i,k,j) alpha(i,k,j) =Tmpv003 Tmpv001 =c*alpha(i,k,j) ! Tmpv307(i,k) =gamma(i,k,j) Tmpv307(i,k) =gamma(i,k-1,j) gamma(i,k,j) =Tmpv001 ENDDO ENDDO DO i =i_start, i_end Tmpv001 =2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j) Tmpv002 =1. +Tmpv001 b =Tmpv002 Tmpv204(i) =c c =0. Tmpv001 =a(i,kde,j)*gamma(i,kde-1,j) Tmpv002 =b -Tmpv001 Tmpv207(i) = Tmpv002 ! Added by Ning Pan, 2010-08-02 Tmpv003 =1./Tmpv002 Tmpv205(i) =alpha(i,kde,j) alpha(i,kde,j) =Tmpv003 Tmpv001 =c*alpha(i,kde,j) Tmpv206(i) =gamma(i,kde,j) gamma(i,kde,j) =Tmpv001 ENDDO DO i =i_end, i_start, -1 gamma(i,kde,j) =Tmpv206(i) a_Tmpv1 =a_gamma(i,kde,j) a_gamma(i,kde,j) =0.0 a_c =a_c +alpha(i,kde,j)*a_Tmpv1 a_alpha(i,kde,j) =a_alpha(i,kde,j) +c*a_Tmpv1 alpha(i,kde,j) =Tmpv205(i) a_Tmpv3 =a_alpha(i,kde,j) a_alpha(i,kde,j) =0.0 Tmpv002 = Tmpv207(i) ! Added by Ning Pan, 2010-08-02 a_Tmpv2 =-(1.)*a_Tmpv3/(Tmpv002*Tmpv002) a_b =a_b +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_a(i,kde,j) =a_a(i,kde,j) +gamma(i,kde-1,j)*a_Tmpv1 a_gamma(i,kde-1,j) =a_gamma(i,kde-1,j) +a(i,kde,j)*a_Tmpv1 c =Tmpv204(i) a_c =0.0 a_Tmpv2 =a_b a_b =0.0 a_Tmpv1 =a_Tmpv2 a_cof(i) =a_cof(i) +2.*rdnw(kde-1)**2*c2a(i,kde-1,j)*a_Tmpv1 a_c2a(i,kde-1,j) =a_c2a(i,kde-1,j) +2.*cof(i)*rdnw(kde-1)**2*a_Tmpv1 ENDDO DO k =kde-1, 2, -1 DO i =i_end, i_start, -1 c =Tmpv305(i,k) !REVISED BY WALLS ! gamma(i,k,j) =Tmpv307(i,k) gamma(i,k-1,j) =Tmpv307(i,k) a_Tmpv1 =a_gamma(i,k,j) a_gamma(i,k,j) =0.0 a_c =a_c +alpha(i,k,j)*a_Tmpv1 a_alpha(i,k,j) =a_alpha(i,k,j) +c*a_Tmpv1 alpha(i,k,j) =Tmpv306(i,k) a_Tmpv3 =a_alpha(i,k,j) a_alpha(i,k,j) =0.0 Tmpv002 =Tmpv308(i,k) !REVISED BY WALLS a_Tmpv2 =-(1.)*a_Tmpv3/(Tmpv002*Tmpv002) a_b =a_b +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_a(i,k,j) =a_a(i,k,j) +gamma(i,k-1,j)*a_Tmpv1 a_gamma(i,k-1,j) =a_gamma(i,k-1,j) +a(i,k,j)*a_Tmpv1 ! c =Tmpv305(i,k) a_Tmpv4 =a_c a_c =0.0 a_Tmpv3 =c2a(i,k,j)*a_Tmpv4 a_c2a(i,k,j) =a_c2a(i,k,j) +Tmpv304(i,k)*a_Tmpv4 a_Tmpv2 =rdnw(k)*a_Tmpv3 a_Tmpv1 =rdn(k)*a_Tmpv2 a_cqw(i,k,j) =a_cqw(i,k,j) -cof(i)*a_Tmpv1 a_cof(i) =a_cof(i) -cqw(i,k,j)*a_Tmpv1 a_Tmpv5 =a_b a_b =0.0 a_Tmpv4 =a_Tmpv5 a_Tmpv2 =Tmpv303(i,k)*a_Tmpv4 a_Tmpv3 =Tmpv302(i,k)*a_Tmpv4 a_c2a(i,k,j) =a_c2a(i,k,j) +rdnw(k)*a_Tmpv3 a_c2a(i,k-1,j) =a_c2a(i,k-1,j) +rdnw(k-1)*a_Tmpv3 a_Tmpv1 =rdn(k)*a_Tmpv2 a_cqw(i,k,j) =a_cqw(i,k,j) +cof(i)*a_Tmpv1 a_cof(i) =a_cof(i) +cqw(i,k,j)*a_Tmpv1 ENDDO ENDDO DO k =kde-1, 3, -1 DO i =i_end, i_start, -1 a(i,k,j) =Tmpv301(i,k) a_Tmpv4 =a_a(i,k,j) a_a(i,k,j) =0.0 a_Tmpv3 =c2a(i,k-1,j)*a_Tmpv4 a_c2a(i,k-1,j) =a_c2a(i,k-1,j) +Tmpv300(i,k)*a_Tmpv4 a_Tmpv2 =rdnw(k-1)*a_Tmpv3 a_Tmpv1 =rdn(k)*a_Tmpv2 a_cqw(i,k,j) =a_cqw(i,k,j) -cof(i)*a_Tmpv1 a_cof(i) =a_cof(i) -cqw(i,k,j)*a_Tmpv1 ENDDO ENDDO DO i =i_end, i_start, -1 gamma(i,1,j) =Tmpv203(i) a_gamma(i,1,j) =0.0 a(i,kde,j) =Tmpv202(i) a_Tmpv2 =a_a(i,kde,j) a_a(i,kde,j) =0.0 a_Tmpv1 =lid_flag*a_Tmpv2 a_cof(i) =a_cof(i) -2.*rdnw(kde-1)**2*c2a(i,kde-1,j)*a_Tmpv1 a_c2a(i,kde-1,j) =a_c2a(i,kde-1,j) -2.*cof(i)*rdnw(kde-1)**2*a_Tmpv1 a(i,2,j) =Tmpv201(i) a_a(i,2,j) =0.0 cof(i) =Tmpv200(i) a_mut(i,j) =a_mut(i,j) -.5*dts*g*(1.+epssm)/(mut(i,j)*mut(i,j))*2.0*(.5*dts*g* & (1.+epssm)/mut(i,j))*a_cof(i) a_cof(i) =0.0 ENDDO ENDDO !LPB[1] ! IF(top_lid) THEN ! lid_flag =0 ! END IF ! IF(top_lid) THEN ! END IF !LPB[0] ! i_start =its ! i_end =min(ite, ide-1) ! j_start =jts ! j_end =min(jte, jde-1) ! k_start =kts ! k_end =kte-1 ! lid_flag =1 END SUBROUTINE a_calc_coef_w SUBROUTINE a_advance_uv(u,a_u,ru_tend,a_ru_tend,v,a_v,rv_tend, & a_rv_tend,p,a_p,pb,ph,a_ph,php,a_php,alt,a_alt,al,a_al,mu,a_mu, & muu,a_muu,cqu,a_cqu,muv,a_muv,cqv,a_cqv,mudf,a_mudf,msfux,msfuy,msfvx, & msfvx_inv,msfvy,rdx,rdy,dts,cf1,cf2,cf3,fnm,fnp,emdiv,rdnw,config_flags,spec_zone, & non_hydrostatic,top_lid,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, & jte,kts,kte) !PART I: DECLARATION OF VARIABLES IMPLICIT NONE INTEGER :: K0_ADJ,K1_ADJ,K2_ADJ,K3_ADJ TYPE(grid_config_rec_type) :: config_flags LOGICAL :: non_hydrostatic,top_lid INTEGER :: ids,ide,jds,jde,kds,kde INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte INTEGER :: spec_zone REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_u,u,a_v,v REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_ru_tend,ru_tend,a_rv_tend,rv_tend, & a_ph,ph,a_php,php,a_p,p,pb,a_alt,alt,a_al,al,a_cqu,cqu,a_cqv,cqv REAL,DIMENSION(ims:ime,jms:jme) :: a_muu,muu,a_muv,muv,a_mu,mu,a_mudf,mudf REAL,DIMENSION(kms:kme) :: fnm,fnp,rdnw REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msfvx_inv REAL :: rdx,rdy,dts,cf1,cf2,cf3,emdiv REAL,DIMENSION(its:ite,kts:kte) :: a_dpn,dpn,a_dpxy,dpxy REAL,DIMENSION(its:ite) :: a_mudf_xy,mudf_xy REAL :: dx,dy INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end INTEGER :: i_endu,j_endv,k_endw INTEGER :: i_start_up,i_end_up,j_start_up,j_end_up INTEGER :: i_start_vp,i_end_vp,j_start_vp,j_end_vp INTEGER :: i_start_u_tend,i_end_u_tend,j_start_v_tend,j_end_v_tend ! REAL,DIMENSION(its:ite,kts:kte) :: Keep_Lpb20_dpxy ! REAL,DIMENSION(its:ite,kts:kte) :: Keep_Lpb20_dpn 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,DIMENSION(its:ite,kts:kte) :: Tmpv300 REAL,DIMENSION(its:ite,kts:kte) :: Tmpv301 REAL,DIMENSION(its:ite,kts:kte) :: Tmpv302 REAL,DIMENSION(its:ite,kts:kte) :: Tmpv303 REAL,DIMENSION(its:ite,kts:kte) :: Tmpv304 REAL,DIMENSION(its:ite,kts:kte) :: Tmpv305 REAL,DIMENSION(its:ite,kts:kte) :: Tmpv306 !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] !LPB[1] IF( config_flags%nested .or. config_flags%specified ) THEN i_start = max( its,ids+spec_zone ) i_end = min( ite,ide-spec_zone-1 ) j_start = max( jts,jds+spec_zone ) j_end = min( jte,jde-spec_zone-1 ) k_start = kts k_end = min( kte, kde-1 ) i_endu = min( ite,ide-spec_zone ) j_endv = min( jte,jde-spec_zone ) k_endw = k_end IF( config_flags%periodic_x) THEN i_start = its i_end = min(ite,ide-1) i_endu = ite ENDIF ELSE i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 i_endu = ite j_endv = jte k_endw = k_end ENDIF !LPB[2] i_start_up = i_start i_end_up = i_endu j_start_up = j_start j_end_up = j_end i_start_vp = i_start i_end_vp = i_end j_start_vp = j_start j_end_vp = j_endv !LPB[3] IF ( (config_flags%open_xs .or. & config_flags%symmetric_xs ) & .and. (its == ids) ) & i_start_up = i_start_up + 1 !LPB[4] !LPB[5] IF ( (config_flags%open_xe .or. & config_flags%symmetric_xe ) & .and. (ite == ide) ) & i_end_up = i_end_up - 1 !LPB[6] !LPB[7] IF ( (config_flags%open_ys .or. & config_flags%symmetric_ys .or. & config_flags%polar ) & .and. (jts == jds) ) & j_start_vp = j_start_vp + 1 !LPB[8] !LPB[9] IF ( (config_flags%open_ye .or. & config_flags%symmetric_ye .or. & config_flags%polar ) & .and. (jte == jde) ) & j_end_vp = j_end_vp - 1 !LPB[10] i_start_u_tend = i_start i_end_u_tend = i_endu j_start_v_tend = j_start j_end_v_tend = j_endv !LPB[11] IF ( config_flags%symmetric_xs .and. (its == ids) ) & i_start_u_tend = i_start_u_tend+1 !LPB[12] !LPB[13] IF ( config_flags%symmetric_xe .and. (ite == ide) ) & i_end_u_tend = i_end_u_tend-1 !LPB[14] !LPB[15] IF ( config_flags%symmetric_ys .and. (jts == jds) ) & j_start_v_tend = j_start_v_tend+1 !LPB[16] !LPB[17] IF ( config_flags%symmetric_ye .and. (jte == jde) ) & j_end_v_tend = j_end_v_tend-1 !LPB[18] dx = 1./rdx dy = 1./rdy !LPB[19] u_outer_j_loop: DO j = j_start, j_end DO k = k_start, k_end DO i = i_start_u_tend, i_end_u_tend u(i,k,j) = u(i,k,j) + dts*ru_tend(i,k,j) ENDDO ENDDO DO i = i_start_up, i_end_up mudf_xy(i)= -emdiv*dx*(mudf(i,j)-mudf(i-1,j))/msfuy(i,j) ENDDO DO k = k_start, k_end DO i = i_start_up, i_end_up dpxy(i,k)= (msfux(i,j)/msfuy(i,j))*.5*rdx*muu(i,j)*( & ((ph (i,k+1,j)-ph (i-1,k+1,j))+(ph (i,k,j)-ph (i-1,k,j))) & +(alt(i,k ,j)+alt(i-1,k ,j))*(p (i,k,j)-p (i-1,k,j)) & +(al (i,k ,j)+al (i-1,k ,j))*(pb (i,k,j)-pb (i-1,k,j)) ) ENDDO ENDDO IF (non_hydrostatic) THEN DO i = i_start_up, i_end_up dpn(i,1) = .5*( cf1*(p(i,1,j)+p(i-1,1,j)) & +cf2*(p(i,2,j)+p(i-1,2,j)) & +cf3*(p(i,3,j)+p(i-1,3,j)) ) dpn(i,kde) = 0. ENDDO IF (top_lid) THEN DO i = i_start_up, i_end_up dpn(i,kde) =.5*( cf1*(p(i-1,kde-1,j)+p(i,kde-1,j)) & +cf2*(p(i-1,kde-2,j)+p(i,kde-2,j)) & +cf3*(p(i-1,kde-3,j)+p(i,kde-3,j)) ) ENDDO ENDIF DO k = k_start+1, k_end DO i = i_start_up, i_end_up dpn(i,k) = .5*( fnm(k)*(p(i,k ,j)+p(i-1,k ,j)) & +fnp(k)*(p(i,k-1,j)+p(i-1,k-1,j)) ) ENDDO ENDDO DO k = k_start, k_end DO i = i_start_up, i_end_up dpxy(i,k)=dpxy(i,k) + (msfux(i,j)/msfuy(i,j))*rdx*(php(i,k,j)-php(i-1,k,j)) & * & (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*(mu(i-1,j)+mu(i,j))) ENDDO ENDDO END IF DO k = k_start, k_end DO i = i_start_up, i_end_up u(i,k,j)=u(i,k,j)-dts*cqu(i,k,j)*dpxy(i,k)+mudf_xy(i) ENDDO ENDDO ENDDO u_outer_j_loop !!LPB[20] ! v_outer_j_loop: DO j = j_start_v_tend, j_end_v_tend !! DO k=k_start, k_end ! ! Keep_Lpb20_dpxy(i,k) =dpxy(i,k) !! END DO !! DO k=k_start+1, k_end ! ! Keep_Lpb20_dpn(i,k) =dpn(i,k) !! END DO ! DO k = k_start, k_end ! DO i = i_start, i_end ! v(i,k,j) = v(i,k,j) + dts*rv_tend(i,k,j) ! ENDDO ! ENDDO ! DO i = i_start, i_end ! mudf_xy(i)= -emdiv*dy*(mudf(i,j)-mudf(i,j-1))*msfvx_inv(i,j) ! ENDDO ! IF ( ( j >= j_start_vp) & ! .and.( j <= j_end_vp ) ) THEN ! DO k = k_start, k_end ! DO i = i_start, i_end ! dpxy(i,k)= (msfvy(i,j)/msfvx(i,j))*.5*rdy*muv(i,j)*( & ! ((ph(i,k+1,j)-ph(i,k+1,j-1))+(ph (i,k,j)-ph (i,k,j-1))) & ! +(alt(i,k ,j)+alt(i,k ,j-1))*(p (i,k,j)-p (i,k,j-1)) & ! +(al (i,k ,j)+al (i,k ,j-1))*(pb (i,k,j)-pb (i,k,j-1)) ) ! ENDDO ! ENDDO ! IF (non_hydrostatic) THEN ! DO i = i_start, i_end ! dpn(i,1) = .5*( cf1*(p(i,1,j)+p(i,1,j-1)) & ! +cf2*(p(i,2,j)+p(i,2,j-1)) & ! +cf3*(p(i,3,j)+p(i,3,j-1)) ) ! dpn(i,kde) = 0. ! ENDDO ! IF (top_lid) THEN ! DO i = i_start, i_end ! dpn(i,kde) =.5*( cf1*(p(i,kde-1,j-1)+p(i,kde-1,j)) & ! +cf2*(p(i,kde-2,j-1)+p(i,kde-2,j)) & ! +cf3*(p(i,kde-3,j-1)+p(i,kde-3,j)) ) ! ENDDO ! ENDIF ! DO k = k_start+1, k_end ! DO i = i_start, i_end ! dpn(i,k) = .5*( fnm(k)*(p(i,k ,j)+p(i,k ,j-1)) & ! +fnp(k)*(p(i,k-1,j)+p(i,k-1,j-1)) ) ! ENDDO ! ENDDO ! DO k = k_start, k_end ! DO i = i_start, i_end ! dpxy(i,k)=dpxy(i,k) + (msfvy(i,j)/msfvx(i,j))*rdy*(php(i,k,j) & ! -php(i,k,j-1))* & ! (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*(mu(i,j-1)+mu(i,j))) ! ENDDO ! ENDDO ! END IF ! DO k = k_start, k_end ! DO i = i_start, i_end ! v(i,k,j)=v(i,k,j)-dts*cqv(i,k,j)*dpxy(i,k)+mudf_xy(i) ! ENDDO ! ENDDO ! END IF ! ENDDO v_outer_j_loop !!LPB[21] !!LPB[22] ! IF (config_flags%polar) THEN ! IF (jts == jds) THEN ! DO k = k_start, k_end ! DO i = i_start, i_end ! v(i,k,jds) = 0. ! ENDDO ! ENDDO ! END IF ! IF (jte == jde) THEN ! DO k = k_start, k_end ! DO i = i_start, i_end ! v(i,k,jde) = 0. ! ENDDO ! ENDDO ! END IF ! END IF !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS Do K1_ADJ =kts, kte Do K0_ADJ =its, ite a_dpn(K0_ADJ,K1_ADJ) =0.0 End Do End Do Do K1_ADJ =kts, kte Do K0_ADJ =its, ite a_dpxy(K0_ADJ,K1_ADJ) =0.0 End Do End Do Do K0_ADJ =its, ite a_mudf_xy(K0_ADJ) =0.0 End Do !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[22] ! IF(config_flags%polar) THEN ! IF(jts == jds) THEN ! DO k =k_start, k_end ! DO i =i_start, i_end ! v(i,k,jds) =0. ! ENDDO ! ENDDO ! END IF ! IF(jte == jde) THEN ! DO k =k_start, k_end ! DO i =i_start, i_end ! v(i,k,jde) =0. ! ENDDO ! ENDDO ! END IF ! END IF IF(config_flags%polar) THEN IF(jte == jde) THEN DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_v(i,k,jde) =0.0 ENDDO ENDDO END IF IF(jts == jds) THEN DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_v(i,k,jds) =0.0 ENDDO ENDDO END IF END IF !LPB[21] !LPB[20] DO j =j_end_v_tend, j_start_v_tend, -1 ! DO k=k_start, k_end ! dpxy(i,k) =Keep_Lpb20_dpxy(i,k) ! END DO ! DO k=k_start+1, k_end ! dpn(i,k) =Keep_Lpb20_dpn(i,k) ! END DO DO k =k_start, k_end DO i =i_start, i_end Tmpv001 =v(i,k,j) +dts*rv_tend(i,k,j) ! v(i,k,j) =Tmpv001 ENDDO ENDDO DO i =i_start, i_end Tmpv001 =mudf(i,j) -mudf(i,j-1) Tmpv002 =-emdiv*dy*Tmpv001 Tmpv003 =Tmpv002*msfvx_inv(i,j) ! mudf_xy(i) =Tmpv003 ENDDO IF( ( j >= j_start_vp) .and.( j <= j_end_vp ) ) THEN DO k =k_start, k_end DO i =i_start, i_end Tmpv001 =ph(i,k+1,j) -ph(i,k+1,j-1) Tmpv002 =ph(i,k,j) -ph(i,k,j-1) Tmpv003 =Tmpv001 +Tmpv002 Tmpv004 =alt(i,k,j) +alt(i,k,j-1) Tmpv005 =p(i,k,j) -p(i,k,j-1) Tmpv300(i,k) =Tmpv004 Tmpv301(i,k) =Tmpv005 Tmpv006 =Tmpv300(i,k)*Tmpv301(i,k) Tmpv007 =Tmpv003 +Tmpv006 Tmpv008 =al(i,k,j) +al(i,k,j-1) Tmpv009 =Tmpv008*(pb(i,k,j)-pb(i,k,j-1)) Tmpv010 =Tmpv007 +Tmpv009 Tmpv302(i,k) =Tmpv010 Tmpv011 =(msfvy(i,j)/msfvx(i,j))*.5*rdy*muv(i,j)*Tmpv302(i,k) Tmpv303(i,k) =dpxy(i,k) dpxy(i,k) =Tmpv011 ENDDO ENDDO IF(non_hydrostatic) THEN DO i =i_start, i_end Tmpv001 =p(i,1,j) +p(i,1,j-1) Tmpv002 =cf1*Tmpv001 Tmpv003 =p(i,2,j) +p(i,2,j-1) Tmpv004 =cf2*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =p(i,3,j) +p(i,3,j-1) Tmpv007 =cf3*Tmpv006 Tmpv008 =Tmpv005 +Tmpv007 Tmpv009 =.5*Tmpv008 dpn(i,1) =Tmpv009 dpn(i,kde) =0. ENDDO IF(top_lid) THEN DO i =i_start, i_end Tmpv001 =p(i,kde-1,j-1) +p(i,kde-1,j) Tmpv002 =cf1*Tmpv001 Tmpv003 =p(i,kde-2,j-1) +p(i,kde-2,j) Tmpv004 =cf2*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =p(i,kde-3,j-1) +p(i,kde-3,j) Tmpv007 =cf3*Tmpv006 Tmpv008 =Tmpv005 +Tmpv007 Tmpv009 =.5*Tmpv008 dpn(i,kde) =Tmpv009 ENDDO ENDIF DO k =k_start+1, k_end DO i =i_start, i_end Tmpv001 =p(i,k,j) +p(i,k,j-1) Tmpv002 =fnm(k)*Tmpv001 Tmpv003 =p(i,k-1,j) +p(i,k-1,j-1) Tmpv004 =fnp(k)*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =.5*Tmpv005 dpn(i,k) =Tmpv006 ENDDO ENDDO DO k =k_start, k_end DO i =i_start, i_end Tmpv001 =php(i,k,j) -php(i,k,j-1) Tmpv002 =(msfvy(i,j)/msfvx(i,j))*rdy*Tmpv001 Tmpv003 =dpn(i,k+1) -dpn(i,k) Tmpv004 =rdnw(k)*Tmpv003 Tmpv005 =mu(i,j-1) +mu(i,j) Tmpv006 =.5*Tmpv005 Tmpv007 =Tmpv004 -Tmpv006 Tmpv304(i,k) =Tmpv002 Tmpv305(i,k) =Tmpv007 Tmpv008 =Tmpv304(i,k)*Tmpv305(i,k) Tmpv009 =dpxy(i,k) +Tmpv008 Tmpv306(i,k) =dpxy(i,k) dpxy(i,k) =Tmpv009 ENDDO ENDDO END IF DO k =k_start, k_end DO i =i_start, i_end Tmpv001 =dts*cqv(i,k,j)*dpxy(i,k) Tmpv002 =v(i,k,j) -Tmpv001 Tmpv003 =Tmpv002 +mudf_xy(i) ! v(i,k,j) =Tmpv003 ENDDO ENDDO END IF IF( ( j >= j_start_vp) & .and.( j <= j_end_vp ) ) THEN DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_Tmpv3 =a_v(i,k,j) a_v(i,k,j) =0.0 a_Tmpv2 =a_Tmpv3 a_mudf_xy(i) =a_mudf_xy(i) +a_Tmpv3 a_v(i,k,j) =a_v(i,k,j) +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_cqv(i,k,j) =a_cqv(i,k,j) +dts*dpxy(i,k)*a_Tmpv1 a_dpxy(i,k) =a_dpxy(i,k) +dts*cqv(i,k,j)*a_Tmpv1 ENDDO ENDDO IF(non_hydrostatic) THEN DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 dpxy(i,k) =Tmpv306(i,k) a_Tmpv9 =a_dpxy(i,k) a_dpxy(i,k) =0.0 a_dpxy(i,k) =a_dpxy(i,k) +a_Tmpv9 a_Tmpv8 =a_Tmpv9 a_Tmpv2 =Tmpv305(i,k)*a_Tmpv8 a_Tmpv7 =Tmpv304(i,k)*a_Tmpv8 a_Tmpv4 =a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_Tmpv5 =.5*a_Tmpv6 a_mu(i,j-1) =a_mu(i,j-1) +a_Tmpv5 a_mu(i,j) =a_mu(i,j) +a_Tmpv5 a_Tmpv3 =rdnw(k)*a_Tmpv4 a_dpn(i,k+1) =a_dpn(i,k+1) +a_Tmpv3 a_dpn(i,k) =a_dpn(i,k) -a_Tmpv3 a_Tmpv1 =(msfvy(i,j)/msfvx(i,j))*rdy*a_Tmpv2 a_php(i,k,j) =a_php(i,k,j) +a_Tmpv1 a_php(i,k,j-1) =a_php(i,k,j-1) -a_Tmpv1 ENDDO ENDDO DO k =k_end, k_start+1, -1 DO i =i_end, i_start, -1 a_Tmpv6 =a_dpn(i,k) a_dpn(i,k) =0.0 a_Tmpv5 =.5*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =fnp(k)*a_Tmpv4 a_p(i,k-1,j) =a_p(i,k-1,j) +a_Tmpv3 a_p(i,k-1,j-1) =a_p(i,k-1,j-1) +a_Tmpv3 a_Tmpv1 =fnm(k)*a_Tmpv2 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv1 a_p(i,k,j-1) =a_p(i,k,j-1) +a_Tmpv1 ENDDO ENDDO IF(top_lid) THEN DO i =i_end, i_start, -1 a_Tmpv9 =a_dpn(i,kde) a_dpn(i,kde) =0.0 a_Tmpv8 =.5*a_Tmpv9 a_Tmpv5 =a_Tmpv8 a_Tmpv7 =a_Tmpv8 a_Tmpv6 =cf3*a_Tmpv7 a_p(i,kde-3,j-1) =a_p(i,kde-3,j-1) +a_Tmpv6 a_p(i,kde-3,j) =a_p(i,kde-3,j) +a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =cf2*a_Tmpv4 a_p(i,kde-2,j-1) =a_p(i,kde-2,j-1) +a_Tmpv3 a_p(i,kde-2,j) =a_p(i,kde-2,j) +a_Tmpv3 a_Tmpv1 =cf1*a_Tmpv2 a_p(i,kde-1,j-1) =a_p(i,kde-1,j-1) +a_Tmpv1 a_p(i,kde-1,j) =a_p(i,kde-1,j) +a_Tmpv1 ENDDO ENDIF DO i =i_end, i_start, -1 a_dpn(i,kde) =0.0 a_Tmpv9 =a_dpn(i,1) a_dpn(i,1) =0.0 a_Tmpv8 =.5*a_Tmpv9 a_Tmpv5 =a_Tmpv8 a_Tmpv7 =a_Tmpv8 a_Tmpv6 =cf3*a_Tmpv7 a_p(i,3,j) =a_p(i,3,j) +a_Tmpv6 a_p(i,3,j-1) =a_p(i,3,j-1) +a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =cf2*a_Tmpv4 a_p(i,2,j) =a_p(i,2,j) +a_Tmpv3 a_p(i,2,j-1) =a_p(i,2,j-1) +a_Tmpv3 a_Tmpv1 =cf1*a_Tmpv2 a_p(i,1,j) =a_p(i,1,j) +a_Tmpv1 a_p(i,1,j-1) =a_p(i,1,j-1) +a_Tmpv1 ENDDO END IF DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 dpxy(i,k) =Tmpv303(i,k) a_Tmpv11 =a_dpxy(i,k) a_dpxy(i,k) =0.0 a_muv(i,j) =a_muv(i,j) +(msfvy(i,j)/msfvx(i,j))*.5*rdy*Tmpv302(i,k)*a_Tmpv11 a_Tmpv10 =(msfvy(i,j)/msfvx(i,j))*.5*rdy*muv(i,j)*a_Tmpv11 a_Tmpv7 =a_Tmpv10 a_Tmpv9 =a_Tmpv10 a_Tmpv8 =(pb(i,k,j)-pb(i,k,j-1))*a_Tmpv9 a_al(i,k,j) =a_al(i,k,j) +a_Tmpv8 a_al(i,k,j-1) =a_al(i,k,j-1) +a_Tmpv8 a_Tmpv3 =a_Tmpv7 a_Tmpv6 =a_Tmpv7 a_Tmpv4 =Tmpv301(i,k)*a_Tmpv6 a_Tmpv5 =Tmpv300(i,k)*a_Tmpv6 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv5 a_p(i,k,j-1) =a_p(i,k,j-1) -a_Tmpv5 a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv4 a_alt(i,k,j-1) =a_alt(i,k,j-1) +a_Tmpv4 a_Tmpv1 =a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv2 a_ph(i,k,j-1) =a_ph(i,k,j-1) -a_Tmpv2 a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1 a_ph(i,k+1,j-1) =a_ph(i,k+1,j-1) -a_Tmpv1 ENDDO ENDDO END IF DO i =i_end, i_start, -1 a_Tmpv3 =a_mudf_xy(i) a_mudf_xy(i) =0.0 a_Tmpv2 =msfvx_inv(i,j)*a_Tmpv3 a_Tmpv1 =-emdiv*dy*a_Tmpv2 a_mudf(i,j) =a_mudf(i,j) +a_Tmpv1 a_mudf(i,j-1) =a_mudf(i,j-1) -a_Tmpv1 ENDDO DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_v(i,k,j) a_v(i,k,j) =0.0 a_v(i,k,j) =a_v(i,k,j) +a_Tmpv1 a_rv_tend(i,k,j) =a_rv_tend(i,k,j) +dts*a_Tmpv1 ENDDO ENDDO ENDDO !LPB[19] DO j =j_end, j_start, -1 DO k =k_start, k_end DO i =i_start_u_tend, i_end_u_tend Tmpv001 =u(i,k,j) +dts*ru_tend(i,k,j) ! u(i,k,j) =Tmpv001 ENDDO ENDDO DO i =i_start_up, i_end_up Tmpv001 =mudf(i,j) -mudf(i-1,j) Tmpv002 =-emdiv*dx*Tmpv001 Tmpv003 =Tmpv002/msfuy(i,j) ! mudf_xy(i) =Tmpv003 ENDDO DO k =k_start, k_end DO i =i_start_up, i_end_up Tmpv001 =ph(i,k+1,j) -ph(i-1,k+1,j) Tmpv002 =ph(i,k,j) -ph(i-1,k,j) Tmpv003 =Tmpv001 +Tmpv002 Tmpv004 =alt(i,k,j) +alt(i-1,k,j) Tmpv005 =p(i,k,j) -p(i-1,k,j) Tmpv300(i,k) =Tmpv004 Tmpv301(i,k) =Tmpv005 Tmpv006 =Tmpv300(i,k)*Tmpv301(i,k) Tmpv007 =Tmpv003 +Tmpv006 Tmpv008 =al(i,k,j) +al(i-1,k,j) Tmpv009 =Tmpv008*(pb(i,k,j)-pb(i-1,k,j)) Tmpv010 =Tmpv007 +Tmpv009 Tmpv302(i,k) =Tmpv010 Tmpv011 =(msfux(i,j)/msfuy(i,j))*.5*rdx*muu(i,j)*Tmpv302(i,k) Tmpv303(i,k) =dpxy(i,k) dpxy(i,k) =Tmpv011 ENDDO ENDDO IF(non_hydrostatic) THEN DO i =i_start_up, i_end_up Tmpv001 =p(i,1,j) +p(i-1,1,j) Tmpv002 =cf1*Tmpv001 Tmpv003 =p(i,2,j) +p(i-1,2,j) Tmpv004 =cf2*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =p(i,3,j) +p(i-1,3,j) Tmpv007 =cf3*Tmpv006 Tmpv008 =Tmpv005 +Tmpv007 Tmpv009 =.5*Tmpv008 dpn(i,1) =Tmpv009 dpn(i,kde) =0. ENDDO IF(top_lid) THEN DO i =i_start_up, i_end_up Tmpv001 =p(i-1,kde-1,j) +p(i,kde-1,j) Tmpv002 =cf1*Tmpv001 Tmpv003 =p(i-1,kde-2,j) +p(i,kde-2,j) Tmpv004 =cf2*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =p(i-1,kde-3,j) +p(i,kde-3,j) Tmpv007 =cf3*Tmpv006 Tmpv008 =Tmpv005 +Tmpv007 Tmpv009 =.5*Tmpv008 dpn(i,kde) =Tmpv009 ENDDO ENDIF DO k =k_start+1, k_end DO i =i_start_up, i_end_up Tmpv001 =p(i,k,j) +p(i-1,k,j) Tmpv002 =fnm(k)*Tmpv001 Tmpv003 =p(i,k-1,j) +p(i-1,k-1,j) Tmpv004 =fnp(k)*Tmpv003 Tmpv005 =Tmpv002 +Tmpv004 Tmpv006 =.5*Tmpv005 dpn(i,k) =Tmpv006 ENDDO ENDDO DO k =k_start, k_end DO i =i_start_up, i_end_up Tmpv001 =php(i,k,j) -php(i-1,k,j) Tmpv002 =(msfux(i,j)/msfuy(i,j))*rdx*Tmpv001 Tmpv003 =dpn(i,k+1) -dpn(i,k) Tmpv004 =rdnw(k)*Tmpv003 Tmpv005 =mu(i-1,j) +mu(i,j) Tmpv006 =.5*Tmpv005 Tmpv007 =Tmpv004 -Tmpv006 Tmpv304(i,k) =Tmpv002 Tmpv305(i,k) =Tmpv007 Tmpv008 =Tmpv304(i,k)*Tmpv305(i,k) Tmpv009 =dpxy(i,k) +Tmpv008 Tmpv306(i,k) =dpxy(i,k) dpxy(i,k) =Tmpv009 ENDDO ENDDO END IF DO k =k_start, k_end DO i =i_start_up, i_end_up Tmpv001 =dts*cqu(i,k,j)*dpxy(i,k) Tmpv002 =u(i,k,j) -Tmpv001 Tmpv003 =Tmpv002 +mudf_xy(i) ! u(i,k,j) =Tmpv003 ENDDO ENDDO DO k =k_end, k_start, -1 DO i =i_end_up, i_start_up, -1 a_Tmpv3 =a_u(i,k,j) a_u(i,k,j) =0.0 a_Tmpv2 =a_Tmpv3 a_mudf_xy(i) =a_mudf_xy(i) +a_Tmpv3 a_u(i,k,j) =a_u(i,k,j) +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_cqu(i,k,j) =a_cqu(i,k,j) +dts*dpxy(i,k)*a_Tmpv1 a_dpxy(i,k) =a_dpxy(i,k) +dts*cqu(i,k,j)*a_Tmpv1 ENDDO ENDDO IF(non_hydrostatic) THEN DO k =k_end, k_start, -1 DO i =i_end_up, i_start_up, -1 dpxy(i,k) =Tmpv306(i,k) a_Tmpv9 =a_dpxy(i,k) a_dpxy(i,k) =0.0 a_dpxy(i,k) =a_dpxy(i,k) +a_Tmpv9 a_Tmpv8 =a_Tmpv9 a_Tmpv2 =Tmpv305(i,k)*a_Tmpv8 a_Tmpv7 =Tmpv304(i,k)*a_Tmpv8 a_Tmpv4 =a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_Tmpv5 =.5*a_Tmpv6 a_mu(i-1,j) =a_mu(i-1,j) +a_Tmpv5 a_mu(i,j) =a_mu(i,j) +a_Tmpv5 a_Tmpv3 =rdnw(k)*a_Tmpv4 a_dpn(i,k+1) =a_dpn(i,k+1) +a_Tmpv3 a_dpn(i,k) =a_dpn(i,k) -a_Tmpv3 a_Tmpv1 =(msfux(i,j)/msfuy(i,j))*rdx*a_Tmpv2 a_php(i,k,j) =a_php(i,k,j) +a_Tmpv1 a_php(i-1,k,j) =a_php(i-1,k,j) -a_Tmpv1 ENDDO ENDDO DO k =k_end, k_start+1, -1 DO i =i_end_up, i_start_up, -1 a_Tmpv6 =a_dpn(i,k) a_dpn(i,k) =0.0 a_Tmpv5 =.5*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =fnp(k)*a_Tmpv4 a_p(i,k-1,j) =a_p(i,k-1,j) +a_Tmpv3 a_p(i-1,k-1,j) =a_p(i-1,k-1,j) +a_Tmpv3 a_Tmpv1 =fnm(k)*a_Tmpv2 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv1 a_p(i-1,k,j) =a_p(i-1,k,j) +a_Tmpv1 ENDDO ENDDO IF(top_lid) THEN DO i =i_end_up, i_start_up, -1 a_Tmpv9 =a_dpn(i,kde) a_dpn(i,kde) =0.0 a_Tmpv8 =.5*a_Tmpv9 a_Tmpv5 =a_Tmpv8 a_Tmpv7 =a_Tmpv8 a_Tmpv6 =cf3*a_Tmpv7 a_p(i-1,kde-3,j) =a_p(i-1,kde-3,j) +a_Tmpv6 a_p(i,kde-3,j) =a_p(i,kde-3,j) +a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =cf2*a_Tmpv4 a_p(i-1,kde-2,j) =a_p(i-1,kde-2,j) +a_Tmpv3 a_p(i,kde-2,j) =a_p(i,kde-2,j) +a_Tmpv3 a_Tmpv1 =cf1*a_Tmpv2 a_p(i-1,kde-1,j) =a_p(i-1,kde-1,j) +a_Tmpv1 a_p(i,kde-1,j) =a_p(i,kde-1,j) +a_Tmpv1 ENDDO ENDIF DO i =i_end_up, i_start_up, -1 a_dpn(i,kde) =0.0 a_Tmpv9 =a_dpn(i,1) a_dpn(i,1) =0.0 a_Tmpv8 =.5*a_Tmpv9 a_Tmpv5 =a_Tmpv8 a_Tmpv7 =a_Tmpv8 a_Tmpv6 =cf3*a_Tmpv7 a_p(i,3,j) =a_p(i,3,j) +a_Tmpv6 a_p(i-1,3,j) =a_p(i-1,3,j) +a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =a_Tmpv5 a_Tmpv3 =cf2*a_Tmpv4 a_p(i,2,j) =a_p(i,2,j) +a_Tmpv3 a_p(i-1,2,j) =a_p(i-1,2,j) +a_Tmpv3 a_Tmpv1 =cf1*a_Tmpv2 a_p(i,1,j) =a_p(i,1,j) +a_Tmpv1 a_p(i-1,1,j) =a_p(i-1,1,j) +a_Tmpv1 ENDDO END IF DO k =k_end, k_start, -1 DO i =i_end_up, i_start_up, -1 dpxy(i,k) =Tmpv303(i,k) a_Tmpv11 =a_dpxy(i,k) a_dpxy(i,k) =0.0 a_muu(i,j) =a_muu(i,j) +(msfux(i,j)/msfuy(i,j))*.5*rdx*Tmpv302(i,k)*a_Tmpv11 a_Tmpv10 =(msfux(i,j)/msfuy(i,j))*.5*rdx*muu(i,j)*a_Tmpv11 a_Tmpv7 =a_Tmpv10 a_Tmpv9 =a_Tmpv10 a_Tmpv8 =(pb(i,k,j)-pb(i-1,k,j))*a_Tmpv9 a_al(i,k,j) =a_al(i,k,j) +a_Tmpv8 a_al(i-1,k,j) =a_al(i-1,k,j) +a_Tmpv8 a_Tmpv3 =a_Tmpv7 a_Tmpv6 =a_Tmpv7 a_Tmpv4 =Tmpv301(i,k)*a_Tmpv6 a_Tmpv5 =Tmpv300(i,k)*a_Tmpv6 a_p(i,k,j) =a_p(i,k,j) +a_Tmpv5 a_p(i-1,k,j) =a_p(i-1,k,j) -a_Tmpv5 a_alt(i,k,j) =a_alt(i,k,j) +a_Tmpv4 a_alt(i-1,k,j) =a_alt(i-1,k,j) +a_Tmpv4 a_Tmpv1 =a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv2 a_ph(i-1,k,j) =a_ph(i-1,k,j) -a_Tmpv2 a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv1 a_ph(i-1,k+1,j) =a_ph(i-1,k+1,j) -a_Tmpv1 ENDDO ENDDO DO i =i_end_up, i_start_up, -1 a_Tmpv3 =a_mudf_xy(i) a_mudf_xy(i) =0.0 a_Tmpv2 =a_Tmpv3/msfuy(i,j) a_Tmpv1 =-emdiv*dx*a_Tmpv2 a_mudf(i,j) =a_mudf(i,j) +a_Tmpv1 a_mudf(i-1,j) =a_mudf(i-1,j) -a_Tmpv1 ENDDO DO k =k_end, k_start, -1 DO i =i_end_u_tend, i_start_u_tend, -1 a_Tmpv1 =a_u(i,k,j) a_u(i,k,j) =0.0 a_u(i,k,j) =a_u(i,k,j) +a_Tmpv1 a_ru_tend(i,k,j) =a_ru_tend(i,k,j) +dts*a_Tmpv1 ENDDO ENDDO ENDDO !LPB[18] ! dx =1./rdx ! dy =1./rdy !LPB[17] ! IF( config_flags%symmetric_ye .and. (jte == jde) ) THEN ! j_end_v_tend =j_end_v_tend-1 ! END IF ! IF( config_flags%symmetric_ye .and. (jte == jde) ) THEN ! END IF !LPB[16] !LPB[15] ! IF( config_flags%symmetric_ys .and. (jts == jds) ) THEN ! j_start_v_tend =j_start_v_tend+1 ! END IF ! IF( config_flags%symmetric_ys .and. (jts == jds) ) THEN ! END IF !LPB[14] !LPB[13] ! IF( config_flags%symmetric_xe .and. (ite == ide) ) THEN ! i_end_u_tend =i_end_u_tend-1 ! END IF ! IF( config_flags%symmetric_xe .and. (ite == ide) ) THEN ! END IF !LPB[12] !LPB[11] ! IF( config_flags%symmetric_xs .and. (its == ids) ) THEN ! i_start_u_tend =i_start_u_tend+1 ! END IF ! IF( config_flags%symmetric_xs .and. (its == ids) ) THEN ! END IF !LPB[10] ! i_start_u_tend =i_start ! i_end_u_tend =i_endu ! j_start_v_tend =j_start ! j_end_v_tend =j_endv !LPB[9] ! IF( (config_flags%open_ye .or. config_flags%symmetric_ye .or. config_flags%polar ) .and. (jte == jde) ) THEN ! j_end_vp =j_end_vp-1 ! END IF ! IF( (config_flags%open_ye .or. & ! config_flags%symmetric_ye .or. & ! config_flags%polar ) & ! .and. (jte == jde) ) THEN ! END IF !LPB[8] !LPB[7] ! IF( (config_flags%open_ys .or. config_flags%symmetric_ys .or. config_flags%polar ) .and. (jts == jds) ) THEN ! j_start_vp =j_start_vp+1 ! END IF ! IF( (config_flags%open_ys .or. & ! config_flags%symmetric_ys .or. & ! config_flags%polar ) & ! .and. (jts == jds) ) THEN ! END IF !LPB[6] !LPB[5] ! IF( (config_flags%open_xe .or. config_flags%symmetric_xe ) .and. (ite == ide) ) THEN ! i_end_up =i_end_up-1 ! END IF ! IF( (config_flags%open_xe .or. & ! config_flags%symmetric_xe ) & ! .and. (ite == ide) ) THEN ! END IF !LPB[4] !LPB[3] ! IF( (config_flags%open_xs .or. config_flags%symmetric_xs ) .and. (its == ids) ) THEN ! i_start_up =i_start_up+1 ! END IF ! IF( (config_flags%open_xs .or. & ! config_flags%symmetric_xs ) & ! .and. (its == ids) ) THEN ! END IF !LPB[2] ! i_start_up =i_start ! i_end_up =i_endu ! j_start_up =j_start ! j_end_up =j_end ! i_start_vp =i_start ! i_end_vp =i_end ! j_start_vp =j_start ! j_end_vp =j_endv !LPB[1] ! IF( config_flags%nested .or. config_flags%specified ) THEN ! i_start =max(its, ids+spec_zone) ! i_end =min(ite, ide-spec_zone-1) ! j_start =max(jts, jds+spec_zone) ! j_end =min(jte, jde-spec_zone-1) ! k_start =kts ! k_end =min(kte, kde-1) ! i_endu =min(ite, ide-spec_zone) ! j_endv =min(jte, jde-spec_zone) ! k_endw =k_end ! IF( config_flags%periodic_x) THEN ! i_start =its ! i_end =min(ite, ide-1) ! i_endu =ite ! ENDIF ! ELSE ! i_start =its ! i_end =min(ite, ide-1) ! j_start =jts ! j_end =min(jte, jde-1) ! k_start =kts ! k_end =kte-1 ! i_endu =ite ! j_endv =jte ! k_endw =k_end ! ENDIF IF( config_flags%nested .or. config_flags%specified ) THEN IF( config_flags%periodic_x) THEN ENDIF ELSE ENDIF !LPB[0] END SUBROUTINE a_advance_uv SUBROUTINE a_advance_mu_t(ww,a_ww,ww_1,a_ww_1,u,a_u,u_1,a_u_1,v, & a_v,v_1,a_v_1,mu,a_mu,mut,a_mut,muave,a_muave,muts,a_muts,muu,a_muu, & muv,a_muv,mudf,a_mudf,uam,a_uam,vam,a_vam,wwam,a_wwam,t,a_t, & t_1,a_t_1,t_ave,a_t_ave,ft,a_ft,mu_tend,a_mu_tend,rdx,rdy,dts,epssm,dnw, & fnm,fnp,rdnw,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,step,config_flags,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 INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte INTEGER :: step REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_u,u,a_v,v,a_u_1,u_1,a_v_1,v_1, & a_t_1,t_1,a_ft,ft REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_ww,ww,a_ww_1,ww_1,a_t,t,a_t_ave, & t_ave,a_uam,uam,a_vam,vam,a_wwam,wwam REAL,DIMENSION(ims:ime,jms:jme) :: a_muu,muu,a_muv,muv,a_mut,mut,msfux,msfuy, & msfvx,msfvx_inv,msfvy,msftx,msfty,a_mu_tend,mu_tend REAL,DIMENSION(ims:ime,jms:jme) :: a_muave,muave,a_muts,muts,a_mudf,mudf REAL,DIMENSION(ims:ime,jms:jme) :: a_mu,mu REAL,DIMENSION(kms:kme) :: fnm,fnp,dnw,rdnw REAL :: rdx,rdy,dts,epssm REAL,DIMENSION(its:ite,kts:kte) :: a_wdtn,wdtn,a_dvdxi,dvdxi REAL,DIMENSION(its:ite) :: a_dmdt,dmdt INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end INTEGER :: i_endu,j_endv REAL :: a_acc,acc 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 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv300 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv301 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv302 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv303 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv304 !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 !LPB[1] IF ( .NOT. config_flags%periodic_x )THEN IF ( config_flags%specified .or. config_flags%nested ) then i_start = max(its,ids+1) i_end = min(ite,ide-2) ENDIF ENDIF !LPB[2] !LPB[3] IF ( config_flags%specified .or. config_flags%nested ) then j_start = max(jts,jds+1) j_end = min(jte,jde-2) ENDIF !LPB[4] i_endu = ite j_endv = jte !LPB[5] DO j = j_start, j_end DO i=i_start, i_end dmdt(i) = 0. ENDDO DO k=k_start, k_end DO i=i_start, i_end dvdxi(i,k) = msftx(i,j)*msfty(i,j)*( & rdy*( (v(i,k,j+1)+muv(i,j+1)*v_1(i,k,j+1)*msfvx_inv(i,j+1)) & -(v(i,k,j )+muv(i,j )*v_1(i,k,j )*msfvx_inv(i,j )) ) & +rdx*( (u(i+1,k,j)+muu(i+1,j)*u_1(i+1,k,j)/msfuy(i+1,j)) & -(u(i,k,j )+muu(i ,j)*u_1(i,k,j )/msfuy(i ,j)) )) dmdt(i) = dmdt(i) + dnw(k)*dvdxi(i,k) ENDDO ENDDO DO i=i_start, i_end muave(i,j) = mu(i,j) mu(i,j) = mu(i,j)+dts*(dmdt(i)+mu_tend(i,j)) mudf(i,j) = (dmdt(i)+mu_tend(i,j)) muts(i,j) = mut(i,j)+mu(i,j) muave(i,j) =.5*((1.+epssm)*mu(i,j)+(1.-epssm)*muave(i,j)) ENDDO DO k=2,k_end DO i=i_start, i_end ww(i,k,j)=ww(i,k-1,j)-dnw(k-1)*(dmdt(i)+dvdxi(i,k-1)+mu_tend(i,j))/msfty(i,j) ENDDO END DO DO k=1,k_end DO i=i_start, i_end ww(i,k,j)=ww(i,k,j)-ww_1(i,k,j) END DO END DO ENDDO ! Remarked by Ning Pan, 2010-08-31 : LPB[6] !LPB[6] ! DO j=j_start, j_end ! DO k=1,k_end ! DO i=i_start, i_end ! t_ave(i,k,j) = t(i,k,j) ! t (i,k,j) = t(i,k,j) + msfty(i,j)*dts*ft(i,k,j) ! END DO ! END DO ! ENDDO !!LPB[7] ! DO j=j_start, j_end ! DO i=i_start, i_end ! wdtn(i,1 )=0. ! wdtn(i,kde)=0. ! ENDDO ! DO k=2,k_end ! DO i=i_start, i_end ! wdtn(i,k)= ww(i,k,j)*(fnm(k)*t_1(i,k ,j)+fnp(k)*t_1(i,k-1,j)) ! ENDDO ! ENDDO ! DO k=1,k_end ! DO i=i_start, i_end ! t(i,k,j) = t(i,k,j) - dts*msfty(i,j)*( & ! & ! msftx(i,j)*( & ! .5*rdy* & ! ( v(i,k,j+1)*(t_1(i,k,j+1)+t_1(i,k, j )) & ! -v(i,k,j )*(t_1(i,k, j )+t_1(i,k,j-1)) ) & ! + .5*rdx* & ! ( u(i+1,k,j)*(t_1(i+1,k,j)+t_1(i ,k,j)) & ! -u(i ,k,j)*(t_1(i ,k,j)+t_1(i-1,k,j)) ) ) & ! + rdnw(k)*( wdtn(i,k+1)-wdtn(i,k) ) ) ! ENDDO ! ENDDO ! ENDDO !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS Do K1_ADJ =kts, kte Do K0_ADJ =its, ite a_wdtn(K0_ADJ,K1_ADJ) =0.0 End Do End Do Do K1_ADJ =kts, kte Do K0_ADJ =its, ite a_dvdxi(K0_ADJ,K1_ADJ) =0.0 End Do End Do Do K0_ADJ =its, ite a_dmdt(K0_ADJ) =0.0 End Do a_acc =0.0 !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[7] DO j =j_end, j_start, -1 ! Remarked by Ning Pan, 2010-08-31 ! DO i =i_start, i_end ! wdtn(i,1) =0. ! wdtn(i,kde) =0. ! ENDDO DO k =2, k_end DO i =i_start, i_end Tmpv001 =fnm(k)*t_1(i,k,j) +fnp(k)*t_1(i,k-1,j) Tmpv300(i,k) =Tmpv001 ! Remarked by Ning Pan, 2010-08-31 ! Tmpv002 =ww(i,k,j)*Tmpv300(i,k) !! wdtn(i,k) =Tmpv002 ENDDO ENDDO DO k =1, k_end DO i =i_start, i_end Tmpv001 =t_1(i,k,j+1) +t_1(i,k,j) Tmpv301(i,k) =Tmpv001 Tmpv002 =v(i,k,j+1)*Tmpv301(i,k) Tmpv003 =t_1(i,k,j) +t_1(i,k,j-1) Tmpv302(i,k) =Tmpv003 Tmpv004 =v(i,k,j)*Tmpv302(i,k) Tmpv005 =Tmpv002 -Tmpv004 Tmpv006 =.5*rdy*Tmpv005 Tmpv007 =t_1(i+1,k,j) +t_1(i,k,j) Tmpv303(i,k) =Tmpv007 Tmpv008 =u(i+1,k,j)*Tmpv303(i,k) Tmpv009 =t_1(i,k,j) +t_1(i-1,k,j) Tmpv304(i,k) =Tmpv009 ! Remarked by Ning Pan, 2010-08-31 ! Tmpv010 =u(i,k,j)*Tmpv304(i,k) ! Tmpv011 =Tmpv008 -Tmpv010 ! Tmpv012 =.5*rdx*Tmpv011 ! Tmpv013 =Tmpv006 +Tmpv012 ! Tmpv014 =msftx(i,j)*Tmpv013 ! Tmpv015 =wdtn(i,k+1) -wdtn(i,k) ! Tmpv016 =rdnw(k)*Tmpv015 ! Tmpv017 =Tmpv014 +Tmpv016 ! Tmpv018 =dts*msfty(i,j)*Tmpv017 ! Tmpv019 =t(i,k,j) -Tmpv018 !! t(i,k,j) =Tmpv019 ENDDO ENDDO DO k =k_end, 1, -1 DO i =i_end, i_start, -1 a_Tmpv19 =a_t(i,k,j) a_t(i,k,j) =0.0 a_t(i,k,j) =a_t(i,k,j) +a_Tmpv19 a_Tmpv18 =-a_Tmpv19 a_Tmpv17 =dts*msfty(i,j)*a_Tmpv18 a_Tmpv14 =a_Tmpv17 a_Tmpv16 =a_Tmpv17 a_Tmpv15 =rdnw(k)*a_Tmpv16 a_wdtn(i,k+1) =a_wdtn(i,k+1) +a_Tmpv15 a_wdtn(i,k) =a_wdtn(i,k) -a_Tmpv15 a_Tmpv13 =msftx(i,j)*a_Tmpv14 a_Tmpv6 =a_Tmpv13 a_Tmpv12 =a_Tmpv13 a_Tmpv11 =.5*rdx*a_Tmpv12 a_Tmpv8 =a_Tmpv11 a_Tmpv10 =-a_Tmpv11 a_u(i,k,j) =a_u(i,k,j) +Tmpv304(i,k)*a_Tmpv10 a_Tmpv9 =u(i,k,j)*a_Tmpv10 a_t_1(i,k,j) =a_t_1(i,k,j) +a_Tmpv9 a_t_1(i-1,k,j) =a_t_1(i-1,k,j) +a_Tmpv9 a_u(i+1,k,j) =a_u(i+1,k,j) +Tmpv303(i,k)*a_Tmpv8 a_Tmpv7 =u(i+1,k,j)*a_Tmpv8 a_t_1(i+1,k,j) =a_t_1(i+1,k,j) +a_Tmpv7 a_t_1(i,k,j) =a_t_1(i,k,j) +a_Tmpv7 a_Tmpv5 =.5*rdy*a_Tmpv6 a_Tmpv2 =a_Tmpv5 a_Tmpv4 =-a_Tmpv5 a_v(i,k,j) =a_v(i,k,j) +Tmpv302(i,k)*a_Tmpv4 a_Tmpv3 =v(i,k,j)*a_Tmpv4 a_t_1(i,k,j) =a_t_1(i,k,j) +a_Tmpv3 a_t_1(i,k,j-1) =a_t_1(i,k,j-1) +a_Tmpv3 a_v(i,k,j+1) =a_v(i,k,j+1) +Tmpv301(i,k)*a_Tmpv2 a_Tmpv1 =v(i,k,j+1)*a_Tmpv2 a_t_1(i,k,j+1) =a_t_1(i,k,j+1) +a_Tmpv1 a_t_1(i,k,j) =a_t_1(i,k,j) +a_Tmpv1 ENDDO ENDDO DO k =k_end, 2, -1 DO i =i_end, i_start, -1 a_Tmpv2 =a_wdtn(i,k) a_wdtn(i,k) =0.0 a_ww(i,k,j) =a_ww(i,k,j) +Tmpv300(i,k)*a_Tmpv2 a_Tmpv1 =ww(i,k,j)*a_Tmpv2 a_t_1(i,k,j) =a_t_1(i,k,j) +fnm(k)*a_Tmpv1 a_t_1(i,k-1,j) =a_t_1(i,k-1,j) +fnp(k)*a_Tmpv1 ENDDO ENDDO DO i =i_end, i_start, -1 a_wdtn(i,kde) =0.0 a_wdtn(i,1) =0.0 ENDDO ENDDO !LPB[6] DO j =j_end, j_start, -1 ! DO k =1, k_end ! DO i =i_start, i_end ! t_ave(i,k,j) =t(i,k,j) ! Tmpv001 =t(i,k,j) +msfty(i,j)*dts*ft(i,k,j) ! t(i,k,j) =Tmpv001 ! ENDDO ! ENDDO DO k =k_end, 1, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_t(i,k,j) a_t(i,k,j) =0.0 a_t(i,k,j) =a_t(i,k,j) +a_Tmpv1 a_ft(i,k,j) =a_ft(i,k,j) +msfty(i,j)*dts*a_Tmpv1 a_t(i,k,j) =a_t(i,k,j) +a_t_ave(i,k,j) a_t_ave(i,k,j) =0.0 ENDDO ENDDO ENDDO !LPB[5] DO j =j_end, j_start, -1 ! Remarked by Ning Pan, 2010-08-31 : not need to recalculate ! DO i =i_start, i_end ! dmdt(i) =0. ! ENDDO ! DO k =k_start, k_end ! DO i =i_start, i_end ! Tmpv001 =muv(i,j+1)*v_1(i,k,j+1) ! Tmpv002 =Tmpv001*msfvx_inv(i,j+1) ! Tmpv003 =v(i,k,j+1) +Tmpv002 ! Tmpv004 =muv(i,j)*v_1(i,k,j) ! Tmpv005 =Tmpv004*msfvx_inv(i,j) ! Tmpv006 =v(i,k,j) +Tmpv005 ! Tmpv007 =Tmpv003 -Tmpv006 ! Tmpv008 =rdy*Tmpv007 ! Tmpv009 =muu(i+1,j)*u_1(i+1,k,j) ! Tmpv010 =Tmpv009/msfuy(i+1,j) ! Tmpv011 =u(i+1,k,j) +Tmpv010 ! Tmpv012 =muu(i,j)*u_1(i,k,j) ! Tmpv013 =Tmpv012/msfuy(i,j) ! Tmpv014 =u(i,k,j) +Tmpv013 ! Tmpv015 =Tmpv011 -Tmpv014 ! Tmpv016 =rdx*Tmpv015 ! Tmpv017 =Tmpv008 +Tmpv016 ! Tmpv018 =msftx(i,j)*msfty(i,j)*Tmpv017 !! dvdxi(i,k) =Tmpv018 ! Tmpv001 =dmdt(i) +dnw(k)*dvdxi(i,k) !! dmdt(i) =Tmpv001 ! ENDDO ! ENDDO ! DO i =i_start, i_end !! muave(i,j) =mu(i,j) ! Tmpv001 =dmdt(i) +mu_tend(i,j) ! Tmpv002 =dts*Tmpv001 ! Tmpv003 =mu(i,j) +Tmpv002 !! mu(i,j) =Tmpv003 ! Tmpv001 =dmdt(i) +mu_tend(i,j) !! mudf(i,j) =Tmpv001 ! Tmpv001 =mut(i,j) +mu(i,j) !! muts(i,j) =Tmpv001 ! Tmpv001 =(1.+epssm)*mu(i,j) +(1.-epssm)*muave(i,j) ! Tmpv002 =.5*Tmpv001 !! muave(i,j) =Tmpv002 ! ENDDO ! DO k =2, k_end ! DO i =i_start, i_end ! Tmpv001 =dmdt(i) +dvdxi(i,k-1) ! Tmpv002 =Tmpv001 +mu_tend(i,j) ! Tmpv003 =dnw(k-1)*Tmpv002 ! Tmpv004 =Tmpv003/msfty(i,j) ! Tmpv005 =ww(i,k-1,j) -Tmpv004 !! ww(i,k,j) =Tmpv005 ! ENDDO ! ENDDO ! DO k =1, k_end ! DO i =i_start, i_end ! Tmpv001 =ww(i,k,j) -ww_1(i,k,j) !! ww(i,k,j) =Tmpv001 ! ENDDO ! ENDDO DO k =k_end, 1, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_ww(i,k,j) a_ww(i,k,j) =0.0 a_ww(i,k,j) =a_ww(i,k,j) +a_Tmpv1 a_ww_1(i,k,j) =a_ww_1(i,k,j) -a_Tmpv1 ENDDO ENDDO DO k =k_end, 2, -1 DO i =i_end, i_start, -1 a_Tmpv5 =a_ww(i,k,j) a_ww(i,k,j) =0.0 a_ww(i,k-1,j) =a_ww(i,k-1,j) +a_Tmpv5 a_Tmpv4 =-a_Tmpv5 a_Tmpv3 =a_Tmpv4/msfty(i,j) a_Tmpv2 =dnw(k-1)*a_Tmpv3 a_Tmpv1 =a_Tmpv2 a_mu_tend(i,j) =a_mu_tend(i,j) +a_Tmpv2 a_dmdt(i) =a_dmdt(i) +a_Tmpv1 a_dvdxi(i,k-1) =a_dvdxi(i,k-1) +a_Tmpv1 ENDDO ENDDO DO i =i_end, i_start, -1 a_Tmpv2 =a_muave(i,j) a_muave(i,j) =0.0 a_Tmpv1 =.5*a_Tmpv2 a_mu(i,j) =a_mu(i,j) +(1.+epssm)*a_Tmpv1 a_muave(i,j) =a_muave(i,j) +(1.-epssm)*a_Tmpv1 a_Tmpv1 =a_muts(i,j) a_muts(i,j) =0.0 a_mut(i,j) =a_mut(i,j) +a_Tmpv1 a_mu(i,j) =a_mu(i,j) +a_Tmpv1 a_Tmpv1 =a_mudf(i,j) a_mudf(i,j) =0.0 a_dmdt(i) =a_dmdt(i) +a_Tmpv1 a_mu_tend(i,j) =a_mu_tend(i,j) +a_Tmpv1 a_Tmpv3 =a_mu(i,j) a_mu(i,j) =0.0 a_mu(i,j) =a_mu(i,j) +a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =dts*a_Tmpv2 a_dmdt(i) =a_dmdt(i) +a_Tmpv1 a_mu_tend(i,j) =a_mu_tend(i,j) +a_Tmpv1 a_mu(i,j) =a_mu(i,j) +a_muave(i,j) a_muave(i,j) =0.0 ENDDO DO k =k_end, k_start, -1 DO i =i_end, i_start, -1 a_Tmpv1 =a_dmdt(i) a_dmdt(i) =0.0 a_dmdt(i) =a_dmdt(i) +a_Tmpv1 a_dvdxi(i,k) =a_dvdxi(i,k) +dnw(k)*a_Tmpv1 a_Tmpv18 =a_dvdxi(i,k) a_dvdxi(i,k) =0.0 a_Tmpv17 =msftx(i,j)*msfty(i,j)*a_Tmpv18 a_Tmpv8 =a_Tmpv17 a_Tmpv16 =a_Tmpv17 a_Tmpv15 =rdx*a_Tmpv16 a_Tmpv11 =a_Tmpv15 a_Tmpv14 =-a_Tmpv15 a_u(i,k,j) =a_u(i,k,j) +a_Tmpv14 a_Tmpv13 =a_Tmpv14 a_Tmpv12 =a_Tmpv13/msfuy(i,j) a_muu(i,j) =a_muu(i,j) +u_1(i,k,j)*a_Tmpv12 a_u_1(i,k,j) =a_u_1(i,k,j) +muu(i,j)*a_Tmpv12 a_u(i+1,k,j) =a_u(i+1,k,j) +a_Tmpv11 a_Tmpv10 =a_Tmpv11 a_Tmpv9 =a_Tmpv10/msfuy(i+1,j) a_muu(i+1,j) =a_muu(i+1,j) +u_1(i+1,k,j)*a_Tmpv9 a_u_1(i+1,k,j) =a_u_1(i+1,k,j) +muu(i+1,j)*a_Tmpv9 a_Tmpv7 =rdy*a_Tmpv8 a_Tmpv3 =a_Tmpv7 a_Tmpv6 =-a_Tmpv7 a_v(i,k,j) =a_v(i,k,j) +a_Tmpv6 a_Tmpv5 =a_Tmpv6 a_Tmpv4 =msfvx_inv(i,j)*a_Tmpv5 a_muv(i,j) =a_muv(i,j) +v_1(i,k,j)*a_Tmpv4 a_v_1(i,k,j) =a_v_1(i,k,j) +muv(i,j)*a_Tmpv4 a_v(i,k,j+1) =a_v(i,k,j+1) +a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =msfvx_inv(i,j+1)*a_Tmpv2 a_muv(i,j+1) =a_muv(i,j+1) +v_1(i,k,j+1)*a_Tmpv1 a_v_1(i,k,j+1) =a_v_1(i,k,j+1) +muv(i,j+1)*a_Tmpv1 ENDDO ENDDO DO i =i_end, i_start, -1 a_dmdt(i) =0.0 ENDDO ENDDO !LPB[4] ! i_endu =ite ! j_endv =jte !LPB[3] ! IF( config_flags%specified .or. config_flags%nested ) THEN ! j_start =max(jts, jds+1) ! j_end =min(jte, jde-2) ! ENDIF ! Remarked by Ning Pan, 2010-08-31 ! IF( config_flags%specified .or. config_flags%nested ) THEN ! ENDIF !LPB[2] !LPB[1] ! IF( .NOT. config_flags%periodic_x ) THEN ! IF( config_flags%specified .or. config_flags%nested ) THEN ! i_start =max(its, ids+1) ! i_end =min(ite, ide-2) ! ENDIF ! ENDIF ! Remarked by Ning Pan, 2010-08-31 ! IF( .NOT. config_flags%periodic_x ) THEN ! IF( config_flags%specified .or. config_flags%nested ) THEN ! ENDIF ! ENDIF !LPB[0] ! i_start =its ! i_end =min(ite, ide-1) ! j_start =jts ! j_end =min(jte, jde-1) ! k_start =kts ! k_end =kte-1 END SUBROUTINE a_advance_mu_t SUBROUTINE a_advance_w(w,a_w,rw_tend,a_rw_tend,ww,a_ww,w_save, & a_w_save,u,a_u,v,a_v,mu1,a_mu1,mut,a_mut,muave,a_muave,muts,a_muts, & t_2ave,a_t_2ave,t_2,a_t_2,t_1,a_t_1,ph,a_ph,ph_1,a_ph_1,phb, & !a_ph_tend,ph_tend,a_ht,ht,a_c2a,c2a,a_cqw,cqw,a_alt,alt,alb,a_a,a, & ! Remarked by Ning Pan, 2010-07-08 ph_tend,a_ph_tend,ht,c2a,a_c2a,cqw,a_cqw,alt,a_alt,alb,a,a_a, & ! Ning Pan, 2010-07-08 alpha,a_alpha,gamma,a_gamma,rdx,rdy,dts,t0,epssm,dnw,fnm,fnp,rdnw,rdn,cf1,cf2, & cf3,msftx,msfty,config_flags,top_lid,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 INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte LOGICAL :: top_lid REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_t_2ave,t_2ave,a_w,w,a_ph,ph REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_rw_tend,rw_tend,a_ww,ww,a_w_save, & w_save,a_u,u,a_v,v,a_t_2,t_2,a_t_1,t_1,a_ph_1,ph_1,phb,a_ph_tend,ph_tend, & a_alpha,alpha,a_gamma,gamma,a_a,a,a_c2a,c2a,a_cqw,cqw,alb,a_alt,alt REAL,DIMENSION(ims:ime,jms:jme) :: a_mu1,mu1,a_mut,mut,a_muave,muave,a_muts, & ! muts,a_ht,ht,msftx,msfty ! Remarked by Ning Pan, 2010-07-09 muts,a_ht,ht,msftx,msfty ! Ning Pan, 2010-07-09 REAL,DIMENSION(kms:kme) :: fnp,fnm,rdnw,rdn,dnw REAL :: rdx,rdy,dts,cf1,cf2,cf3,t0,epssm REAL,DIMENSION(its:ite) :: a_mut_inv,mut_inv,msft_inv REAL,DIMENSION(its:ite,kts:kte) :: a_rhs,rhs,a_wdwn,wdwn INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end REAL,DIMENSION(kts:kte) :: a_dampwt,dampwt REAL :: a_htop,htop,a_hbot,hbot,hdepth,a_hk,hk REAL :: pi,dampmag ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb6_t_2ave ! REAL,DIMENSION(its:ite,kts:kte) :: Keep_Lpb6_rhs, REVISED BY WALLS ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb6_w ! REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: Keep_Lpb6_ph 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,a_Tmpv21,Tmpv021, & a_Tmpv22,Tmpv022,a_Tmpv23,Tmpv023,a_Tmpv24,Tmpv024,a_Tmpv25,Tmpv025,a_Tmpv26,Tmpv026 ! REAL,DIMENSION(ims:ime) :: Tmpv200, REVISED BY WALLS REAL,DIMENSION(ims:ime) :: Tmpv201 REAL,DIMENSION(ims:ime) :: Tmpv202 REAL,DIMENSION(ims:ime) :: Tmpv203 REAL,DIMENSION(ims:ime) :: Tmpv204 REAL,DIMENSION(ims:ime) :: Tmpv205 REAL,DIMENSION(ims:ime) :: Tmpv206 REAL,DIMENSION(ims:ime) :: Tmpv207 REAL,DIMENSION(ims:ime) :: Tmpv208 REAL,DIMENSION(ims:ime) :: Tmpv209 REAL,DIMENSION(ims:ime) :: Tmpv2010 REAL,DIMENSION(ims:ime) :: Tmpv2011 REAL,DIMENSION(ims:ime) :: Tmpv2012 REAL,DIMENSION(ims:ime) :: Tmpv2013 REAL,DIMENSION(ims:ime) :: Tmpv2014 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv300 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv301 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv302 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv303 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv304 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv305 REAL,DIMENSION(its:min(ite,ide-1),kte-1) :: Tmpv306 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv307 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv308 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv309 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3010 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3011 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3012 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3013 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3014 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3015 REAL,DIMENSION(its:min(ite,ide-1),2:kte-1) :: Tmpv3016 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3017 REAL,DIMENSION(its:min(ite,ide-1),1:kte) :: Tmpv3018 !REVISED BY WALLS REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3019 !REVISED BY WALLS REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3020 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3021 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3022 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3023 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3024 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3025 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3026 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3027 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3028 REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3029 !REVISED BY WALLS REAL,DIMENSION(its:min(ite,ide-1),2:kte) :: Tmpv3030 !REVISED BY WALLS !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] i_start = its i_end = min(ite,ide-1) j_start = jts j_end = min(jte,jde-1) k_start = kts k_end = kte-1 !LPB[1] IF ( .NOT. config_flags%periodic_x )THEN IF ( config_flags%specified .or. config_flags%nested ) then i_start = max(its,ids+1) i_end = min(ite,ide-2) ENDIF ENDIF !LPB[2] !LPB[3] IF ( config_flags%specified .or. config_flags%nested ) then j_start = max(jts,jds+1) j_end = min(jte,jde-2) ENDIF !LPB[4] pi = 4.*atan(1.) dampmag = dts*config_flags%dampcoef hdepth=config_flags%zdamp !LPB[5] DO i=i_start, i_end rhs(i,1) = 0. ENDDO !LPB[6] ! j_loop_w: DO j = j_start, j_end ! ! DO k=1, k_end ! DO i=i_start, i_end ! Keep_Lpb6_t_2ave(i,k,j) =t_2ave(i,k,j) ! END DO ! END DO ! DO k=2, k_end ! Keep_Lpb6_rhs(i,k) =rhs(i,k) ! END DO ! DO k=2, k_end ! DO i=i_start, i_end ! Keep_Lpb6_w(i,k,j) =w(i,k,j) ! END DO ! END DO ! DO k=2, k_end+1 ! DO i=i_start, i_end ! Keep_Lpb6_ph(i,k,j) =ph(i,k,j) ! END DO ! END DO ! ! DO i=i_start, i_end ! mut_inv(i) = 1./mut(i,j) ! msft_inv(i) = 1./msfty(i,j) ! ENDDO ! ! DO k=1, k_end ! DO i=i_start, i_end ! t_2ave(i,k,j)=.5*((1.+epssm)*t_2(i,k,j) & ! +(1.-epssm)*t_2ave(i,k,j)) ! t_2ave(i,k,j)=(t_2ave(i,k,j) + muave(i,j)*t0) & ! /(muts(i,j)*(t0+t_1(i,k,j))) ! wdwn(i,k+1)=.5*(ww(i,k+1,j)+ww(i,k,j))*rdnw(k) & ! *(ph_1(i,k+1,j)-ph_1(i,k,j)+phb(i,k+1,j)-phb(i,k,j)) ! rhs(i,k+1) = dts*(ph_tend(i,k+1,j) + .5*g*(1.-epssm)*w(i,k+1,j)) ! ENDDO ! ENDDO ! ! DO k=2,k_end ! DO i=i_start, i_end ! rhs(i,k) = rhs(i,k)-dts*( fnm(k)*wdwn(i,k+1) & ! +fnp(k)*wdwn(i,k ) ) ! ENDDO ! ENDDO ! ! DO k=2,k_end+1 ! DO i=i_start, i_end ! rhs(i,k) = ph(i,k,j) + msfty(i,j)*rhs(i,k)*mut_inv(i) ! if(top_lid .and. k.eq.k_end+1) rhs(i,k)=0. ! ! ENDDO ! ENDDO ! ! DO i=i_start, i_end ! w(i,1,j)= & ! msfty(i,j)*.5*rdy*( & ! (ht(i,j+1)-ht(i,j )) & ! *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1)) & ! +(ht(i,j )-ht(i,j-1)) & ! *(cf1*v(i,1,j )+cf2*v(i,2,j )+cf3*v(i,3,j )) ) & ! +msftx(i,j)*.5*rdx*( & ! (ht(i+1,j)-ht(i,j )) & ! *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j)) & ! +(ht(i,j )-ht(i-1,j)) & ! *(cf1*u(i ,1,j)+cf2*u(i ,2,j)+cf3*u(i ,3,j)) ) ! ENDDO ! ! DO k=2,k_end ! DO i=i_start, i_end ! w(i,k,j)=w(i,k,j)+dts*rw_tend(i,k,j) & ! + msft_inv(i)*cqw(i,k,j)*( & ! +.5*dts*g*mut_inv(i)*rdn(k)* & ! (c2a(i,k ,j)*rdnw(k ) & ! *((1.+epssm)*(rhs(i,k+1 )-rhs(i,k )) & ! +(1.-epssm)*(ph(i,k+1,j)-ph(i,k ,j))) & ! -c2a(i,k-1,j)*rdnw(k-1) & ! *((1.+epssm)*(rhs(i,k )-rhs(i,k-1 )) & ! +(1.-epssm)*(ph(i,k ,j)-ph(i,k-1,j))))) & ! +dts*g*msft_inv(i)*(rdn(k)* & ! (c2a(i,k ,j)*alt(i,k ,j)*t_2ave(i,k ,j) & ! -c2a(i,k-1,j)*alt(i,k-1,j)*t_2ave(i,k-1,j)) & ! - muave(i,j)) ! ENDDO ! ENDDO ! K=k_end+1 ! ! DO i=i_start, i_end ! w(i,k,j)=w(i,k,j)+dts*rw_tend(i,k,j) & ! +msft_inv(i)*( & ! -.5*dts*g*mut_inv(i)*rdnw(k-1)**2*2.*c2a(i,k-1,j) & ! *((1.+epssm)*(rhs(i,k )-rhs(i,k-1 )) & ! +(1.-epssm)*(ph(i,k,j)-ph(i,k-1,j))) & ! -dts*g*(2.*rdnw(k-1)* & ! c2a(i,k-1,j)*alt(i,k-1,j)*t_2ave(i,k-1,j) & ! + muave(i,j)) ) ! if(top_lid)w(i,k,j) = 0. ! ! ENDDO ! ! DO k=2,k_end+1 ! DO i=i_start, i_end ! w(i,k,j)=(w(i,k,j)-a(i,k,j)*w(i,k-1,j))*alpha(i,k,j) ! ENDDO ! ENDDO ! ! DO k=k_end,2,-1 ! DO i=i_start, i_end ! w (i,k,j)=w (i,k,j)-gamma(i,k,j)*w(i,k+1,j) ! ENDDO ! ENDDO ! IF (config_flags%damp_opt .eq. 3) THEN ! ! DO k=k_end+1,2,-1 ! DO i=i_start, i_end ! htop=(ph_1(i,k_end+1,j)+phb(i,k_end+1,j))/g ! hk=(ph_1(i,k,j)+phb(i,k,j))/g ! hbot=htop-hdepth ! dampwt(k) = 0. ! if(hk .ge. hbot)then ! ! dampwt(k) = dampmag*sin(0.5*pi*(hk-hbot)/hdepth)*sin(0.5*pi*(hk-hbot)/hdepth) ! endif ! w(i,k,j) = (w(i,k,j) - dampwt(k)*mut(i,j)*w_save(i,k,j))/(1.+dampwt(k)) ! ENDDO ! ENDDO ! ENDIF ! ! DO k=k_end+1,2,-1 ! DO i=i_start, i_end ! ph(i,k,j) = rhs(i,k)+msfty(i,j)*.5*dts*g*(1.+epssm) & ! *w(i,k,j)/muts(i,j) ! ENDDO ! ENDDO ! ! ENDDO j_loop_w !PART III: INITIALIZATION OF LOCAL ADJOINT PERTURBATIONS Do K0_ADJ =its, ite a_mut_inv(K0_ADJ) =0.0 End Do Do K1_ADJ =kts, kte Do K0_ADJ =its, ite a_rhs(K0_ADJ,K1_ADJ) =0.0 End Do End Do Do K1_ADJ =kts, kte Do K0_ADJ =its, ite a_wdwn(K0_ADJ,K1_ADJ) =0.0 End Do End Do Do K0_ADJ =kts, kte a_dampwt(K0_ADJ) =0.0 End Do a_htop =0.0 a_hbot =0.0 a_hk =0.0 !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[6] DO j =j_end, j_start, -1 ! DO k=1, k_end ! DO i=i_start, i_end ! t_2ave(i,k,j) =Keep_Lpb6_t_2ave(i,k,j) ! END DO ! END DO ! DO k=2, k_end ! rhs(i,k) =Keep_Lpb6_rhs(i,k) ! END DO ! DO k=2, k_end ! DO i=i_start, i_end ! w(i,k,j) =Keep_Lpb6_w(i,k,j) ! END DO ! END DO ! DO k=2, k_end+1 ! DO i=i_start, i_end ! ph(i,k,j) =Keep_Lpb6_ph(i,k,j) ! END DO ! END DO DO i =i_start, i_end !THE KEEPING OPERATION IS NOT NECESSARY IF THE VARIABLE IS LOCALLY AN OUTPUT VARIABLE !REVISED BY WALLS ! Tmpv200(i) =mut_inv(i) mut_inv(i) =1./mut(i,j) msft_inv(i) =1./msfty(i,j) ENDDO DO k =1, k_end DO i =i_start, i_end Tmpv001 =(1.+epssm)*t_2(i,k,j) +(1.-epssm)*t_2ave(i,k,j) Tmpv002 =.5*Tmpv001 Tmpv300(i,k) =t_2ave(i,k,j) t_2ave(i,k,j) =Tmpv002 Tmpv001 =t_2ave(i,k,j) +muave(i,j)*t0 Tmpv002 =muts(i,j)*(t0 +t_1(i,k,j)) Tmpv301(i,k) =Tmpv001 Tmpv302(i,k) =Tmpv002 Tmpv003 =Tmpv301(i,k)/Tmpv302(i,k) Tmpv303(i,k) =t_2ave(i,k,j) t_2ave(i,k,j) =Tmpv003 Tmpv001 =ww(i,k+1,j) +ww(i,k,j) Tmpv002 =.5*Tmpv001 Tmpv003 =Tmpv002*rdnw(k) Tmpv004 =ph_1(i,k+1,j) -ph_1(i,k,j) Tmpv005 =Tmpv004 +phb(i,k+1,j) Tmpv006 =Tmpv005 -phb(i,k,j) Tmpv304(i,k) =Tmpv003 Tmpv305(i,k) =Tmpv006 Tmpv007 =Tmpv304(i,k)*Tmpv305(i,k) wdwn(i,k+1) =Tmpv007 ! Removed comment by Ning Pan, 2010-07-09 Tmpv001 =ph_tend(i,k+1,j) +.5*g*(1.-epssm)*w(i,k+1,j) Tmpv002 =dts*Tmpv001 Tmpv306(i,k) =rhs(i,k+1) rhs(i,k+1) =Tmpv002 ENDDO ENDDO DO k =2, k_end DO i =i_start, i_end Tmpv001 =fnm(k)*wdwn(i,k+1) +fnp(k)*wdwn(i,k) Tmpv002 =dts*Tmpv001 Tmpv003 =rhs(i,k) -Tmpv002 Tmpv307(i,k) =rhs(i,k) rhs(i,k) =Tmpv003 ENDDO ENDDO DO k =2, k_end+1 DO i =i_start, i_end Tmpv001 =msfty(i,j)*rhs(i,k)*mut_inv(i) Tmpv002 =ph(i,k,j) +Tmpv001 Tmpv308(i,k) =rhs(i,k) rhs(i,k) =Tmpv002 IF(top_lid .and. k.eq.k_end+1) THEN Tmpv309(i,k) =rhs(i,k) rhs(i,k) =0. END IF ENDDO ENDDO DO i =i_start, i_end Tmpv001 =ht(i,j+1) -ht(i,j) Tmpv002 =cf1*v(i,1,j+1) +cf2*v(i,2,j+1) Tmpv003 =Tmpv002 +cf3*v(i,3,j+1) Tmpv201(i) =Tmpv001 Tmpv202(i) =Tmpv003 Tmpv004 =Tmpv201(i)*Tmpv202(i) Tmpv005 =ht(i,j) -ht(i,j-1) Tmpv006 =cf1*v(i,1,j) +cf2*v(i,2,j) Tmpv007 =Tmpv006 +cf3*v(i,3,j) Tmpv203(i) =Tmpv005 Tmpv204(i) =Tmpv007 Tmpv008 =Tmpv203(i)*Tmpv204(i) Tmpv009 =Tmpv004 +Tmpv008 Tmpv010 =msfty(i,j)*.5*rdy*Tmpv009 Tmpv011 =ht(i+1,j) -ht(i,j) Tmpv012 =cf1*u(i+1,1,j) +cf2*u(i+1,2,j) Tmpv013 =Tmpv012 +cf3*u(i+1,3,j) Tmpv205(i) =Tmpv011 Tmpv206(i) =Tmpv013 Tmpv014 =Tmpv205(i)*Tmpv206(i) Tmpv015 =ht(i,j) -ht(i-1,j) Tmpv016 =cf1*u(i,1,j) +cf2*u(i,2,j) Tmpv017 =Tmpv016 +cf3*u(i,3,j) Tmpv207(i) =Tmpv015 Tmpv208(i) =Tmpv017 Tmpv018 =Tmpv207(i)*Tmpv208(i) Tmpv019 =Tmpv014 +Tmpv018 Tmpv020 =msftx(i,j)*.5*rdx*Tmpv019 Tmpv021 =Tmpv010 +Tmpv020 Tmpv209(i) =w(i,1,j) w(i,1,j) =Tmpv021 ENDDO DO k =2, k_end DO i =i_start, i_end Tmpv001 =w(i,k,j) +dts*rw_tend(i,k,j) Tmpv002 =rhs(i,k+1) -rhs(i,k) Tmpv003 =(1.+epssm)*Tmpv002 Tmpv004 =ph(i,k+1,j) -ph(i,k,j) Tmpv005 =(1.-epssm)*Tmpv004 Tmpv006 =Tmpv003 +Tmpv005 Tmpv3010(i,k) =Tmpv006 Tmpv007 =c2a(i,k,j)*rdnw(k)*Tmpv3010(i,k) Tmpv008 =rhs(i,k) -rhs(i,k-1) Tmpv009 =(1.+epssm)*Tmpv008 Tmpv010 =ph(i,k,j) -ph(i,k-1,j) Tmpv011 =(1.-epssm)*Tmpv010 Tmpv012 =Tmpv009 +Tmpv011 Tmpv3011(i,k) =Tmpv012 Tmpv013 =c2a(i,k-1,j)*rdnw(k-1)*Tmpv3011(i,k) Tmpv014 =Tmpv007 -Tmpv013 Tmpv3012(i,k) =Tmpv014 Tmpv015 =.5*dts*g*mut_inv(i)*rdn(k)*Tmpv3012(i,k) Tmpv3013(i,k) =+Tmpv015 Tmpv016 =msft_inv(i)*cqw(i,k,j)*Tmpv3013(i,k) Tmpv017 =Tmpv001 +Tmpv016 Tmpv018 =c2a(i,k,j)*alt(i,k,j) Tmpv3014(i,k) =Tmpv018 Tmpv019 =Tmpv3014(i,k)*t_2ave(i,k,j) Tmpv020 =c2a(i,k-1,j)*alt(i,k-1,j) Tmpv3015(i,k) =Tmpv020 Tmpv021 =Tmpv3015(i,k)*t_2ave(i,k-1,j) Tmpv022 =Tmpv019 -Tmpv021 Tmpv023 =rdn(k)*Tmpv022 Tmpv024 =Tmpv023 -muave(i,j) Tmpv025 =dts*g*msft_inv(i)*Tmpv024 Tmpv026 =Tmpv017 +Tmpv025 Tmpv3016(i,k) =w(i,k,j) w(i,k,j) =Tmpv026 ENDDO ENDDO K =k_end+1 DO i =i_start, i_end !DELETE JUST FOR TUNNING Tmpv001 =w(i,k,j) +dts*rw_tend(i,k,j) Tmpv002 =-.5*dts*g*mut_inv(i)*rdnw(k-1)**2*2.*c2a(i,k-1,j) Tmpv003 =rhs(i,k) -rhs(i,k-1) Tmpv004 =(1.+epssm)*Tmpv003 Tmpv005 =ph(i,k,j) -ph(i,k-1,j) Tmpv006 =(1.-epssm)*Tmpv005 Tmpv007 =Tmpv004 +Tmpv006 Tmpv2010(i) =Tmpv002 Tmpv2011(i) =Tmpv007 Tmpv008 =Tmpv2010(i)*Tmpv2011(i) Tmpv009 =2.*rdnw(k-1)*c2a(i,k-1,j)*alt(i,k-1,j) Tmpv2012(i) =Tmpv009 Tmpv010 =Tmpv2012(i)*t_2ave(i,k-1,j) Tmpv011 =Tmpv010 +muave(i,j) Tmpv012 =dts*g*Tmpv011 Tmpv013 =Tmpv008 -Tmpv012 Tmpv014 =msft_inv(i)*Tmpv013 Tmpv015 =Tmpv001 +Tmpv014 Tmpv2013(i) =w(i,k,j) w(i,k,j) =Tmpv015 IF(top_lid) THEN Tmpv2014(i) =w(i,k,j) w(i,k,j) =0. END IF ENDDO DO k =2, k_end+1 DO i =i_start, i_end Tmpv001 =a(i,k,j)*w(i,k-1,j) Tmpv002 =w(i,k,j) -Tmpv001 Tmpv3017(i,k) =Tmpv002 Tmpv003 =Tmpv3017(i,k)*alpha(i,k,j) ! Tmpv3018(i,k) =w(i,k,j) Tmpv3018(i,k) =w(i,k-1,j) !REVISED BY WALLS w(i,k,j) =Tmpv003 ENDDO ENDDO DO k =k_end, 2, -1 DO i =i_start, i_end Tmpv001 =gamma(i,k,j)*w(i,k+1,j) Tmpv002 =w(i,k,j) -Tmpv001 ! Tmpv3019(i,k) =w(i,k,j) Tmpv3019(i,k) =w(i,k+1,j) !REVISED BY WALLS w(i,k,j) =Tmpv002 ENDDO ENDDO IF(config_flags%damp_opt .eq. 3) THEN DO k =k_end+1, 2, -1 DO i =i_start, i_end htop =(ph_1(i,k_end+1,j) +phb(i,k_end+1,j))/g !REVISED BY WALLS hk =(ph_1(i,k,j) +phb(i,k,j))/g hbot =htop -hdepth Tmpv3020(i,k) =dampwt(k) dampwt(k) =0. Tmpv3029(i,k) =hk !REVISED BY WALLS Tmpv3030(i,k) =hbot !REVISED BY WALLS IF(hk .ge. hbot) THEN Tmpv001 =hk -hbot Tmpv002 =0.5*pi*Tmpv001 Tmpv003 =Tmpv002/hdepth Tmpv3021(i,k) =Tmpv003 Tmpv004 =sin(Tmpv3021(i,k)) Tmpv005 =dampmag*Tmpv004 Tmpv006 =hk -hbot Tmpv007 =0.5*pi*Tmpv006 Tmpv008 =Tmpv007/hdepth Tmpv3022(i,k) =Tmpv008 Tmpv009 =sin(Tmpv3022(i,k)) Tmpv3023(i,k) =Tmpv005 Tmpv3024(i,k) =Tmpv009 Tmpv010 =Tmpv3023(i,k)*Tmpv3024(i,k) Tmpv3025(i,k) =dampwt(k) dampwt(k) =Tmpv010 endif Tmpv001 =dampwt(k)*mut(i,j) Tmpv3026(i,k) =Tmpv001 Tmpv002 =Tmpv3026(i,k)*w_save(i,k,j) Tmpv003 =w(i,k,j) -Tmpv002 Tmpv3027(i,k) =Tmpv003 Tmpv004 =Tmpv3027(i,k)/(1. +dampwt(k)) ! Tmpv3028(i,k) =w(i,k,j), REVISED BY WALLS Tmpv3028(i,k) =dampwt(k) !REVISED BY WALLS w(i,k,j) =Tmpv004 ENDDO ENDDO ENDIF ! Ning Pan, 2010-07-09 - No need to recalculate ph ! DO k =k_end+1, 2, -1 ! DO i =i_start, i_end !DELETE! JUST FOR TUNNING !! Tmpv001 =msfty(i,j)*.5*dts*g*(1.+epssm)*w(i,k,j)/muts(i,j) !! Tmpv002 =rhs(i,k) +Tmpv001 !! ph(i,k,j) =Tmpv002 ! ENDDO ! ENDDO DO k =2, k_end+1, 1 DO i =i_end, i_start, -1 !DELETE JUST FOR TUNNING a_Tmpv2 =a_ph(i,k,j) a_ph(i,k,j) =0.0 a_rhs(i,k) =a_rhs(i,k) +a_Tmpv2 a_Tmpv1 =a_Tmpv2 a_w(i,k,j) =a_w(i,k,j) +msfty(i,j)*.5*dts*g*(1.+epssm)/muts(i,j)*a_Tmpv1 a_muts(i,j) =a_muts(i,j) -msfty(i,j)*.5*dts*g*(1.+epssm)*w(i,k,j)/(muts(i,j) & *muts(i,j))*a_Tmpv1 ENDDO ENDDO IF(config_flags%damp_opt .eq. 3) THEN DO k =2, k_end+1, 1 DO i =i_end, i_start, -1 ! w(i,k,j) =Tmpv3028(i,k), REVISED BY WALLS a_Tmpv4 =a_w(i,k,j) a_w(i,k,j) =0.0 dampwt(k) =Tmpv3028(i,k) !REVISED BY WALLS a_Tmpv3 =a_Tmpv4/(1. +dampwt(k)) a_dampwt(k) =a_dampwt(k) -Tmpv3027(i,k)/((1. +dampwt(k))*(1. +dampwt(k)))*a_Tmpv4 a_w(i,k,j) =a_w(i,k,j) +a_Tmpv3 a_Tmpv2 =-a_Tmpv3 a_Tmpv1 =w_save(i,k,j)*a_Tmpv2 a_w_save(i,k,j) =a_w_save(i,k,j) +Tmpv3026(i,k)*a_Tmpv2 a_dampwt(k) =a_dampwt(k) +mut(i,j)*a_Tmpv1 a_mut(i,j) =a_mut(i,j) +dampwt(k)*a_Tmpv1 hk =Tmpv3029(i,k) !REVISED BY WALLS hbot =Tmpv3030(i,k) !REVISED BY WALLS IF(hk .ge. hbot) THEN dampwt(k) =Tmpv3025(i,k) a_Tmpv10 =a_dampwt(k) a_dampwt(k) =0.0 a_Tmpv5 =Tmpv3024(i,k)*a_Tmpv10 a_Tmpv9 =Tmpv3023(i,k)*a_Tmpv10 a_Tmpv8 =cos(Tmpv3022(i,k))*a_Tmpv9 a_Tmpv7 =a_Tmpv8/hdepth a_Tmpv6 =0.5*pi*a_Tmpv7 a_hk =a_hk +a_Tmpv6 a_hbot =a_hbot -a_Tmpv6 a_Tmpv4 =dampmag*a_Tmpv5 a_Tmpv3 =cos(Tmpv3021(i,k))*a_Tmpv4 a_Tmpv2 =a_Tmpv3/hdepth a_Tmpv1 =0.5*pi*a_Tmpv2 a_hk =a_hk +a_Tmpv1 a_hbot =a_hbot -a_Tmpv1 ENDIF !REVISED BY WALLS ! endif dampwt(k) =Tmpv3020(i,k) a_dampwt(k) =0.0 a_htop =a_htop +a_hbot a_hbot =0.0 a_ph_1(i,k,j) =a_ph_1(i,k,j) +1.0/g*a_hk a_hk =0.0 a_ph_1(i,k_end+1,j) =a_ph_1(i,k_end+1,j) +1.0/g*a_htop a_htop =0.0 ENDDO ENDDO ENDIF DO k =2, k_end, 1 DO i =i_end, i_start, -1 ! w(i,k,j) =Tmpv3019(i,k) w(i,k+1,j) =Tmpv3019(i,k) !REVISED BY WALLS a_Tmpv2 =a_w(i,k,j) a_w(i,k,j) =0.0 a_w(i,k,j) =a_w(i,k,j) +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_gamma(i,k,j) =a_gamma(i,k,j) +w(i,k+1,j)*a_Tmpv1 a_w(i,k+1,j) =a_w(i,k+1,j) +gamma(i,k,j)*a_Tmpv1 ENDDO ENDDO DO k =k_end+1, 2, -1 DO i =i_end, i_start, -1 ! w(i,k,j) =Tmpv3018(i,k) w(i,k-1,j) =Tmpv3018(i,k) a_Tmpv3 =a_w(i,k,j) a_w(i,k,j) =0.0 a_Tmpv2 =alpha(i,k,j)*a_Tmpv3 a_alpha(i,k,j) =a_alpha(i,k,j) +Tmpv3017(i,k)*a_Tmpv3 a_w(i,k,j) =a_w(i,k,j) +a_Tmpv2 a_Tmpv1 =-a_Tmpv2 a_a(i,k,j) =a_a(i,k,j) +w(i,k-1,j)*a_Tmpv1 a_w(i,k-1,j) =a_w(i,k-1,j) +a(i,k,j)*a_Tmpv1 ENDDO ENDDO K=k_end+1 ! Added by Ning Pan, 2010-07-09 DO i =i_end, i_start, -1 !DELETE JUST FOR TUNNING IF(top_lid) THEN w(i,k,j) =Tmpv2014(i) a_w(i,k,j) =0.0 END IF w(i,k,j) =Tmpv2013(i) a_Tmpv15 =a_w(i,k,j) a_w(i,k,j) =0.0 a_Tmpv1 =a_Tmpv15 a_Tmpv14 =a_Tmpv15 a_Tmpv13 =msft_inv(i)*a_Tmpv14 a_Tmpv8 =a_Tmpv13 a_Tmpv12 =-a_Tmpv13 a_Tmpv11 =dts*g*a_Tmpv12 a_Tmpv10 =a_Tmpv11 a_muave(i,j) =a_muave(i,j) +a_Tmpv11 a_Tmpv9 =t_2ave(i,k-1,j)*a_Tmpv10 a_t_2ave(i,k-1,j) =a_t_2ave(i,k-1,j) +Tmpv2012(i)*a_Tmpv10 a_c2a(i,k-1,j) =a_c2a(i,k-1,j) +2.*rdnw(k-1)*alt(i,k-1,j)*a_Tmpv9 a_alt(i,k-1,j) =a_alt(i,k-1,j) +2.*rdnw(k-1)*c2a(i,k-1,j)*a_Tmpv9 a_Tmpv2 =Tmpv2011(i)*a_Tmpv8 a_Tmpv7 =Tmpv2010(i)*a_Tmpv8 a_Tmpv4 =a_Tmpv7 a_Tmpv6 =a_Tmpv7 a_Tmpv5 =(1.-epssm)*a_Tmpv6 a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv5 a_ph(i,k-1,j) =a_ph(i,k-1,j) -a_Tmpv5 a_Tmpv3 =(1.+epssm)*a_Tmpv4 a_rhs(i,k) =a_rhs(i,k) +a_Tmpv3 a_rhs(i,k-1) =a_rhs(i,k-1) -a_Tmpv3 a_mut_inv(i) =a_mut_inv(i) -.5*dts*g*rdnw(k-1)**2*2.*c2a(i,k-1,j)*a_Tmpv2 a_c2a(i,k-1,j) =a_c2a(i,k-1,j) -.5*dts*g*mut_inv(i)*rdnw(k-1)**2*2.*a_Tmpv2 a_w(i,k,j) =a_w(i,k,j) +a_Tmpv1 a_rw_tend(i,k,j) =a_rw_tend(i,k,j) +dts*a_Tmpv1 ENDDO ! K=k_end+1, REVISED BY WALLS DO k =k_end, 2, -1 DO i =i_end, i_start, -1 w(i,k,j) =Tmpv3016(i,k) a_Tmpv26 =a_w(i,k,j) a_w(i,k,j) =0.0 a_Tmpv17 =a_Tmpv26 a_Tmpv25 =a_Tmpv26 a_Tmpv24 =dts*g*msft_inv(i)*a_Tmpv25 a_Tmpv23 =a_Tmpv24 a_muave(i,j) =a_muave(i,j) -a_Tmpv24 a_Tmpv22 =rdn(k)*a_Tmpv23 a_Tmpv19 =a_Tmpv22 a_Tmpv21 =-a_Tmpv22 a_Tmpv20 =t_2ave(i,k-1,j)*a_Tmpv21 a_t_2ave(i,k-1,j) =a_t_2ave(i,k-1,j) +Tmpv3015(i,k)*a_Tmpv21 a_c2a(i,k-1,j) =a_c2a(i,k-1,j) +alt(i,k-1,j)*a_Tmpv20 a_alt(i,k-1,j) =a_alt(i,k-1,j) +c2a(i,k-1,j)*a_Tmpv20 a_Tmpv18 =t_2ave(i,k,j)*a_Tmpv19 a_t_2ave(i,k,j) =a_t_2ave(i,k,j) +Tmpv3014(i,k)*a_Tmpv19 a_c2a(i,k,j) =a_c2a(i,k,j) +alt(i,k,j)*a_Tmpv18 a_alt(i,k,j) =a_alt(i,k,j) +c2a(i,k,j)*a_Tmpv18 a_Tmpv1 =a_Tmpv17 a_Tmpv16 =a_Tmpv17 a_cqw(i,k,j) =a_cqw(i,k,j) +msft_inv(i)*Tmpv3013(i,k)*a_Tmpv16 a_Tmpv15 =msft_inv(i)*cqw(i,k,j)*a_Tmpv16 a_mut_inv(i) =a_mut_inv(i) +.5*dts*g*rdn(k)*Tmpv3012(i,k)*a_Tmpv15 a_Tmpv14 =.5*dts*g*mut_inv(i)*rdn(k)*a_Tmpv15 a_Tmpv7 =a_Tmpv14 a_Tmpv13 =-a_Tmpv14 a_c2a(i,k-1,j) =a_c2a(i,k-1,j) +rdnw(k-1)*Tmpv3011(i,k)*a_Tmpv13 a_Tmpv12 =c2a(i,k-1,j)*rdnw(k-1)*a_Tmpv13 a_Tmpv9 =a_Tmpv12 a_Tmpv11 =a_Tmpv12 a_Tmpv10 =(1.-epssm)*a_Tmpv11 a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv10 a_ph(i,k-1,j) =a_ph(i,k-1,j) -a_Tmpv10 a_Tmpv8 =(1.+epssm)*a_Tmpv9 a_rhs(i,k) =a_rhs(i,k) +a_Tmpv8 a_rhs(i,k-1) =a_rhs(i,k-1) -a_Tmpv8 a_c2a(i,k,j) =a_c2a(i,k,j) +rdnw(k)*Tmpv3010(i,k)*a_Tmpv7 a_Tmpv6 =c2a(i,k,j)*rdnw(k)*a_Tmpv7 a_Tmpv3 =a_Tmpv6 a_Tmpv5 =a_Tmpv6 a_Tmpv4 =(1.-epssm)*a_Tmpv5 a_ph(i,k+1,j) =a_ph(i,k+1,j) +a_Tmpv4 a_ph(i,k,j) =a_ph(i,k,j) -a_Tmpv4 a_Tmpv2 =(1.+epssm)*a_Tmpv3 a_rhs(i,k+1) =a_rhs(i,k+1) +a_Tmpv2 a_rhs(i,k) =a_rhs(i,k) -a_Tmpv2 a_w(i,k,j) =a_w(i,k,j) +a_Tmpv1 a_rw_tend(i,k,j) =a_rw_tend(i,k,j) +dts*a_Tmpv1 ENDDO ENDDO DO i =i_end, i_start, -1 w(i,1,j) =Tmpv209(i) a_Tmpv21 =a_w(i,1,j) a_w(i,1,j) =0.0 a_Tmpv10 =a_Tmpv21 a_Tmpv20 =a_Tmpv21 a_Tmpv19 =msftx(i,j)*.5*rdx*a_Tmpv20 a_Tmpv14 =a_Tmpv19 a_Tmpv18 =a_Tmpv19 a_Tmpv15 =Tmpv208(i)*a_Tmpv18 a_Tmpv17 =Tmpv207(i)*a_Tmpv18 a_Tmpv16 =a_Tmpv17 a_u(i,3,j) =a_u(i,3,j) +cf3*a_Tmpv17 a_u(i,1,j) =a_u(i,1,j) +cf1*a_Tmpv16 a_u(i,2,j) =a_u(i,2,j) +cf2*a_Tmpv16 ! a_ht(i,j) =a_ht(i,j) +a_Tmpv15 ! Remarked by Ning Pan, 2010-07-09 ! a_ht(i-1,j) =a_ht(i-1,j) -a_Tmpv15 ! Remarked by Ning Pan, 2010-07-09 a_Tmpv11 =Tmpv206(i)*a_Tmpv14 a_Tmpv13 =Tmpv205(i)*a_Tmpv14 a_Tmpv12 =a_Tmpv13 a_u(i+1,3,j) =a_u(i+1,3,j) +cf3*a_Tmpv13 a_u(i+1,1,j) =a_u(i+1,1,j) +cf1*a_Tmpv12 a_u(i+1,2,j) =a_u(i+1,2,j) +cf2*a_Tmpv12 ! a_ht(i+1,j) =a_ht(i+1,j) +a_Tmpv11 ! Remarked by Ning Pan, 2010-07-09 ! a_ht(i,j) =a_ht(i,j) -a_Tmpv11 ! Remarked by Ning Pan, 2010-07-09 a_Tmpv9 =msfty(i,j)*.5*rdy*a_Tmpv10 a_Tmpv4 =a_Tmpv9 a_Tmpv8 =a_Tmpv9 a_Tmpv5 =Tmpv204(i)*a_Tmpv8 a_Tmpv7 =Tmpv203(i)*a_Tmpv8 a_Tmpv6 =a_Tmpv7 a_v(i,3,j) =a_v(i,3,j) +cf3*a_Tmpv7 a_v(i,1,j) =a_v(i,1,j) +cf1*a_Tmpv6 a_v(i,2,j) =a_v(i,2,j) +cf2*a_Tmpv6 ! a_ht(i,j) =a_ht(i,j) +a_Tmpv5 ! Remarked by Ning Pan, 2010-07-09 ! a_ht(i,j-1) =a_ht(i,j-1) -a_Tmpv5 ! Remarked by Ning Pan, 2010-07-09 a_Tmpv1 =Tmpv202(i)*a_Tmpv4 a_Tmpv3 =Tmpv201(i)*a_Tmpv4 a_Tmpv2 =a_Tmpv3 a_v(i,3,j+1) =a_v(i,3,j+1) +cf3*a_Tmpv3 a_v(i,1,j+1) =a_v(i,1,j+1) +cf1*a_Tmpv2 a_v(i,2,j+1) =a_v(i,2,j+1) +cf2*a_Tmpv2 ! a_ht(i,j+1) =a_ht(i,j+1) +a_Tmpv1 ! Remarked by Ning Pan, 2010-07-09 ! a_ht(i,j) =a_ht(i,j) -a_Tmpv1 ! Remarked by Ning Pan, 2010-07-09 ENDDO DO k =k_end+1, 2, -1 DO i =i_end, i_start, -1 IF(top_lid .and. k.eq.k_end+1) THEN rhs(i,k) =Tmpv309(i,k) a_rhs(i,k) =0.0 END IF rhs(i,k) =Tmpv308(i,k) a_Tmpv2 =a_rhs(i,k) a_rhs(i,k) =0.0 a_ph(i,k,j) =a_ph(i,k,j) +a_Tmpv2 a_Tmpv1 =a_Tmpv2 a_rhs(i,k) =a_rhs(i,k) +msfty(i,j)*mut_inv(i)*a_Tmpv1 a_mut_inv(i) =a_mut_inv(i) +msfty(i,j)*rhs(i,k)*a_Tmpv1 ENDDO ENDDO DO k =k_end, 2, -1 DO i =i_end, i_start, -1 rhs(i,k) =Tmpv307(i,k) a_Tmpv3 =a_rhs(i,k) a_rhs(i,k) =0.0 a_rhs(i,k) =a_rhs(i,k) +a_Tmpv3 a_Tmpv2 =-a_Tmpv3 a_Tmpv1 =dts*a_Tmpv2 a_wdwn(i,k+1) =a_wdwn(i,k+1) +fnm(k)*a_Tmpv1 a_wdwn(i,k) =a_wdwn(i,k) +fnp(k)*a_Tmpv1 ENDDO ENDDO DO k =k_end, 1, -1 DO i =i_end, i_start, -1 rhs(i,k+1) =Tmpv306(i,k) a_Tmpv2 =a_rhs(i,k+1) a_rhs(i,k+1) =0.0 a_Tmpv1 =dts*a_Tmpv2 a_ph_tend(i,k+1,j) =a_ph_tend(i,k+1,j) +a_Tmpv1 a_w(i,k+1,j) =a_w(i,k+1,j) +.5*g*(1.-epssm)*a_Tmpv1 a_Tmpv7 =a_wdwn(i,k+1) a_wdwn(i,k+1) =0.0 a_Tmpv3 =Tmpv305(i,k)*a_Tmpv7 a_Tmpv6 =Tmpv304(i,k)*a_Tmpv7 a_Tmpv5 =a_Tmpv6 a_Tmpv4 =a_Tmpv5 a_ph_1(i,k+1,j) =a_ph_1(i,k+1,j) +a_Tmpv4 a_ph_1(i,k,j) =a_ph_1(i,k,j) -a_Tmpv4 a_Tmpv2 =rdnw(k)*a_Tmpv3 a_Tmpv1 =.5*a_Tmpv2 a_ww(i,k+1,j) =a_ww(i,k+1,j) +a_Tmpv1 a_ww(i,k,j) =a_ww(i,k,j) +a_Tmpv1 t_2ave(i,k,j) =Tmpv303(i,k) a_Tmpv3 =a_t_2ave(i,k,j) a_t_2ave(i,k,j) =0.0 a_Tmpv1 =a_Tmpv3/Tmpv302(i,k) a_Tmpv2 =-Tmpv301(i,k)/(Tmpv302(i,k)*Tmpv302(i,k))*a_Tmpv3 a_muts(i,j) =a_muts(i,j) +(t0 +t_1(i,k,j))*a_Tmpv2 a_t_1(i,k,j) =a_t_1(i,k,j) +muts(i,j)*a_Tmpv2 a_t_2ave(i,k,j) =a_t_2ave(i,k,j) +a_Tmpv1 a_muave(i,j) =a_muave(i,j) +t0*a_Tmpv1 t_2ave(i,k,j) =Tmpv300(i,k) a_Tmpv2 =a_t_2ave(i,k,j) a_t_2ave(i,k,j) =0.0 a_Tmpv1 =.5*a_Tmpv2 a_t_2(i,k,j) =a_t_2(i,k,j) +(1.+epssm)*a_Tmpv1 a_t_2ave(i,k,j) =a_t_2ave(i,k,j) +(1.-epssm)*a_Tmpv1 ENDDO ENDDO DO i =i_end, i_start, -1 ! mut_inv(i) =Tmpv200(i), REVISED BY WALLS a_mut(i,j) =a_mut(i,j) -1./(mut(i,j)*mut(i,j))*a_mut_inv(i) a_mut_inv(i) =0.0 ENDDO ENDDO !LPB[5] DO i =i_end, i_start, -1 ! rhs(i,1) =0. a_rhs(i,1) =0.0 ENDDO !LPB[4] ! pi =4.*Atan(1.) ! dampmag =dts*config_flags%dampcoef ! hdepth =config_flags%zdamp !LPB[3] ! IF( config_flags%specified .or. config_flags%nested ) THEN ! j_start =max(jts, jds+1) ! j_end =min(jte, jde-2) ! ENDIF IF( config_flags%specified .or. config_flags%nested ) THEN ENDIF !LPB[2] !LPB[1] ! IF( .NOT. config_flags%periodic_x ) THEN ! IF( config_flags%specified .or. config_flags%nested ) THEN ! i_start =max(its, ids+1) ! i_end =min(ite, ide-2) ! ENDIF ! ENDIF IF( .NOT. config_flags%periodic_x ) THEN IF( config_flags%specified .or. config_flags%nested ) THEN ENDIF ENDIF !LPB[0] ! i_start =its ! i_end =min(ite, ide-1) ! j_start =jts ! j_end =min(jte, jde-1) ! k_start =kts ! k_end =kte-1 END SUBROUTINE a_advance_w SUBROUTINE a_sumflux(ru,a_ru,rv,a_rv,ww,a_ww,u_lin,a_u_lin,v_lin, & a_v_lin,ww_lin,a_ww_lin,muu,a_muu,muv,a_muv,ru_m,a_ru_m,rv_m,a_rv_m, & ww_m,a_ww_m,epssm,msfux,msfuy,msfvx,msfvx_inv,msfvy,iteration,number_of_small_timesteps, & 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 INTEGER :: number_of_small_timesteps INTEGER :: iteration INTEGER :: ids,ide,jds,jde,kds,kde INTEGER :: ims,ime,jms,jme,kms,kme INTEGER :: its,ite,jts,jte,kts,kte REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_ru,ru,a_rv,rv,a_ww,ww,a_u_lin, & u_lin,a_v_lin,v_lin,a_ww_lin,ww_lin REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: a_ru_m,ru_m,a_rv_m,rv_m,a_ww_m,ww_m REAL,DIMENSION(ims:ime,jms:jme) :: a_muu,muu,a_muv,muv,msfux,msfuy,msfvx,msfvy,msfvx_inv INTEGER :: mini,minj,mink REAL :: epssm INTEGER :: i,j,k REAL :: a_Tmpv1,Tmpv001,a_Tmpv2,Tmpv002,a_Tmpv3,Tmpv003 !PART II: CALCULATIONS OF B. S. TRAJECTORY !LPB[0] !LPB[1] IF (iteration == 1 )THEN DO j = jts, jte DO k = kts, kte DO i = its, ite ru_m(i,k,j) = 0. rv_m(i,k,j) = 0. ww_m(i,k,j) = 0. ENDDO ENDDO ENDDO ENDIF !LPB[2] mini = min(ide-1,ite) minj = min(jde-1,jte) mink = min(kde-1,kte) !LPB[3] DO j = jts, minj DO k = kts, mink DO i = its, mini ru_m(i,k,j) = ru_m(i,k,j) + ru(i,k,j) rv_m(i,k,j) = rv_m(i,k,j) + rv(i,k,j) ww_m(i,k,j) = ww_m(i,k,j) + ww(i,k,j) ENDDO ENDDO ENDDO !LPB[4] !LPB[5] IF (ite .GT. mini) THEN DO j = jts, minj DO k = kts, mink DO i = mini+1, ite ru_m(i,k,j) = ru_m(i,k,j) + ru(i,k,j) ENDDO ENDDO ENDDO END IF !LPB[6] !LPB[7] IF (jte .GT. minj) THEN DO j = minj+1, jte DO k = kts, mink DO i = its, mini rv_m(i,k,j) = rv_m(i,k,j) + rv(i,k,j) ENDDO ENDDO ENDDO END IF !LPB[8] !LPB[9] IF ( kte .GT. mink) THEN DO j = jts, minj DO k = mink+1, kte DO i = its, mini ww_m(i,k,j) = ww_m(i,k,j) + ww(i,k,j) ENDDO ENDDO ENDDO END IF !LPB[10] !!LPB[11] ! ! IF (iteration == number_of_small_timesteps) THEN ! DO j = jts, minj ! DO k = kts, mink ! DO i = its, mini ! ru_m(i,k,j) = ru_m(i,k,j) / number_of_small_timesteps & ! + muu(i,j)*u_lin(i,k,j)/msfuy(i,j) ! rv_m(i,k,j) = rv_m(i,k,j) / number_of_small_timesteps & ! + muv(i,j)*v_lin(i,k,j)*msfvx_inv(i,j) ! ww_m(i,k,j) = ww_m(i,k,j) / number_of_small_timesteps & ! + ww_lin(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! IF (ite .GT. mini) THEN ! DO j = jts, minj ! DO k = kts, mink ! DO i = mini+1, ite ! ru_m(i,k,j) = ru_m(i,k,j) / number_of_small_timesteps & ! + muu(i,j)*u_lin(i,k,j)/msfuy(i,j) ! ENDDO ! ENDDO ! ENDDO ! END IF ! IF (jte .GT. minj) THEN ! DO j = minj+1, jte ! DO k = kts, mink ! DO i = its, mini ! rv_m(i,k,j) = rv_m(i,k,j) / number_of_small_timesteps & ! + muv(i,j)*v_lin(i,k,j)*msfvx_inv(i,j) ! ENDDO ! ENDDO ! ENDDO ! END IF ! IF ( kte .GT. mink) THEN ! DO j = jts, minj ! DO k = mink+1, kte ! DO i = its, mini ! ww_m(i,k,j) = ww_m(i,k,j) / number_of_small_timesteps & ! + ww_lin(i,k,j) ! ENDDO ! ENDDO ! ENDDO ! END IF ! ENDIF !PART IV: REVERSE/BACKWARD ACCUMULATIONS !LPB[11] IF(iteration == number_of_small_timesteps) THEN DO j =jts, minj DO k =kts, mink DO i =its, mini Tmpv001 =muu(i,j)*u_lin(i,k,j) Tmpv002 =Tmpv001/msfuy(i,j) Tmpv003 =ru_m(i,k,j)/number_of_small_timesteps +Tmpv002 ! ru_m(i,k,j) =Tmpv003 Tmpv001 =muv(i,j)*v_lin(i,k,j) Tmpv002 =Tmpv001*msfvx_inv(i,j) Tmpv003 =rv_m(i,k,j)/number_of_small_timesteps +Tmpv002 ! rv_m(i,k,j) =Tmpv003 Tmpv001 =ww_m(i,k,j)/number_of_small_timesteps +ww_lin(i,k,j) ! ww_m(i,k,j) =Tmpv001 ENDDO ENDDO ENDDO IF(ite .GT. mini) THEN DO j =jts, minj DO k =kts, mink DO i =mini+1, ite Tmpv001 =muu(i,j)*u_lin(i,k,j) Tmpv002 =Tmpv001/msfuy(i,j) Tmpv003 =ru_m(i,k,j)/number_of_small_timesteps +Tmpv002 ! ru_m(i,k,j) =Tmpv003 ENDDO ENDDO ENDDO END IF IF(jte .GT. minj) THEN DO j =minj+1, jte DO k =kts, mink DO i =its, mini Tmpv001 =muv(i,j)*v_lin(i,k,j) Tmpv002 =Tmpv001*msfvx_inv(i,j) Tmpv003 =rv_m(i,k,j)/number_of_small_timesteps +Tmpv002 ! rv_m(i,k,j) =Tmpv003 ENDDO ENDDO ENDDO END IF IF( kte .GT. mink) THEN DO j =jts, minj DO k =mink+1, kte DO i =its, mini Tmpv001 =ww_m(i,k,j)/number_of_small_timesteps +ww_lin(i,k,j) ! ww_m(i,k,j) =Tmpv001 ENDDO ENDDO ENDDO END IF ENDIF IF(iteration == number_of_small_timesteps) THEN IF( kte .GT. mink) THEN DO j =minj, jts, -1 DO k =kte, mink+1, -1 DO i =mini, its, -1 a_Tmpv1 =a_ww_m(i,k,j) a_ww_m(i,k,j) =0.0 a_ww_m(i,k,j) =a_ww_m(i,k,j) +1.0/number_of_small_timesteps*a_Tmpv1 a_ww_lin(i,k,j) =a_ww_lin(i,k,j) +a_Tmpv1 ENDDO ENDDO ENDDO END IF IF(jte .GT. minj) THEN DO j =jte, minj+1, -1 DO k =mink, kts, -1 DO i =mini, its, -1 a_Tmpv3 =a_rv_m(i,k,j) a_rv_m(i,k,j) =0.0 a_rv_m(i,k,j) =a_rv_m(i,k,j) +1.0/number_of_small_timesteps*a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =msfvx_inv(i,j)*a_Tmpv2 a_muv(i,j) =a_muv(i,j) +v_lin(i,k,j)*a_Tmpv1 a_v_lin(i,k,j) =a_v_lin(i,k,j) +muv(i,j)*a_Tmpv1 ENDDO ENDDO ENDDO END IF IF(ite .GT. mini) THEN DO j =minj, jts, -1 DO k =mink, kts, -1 DO i =ite, mini+1, -1 a_Tmpv3 =a_ru_m(i,k,j) a_ru_m(i,k,j) =0.0 a_ru_m(i,k,j) =a_ru_m(i,k,j) +1.0/number_of_small_timesteps*a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =a_Tmpv2/msfuy(i,j) a_muu(i,j) =a_muu(i,j) +u_lin(i,k,j)*a_Tmpv1 a_u_lin(i,k,j) =a_u_lin(i,k,j) +muu(i,j)*a_Tmpv1 ENDDO ENDDO ENDDO END IF DO j =minj, jts, -1 DO k =mink, kts, -1 DO i =mini, its, -1 a_Tmpv1 =a_ww_m(i,k,j) a_ww_m(i,k,j) =0.0 a_ww_m(i,k,j) =a_ww_m(i,k,j) +1.0/number_of_small_timesteps*a_Tmpv1 a_ww_lin(i,k,j) =a_ww_lin(i,k,j) +a_Tmpv1 a_Tmpv3 =a_rv_m(i,k,j) a_rv_m(i,k,j) =0.0 a_rv_m(i,k,j) =a_rv_m(i,k,j) +1.0/number_of_small_timesteps*a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =msfvx_inv(i,j)*a_Tmpv2 a_muv(i,j) =a_muv(i,j) +v_lin(i,k,j)*a_Tmpv1 a_v_lin(i,k,j) =a_v_lin(i,k,j) +muv(i,j)*a_Tmpv1 a_Tmpv3 =a_ru_m(i,k,j) a_ru_m(i,k,j) =0.0 a_ru_m(i,k,j) =a_ru_m(i,k,j) +1.0/number_of_small_timesteps*a_Tmpv3 a_Tmpv2 =a_Tmpv3 a_Tmpv1 =a_Tmpv2/msfuy(i,j) a_muu(i,j) =a_muu(i,j) +u_lin(i,k,j)*a_Tmpv1 a_u_lin(i,k,j) =a_u_lin(i,k,j) +muu(i,j)*a_Tmpv1 ENDDO ENDDO ENDDO ENDIF !LPB[10] !LPB[9] ! IF( kte .GT. mink) THEN ! DO j =jts, minj ! DO k =mink+1, kte ! DO i =its, mini ! Tmpv001 =ww_m(i,k,j) +ww(i,k,j) ! ww_m(i,k,j) =Tmpv001 ! ENDDO ! ENDDO ! ENDDO ! END IF IF( kte .GT. mink) THEN DO j =minj, jts, -1 DO k =kte, mink+1, -1 DO i =mini, its, -1 a_Tmpv1 =a_ww_m(i,k,j) a_ww_m(i,k,j) =0.0 a_ww_m(i,k,j) =a_ww_m(i,k,j) +a_Tmpv1 a_ww(i,k,j) =a_ww(i,k,j) +a_Tmpv1 ENDDO ENDDO ENDDO END IF !LPB[8] !LPB[7] ! IF(jte .GT. minj) THEN ! DO j =minj+1, jte ! DO k =kts, mink ! DO i =its, mini ! Tmpv001 =rv_m(i,k,j) +rv(i,k,j) ! rv_m(i,k,j) =Tmpv001 ! ENDDO ! ENDDO ! ENDDO ! END IF IF(jte .GT. minj) THEN DO j =jte, minj+1, -1 DO k =mink, kts, -1 DO i =mini, its, -1 a_Tmpv1 =a_rv_m(i,k,j) a_rv_m(i,k,j) =0.0 a_rv_m(i,k,j) =a_rv_m(i,k,j) +a_Tmpv1 a_rv(i,k,j) =a_rv(i,k,j) +a_Tmpv1 ENDDO ENDDO ENDDO END IF !LPB[6] !LPB[5] ! IF(ite .GT. mini) THEN ! DO j =jts, minj ! DO k =kts, mink ! DO i =mini+1, ite ! Tmpv001 =ru_m(i,k,j) +ru(i,k,j) ! ru_m(i,k,j) =Tmpv001 ! ENDDO ! ENDDO ! ENDDO ! END IF IF(ite .GT. mini) THEN DO j =minj, jts, -1 DO k =mink, kts, -1 DO i =ite, mini+1, -1 a_Tmpv1 =a_ru_m(i,k,j) a_ru_m(i,k,j) =0.0 a_ru_m(i,k,j) =a_ru_m(i,k,j) +a_Tmpv1 a_ru(i,k,j) =a_ru(i,k,j) +a_Tmpv1 ENDDO ENDDO ENDDO END IF !LPB[4] !LPB[3] DO j =minj, jts, -1 ! DO k =kts, mink ! DO i =its, mini ! Tmpv001 =ru_m(i,k,j) +ru(i,k,j) ! ru_m(i,k,j) =Tmpv001 ! Tmpv001 =rv_m(i,k,j) +rv(i,k,j) ! rv_m(i,k,j) =Tmpv001 ! Tmpv001 =ww_m(i,k,j) +ww(i,k,j) ! ww_m(i,k,j) =Tmpv001 ! ENDDO ! ENDDO DO k =mink, kts, -1 DO i =mini, its, -1 a_Tmpv1 =a_ww_m(i,k,j) a_ww_m(i,k,j) =0.0 a_ww_m(i,k,j) =a_ww_m(i,k,j) +a_Tmpv1 a_ww(i,k,j) =a_ww(i,k,j) +a_Tmpv1 a_Tmpv1 =a_rv_m(i,k,j) a_rv_m(i,k,j) =0.0 a_rv_m(i,k,j) =a_rv_m(i,k,j) +a_Tmpv1 a_rv(i,k,j) =a_rv(i,k,j) +a_Tmpv1 a_Tmpv1 =a_ru_m(i,k,j) a_ru_m(i,k,j) =0.0 a_ru_m(i,k,j) =a_ru_m(i,k,j) +a_Tmpv1 a_ru(i,k,j) =a_ru(i,k,j) +a_Tmpv1 ENDDO ENDDO ENDDO !LPB[2] ! mini =min(ide-1, ite) ! minj =min(jde-1, jte) ! mink =min(kde-1, kte) !LPB[1] ! IF(iteration == 1 ) THEN ! DO j =jts, jte ! DO k =kts, kte ! DO i =its, ite ! ru_m(i,k,j) =0. ! rv_m(i,k,j) =0. ! ww_m(i,k,j) =0. ! ENDDO ! ENDDO ! ENDDO ! ENDIF IF(iteration == 1 ) THEN DO j =jte, jts, -1 DO k =kte, kts, -1 DO i =ite, its, -1 a_ww_m(i,k,j) =0.0 a_rv_m(i,k,j) =0.0 a_ru_m(i,k,j) =0.0 ENDDO ENDDO ENDDO ENDIF !LPB[0] END SUBROUTINE a_sumflux SUBROUTINE a_init_module_small_step END SUBROUTINE a_init_module_small_step END MODULE a_module_small_step_em