MODULE QF_UOC
!
! Y. Shao, 29 Jan 2004 
!         
! JY Kang, 01 Dec 2008, Modify the code for WRF_chem
!
! M. Klose, 2010-2015 Modifications
! 
! M. Klose, 2017 Modifications and implementation in NMMB-MONARCH
!-----------------------------------------------------------------------------------
! Calculate sediment flux for multi-particle size soils as a weighted average of Q(d) 
!           dust emission F(d) for covered and moisture soil
!
! Options for dust calculation:
! 1 Shao (2001), JGR
! 2 Shao (2004), JGR
! 3 Shao et al. (2011), JGR - simplification of 2; added 26 Sep 2009
!
!--------------------------------------------------------------------------------------
!
! INPUT: 
!      nbins       number of dust transport bins 
!      rmax        dust-particle radius at upper edges of transport bins
!      idst        index in psd for dust cut-off (20 um)
!      g           gravitational acceleration, 9.8 m s-2
!      rhop        particle density, 2650 kg m-3
!      rho         density of dry air (bottom layer) [kg m-3]
! !      dt          time step
!      ustar       friction veloity, m s-1
!      w           volumetric soil moisture content in the topmost soil layer [m3 m-3]
!      vegfra      vegetation fraction (?!!)
!      ustart0     ideal (dry and smooth) threshold friction velocity based on Shao and Lu (2000) [m s-1]
!      imod        selected dust emission scheme 
! !      dz_lowest   depth or lowest model layer [m]
!      drysmc      air-dry soil moisture [m3 m-3] 
!      a_smois     coefficient
!      b_smois     coefficient
!      d0          diameter at bin-edges in particle-size distribution (psd)
!      dd          diameter in bin centers in psd
!      psdm        particle-size distribution density at dd, minimal dispersion
!      dpsdm       delta P between d0-points, minimal dispersion
!      psdf        particle-size distribution density at dd, full dispersion
!      dpsdf       delta P between d0-points, full dispersion
!      imax        number of psd-bins (psdmax in other modules)
!      barel_sc    (1-vegfra)*(1-snowfra)*(1-bedrock_fr) for Marticorena drag partition 
!                  (1-snowfra)*(1-bedrock_fr) for Raupach drag partition
! 
! OUTPUT:  
! !      conc        dust concentration in lowest layer [kg m-3]
! !      emiss_cum   emitted dust mass accumulated between history output (for diagnostics) [kg m-2]
!      fbin        dust emission in each bin [kg m-2 s-1] 
!      rough_cor   roughness correction factor for u*t, [0,1], dimensionless (output for testing)
!      smois_cor   soil moisture correction factor for u*t, [0,1], dimensionless (output for testing) 
! (local)
!      q           Sand flux from each size range.
!      ffq         Weighted sand flux from each size range.
!      qtotal      Total sand flux (weighted average).
!      f           Weighted dust flux ejected by single sand size range for given d_d. 
!      fff         Weighted dust flux ejected by all sand size range from each dust size range.
!      ftotal      Total dust flux (weighted average).
!--------------------------------------------------------------------------------------
!

  CONTAINS

  subroutine qf_uoc_driver ( nbins0, rmax, idst, ibin_u, ibin_l,     &
                    g, rhop, rho, ustar_qf, vegfra, ustart0, imod,   &
!                     soilc, tot_soilc, domsoilc,                      &
!                     conc, emiss_cum,                                 & 
                    fbin, ustdp,                                     & 
                    rough_cor, smois_cor, barel_sc,                  & 
!                     w, drysmc, a_smois, b_smois,                     &
                    d0, dd, psdm, dpsdm, psdf, dpsdf, imax, pmass)
       
       INTEGER, INTENT(IN   )                   :: nbins0, imod, idst, imax, ustdp
       REAL,    INTENT(IN   )                   :: g, rho, ustar_qf!, dt, dz_lowest
       REAL,    INTENT(IN   )                   :: rhop !, w, a_smois, b_smois
       REAL,    INTENT(IN   )                   :: vegfra, barel_sc
       REAL,    INTENT(IN   )                   :: rough_cor, smois_cor  
!        REAL   , INTENT(INOUT), DIMENSION(nbins) :: conc, emiss_cum
       REAL   , INTENT(IN   ), DIMENSION(8) :: rmax  ! size cut radii [mu] 
       INTEGER, INTENT(IN   ), DIMENSION(8) :: ibin_u, ibin_l

!kang [2009/01/07] soil class type
!        REAL, INTENT(IN   )                      :: tot_soilc       
!        REAL, DIMENSION(16), INTENT(IN)          :: soilc       
!        INTEGER,  INTENT(IN  )                   :: domsoilc
     
!      particle-size distributions 
       real, dimension(0:imax), intent(in) :: d0
       real, dimension(imax), intent(in)   :: dd, pmass, ustart0
       real, dimension(imax), intent(in)   :: psdm, dpsdm!, ppsdm    ! minimally dispersed
       real, dimension(imax), intent(in)   :: psdf, dpsdf!, ppsdf    ! fully dispersed
       real, dimension(imax)               :: dpsds!, psds, ppsds    ! sediment       

       integer :: i, j, n, kk, ij, ffile       
       real :: total, qtotal, ftotal
       real :: ftotalb, ftotalp
!
       real, dimension(imax)      :: ustart, q, ffq
       real, dimension(idst)      :: fff, fff_old, a1_dim
       real, dimension(imax,imax) :: f
!
!        real, parameter :: c_lambda=0.35
       real, parameter :: kappa=1.
       real :: h, lambda
       real :: ghl, fc
       real :: phl
       real :: cys, u0, al0, rhos, omega, rys
       real :: ddm, a1, a2, a3  
       real :: zeta, sigma_m                      ! u*sqrt(rhos/p), bombardment coefficient
!
       real :: qwhite_out, pmass_out, vhlys_out
! 
       integer :: nbins 
       real,    dimension(8) :: dbin, fbin, cell_fbin, fbin_old
       real      :: cell_ftotal, cf
       integer   :: isl, cc
!*******************************************************************************************
!
! write(*,*) 'idst', idst
! write(*,*) 'dpsdm', dpsdm
! write(*,*) 'dpsdf', dpsdf
! initialization
       f = 0.
       fbin = 0.
       dbin = rmax*2.   !size cut diameter (um)
       if (nbins0 .gt. 8) then 
          nbins = nbins0/2
       else 
          nbins = nbins0
       endif
       if (nbins .ne. 8) write(*,*) 'ERROR: Problem with dust bins'
       ustart(:) = 0.
!        cell_ftotal = 0.
!        do n = 1, nbins
!           cell_fbin(n) = 0.
!        enddo
! 
!        DO cc = 1, 12  ! soil category
!            if (soilc(cc).eq.0.) then
!               go to 103
!            endif
!        
!            psdm(:)=psd_m(:,cc)
!            psdf(:)=psd_f(:,cc)
!            dpsdm(:)=dpsd_m(:,cc)
!            dpsdf(:)=dpsd_f(:,cc)
!            ppsdm(:)=ppsd_m(:,cc)
!            ppsdf(:)=ppsd_f(:,cc)
!
!-------------------
! frontal area index
!-------------------
!        cf = vegfra
! !        write(*,*) 'cf', cf
!        if (cf .gt. 0.95) then 
!           write(*,*) 'cover fraction too large, reset'
!           cf = 0.95
!        endif ! correction, because larger values lead to large a lambda that is problematic in Raupach scheme
! !         
!        lambda = - c_lambda*log( 1. - cf )
! !        call r_c(lambda, rough_cor)
!        call r_c(vegfra, rough_cor)   ! this is now already done in module_SF_JSFC.F90
!        call h_c(w, drysmc, a_smois, b_smois, smois_cor) ! this is now already done in module_SF_JSFC.F90
!        write(*,*) 'roughcor', rough_cor
!        write(*,*) 'smoiscor', smois_cor
!----------------------------------------------
! for each particle size group, estimate ustart
!----------------------------------------------
!
       if (ustdp.eq.0) then  ! apply drag partition to ustart
          ustart = rough_cor*smois_cor*ustart0      ! ustar_qf = ustar
       else                  ! apply drag partition to ustar
          ustart = smois_cor*ustart0                ! ustar_qf = ustar/rough_cor
       endif 
       ustart_min = minval(ustart)
       
!        write(*,*) 'ustt', ustart_min
!          if (cc.eq.domsoilc) then
!           smois_cor_in = smois_correc
!          endif
       IF ( ustar_qf .le. ustart_min ) THEN    ! no erosion goto 102
          goto 102
       ELSE  
          do i = 1, imax
             call qwhite(ustart(i), ustar_qf, rho, g, qwhite_out)
!              q(i) = (1.-cf)*qwhite_out
             q(i) = barel_sc*qwhite_out
          enddo       
! default settings: 
          rhos = 1000.        ! bulk density of soil [kg/m3] 
          phl = 30000.        ! plastic pressure [N/m2]
          cys = 0.00001       ! cys : parameter
       
          ghl = exp( -kappa*(ustar_qf - ustart_min)**3.0 )
          dpsds = ghl*dpsdm + (1.-ghl)*dpsdf
!           psds  = ghl*psdm + (1.-ghl)*psdf
!           ppsds = ghl*ppsdm + (1.-ghl)*ppsdf
!
          ffq = q*dpsds
          qtotal = sum(ffq)
!           write(*,*) 'qtotal', qtotal
!--------------
! dust emission
!--------------
!--------------------------------
! Shao (2001) dust emission model
!--------------------------------
       IF (imod .eq. 1) THEN 
          do i = idst+1, imax
             ddm = dd(i)*1.e-6
             u0 = 10.*ustar_qf
             al0 = 13.0*3.14159/180.
             call vhlys(phl, 2, pmass(i), al0, u0, ddm, vhlys_out)
             omega = vhlys_out     ![m3]
!              
             do j = 1, idst
                if (psdf(j).ne.0.) then         ! don't divide by zero
                  rys = psdm(j)/psdf(j)
                  if (rys .gt.1.) then   ! more small particles in PSDM than in PSDF, but PSDF != 0
                      rys = 1.
                  endif                  
                elseif (psdf(j).eq.0. .and. psdm(j).ne.0.) then     
!                   write(0,*) 'WARNING: more small particles in PSDM than in PSDF'
                  rys = 1.
                else                            ! both zero
                  rys = 1.
                endif
                a1 = cys*( (1.-ghl) + ghl*rys )
                a2 = ffq(i)*g/ustar_qf**2./pmass(i)
                 
                if ( dpsdf(j) .lt. dpsdm(j) ) then 
                   a3 = dpsdf(j)*rhos*omega
                else 
                    a3 = dpsdf(j)*rhos*omega + (dpsdf(j)-dpsdm(j))*pmass(i)
                endif
                f(i,j) = a1*a2*a3    ![kg/m2/s]
             enddo
          enddo
!          
          fff(1:idst) = 0.
!           fff(1:idst) = (1.-cf)*sum(f(idst+1:imax,1:idst), DIM=1)
          fff(1:idst) = sum(f(idst+1:imax,1:idst), DIM=1)
! 
          do n=1,nbins
             fbin(n) = sum(fff(ibin_l(n):ibin_u(n)))          
          enddo        
! 
!--------------------------------
! Shao (2004) dust emission model
!--------------------------------
       ELSEIF (imod .eq. 2) THEN
         zeta = ustar_qf*sqrt( rhos/phl )
         sigma_m = 12.*zeta*zeta*(1.+14.*zeta)
! 
         do i = idst+1, imax
            do j = 1, idst
               if (psdf(j).ne.0.) then         ! don't divide by zero
                  rys = psdm(j)/psdf(j)
                  if (rys .gt.1.) then   ! more small particles in PSDM than in PSDF, but PSDF != 0
                      rys = 1.
                  endif                  
               elseif (psdm(j).ne.0.) then     
!                  write(0,*) 'WARNING: more small particles in PSDM than in PSDF'
                  rys = 1.
               else                            ! both zero
                  rys = 1.
               endif
               a1 = cys*dpsdf(j)*( (1.-ghl) + ghl*rys )
               a2 = (1.+sigma_m)
               a3 = ffq(i)*g/ustar_qf**2.
               f(i,j) = a1*a2*a3
            enddo
         enddo
! 
         fff(1:idst) = 0.
!          fff(1:idst) = (1.-cf)*sum(f(idst+1:imax,1:idst), DIM=1)
         fff(1:idst) = sum(f(idst+1:imax,1:idst), DIM=1)
!            
         do n=1,nbins
            fbin(n) = sum(fff(ibin_l(n):ibin_u(n)))          
         enddo
! 
!--------------------------------------------------------------------------
! Shao (2011) minimal version, ghl = 1, Q independent of sand particle size
! 
! See Eq. (34) in 
! Shao, Y., M. Ishizuka, M. Mikami, J. Leys (2011): Parameterization of size-
! resolved dust emission and validation with measurements, JGR, 116, D08203, 
! doi: 10.1029/2010JD014527
!--------------------------------------------------------------------------
       ELSEIF (imod .eq. 3) THEN 
         a1_dim = 0.
         zeta = ustar_qf*sqrt( rhos/phl )
         sigma_m = 12.*zeta*zeta*(1.+14.*zeta)
! 
         a1_dim(1:idst) = cys*dpsdm(1:idst)
         a2 = (1.+sigma_m)
         a3 = qtotal*g/ustar_qf**2.         
!          fff(1:idst) = (1.-cf)*a1_dim(1:idst)*a2*a3
         fff(1:idst) = a1_dim(1:idst)*a2*a3     
!           
         do n=1,nbins
            fbin(n) = sum(fff(ibin_l(n):ibin_u(n)))          
         enddo
! 
       ENDIF  ! dust scheme
       ENDIF    ! ust < ust_t
! 
102   continue
! ! Use this in case there is more than one soil type in the same grid cell
! !       do n = 1, nbins
! !       cell_fbin(n) = cell_fbin(n) + (soilc(cc)/tot_soilc)*fbin(n)
! !       enddo
! ! For now, there is only one soil type per grid cell and thus: 
!       cell_fbin = fbin

103   continue  
!       ENDDO  ! cc, soil category
      
!       do n = 1, nbins
! ! fbin : [kg/m2/s],  dz_lowest : [m],  rho : [kg/m3],  dt : [s] -> tc : [kg/kg-dryair]
! !          tc(n) = tc(n) + cell_fbin(n)/dz_lowest/rho*dt     ![kg/kg-dryair]
! !          bems(n) = cell_fbin(n)     ![kg/m2/s]
!          conc(n) = conc(n) + cell_fbin(n)/dz_lowest*dt     ![kg m-3]
!          emiss_cum(n) = emiss_cum(n) + cell_fbin(n)*dt       ![kg m-2]
!       enddo


      END subroutine qf_uoc_driver


!*****************************************************************************
      subroutine qwhite(ustt, ustar, rho, g, qwhite_out)
!
! Yaping Shao 17-07-99!
!
! Kawamura (1964) or White (1979) Sand Flux Equation
! Q = c*rho*u_*^3 over g (1 - u_*t/u_*)(1 + u_*t/u_*)^2
! qwhite: Streamwise Sand Flux;        [kg m-1 s-1]
! c     : 2.6
! ustt   : threhold friction velocity  [m/s]
! ustar : friction velocity            [m/s]
!
      real :: c
      real, intent(in) :: ustar, rho, g
      real, intent(in) :: ustt
      real, intent(out) :: qwhite_out
      real :: a, b
! default setting:       
      c = 1.0  ! typical values are 2.3 or 2.6, but here we dump this into the overall calibration
      a = rho/g

      IF (ustar.lt.ustt) THEN 
        qwhite_out = 0.0
      ELSE
        b = ustt/ustar 
        qwhite_out = c*a*ustar**3.*(1.-b)*(1.+b)**2.
      ENDIF

      END subroutine qwhite
!*****************************************************************************
      subroutine vhlys(p, k, xm, alpha, u, d, vhlys_out)
!
! Volume removal according to Lu and Shao (1999), Equation (8)
! alpha: impact angle             [^o]
! u    : impact velocity          [m/s]
! p    : plastic pressure         [N/m^2]
! xm   : particle mass            [kg]
! d    : particle diameter        [m]
!
!
      REAL,intent(in) :: alpha, xm, u, d, p
      REAL :: beta
      REAL, PARAMETER :: pi=3.1415927
      REAL :: t1, t2, t3
      INTEGER,intent(in) :: k
      real,intent(out) :: vhlys_out

      beta = sqrt( p*k*d/xm )
      t1 = u*u/(beta*beta)*( sin(2.*alpha) - 4.*sin(alpha)*sin(alpha) )
      t2 = u*sin(alpha)/beta
      t3 = 7.5*pi*t2**3.0/d
      vhlys_out = d*( t1 + t3 )
      
      END subroutine vhlys      
!*****************************************************************************
! A routine for correction of ust for soil moisture content
!
! w : volumetric soil moisture
! isl: soil texture type, ranging from 1 to 12
!
! Author: Yaping Shao, 5/05/2001
! Reference: Fecan et al. (1999), Ann. Geophysicae,17,149-157
!
! Data based on Shao and Jung, 2000, unpublished manuscript
! Data invented for sand, loamy sand, sandy loam, loam, clay loam, and clay
! Parameters published in Klose et al. (2014), JGR
!----------------------------------------------------------------------
      subroutine h_c (w, wr, a, b, h)

      real, intent(in)  :: w, wr, a, b
      real, intent(out) :: h
!       
      if ( w.lt.0. ) then
        write(*,*) 'soil moisture correction (h_c): w = ', w, ' <  0'
        stop
      endif
!       
      if ( w.le.wr ) then
         h = 1.
      else
         h = sqrt( 1 + a*( w-wr )**b )         
      endif
! 
      END subroutine h_c
!*****************************************************************************
      subroutine r_c (vegfra, c_lambda, r)
!
!   Y. Shao 17-07-92
!   CORRECTION FUNCTION FOR UST(D) BASED ON Raupach et al. (1992)
!   x = frontal area index
!
!   R_C = (1 - sig m x)^{1/2} (1 + m beta x)^{1/2}
!         Note I deife R_C = u_{*tR}/u_{*tS}
!         While Raupach et al. defined 
!                      R_C = u_{*tS}/u_{*tR} and their R function is
!   R_C = (1 - sig m x)^{-1/2} (1 + m beta x)^{-1/2}
!                      
!   sig   : basal to frontal area; about 1
!   m     : parameter less than 1; about 0.5
!   beta  : a ratio of drag coef.; about 90. ; changed to 200 (recommendation by Y. Shao based on data by Gillies et al.)
!
      real :: xc, x, cf
      real, intent(in) :: vegfra, c_lambda
      real, intent(out) :: r
      real, parameter :: sig=1., m=0.5, beta=200.
!       real, parameter :: c_lambda=0.35  ! now specified in module_SF_JSFC.F90 and input 
!
      cf = vegfra
      if (cf .gt. 0.95) then 
!         write(*,*) 'vegetation cover fraction too large, reset'
         cf = 0.95
      endif ! correction, because larger values lead to large lambda that is problematic in Raupach scheme
!         
      x = - c_lambda*log( 1. - cf )   
! 
      xc = 1./(sig*m)
      IF (x.ge.xc) THEN
        r   = 999.           ! Fully covered surface
      ELSE
        r   = sqrt(1.-sig*m*x)*sqrt(1.+m*beta*x)
      ENDIF
!
      END subroutine r_c



END MODULE QF_UOC
