<p><b>laura@ucar.edu</b> 2010-07-23 15:15:11 -0600 (Fri, 23 Jul 2010)</p><p>interface between physics and non-hydrostatic dynamical core<br>
</p><hr noshade><pre><font color="gray">Added: branches/atmos_physics/src/core_physics/module_physics_interface_nhyd.F
===================================================================
--- branches/atmos_physics/src/core_physics/module_physics_interface_nhyd.F (rev 0)
+++ branches/atmos_physics/src/core_physics/module_physics_interface_nhyd.F 2010-07-23 21:15:11 UTC (rev 412)
@@ -0,0 +1,340 @@
+!=============================================================================================
+ module module_physics_interface_nhyd
+ use configure
+ use grid_types
+
+ use module_physics_constants
+ use module_physics_vars
+
+ implicit none
+ private
+ public:: nhyd_to_physics, &
+ microphysics_nhyd_to_phys, &
+ microphysics_phys_to_nhyd
+
+ contains
+
+!=============================================================================================
+ subroutine nhyd_to_physics(grid,vars)
+!=============================================================================================
+
+!input variables:
+ type(grid_meta) ,intent(in):: grid
+ type(grid_state),intent(in):: vars
+
+!local variables:
+ integer:: i,k,j
+
+ real(kind=RKIND),dimension(:,:),pointer:: zgrid
+ real(kind=RKIND),dimension(:,:),pointer:: zz,exner,rtheta_p,rtheta_b
+ real(kind=RKIND),dimension(:,:),pointer:: rho,theta,qv,pressure,u,v,w
+
+!---------------------------------------------------------------------------------------------
+
+!write(6,*)
+!write(6,*) '--- enter subroutine nhyd_to_phys:'
+
+!initialization:
+ zgrid => grid% zgrid % array
+ zz => grid % zz % array
+ exner => grid % exner % array
+ rtheta_p => grid % rtheta_p % array
+ rtheta_b => grid % rtheta_base % array
+
+ rho => vars % rho % array
+ theta => vars % theta % array
+ pressure => vars % pressure % array
+ qv => vars % scalars % array(index_qv,:,:)
+
+ w => vars % w % array
+ u => vars % uReconstructZonal % array
+ v => vars % uReconstructMeridional % array
+
+!copy sounding variables from the geodesic grid to the wrf-physics grid:
+ do j = jts, jtf
+ do k = kts, ktf
+ do i = its, itf
+
+ u_p(i,k,j) = u(k,i)
+ v_p(i,k,j) = v(k,i)
+ w_p(i,k,j) = w(k,i)
+
+ rho_p(i,k,j) = zz(k,i) * rho(k,i)
+ th_p(i,k,j) = theta(k,i) / (1. + R_v/R_d * qv(k,i))
+ t_p(i,k,j) = theta(k,i) * exner(k,i)/ (1. + R_v/R_d * qv(k,i))
+
+ pi_p(i,k,j) = exner(k,i)
+ p_p(i,k,j) = R_d * zz(k,i) * exner(k,i) * (rtheta_p(k,i)+rtheta_b(k,i))
+
+ dz_p(i,k,j) = zgrid(k+1,i)-zgrid(k,i)
+
+ qv_p(i,k,j) = max(0.,vars % scalars % array(index_qv,k,i))
+
+ enddo
+ enddo
+ enddo
+
+ do j = jts, jtf
+ do i = 5000,5000
+ do k = ktf, kts, -1
+ write(6,201) i,k,p_p(i,k,j),pi_p(i,k,j),dz_p(i,k,j),rho_p(i,k,j),th_p(i,k,j), &
+ th_p(i,k,j)*pi_p(i,k,j),qv_p(i,k,j)
+ enddo
+ enddo
+ enddo
+ write(6,*) '--- end subroutine nhyd_to_phys:'
+
+ 201 format(2i8,10(1x,e15.8))
+
+ end subroutine nhyd_to_physics
+
+!=============================================================================================
+ subroutine microphysics_nhyd_to_phys(vars, grid)
+!=============================================================================================
+
+!input variables:
+ type(grid_meta) ,intent(in):: grid
+ type(grid_state),intent(in):: vars
+
+!local variables:
+ integer:: i,k,j
+ real(kind=RKIND),dimension(:,:),pointer:: zgrid
+ real(kind=RKIND),dimension(:,:),pointer:: zz,exner,rtheta_p,rtheta_b
+ real(kind=RKIND),dimension(:,:),pointer:: rho,theta,qv,pressure
+
+!---------------------------------------------------------------------------------------------
+
+!initialization:
+!write(6,*)
+!write(6,*) '--- enter subroutine microphysics_nhyd_to_phys:'
+!write(6,*) ' its= ',its,' ite=',itf
+!write(6,*) ' jts= ',jts,' jte=',jtf
+!write(6,*) ' kts= ',kts,' kte=',ktf
+
+ zgrid => grid% zgrid % array
+
+ zz => grid % zz % array
+ exner => grid % exner % array
+ rtheta_p => grid % rtheta_p % array
+ rtheta_b => grid % rtheta_base % array
+
+ rho => vars % rho % array
+ theta => vars % theta % array
+ pressure => vars % pressure % array
+
+ qv => vars % scalars % array(index_qv,:,:)
+
+!copy sounding variables from the geodesic grid to the wrf-physics grid:
+ do j = jts, jtf
+ do k = kts, ktf
+ do i = its, itf
+
+ rho_p(i,k,j) = zz(k,i) * rho(k,i)
+ th_p(i,k,j) = theta(k,i) / (1. + R_v/R_d * qv(k,i))
+
+ pi_p(i,k,j) = exner(k,i)
+ p_p(i,k,j) = R_d * zz(k,i) * exner(k,i) * (rtheta_p(k,i)+rtheta_b(k,i))
+
+ z_p(I,k,j) = 0.5*(zgrid(k+1,i)+zgrid(k,i))
+ dz_p(i,k,j) = zgrid(k+1,i)-zgrid(k,i)
+
+ qv_p(i,k,j) = max(0.,vars % scalars % array(index_qv,k,i))
+ qc_p(i,k,j) = max(0.,vars % scalars % array(index_qc,k,i))
+ qr_p(i,k,j) = max(0.,vars % scalars % array(index_qr,k,i))
+
+ enddo
+ enddo
+ enddo
+
+!additional initialization as function of cloud microphysics scheme:
+ microp_select_init: select case(microp_scheme)
+
+ case (microp_thompson)
+
+ do j = jts, jtf
+ do k = kts, ktf
+ do i = its, itf
+
+ !mass mixing ratios:
+ qi_p(i,k,j) = max(0.,vars % scalars % array(index_qi,k,i))
+ qs_p(i,k,j) = max(0.,vars % scalars % array(index_qs,k,i))
+ qg_p(i,k,j) = max(0.,vars % scalars % array(index_qg,k,i))
+
+ !number concentrations:
+ qnr_p(i,k,j) = max(0., vars % scalars % array(index_qnr,k,i))
+ qni_p(i,k,j) = max(0., vars % scalars % array(index_qni,k,i))
+
+ enddo
+ enddo
+ enddo
+
+ case default
+
+ end select microp_select_init
+
+!write(6,*) '--- end microphysics_nhyd_to_phys:'
+!do j = jts, jtf
+!do i = 100, 100
+!do k = ktf, kts, -1
+! write(6,201) j,i,k,p_phy(i,k,j),pi_phy(i,k,j),z_phy(i,k,j),dz_phy(i,k,j), &
+! th_phy(i,k,j),th_phy(i,k,j)*pi_phy(i,k,j),qv_phy(i,k,j),qc_phy(i,k,j), &
+! qr_phy(i,k,j)
+!enddo
+!write(6,*)
+!enddo
+!enddo
+
+!do i = its, itf
+!do i = 100, 100
+!do k = ktf, kts, -1
+! write(6,201) j,i,k,pressure(k,i),exner(k,i),theta(k,i),rtheta_p(k,i),rtheta_b(k,i)
+!enddo
+!write(6,*)
+!enddo
+
+!formats:
+ 201 format(3i6,10(1x,e15.8))
+
+ end subroutine microphysics_nhyd_to_phys
+
+!=============================================================================================
+ subroutine microphysics_phys_to_nhyd(vars, grid, itimestep)
+!=============================================================================================
+
+!input variables:
+ integer,intent(in):: itimestep
+ type(grid_meta),intent(in):: grid
+
+!output variables:
+ type(grid_state),intent(out):: vars
+
+!local variables:
+ integer:: i,k,j
+ real(kind=RKIND),dimension(:,:),pointer:: zz,exner,exner_b,rtheta_p,rtheta_b
+ real(kind=RKIND),dimension(:,:),pointer:: rho,theta,pressure
+ real(kind=RKIND),dimension(:,:),pointer:: rt_diabatic_tend
+
+!---------------------------------------------------------------------------------------------
+
+!initialization:
+ zz => grid % zz % array
+ exner => grid % exner % array
+ exner_b => grid % exner_base % array
+ rtheta_p => grid % rtheta_p % array
+ rtheta_b => grid % rtheta_base % array
+
+ rho => vars % rho % array
+ theta => vars % theta % array
+ pressure => vars % pressure % array
+
+ rt_diabatic_tend => grid % rt_diabatic_tend % array
+
+!variables common to all cloud microphysics schemes:
+
+ do j = jts, jtf
+ do k = kts, ktf
+ do i = its, itf
+
+ !potential temperature and diabatic forcing:
+ rt_diabatic_tend(k,i) = theta(k,i)
+ theta(k,i) = th_p(i,k,j) * (1. + R_v/R_d * qv_p(i,k,j))
+ rt_diabatic_tend(k,i) = (theta(k,i) - rt_diabatic_tend(k,i)) / dt_dyn
+
+ !density-weigthed perturbation potential temperature:
+ rtheta_p(k,i) = rho(k,i) * theta(k,i) - rtheta_b(k,i)
+
+ !exner function:
+ exner(k,i) = (zz(k,i)*(R_d/P0)*(rtheta_p(k,i)+rtheta_b(k,i)))**rcv
+
+ !perturbation pressure:
+ pressure(k,i) = zz(k,i)*R_d*(exner(k,i)*rtheta_p(k,i) &
+ + (exner(k,i)-exner_b(k,i))*rtheta_b(k,i))
+
+ !mass mixing ratios:
+ vars % scalars % array(index_qv,k,i) = qv_p(i,k,j)
+ vars % scalars % array(index_qc,k,i) = qc_p(i,k,j)
+ vars % scalars % array(index_qr,k,i) = qr_p(i,k,j)
+
+ enddo
+ enddo
+ enddo
+
+!variables specific to different cloud microphysics schemes:
+
+ microp_select_init: select case(microp_scheme)
+
+ case (microp_thompson)
+
+ do j = jts, jtf
+ do k = kts, ktf
+ do i = its, itf
+
+ !mass mixing ratios:
+ vars % scalars % array(index_qi,k,i) = qi_p(i,k,j)
+ vars % scalars % array(index_qs,k,i) = qs_p(i,k,j)
+ vars % scalars % array(index_qg,k,i) = qg_p(i,k,j)
+
+ !number concentrations:
+ vars % scalars % array(index_qnr,k,i) = qnr_p(i,k,j)
+ vars % scalars % array(index_qni,k,i) = qni_p(i,k,j)
+
+ enddo
+ enddo
+ enddo
+
+ case default
+
+ end select microp_select_init
+
+ write(6,*) '--- end micropysics_phys_to_nhy:'
+!if(itimestep == 4) then
+!do j = jts, jtf
+! do i = its, itf
+! do k = ktf, kts, -1
+! write(6,201) j,i,k,p_phy(i,k,j),pi_phy(i,k,j),z_phy(i,k,j),dz_phy(i,k,j), &
+! th_phy(i,k,j),th_phy(i,k,j)*pi_phy(i,k,j),qv_phy(i,k,j),qc_phy(i,k,j), &
+! qr_phy(i,k,j)
+! enddo
+! enddo
+!enddo
+!do j = jts, jtf
+! do i = its, itf
+! do k = ktf, kts, -1
+! write(6,201) j,i,k,vars % scalars % array(index_qv,k,i), &
+! vars % scalars % array(index_qc,k,i), &
+! vars % scalars % array(index_qr,k,i)
+! enddo
+! enddo
+!enddo
+
+!else
+
+!do j = jts, jtf
+! do i = 100, 100
+! do k = ktf, kts, -1
+! write(6,201) j,i,k,p_phy(i,k,j),pi_phy(i,k,j),z_phy(i,k,j),dz_phy(i,k,j), &
+! th_phy(i,k,j),th_phy(i,k,j)*pi_phy(i,k,j),qv_phy(i,k,j),qc_phy(i,k,j), &
+! qr_phy(i,k,j)
+! enddo
+! enddo
+!enddo
+ do j = jts, jtf
+ do i = 100, 100
+ do k = ktf, kts, -1
+ write(6,201) j,i,k,vars % scalars % array(index_qv,k,i), &
+ vars % scalars % array(index_qc,k,i), &
+ vars % scalars % array(index_qr,k,i)
+ enddo
+ enddo
+ enddo
+
+!endif
+
+!formats:
+ 201 format(3i7,10(1x,e15.8))
+
+ end subroutine microphysics_phys_to_nhyd
+
+!=============================================================================================
+ end module module_physics_interface_nhyd
+!=============================================================================================
</font>
</pre>