secondary_continuum.F90 coverage: 68.75 %func 63.08 %block
1) ! added by S. Karra 07/11/12
2)
3) module Secondary_Continuum_module
4)
5) use Secondary_Continuum_Aux_module
6)
7) use PFLOTRAN_Constants_module
8)
9) implicit none
10)
11) private
12)
13) #include "petsc/finclude/petscsys.h"
14)
15) #include "petsc/finclude/petscvec.h"
16) #include "petsc/finclude/petscvec.h90"
17) #include "petsc/finclude/petscmat.h"
18) #include "petsc/finclude/petscmat.h90"
19) #include "petsc/finclude/petscsnes.h"
20) #include "petsc/finclude/petscviewer.h"
21) #include "petsc/finclude/petsclog.h"
22)
23) ! secondary continuum cell type
24) PetscInt, parameter, public :: SLAB = 0
25) PetscInt, parameter, public :: NESTED_CUBE = 1
26) PetscInt, parameter, public :: NESTED_SPHERE = 2
27)
28) PetscReal, parameter :: perturbation_tolerance = 1.d-5
29)
30) public :: SecondaryContinuumType, &
31) SecondaryContinuumSetProperties, &
32) SecondaryRTAuxVarInit, &
33) SecondaryRTResJacMulti, &
34) SecondaryRTAuxVarComputeMulti, &
35) THCSecHeatAuxVarCompute, &
36) THSecHeatAuxVarCompute, &
37) MphaseSecHeatAuxVarCompute, &
38) SecondaryRTUpdateIterate, &
39) SecondaryRTUpdateEquilState, &
40) SecondaryRTUpdateKineticState, &
41) SecondaryRTTimeCut
42)
43) contains
44)
45) ! ************************************************************************** !
46)
47) subroutine SecondaryContinuumType(sec_continuum,nmat,aream, &
48) volm,dm1,dm2,aperture,epsilon,log_spacing,outer_spacing, &
49) interfacial_area,option)
50) !
51) ! The area, volume, grid sizes for secondary continuum
52) ! are calculated based on the input dimensions and geometry
53) !
54) ! Author: Satish Karra, LANL
55) ! Date: 07/11/12
56) !
57)
58) use Option_module
59)
60) implicit none
61)
62) type(sec_continuum_type) :: sec_continuum
63)
64) type(option_type) :: option
65)
66) character(len=MAXSTRINGLENGTH) :: string
67)
68) PetscInt :: igeom, nmat, m
69) PetscReal :: aream(nmat), volm(nmat), dm1(nmat), dm2(nmat)
70) PetscReal :: dy, r0, r1, aream0, am0, vm0, interfacial_area
71) PetscReal :: num_density, aperture, epsilon, fracture_spacing
72) PetscReal :: outer_spacing, matrix_block_size
73) PetscReal :: grid_spacing(nmat)
74) PetscBool :: log_spacing
75) PetscReal :: sum
76)
77) PetscInt, save :: icall
78)
79) data icall/0/
80)
81) igeom = sec_continuum%itype
82) option%nsec_cells = nmat
83)
84) select case (igeom)
85) case(SLAB)
86)
87) dy = sec_continuum%slab%length/nmat
88) aream0 = sec_continuum%slab%area
89) do m = 1, nmat
90) volm(m) = dy*aream0
91) enddo
92) am0 = aream0
93) vm0 = nmat*dy*aream0
94) interfacial_area = am0/vm0
95)
96) do m = 1, nmat
97) aream(m) = aream0
98) dm1(m) = 0.5d0*dy
99) dm2(m) = 0.5d0*dy
100) enddo
101)
102) if (icall == 0 .and. OptionPrintToFile(option)) then
103) icall = 1
104) string = 'DCDM Multiple Continuum Model'
105) write(option%fid_out,'(/,2x,a,/)') trim(string)
106) string = 'Slab'
107) write(option%fid_out,'(2x,a,/)') trim(string)
108) num_density = (1.d0-epsilon)/vm0
109) write(option%fid_out,'(2x,"number density: ",11x,1pe12.4," m^(-3)")') num_density
110) write(option%fid_out,'(2x,"matrix block size: ",8x,1pe12.4," m")') sec_continuum%slab%length
111) write(option%fid_out,'(2x,"epsilon: ",18x,1pe12.4)') epsilon
112) write(option%fid_out,'(2x,"specific interfacial area: ",1pe12.4," m^(-1)")') interfacial_area
113) do m = 1, nmat
114) if (m == 1) write(option%fid_out,'(/,2x,"node matrix volume fraction")')
115) write(option%fid_out,'(2x,i3,3x,1pe12.4)') m,volm(m)/vm0 !*(1.d0 - epsilon)
116) enddo
117) ! aperture = r0*(1.d0/(1.d0-epsilon)**(1.d0/3.d0)-1.d0)
118) ! write(option%fid_out,'(2x,"aperture: ",17x,1pe12.4," m")') aperture
119) endif
120)
121) ! Store the distances
122) sec_continuum%distance(1) = dm1(1)
123) do m = 2, nmat
124) sec_continuum%distance(m) = sec_continuum%distance(m-1) + &
125) dm2(m-1) + dm1(m)
126) enddo
127)
128) case(NESTED_CUBE)
129)
130) if (sec_continuum%nested_cube%fracture_spacing > 0.d0) then
131)
132) fracture_spacing = sec_continuum%nested_cube%fracture_spacing
133) ! override epsilon if aperture defined
134) if (aperture > 0.d0) then
135) r0 = fracture_spacing - aperture
136) epsilon = 1.d0 - (1.d0 + aperture/r0)**(-3.d0)
137) else if (epsilon > 0.d0) then
138) r0 = fracture_spacing*(1.d0-epsilon)**(1.d0/3.d0)
139) aperture = r0*((1.d0-epsilon)**(-1.d0/3.d0)-1.d0)
140) endif
141)
142) else if (sec_continuum%nested_cube%matrix_block_size > 0.d0) then
143)
144) r0 = sec_continuum%nested_cube%matrix_block_size
145)
146) ! override epsilon if aperture defined
147) if (aperture > 0.d0) then
148) fracture_spacing = r0 + aperture
149) epsilon = 1.d0 - (1.d0 + aperture/r0)**(-3.d0)
150) else if (epsilon > 0.d0) then
151) fracture_spacing = r0*(1.d0-epsilon)**(-1.d0/3.d0)
152) aperture = fracture_spacing - r0
153) endif
154) endif
155)
156) if (log_spacing) then
157)
158) matrix_block_size = r0
159) call SecondaryContinuumCalcLogSpacing(matrix_block_size,outer_spacing, &
160) nmat,grid_spacing,option)
161)
162) r0 = 2.d0*grid_spacing(1)
163) dm1(1) = 0.5d0*grid_spacing(1)
164) dm2(1) = 0.5d0*grid_spacing(1)
165) volm(1) = r0**3.d0
166) aream(1) = 6.d0*r0**2.d0
167) do m = 2, nmat
168) dm1(m) = 0.5d0*grid_spacing(m)
169) dm2(m) = 0.5d0*grid_spacing(m)
170) r1 = r0 + 2.d0*(dm1(m) + dm2(m))
171) volm(m) = r1**3.d0 - r0**3.d0
172) aream(m) = 6.d0*r1**2.d0
173) r0 = r1
174) enddo
175) r0 = matrix_block_size
176) am0 = 6.d0*r0**2.d0
177) vm0 = r0**3.d0
178) interfacial_area = am0/vm0
179)
180) else
181) dy = r0/nmat/2.d0
182)
183) r0 = 2.d0*dy
184) volm(1) = r0**3.d0
185) do m = 2, nmat
186) r1 = r0 + 2.d0*dy
187) volm(m) = r1**3.d0 - r0**3.d0
188) r0 = r1
189) enddo
190)
191) r0 = 2.d0*dy
192) aream(1) = 6.d0*r0**2.d0
193) dm1(1) = 0.5d0*dy
194) dm2(1) = 0.5d0*dy
195) do m = 2, nmat
196) dm1(m) = 0.5d0*dy
197) dm2(m) = 0.5d0*dy
198) r0 = r0 + 2.d0*dy
199) aream(m) = 6.d0*r0**2.d0
200) enddo
201) r0 = real(2.d0*nmat)*dy
202) am0 = 6.d0*r0**2.d0
203) vm0 = r0**3.d0
204) interfacial_area = am0/vm0
205) endif
206)
207) if (icall == 0 .and. OptionPrintToFile(option)) then
208) icall = 1
209) string = 'DCDM Multiple Continuum Model'
210) write(option%fid_out,'(/,2x,a,/)') trim(string)
211) string = 'Nested Cubes'
212) write(option%fid_out,'(2x,a,/)') trim(string)
213) num_density = (1.d0-epsilon)/vm0
214) write(option%fid_out,'(2x,"number density: ",11x,1pe12.4," m^(-3)")') num_density
215) write(option%fid_out,'(2x,"matrix block size: ",8x,1pe12.4," m")') r0
216) write(option%fid_out,'(2x,"epsilon: ",18x,1pe12.4)') epsilon
217) write(option%fid_out,'(2x,"specific interfacial area: ",1pe12.4," m^(-1)")') interfacial_area
218) write(option%fid_out,'(2x,"fracture aperture: ",8x,1pe12.4," m")') aperture
219) write(option%fid_out,'(2x,"fracture spacing: ",9x,1pe12.4," m")') fracture_spacing
220) write(option%fid_out,'(/,2x,"node vol. frac. dm1 dm2 aream dy y")')
221) r0 = 0.d0
222) do m = 1, nmat
223) if (m == 1) then
224) r0 = r0 + dm1(m)
225) else
226) r0 = r0 + dm2(m-1)+dm1(m)
227) endif
228) write(option%fid_out,'(2x,i3,3x,1p6e12.4)') m,volm(m)/vm0,dm1(m),dm2(m),aream(m), &
229) dm1(m)+dm2(m),r0
230) enddo
231) endif
232)
233) ! Store the distances
234) sec_continuum%distance(1) = dm1(1)
235) do m = 2, nmat
236) sec_continuum%distance(m) = sec_continuum%distance(m-1) + &
237) dm2(m-1) + dm1(m)
238) enddo
239)
240) case(NESTED_SPHERE)
241)
242) dy = sec_continuum%nested_sphere%radius/nmat
243) r0 = dy
244)
245) volm(1) = 4.d0/3.d0*pi*r0**3.d0
246) do m = 2, nmat
247) r1 = r0 + dy
248) volm(m) = 4.d0/3.d0*pi*(r1**3.d0 - r0**3.d0)
249) r0 = r1
250) enddo
251)
252) r0 = dy
253) aream(1) = 4.d0*pi*r0**2.d0
254) dm1(1) = 0.5d0*dy
255) dm2(1) = 0.5d0*dy
256) do m = 2, nmat
257) r0 = r0 + dy
258) dm1(m) = 0.5d0*dy
259) dm2(m) = 0.5d0*dy
260) aream(m) = 4.d0*pi*r0**2.d0
261) enddo
262) r0 = 0.5d0*real(2.d0*nmat)*dy
263) am0 = 4.d0*pi*r0**2.d0
264) vm0 = am0*r0/3.d0
265) interfacial_area = am0/vm0
266)
267) if (icall == 0 .and. OptionPrintToFile(option)) then
268) icall = 1
269) string = 'DCDM Multiple Continuum Model'
270) write(option%fid_out,'(/,2x,a,/)') trim(string)
271) string = 'Nested Spheres'
272) write(option%fid_out,'(2x,a,/)') trim(string)
273) num_density = (1.d0-epsilon)/vm0
274) write(option%fid_out,'(2x,"number density: ",11x,1pe12.4," m^(-3)")') num_density
275) write(option%fid_out,'(2x,"sphere radius: ",8x,1pe12.4," m")') sec_continuum%nested_sphere%radius
276) write(option%fid_out,'(2x,"epsilon: ",18x,1pe12.4)') epsilon
277) write(option%fid_out,'(2x,"specific interfacial area: ",1pe12.4," m^(-1)")') interfacial_area
278) do m = 1, nmat
279) if (m == 1) write(option%fid_out,'(/,2x,"node matrix volume fraction")')
280) write(option%fid_out,'(2x,i3,3x,1pe12.4)') m,volm(m)/vm0*(1.d0 - epsilon)
281) enddo
282)
283) ! aperture = r0*(1.d0/(1.d0-epsilon)**(1.d0/3.d0)-1.d0)
284) ! write(option%fid_out,'(2x,"aperture: ",17x,1pe12.4," m")') aperture
285) endif
286)
287) ! Store the distances
288) sec_continuum%distance(1) = dm1(1)
289) do m = 2, nmat
290) sec_continuum%distance(m) = sec_continuum%distance(m-1) + &
291) dm2(m-1) + dm1(m)
292) enddo
293)
294) end select
295)
296)
297) sum = 0.d0
298) do m = 1,nmat
299) if (volm(m)/vm0 > 1.d0) then
300) print *, 'Error: volume fraction for cell', m, 'is greater than 1.'
301) stop
302) else
303) sum = sum + volm(m)/vm0
304) endif
305) enddo
306)
307) if (icall /= 2 .and. OptionPrintToFile(Option)) then
308) icall = 2
309) write(option%fid_out,'(/,"sum of volume fractions:",1x,1pe12.4)') sum
310) endif
311)
312) if (abs(sum - 1.d0) > 1.d-6) then
313) option%io_buffer = 'Error: Sum of the volume fractions of the' // &
314) ' secondary cells is not equal to 1.'
315) call printErrMsg(option)
316) endif
317)
318) end subroutine SecondaryContinuumType
319)
320) ! ************************************************************************** !
321)
322) subroutine SecondaryContinuumSetProperties(sec_continuum, &
323) sec_continuum_name, &
324) sec_continuum_length, &
325) sec_continuum_matrix_block_size, &
326) sec_continuum_fracture_spacing, &
327) sec_continuum_radius, &
328) sec_continuum_area, &
329) option)
330) !
331) ! The type, dimensions of the secondary
332) ! continuum are set
333) !
334) ! Author: Satish Karra, LANL
335) ! Date: 07/17/12
336) !
337)
338) use Option_module
339) use String_module
340)
341) implicit none
342)
343) type(sec_continuum_type) :: sec_continuum
344) type(option_type) :: option
345) PetscReal :: sec_continuum_matrix_block_size
346) PetscReal :: sec_continuum_fracture_spacing
347) PetscReal :: sec_continuum_length
348) PetscReal :: sec_continuum_area
349) PetscReal :: sec_continuum_radius
350) character(len=MAXWORDLENGTH) :: sec_continuum_name
351)
352) call StringToUpper(sec_continuum_name)
353)
354) select case(trim(sec_continuum_name))
355) case("SLAB")
356) sec_continuum%itype = SLAB
357) sec_continuum%slab%length = sec_continuum_length
358) if (sec_continuum_area == 0.d0) then
359) option%io_buffer = 'Keyword "AREA" not specified for SLAB type ' // &
360) 'under SECONDARY_CONTINUUM'
361) call printErrMsg(option)
362) endif
363) sec_continuum%slab%area = sec_continuum_area
364) case("NESTED_CUBES")
365) sec_continuum%itype = NESTED_CUBE
366) sec_continuum%nested_cube%matrix_block_size = sec_continuum_matrix_block_size
367) sec_continuum%nested_cube%fracture_spacing = sec_continuum_fracture_spacing
368) case("NESTED_SPHERES")
369) sec_continuum%itype = NESTED_SPHERE
370) sec_continuum%nested_sphere%radius = sec_continuum_radius
371) case default
372) option%io_buffer = 'Keyword "' // trim(sec_continuum_name) // '" not ' // &
373) 'recognized in SecondaryContinuumSetProperties()'
374) call printErrMsg(option)
375) end select
376)
377) end subroutine SecondaryContinuumSetProperties
378)
379) ! ************************************************************************** !
380)
381) subroutine SecondaryContinuumCalcLogSpacing(matrix_size,outer_grid_size, &
382) sec_num_cells,grid_spacing,option)
383) !
384) ! Given the matrix block size and the
385) ! grid spacing of the outer most secondary continuum cell, a geometric
386) ! series is assumed and the grid spacing of the rest of the cells is
387) ! calculated
388) !
389) ! Equation:
390) ! \frac{1 - \rho}{1 - \rho_M}*\rho*(M-1) = \frac{2\Delta\xi_m}{l_M}
391) !
392) ! where
393) ! \Delta\xi_m: Grid spacing of the outer most continuum cell (INPUT)
394) ! l_M : Matrix block size (INPUT)
395) ! M : Number of secondary continuum cells (INPUT)
396) ! \rho : Logarithmic grid spacing factor (COMPUTED)
397) !
398) ! Author: Satish Karra, LANL
399) ! Date: 07/17/12
400) !
401)
402) use Option_module
403)
404) implicit none
405)
406) type(option_type) :: option
407) PetscReal :: matrix_size, outer_grid_size
408) PetscInt :: sec_num_cells
409) PetscReal :: grid_spacing(sec_num_cells)
410) PetscReal :: delta, delta_new, inner_grid_size
411) PetscReal :: F, dF
412) PetscReal, parameter :: tol = 1.d-12
413) PetscInt, parameter :: maxit = 50
414) PetscInt :: i
415)
416)
417) if (mod(sec_num_cells,2) /= 0) then
418) option%io_buffer = 'NUM_CELLS under SECONDARY_CONTINUUM has to be' // &
419) ' even for logarithmic grid spacing'
420) call printErrMsg(option)
421) endif
422)
423) delta = 0.99d0
424)
425) do i = 1, maxit
426) F = (1.d0 - delta)/(1.d0 - delta**sec_num_cells)*delta**(sec_num_cells - 1.d0) - &
427) 2.d0*outer_grid_size/matrix_size
428) dF = (1.d0 + sec_num_cells*(delta - 1.d0) - delta**sec_num_cells)/ &
429) (delta**sec_num_cells - 1.d0)**2.d0*delta**(sec_num_cells - 2.d0)
430) delta_new = delta + F/dF
431) if ((abs(F) < tol)) exit
432) delta = delta_new
433) if (delta < 0.d0) delta = 0.5d0
434) ! if (delta > 1.d0) delta = 0.9d0
435) enddo
436)
437) if (i == maxit) then
438) option%io_buffer = 'Log Grid spacing solution has not converged' // &
439) ' with given fracture values.'
440) call printErrMsg(option)
441) endif
442)
443) inner_grid_size = outer_grid_size/delta**(sec_num_cells - 1)
444)
445) do i = 1, sec_num_cells
446) grid_spacing(i) = inner_grid_size*delta**(i-1)
447) enddo
448)
449) ! write(option%fid_out,'(" Logarithmic grid spacing: delta = ",1pe12.4)') delta
450)
451) end subroutine SecondaryContinuumCalcLogSpacing
452)
453) ! ************************************************************************** !
454)
455) subroutine SecondaryRTTimeCut(realization)
456) !
457) ! Resets secondary concentrations to previous time
458) ! step when there is a time cut
459) !
460) ! Author: Satish Karra, LANL
461) ! Date: 05/29/13
462) !
463)
464) use Realization_Subsurface_class
465) use Grid_module
466) use Reaction_Aux_module
467)
468) implicit none
469) class(realization_subsurface_type) :: realization
470) type(reaction_type), pointer :: reaction
471) type(sec_transport_type), pointer :: rt_sec_transport_vars(:)
472) type(grid_type), pointer :: grid
473)
474) PetscInt :: local_id, ghosted_id
475) PetscInt :: ngcells, ncomp
476) PetscInt :: cell, comp
477)
478) reaction => realization%reaction
479) rt_sec_transport_vars => realization%patch%aux%SC_RT%sec_transport_vars
480) grid => realization%patch%grid
481)
482) ncomp = reaction%naqcomp
483)
484) do local_id = 1, grid%nlmax
485) ghosted_id = grid%nL2G(local_id)
486) if (realization%patch%imat(ghosted_id) <= 0) cycle
487) do comp = 1, ncomp
488) ngcells = rt_sec_transport_vars(local_id)%ncells
489) do cell = 1, ngcells
490) rt_sec_transport_vars(local_id)%updated_conc(comp,cell) = &
491) rt_sec_transport_vars(local_id)%sec_rt_auxvar(cell)%pri_molal(comp)
492) enddo
493) enddo
494) enddo
495)
496) end subroutine SecondaryRTTimeCut
497)
498) ! ************************************************************************** !
499)
500) subroutine SecondaryRTAuxVarInit(ptr,rt_sec_transport_vars,reaction, &
501) initial_condition,constraint,option)
502) !
503) ! Initializes all the secondary continuum reactive
504) ! transport variables
505) !
506) ! Author: Satish Karra, LANL
507) ! Date: 02/05/13
508) !
509)
510) use Coupler_module
511) use Transport_Constraint_module
512) use Condition_module
513) use Global_Aux_module
514) use Material_module
515) use Option_module
516) use Reaction_module
517) use Reaction_Aux_module
518) use Reactive_Transport_Aux_module
519) use Material_Aux_class
520)
521) use EOS_Water_module
522)
523) implicit none
524)
525) type(sec_transport_type) :: rt_sec_transport_vars
526) type(material_property_type), pointer :: ptr
527) type(reaction_type), pointer :: reaction
528) type(coupler_type), pointer :: initial_condition
529) type(option_type), pointer :: option
530) type(reactive_transport_auxvar_type), pointer :: rt_auxvar
531) type(global_auxvar_type), pointer :: global_auxvar
532) class(material_auxvar_type), allocatable :: material_auxvar
533) type(tran_constraint_type), pointer :: constraint
534) type(flow_condition_type), pointer :: initial_flow_condition
535)
536)
537) PetscReal :: equil_conc(reaction%mineral%nmnrl)
538) PetscInt :: i, cell
539) PetscReal :: area_per_vol
540) PetscReal :: dum1
541) PetscInt :: num_iterations
542) PetscErrorCode :: ierr
543)
544) num_iterations = 0
545)
546) allocate(material_auxvar)
547) call MaterialAuxVarInit(material_auxvar,option)
548) material_auxvar%porosity = option%reference_porosity
549)
550) call SecondaryContinuumSetProperties( &
551) rt_sec_transport_vars%sec_continuum, &
552) ptr%secondary_continuum_name, &
553) ptr%secondary_continuum_length, &
554) ptr%secondary_continuum_matrix_block_size, &
555) ptr%secondary_continuum_fracture_spacing, &
556) ptr%secondary_continuum_radius, &
557) ptr%secondary_continuum_area, &
558) option)
559)
560) rt_sec_transport_vars%ncells = ptr%secondary_continuum_ncells
561) rt_sec_transport_vars%aperture = ptr%secondary_continuum_aperture
562) rt_sec_transport_vars%epsilon = ptr%secondary_continuum_epsilon
563) rt_sec_transport_vars%log_spacing = ptr%secondary_continuum_log_spacing
564) rt_sec_transport_vars%outer_spacing = ptr%secondary_continuum_outer_spacing
565)
566) allocate(rt_sec_transport_vars%area(rt_sec_transport_vars%ncells))
567) allocate(rt_sec_transport_vars%vol(rt_sec_transport_vars%ncells))
568) allocate(rt_sec_transport_vars%dm_minus(rt_sec_transport_vars%ncells))
569) allocate(rt_sec_transport_vars%dm_plus(rt_sec_transport_vars%ncells))
570) allocate(rt_sec_transport_vars%sec_continuum% &
571) distance(rt_sec_transport_vars%ncells))
572)
573) call SecondaryContinuumType(rt_sec_transport_vars%sec_continuum, &
574) rt_sec_transport_vars%ncells, &
575) rt_sec_transport_vars%area, &
576) rt_sec_transport_vars%vol, &
577) rt_sec_transport_vars%dm_minus, &
578) rt_sec_transport_vars%dm_plus, &
579) rt_sec_transport_vars%aperture, &
580) rt_sec_transport_vars%epsilon, &
581) rt_sec_transport_vars%log_spacing, &
582) rt_sec_transport_vars%outer_spacing, &
583) area_per_vol,option)
584) rt_sec_transport_vars%interfacial_area = area_per_vol* &
585) (1.d0 - rt_sec_transport_vars%epsilon)*ptr% &
586) secondary_continuum_area_scaling
587)
588) ! Initializing the secondary RT auxvars
589) allocate(rt_sec_transport_vars%sec_rt_auxvar(rt_sec_transport_vars%ncells))
590) do cell = 1, rt_sec_transport_vars%ncells
591) call RTAuxVarInit(rt_sec_transport_vars%sec_rt_auxvar(cell),reaction,option)
592) enddo
593)
594) allocate(rt_sec_transport_vars%sec_jac(reaction%naqcomp,reaction%naqcomp))
595)
596) ! Allocate diagonal terms
597) allocate(rt_sec_transport_vars%cxm(reaction%naqcomp,reaction%naqcomp,&
598) rt_sec_transport_vars%ncells))
599) allocate(rt_sec_transport_vars%cxp(reaction%naqcomp,reaction%naqcomp,&
600) rt_sec_transport_vars%ncells))
601) allocate(rt_sec_transport_vars%cdl(reaction%naqcomp,reaction%naqcomp,&
602) rt_sec_transport_vars%ncells))
603) allocate(rt_sec_transport_vars% &
604) r(reaction%naqcomp*rt_sec_transport_vars%ncells))
605) allocate(rt_sec_transport_vars% &
606) updated_conc(reaction%naqcomp,rt_sec_transport_vars%ncells))
607)
608)
609) initial_flow_condition => initial_condition%flow_condition
610) do cell = 1, rt_sec_transport_vars%ncells
611) global_auxvar => initial_condition%tran_condition% &
612) constraint_coupler_list%global_auxvar
613) rt_auxvar => rt_sec_transport_vars%sec_rt_auxvar(cell)
614) if (associated(initial_flow_condition)) then
615) if (associated(initial_flow_condition%pressure)) then
616) if (associated(initial_flow_condition%pressure%dataset)) then
617) global_auxvar%pres = &
618) initial_flow_condition%pressure%dataset%rarray(1)
619) else
620) global_auxvar%pres = option%reference_pressure
621) endif
622) else
623) global_auxvar%pres = option%reference_pressure
624) endif
625) if (associated(initial_flow_condition%temperature)) then
626) if (associated(initial_flow_condition%temperature%dataset)) then
627) global_auxvar%temp = &
628) initial_flow_condition%temperature%dataset%rarray(1)
629) else
630) global_auxvar%temp = option%reference_temperature
631) endif
632) else
633) global_auxvar%temp = option%reference_temperature
634) endif
635)
636) call EOSWaterDensity(global_auxvar%temp, &
637) global_auxvar%pres(1), &
638) global_auxvar%den_kg(1), &
639) dum1,ierr)
640) else
641) global_auxvar%pres = option%reference_pressure
642) global_auxvar%temp = option%reference_temperature
643) global_auxvar%den_kg = option%reference_water_density
644) endif
645) global_auxvar%sat = option%reference_saturation
646)
647) call ReactionEquilibrateConstraint(rt_auxvar,global_auxvar, &
648) material_auxvar, &
649) reaction,constraint%name, &
650) constraint%aqueous_species, &
651) constraint%free_ion_guess, &
652) constraint%minerals, &
653) constraint%surface_complexes, &
654) constraint%colloids, &
655) constraint%immobile_species, &
656) num_iterations, &
657) PETSC_FALSE,option)
658)
659) rt_sec_transport_vars%updated_conc(:,cell) = rt_auxvar%pri_molal
660)
661) enddo
662)
663) call MaterialAuxVarStrip(material_auxvar)
664) deallocate(material_auxvar)
665)
666) rt_sec_transport_vars%sec_jac_update = PETSC_FALSE
667) rt_sec_transport_vars%sec_jac = 0.d0
668) rt_sec_transport_vars%cxm = 0.d0
669) rt_sec_transport_vars%cxp = 0.d0
670) rt_sec_transport_vars%cdl = 0.d0
671) rt_sec_transport_vars%r = 0.d0
672)
673) end subroutine SecondaryRTAuxVarInit
674)
675) ! ************************************************************************** !
676)
677) subroutine SecondaryRTResJacMulti(sec_transport_vars,auxvar, &
678) global_auxvar,prim_vol, &
679) reaction,diffusion_coefficient, &
680) porosity,option,res_transport)
681) !
682) ! RTSecondaryTransportMulti: Calculates the source term contribution due to
683) ! secondary continuum in the primary continuum residual for multicomponent
684) ! system assuming only aqueous reaction
685) !
686) ! Author: Satish Karra, LANL
687) ! Date: 1/31/13
688) !
689)
690)
691) use Option_module
692) use Global_Aux_module
693) use Block_Solve_module
694) use Block_Tridiag_module
695) use Utility_module
696) use Reaction_module
697) use Reaction_Aux_module
698) use Reactive_Transport_Aux_module
699) use Material_Aux_class
700)
701) implicit none
702)
703) type(sec_transport_type) :: sec_transport_vars
704) type(reactive_transport_auxvar_type) :: auxvar
705) type(reactive_transport_auxvar_type) :: rt_auxvar
706) type(global_auxvar_type) :: global_auxvar
707) type(reaction_type), pointer :: reaction
708) type(option_type) :: option
709) PetscReal :: coeff_left(reaction%naqcomp,reaction%naqcomp, &
710) sec_transport_vars%ncells)
711) PetscReal :: coeff_diag(reaction%naqcomp,reaction%naqcomp, &
712) sec_transport_vars%ncells)
713) PetscReal :: coeff_right(reaction%naqcomp,reaction%naqcomp, &
714) sec_transport_vars%ncells)
715) PetscReal :: res(sec_transport_vars%ncells*reaction%naqcomp)
716) PetscReal :: rhs(sec_transport_vars%ncells*reaction%naqcomp)
717) PetscReal :: D_M(reaction%naqcomp,reaction%naqcomp)
718) PetscReal :: identity(reaction%naqcomp,reaction%naqcomp)
719) PetscReal :: b_M(reaction%naqcomp,reaction%naqcomp)
720) PetscReal :: sec_jac(reaction%naqcomp,reaction%naqcomp)
721) PetscReal :: inv_D_M(reaction%naqcomp,reaction%naqcomp)
722) PetscReal :: conc_upd(reaction%naqcomp,sec_transport_vars%ncells)
723) PetscReal :: total_upd(reaction%naqcomp,sec_transport_vars%ncells)
724) PetscReal :: total_prev(reaction%naqcomp,sec_transport_vars%ncells)
725) PetscReal :: conc_current_M(reaction%naqcomp)
726) PetscReal :: total_current_M(reaction%naqcomp)
727) PetscReal :: res_transport(reaction%naqcomp)
728) PetscReal :: total_primary_node(reaction%naqcomp)
729) PetscReal :: area(sec_transport_vars%ncells)
730) PetscReal :: vol(sec_transport_vars%ncells)
731) PetscReal :: dm_plus(sec_transport_vars%ncells)
732) PetscReal :: dm_minus(sec_transport_vars%ncells)
733) PetscReal :: res_react(reaction%naqcomp)
734) PetscReal :: jac_react(reaction%naqcomp,reaction%naqcomp)
735) PetscReal :: dtotal(reaction%naqcomp,reaction%naqcomp,sec_transport_vars%ncells)
736) PetscReal :: dtotal_prim(reaction%naqcomp,reaction%naqcomp)
737) PetscInt :: i, j, k, n, l
738) PetscInt :: ngcells, ncomp
739) PetscReal :: area_fm
740) PetscReal :: diffusion_coefficient
741) PetscReal :: porosity
742) PetscReal :: arrhenius_factor
743) PetscReal :: pordt, pordiff
744) PetscReal :: prim_vol ! volume of primary grid cell
745) PetscReal :: dCsec_dCprim(reaction%naqcomp,reaction%naqcomp)
746) PetscReal :: dPsisec_dCprim(reaction%naqcomp,reaction%naqcomp)
747) PetscInt :: jcomp, lcomp, kcomp, icplx, ncompeq
748) PetscReal :: sec_sec_molal_M(reaction%neqcplx) ! secondary species molality of secondary continuum
749)
750) PetscInt :: pivot(reaction%naqcomp,sec_transport_vars%ncells)
751) PetscInt :: indx(reaction%naqcomp)
752) PetscInt :: d, ier
753) PetscReal :: m
754)
755) ! Quantities for numerical jacobian
756) PetscReal :: conc_prim(reaction%naqcomp)
757) PetscReal :: conc_prim_pert(reaction%naqcomp)
758) PetscReal :: sec_jac_num(reaction%naqcomp,reaction%naqcomp)
759) PetscReal :: conc_current_M_pert(reaction%naqcomp)
760) PetscReal :: total_current_M_pert(reaction%naqcomp)
761) PetscReal :: res_transport_pert(reaction%naqcomp)
762) PetscReal :: total_primary_node_pert(reaction%naqcomp)
763) PetscReal :: dtotal_prim_num(reaction%naqcomp,reaction%naqcomp)
764) PetscReal :: dPsisec_dCprim_num(reaction%naqcomp,reaction%naqcomp)
765) PetscReal :: pert
766) PetscReal :: coeff_diag_dm(reaction%naqcomp,reaction%naqcomp, &
767) sec_transport_vars%ncells)
768) PetscReal :: coeff_left_dm(reaction%naqcomp,reaction%naqcomp, &
769) sec_transport_vars%ncells)
770) PetscReal :: coeff_right_dm(reaction%naqcomp,reaction%naqcomp, &
771) sec_transport_vars%ncells)
772) PetscReal :: coeff_left_pert(reaction%naqcomp,reaction%naqcomp, &
773) sec_transport_vars%ncells)
774) PetscReal :: coeff_diag_pert(reaction%naqcomp,reaction%naqcomp, &
775) sec_transport_vars%ncells)
776) PetscReal :: coeff_right_pert(reaction%naqcomp,reaction%naqcomp, &
777) sec_transport_vars%ncells)
778) PetscReal :: coeff_left_copy(reaction%naqcomp,reaction%naqcomp, &
779) sec_transport_vars%ncells)
780) PetscReal :: coeff_diag_copy(reaction%naqcomp,reaction%naqcomp, &
781) sec_transport_vars%ncells)
782) PetscReal :: coeff_right_copy(reaction%naqcomp,reaction%naqcomp, &
783) sec_transport_vars%ncells)
784)
785) PetscReal :: total_sorb_upd(reaction%naqcomp,sec_transport_vars%ncells)
786) PetscReal :: total_sorb_prev(reaction%naqcomp,sec_transport_vars%ncells)
787) PetscReal :: dtotal_sorb_upd(reaction%naqcomp,reaction%naqcomp,sec_transport_vars%ncells)
788)
789) class(material_auxvar_type), allocatable :: material_auxvar
790)
791) ngcells = sec_transport_vars%ncells
792) area = sec_transport_vars%area
793) vol = sec_transport_vars%vol
794) dm_plus = sec_transport_vars%dm_plus
795) dm_minus = sec_transport_vars%dm_minus
796) area_fm = sec_transport_vars%interfacial_area
797) ncomp = reaction%naqcomp
798)
799) do j = 1, ncomp
800) do i = 1, ngcells
801) total_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total(j,1)
802) if (reaction%neqsorb > 0) then
803) total_sorb_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total_sorb_eq(j)
804) endif
805) enddo
806) enddo
807) conc_upd = sec_transport_vars%updated_conc
808)
809) ! Note that sec_transport_vars%sec_rt_auxvar(i)%pri_molal(j) units are in mol/kg
810) ! Need to convert to mol/L since the units of total. in the Thomas
811) ! algorithm are in mol/L
812)
813) coeff_left = 0.d0
814) coeff_diag = 0.d0
815) coeff_right = 0.d0
816) res = 0.d0
817) rhs = 0.d0
818) D_M = 0.d0
819) identity = 0.d0
820) b_M = 0.d0
821) inv_D_M = 0.d0
822) total_current_M = 0.d0
823) dPsisec_dCprim = 0.d0
824) dCsec_dCprim = 0.d0
825)
826) total_primary_node = auxvar%total(:,1) ! in mol/L
827) dtotal_prim = auxvar%aqueous%dtotal(:,:,1)
828) pordt = porosity/option%tran_dt
829) pordiff = porosity*diffusion_coefficient
830)
831) call RTAuxVarInit(rt_auxvar,reaction,option)
832) do i = 1, ngcells
833) call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i),option)
834) rt_auxvar%pri_molal = conc_upd(:,i)
835) call RTotal(rt_auxvar,global_auxvar,reaction,option)
836) if (reaction%neqsorb > 0) then
837) call SecondaryRTotalSorb(rt_auxvar,global_auxvar,material_auxvar,reaction,option)
838) endif
839) total_upd(:,i) = rt_auxvar%total(:,1)
840) dtotal(:,:,i) = rt_auxvar%aqueous%dtotal(:,:,1)
841) if (reaction%neqsorb > 0) then
842) total_sorb_upd(:,i) = rt_auxvar%total_sorb_eq(:)
843) dtotal_sorb_upd(:,:,i) = rt_auxvar%dtotal_sorb_eq(:,:)
844) endif
845) enddo
846)
847) !================ Calculate the secondary residual =============================
848)
849) do j = 1, ncomp
850)
851) ! Accumulation
852) do i = 1, ngcells
853) n = j + (i-1)*ncomp
854) res(n) = pordt*(total_upd(j,i) - total_prev(j,i))*vol(i) ! in mol/L*m3/s
855) if (reaction%neqsorb > 0) then
856) res(n) = res(n) + vol(i)/option%tran_dt*(total_sorb_upd(j,i) - total_sorb_prev(j,i))
857) endif
858) enddo
859)
860) ! Flux terms
861) do i = 2, ngcells - 1
862) n = j + (i-1)*ncomp
863) res(n) = res(n) - pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))* &
864) (total_upd(j,i+1) - total_upd(j,i))
865) res(n) = res(n) + pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))* &
866) (total_upd(j,i) - total_upd(j,i-1))
867) enddo
868)
869)
870) ! Apply boundary conditions
871) ! Inner boundary
872) res(j) = res(j) - pordiff*area(1)/(dm_minus(2) + dm_plus(1))* &
873) (total_upd(j,2) - total_upd(j,1))
874)
875) ! Outer boundary
876) res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) - &
877) pordiff*area(ngcells)/dm_plus(ngcells)* &
878) (total_primary_node(j) - total_upd(j,ngcells))
879) res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) + &
880) pordiff*area(ngcells-1)/(dm_minus(ngcells) &
881) + dm_plus(ngcells-1))*(total_upd(j,ngcells) - &
882) total_upd(j,ngcells-1))
883)
884) enddo
885)
886) res = res*1.d3 ! Convert mol/L*m3/s to mol/s
887)
888) !================ Calculate the secondary jacobian =============================
889)
890)
891) do j = 1, ncomp
892) do k = 1, ncomp
893) ! Accumulation
894) do i = 1, ngcells
895) coeff_diag(j,k,i) = coeff_diag(j,k,i) + pordt*vol(i)
896) if (reaction%neqsorb > 0) then
897) coeff_diag(j,k,i) = coeff_diag(j,k,i) + vol(i)/option%tran_dt*(dtotal_sorb_upd(j,k,i))
898) endif
899) enddo
900)
901) ! Flux terms
902) do i = 2, ngcells-1
903) coeff_diag(j,k,i) = coeff_diag(j,k,i) + &
904) pordiff*area(i)/(dm_minus(i+1) + dm_plus(i)) + &
905) pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))
906) coeff_left(j,k,i) = coeff_left(j,k,i) - &
907) pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))
908) coeff_right(j,k,i) = coeff_right(j,k,i) - &
909) pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))
910) enddo
911)
912)
913) ! Apply boundary conditions
914) ! Inner boundary
915) coeff_diag(j,k,1) = coeff_diag(j,k,1) + &
916) pordiff*area(1)/(dm_minus(2) + dm_plus(1))
917)
918) coeff_right(j,k,1) = coeff_right(j,k,1) - &
919) pordiff*area(1)/(dm_minus(2) + dm_plus(1))
920)
921) ! Outer boundary -- closest to primary node
922) coeff_diag(j,k,ngcells) = coeff_diag(j,k,ngcells) + &
923) pordiff*area(ngcells-1)/(dm_minus(ngcells) &
924) + dm_plus(ngcells-1)) + &
925) pordiff*area(ngcells)/dm_plus(ngcells)
926) coeff_left(j,k,ngcells) = coeff_left(j,k,ngcells) - &
927) pordiff*area(ngcells-1)/(dm_minus(ngcells) + &
928) dm_plus(ngcells-1))
929)
930) enddo
931) enddo
932)
933) !============================= Include dtotal ==================================
934)
935) ! Include dtotal (units of kg water/ L water)
936) i = 1
937) do j = 1, ncomp
938) do k = 1, ncomp
939) coeff_diag(j,k,i) = coeff_diag(j,k,i)*dtotal(j,k,i) ! m3/s*kg/L
940) coeff_right(j,k,i) = coeff_right(j,k,i)*dtotal(j,k,i+1)
941) enddo
942) enddo
943) do i = 2, ngcells-1
944) do j = 1, ncomp
945) do k = 1, ncomp
946) coeff_diag(j,k,i) = coeff_diag(j,k,i)*dtotal(j,k,i) ! m3/s*kg/L
947) coeff_left(j,k,i) = coeff_left(j,k,i)*dtotal(j,k,i-1)
948) coeff_right(j,k,i) = coeff_right(j,k,i)*dtotal(j,k,i+1)
949) enddo
950) enddo
951) enddo
952) i = ngcells
953) do j = 1, ncomp
954) do k = 1, ncomp
955) coeff_diag(j,k,i) = coeff_diag(j,k,i)*dtotal(j,k,i) ! m3/s*kg/L
956) coeff_left(j,k,i) = coeff_left(j,k,i)*dtotal(j,k,i-1)
957) enddo
958) enddo
959)
960) ! Sorption
961) do j = 1, ncomp
962) do k = 1, ncomp
963) ! Accumulation
964) do i = 1, ngcells
965) if (reaction%neqsorb > 0) then
966) coeff_diag(j,k,i) = coeff_diag(j,k,i) + vol(i)/option%tran_dt*(dtotal_sorb_upd(j,k,i))
967) endif
968) enddo
969) enddo
970) enddo
971)
972)
973) ! Convert m3/s*kg/L to kg water/s
974) coeff_right = coeff_right*1.d3
975) coeff_left = coeff_left*1.d3
976) coeff_diag = coeff_diag*1.d3
977)
978) !====================== Add reaction contributions =============================
979)
980) ! Reaction
981) allocate(material_auxvar)
982) call MaterialAuxVarInit(material_auxvar,option)
983) do i = 1, ngcells
984) res_react = 0.d0
985) jac_react = 0.d0
986) call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i), &
987) option)
988) rt_auxvar%pri_molal = conc_upd(:,i) ! in mol/kg
989) call RTotal(rt_auxvar,global_auxvar,reaction,option)
990) material_auxvar%porosity = porosity
991) material_auxvar%volume = vol(i)
992) call RReaction(res_react,jac_react,PETSC_TRUE, &
993) rt_auxvar,global_auxvar,material_auxvar,reaction,option)
994) do j = 1, ncomp
995) res(j+(i-1)*ncomp) = res(j+(i-1)*ncomp) + res_react(j)
996) enddo
997) coeff_diag(:,:,i) = coeff_diag(:,:,i) + jac_react ! in kg water/s
998) enddo
999) call MaterialAuxVarStrip(material_auxvar)
1000) deallocate(material_auxvar)
1001)
1002) !============================== Forward solve ==================================
1003)
1004) rhs = -res
1005)
1006) if (reaction%use_log_formulation) then
1007) ! scale the jacobian by concentrations
1008) i = 1
1009) do k = 1, ncomp
1010) coeff_diag(:,k,i) = coeff_diag(:,k,i)*conc_upd(k,i) ! m3/s*kg/L
1011) coeff_right(:,k,i) = coeff_right(:,k,i)*conc_upd(k,i+1)
1012) enddo
1013) do i = 2, ngcells-1
1014) do k = 1, ncomp
1015) coeff_diag(:,k,i) = coeff_diag(:,k,i)*conc_upd(k,i) ! m3/s*kg/L
1016) coeff_left(:,k,i) = coeff_left(:,k,i)*conc_upd(k,i-1)
1017) coeff_right(:,k,i) = coeff_right(:,k,i)*conc_upd(k,i+1)
1018) enddo
1019) enddo
1020) i = ngcells
1021) do k = 1, ncomp
1022) coeff_diag(:,k,i) = coeff_diag(:,k,i)*conc_upd(k,i) ! m3/s*kg/L
1023) coeff_left(:,k,i) = coeff_left(:,k,i)*conc_upd(k,i-1)
1024) enddo
1025) endif
1026)
1027) ! First do an LU decomposition for calculating D_M matrix
1028) coeff_diag_dm = coeff_diag
1029) coeff_left_dm = coeff_left
1030) coeff_right_dm = coeff_right
1031)
1032) select case (option%secondary_continuum_solver)
1033) case(1)
1034) do i = 2, ngcells
1035) coeff_left_dm(:,:,i-1) = coeff_left_dm(:,:,i)
1036) enddo
1037) coeff_left_dm(:,:,ngcells) = 0.d0
1038) call bl3dfac(ngcells,ncomp,coeff_right_dm,coeff_diag_dm,coeff_left_dm,pivot)
1039) case(2)
1040) call decbt(ncomp,ngcells,ncomp,coeff_diag_dm,coeff_right_dm,coeff_left_dm,pivot,ier)
1041) if (ier /= 0) then
1042) print *,'error in matrix decbt: ier = ',ier
1043) stop
1044) endif
1045) case(3)
1046) ! Thomas algorithm for tridiagonal system
1047) ! Forward elimination
1048) if (ncomp /= 1) then
1049) option%io_buffer = 'THOMAS algorithm can be used only with single '// &
1050) 'component chemistry'
1051) call printErrMsg(option)
1052) endif
1053) do i = 2, ngcells
1054) m = coeff_left_dm(ncomp,ncomp,i)/coeff_diag_dm(ncomp,ncomp,i-1)
1055) coeff_diag_dm(ncomp,ncomp,i) = coeff_diag_dm(ncomp,ncomp,i) - &
1056) m*coeff_right_dm(ncomp,ncomp,i-1)
1057) enddo
1058) case default
1059) option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
1060) 'HINDMARSH or KEARST. For single component'// &
1061) 'chemistry THOMAS can be used.'
1062) call printErrMsg(option)
1063) end select
1064)
1065) ! Set the values of D_M matrix and create identity matrix of size ncomp x ncomp
1066) do i = 1, ncomp
1067) do j = 1, ncomp
1068) D_M(i,j) = coeff_diag_dm(i,j,ngcells)
1069) if (j == i) then
1070) identity(i,j) = 1.d0
1071) else
1072) identity(i,j) = 0.d0
1073) endif
1074) enddo
1075) enddo
1076)
1077) ! Find the inverse of D_M
1078) call ludcmp(D_M,ncomp,indx,d)
1079) do j = 1, ncomp
1080) call lubksb(D_M,ncomp,indx,identity(1,j))
1081) enddo
1082) inv_D_M = identity
1083)
1084) if (option%numerical_derivatives_multi_coupling) then
1085) ! Store the coeffs for numerical jacobian
1086) coeff_diag_copy = coeff_diag
1087) coeff_left_copy = coeff_left
1088) coeff_right_copy = coeff_right
1089) endif
1090)
1091) select case (option%secondary_continuum_solver)
1092) case(1)
1093) do i = 2, ngcells
1094) coeff_left(:,:,i-1) = coeff_left(:,:,i)
1095) enddo
1096) coeff_left(:,:,ngcells) = 0.d0
1097) call bl3dfac(ngcells,ncomp,coeff_right,coeff_diag,coeff_left,pivot)
1098) call bl3dsolf(ngcells,ncomp,coeff_right,coeff_diag,coeff_left,pivot, &
1099) ONE_INTEGER,rhs)
1100) case(2)
1101) call decbt(ncomp,ngcells,ncomp,coeff_diag,coeff_right,coeff_left, &
1102) pivot,ier)
1103) if (ier /= 0) then
1104) print *,'error in matrix decbt: ier = ',ier
1105) stop
1106) endif
1107) call solbtf(ncomp,ngcells,ncomp,coeff_diag,coeff_right,coeff_left, &
1108) pivot,rhs)
1109) case(3)
1110) ! Thomas algorithm for tridiagonal system
1111) ! Forward elimination
1112) if (ncomp /= 1) then
1113) option%io_buffer = 'THOMAS algorithm can be used only with single '// &
1114) 'component chemistry'
1115) call printErrMsg(option)
1116) endif
1117) do i = 2, ngcells
1118) m = coeff_left(ncomp,ncomp,i)/coeff_diag(ncomp,ncomp,i-1)
1119) coeff_diag(ncomp,ncomp,i) = coeff_diag(ncomp,ncomp,i) - &
1120) m*coeff_right(ncomp,ncomp,i-1)
1121) rhs(i) = rhs(i) - m*rhs(i-1)
1122) enddo
1123) rhs(ngcells) = rhs(ngcells)/coeff_diag(ncomp,ncomp,ngcells)
1124) case default
1125) option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
1126) 'HINDMARSH or KEARST. For single component'// &
1127) 'chemistry THOMAS can be used.'
1128) call printErrMsg(option)
1129) end select
1130)
1131) ! Update the secondary concentrations
1132) do i = 1, ncomp
1133) if (reaction%use_log_formulation) then
1134) ! convert log concentration to concentration
1135) rhs(i+(ngcells-1)*ncomp) = dsign(1.d0,rhs(i+(ngcells-1)*ncomp))* &
1136) min(dabs(rhs(i+(ngcells-1)*ncomp)),reaction%max_dlnC)
1137) conc_current_M(i) = conc_upd(i,ngcells)*exp(rhs(i+(ngcells-1)*ncomp))
1138) else
1139) conc_current_M(i) = conc_upd(i,ngcells) + rhs(i+(ngcells-1)*ncomp)
1140) endif
1141) enddo
1142)
1143) ! Update the secondary continuum totals at the outer matrix node
1144) call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(ngcells), &
1145) option)
1146) rt_auxvar%pri_molal = conc_current_M ! in mol/kg
1147) call RTotal(rt_auxvar,global_auxvar,reaction,option)
1148) total_current_M = rt_auxvar%total(:,1)
1149) if (reaction%neqcplx > 0) sec_sec_molal_M = rt_auxvar%sec_molal
1150) call RTAuxVarStrip(rt_auxvar)
1151)
1152)
1153) b_m = pordiff/dm_plus(ngcells)*area(ngcells)*inv_D_M ! in m3/kg
1154) b_m = b_m*1.d3 ! in L/kg For log formulation, L/mol
1155)
1156) dCsec_dCprim = b_m*dtotal_prim
1157)
1158) ! Calculate the dervative of outer matrix node total with respect to the
1159) ! primary node concentration
1160)
1161) if (reaction%use_log_formulation) then ! log formulation
1162) do j = 1, ncomp
1163) do l = 1, ncomp
1164) dPsisec_dCprim(j,l) = dCsec_dCprim(j,l)*conc_current_M(j)
1165) enddo
1166) enddo
1167)
1168) if (reaction%neqcplx > 0) then
1169) do icplx = 1, reaction%neqcplx
1170) ncompeq = reaction%eqcplxspecid(0,icplx)
1171) do j = 1, ncompeq
1172) jcomp = reaction%eqcplxspecid(j,icplx)
1173) do l = 1, ncompeq
1174) lcomp = reaction%eqcplxspecid(l,icplx)
1175) do k = 1, ncompeq
1176) kcomp = reaction%eqcplxspecid(k,icplx)
1177) dPsisec_dCprim(jcomp,lcomp) = dPsisec_dCprim(jcomp,lcomp) + &
1178) reaction%eqcplxstoich(j,icplx)* &
1179) reaction%eqcplxstoich(k,icplx)* &
1180) dCsec_dCprim(kcomp,lcomp)* &
1181) sec_sec_molal_M(icplx)
1182) enddo
1183) enddo
1184) enddo
1185) enddo
1186) endif
1187)
1188) else ! linear case
1189)
1190) dPsisec_dCprim = dCsec_dCprim ! dimensionless
1191)
1192) if (reaction%neqcplx > 0) then
1193) do icplx = 1, reaction%neqcplx
1194) ncompeq = reaction%eqcplxspecid(0,icplx)
1195) do j = 1, ncompeq
1196) jcomp = reaction%eqcplxspecid(j,icplx)
1197) do l = 1, ncompeq
1198) lcomp = reaction%eqcplxspecid(l,icplx)
1199) do k = 1, ncompeq
1200) kcomp = reaction%eqcplxspecid(k,icplx)
1201) dPsisec_dCprim(jcomp,lcomp) = dPsisec_dCprim(jcomp,lcomp) + &
1202) reaction%eqcplxstoich(j,icplx)* &
1203) reaction%eqcplxstoich(k,icplx)* &
1204) dCsec_dCprim(kcomp,lcomp)* &
1205) sec_sec_molal_M(icplx)/ &
1206) conc_current_M(kcomp)
1207) enddo
1208) enddo
1209) enddo
1210) enddo
1211) endif
1212)
1213) endif
1214)
1215) dPsisec_dCprim = dPsisec_dCprim*global_auxvar%den_kg(1)*1.d-3 ! in kg/L
1216)
1217) ! Calculate the coupling term
1218) res_transport = pordiff/dm_plus(ngcells)*area_fm* &
1219) (total_current_M - total_primary_node)*prim_vol*1.d3 ! in mol/s
1220)
1221) ! Calculate the jacobian contribution due to coupling term
1222) sec_jac = area_fm*pordiff/dm_plus(ngcells)*(dPsisec_dCprim - dtotal_prim)* &
1223) prim_vol*1.d3 ! in kg water/s
1224)
1225) ! Store the contribution to the primary jacobian term
1226) sec_transport_vars%sec_jac = sec_jac
1227) sec_transport_vars%sec_jac_update = PETSC_TRUE
1228)
1229) ! Store the coefficients from LU decomposition of the block tridiagonal
1230) ! sytem. These will be called later to perform backsolve to the get the
1231) ! updated secondary continuum concentrations at the end of the timestep
1232) sec_transport_vars%cxm = coeff_left
1233) sec_transport_vars%cxp = coeff_right
1234) sec_transport_vars%cdl = coeff_diag
1235)
1236) ! Store the solution of the forward solve
1237) sec_transport_vars%r = rhs
1238)
1239) !============== Numerical jacobian for coupling term ===========================
1240)
1241)
1242) if (option%numerical_derivatives_multi_coupling) then
1243)
1244) call RTAuxVarInit(rt_auxvar,reaction,option)
1245) conc_prim = auxvar%pri_molal
1246) conc_prim_pert = conc_prim
1247)
1248) do l = 1, ncomp
1249)
1250) conc_prim_pert = conc_prim
1251) pert = conc_prim(l)*perturbation_tolerance
1252) conc_prim_pert(l) = conc_prim_pert(l) + pert
1253)
1254) res = 0.d0
1255) rhs = 0.d0
1256)
1257) coeff_diag_pert = coeff_diag_copy
1258) coeff_left_pert = coeff_left_copy
1259) coeff_right_pert = coeff_right_copy
1260)
1261) call RTAuxVarCopy(rt_auxvar,auxvar,option)
1262) rt_auxvar%pri_molal = conc_prim_pert ! in mol/kg
1263) call RTotal(rt_auxvar,global_auxvar,reaction,option)
1264) total_primary_node_pert = rt_auxvar%total(:,1)
1265)
1266) !================ Calculate the secondary residual =============================
1267)
1268) do j = 1, ncomp
1269)
1270) ! Accumulation
1271) do i = 1, ngcells
1272) n = j + (i-1)*ncomp
1273) res(n) = pordt*(total_upd(j,i) - total_prev(j,i))*vol(i) ! in mol/L*m3/s
1274) enddo
1275)
1276) ! Flux terms
1277) do i = 2, ngcells - 1
1278) n = j + (i-1)*ncomp
1279) res(n) = res(n) - pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))* &
1280) (total_upd(j,i+1) - total_upd(j,i))
1281) res(n) = res(n) + pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))* &
1282) (total_upd(j,i) - total_upd(j,i-1))
1283) enddo
1284)
1285)
1286) ! Apply boundary conditions
1287) ! Inner boundary
1288) res(j) = res(j) - pordiff*area(1)/(dm_minus(2) + dm_plus(1))* &
1289) (total_upd(j,2) - total_upd(j,1))
1290)
1291) ! Outer boundary
1292) res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) - &
1293) pordiff*area(ngcells)/dm_plus(ngcells)* &
1294) (total_primary_node_pert(j) - &
1295) total_upd(j,ngcells))
1296) res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) + &
1297) pordiff*area(ngcells-1)/(dm_minus(ngcells) &
1298) + dm_plus(ngcells-1))*(total_upd(j,ngcells) - &
1299) total_upd(j,ngcells-1))
1300)
1301) enddo
1302)
1303) res = res*1.d3 ! Convert mol/L*m3/s to mol/s
1304)
1305) !============================== Forward solve ==================================
1306)
1307) rhs = -res
1308)
1309) select case (option%secondary_continuum_solver)
1310) case(1)
1311) call bl3dfac(ngcells,ncomp,coeff_right_pert,coeff_diag_pert, &
1312) coeff_left_pert,pivot)
1313) call bl3dsolf(ngcells,ncomp,coeff_right_pert,coeff_diag_pert, &
1314) coeff_left_pert,pivot,ONE_INTEGER,rhs)
1315) case(2)
1316) call decbt(ncomp,ngcells,ncomp,coeff_diag_pert,coeff_right_pert, &
1317) coeff_left_pert,pivot,ier)
1318) if (ier /= 0) then
1319) print *,'error in matrix decbt: ier = ',ier
1320) stop
1321) endif
1322) call solbtf(ncomp,ngcells,ncomp,coeff_diag_pert,coeff_right_pert, &
1323) coeff_left_pert,pivot,rhs)
1324) case(3)
1325) ! Thomas algorithm for tridiagonal system
1326) ! Forward elimination
1327) if (ncomp /= 1) then
1328) option%io_buffer = 'THOMAS algorithm can be used only with '// &
1329) 'single component chemistry'
1330) call printErrMsg(option)
1331) endif
1332) do i = 2, ngcells
1333) m = coeff_left_pert(ncomp,ncomp,i)/coeff_diag_pert(ncomp,ncomp,i-1)
1334) coeff_diag_pert(ncomp,ncomp,i) = coeff_diag_pert(ncomp,ncomp,i) - &
1335) m*coeff_right_pert(ncomp,ncomp,i-1)
1336) rhs(i) = rhs(i) - m*rhs(i-1)
1337) enddo
1338) rhs(ngcells) = rhs(ngcells)/coeff_diag(ncomp,ncomp,ngcells)
1339) case default
1340) option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
1341) 'HINDMARSH or KEARST. For single component'// &
1342) 'chemistry THOMAS can be used.'
1343) call printErrMsg(option)
1344) end select
1345)
1346) ! Update the secondary concentrations
1347) do i = 1, ncomp
1348) if (reaction%use_log_formulation) then
1349) ! convert log concentration to concentration
1350) rhs(i+(ngcells-1)*ncomp) = dsign(1.d0,rhs(i+(ngcells-1)*ncomp))* &
1351) min(dabs(rhs(i+(ngcells-1)*ncomp)),reaction%max_dlnC)
1352) conc_current_M_pert(i) = conc_upd(i,ngcells)* &
1353) exp(rhs(i+(ngcells-1)*ncomp))
1354) else
1355) conc_current_M_pert(i) = conc_upd(i,ngcells) + &
1356) rhs(i+(ngcells-1)*ncomp)
1357) endif
1358) enddo
1359)
1360) ! Update the secondary continuum totals at the outer matrix node
1361) call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(ngcells), &
1362) option)
1363) rt_auxvar%pri_molal = conc_current_M_pert ! in mol/kg
1364) call RTotal(rt_auxvar,global_auxvar,reaction,option)
1365) total_current_M_pert = rt_auxvar%total(:,1)
1366)
1367) ! Calculate the coupling term
1368) res_transport_pert = pordiff/dm_plus(ngcells)*area_fm* &
1369) (total_current_M_pert - total_primary_node_pert)* &
1370) prim_vol*1.d3 ! in mol/s
1371)
1372) dtotal_prim_num(:,l) = (total_primary_node_pert(:) - &
1373) total_primary_node(:))/pert
1374)
1375) dPsisec_dCprim_num(:,l) = (total_current_M_pert(:) - &
1376) total_current_M(:))/pert
1377)
1378) sec_jac_num(:,l) = (res_transport_pert(:) - res_transport(:))/pert
1379)
1380) enddo
1381)
1382) call RTAuxVarStrip(rt_auxvar)
1383) sec_transport_vars%sec_jac = sec_jac_num
1384)
1385) endif
1386)
1387)
1388) end subroutine SecondaryRTResJacMulti
1389)
1390) ! ************************************************************************** !
1391)
1392) subroutine SecondaryRTUpdateIterate(line_search,P0,dP,P1,dX_changed, &
1393) X1_changed,realization,ierr)
1394) !
1395) ! Checks update after the update is done
1396) !
1397) ! Author: Satish Karra, LANL
1398) ! Date: 02/22/13
1399) !
1400)
1401) use Realization_Subsurface_class
1402) use Option_module
1403) use Grid_module
1404) use Reaction_Aux_module
1405) use Reactive_Transport_Aux_module
1406) use Global_Aux_module
1407)
1408) implicit none
1409)
1410) SNESLineSearch :: line_search
1411) Vec :: P0
1412) Vec :: dP
1413) Vec :: P1
1414) class(realization_subsurface_type) :: realization
1415) ! ignore changed flag for now.
1416) PetscBool :: dX_changed
1417) PetscBool :: X1_changed
1418)
1419) type(option_type), pointer :: option
1420) type(grid_type), pointer :: grid
1421) type(reactive_transport_auxvar_type), pointer :: rt_auxvars(:)
1422) type(sec_transport_type), pointer :: rt_sec_transport_vars(:)
1423) type(global_auxvar_type), pointer :: global_auxvars(:)
1424) type(reaction_type), pointer :: reaction
1425) PetscInt :: local_id, ghosted_id
1426) PetscReal :: sec_diffusion_coefficient
1427) PetscReal :: sec_porosity
1428) PetscErrorCode :: ierr
1429) PetscReal :: inf_norm_sec
1430) PetscReal :: max_inf_norm_sec
1431)
1432) option => realization%option
1433) grid => realization%patch%grid
1434) rt_auxvars => realization%patch%aux%RT%auxvars
1435) global_auxvars => realization%patch%aux%Global%auxvars
1436) reaction => realization%reaction
1437) if (option%use_mc) then
1438) rt_sec_transport_vars => realization%patch%aux%SC_RT%sec_transport_vars
1439) endif
1440)
1441) dX_changed = PETSC_FALSE
1442) X1_changed = PETSC_FALSE
1443)
1444) max_inf_norm_sec = 0.d0
1445)
1446) if (option%use_mc) then
1447) do local_id = 1, grid%nlmax
1448) ghosted_id = grid%nL2G(local_id)
1449) if (realization%patch%imat(ghosted_id) <= 0) cycle
1450) sec_diffusion_coefficient = realization%patch% &
1451) material_property_array(1)%ptr% &
1452) secondary_continuum_diff_coeff
1453) sec_porosity = realization%patch%material_property_array(1)%ptr% &
1454) secondary_continuum_porosity
1455)
1456) call SecondaryRTAuxVarComputeMulti(&
1457) rt_sec_transport_vars(local_id), &
1458) reaction, &
1459) option)
1460)
1461) call SecondaryRTCheckResidual(rt_sec_transport_vars(local_id), &
1462) rt_auxvars(ghosted_id), &
1463) global_auxvars(ghosted_id), &
1464) reaction,sec_diffusion_coefficient, &
1465) sec_porosity,option,inf_norm_sec)
1466)
1467) max_inf_norm_sec = max(max_inf_norm_sec,inf_norm_sec)
1468) enddo
1469) call MPI_Allreduce(max_inf_norm_sec,option%infnorm_res_sec,ONE_INTEGER_MPI, &
1470) MPI_DOUBLE_PRECISION, &
1471) MPI_MAX,option%mycomm,ierr)
1472) endif
1473)
1474)
1475) end subroutine SecondaryRTUpdateIterate
1476)
1477) ! ************************************************************************** !
1478)
1479) subroutine SecondaryRTUpdateEquilState(sec_transport_vars,global_auxvars, &
1480) reaction,option)
1481) !
1482) ! Updates the equilibrium secondary continuum
1483) ! variables
1484) ! at the end of time step
1485) !
1486) ! Author: Satish Karra, LANL; Glenn Hammond (modification)
1487) ! Date: 02/22/13; 06/27/13
1488) !
1489)
1490)
1491) use Option_module
1492) use Reaction_Aux_module
1493) use Reactive_Transport_Aux_module
1494) use Reaction_module
1495) use Global_Aux_module
1496)
1497) implicit none
1498)
1499)
1500) type(option_type), pointer :: option
1501) type(sec_transport_type) :: sec_transport_vars
1502) type(global_auxvar_type) :: global_auxvars
1503) type(reaction_type), pointer :: reaction
1504) PetscInt :: ngcells,ncomp
1505) PetscInt :: i,j
1506)
1507) ngcells = sec_transport_vars%ncells
1508) ncomp = reaction%naqcomp
1509)
1510) do j = 1, ncomp
1511) do i = 1, ngcells
1512) sec_transport_vars%sec_rt_auxvar(i)%pri_molal(j) = sec_transport_vars%&
1513) updated_conc(j,i)
1514) enddo
1515) enddo
1516)
1517) do i = 1, ngcells
1518) call RTotal(sec_transport_vars%sec_rt_auxvar(i),global_auxvars, &
1519) reaction,option)
1520) enddo
1521)
1522) end subroutine SecondaryRTUpdateEquilState
1523)
1524) ! ************************************************************************** !
1525)
1526) subroutine SecondaryRTUpdateKineticState(sec_transport_vars,global_auxvars, &
1527) reaction,porosity,option)
1528) !
1529) ! Updates the kinetic secondary continuum
1530) ! variables at the end of time step
1531) !
1532) ! Author: Satish Karra, LANL; Glenn Hammond (modification)
1533) ! Date: 02/22/13; 06/27/13
1534) !
1535)
1536)
1537) use Option_module
1538) use Reaction_Aux_module
1539) use Reactive_Transport_Aux_module
1540) use Reaction_module
1541) use Global_Aux_module
1542) use Material_Aux_class
1543)
1544) implicit none
1545)
1546)
1547) type(option_type), pointer :: option
1548) type(sec_transport_type) :: sec_transport_vars
1549) type(global_auxvar_type) :: global_auxvars
1550) type(reaction_type), pointer :: reaction
1551) PetscReal :: porosity
1552) PetscInt :: ngcells
1553) PetscReal :: vol(sec_transport_vars%ncells)
1554) PetscReal :: res_react(reaction%naqcomp)
1555) PetscReal :: jac_react(reaction%naqcomp,reaction%naqcomp)
1556) PetscInt :: i,j
1557) class(material_auxvar_type), allocatable :: material_auxvar
1558)
1559) ngcells = sec_transport_vars%ncells
1560) vol = sec_transport_vars%vol
1561)
1562) res_react = 0.d0
1563) jac_react = 0.d0 ! These are not used anyway
1564) allocate(material_auxvar)
1565) call MaterialAuxVarInit(material_auxvar,option)
1566) do i = 1, ngcells
1567) material_auxvar%porosity = porosity
1568) material_auxvar%volume = vol(i)
1569) call RReaction(res_react,jac_react,PETSC_FALSE, &
1570) sec_transport_vars%sec_rt_auxvar(i), &
1571) global_auxvars,material_auxvar,reaction,option)
1572) enddo
1573) call MaterialAuxVarStrip(material_auxvar)
1574) deallocate(material_auxvar)
1575)
1576) if (reaction%mineral%nkinmnrl > 0) then
1577) do i = 1, ngcells
1578) do j = 1, reaction%mineral%nkinmnrl
1579) sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) = &
1580) sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) + &
1581) sec_transport_vars%sec_rt_auxvar(i)%mnrl_rate(j)* &
1582) reaction%mineral%kinmnrl_molar_vol(j)* &
1583) option%tran_dt
1584) if (sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) < 0.d0) &
1585) sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) = 0.d0
1586) enddo
1587) enddo
1588) endif
1589)
1590)
1591) end subroutine SecondaryRTUpdateKineticState
1592)
1593) ! ************************************************************************** !
1594)
1595) subroutine SecondaryRTCheckResidual(sec_transport_vars,auxvar, &
1596) global_auxvar, &
1597) reaction,diffusion_coefficient, &
1598) porosity,option,inf_norm_sec)
1599) !
1600) ! The residual of the secondary domain are checked
1601) ! to ensure convergence
1602) !
1603) ! Author: Satish Karra, LANL
1604) ! Date: 1/31/13
1605) !
1606)
1607) use Option_module
1608) use Global_Aux_module
1609) use Block_Solve_module
1610) use Block_Tridiag_module
1611) use Utility_module
1612) use Reaction_module
1613) use Reaction_Aux_module
1614) use Reactive_Transport_Aux_module
1615) use Material_Aux_class
1616)
1617) implicit none
1618)
1619) type(sec_transport_type) :: sec_transport_vars
1620) type(reactive_transport_auxvar_type) :: auxvar
1621) type(reactive_transport_auxvar_type) :: rt_auxvar
1622) type(global_auxvar_type) :: global_auxvar
1623) type(reaction_type), pointer :: reaction
1624) type(option_type) :: option
1625)
1626) PetscReal :: res(sec_transport_vars%ncells*reaction%naqcomp)
1627) PetscReal :: conc_upd(reaction%naqcomp,sec_transport_vars%ncells)
1628) PetscReal :: total_upd(reaction%naqcomp,sec_transport_vars%ncells)
1629) PetscReal :: total_prev(reaction%naqcomp,sec_transport_vars%ncells)
1630) PetscReal :: total_primary_node(reaction%naqcomp)
1631) PetscReal :: area(sec_transport_vars%ncells)
1632) PetscReal :: vol(sec_transport_vars%ncells)
1633) PetscReal :: dm_plus(sec_transport_vars%ncells)
1634) PetscReal :: dm_minus(sec_transport_vars%ncells)
1635) PetscReal :: res_react(reaction%naqcomp)
1636) PetscReal :: jac_react(reaction%naqcomp,reaction%naqcomp)
1637) PetscInt :: i, j, k, n
1638) PetscInt :: ngcells, ncomp
1639) PetscReal :: area_fm
1640) PetscReal :: diffusion_coefficient
1641) PetscReal :: porosity
1642) PetscReal :: arrhenius_factor
1643) PetscReal :: pordt, pordiff
1644) PetscReal :: inf_norm_sec
1645) class(material_auxvar_type), allocatable :: material_auxvar
1646)
1647) PetscReal :: total_sorb_upd(reaction%naqcomp,sec_transport_vars%ncells)
1648) PetscReal :: total_sorb_prev(reaction%naqcomp,sec_transport_vars%ncells)
1649)
1650) ngcells = sec_transport_vars%ncells
1651) area = sec_transport_vars%area
1652) vol = sec_transport_vars%vol
1653) dm_plus = sec_transport_vars%dm_plus
1654) dm_minus = sec_transport_vars%dm_minus
1655) area_fm = sec_transport_vars%interfacial_area
1656) ncomp = reaction%naqcomp
1657)
1658) do j = 1, ncomp
1659) do i = 1, ngcells
1660) total_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total(j,1)
1661) if (reaction%neqsorb > 0) then
1662) total_sorb_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total_sorb_eq(j)
1663) endif
1664) enddo
1665) enddo
1666) conc_upd = sec_transport_vars%updated_conc
1667)
1668) ! Note that sec_transport_vars%sec_rt_auxvar(i)%pri_molal(j) units are in mol/kg
1669) ! Need to convert to mol/L since the units of total. in the Thomas
1670) ! algorithm are in mol/L
1671)
1672) res = 0.d0
1673)
1674) total_primary_node = auxvar%total(:,1) ! in mol/L
1675) pordt = porosity/option%tran_dt
1676) pordiff = porosity*diffusion_coefficient
1677)
1678) call RTAuxVarInit(rt_auxvar,reaction,option)
1679) do i = 1, ngcells
1680) call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i),option)
1681) rt_auxvar%pri_molal = conc_upd(:,i)
1682) call RTotal(rt_auxvar,global_auxvar,reaction,option)
1683) if (reaction%neqsorb > 0) then
1684) call SecondaryRTotalSorb(rt_auxvar,global_auxvar,material_auxvar,reaction,option)
1685) endif
1686) total_upd(:,i) = rt_auxvar%total(:,1)
1687) if (reaction%neqsorb > 0) then
1688) total_sorb_upd(:,i) = rt_auxvar%total_sorb_eq(:)
1689) endif
1690) enddo
1691)
1692) !================ Calculate the secondary residual =============================
1693)
1694) do j = 1, ncomp
1695)
1696) ! Accumulation
1697) do i = 1, ngcells
1698) n = j + (i-1)*ncomp
1699) res(n) = pordt*(total_upd(j,i) - total_prev(j,i))*vol(i) ! in mol/L*m3/s
1700) if (reaction%neqsorb > 0) then
1701) res(n) = res(n) + vol(i)/option%tran_dt*(total_sorb_upd(j,i) - total_sorb_prev(j,i))
1702) endif
1703) enddo
1704)
1705) ! Flux terms
1706) do i = 2, ngcells - 1
1707) n = j + (i-1)*ncomp
1708) res(n) = res(n) - pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))* &
1709) (total_upd(j,i+1) - total_upd(j,i))
1710) res(n) = res(n) + pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))* &
1711) (total_upd(j,i) - total_upd(j,i-1))
1712) enddo
1713)
1714)
1715) ! Apply boundary conditions
1716) ! Inner boundary
1717) res(j) = res(j) - pordiff*area(1)/(dm_minus(2) + dm_plus(1))* &
1718) (total_upd(j,2) - total_upd(j,1))
1719)
1720) ! Outer boundary
1721) res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) - &
1722) pordiff*area(ngcells)/dm_plus(ngcells)* &
1723) (total_primary_node(j) - total_upd(j,ngcells))
1724) res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) + &
1725) pordiff*area(ngcells-1)/(dm_minus(ngcells) &
1726) + dm_plus(ngcells-1))*(total_upd(j,ngcells) - &
1727) total_upd(j,ngcells-1))
1728)
1729) enddo
1730)
1731) res = res*1.d3 ! Convert mol/L*m3/s to mol/s
1732)
1733)
1734) !====================== Add reaction contributions =============================
1735)
1736) ! Reaction
1737) allocate(material_auxvar)
1738) call MaterialAuxVarInit(material_auxvar,option)
1739) do i = 1, ngcells
1740) res_react = 0.d0
1741) jac_react = 0.d0
1742) call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i), &
1743) option)
1744) rt_auxvar%pri_molal = conc_upd(:,i) ! in mol/kg
1745) call RTotal(rt_auxvar,global_auxvar,reaction,option)
1746) material_auxvar%porosity = porosity
1747) material_auxvar%volume = vol(i)
1748) call RReaction(res_react,jac_react,PETSC_FALSE, &
1749) rt_auxvar,global_auxvar,material_auxvar,reaction,option)
1750) do j = 1, ncomp
1751) res(j+(i-1)*ncomp) = res(j+(i-1)*ncomp) + res_react(j)
1752) enddo
1753) enddo
1754) call MaterialAuxVarStrip(material_auxvar)
1755) deallocate(material_auxvar)
1756)
1757) ! Need to decide how to scale the residual with volumes
1758) do i = 1, ngcells
1759) do j = 1, ncomp
1760) res(j+(i-1)*ncomp) = res(j+(i-1)*ncomp)/vol(i)
1761) enddo
1762) enddo
1763)
1764) inf_norm_sec = maxval(abs(res))
1765) call RTAuxVarStrip(rt_auxvar)
1766)
1767) end subroutine SecondaryRTCheckResidual
1768)
1769) ! ************************************************************************** !
1770)
1771) subroutine SecondaryRTAuxVarComputeMulti(sec_transport_vars,reaction, &
1772) option)
1773) !
1774) ! Updates the secondary continuum
1775) ! concentrations at end of each time step for multicomponent system
1776) !
1777) ! Author: Satish Karra, LANL
1778) ! Date: 2/1/13
1779) !
1780)
1781)
1782) use Option_module
1783) use Reaction_Aux_module
1784) use Reaction_module
1785) use Reactive_Transport_Aux_module
1786) use Block_Solve_module
1787) use Block_Tridiag_module
1788) use Utility_module
1789)
1790)
1791) implicit none
1792)
1793) type(sec_transport_type) :: sec_transport_vars
1794) type(reaction_type), pointer :: reaction
1795) type(option_type) :: option
1796) PetscReal :: coeff_left(reaction%naqcomp,reaction%naqcomp, &
1797) sec_transport_vars%ncells)
1798) PetscReal :: coeff_diag(reaction%naqcomp,reaction%naqcomp, &
1799) sec_transport_vars%ncells)
1800) PetscReal :: coeff_right(reaction%naqcomp,reaction%naqcomp, &
1801) sec_transport_vars%ncells)
1802) PetscReal :: rhs(sec_transport_vars%ncells*reaction%naqcomp)
1803) PetscReal :: conc_upd(reaction%naqcomp,sec_transport_vars%ncells)
1804) PetscInt :: i, j, n
1805) PetscInt :: ngcells, ncomp
1806) PetscInt :: pivot(reaction%naqcomp,sec_transport_vars%ncells)
1807) PetscInt :: indx(reaction%naqcomp)
1808) PetscInt :: d
1809)
1810) ngcells = sec_transport_vars%ncells
1811) ncomp = reaction%naqcomp
1812) ! Note that sec_transport_vars%sec_conc units are in mol/kg
1813) ! Need to convert to mol/L since the units of conc. in the Thomas
1814) ! algorithm are in mol/L
1815)
1816) coeff_left = 0.d0
1817) coeff_diag = 0.d0
1818) coeff_right = 0.d0
1819) rhs = 0.d0
1820)
1821) conc_upd = sec_transport_vars%updated_conc
1822)
1823) ! Use the stored coefficient matrices from LU decomposition of the
1824) ! block triagonal sytem
1825) coeff_left = sec_transport_vars%cxm
1826) coeff_right = sec_transport_vars%cxp
1827) coeff_diag = sec_transport_vars%cdl
1828) rhs = sec_transport_vars%r
1829)
1830) select case (option%secondary_continuum_solver)
1831) case(1)
1832) call bl3dsolb(ngcells,ncomp,coeff_right,coeff_diag,coeff_left,pivot, &
1833) ONE_INTEGER,rhs)
1834) case(2)
1835) call solbtb(ncomp,ngcells,ncomp,coeff_diag,coeff_right,coeff_left, &
1836) pivot,rhs)
1837) case(3)
1838) do i = ngcells-1, 1, -1
1839) rhs(i) = (rhs(i) - coeff_right(ncomp,ncomp,i)*rhs(i+1))/ &
1840) coeff_diag(ncomp,ncomp,i)
1841) enddo
1842) case default
1843) option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
1844) 'HINDMARSH or KEARST. For single component'// &
1845) 'chemistry THOMAS can be used.'
1846) call printErrMsg(option)
1847) end select
1848)
1849) do j = 1, ncomp
1850) do i = 1, ngcells
1851) n = j + (i - 1)*ncomp
1852) if (reaction%use_log_formulation) then
1853) ! convert log concentration to concentration
1854) rhs(n) = dsign(1.d0,rhs(n))*min(dabs(rhs(n)),reaction%max_dlnC)
1855) conc_upd(j,i) = exp(rhs(n))*conc_upd(j,i)
1856) else
1857) conc_upd(j,i) = rhs(n) + conc_upd(j,i)
1858) endif
1859) if (conc_upd(j,i) < 0.d0) conc_upd(j,i) = 1.d-8
1860) enddo
1861) enddo
1862)
1863) sec_transport_vars%updated_conc = conc_upd
1864)
1865) end subroutine SecondaryRTAuxVarComputeMulti
1866)
1867) ! ************************************************************************** !
1868)
1869) subroutine THCSecHeatAuxVarCompute(sec_heat_vars,global_auxvar, &
1870) therm_conductivity,dencpr, &
1871) option)
1872) !
1873) ! Computes secondary auxillary variables for each
1874) ! grid cell for heat transfer only
1875) !
1876) ! Author: Satish Karra, LANL
1877) ! Date: 06/5/12
1878) !
1879)
1880) use Option_module
1881) use Global_Aux_module
1882)
1883) implicit none
1884)
1885) type(sec_heat_type) :: sec_heat_vars
1886) type(global_auxvar_type) :: global_auxvar
1887) type(option_type) :: option
1888) PetscReal :: coeff_left(sec_heat_vars%ncells)
1889) PetscReal :: coeff_diag(sec_heat_vars%ncells)
1890) PetscReal :: coeff_right(sec_heat_vars%ncells)
1891) PetscReal :: rhs(sec_heat_vars%ncells)
1892) PetscReal :: sec_temp(sec_heat_vars%ncells)
1893) PetscReal :: area(sec_heat_vars%ncells)
1894) PetscReal :: vol(sec_heat_vars%ncells)
1895) PetscReal :: dm_plus(sec_heat_vars%ncells)
1896) PetscReal :: dm_minus(sec_heat_vars%ncells)
1897) PetscInt :: i, ngcells
1898) PetscReal :: area_fm
1899) PetscReal :: alpha, therm_conductivity, dencpr
1900) PetscReal :: temp_primary_node
1901) PetscReal :: m
1902)
1903) ngcells = sec_heat_vars%ncells
1904) area = sec_heat_vars%area
1905) vol = sec_heat_vars%vol
1906) dm_plus = sec_heat_vars%dm_plus
1907) dm_minus = sec_heat_vars%dm_minus
1908) area_fm = sec_heat_vars%interfacial_area
1909) temp_primary_node = global_auxvar%temp
1910)
1911) coeff_left = 0.d0
1912) coeff_diag = 0.d0
1913) coeff_right = 0.d0
1914) rhs = 0.d0
1915) sec_temp = 0.d0
1916)
1917) alpha = option%flow_dt*therm_conductivity/dencpr
1918)
1919)
1920) ! Setting the coefficients
1921) do i = 2, ngcells-1
1922) coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
1923) coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
1924) alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
1925) coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
1926) enddo
1927)
1928) coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
1929) coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
1930)
1931) coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
1932) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
1933) coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
1934) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
1935) + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
1936) + 1.d0
1937)
1938)
1939) rhs = sec_heat_vars%sec_temp ! secondary continuum values from previous time step
1940) rhs(ngcells) = rhs(ngcells) + &
1941) alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
1942) temp_primary_node
1943)
1944) ! Thomas algorithm for tridiagonal system
1945) ! Forward elimination
1946) do i = 2, ngcells
1947) m = coeff_left(i)/coeff_diag(i-1)
1948) coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
1949) rhs(i) = rhs(i) - m*rhs(i-1)
1950) enddo
1951)
1952) ! Back substitution
1953) ! Calculate temperature in the secondary continuum
1954) sec_temp(ngcells) = rhs(ngcells)/coeff_diag(ngcells)
1955) do i = ngcells-1, 1, -1
1956) sec_temp(i) = (rhs(i) - coeff_right(i)*sec_temp(i+1))/coeff_diag(i)
1957) enddo
1958)
1959) sec_heat_vars%sec_temp = sec_temp
1960)
1961) end subroutine THCSecHeatAuxVarCompute
1962)
1963) ! ************************************************************************** !
1964)
1965) subroutine THSecHeatAuxVarCompute(sec_heat_vars,global_auxvar, &
1966) therm_conductivity,dencpr, &
1967) option)
1968) !
1969) ! Computes secondary auxillary variables for each
1970) ! grid cell for heat transfer only
1971) !
1972) ! Author: Satish Karra, LANL
1973) ! Date: 06/5/12
1974) !
1975)
1976) use Option_module
1977) use Global_Aux_module
1978)
1979) implicit none
1980)
1981) type(sec_heat_type) :: sec_heat_vars
1982) type(global_auxvar_type) :: global_auxvar
1983) type(option_type) :: option
1984) PetscReal :: coeff_left(sec_heat_vars%ncells)
1985) PetscReal :: coeff_diag(sec_heat_vars%ncells)
1986) PetscReal :: coeff_right(sec_heat_vars%ncells)
1987) PetscReal :: rhs(sec_heat_vars%ncells)
1988) PetscReal :: sec_temp(sec_heat_vars%ncells)
1989) PetscReal :: area(sec_heat_vars%ncells)
1990) PetscReal :: vol(sec_heat_vars%ncells)
1991) PetscReal :: dm_plus(sec_heat_vars%ncells)
1992) PetscReal :: dm_minus(sec_heat_vars%ncells)
1993) PetscInt :: i, ngcells
1994) PetscReal :: area_fm
1995) PetscReal :: alpha, therm_conductivity, dencpr
1996) PetscReal :: temp_primary_node
1997) PetscReal :: m
1998)
1999) ngcells = sec_heat_vars%ncells
2000) area = sec_heat_vars%area
2001) vol = sec_heat_vars%vol
2002) dm_plus = sec_heat_vars%dm_plus
2003) dm_minus = sec_heat_vars%dm_minus
2004) area_fm = sec_heat_vars%interfacial_area
2005) temp_primary_node = global_auxvar%temp
2006)
2007) coeff_left = 0.d0
2008) coeff_diag = 0.d0
2009) coeff_right = 0.d0
2010) rhs = 0.d0
2011) sec_temp = 0.d0
2012)
2013) alpha = option%flow_dt*therm_conductivity/dencpr
2014)
2015)
2016) ! Setting the coefficients
2017) do i = 2, ngcells-1
2018) coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
2019) coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
2020) alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
2021) coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
2022) enddo
2023)
2024) coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
2025) coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
2026)
2027) coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
2028) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
2029) coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
2030) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
2031) + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
2032) + 1.d0
2033)
2034)
2035) rhs = sec_heat_vars%sec_temp ! secondary continuum values from previous time step
2036) rhs(ngcells) = rhs(ngcells) + &
2037) alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
2038) temp_primary_node
2039)
2040) ! Thomas algorithm for tridiagonal system
2041) ! Forward elimination
2042) do i = 2, ngcells
2043) m = coeff_left(i)/coeff_diag(i-1)
2044) coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
2045) rhs(i) = rhs(i) - m*rhs(i-1)
2046) enddo
2047)
2048) ! Back substitution
2049) ! Calculate temperature in the secondary continuum
2050) sec_temp(ngcells) = rhs(ngcells)/coeff_diag(ngcells)
2051) do i = ngcells-1, 1, -1
2052) sec_temp(i) = (rhs(i) - coeff_right(i)*sec_temp(i+1))/coeff_diag(i)
2053) enddo
2054)
2055) sec_heat_vars%sec_temp = sec_temp
2056)
2057) end subroutine THSecHeatAuxVarCompute
2058)
2059) ! ************************************************************************** !
2060)
2061) subroutine MphaseSecHeatAuxVarCompute(sec_heat_vars,auxvar,global_auxvar, &
2062) therm_conductivity,dencpr, &
2063) option)
2064) !
2065) ! Computes secondary auxillary variables in each
2066) ! grid cell for heat transfer only
2067) !
2068) ! Author: Satish Karra, LANL
2069) ! Date: 06/28/12
2070) !
2071)
2072) use Option_module
2073) use Global_Aux_module
2074) use Mphase_Aux_module
2075)
2076) implicit none
2077)
2078) type(sec_heat_type) :: sec_heat_vars
2079) type(mphase_auxvar_elem_type) :: auxvar
2080) type(global_auxvar_type) :: global_auxvar
2081) type(option_type) :: option
2082) PetscReal :: coeff_left(sec_heat_vars%ncells)
2083) PetscReal :: coeff_diag(sec_heat_vars%ncells)
2084) PetscReal :: coeff_right(sec_heat_vars%ncells)
2085) PetscReal :: rhs(sec_heat_vars%ncells)
2086) PetscReal :: sec_temp(sec_heat_vars%ncells)
2087) PetscReal :: area(sec_heat_vars%ncells)
2088) PetscReal :: vol(sec_heat_vars%ncells)
2089) PetscReal :: dm_plus(sec_heat_vars%ncells)
2090) PetscReal :: dm_minus(sec_heat_vars%ncells)
2091) PetscInt :: i, ngcells
2092) PetscReal :: area_fm
2093) PetscReal :: alpha, therm_conductivity, dencpr
2094) PetscReal :: temp_primary_node
2095) PetscReal :: m
2096)
2097)
2098) ngcells = sec_heat_vars%ncells
2099) area = sec_heat_vars%area
2100) vol = sec_heat_vars%vol
2101) dm_plus = sec_heat_vars%dm_plus
2102) dm_minus = sec_heat_vars%dm_minus
2103) area_fm = sec_heat_vars%interfacial_area
2104) temp_primary_node = auxvar%temp
2105)
2106)
2107) coeff_left = 0.d0
2108) coeff_diag = 0.d0
2109) coeff_right = 0.d0
2110) rhs = 0.d0
2111) sec_temp = 0.d0
2112)
2113) alpha = option%flow_dt*therm_conductivity/dencpr
2114)
2115)
2116) ! Setting the coefficients
2117) do i = 2, ngcells-1
2118) coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
2119) coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
2120) alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
2121) coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
2122) enddo
2123)
2124) coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
2125) coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
2126)
2127) coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
2128) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
2129) coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
2130) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
2131) + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
2132) + 1.d0
2133)
2134) rhs = sec_heat_vars%sec_temp ! secondary continuum values from previous time step
2135) rhs(ngcells) = rhs(ngcells) + &
2136) alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
2137) temp_primary_node
2138)
2139) ! Thomas algorithm for tridiagonal system
2140) ! Forward elimination
2141) do i = 2, ngcells
2142) m = coeff_left(i)/coeff_diag(i-1)
2143) coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
2144) rhs(i) = rhs(i) - m*rhs(i-1)
2145) enddo
2146)
2147) ! Back substitution
2148) ! Calculate temperature in the secondary continuum
2149) sec_temp(ngcells) = rhs(ngcells)/coeff_diag(ngcells)
2150) do i = ngcells-1, 1, -1
2151) sec_temp(i) = (rhs(i) - coeff_right(i)*sec_temp(i+1))/coeff_diag(i)
2152) enddo
2153)
2154) ! print *,'temp_dcdm= ',(sec_temp(i),i=1,ngcells)
2155)
2156) sec_heat_vars%sec_temp = sec_temp
2157)
2158)
2159) end subroutine MphaseSecHeatAuxVarCompute
2160)
2161) ! ************************************************************************** !
2162)
2163) subroutine SecondaryRTotalSorb(rt_auxvar,global_auxvar,material_auxvar,reaction, &
2164) option)
2165) !
2166) ! Computes the secondary total sorbed component concentrations and
2167) ! derivative with respect to free-ion
2168) !
2169) ! Author: Satish Karra, LANL
2170) ! Date: 02/20/2014
2171) !
2172)
2173) use Option_module
2174) use Global_Aux_module
2175) use Reaction_Aux_module
2176) use Reaction_module
2177) use Reactive_Transport_Aux_module
2178) use Material_Aux_class
2179)
2180) implicit none
2181)
2182) type(reactive_transport_auxvar_type) :: rt_auxvar
2183) type(global_auxvar_type) :: global_auxvar
2184) class(material_auxvar_type) :: material_auxvar
2185) type(reaction_type) :: reaction
2186) type(option_type) :: option
2187)
2188) call RZeroSorb(rt_auxvar)
2189)
2190) if (reaction%neqkdrxn > 0) then
2191) call SecondaryRTotalSorbKD(rt_auxvar,global_auxvar,material_auxvar, &
2192) reaction,option)
2193) endif
2194)
2195) end subroutine SecondaryRTotalSorb
2196)
2197) ! ************************************************************************** !
2198)
2199) subroutine SecondaryRTotalSorbKD(rt_auxvar,global_auxvar,material_auxvar,reaction, &
2200) option)
2201) !
2202) ! Computes the total sorbed component concentrations and
2203) ! derivative with respect to free-ion for the linear
2204) ! K_D model
2205) !
2206) ! Author: Satish Karra, LANL
2207) ! Date: 02/20/2014
2208) !
2209)
2210) use Option_module
2211) use Reaction_Aux_module
2212) use Reaction_module
2213) use Reactive_Transport_Aux_module
2214) use Material_Aux_class
2215) use Global_Aux_module
2216)
2217) implicit none
2218)
2219) type(reactive_transport_auxvar_type) :: rt_auxvar
2220) type(global_auxvar_type) :: global_auxvar
2221) class(material_auxvar_type) :: material_auxvar
2222) type(reaction_type) :: reaction
2223) type(option_type) :: option
2224)
2225) PetscInt :: irxn
2226) PetscInt :: icomp
2227) PetscReal :: res
2228) PetscReal :: dres_dc
2229) PetscReal :: activity
2230) PetscReal :: molality
2231) PetscReal :: tempreal
2232) PetscReal :: one_over_n
2233) PetscReal :: activity_one_over_n
2234)
2235) ! Surface Complexation
2236) do irxn = 1, reaction%neqkdrxn
2237) icomp = reaction%eqkdspecid(irxn)
2238) molality = rt_auxvar%pri_molal(icomp)
2239) activity = molality*rt_auxvar%pri_act_coef(icomp) ! Activity coefficient needs?
2240) select case(reaction%sec_cont_eqkdtype(irxn))
2241) case(SORPTION_LINEAR)
2242) ! Csorb = Kd*Caq
2243) res = reaction%sec_cont_eqkddistcoef(irxn)*activity
2244) dres_dc = res/molality
2245) case(SORPTION_LANGMUIR)
2246) ! Csorb = K*Caq*b/(1+K*Caq)
2247) tempreal = reaction%sec_cont_eqkddistcoef(irxn)*activity
2248) res = tempreal*reaction%sec_cont_eqkdlangmuirb(irxn) / (1.d0 + tempreal)
2249) dres_dc = res/molality - &
2250) res / (1.d0 + tempreal) * tempreal / molality
2251) case(SORPTION_FREUNDLICH)
2252) ! Csorb = Kd*Caq**(1/n)
2253) one_over_n = 1.d0/reaction%sec_cont_eqkdfreundlichn(irxn)
2254) activity_one_over_n = activity**one_over_n
2255) res = reaction%sec_cont_eqkddistcoef(irxn)* &
2256) activity**one_over_n
2257) dres_dc = res/molality*one_over_n
2258) case default
2259) res = 0.d0
2260) dres_dc = 0.d0
2261) end select
2262) rt_auxvar%total_sorb_eq(icomp) = rt_auxvar%total_sorb_eq(icomp) + res
2263) rt_auxvar%dtotal_sorb_eq(icomp,icomp) = &
2264) rt_auxvar%dtotal_sorb_eq(icomp,icomp) + dres_dc
2265) enddo
2266)
2267) end subroutine SecondaryRTotalSorbKD
2268)
2269)
2270) end module Secondary_Continuum_module
2271)