<p><b>laura@ucar.edu</b> 2010-05-20 14:00:30 -0600 (Thu, 20 May 2010)</p><p>Main driver for all physics parameterizations, except cloud microphysics.<br>
</p><hr noshade><pre><font color="gray">Added: branches/atmos_physics/src/core_hyd_phys/module_physics_driver.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_driver.F         (rev 0)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_driver.F        2010-05-20 20:00:30 UTC (rev 290)
@@ -0,0 +1,277 @@
+!==============================================================================
+ MODULE module_physics_driver
+ USE grid_types
+ USE constants
+
+ USE module_cu_kfeta
+ USE module_mp_thompson
+ USE module_physics_constants
+ USE module_physics_manager
+ USE module_physics_vars
+
+ IMPLICIT NONE
+ PRIVATE
+ PUBLIC:: physics_driver
+
+ CONTAINS
+
+!==============================================================================
+ SUBROUTINE physics_driver(domain,itimestep)
+!==============================================================================
+
+!INPUT ARGUMENTS:
+!----------------
+ INTEGER,INTENT(in):: itimestep
+
+!INOUT ARGUMENTS:
+!----------------
+ TYPE(domain_type),INTENT(inout):: domain
+
+!LOCAL VARIABLES:
+!----------------
+ TYPE(block_type),POINTER:: block
+
+!==============================================================================
+
+ block => domain % blocklist
+ DO WHILE(associated(block))
+
+ !physics prep step:
+ CALL physics_prep(block%mesh,block%time_levs(2)%state)
+
+ CALL convection_driver(itimestep,block%mesh,block%time_levs(2)%state)
+ block => block % next
+ END DO
+
+ END SUBROUTINE physics_driver
+
+!==============================================================================
+ SUBROUTINE physics_prep(grid,vars)
+!==============================================================================
+
+!INPUT VARIABLES:
+!----------------
+ TYPE(grid_meta),INTENT(in):: grid
+ TYPE(grid_state),INTENT(in):: vars
+
+!LOCAL VARIABLES:
+ INTEGER:: nCells,nCellsSolve,nLevels
+ INTEGER:: i,itf,k,ktf,j,jtf
+
+ REAL(KIND=RKIND):: tm
+
+ REAL(KIND=RKIND),DIMENSION(:,:),POINTER:: &
+ uReconstructX, &!
+ uReconstructY, &!
+ uReconstructZ !
+
+!==============================================================================
+ write(6,*)
+ write(6,*) '--- enter SUBROUTINE PHYSICS_PREP:'
+
+ nCells = grid%nCells
+ nCellsSolve = grid%nCellsSolve
+ nLevels = grid%nVertLevels
+
+ write(6,*) ' nCells =', nCells
+ write(6,*) ' nCellsSolve=', nCellsSolve
+ write(6,*) ' nLevels =', nLevels
+ write(6,*)
+ write(6,*) ' IMS= ',ims,' IME=',ime
+ write(6,*) ' JMS= ',jms,' JME=',jme
+ write(6,*) ' KMS= ',kms,' KME=',kme
+ write(6,*)
+ write(6,*) ' IDS= ',ids,' IDE=',ide
+ write(6,*) ' JDS= ',jds,' JDE=',jde
+ write(6,*) ' KDS= ',kds,' KDE=',kde
+ write(6,*)
+ write(6,*) ' ITS= ',its,' ITE=',ite
+ write(6,*) ' JTS= ',jts,' JTE=',jte
+ write(6,*) ' KTS= ',kts,' KTE=',kte
+
+!INITIALIZATION:
+ itf = ite
+ jtf = jte
+ ktf = kte-1
+ write(6,*)
+ write(6,*) ' ITS= ',its,' ITF=',itf
+ write(6,*) ' JTS= ',jts,' JTF=',jtf
+ write(6,*) ' KTS= ',kts,' KTF=',ktf
+
+ uReconstructX => vars % uReconstructX % array
+ uReconstructY => vars % uReconstructY % array
+ uReconstructZ => vars % uReconstructZ % array
+
+ DO j = jts,jtf
+
+ DO k = kts,kte
+ DO i = its,itf
+ w_phy(i,k,j) = vars%w%array(k,i)
+ ENDDO
+ ENDDO
+
+ DO k = kts,ktf
+ DO i = its,itf
+ u_phy(i,k,j) = 0.0 !needs to be calculated using uReconstructX,...
+ v_phy(i,k,j) = 0.0 !needs to be calculated using uReconstructX,...
+
+ dz_phy(i,k,j) = (vars%geopotential%array(k+1,i) &
+ - vars%geopotential%array(k,i)) / g
+ p_phy(i,k,j) = (vars%pressure%array(k+1,i) &
+ + vars%pressure%array(k,i)) / 2
+ th_phy(i,k,j) = vars%theta%array(k,i)
+ qv_phy(i,k,j) = vars%scalars%array(index_qv,k,i)
+
+ pi_phy(i,k,j) = (p_phy(i,k,j)/p0)**(rgas/cp)
+ t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
+
+ tm = (1.+1.61*qv_phy(i,k,j))*th_phy(i,k,j)
+ al_phy(i,k,j) = R_d/P0*tm*(p_phy(i,k,j)/P0)**cvpm
+ rho_phy(i,k,j) = 1./al_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,p_phy(i,k,j),pi_phy(i,k,j),dz_phy(i,k,j),th_phy(i,k,j),&
+! t_phy(i,k,j),qv_phy(i,k,j),al_phy(i,k,j),rho_phy(i,k,j)
+!ENDDO
+!write(6,*)
+!ENDDO
+!ENDDO
+ write(6,*) '--- end SUBROUTINE PHYSICS_PREP:'
+
+!FORMAT:
+ 201 format(i3,1x,i6,i3,8(1x,e15.8))
+
+ END SUBROUTINE physics_prep
+
+!==============================================================================
+ SUBROUTINE convection_driver(itimestep,grid,vars,curr_secs,cudt, &
+ adapt_step_flag)
+!==============================================================================
+
+!INPUT AND OUTPUT ARGUMENTS:
+!---------------------------
+ LOGICAL,INTENT(in),OPTIONAL:: adapt_step_flag
+ INTEGER,INTENT(in):: itimestep
+ REAL(KIND=RKIND),INTENT(in),OPTIONAL:: cudt
+ REAL(KIND=RKIND),INTENT(in),OPTIONAL:: curr_secs
+
+ TYPE(grid_meta),INTENT(in):: grid
+ TYPE(grid_state),INTENT(inout):: vars
+
+!LOCAL VARIABLES AND ARRAYS:
+!---------------------------
+ LOGICAL:: adapt_step_flag_pass
+ INTEGER:: nCells,nCellsSolve,nLevels
+ INTEGER:: i,itf,k,ktf,j,jtf
+ INTEGER:: icount
+ REAL(KIND=RKIND):: dx
+ REAL(KIND=RKIND):: cudt_pass,curr_secs_pass
+
+ REAL(KIND=RKIND),DIMENSION(:),POINTER:: &
+ cutop,cubot,pratec,raincv
+
+!==============================================================================
+ write(6,*)
+ write(6,*) '--- enter SUBROUTINE CONVECTION_DRIVER: dt_phys=',dt_cu
+
+ nCells = grid%nCells
+ nCellsSolve = grid%nCellsSolve
+ nLevels = grid%nVertLevels
+
+ write(6,*) '--- nCells =', nCells
+ write(6,*) '--- nCellsSolve =', nCellsSolve
+ write(6,*) '--- nLevels =', nLevels
+
+ write(6,*) ' IMS= ',ims,' IME=',ime
+ write(6,*) ' JMS= ',jms,' JME=',jme
+ write(6,*) ' KMS= ',kms,' KME=',kme
+ write(6,*)
+ write(6,*) ' IDS= ',ids,' IDE=',ide
+ write(6,*) ' JDS= ',jds,' JDE=',jde
+ write(6,*) ' KDS= ',kds,' KDE=',kde
+ write(6,*)
+ write(6,*) ' ITS= ',its,' ITE=',ite
+ write(6,*) ' JTS= ',jts,' JTE=',jte
+ write(6,*) ' KTS= ',kts,' KTE=',kte
+
+ itf = ite
+ jtf = jte
+ ktf = kte-1
+ write(6,*)
+ write(6,*) ' ITS= ',its,' ITF=',itf
+ write(6,*) ' JTS= ',jts,' JTF=',jtf
+ write(6,*) ' KTS= ',kts,' KTF=',ktf
+
+!INITIALIZATION:
+ IF(.not. PRESENT(curr_secs)) THEN
+ curr_secs_pass = -1
+ ELSE
+ curr_secs_pass = curr_secs
+ ENDIF
+ IF(.not. PRESENT(cudt)) THEN
+ cudt_pass = -1
+ ELSE
+ cudt_pass = cudt
+ ENDIF
+ IF(.not. PRESENT(adapt_step_flag)) THEN
+ adapt_step_flag_pass = .false.
+ ELSE
+ adapt_step_flag_pass = adapt_step_flag
+ ENDIF
+
+ dx = sqrt(maxval(grid%areaCell%array))
+
+ write(6,*) 'curr_secs_pass =', curr_secs_pass
+ write(6,*) 'cudt_pass =', cudt_pass
+ write(6,*) 'adapt_step_flag_pass=', adapt_step_flag_pass
+ write(6,*) 'dx =', dx
+
+!INITIALIZATION OF POINTER ARRAYS:
+ cutop => vars % cutop % array
+ cubot => vars % cubot % array
+ pratec => vars % pratec % array
+ raincv => vars % raincv % array
+
+!CALL TO KAIN-FRITSCH-ETA CONVECTION SCHEME:
+ write(6,*)
+ write(6,*) '--- begin subroutine KF_ETA_CPS:'
+
+ CALL kf_eta_cps( &
+ !WRF-like dimensions:
+ ids,ide,jds,jde,kds,kde, &
+ ims,ime,jms,jme,kms,kme, &
+ its,itf,jts,jtf,kts,ktf, &
+ dt_dyn,itimestep,dx,cudt_pass, &
+ curr_secs_pass, &
+ adapt_step_flag_pass, &
+ rho_phy,raincv_phy,pratec_phy, &
+ nca_phy, &
+ u_phy,v_phy,th_phy,t_phy, &
+ w_phy,dz_phy,p_phy,pi_phy, &
+ w0avg_phy,xlv0,xlv1,xls0,xls1, &
+ cp,R_d,g,ep_1,ep_2, &
+ svp1,svp2,svp3,svpt0, &
+ n_cu,cu_act_flag,warm_rain, &
+ cutop_phy,cubot_phy,qv_phy, &
+ f_qv,f_qc,f_qr,f_qi,f_qs, &
+ rthcuten_phy,rqvcuten_phy, &
+ rqccuten_phy,rqrcuten_phy, &
+ rqicuten_phy,rqscuten_phy &
+ )
+
+ write(6,*) '--- end subroutine KF_ETA_CPS:'
+
+!FORMAT:
+ 201 FORMAT(i3,1x,i6,1x,i3,10(1x,e15.8))
+ 202 FORMAT(2i6,10(1x,e15.8))
+
+ END SUBROUTINE convection_driver
+
+!==============================================================================
+ END MODULE module_physics_driver
+!==============================================================================
</font>
</pre>