Line data    Source code

       1             : ! Include shortname defintions, so that the F77 code does not have to be modified to
       2             : ! reference the CARMA structure.
       3             : #include "carma_globaer.h"
       4             : 
       5             : !! This routine calculates particle source terms <rnucpe> due to particle
       6             : !! element transfer processes for which the source element number is larger
       7             : !! than the target element number.
       8             : !!
       9             : !! @author Andy Ackerman
      10             : !! @version Dec-1995
      11  1418703438 : subroutine downgxfer(carma, cstate, iz, rc)
      12             : 
      13             :   ! types
      14             :   use carma_precision_mod
      15             :   use carma_enums_mod
      16             :   use carma_constants_mod
      17             :   use carma_types_mod
      18             :   use carmastate_mod
      19             :   use carma_mod
      20             : 
      21             :   implicit none
      22             : 
      23             :   type(carma_type), intent(in)         :: carma   !! the carma object
      24             :   type(carmastate_type), intent(inout) :: cstate  !! the carma state object
      25             :   integer, intent(in)                  :: iz      !! z index
      26             :   integer, intent(inout)               :: rc      !! return code, negative indicates failure
      27             : 
      28             :   ! Local declarations
      29             :   integer                              :: igroup  ! group index
      30             :   integer                              :: iepart
      31             :   integer                              :: ibin    !! bin index
      32             :   integer                              :: ielem   !! element index
      33             :   integer                              :: i
      34             :   integer                              :: jefrom
      35             :   integer                              :: iefrom
      36             :   integer                              :: igfrom
      37             :   integer                              :: ipow_from
      38             :   integer                              :: ipow_to
      39             :   integer                              :: ipow
      40             :   integer                              :: jfrom
      41             :   integer                              :: ifrom
      42             :   integer                              :: ic
      43             :   integer                              :: iecore
      44             :   real(kind=f)                         :: elemass
      45             :   real(kind=f)                         :: totmass
      46             :   real(kind=f)                         :: rmasscore
      47             :   real(kind=f)                         :: fracmass
      48             :   real(kind=f)                         :: rnucprod
      49             :   
      50             : 
      51             :   ! Calculate nucleation source terms for which the source element
      52             :   ! number is greater than the target element number
      53             : 
      54             :   ! Set nucleation production rates to zero to avoid double-application
      55             :   ! of rates calculated in upgxfer.f
      56 >20996*10^7 :   rnucpe(:,:) = 0._f
      57             : 
      58             :   ! Loop over particle elements and bins
      59 11349627504 :   do ielem = 1, NELEM
      60 >20996*10^7 :     do ibin = 1, NBIN
      61             : 
      62             :       ! Define group & particle # concentration indices for current element
      63 >19861*10^7 :       igroup = igelem(ielem)      ! target particle group
      64 >19861*10^7 :       iepart = ienconc(igroup)    ! target particle number concentration element
      65             :       
      66             :       ! First calculate production terms due to nucleation <rnucpe>.
      67             : 
      68             :       ! Loop over elements that nucleate to element <ielem>.
      69 >23692*10^7 :       do jefrom = 1,nnucelem(ielem)
      70             : 
      71 28374068760 :         iefrom = inucelem(jefrom,ielem)    ! source particle element
      72             : 
      73             :         ! Only calculate production rates here if <ielem> is less than
      74             :         ! <iefrom>.  Otherwise, production is calculated in upgxfer.f
      75 >22699*10^7 :         if( ielem .lt. iefrom ) then
      76           0 :           igfrom = igelem(iefrom)            ! source particle group
      77             : 
      78             :           ! <ipow> is the power to which the source particle mass must be taken
      79             :           ! to match the type of the target element.  This ugliness could be
      80             :           ! handled much more slickly in setupnuc()
      81           0 :           if( itype(iefrom) .eq. I_INVOLATILE .or. itype(iefrom) .eq. I_VOLATILE )then
      82             :             ipow_from = 0
      83           0 :           elseif ( itype(iefrom) .eq. I_COREMASS .or. itype(iefrom) .eq. I_VOLCORE )then
      84             :             ipow_from = 1
      85             :           else
      86           0 :             ipow_from = 2
      87             :           endif
      88             : 
      89           0 :           if( itype(ielem) .eq. I_INVOLATILE .or. itype(ielem) .eq. I_VOLATILE )then
      90             :             ipow_to = 0
      91           0 :           elseif ( itype(ielem) .eq. I_COREMASS .or. itype(ielem) .eq. I_VOLCORE )then
      92             :             ipow_to = 1
      93             :           else
      94           0 :             ipow_to = 2
      95             :           endif
      96             : 
      97           0 :           ipow = ipow_to - ipow_from
      98             : 
      99             :           ! Loop over bins that nucleate to bin <ibin>.
     100           0 :           do jfrom = 1,nnucbin(igfrom,ibin,igroup)
     101             : 
     102           0 :             ifrom = inucbin(jfrom,igfrom,ibin,igroup)    ! bin of source
     103             : 
     104             :             ! Bypass calculation if few source particles are present
     105           0 :             if( pconmax(iz,igfrom) .gt. FEW_PC )then
     106           0 :               if( rnuclg(ifrom,igfrom,igroup) .gt. 0._f )then
     107             :            
     108             :                 ! First calculate mass associated with the source element <elemass>
     109             :                 ! (this is <rmass> for all source elements except particle number
     110             :                 ! concentration in a multicomponent particle group).
     111           0 :                 if( ncore(igfrom) .eq. 0 .or. itype(iefrom) .gt. I_VOLATILE )then
     112           0 :                   elemass = rmass(ifrom,igfrom)
     113             :                 else
     114           0 :                   totmass  = pc(iz,ifrom,iefrom) * rmass(ifrom,igfrom)
     115           0 :                   rmasscore = pc(iz,ifrom,icorelem(1,igfrom))
     116             :                   
     117           0 :                   do ic = 2,ncore(igfrom)
     118           0 :                     iecore = icorelem(ic,igfrom)
     119           0 :                     rmasscore = rmasscore + pc(iz,ifrom,iecore)
     120             :                   enddo
     121             :                   
     122           0 :                   fracmass = 1._f - rmasscore/totmass
     123           0 :                   elemass  = fracmass * rmass(ifrom,igfrom)
     124             :                 endif
     125             : 
     126             :                 rnucprod = rnuclg(ifrom,igfrom,igroup) * &
     127           0 :                   pc(iz,ifrom,iefrom) * elemass**ipow
     128             : 
     129           0 :                 rnucpe(ibin,ielem) = rnucpe(ibin,ielem) + rnucprod
     130             : 
     131             :                 ! Calculate latent heat associated with nucleation to <ibin,ielem>
     132             :                 ! from <ifrom,iefrom>
     133             : !                rlprod = rlprod + rnucprod * rlh_nuc(iefrom,ielem) / &
     134             : !                  (CP * rhoa(iz)) * elemass
     135             : 
     136             :               endif  ! (rnuclg > 0.)
     137             :             endif   ! (pconmax > FEW_PC)
     138             :           enddo    ! (jfrom = 1,nnucbin)
     139             :         endif     ! (ielem < iefrom)
     140             :       enddo      ! (jefrom = 1,nnucelem)
     141             :     enddo       ! (ibin = 1, NBIN)
     142             :   enddo       ! (ielem = 1, NELEM)
     143             : 
     144             :   ! Return to caller with down-grid production terms evaluated.
     145  1418703438 :   return
     146  1418703438 : end