!WRF:MODEL_LAYER:PHYSICS
!

MODULE module_microphysics_driver 2
CONTAINS


SUBROUTINE microphysics_driver(th_phy, moist_new, moist_old, w,        & 2,23
                               rho, pi_phy, p_phy, RAINNC, RAINNCV,    &
                               z, ht, dz8w, p8w, dt,dx,dy,             &
                               config_flags, n_moist,                  &
                               warm_rain,                              &
                               XLAND,T0ETA,Q0ETA,P0ETA,itimestep,      &
                               F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,       &
                               LOWLYR,                                 &
                               ids,ide, jds,jde, kds,kde, 	       & 
                               ims,ime, jms,jme, kms,kme, 	       &
                               its,ite, jts,jte, kts,kte  	       )
! Framework
   USE module_state_description
! Model Layer
   USE module_bc
   USE module_model_constants
   USE module_wrf_error

! *** add new modules of schemes here

   USE module_mp_kessler
   USE module_mp_lin
   USE module_mp_ncloud3
   USE module_mp_ncloud5
   USE module_mp_eta
   USE module_mp_etanew
    
!----------------------------------------------------------------------
   ! This driver calls subroutines for the microphys.
   !
   ! Schemes
   !
   ! 1. Kessler scheme
   ! 2. Lin et al. (1983), Ruttledge and Hibbs (1984)
   ! 3. NCEP cloud3, Hong et al. (1998) with some mod, Dudhia (1989)
   ! 4. NCEP cloud5, Hong et al. (1998) with some mod, Ruttledge and Hobbs (1984)
   ! 
!----------------------------------------------------------------------
   IMPLICIT NONE
!======================================================================
! Grid structure in physics part of WRF
!----------------------------------------------------------------------  
! The horizontal velocities used in the physics are unstaggered
! relative to temperature/moisture variables. All predicted
! variables are carried at half levels except w, which is at full
! levels. Some arrays with names (*8w) are at w (full) levels.
!
!----------------------------------------------------------------------  
! In WRF, kms (smallest number) is the bottom level and kme (largest 
! number) is the top level.  In your scheme, if 1 is at the top level, 
! then you have to reverse the order in the k direction.
!                 
!         kme      -   half level (no data at this level)
!         kme    ----- full level
!         kme-1    -   half level
!         kme-1  ----- full level
!         .
!         .
!         .
!         kms+2    -   half level
!         kms+2  ----- full level
!         kms+1    -   half level
!         kms+1  ----- full level
!         kms      -   half level
!         kms    ----- full level
!
!======================================================================
! Definitions
!-----------
! Rho_d      dry density (kg/m^3)
! Theta_m    moist potential temperature (K)
! Qv         water vapor mixing ratio (kg/kg)
! Qc         cloud water mixing ratio (kg/kg)
! Qr         rain water mixing ratio (kg/kg)
! Qi         cloud ice mixing ratio (kg/kg)
! Qs         snow mixing ratio (kg/kg)
!----------------------------------------------------------------------
!-- th_phy	  potential temperature    (K)
!-- moist_new     updated moisture array   (kg/kg)
!-- moist_old     Old moisture array       (kg/kg)
!-- rho           density of air           (kg/m^3)
!-- pi		  exner function           (dimensionless)
!-- p		  pressure                 (Pa)
!-- RAINNC	  grid scale precipitation (mm)
!-- RAINNCV	  one time step grid scale precipitation (mm/step)
!!!-- SR            one time step mass ratio of snow to total precip
!-- z		  Height above sea level   (m)
!-- dt		  Time step 		 (s)
!-- config_flags  flag for configuration      ! change ---  ?????   
!-- n_moist  	  number of water substances   (integer)
!-- G		  acceleration due to gravity  (m/s^2)
!-- CP		  heat capacity at constant pressure for dry air (J/kg/K)
!-- R_d		  gas constant for dry air (J/kg/K)
!-- R_v		  gas constant for water vapor (J/kg/K)
!-- XLS		  latent heat of sublimation   (J/kg)
!-- XLV		  latent heat of vaporization  (J/kg)
!-- XLF		  latent heat of melting       (J/kg)
!-- rhowater 	  water density 		     (kg/m^3)
!-- rhosnow 	  snow density 		     (kg/m^3)
!-- F_ICE_PHY     Fraction of ice.
!-- F_RAIN_PHY    Fraction of rain.
!-- F_RIMEF_PHY   Mass ratio of rimed ice (rime factor)
!-- P_QV          species index for water vapor
!-- P_QC          species index for cloud water
!-- P_QR          species index for rain water
!-- P_QI          species index for cloud ice
!-- P_QS          species index for snow
!-- P_QG          species index for graupel
!-- ids           start index for i in domain
!-- ide           end index for i in domain
!-- jds           start index for j in domain
!-- jde           end index for j in domain
!-- kds           start index for k in domain
!-- kde           end index for k in domain
!-- ims           start index for i in memory
!-- ime           end index for i in memory
!-- jms           start index for j in memory
!-- jme           end index for j in memory
!-- kms           start index for k in memory
!-- kme           end index for k in memory
!-- its           start index for i in tile
!-- ite           end index for i in tile
!-- jts           start index for j in tile
!-- jte           end index for j in tile
!-- kts           start index for k in tile
!-- kte           end index for k in tile
!
!======================================================================

   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   )    ::       its,ite, jts,jte, kts,kte
   INTEGER,      INTENT(IN   )    ::               n_moist,itimestep
   LOGICAL,      INTENT(IN   )    ::   warm_rain
!
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                    &
         INTENT(INOUT) ::                                     th_phy, &
                                                               T0ETA, &
                                                               Q0ETA, & 
                                                               P0ETA
!
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme, n_moist ),           &
         INTENT(INOUT) ::                                  moist_new

   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                    &
         INTENT(IN   ) ::                                          z, &
                                                                 rho, &
                                                                dz8w, &
                                                                   w, &
                                                                 p8w, &
                                                              pi_phy, &
                                                               p_phy
!
   REAL, DIMENSION( ims:ime , kms:kme , jms:jme, n_moist ),           &
         INTENT(IN   ) ::                                  moist_old
!
   REAL, DIMENSION( ims:ime , jms:jme ),  INTENT(INOUT) ::    RAINNC, &
                                                              RAINNCV
!

   REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme ) ::     &
        		             F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY

!

   REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: ht,XLAND

   REAL, INTENT(IN   ) :: dt,dx,dy

   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: LOWLYR

 
! LOCAL  VAR

   INTEGER :: i,j,k

!---------------------------------------------------------------------
!  check for microphysics type.  We need a clean way to 
!  specify these things!
!---------------------------------------------------------------------

   if (config_flags%mp_physics .eq. 0) return

!-----------
   IF ( n_moist >= PARAM_FIRST_SCALAR ) THEN

     micro_select: SELECT CASE(config_flags%mp_physics)

        CASE (KESSLERSCHEME)
             CALL wrf_debug ( 100 , 'microphysics_driver: calling kessler' )
             CALL kessler( th_phy,                       &
                     moist_new(ims,kms,jms,P_QV),        &
                     moist_new(ims,kms,jms,P_QC),        &
                     moist_old(ims,kms,jms,P_QC),        &
                     moist_new(ims,kms,jms,P_QR),        &
                     moist_old(ims,kms,jms,P_QR),        &
                     rho, pi_phy, RAINNC,                &
                     RAINNCV, dt, z, xlv, cp,            &
                     EP_2,SVP1,SVP2,SVP3,SVPT0,rhowater, &
                     dz8w,                               &
                     ids,ide, jds,jde, kds,kde,          &
                     ims,ime, jms,jme, kms,kme,          &
                     its,ite, jts,jte, kts,kte           )

        CASE (LINSCHEME)
             CALL wrf_debug ( 100 , 'microphysics_driver: calling lin_et_al' )
             CALL lin_et_al( th_phy,                     &
                     moist_new(ims,kms,jms,P_QV),        &
                     moist_new(ims,kms,jms,P_QC),        &
                     moist_new(ims,kms,jms,P_QR),        &
                     moist_new(ims,kms,jms,P_QI),        &
                     moist_new(ims,kms,jms,P_QS),        &
                     moist_new(ims,kms,jms,P_QG),        &
                     moist_old(ims,kms,jms,P_QR),        &
                     moist_old(ims,kms,jms,P_QS),        &
                     moist_old(ims,kms,jms,P_QG),        &
                     rho, pi_phy, p_phy, RAINNC,         &
                     RAINNCV,dt, z,                      &
                     ht, dz8w, G, cp, R_d, R_v,          &
                     XLS, XLV, XLF, rhowater, rhosnow,   &
                     EP_2,SVP1,SVP2,SVP3,SVPT0,          &
                     P_QI, P_QS, P_QG,                   &
                     PARAM_FIRST_SCALAR,                 &
                     ids,ide, jds,jde, kds,kde,          &
                     ims,ime, jms,jme, kms,kme,          & 
                     its,ite, jts,jte, kts,kte           )

        CASE (NCEPCLOUD3)
             CALL wrf_debug ( 100 , 'microphysics_driver: calling ncloud3' )
             CALL ncloud3(th_phy,                        &
                     moist_new(ims,kms,jms,P_QV),        &
                     moist_new(ims,kms,jms,P_QC),        &
                     moist_new(ims,kms,jms,P_QR),        &
                     w, rho, pi_phy, p_phy, dz8w, RAINNC,&
                     RAINNCV,dt,g,cp,cpv,r_d,r_v,SVPT0,  &
                     ep_1, ep_2, epsilon,                &
                     XLS, XLV, XLF, rhoair0, rhowater,   &
                     cliq,cice,psat,                     &
                     ids,ide, jds,jde, kds,kde,          &
                     ims,ime, jms,jme, kms,kme,          &
                     its,ite, jts,jte, kts,kte           )

        CASE (NCEPCLOUD5)
             CALL wrf_debug ( 100 , 'microphysics_driver: calling ncloud5' )
             CALL  ncloud5(th_phy,                       &
                     moist_new(ims,kms,jms,P_QV),        &
                     moist_new(ims,kms,jms,P_QC),        &
                     moist_new(ims,kms,jms,P_QR),        &
                     moist_new(ims,kms,jms,P_QI),        &
                     moist_new(ims,kms,jms,P_QS),        &
                     w, rho, pi_phy, p_phy, dz8w, RAINNC,&
                     RAINNCV,dt,g,cp,cpv,r_d,r_v,SVPT0,  &
                     ep_1, ep_2, epsilon,                &
                     XLS, XLV, XLF, rhoair0, rhowater,   &
                     cliq,cice,psat,                     &
                     ids,ide, jds,jde, kds,kde,          &
                     ims,ime, jms,jme, kms,kme,          &
                     its,ite, jts,jte, kts,kte           )


        CASE (ETAMPSCHEME)
             CALL wrf_debug ( 100 , 'microphysics_driver: calling etampshcheme' )
             CALL ETAMP(itimestep,DT,XLAND,pi_phy,p8w,p_phy,th_phy,  &
                     moist_new(ims,kms,jms,P_QV),        &
                     moist_new(ims,kms,jms,P_QC),        &
                     RAINNC,RAINNCV,T0ETA,Q0ETA,P0ETA,   &
                     ids,ide, jds,jde, kds,kde,          &
                     ims,ime, jms,jme, kms,kme,          &
                     its,ite, jts,jte, kts,kte           )


	CASE (ETAMPNEW)
             CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew')

               CALL ETAMP_NEW(itimestep,DT,DX,DY,RAINNC,RAINNCV,     &
 	                      dz8w,rho,p_phy,pi_phy,th_phy,          &
                              moist_new(ims,kms,jms,P_QV),           &
                              moist_new(ims,kms,jms,P_QC),           &
                              LOWLYR,                                &
                              F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,      &
                              ids,ide, jds,jde, kds,kde,             &
                              ims,ime, jms,jme, kms,kme,             &
                              its,ite, jts,jte, kts,kte             )

      CASE DEFAULT 

         WRITE( wrf_err_message , * ) 'The microphysics option does not exist: mp_physics = ', config_flags%mp_physics
         CALL wrf_error_fatal ( wrf_err_message )

      END SELECT micro_select 

   ELSE

      WRITE( wrf_err_message , * ) 'The microphysics option does not exist: mp_physics = ', config_flags%mp_physics
      CALL wrf_error_fatal ( wrf_err_message )

   ENDIF

   CALL wrf_debug ( 200 , 'microphysics_driver: returning from' )

   RETURN

   END SUBROUTINE microphysics_driver

END MODULE module_microphysics_driver