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