!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE MICROPH_wsm6_driver ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE micro_wsm6_driver(mscheme,nx,ny,nz,dtbig1,zp,w, & 1,4
ptprt,ptbar,pprt,pbar,ppi, &
qv,qvbar,qc,qr,qi,qs,qh, &
raing,prcrate, &
tk,p,q,qci,qrs,ww,den,delz,rainncv)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Call WRF ice microphysics parameterization scheme WSM6.
!
!-----------------------------------------------------------------------
!
! AUTHOR: Yunheng Wang
! 03/01/2006.
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
USE module_mp_wsm6
IMPLICIT NONE
INCLUDE 'globcst.inc'
INTEGER, INTENT(IN) :: mscheme ! 0 - 2
! 0 - WRF WSM6
! 1 - WSM6 with gamma distribution constraint for rain
! 2 - WSM6 with diagnostic N0
INTEGER, INTENT(IN) :: nx, ny, nz
REAL, INTENT(IN) :: dtbig1
REAL, INTENT(IN) :: zp(nx,ny,nz)
REAL, INTENT(IN) :: w (nx,ny,nz)
REAL, INTENT(INOUT) :: ptprt(nx,ny,nz)
REAL, INTENT(INOUT) :: pprt (nx,ny,nz)
REAL, INTENT(INOUT) :: qv (nx,ny,nz)
REAL, INTENT(IN) :: ptbar(nx,ny,nz)
REAL, INTENT(IN) :: pbar (nx,ny,nz)
REAL, INTENT(IN) :: qvbar(nx,ny,nz)
REAL, INTENT(IN) :: ppi (nx,ny,nz)
! REAL, INTENT(INOUT) :: qscalar(nx,ny,nz,nscalar)
REAL, INTENT(INOUT) :: qc(nx,ny,nz)
REAL, INTENT(INOUT) :: qr(nx,ny,nz)
REAL, INTENT(INOUT) :: qi(nx,ny,nz)
REAL, INTENT(INOUT) :: qs(nx,ny,nz)
REAL, INTENT(INOUT) :: qh(nx,ny,nz)
REAL, INTENT(INOUT) :: raing (nx,ny)
REAL, INTENT(INOUT) :: prcrate(nx,ny)
REAL :: tk(nx,nz,ny) ! ikj memory order
REAL :: q (nx,nz,ny) ! ikj memory order
REAL :: p (nx,nz,ny) ! ikj memory order
REAL :: qci(nx,nz,2)
REAL :: qrs(nx,nz,3)
REAL :: ww(nx,nz), den(nx,nz), delz(nx,nz)
REAL :: rainncv(nx)
!-----------------------------------------------------------------------
!
! Misc. local varibles
!
!-----------------------------------------------------------------------
INTEGER :: i, j, k
INTEGER :: its,ite,jts,jte,kts,kte
REAL :: deltat
LOGICAL, SAVE :: initialized = .FALSE.
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!-----------------------------------------------------------------------
!
! Since this scheme comtain microphysical ice process, it must at least
! define qc, qr, qi, qs, qg
!
!-----------------------------------------------------------------------
! IF (P_QC < 1 .OR. P_QR < 1 .OR. P_QI < 1 .OR. P_QS < 1 .OR. P_QG < 1) THEN
!
! WRITE(6,'(2a,/,5(a,I2),/,a)') &
! 'No enough microphysical array was defined ', &
! 'inside subroutine micro_wsm6.', &
! 'P_QC = ',P_QC,' P_QR = ',P_QR,' P_QI = ',P_QI, &
! ' P_QS = ',P_QS,' P_QG = ',P_QG, &
! 'Program aborting ...'
! CALL arpsstop('Wrong size for microphysics array, qscalar.',1)
!
! END IF
!-----------------------------------------------------------------------
!
! Initialize if the first time
!
!-----------------------------------------------------------------------
IF (mscheme < 0 .OR. mscheme > 2) THEN
WRITE(6,*) 'Unsupported WSM6 microphysics scheme ',mscheme
CALL arpsstop('Unsupported WSM6 scheme.',mscheme)
END IF
IF (.NOT. initialized) THEN
CALL wsm6init(mscheme)
initialized = .TRUE.
END IF
!-----------------------------------------------------------------------
!
! Time steps assignment
!
!-----------------------------------------------------------------------
IF( sadvopt /= 4) THEN ! Leapfrog scheme
deltat = 2*dtbig1
ELSE ! Forward scheme
deltat = dtbig1
END IF
!-----------------------------------------------------------------------
!
! Get temperature from potential temperature
! Get total specific humidity (actually it should be mixing ratio,
! we use them alternately because the difference is small)
! Get total pressure
!
!-----------------------------------------------------------------------
DO k = 1,nz-1
DO j = 1,ny-1
DO i = 1,nx-1
tk (i,k,j) = (ptprt(i,j,k) + ptbar(i,j,k))*ppi(i,j,k)
p (i,k,j) = pprt (i,j,k) + pbar (i,j,k)
q (i,k,j) = qv (i,j,k)
END DO
END DO
END DO
!-----------------------------------------------------------------------
!
! Call the microphysics 2D model with each x-z slab
!
!-----------------------------------------------------------------------
!$OMP PARALLEL DO &
!$OMP PRIVATE ( j )
its = 1 ! Should fix these index if OMP is desired.
ite = nx-1
jts = 1
jts = ny-1
kts = 1
kte = nz-1
DO j = 1,ny-1 ! for each x-z slab
!-----------------------------------------------------------------------
!
! Convert to WSM6 arrays from ARPS arrays
!
!-----------------------------------------------------------------------
DO k = 1,nz-1
DO i = 1,nx-1
ww(i,k) = w(i,j,k)
! qci(i,k,1) = qscalar(i,j,k,P_QC)
! qci(i,k,2) = qscalar(i,j,k,P_QI)
! qrs(i,k,1) = qscalar(i,j,k,P_QR)
! qrs(i,k,2) = qscalar(i,j,k,P_QS)
! qrs(i,k,3) = qscalar(i,j,k,P_QG)
qci(i,k,1) = qc(i,j,k)
qci(i,k,2) = qi(i,j,k)
qrs(i,k,1) = qr(i,j,k)
qrs(i,k,2) = qs(i,j,k)
qrs(i,k,3) = qh(i,j,k)
delz(i,k) = zp(i,j,k+1)-zp(i,j,k)
den (i,k) = p(i,k,j)/(rd*tk(i,k,j)) ! air density at time tfuture
END DO
END DO
! IF (mscheme == 0) THEN ! original WRF WSM6 scheme in WRFV2.1.2
CALL wsm62D_WRF(tk(:,:,j), q(:,:,j), qci, qrs, ww, den, p(:,:,j),&
delz, raing(:,j), rainncv, deltat, &
j, &
1, nx-1, 1, ny-1, 1, nz-1, &
1, nx, 1, ny, 1, nz, &
its, ite, jts, jte, kts, kte)
! ELSE IF (mscheme == 1) THEN ! Simplified Gamma distribution for rain
!
! WRITE(6,*) 'Not supported microphysics scheme'
! CALL arpsstop('WSM6GR not supported.',1)
! CALL wsm62D_GR (tk(:,:,j), q(:,:,j), qci, qrs, ww, den, p(:,:,j),&
! delz, raing(:,j), rainncv, deltat, &
! j, &
! 1, nx-1, 1, ny-1, 1, nz-1, &
! 1, nx, 1, ny, 1, nz, &
! its, ite, jts, jte, kts, kte)
! ELSE IF (mscheme == 2) THEN ! Diagnostic N0
!
! WRITE(6,*) 'Not supported microphysics scheme'
! CALL arpsstop('WSM6N0 not supported.',1)
! CALL wsm62D_N0 (tk(:,:,j), q(:,:,j), qci, qrs, ww, den, p(:,:,j),&
! delz, raing(:,j), rainncv, deltat, &
! j, &
! 1, nx-1, 1, ny-1, 1, nz-1, &
! 1, nx, 1, ny, 1, nz, &
! its, ite, jts, jte, kts, kte)
! END IF
!-----------------------------------------------------------------------
!
! Convert back to ARPS arrays
!
!-----------------------------------------------------------------------
DO k = 1,nz-1
DO i = 1,nx-1
! qscalar(i,j,k,P_QC) = qci(i,k,1)
! qscalar(i,j,k,P_QI) = qci(i,k,2)
! qscalar(i,j,k,P_QR) = qrs(i,k,1)
! qscalar(i,j,k,P_QS) = qrs(i,k,2)
! qscalar(i,j,k,P_QG) = qrs(i,k,3)
qc(i,j,k) = qci(i,k,1)
qi(i,j,k) = qci(i,k,2)
qr(i,j,k) = qrs(i,k,1)
qs(i,j,k) = qrs(i,k,2)
qh(i,j,k) = qrs(i,k,3)
END DO
END DO
DO i = 1,nx-1
prcrate(i,j) = rainncv(i)*denr/(1000*dtbig) ! from mm -> kg m-2 s-1
END DO
END DO
!$OMP END PARALLEL DO
!-----------------------------------------------------------------------
!
! Beside hydrometeor arrays, the microphysics scheme changes ARPS
! potential temperature and mixing ratio only.
!
!-----------------------------------------------------------------------
DO k = 1,nz-1
DO j = 1,ny-1
DO i = 1,nx-1
ptprt(i,j,k) = tk(i,k,j)/ppi(i,j,k) - ptbar(i,j,k)
qv (i,j,k) = q(i,k,j)
END DO
END DO
END DO
RETURN
END SUBROUTINE micro_wsm6_driver