ETAMP_Q2F.f

      SUBROUTINE etamp_q2f(QRIMEF,QQI,QQR,QQW,CWM,F_RAIN,F_ICE,F_RIMEF,T)
      ! This subroutine is to be used with the WRF "advected Ferrier
      ! scheme" to calculate the F_ICE, F_RIMEF and F_RAIN arrays from
      ! the QQW, QQR, QQI and the input array QRIMEF.
        use ctlblk_mod, only: lm,im,jsta,jend,jsta_2l,jend_2u,&
                                    ista,iend,ista_2l,iend_2u
        implicit none

        real, intent(in),dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm) :: &
             qrimef,qqw,qqr,qqi, t

        real, intent(out),dimension(ista_2l:iend_2u,jsta_2l:jend_2u,lm) :: &
             f_rain,f_ice,f_rimef,cwm

        integer :: i,j,l
        real :: qt

        ! NOTE: these parameters must match the WRF Ferrier scheme.
        ! They're wrong elsewhere in the post:
        real, parameter :: t_ice=-40., t0c=273.15, t_icek=233.15
        real, parameter :: epsq=1.e-12

      bigl: do l=1,lm
         bigj: do j=jsta,jend
            bigi: do i=ista,iend
               qt=qqw(i,j,l)+qqr(i,j,l)+qqi(i,j,l)
               cwm(i,j,l)=qt
               if(qqi(i,j,l)<=epsq) then
                  f_ice(i,j,l)=0.
                  f_rimef(i,j,l)=1.
                  if(t(i,j,l)<t_icek) f_ice(i,j,l)=1.
               else
                  f_ice(i,j,l)=max(0.,min(1.,qqi(i,j,l)/qt))
                  f_rimef(i,j,l)=max(1.,min(100.,qrimef(i,j,l)/qqi(i,j,l)))
               endif
               if(qqr(i,j,l) <= epsq) then
                  f_rain(i,j,l)=0.
               else
                  f_rain(i,j,l)=max(0.,min(1.,qqr(i,j,l)/(qqr(i,j,l)+qqw(i,j,l))))
               endif
            enddo bigi
         enddo bigj
      enddo bigl
      END SUBROUTINE etamp_q2f