subroutine mwave_cpfrac ( &
 & klev,             & ! in: dimensions   
 & ksat,             & ! in: satellite ID (for mwave) 
 & yd_mwave_phys_fw, & ! in: 2d/3d fields, FW
 & pcfrac_fw,        & ! out: weighted cloud/precip fraction FW
 & yd_mwave_phys_tl, & ! in:  2d/3d fields, TL
 & pcfrac_tl,        & ! out: TL
 & yd_mwave_phys_ad, & ! inout: 2d/3d fields, AD
 & pcfrac_ad )         ! inout: AD   

!**** 4D-Var in clouds/precipitation for microwave radiances 

!     Cloud /precipitation fraction conistent with model physics
!     Also provides TL and adjoint calculations via optional variables

!     Modifications:
!     07-Apr-2010    Alan Geer  Cloud / precip fraction consistent with physics

!**** MODULES      

!* KIND     
use parkind1, only: jpim, jprb
use yomhook , only: lhook, dr_hook

!* IFS
use yommwave, only: mwave_phys_type
use yomcst  , only: rg, rd

implicit none
          
!* Common variables
integer (kind=jpim), intent    (in) :: klev, ksat
type (mwave_phys_type), intent (in) :: yd_mwave_phys_fw 
real (kind=jprb), intent      (out) :: pcfrac_fw

!* Optional variables for TL/AD behaviour
type (mwave_phys_type), optional, intent(in)    :: yd_mwave_phys_tl
type (mwave_phys_type), optional, intent(inout) :: yd_mwave_phys_ad
real (kind=jprb), optional, intent(out)   :: pcfrac_tl
real (kind=jprb), optional, intent(inout) :: pcfrac_ad

!* OTHER
integer (kind=jpim) :: ilev

real (kind=jprb), dimension (klev) :: zdp_fw, zdp_tl, zdp_ad, zdlnp_fw, zdlnp_tl, zdlnp_ad
real (kind=jprb), dimension (klev) :: zdz_fw, zdz_tl, zdz_ad
real (kind=jprb), dimension (klev) :: zrhoair_lrain_fw, zrhoair_lrain_tl, zrhoair_lrain_ad
real (kind=jprb), dimension (klev) :: zrhoair_lsnow_fw, zrhoair_lsnow_tl, zrhoair_lsnow_ad
real (kind=jprb), dimension (klev) :: zrhoair_crain_fw, zrhoair_crain_tl, zrhoair_crain_ad
real (kind=jprb), dimension (klev) :: zrhoair_csnow_fw, zrhoair_csnow_tl, zrhoair_csnow_ad

real (kind=jprb) :: zconv_rain (2), zconv_snow (2)
real (kind=jprb) :: zhydro_column_fw, zhydro_column_tl, zhydro_column_ad
real (kind=jprb) :: zcfrac_sum_fw, zcfrac_sum_tl, zcfrac_sum_ad

real (kind=jprb), parameter :: zem3 = 0.001_jprb
logical :: lltl, llad

! adjustment variables
real (kind=jprb) :: zhook_handle

if (lhook) call dr_hook ('MWAVE_CPFRAC',0,zhook_handle)

! Decide if TL or AD behaviour
lltl = present(yd_mwave_phys_tl) .and. present(pcfrac_tl)
llad = present(yd_mwave_phys_ad) .and. present(pcfrac_ad)

call mwave_share_rtcoeff (zconv_rain, zconv_snow, ksat) 

zdlnp_fw (1) = 0.0_JPRB
zdlnp_tl (1) = 0.0_JPRB
do ilev = 1, klev

  ! (1) Delta pressure and delta z, for the vertical integrals
  zdp_fw (ilev) = (yd_mwave_phys_fw % ph (ilev+1) - yd_mwave_phys_fw % ph (ilev)) / rg
  if (ilev > 1) then
    zdlnp_fw (ilev) = log (yd_mwave_phys_fw % ph (ilev+1) / yd_mwave_phys_fw % ph (ilev)) 
  endif 
  zdz_fw (ilev) =  yd_mwave_phys_fw % t (ilev) * zdlnp_fw (ilev) * rd / rg 

  if (lltl) then

    zdp_tl (ilev) = (yd_mwave_phys_tl % ph (ilev+1) - yd_mwave_phys_tl % ph (ilev)) / rg
    if (ilev > 1) then
      zdlnp_tl (ilev) = (1.0_JPRB / yd_mwave_phys_fw % ph (ilev+1)) * yd_mwave_phys_tl % ph (ilev+1) &
                &     - (1.0_JPRB / yd_mwave_phys_fw % ph (ilev  )) * yd_mwave_phys_tl % ph (ilev  )
    endif 
    zdz_tl (ilev) = (yd_mwave_phys_tl % t (ilev) * zdlnp_fw (ilev) &
                & +  yd_mwave_phys_fw % t (ilev) * zdlnp_tl (ilev)) * rd / rg

  endif
enddo 

zrhoair_lrain_fw (:) = 0.0_JPRB
zrhoair_lsnow_fw (:) = 0.0_JPRB
zrhoair_crain_fw (:) = 0.0_JPRB
zrhoair_csnow_fw (:) = 0.0_JPRB

! (2) Density of hydrometeors in kg kg-1
where (yd_mwave_phys_fw % rfl > 0.0_JPRB) 
  zrhoair_lrain_fw = zem3 * ((yd_mwave_phys_fw % rfl * zconv_rain (1)) ** zconv_rain (2))
endwhere

where (yd_mwave_phys_fw % sfl > 0.0_JPRB) 
  zrhoair_lsnow_fw = zem3 * ((yd_mwave_phys_fw % sfl * zconv_snow (1)) ** zconv_snow (2))
endwhere

where (yd_mwave_phys_fw % crfl > 0.0_JPRB) 
  zrhoair_crain_fw = zem3 * ((yd_mwave_phys_fw % crfl * zconv_rain (1)) ** zconv_rain (2))
endwhere

where (yd_mwave_phys_fw % csfl > 0.0_JPRB) 
  zrhoair_csnow_fw = zem3 * ((yd_mwave_phys_fw % csfl * zconv_snow (1)) ** zconv_snow (2))
endwhere

zrhoair_lrain_tl (:) = 0.0_JPRB
zrhoair_lsnow_tl (:) = 0.0_JPRB
zrhoair_crain_tl (:) = 0.0_JPRB
zrhoair_csnow_tl (:) = 0.0_JPRB

if (lltl) then 
  where (yd_mwave_phys_fw % rfl > 0.0_JPRB) 
    zrhoair_lrain_tl = zem3 * ((yd_mwave_phys_fw % rfl * zconv_rain (1)) ** (zconv_rain (2) - 1.0_JPRB)) &
                     &      * zconv_rain (1) * zconv_rain (2) * yd_mwave_phys_tl % rfl  
  endwhere

  where (yd_mwave_phys_fw % sfl > 0.0_JPRB) 
    zrhoair_lsnow_tl = zem3 * ((yd_mwave_phys_fw % sfl * zconv_snow (1)) ** (zconv_snow (2) - 1.0_JPRB)) &
                     &      * zconv_snow (1) * zconv_snow (2) * yd_mwave_phys_tl % sfl  
  endwhere

  where (yd_mwave_phys_fw % crfl > 0.0_JPRB) 
    zrhoair_crain_tl = zem3 * ((yd_mwave_phys_fw % crfl * zconv_rain (1)) ** (zconv_rain (2) - 1.0_JPRB)) &
                     &      * zconv_rain (1) * zconv_rain (2) * yd_mwave_phys_tl % crfl  
  endwhere

  where (yd_mwave_phys_fw % csfl > 0.0_JPRB) 
    zrhoair_csnow_tl = zem3 * ((yd_mwave_phys_fw % csfl * zconv_snow (1)) ** (zconv_snow (2) - 1.0_JPRB)) &
                     &      * zconv_snow (1) * zconv_snow (2) * yd_mwave_phys_tl % csfl  
  endwhere
endif

! (3) Total hydrometeor column
zhydro_column_fw = sum( &
  &   (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) * zdp_fw &
  & + (zrhoair_crain_fw + zrhoair_csnow_fw + zrhoair_lrain_fw + zrhoair_lsnow_fw) * zdz_fw ) 

if (lltl) then
  zhydro_column_tl = sum( &
    &   (yd_mwave_phys_tl % cwc + yd_mwave_phys_tl % cic) * zdp_fw &
    & + (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) * zdp_tl &
    & + (zrhoair_crain_tl + zrhoair_csnow_tl + zrhoair_lrain_tl + zrhoair_lsnow_tl) * zdz_fw &
    & + (zrhoair_crain_fw + zrhoair_csnow_fw + zrhoair_lrain_fw + zrhoair_lsnow_fw) * zdz_tl )
endif

if ( zhydro_column_fw > 1E-12_JPRB ) then

  ! (4) Weighted average of cloud, convective precip, and large-scale precip fraction
  zcfrac_sum_fw = sum( &
    &   yd_mwave_phys_fw % cc   * (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) * zdp_fw &
    & + 0.05                    * (zrhoair_crain_fw + zrhoair_csnow_fw) * zdz_fw &
    & + yd_mwave_phys_fw % pfrc * (zrhoair_lrain_fw + zrhoair_lsnow_fw) * zdz_fw )
  pcfrac_fw = zcfrac_sum_fw / zhydro_column_fw

  if (lltl) then
    zcfrac_sum_tl = sum( &
      &   yd_mwave_phys_tl % cc   * (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) * zdp_fw &
      & + yd_mwave_phys_fw % cc   * (yd_mwave_phys_tl % cwc + yd_mwave_phys_tl % cic) * zdp_fw &
      & + yd_mwave_phys_fw % cc   * (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) * zdp_tl &
      & + 0.05                    * (zrhoair_crain_tl + zrhoair_csnow_tl) * zdz_fw & ! AJGDB 0.05
      & + 0.05                    * (zrhoair_crain_fw + zrhoair_csnow_fw) * zdz_tl &
      & + yd_mwave_phys_tl % pfrc * (zrhoair_lrain_fw + zrhoair_lsnow_fw) * zdz_fw &
      & + yd_mwave_phys_fw % pfrc * (zrhoair_lrain_tl + zrhoair_lsnow_tl) * zdz_fw &
      & + yd_mwave_phys_fw % pfrc * (zrhoair_lrain_fw + zrhoair_lsnow_fw) * zdz_tl )
    pcfrac_tl = zcfrac_sum_tl / zhydro_column_fw - zhydro_column_tl * zcfrac_sum_fw / (zhydro_column_fw ** 2)
  endif

else
  pcfrac_fw = 0.0_JPRB
  if (lltl) pcfrac_tl = 0.0_JPRB
endif

if (llad) then
  
  zdp_ad           = 0.0_JPRB
  zdz_ad           = 0.0_JPRB
  zrhoair_crain_ad = 0.0_JPRB
  zrhoair_csnow_ad = 0.0_JPRB
  zrhoair_lrain_ad = 0.0_JPRB
  zrhoair_lsnow_ad = 0.0_JPRB

  if ( zhydro_column_fw > 1E-12_JPRB ) then

    zcfrac_sum_ad    = pcfrac_ad / zhydro_column_fw
    zhydro_column_ad = pcfrac_ad * (-1.0_JPRB) * zcfrac_sum_fw / (zhydro_column_fw ** 2) 

    yd_mwave_phys_ad % cc  = yd_mwave_phys_ad % cc  + &
      & zcfrac_sum_ad * (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) * zdp_fw 
    yd_mwave_phys_ad % cwc = yd_mwave_phys_ad % cwc + &
      & zcfrac_sum_ad *  yd_mwave_phys_fw % cc                            * zdp_fw 
    yd_mwave_phys_ad % cic = yd_mwave_phys_ad % cic + &
      & zcfrac_sum_ad *  yd_mwave_phys_fw % cc                            * zdp_fw 
    zdp_ad = zdp_ad + &
      & zcfrac_sum_ad * yd_mwave_phys_fw % cc * (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) 

    zrhoair_crain_ad = zrhoair_crain_ad + zcfrac_sum_ad * 0.05 * zdz_fw
    zrhoair_csnow_ad = zrhoair_csnow_ad + zcfrac_sum_ad * 0.05 * zdz_fw
    zdz_ad = zdz_ad + zcfrac_sum_ad * 0.05 * (zrhoair_crain_fw + zrhoair_csnow_fw)

    zrhoair_lrain_ad = zrhoair_lrain_ad + zcfrac_sum_ad * yd_mwave_phys_fw % pfrc * zdz_fw
    zrhoair_lsnow_ad = zrhoair_lsnow_ad + zcfrac_sum_ad * yd_mwave_phys_fw % pfrc * zdz_fw
    yd_mwave_phys_ad % pfrc = yd_mwave_phys_ad % pfrc + &
      & zcfrac_sum_ad * (zrhoair_lrain_fw + zrhoair_lsnow_fw) * zdz_fw
    zdz_ad = zdz_ad + zcfrac_sum_ad * yd_mwave_phys_fw % pfrc * (zrhoair_lrain_fw + zrhoair_lsnow_fw)

  else
    zhydro_column_ad = 0.0_JPRB
  endif
  pcfrac_ad = 0.0_JPRB

  yd_mwave_phys_ad % cwc = yd_mwave_phys_ad % cwc + zhydro_column_ad * zdp_fw 
  yd_mwave_phys_ad % cic = yd_mwave_phys_ad % cic + zhydro_column_ad * zdp_fw 
  zdp_ad = zdp_ad + zhydro_column_ad * (yd_mwave_phys_fw % cwc + yd_mwave_phys_fw % cic) 
  zrhoair_crain_ad = zrhoair_crain_ad + zhydro_column_ad * zdz_fw 
  zrhoair_csnow_ad = zrhoair_csnow_ad + zhydro_column_ad * zdz_fw 
  zrhoair_lrain_ad = zrhoair_lrain_ad + zhydro_column_ad * zdz_fw 
  zrhoair_lsnow_ad = zrhoair_lsnow_ad + zhydro_column_ad * zdz_fw 
  zdz_ad = zdz_ad + zhydro_column_ad * (zrhoair_crain_fw + zrhoair_csnow_fw + zrhoair_lrain_fw + zrhoair_lsnow_fw) 
  zhydro_column_ad = 0.0_JPRB

  where (yd_mwave_phys_fw % rfl > 0.0_JPRB) 
    yd_mwave_phys_ad % rfl = yd_mwave_phys_ad % rfl + &
      & zrhoair_lrain_ad * zem3 * zconv_rain (1) * zconv_rain (2) * &
      & ((yd_mwave_phys_fw % rfl * zconv_rain (1)) ** (zconv_rain (2) - 1.0_JPRB)) 
  endwhere

  where (yd_mwave_phys_fw % sfl > 0.0_JPRB) 
    yd_mwave_phys_ad % sfl = yd_mwave_phys_ad % sfl + &
      & zrhoair_lsnow_ad * zem3 * zconv_snow (1) * zconv_snow (2) * &
      & ((yd_mwave_phys_fw % sfl * zconv_snow (1)) ** (zconv_snow (2) - 1.0_JPRB)) 
  endwhere

  where (yd_mwave_phys_fw % crfl > 0.0_JPRB) 
    yd_mwave_phys_ad % crfl = yd_mwave_phys_ad % crfl + &
      & zrhoair_crain_ad * zem3 * zconv_rain (1) * zconv_rain (2) * &
      & ((yd_mwave_phys_fw % crfl * zconv_rain (1)) ** (zconv_rain (2) - 1.0_JPRB)) 
  endwhere

  where (yd_mwave_phys_fw % csfl > 0.0_JPRB) 
    yd_mwave_phys_ad % csfl = yd_mwave_phys_ad % csfl + &
      & zrhoair_csnow_ad * zem3 * zconv_snow (1) * zconv_snow (2) * &
      & ((yd_mwave_phys_fw % csfl * zconv_snow (1)) ** (zconv_snow (2) - 1.0_JPRB)) 
  endwhere

  zdlnp_ad = 0.0_JPRB
  do ilev = klev, 1, -1

    yd_mwave_phys_ad % t (ilev) = yd_mwave_phys_ad % t (ilev) + &
      & zdz_ad(ilev) * zdlnp_fw (ilev) * rd / rg
    zdlnp_ad (ilev) = zdlnp_ad (ilev) + &
      & zdz_ad(ilev) * yd_mwave_phys_fw % t (ilev) * rd / rg

    if (ilev > 1) then
      
      yd_mwave_phys_ad % ph (ilev+1) = yd_mwave_phys_ad % ph (ilev+1) + &
        & zdlnp_ad (ilev) * (1.0_JPRB / yd_mwave_phys_fw % ph (ilev+1))
      yd_mwave_phys_ad % ph (ilev  ) = yd_mwave_phys_ad % ph (ilev  ) - &
        & zdlnp_ad (ilev) * (1.0_JPRB / yd_mwave_phys_fw % ph (ilev  ))

    endif

    yd_mwave_phys_ad % ph (ilev+1) = yd_mwave_phys_ad % ph (ilev+1) + zdp_ad (ilev) / rg
    yd_mwave_phys_ad % ph (ilev  ) = yd_mwave_phys_ad % ph (ilev  ) - zdp_ad (ilev) / rg

  enddo 

endif

if (lhook) call dr_hook ('MWAVE_CPFRAC',1,zhook_handle) 

end subroutine mwave_cpfrac
