th.F90 coverage: 82.05 %func 56.55 %block
1) module TH_module
2)
3) use TH_Aux_module
4) use Global_Aux_module
5) use Material_Aux_class
6) use PFLOTRAN_Constants_module
7)
8) implicit none
9)
10) private
11)
12) #include "petsc/finclude/petscsys.h"
13)
14) #include "petsc/finclude/petscvec.h"
15) #include "petsc/finclude/petscvec.h90"
16) #include "petsc/finclude/petscmat.h"
17) #include "petsc/finclude/petscmat.h90"
18) #include "petsc/finclude/petscsnes.h"
19) #include "petsc/finclude/petscviewer.h"
20) #include "petsc/finclude/petsclog.h"
21)
22) ! Cutoff parameters
23) PetscReal, parameter :: eps = 1.D-8
24) PetscReal, parameter :: floweps = 1.D-24
25) PetscReal, parameter :: perturbation_tolerance = 1.d-8
26) PetscReal, parameter :: unit_z(3) = [0.d0,0.d0,1.d0]
27)
28) public THResidual,THJacobian, &
29) THUpdateFixedAccumulation,THTimeCut,&
30) THSetup, THNumericalJacobianTest, &
31) THMaxChange, THUpdateSolution, &
32) THGetTecplotHeader, THInitializeTimestep, &
33) THComputeMassBalance, THResidualToMass, &
34) THSecondaryHeat, THSecondaryHeatJacobian, &
35) THUpdateAuxVars, THDestroy, &
36) THUpdateSurfaceBC, THAccumulation
37)
38) PetscInt, parameter :: jh2o = 1
39)
40) contains
41)
42) ! ************************************************************************** !
43)
44) subroutine THTimeCut(realization)
45) !
46) ! Resets arrays for time step cut
47) !
48) ! Author: ???
49) ! Date: 12/13/07
50) !
51)
52) use Realization_Subsurface_class
53) use Option_module
54) use Field_module
55)
56) implicit none
57)
58) type(realization_subsurface_type) :: realization
59) type(option_type), pointer :: option
60) type(field_type), pointer :: field
61)
62) PetscErrorCode :: ierr
63)
64) option => realization%option
65) field => realization%field
66)
67) call THInitializeTimestep(realization)
68)
69) end subroutine THTimeCut
70)
71) ! ************************************************************************** !
72)
73) subroutine THSetup(realization)
74) !
75) ! Author: ???
76) ! Date: 02/22/08
77) !
78)
79) use Realization_Subsurface_class
80) use Patch_module
81) use Output_Aux_module
82)
83) type(realization_subsurface_type) :: realization
84)
85) type(patch_type), pointer :: cur_patch
86) type(output_variable_list_type), pointer :: list
87)
88) cur_patch => realization%patch_list%first
89) do
90) if (.not.associated(cur_patch)) exit
91) realization%patch => cur_patch
92) call THSetupPatch(realization)
93) cur_patch => cur_patch%next
94) enddo
95)
96) list => realization%output_option%output_snap_variable_list
97) call THSetPlotVariables(realization,list)
98) list => realization%output_option%output_obs_variable_list
99) call THSetPlotVariables(realization,list)
100)
101) end subroutine THSetup
102)
103) ! ************************************************************************** !
104)
105) subroutine THSetupPatch(realization)
106) !
107) ! Creates arrays for auxiliary variables
108) !
109) ! Author: ???
110) ! Date: 02/22/08
111) !
112)
113) use Realization_Subsurface_class
114) use Patch_module
115) use Option_module
116) use Grid_module
117) use Region_module
118) use Coupler_module
119) use Connection_module
120) use Fluid_module
121) use Secondary_Continuum_Aux_module
122) use Secondary_Continuum_module
123)
124) implicit none
125)
126) type(realization_subsurface_type) :: realization
127)
128) type(option_type), pointer :: option
129) type(patch_type), pointer :: patch
130) type(grid_type), pointer :: grid
131) type(coupler_type), pointer :: boundary_condition
132) type(TH_auxvar_type), pointer :: TH_auxvars(:), TH_auxvars_bc(:)
133) type(TH_auxvar_type), pointer :: TH_auxvars_ss(:)
134) type(fluid_property_type), pointer :: cur_fluid_property
135) type(sec_heat_type), pointer :: TH_sec_heat_vars(:)
136) type(coupler_type), pointer :: initial_condition
137) character(len=MAXWORDLENGTH) :: word
138) PetscReal :: area_per_vol
139)
140) PetscInt :: ghosted_id, iconn, sum_connection
141) PetscInt :: i, iphase, local_id, material_id
142) PetscBool :: error_found
143)
144) option => realization%option
145) patch => realization%patch
146) grid => patch%grid
147)
148) patch%aux%TH => THAuxCreate(option)
149) patch%aux%SC_heat => SecondaryAuxHeatCreate(option)
150)
151) ! option%io_buffer = 'Before TH can be run, the TH_parameter object ' // &
152) ! 'must be initialized with the proper variables ' // &
153) ! 'THAuxCreate() is called anywhere.'
154) ! call printErrMsg(option)
155) allocate(patch%aux%TH%TH_parameter%sir(option%nphase, &
156) size(patch%saturation_function_array)))
157)
158) !Jitu, 08/04/2010: Check these allocations. Currently assumes only single value in the array <modified pcl 1-13-11>
159) allocate(patch%aux%TH%TH_parameter%dencpr(size(patch%material_property_array)))
160) allocate(patch%aux%TH%TH_parameter%ckwet(size(patch%material_property_array)))
161) allocate(patch%aux%TH%TH_parameter%ckdry(size(patch%material_property_array)))
162) allocate(patch%aux%TH%TH_parameter%alpha(size(patch%material_property_array)))
163) if (option%use_th_freezing) then
164) allocate(patch%aux%TH%TH_parameter%ckfrozen(size(patch%material_property_array)))
165) allocate(patch%aux%TH%TH_parameter%alpha_fr(size(patch%material_property_array)))
166) endif
167)
168) !Copy the values in the TH_parameter from the global realization
169) error_found = PETSC_FALSE
170) do i = 1, size(patch%material_property_array)
171) word = patch%material_property_array(i)%ptr%name
172) if (Uninitialized(patch%material_property_array(i)%ptr%specific_heat)) then
173) option%io_buffer = 'Non-initialized HEAT_CAPACITY in material ' // &
174) trim(word)
175) call printMsg(option)
176) error_found = PETSC_TRUE
177) endif
178) if (Uninitialized(patch%material_property_array(i)%ptr% &
179) thermal_conductivity_wet)) then
180) option%io_buffer = 'Non-initialized THERMAL_CONDUCTIVITY_WET in &
181) &material ' // &
182) trim(word)
183) call printMsg(option)
184) error_found = PETSC_TRUE
185) endif
186) if (Uninitialized(patch%material_property_array(i)%ptr% &
187) thermal_conductivity_dry)) then
188) option%io_buffer = 'Non-initialized THERMAL_CONDUCTIVITY_DRY in &
189) &material ' // &
190) trim(word)
191) call printMsg(option)
192) error_found = PETSC_TRUE
193) endif
194) if (option%use_th_freezing) then
195) if (Uninitialized(patch%material_property_array(i)%ptr% &
196) thermal_conductivity_frozen)) then
197) option%io_buffer = 'Non-initialized THERMAL_CONDUCTIVITY_FROZEN in &
198) &material ' // &
199) trim(word)
200) call printMsg(option)
201) error_found = PETSC_TRUE
202) endif
203) if (Uninitialized(patch%material_property_array(i)%ptr% &
204) alpha_fr)) then
205) option%io_buffer = 'Non-initialized THERMAL_COND_EXPONENT_FROZEN in &
206) &material ' // &
207) trim(word)
208) call printMsg(option)
209) error_found = PETSC_TRUE
210) endif
211) endif
212) material_id = iabs(patch%material_property_array(i)%ptr%internal_id)
213) ! kg rock/m^3 rock * J/kg rock-K * 1.e-6 MJ/J = MJ/m^3-K
214) patch%aux%TH%TH_parameter%dencpr(material_id) = &
215) patch%material_property_array(i)%ptr%rock_density*option%scale* &
216) patch%material_property_array(i)%ptr%specific_heat
217) patch%aux%TH%TH_parameter%ckwet(material_id) = &
218) patch%material_property_array(i)%ptr%thermal_conductivity_wet* &
219) option%scale
220) patch%aux%TH%TH_parameter%ckdry(material_id) = &
221) patch%material_property_array(i)%ptr%thermal_conductivity_dry* &
222) option%scale
223) patch%aux%TH%TH_parameter%alpha(material_id) = &
224) patch%material_property_array(i)%ptr%alpha
225) if (option%use_th_freezing) then
226) patch%aux%TH%TH_parameter%ckfrozen(material_id) = &
227) patch%material_property_array(i)%ptr%thermal_conductivity_frozen* &
228) option%scale
229) patch%aux%TH%TH_parameter%alpha_fr(material_id) = &
230) patch%material_property_array(i)%ptr%alpha_fr
231) endif
232)
233) enddo
234)
235) if (error_found) then
236) option%io_buffer = 'Material property errors found in THSetup.'
237) call printErrMsg(option)
238) endif
239)
240) do i = 1, size(patch%saturation_function_array)
241) patch%aux%TH%TH_parameter%sir(:,patch%saturation_function_array(i)%ptr%id) = &
242) patch%saturation_function_array(i)%ptr%Sr(:)
243) enddo
244)
245) ! allocate auxvar data structures for all grid cells
246) allocate(TH_auxvars(grid%ngmax))
247) do ghosted_id = 1, grid%ngmax
248) call THAuxVarInit(TH_auxvars(ghosted_id),option)
249) enddo
250)
251)
252) if (option%use_mc) then
253) initial_condition => patch%initial_condition_list%first
254) allocate(TH_sec_heat_vars(grid%nlmax))
255)
256) do local_id = 1, grid%nlmax
257)
258) ! Assuming the same secondary continuum for all regions (need to make it an array)
259) ! S. Karra 07/18/12
260) call SecondaryContinuumSetProperties( &
261) TH_sec_heat_vars(local_id)%sec_continuum, &
262) patch%material_property_array(1)%ptr%secondary_continuum_name, &
263) patch%material_property_array(1)%ptr%secondary_continuum_length, &
264) patch%material_property_array(1)%ptr%secondary_continuum_matrix_block_size, &
265) patch%material_property_array(1)%ptr%secondary_continuum_fracture_spacing, &
266) patch%material_property_array(1)%ptr%secondary_continuum_radius, &
267) patch%material_property_array(1)%ptr%secondary_continuum_area, &
268) option)
269)
270) TH_sec_heat_vars(local_id)%ncells = &
271) patch%material_property_array(1)%ptr%secondary_continuum_ncells
272) TH_sec_heat_vars(local_id)%aperture = &
273) patch%material_property_array(1)%ptr%secondary_continuum_aperture
274) TH_sec_heat_vars(local_id)%epsilon = &
275) patch%material_property_array(1)%ptr%secondary_continuum_epsilon
276) TH_sec_heat_vars(local_id)%log_spacing = &
277) patch%material_property_array(1)%ptr%secondary_continuum_log_spacing
278) TH_sec_heat_vars(local_id)%outer_spacing = &
279) patch%material_property_array(1)%ptr%secondary_continuum_outer_spacing
280)
281) allocate(TH_sec_heat_vars(local_id)%area(TH_sec_heat_vars(local_id)%ncells))
282) allocate(TH_sec_heat_vars(local_id)%vol(TH_sec_heat_vars(local_id)%ncells))
283) allocate(TH_sec_heat_vars(local_id)%dm_minus(TH_sec_heat_vars(local_id)%ncells))
284) allocate(TH_sec_heat_vars(local_id)%dm_plus(TH_sec_heat_vars(local_id)%ncells))
285) allocate(TH_sec_heat_vars(local_id)%sec_continuum% &
286) distance(TH_sec_heat_vars(local_id)%ncells))
287)
288) call SecondaryContinuumType(TH_sec_heat_vars(local_id)%sec_continuum, &
289) TH_sec_heat_vars(local_id)%ncells, &
290) TH_sec_heat_vars(local_id)%area, &
291) TH_sec_heat_vars(local_id)%vol, &
292) TH_sec_heat_vars(local_id)%dm_minus, &
293) TH_sec_heat_vars(local_id)%dm_plus, &
294) TH_sec_heat_vars(local_id)%aperture, &
295) TH_sec_heat_vars(local_id)%epsilon, &
296) TH_sec_heat_vars(local_id)%log_spacing, &
297) TH_sec_heat_vars(local_id)%outer_spacing, &
298) area_per_vol,option)
299)
300) TH_sec_heat_vars(local_id)%interfacial_area = area_per_vol* &
301) (1.d0 - TH_sec_heat_vars(local_id)%epsilon)* &
302) patch%material_property_array(1)%ptr% &
303) secondary_continuum_area_scaling
304)
305) ! Setting the initial values of all secondary node temperatures same as primary node
306) ! temperatures (with initial dirichlet BC only) -- sk 06/26/12
307) allocate(TH_sec_heat_vars(local_id)%sec_temp(TH_sec_heat_vars(local_id)%ncells))
308)
309) if (option%set_secondary_init_temp) then
310) TH_sec_heat_vars(local_id)%sec_temp = &
311) patch%material_property_array(1)%ptr%secondary_continuum_init_temp
312) else
313) TH_sec_heat_vars(local_id)%sec_temp = &
314) initial_condition%flow_condition%temperature%dataset%rarray(1)
315) endif
316)
317) enddo
318)
319) patch%aux%SC_heat%sec_heat_vars => TH_sec_heat_vars
320)
321) endif
322)
323)
324) patch%aux%TH%auxvars => TH_auxvars
325) patch%aux%TH%num_aux = grid%ngmax
326)
327) ! count the number of boundary connections and allocate
328) ! auxvar data structures for them
329) boundary_condition => patch%boundary_condition_list%first
330)
331) sum_connection = 0
332) do
333) if (.not.associated(boundary_condition)) exit
334) sum_connection = sum_connection + &
335) boundary_condition%connection_set%num_connections
336) boundary_condition => boundary_condition%next
337) enddo
338)
339) if (sum_connection > 0) then
340) allocate(TH_auxvars_bc(sum_connection))
341) do iconn = 1, sum_connection
342) call THAuxVarInit(TH_auxvars_bc(iconn),option)
343) enddo
344) patch%aux%TH%auxvars_bc => TH_auxvars_bc
345) endif
346) patch%aux%TH%num_aux_bc = sum_connection
347)
348) ! Create aux vars for source/sink
349) sum_connection = CouplerGetNumConnectionsInList(patch%source_sink_list)
350) if (sum_connection > 0) then
351) allocate(TH_auxvars_ss(sum_connection))
352) do iconn = 1, sum_connection
353) call THAuxVarInit(TH_auxvars_ss(iconn),option)
354) enddo
355) patch%aux%TH%auxvars_ss => TH_auxvars_ss
356) endif
357) patch%aux%TH%num_aux_ss = sum_connection
358)
359) ! initialize parameters
360) cur_fluid_property => realization%fluid_properties
361) do
362) if (.not.associated(cur_fluid_property)) exit
363) iphase = cur_fluid_property%phase_id
364) cur_fluid_property => cur_fluid_property%next
365) enddo
366)
367) end subroutine THSetupPatch
368)
369) ! ************************************************************************** !
370)
371) subroutine THComputeMassBalance(realization, mass_balance)
372) !
373) ! THomputeMassBalance:
374) ! Adapted from RichardsComputeMassBalance: need to be checked
375) !
376) ! Author: Jitendra Kumar
377) ! Date: 07/21/2010
378) !
379)
380) use Realization_Subsurface_class
381) use Patch_module
382)
383) type(realization_subsurface_type) :: realization
384) PetscReal :: mass_balance(realization%option%nphase)
385)
386) type(patch_type), pointer :: cur_patch
387)
388) mass_balance = 0.d0
389)
390) cur_patch => realization%patch_list%first
391) do
392) if (.not.associated(cur_patch)) exit
393) realization%patch => cur_patch
394) call THComputeMassBalancePatch(realization, mass_balance)
395) cur_patch => cur_patch%next
396) enddo
397)
398) end subroutine THComputeMassBalance
399)
400) ! ************************************************************************** !
401)
402) subroutine THComputeMassBalancePatch(realization,mass_balance)
403) !
404) ! THomputeMassBalancePatch:
405) ! Adapted from RichardsComputeMassBalancePatch: need to be checked
406) !
407) ! Author: Jitendra Kumar
408) ! Date: 07/21/2010
409) !
410)
411) use Realization_Subsurface_class
412) use Option_module
413) use Patch_module
414) use Field_module
415) use Grid_module
416) use Material_Aux_class, only : material_auxvar_type, &
417) soil_compressibility_index, &
418) MaterialCompressSoil
419)
420) implicit none
421)
422) type(realization_subsurface_type) :: realization
423) PetscReal :: mass_balance(realization%option%nphase)
424)
425) type(option_type), pointer :: option
426) type(patch_type), pointer :: patch
427) type(field_type), pointer :: field
428) type(grid_type), pointer :: grid
429) type(global_auxvar_type), pointer :: global_auxvars(:)
430) class(material_auxvar_type), pointer :: material_auxvars(:)
431) type(TH_auxvar_type),pointer :: TH_auxvars(:)
432)
433) PetscErrorCode :: ierr
434) PetscInt :: local_id
435) PetscInt :: ghosted_id
436) PetscReal :: compressed_porosity
437) PetscReal :: por
438) PetscReal :: dum1
439)
440) option => realization%option
441) patch => realization%patch
442) grid => patch%grid
443) field => realization%field
444)
445) global_auxvars => patch%aux%Global%auxvars
446) material_auxvars => patch%aux%Material%auxvars
447) TH_auxvars => patch%aux%TH%auxvars
448)
449) do local_id = 1, grid%nlmax
450) ghosted_id = grid%nL2G(local_id)
451) if (patch%imat(ghosted_id) <= 0) cycle
452) ! mass = volume*saturation*density
453)
454) if (soil_compressibility_index > 0) then
455) call MaterialCompressSoil(material_auxvars(ghosted_id), &
456) global_auxvars(ghosted_id)%pres(1), &
457) compressed_porosity,dum1)
458) por = compressed_porosity
459) else
460) por = material_auxvars(ghosted_id)%porosity
461) endif
462)
463) mass_balance = mass_balance + &
464) global_auxvars(ghosted_id)%den_kg* &
465) global_auxvars(ghosted_id)%sat* &
466) por* &
467) material_auxvars(ghosted_id)%volume
468)
469) if (option%use_th_freezing) then
470) ! mass = volume*saturation_ice*density_ice
471) mass_balance = mass_balance + &
472) TH_auxvars(ghosted_id)%ice%den_ice*FMWH2O* &
473) TH_auxvars(ghosted_id)%ice%sat_ice* &
474) por* &
475) material_auxvars(ghosted_id)%volume
476) endif
477)
478) enddo
479)
480) end subroutine THComputeMassBalancePatch
481)
482) ! ************************************************************************** !
483)
484) subroutine THZeroMassBalDeltaPatch(realization)
485) !
486) ! Zeros mass balance delta array
487) !
488) ! Author: Satish Karra, LANL
489) ! Date: 12/13/11
490) !
491)
492) use Realization_Subsurface_class
493) use Option_module
494) use Patch_module
495) use Grid_module
496)
497) implicit none
498)
499) type(realization_subsurface_type) :: realization
500)
501) type(option_type), pointer :: option
502) type(patch_type), pointer :: patch
503) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
504) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
505)
506) PetscInt :: iconn
507)
508) option => realization%option
509) patch => realization%patch
510)
511) global_auxvars_bc => patch%aux%Global%auxvars_bc
512) global_auxvars_ss => patch%aux%Global%auxvars_ss
513)
514) #ifdef COMPUTE_INTERNAL_MASS_FLUX
515) do iconn = 1, patch%aux%TH%num_aux
516) patch%aux%Global%auxvars(iconn)%mass_balance_delta = 0.d0
517) enddo
518) #endif
519)
520) ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
521) ! placed around the internal do loop - geh
522) if (patch%aux%TH%num_aux_bc > 0) then
523) do iconn = 1, patch%aux%TH%num_aux_bc
524) global_auxvars_bc(iconn)%mass_balance_delta = 0.d0
525) enddo
526) endif
527) if (patch%aux%TH%num_aux_ss > 0) then
528) do iconn = 1, patch%aux%TH%num_aux_ss
529) global_auxvars_ss(iconn)%mass_balance_delta = 0.d0
530) enddo
531) endif
532)
533) end subroutine THZeroMassBalDeltaPatch
534)
535) ! ************************************************************************** !
536)
537) subroutine THUpdateMassBalancePatch(realization)
538) !
539) ! Updates mass balance
540) !
541) ! Author: ???
542) ! Date: 12/13/11
543) !
544)
545) use Realization_Subsurface_class
546) use Option_module
547) use Patch_module
548) use Grid_module
549)
550) implicit none
551)
552) type(realization_subsurface_type) :: realization
553)
554) type(option_type), pointer :: option
555) type(patch_type), pointer :: patch
556) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
557) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
558)
559) PetscInt :: iconn
560)
561) option => realization%option
562) patch => realization%patch
563)
564) global_auxvars_bc => patch%aux%Global%auxvars_bc
565) global_auxvars_ss => patch%aux%Global%auxvars_ss
566)
567) #ifdef COMPUTE_INTERNAL_MASS_FLUX
568) do iconn = 1, patch%aux%TH%num_aux
569) patch%aux%Global%auxvars(iconn)%mass_balance = &
570) patch%aux%Global%auxvars(iconn)%mass_balance + &
571) patch%aux%Global%auxvars(iconn)%mass_balance_delta*FMWH2O* &
572) option%flow_dt
573) enddo
574) #endif
575)
576) if (patch%aux%TH%num_aux_bc > 0) then
577) do iconn = 1, patch%aux%TH%num_aux_bc
578) global_auxvars_bc(iconn)%mass_balance = &
579) global_auxvars_bc(iconn)%mass_balance + &
580) global_auxvars_bc(iconn)%mass_balance_delta*FMWH2O*option%flow_dt
581) enddo
582) endif
583) if (patch%aux%TH%num_aux_ss > 0) then
584) do iconn = 1, patch%aux%TH%num_aux_ss
585) global_auxvars_ss(iconn)%mass_balance = &
586) global_auxvars_ss(iconn)%mass_balance + &
587) global_auxvars_ss(iconn)%mass_balance_delta*FMWH2O*option%flow_dt
588) enddo
589) endif
590)
591)
592) end subroutine THUpdateMassBalancePatch
593)
594) ! ************************************************************************** !
595)
596) subroutine THUpdateAuxVars(realization)
597) !
598) ! Updates the auxiliary variables associated with
599) ! the TH problem
600) !
601) ! Author: ???
602) ! Date: 12/10/07
603) !
604)
605) use Realization_Subsurface_class
606) use Patch_module
607)
608) type(realization_subsurface_type) :: realization
609)
610) type(patch_type), pointer :: cur_patch
611)
612) cur_patch => realization%patch_list%first
613) do
614) if (.not.associated(cur_patch)) exit
615) realization%patch => cur_patch
616) call THUpdateAuxVarsPatch(realization)
617) cur_patch => cur_patch%next
618) enddo
619)
620) end subroutine THUpdateAuxVars
621)
622) ! ************************************************************************** !
623)
624) subroutine THUpdateAuxVarsPatch(realization)
625) !
626) ! Updates the auxiliary variables associated with
627) ! the TH problem
628) !
629) ! Author: ???
630) ! Date: 12/10/07
631) !
632)
633) use Realization_Subsurface_class
634) use Patch_module
635) use Option_module
636) use Field_module
637) use Grid_module
638) use Coupler_module
639) use Connection_module
640) use Material_module
641)
642) implicit none
643)
644) type(realization_subsurface_type) :: realization
645)
646) type(option_type), pointer :: option
647) type(patch_type), pointer :: patch
648) type(grid_type), pointer :: grid
649) type(field_type), pointer :: field
650) type(coupler_type), pointer :: boundary_condition
651) type(coupler_type), pointer :: source_sink
652) type(connection_set_type), pointer :: cur_connection_set
653) type(TH_auxvar_type), pointer :: TH_auxvars(:)
654) type(TH_auxvar_type), pointer :: TH_auxvars_bc(:)
655) type(TH_auxvar_type), pointer :: TH_auxvars_ss(:)
656) type(global_auxvar_type), pointer :: global_auxvars(:)
657) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
658) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
659) class(material_auxvar_type), pointer :: material_auxvars(:)
660) type(TH_parameter_type), pointer :: TH_parameter
661)
662) PetscInt :: ghosted_id, local_id, istart, iend, sum_connection, idof, iconn
663) PetscInt :: iphasebc, iphase
664) PetscReal, pointer :: xx_loc_p(:), icap_loc_p(:), iphase_loc_p(:)
665) PetscReal :: xxbc(realization%option%nflowdof)
666) PetscReal, pointer :: xx(:)
667) PetscReal :: tsrc1
668) PetscErrorCode :: ierr
669) PetscInt :: ithrm
670) PetscReal, pointer :: ithrm_loc_p(:)
671)
672) !!
673) ! PetscReal, allocatable :: gradient(:,:)
674) !!
675)
676) option => realization%option
677) patch => realization%patch
678) grid => patch%grid
679) field => realization%field
680)
681) !!
682) ! allocate(gradient(grid%ngmax,3))
683) ! gradient = 0.d0
684) !!
685)
686) TH_auxvars => patch%aux%TH%auxvars
687) TH_auxvars_bc => patch%aux%TH%auxvars_bc
688) TH_auxvars_ss => patch%aux%TH%auxvars_ss
689) global_auxvars => patch%aux%Global%auxvars
690) global_auxvars_bc => patch%aux%Global%auxvars_bc
691) global_auxvars_ss => patch%aux%Global%auxvars_ss
692) material_auxvars => patch%aux%Material%auxvars
693) TH_parameter => patch%aux%TH%TH_parameter
694)
695) call VecGetArrayF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
696) call VecGetArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
697) call VecGetArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
698) call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
699)
700) do ghosted_id = 1, grid%ngmax
701) if (grid%nG2L(ghosted_id) < 0) cycle ! bypass ghosted corner cells
702)
703) if (patch%imat(ghosted_id) <= 0) cycle
704) iend = ghosted_id*option%nflowdof
705) istart = iend-option%nflowdof+1
706) iphase = int(iphase_loc_p(ghosted_id))
707) ithrm = int(ithrm_loc_p(ghosted_id))
708)
709) if (option%use_th_freezing) then
710) call THAuxVarComputeFreezing(xx_loc_p(istart:iend), &
711) TH_auxvars(ghosted_id),global_auxvars(ghosted_id), &
712) material_auxvars(ghosted_id), &
713) iphase, &
714) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
715) TH_parameter, ithrm, &
716) option)
717) else
718) call THAuxVarComputeNoFreezing(xx_loc_p(istart:iend), &
719) TH_auxvars(ghosted_id),global_auxvars(ghosted_id), &
720) material_auxvars(ghosted_id), &
721) iphase, &
722) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
723) TH_parameter, ithrm, &
724) option)
725) endif
726)
727) iphase_loc_p(ghosted_id) = iphase
728) enddo
729)
730) boundary_condition => patch%boundary_condition_list%first
731) sum_connection = 0
732) do
733) if (.not.associated(boundary_condition)) exit
734) cur_connection_set => boundary_condition%connection_set
735) do iconn = 1, cur_connection_set%num_connections
736) sum_connection = sum_connection + 1
737) local_id = cur_connection_set%id_dn(iconn)
738) ghosted_id = grid%nL2G(local_id)
739) if (patch%imat(ghosted_id) <= 0) cycle
740) ithrm = int(ithrm_loc_p(ghosted_id))
741)
742) do idof=1,option%nflowdof
743) select case(boundary_condition%flow_condition%itype(idof))
744) case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC,HET_DIRICHLET,HET_SURF_SEEPAGE_BC)
745) xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
746) case(NEUMANN_BC,ZERO_GRADIENT_BC)
747) xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
748) end select
749) enddo
750)
751) select case(boundary_condition%flow_condition%itype(TH_PRESSURE_DOF))
752) case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC)
753) iphasebc = boundary_condition%flow_aux_int_var(1,iconn)
754) case(NEUMANN_BC,ZERO_GRADIENT_BC)
755) iphasebc=int(iphase_loc_p(ghosted_id))
756) end select
757)
758) if (option%use_th_freezing) then
759) call THAuxVarComputeFreezing(xxbc,TH_auxvars_bc(sum_connection), &
760) global_auxvars_bc(sum_connection), &
761) material_auxvars(ghosted_id), &
762) iphasebc, &
763) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
764) TH_parameter, ithrm, &
765) option)
766) else
767) call THAuxVarComputeNoFreezing(xxbc,TH_auxvars_bc(sum_connection), &
768) global_auxvars_bc(sum_connection), &
769) material_auxvars(ghosted_id), &
770) iphasebc, &
771) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
772) TH_parameter, ithrm, &
773) option)
774) endif
775) enddo
776) boundary_condition => boundary_condition%next
777) enddo
778)
779) ! source/sinks
780) source_sink => patch%source_sink_list%first
781) sum_connection = 0
782) allocate(xx(option%nflowdof))
783) do
784) if (.not.associated(source_sink)) exit
785) cur_connection_set => source_sink%connection_set
786) do iconn = 1, cur_connection_set%num_connections
787) sum_connection = sum_connection + 1
788) local_id = cur_connection_set%id_dn(iconn)
789) ghosted_id = grid%nL2G(local_id)
790) if (patch%imat(ghosted_id) <= 0) cycle
791) ithrm = int(ithrm_loc_p(ghosted_id))
792)
793) iend = ghosted_id*option%nflowdof
794) istart = iend-option%nflowdof+1
795) iphase = int(iphase_loc_p(ghosted_id))
796)
797) select case(source_sink%flow_condition%itype(TH_TEMPERATURE_DOF))
798) case (HET_DIRICHLET)
799) tsrc1 = source_sink%flow_aux_real_var(TWO_INTEGER,iconn)
800) case (DIRICHLET_BC)
801) tsrc1 = source_sink%flow_condition%temperature%dataset%rarray(1)
802) case (ENERGY_RATE_SS,SCALED_ENERGY_RATE_SS,HET_ENERGY_RATE_SS, &
803) ZERO_GRADIENT_BC)
804) tsrc1 = xx_loc_p((ghosted_id-1)*option%nflowdof+2)
805) case default
806) option%io_buffer='Unsupported temperature flow condtion for ' // &
807) 'a source-sink in TH mode: ' // trim(source_sink%name)
808) call printErrMsg(option)
809) end select
810)
811) xx(1) = xx_loc_p(istart)
812) xx(2) = tsrc1
813)
814) if (option%use_th_freezing) then
815) call THAuxVarComputeFreezing(xx, &
816) TH_auxvars_ss(sum_connection),global_auxvars_ss(sum_connection), &
817) material_auxvars(ghosted_id), &
818) iphase, &
819) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
820) TH_parameter, ithrm, &
821) option)
822) else
823) call THAuxVarComputeNoFreezing(xx, &
824) TH_auxvars_ss(sum_connection),global_auxvars_ss(sum_connection), &
825) material_auxvars(ghosted_id), &
826) iphase, &
827) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
828) TH_parameter, ithrm, &
829) option)
830) endif
831) enddo
832) source_sink => source_sink%next
833) enddo
834) deallocate(xx)
835)
836) call VecRestoreArrayF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
837) call VecRestoreArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
838) call VecRestoreArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
839) call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
840)
841) patch%aux%TH%auxvars_up_to_date = PETSC_TRUE
842)
843) ! Update a flag marking presence or absence of standing water for BC grid cells
844) if (option%surf_flow_on) call THUpdateSurfaceWaterFlag(realization)
845)
846) end subroutine THUpdateAuxVarsPatch
847)
848) ! ************************************************************************** !
849)
850) subroutine THInitializeTimestep(realization)
851) !
852) ! Update data in module prior to time step
853) !
854) ! Author: ???
855) ! Date: 02/20/08
856) !
857)
858) use Realization_Subsurface_class
859)
860) implicit none
861)
862) type(realization_subsurface_type) :: realization
863)
864) call THUpdateFixedAccumulation(realization)
865)
866) end subroutine THInitializeTimestep
867)
868) ! ************************************************************************** !
869)
870) subroutine THUpdateSolution(realization)
871) !
872) ! Updates data in module after a successful time step
873) !
874) ! Author: ???
875) ! Date: 02/13/08
876) !
877)
878) use Realization_Subsurface_class
879) use Field_module
880) use Patch_module
881)
882) implicit none
883)
884) type(realization_subsurface_type) :: realization
885)
886) type(field_type), pointer :: field
887) type(patch_type), pointer :: cur_patch
888) PetscErrorCode :: ierr
889) PetscViewer :: viewer
890)
891) field => realization%field
892)
893) cur_patch => realization%patch_list%first
894) do
895) if (.not.associated(cur_patch)) exit
896) realization%patch => cur_patch
897) call THUpdateSolutionPatch(realization)
898) cur_patch => cur_patch%next
899) enddo
900)
901) end subroutine THUpdateSolution
902)
903) ! ************************************************************************** !
904)
905) subroutine THUpdateSolutionPatch(realization)
906) !
907) ! Updates data in module after a successful time
908) ! step
909) !
910) ! Author: Satish Karra, LANL
911) ! Date: 12/13/11, 02/28/14
912) !
913)
914)
915) use Realization_Subsurface_class
916) use Patch_module
917) use Grid_module
918) use Option_module
919) use Field_module
920) use Secondary_Continuum_Aux_module
921) use Secondary_Continuum_module
922)
923) implicit none
924)
925) type(realization_subsurface_type) :: realization
926) type(grid_type), pointer :: grid
927) type(patch_type), pointer :: patch
928) type(option_type), pointer :: option
929) type(field_type), pointer :: field
930) type(TH_parameter_type), pointer :: TH_parameter
931) type(TH_auxvar_type), pointer :: auxvars(:)
932) type(global_auxvar_type), pointer :: global_auxvars(:)
933) type(sec_heat_type), pointer :: TH_sec_heat_vars(:)
934)
935) PetscInt :: istart, iend
936) PetscInt :: local_id, ghosted_id
937) ! secondary continuum variables
938) PetscReal :: sec_dencpr
939) PetscErrorCode :: ierr
940) PetscReal, pointer :: ithrm_loc_p(:)
941)
942) patch => realization%patch
943) grid => patch%grid
944) option => realization%option
945) field => realization%field
946)
947) TH_parameter => patch%aux%TH%TH_parameter
948) auxvars => patch%aux%TH%auxvars
949) global_auxvars => patch%aux%Global%auxvars
950)
951) if (option%use_mc) then
952) TH_sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
953) endif
954)
955) if (realization%option%compute_mass_balance_new) then
956) call THUpdateMassBalancePatch(realization)
957) endif
958)
959) if (option%use_mc) then
960) call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
961) do local_id = 1, grid%nlmax ! For each local node do...
962) ghosted_id = grid%nL2G(local_id)
963) if (patch%imat(ghosted_id) <= 0) cycle
964) iend = local_id*option%nflowdof
965) istart = iend-option%nflowdof+1
966)
967) sec_dencpr = TH_parameter%dencpr(int(ithrm_loc_p(local_id))) ! secondary rho*c_p same as primary for now
968)
969) call THSecHeatAuxVarCompute(TH_sec_heat_vars(local_id), &
970) global_auxvars(ghosted_id), &
971) TH_parameter%ckwet(int(ithrm_loc_p(local_id))), &
972) sec_dencpr, &
973) option)
974)
975) enddo
976) call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
977) endif
978)
979)
980) end subroutine THUpdateSolutionPatch
981)
982) ! ************************************************************************** !
983)
984) subroutine THUpdateFixedAccumulation(realization)
985) !
986) ! Updates the fixed portion of the
987) ! accumulation term
988) !
989) ! Author: ???
990) ! Date: 12/10/07
991) !
992)
993) use Realization_Subsurface_class
994) use Patch_module
995)
996) type(realization_subsurface_type) :: realization
997)
998) type(patch_type), pointer :: cur_patch
999)
1000) cur_patch => realization%patch_list%first
1001) do
1002) if (.not.associated(cur_patch)) exit
1003) realization%patch => cur_patch
1004) call THUpdateFixedAccumPatch(realization)
1005) cur_patch => cur_patch%next
1006) enddo
1007)
1008) end subroutine THUpdateFixedAccumulation
1009)
1010) ! ************************************************************************** !
1011)
1012) subroutine THUpdateFixedAccumPatch(realization)
1013) !
1014) ! Updates the fixed portion of the
1015) ! accumulation term
1016) !
1017) ! Author: ???
1018) ! Date: 12/10/07
1019) !
1020)
1021) use Realization_Subsurface_class
1022) use Patch_module
1023) use Option_module
1024) use Field_module
1025) use Grid_module
1026) use Secondary_Continuum_Aux_module
1027)
1028)
1029) implicit none
1030)
1031) type(realization_subsurface_type) :: realization
1032)
1033) type(option_type), pointer :: option
1034) type(patch_type), pointer :: patch
1035) type(grid_type), pointer :: grid
1036) type(field_type), pointer :: field
1037) type(global_auxvar_type), pointer :: global_auxvars(:)
1038) type(TH_auxvar_type), pointer :: TH_auxvars(:)
1039) type(TH_parameter_type), pointer :: TH_parameter
1040) type(sec_heat_type), pointer :: TH_sec_heat_vars(:)
1041) class(material_auxvar_type), pointer :: material_auxvars(:)
1042)
1043) PetscInt :: ghosted_id, local_id, istart, iend, iphase
1044) PetscReal, pointer :: xx_p(:), icap_loc_p(:), iphase_loc_p(:)
1045) PetscReal, pointer :: ithrm_loc_p(:), accum_p(:)
1046) PetscReal :: vol_frac_prim
1047) PetscInt :: ithrm
1048)
1049) PetscErrorCode :: ierr
1050)
1051) option => realization%option
1052) field => realization%field
1053) patch => realization%patch
1054) grid => patch%grid
1055)
1056) TH_parameter => patch%aux%TH%TH_parameter
1057) TH_auxvars => patch%aux%TH%auxvars
1058) global_auxvars => patch%aux%Global%auxvars
1059) TH_sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
1060) material_auxvars => patch%aux%Material%auxvars
1061)
1062) call VecGetArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
1063) call VecGetArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
1064) call VecGetArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
1065) call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
1066)
1067) call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
1068)
1069)
1070) vol_frac_prim = 1.d0
1071)
1072) do local_id = 1, grid%nlmax
1073) ghosted_id = grid%nL2G(local_id)
1074) if (patch%imat(ghosted_id) <= 0) cycle
1075)
1076) iend = local_id*option%nflowdof
1077) istart = iend-option%nflowdof+1
1078) iphase = int(iphase_loc_p(ghosted_id))
1079) ithrm = int(ithrm_loc_p(ghosted_id))
1080)
1081) if (option%use_th_freezing) then
1082) call THAuxVarComputeFreezing(xx_p(istart:iend), &
1083) TH_auxvars(ghosted_id),global_auxvars(ghosted_id), &
1084) material_auxvars(ghosted_id), &
1085) iphase, &
1086) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
1087) TH_parameter, ithrm, &
1088) option)
1089) else
1090) call THAuxVarComputeNoFreezing(xx_p(istart:iend), &
1091) TH_auxvars(ghosted_id),global_auxvars(ghosted_id), &
1092) material_auxvars(ghosted_id), &
1093) iphase, &
1094) patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
1095) TH_parameter, ithrm, &
1096) option)
1097) endif
1098)
1099)
1100) if (option%use_mc) then
1101) vol_frac_prim = TH_sec_heat_vars(local_id)%epsilon
1102) endif
1103)
1104) iphase_loc_p(ghosted_id) = iphase
1105) call THAccumulation(TH_auxvars(ghosted_id),global_auxvars(ghosted_id), &
1106) material_auxvars(ghosted_id), &
1107) TH_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
1108) option,vol_frac_prim,accum_p(istart:iend))
1109) enddo
1110)
1111) call VecRestoreArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
1112) call VecRestoreArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
1113) call VecRestoreArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
1114) call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
1115)
1116) call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
1117)
1118) #if 0
1119) call THNumericalJacobianTest(field%flow_xx,realization)
1120) #endif
1121)
1122) end subroutine THUpdateFixedAccumPatch
1123)
1124) ! ************************************************************************** !
1125)
1126) subroutine THNumericalJacobianTest(xx,realization)
1127) !
1128) ! Computes the a test numerical jacobian
1129) !
1130) ! Author: ???
1131) ! Date: 12/13/07
1132) !
1133)
1134) use Realization_Subsurface_class
1135) use Patch_module
1136) use Option_module
1137) use Grid_module
1138) use Field_module
1139)
1140) implicit none
1141)
1142) Vec :: xx
1143) type(realization_subsurface_type) :: realization
1144)
1145) Vec :: xx_pert
1146) Vec :: res
1147) Vec :: res_pert
1148) Mat :: A
1149) PetscViewer :: viewer
1150) PetscErrorCode :: ierr
1151)
1152) PetscReal :: derivative, perturbation
1153)
1154) PetscReal, pointer :: vec_p(:), vec2_p(:)
1155)
1156) type(grid_type), pointer :: grid
1157) type(option_type), pointer :: option
1158) type(patch_type), pointer :: patch
1159) type(field_type), pointer :: field
1160)
1161) PetscInt :: idof, idof2, icell
1162)
1163) patch => realization%patch
1164) grid => patch%grid
1165) option => realization%option
1166) field => realization%field
1167)
1168) call VecDuplicate(xx,xx_pert,ierr);CHKERRQ(ierr)
1169) call VecDuplicate(xx,res,ierr);CHKERRQ(ierr)
1170) call VecDuplicate(xx,res_pert,ierr);CHKERRQ(ierr)
1171)
1172) call MatCreate(option%mycomm,A,ierr);CHKERRQ(ierr)
1173) call MatSetSizes(A,PETSC_DECIDE,PETSC_DECIDE,grid%nlmax*option%nflowdof,grid%nlmax*option%nflowdof, &
1174) ierr);CHKERRQ(ierr)
1175) call MatSetType(A,MATAIJ,ierr);CHKERRQ(ierr)
1176) call MatSetFromOptions(A,ierr);CHKERRQ(ierr)
1177)
1178) call THResidual(PETSC_NULL_OBJECT,xx,res,realization,ierr)
1179) call VecGetArrayF90(res,vec2_p,ierr);CHKERRQ(ierr)
1180) do icell = 1,grid%nlmax
1181) if (patch%imat(icell) <= 0) cycle
1182) do idof = (icell-1)*option%nflowdof+1,icell*option%nflowdof
1183) call VecCopy(xx,xx_pert,ierr);CHKERRQ(ierr)
1184) call VecGetArrayF90(xx_pert,vec_p,ierr);CHKERRQ(ierr)
1185) perturbation = vec_p(idof)*perturbation_tolerance
1186) vec_p(idof) = vec_p(idof)+perturbation
1187) call VecRestoreArrayF90(xx_pert,vec_p,ierr);CHKERRQ(ierr)
1188) call THResidual(PETSC_NULL_OBJECT,xx_pert,res_pert,realization,ierr)
1189) call VecGetArrayF90(res_pert,vec_p,ierr);CHKERRQ(ierr)
1190) do idof2 = 1, grid%nlmax*option%nflowdof
1191) derivative = (vec_p(idof2)-vec2_p(idof2))/perturbation
1192) if (dabs(derivative) > 1.d-30) then
1193) call matsetvalue(a,idof2-1,idof-1,derivative,insert_values, &
1194) ierr);CHKERRQ(ierr)
1195) endif
1196) enddo
1197) call VecRestoreArrayF90(res_pert,vec_p,ierr);CHKERRQ(ierr)
1198) enddo
1199) enddo
1200) call VecRestoreArrayF90(res,vec2_p,ierr);CHKERRQ(ierr)
1201)
1202) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
1203) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
1204) call PetscViewerASCIIOpen(option%mycomm,'numerical_jacobian.out',viewer, &
1205) ierr);CHKERRQ(ierr)
1206) call MatView(A,viewer,ierr);CHKERRQ(ierr)
1207) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1208)
1209) call MatDestroy(A,ierr);CHKERRQ(ierr)
1210)
1211) call VecDestroy(xx_pert,ierr);CHKERRQ(ierr)
1212) call VecDestroy(res,ierr);CHKERRQ(ierr)
1213) call VecDestroy(res_pert,ierr);CHKERRQ(ierr)
1214)
1215) end subroutine THNumericalJacobianTest
1216)
1217) ! ************************************************************************** !
1218)
1219) subroutine THAccumDerivative(TH_auxvar,global_auxvar, &
1220) material_auxvar, &
1221) rock_dencpr, &
1222) th_parameter, &
1223) ithrm, &
1224) option,sat_func, &
1225) vol_frac_prim,J)
1226) !
1227) ! Computes derivatives of the accumulation
1228) ! term for the Jacobian
1229) !
1230) ! Author: ???
1231) ! Date: 12/13/07
1232) !
1233)
1234) use Option_module
1235) use Saturation_Function_module
1236) use Material_Aux_class, only : material_auxvar_type, &
1237) soil_compressibility_index, &
1238) MaterialCompressSoil
1239) use EOS_Water_module
1240)
1241) implicit none
1242)
1243) type(TH_auxvar_type) :: TH_auxvar
1244) type(global_auxvar_type) :: global_auxvar
1245) class(material_auxvar_type) :: material_auxvar
1246) type(option_type) :: option
1247) PetscReal :: vol,por,rock_dencpr
1248) type(TH_parameter_type) :: th_parameter
1249) PetscInt :: ithrm
1250) type(saturation_function_type) :: sat_func
1251) PetscReal :: J(option%nflowdof,option%nflowdof)
1252)
1253) PetscInt :: ispec
1254) PetscReal :: porXvol, mol(option%nflowspec), eng, por1
1255)
1256) PetscInt :: iphase, ideriv
1257) type(TH_auxvar_type) :: TH_auxvar_pert
1258) type(global_auxvar_type) :: global_auxvar_pert
1259) ! leave as type
1260) type(material_auxvar_type) :: material_auxvar_pert
1261) PetscReal :: x(option%nflowdof), x_pert(option%nflowdof), pert
1262) PetscReal :: res(option%nflowdof), res_pert(option%nflowdof)
1263) PetscReal :: J_pert(option%nflowdof,option%nflowdof)
1264) PetscReal :: vol_frac_prim, tempreal
1265) PetscReal :: compressed_porosity, dcompressed_porosity_dp
1266)
1267) PetscReal :: pres, temp
1268) PetscReal :: sat, dsat_dp, dsat_dt
1269) PetscReal :: den, dden_dp, dden_dt
1270) PetscReal :: u, du_dp, du_dt
1271)
1272) ! ice variables
1273) PetscReal :: sat_g, p_g, den_g, p_sat, mol_g, u_g, C_g
1274) PetscReal :: dpsat_dt, ddeng_dt, dmolg_dt, dsatg_dp, dsatg_dt, dug_dt
1275) PetscReal :: sat_i, den_i, u_i
1276) PetscReal :: dsati_dp, dsati_dt
1277) PetscReal :: ddeni_dp, ddeni_dt
1278) PetscReal :: dui_dt
1279) PetscErrorCode :: ierr
1280)
1281)
1282) ! X = {p, T}; R = {R_p, R_T}
1283)
1284) vol = material_auxvar%volume
1285) pres = global_auxvar%pres(1)
1286) temp = global_auxvar%temp
1287) sat = global_auxvar%sat(1)
1288) den = global_auxvar%den(1)
1289) dden_dp = TH_auxvar%dden_dp
1290) dden_dt = TH_auxvar%dden_dt
1291) dsat_dp = TH_auxvar%dsat_dp
1292) dsat_dt = TH_auxvar%dsat_dt
1293) u = TH_auxvar%u
1294) du_dt = TH_auxvar%du_dt
1295) du_dp = TH_auxvar%du_dp
1296)
1297) if (soil_compressibility_index > 0) then
1298) tempreal = sat*den
1299) call MaterialCompressSoil(material_auxvar,pres, &
1300) compressed_porosity,dcompressed_porosity_dp)
1301) por = compressed_porosity
1302) else
1303) por = material_auxvar%porosity
1304) dcompressed_porosity_dp = 0.d0
1305) endif
1306)
1307) porXvol = por*vol
1308)
1309) ! d(por*sat*den)/dP * vol
1310) J(TH_PRESSURE_DOF,TH_PRESSURE_DOF) = (sat*dden_dp + dsat_dp*den)*porXvol + &
1311) dcompressed_porosity_dp*sat*den*vol
1312)
1313) J(TH_PRESSURE_DOF,TH_TEMPERATURE_DOF) = sat*dden_dt*porXvol
1314) J(TH_TEMPERATURE_DOF,TH_PRESSURE_DOF) = (dsat_dp*den*u + &
1315) sat*dden_dp*u + &
1316) sat*den*du_dp)*porXvol + &
1317) (den*sat*u - rock_dencpr*temp)*vol*dcompressed_porosity_dp
1318) J(TH_TEMPERATURE_DOF,TH_TEMPERATURE_DOF) = sat*(dden_dt*u + den*du_dt)*porXvol + &
1319) (1.d0 - por)*vol*rock_dencpr
1320)
1321)
1322) if (option%use_th_freezing) then
1323) ! SK, 11/17/11
1324) sat_g = TH_auxvar%ice%sat_gas
1325) sat_i = TH_auxvar%ice%sat_ice
1326) dsati_dt = TH_auxvar%ice%dsat_ice_dt
1327) dsati_dp = TH_auxvar%ice%dsat_ice_dp
1328) dsatg_dp = TH_auxvar%ice%dsat_gas_dp
1329) dsatg_dt = TH_auxvar%ice%dsat_gas_dt
1330)
1331) u_g = TH_auxvar%ice%u_gas
1332) u_i = TH_auxvar%ice%u_ice
1333) dug_dt = TH_auxvar%ice%du_gas_dt
1334) dui_dt = TH_auxvar%ice%du_ice_dt
1335)
1336) den_i = TH_auxvar%ice%den_ice
1337) den_g = TH_auxvar%ice%den_gas
1338) mol_g = TH_auxvar%ice%mol_gas
1339) ddeni_dt = TH_auxvar%ice%dden_ice_dt
1340) ddeni_dp = TH_auxvar%ice%dden_ice_dp
1341) ddeng_dt = TH_auxvar%ice%dden_gas_dt
1342) dmolg_dt = TH_auxvar%ice%dmol_gas_dt
1343)
1344) J(TH_PRESSURE_DOF,TH_PRESSURE_DOF) = J(TH_PRESSURE_DOF,TH_PRESSURE_DOF) + &
1345) (dsatg_dp*den_g*mol_g + &
1346) dsati_dp*den_i + &
1347) sat_i *ddeni_dp )*porXvol + &
1348) (sat_g *den_g*mol_g + &
1349) sat_i *den_i )*dcompressed_porosity_dp*vol
1350)
1351) J(TH_PRESSURE_DOF,TH_TEMPERATURE_DOF) = J(TH_PRESSURE_DOF,TH_TEMPERATURE_DOF) + &
1352) (TH_auxvar%dsat_dt*global_auxvar%den(1) + &
1353) dsatg_dt * den_g * mol_g + &
1354) sat_g * ddeng_dt * mol_g + &
1355) sat_g * den_g * dmolg_dt + &
1356) dsati_dt * den_i + &
1357) sat_i * ddeni_dt )*porXvol
1358)
1359) J(TH_TEMPERATURE_DOF,TH_PRESSURE_DOF) = J(TH_TEMPERATURE_DOF,TH_PRESSURE_DOF) + &
1360) (dsatg_dp * den_g * u_g + &
1361) dsati_dp * den_i * u_i + &
1362) sat_i * ddeni_dp * u_i )*porXvol + &
1363) (sat_g * den_g * u_g + &
1364) sat_i * den_i * u_i )*dcompressed_porosity_dp*vol
1365)
1366) J(TH_TEMPERATURE_DOF,TH_TEMPERATURE_DOF) = J(TH_TEMPERATURE_DOF,TH_TEMPERATURE_DOF) + &
1367) (TH_auxvar%dsat_dt*global_auxvar%den(1)*TH_auxvar%u + &
1368) dsatg_dt * den_g * u_g + &
1369) sat_g * ddeng_dt * u_g + &
1370) sat_g * den_g * dug_dt + &
1371) dsati_dt * den_i * u_i + &
1372) sat_i * ddeni_dt * u_i + &
1373) sat_i * den_i * dui_dt )*porXvol
1374) endif
1375)
1376) J = J/option%flow_dt
1377) J(option%nflowdof,:) = vol_frac_prim*J(option%nflowdof,:)
1378)
1379) ! If only solving the energy equation,
1380) ! - Set jacobian term corresponding to mass-equation to zero, and
1381) ! - Set off-diagonal jacobian terms to zero.
1382) if (option%flow%only_energy_eq) then
1383) J(1,1) = 1.d0
1384) J(1,2) = 0.d0
1385) J(2,1) = 0.d0
1386) endif
1387)
1388) if (option%flow%numerical_derivatives) then
1389) call GlobalAuxVarInit(global_auxvar_pert,option)
1390) call MaterialAuxVarInit(material_auxvar_pert,option)
1391)
1392) call THAuxVarCopy(TH_auxvar,TH_auxvar_pert,option)
1393) call GlobalAuxVarCopy(global_auxvar,global_auxvar_pert,option)
1394) call MaterialAuxVarCopy(material_auxvar,material_auxvar_pert,option)
1395)
1396) x(1) = global_auxvar%pres(1)
1397) x(2) = global_auxvar%temp
1398)
1399) call THAccumulation(TH_auxvar,global_auxvar,material_auxvar, &
1400) rock_dencpr,option, &
1401) vol_frac_prim,res)
1402)
1403) do ideriv = 1,option%nflowdof
1404) pert = x(ideriv)*perturbation_tolerance
1405) x_pert = x
1406) if (option%use_th_freezing) then
1407) if (ideriv == 1) then
1408) if (x_pert(ideriv) < option%reference_pressure) then
1409) pert = - pert
1410) endif
1411) x_pert(ideriv) = x_pert(ideriv) + pert
1412) endif
1413)
1414) if (ideriv == 2) then
1415) if (x_pert(ideriv) < 0.d0) then
1416) pert = - 1.d-8
1417) else
1418) pert = 1.d-8
1419) endif
1420) x_pert(ideriv) = x_pert(ideriv) + pert
1421) endif
1422) else
1423) x_pert(ideriv) = x_pert(ideriv) + pert
1424) endif
1425)
1426) if (option%use_th_freezing) then
1427) call THAuxVarComputeFreezing(x_pert,TH_auxvar_pert, &
1428) global_auxvar_pert,material_auxvar_pert, &
1429) iphase,sat_func, &
1430) TH_parameter, ithrm, &
1431) option)
1432) else
1433) call THAuxVarComputeNoFreezing(x_pert,TH_auxvar_pert,&
1434) global_auxvar_pert,material_auxvar_pert,&
1435) iphase,sat_func, &
1436) TH_parameter,ithrm, &
1437) option)
1438) endif
1439)
1440) call THAccumulation(TH_auxvar_pert,global_auxvar_pert, material_auxvar_pert, &
1441) rock_dencpr,option,vol_frac_prim, &
1442) res_pert)
1443) J_pert(:,ideriv) = (res_pert(:)-res(:))/pert
1444) enddo
1445)
1446) J = J_pert
1447) call GlobalAuxVarStrip(global_auxvar_pert)
1448) endif
1449)
1450) end subroutine THAccumDerivative
1451)
1452) ! ************************************************************************** !
1453)
1454) subroutine THAccumulation(auxvar,global_auxvar, &
1455) material_auxvar, &
1456) rock_dencpr,option,vol_frac_prim,Res)
1457) !
1458) ! Computes the non-fixed portion of the accumulation
1459) ! term for the residual
1460) !
1461) ! Author: ???
1462) ! Date: 12/13/07
1463) !
1464)
1465) use Option_module
1466) use Material_Aux_class, only : material_auxvar_type, &
1467) soil_compressibility_index, &
1468) MaterialCompressSoil
1469) use EOS_Water_module
1470)
1471) implicit none
1472)
1473) type(TH_auxvar_type) :: auxvar
1474) type(global_auxvar_type) :: global_auxvar
1475) class(material_auxvar_type) :: material_auxvar
1476) type(option_type) :: option
1477) PetscReal :: Res(1:option%nflowdof)
1478) PetscReal ::rock_dencpr,por1
1479)
1480) PetscInt :: ispec
1481) PetscReal :: vol,por
1482) PetscReal :: porXvol, mol(option%nflowspec), eng
1483) PetscReal :: vol_frac_prim
1484) PetscReal :: compressed_porosity, dcompressed_porosity_dp
1485)
1486) ! ice variables
1487) PetscReal :: sat_g, p_g, den_g, p_sat, mol_g, u_g, C_g
1488) PetscReal :: sat_i, den_i, u_i
1489) PetscErrorCode :: ierr
1490)
1491) vol = material_auxvar%volume
1492)
1493) if (soil_compressibility_index > 0) then
1494) call MaterialCompressSoil(material_auxvar,global_auxvar%pres(1), &
1495) compressed_porosity,dcompressed_porosity_dp)
1496) material_auxvar%porosity = compressed_porosity
1497) por = compressed_porosity
1498) else
1499) por = material_auxvar%porosity
1500) endif
1501) auxvar%transient_por = por
1502)
1503) ! TechNotes, TH Mode: First term of Equation 8
1504) porXvol = por*vol
1505)
1506) mol(1) = global_auxvar%sat(1)*global_auxvar%den(1)*porXvol
1507)
1508) ! TechNotes, TH Mode: First term of Equation 9
1509) ! rock_dencpr [MJ/m^3 rock-K]
1510) eng = global_auxvar%sat(1) * &
1511) global_auxvar%den(1) * &
1512) auxvar%u * porXvol + &
1513) (1.d0 - por) * vol * rock_dencpr * global_auxvar%temp
1514)
1515) if (option%use_th_freezing) then
1516) ! SK, 11/17/11
1517) sat_g = auxvar%ice%sat_gas
1518) sat_i = auxvar%ice%sat_ice
1519) u_i = auxvar%ice%u_ice
1520) den_i = auxvar%ice%den_ice
1521) den_g = auxvar%ice%den_gas
1522) mol_g = auxvar%ice%mol_gas
1523) u_g = auxvar%ice%u_gas
1524) mol(1) = mol(1) + (sat_g*den_g*mol_g + sat_i*den_i)*porXvol
1525) eng = eng + (sat_g*den_g*u_g + sat_i*den_i*u_i)*porXvol
1526) endif
1527)
1528) Res(1:option%nflowdof-1) = mol(:)/option%flow_dt
1529) Res(option%nflowdof) = vol_frac_prim*eng/option%flow_dt
1530)
1531) end subroutine THAccumulation
1532)
1533) ! ************************************************************************** !
1534)
1535) subroutine THFluxDerivative(auxvar_up,global_auxvar_up, &
1536) material_auxvar_up, &
1537) sir_up, &
1538) Dk_up, &
1539) ithrm_up, &
1540) auxvar_dn,global_auxvar_dn, &
1541) material_auxvar_dn, &
1542) sir_dn, &
1543) Dk_dn, &
1544) ithrm_dn, &
1545) area, &
1546) dist, upweight, &
1547) option,sat_func_up,sat_func_dn, &
1548) Dk_dry_up,Dk_dry_dn, &
1549) Dk_ice_up,Dk_ice_dn, &
1550) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
1551) th_parameter, &
1552) Jup,Jdn)
1553)
1554) !
1555) ! Computes the derivatives of the internal flux terms
1556) ! for the Jacobian
1557) !
1558) ! Author: ???
1559) ! Date: 12/13/07
1560) !
1561)
1562) use Option_module
1563) use Saturation_Function_module
1564) use Connection_module
1565) use EOS_Water_module
1566) use Utility_module
1567)
1568) implicit none
1569)
1570) type(TH_auxvar_type) :: auxvar_up, auxvar_dn
1571) type(global_auxvar_type) :: global_auxvar_up, global_auxvar_dn
1572) class(material_auxvar_type) :: material_auxvar_up, material_auxvar_dn
1573) type(option_type) :: option
1574) PetscReal :: sir_up, sir_dn
1575) PetscReal :: dd_up, dd_dn
1576) PetscReal :: perm_up, perm_dn
1577) PetscReal :: Dk_up, Dk_dn
1578) PetscReal :: Dk_dry_up, Dk_dry_dn
1579) PetscReal :: Dk_ice_up, Dk_ice_dn
1580) PetscReal :: alpha_up, alpha_dn
1581) PetscReal :: alpha_fr_up, alpha_fr_dn
1582) PetscInt :: ithrm_up, ithrm_dn
1583) PetscReal :: v_darcy, area
1584) PetscReal :: dist(-1:3)
1585) type(saturation_function_type) :: sat_func_up, sat_func_dn
1586) type(TH_parameter_type) :: th_parameter
1587) PetscReal :: Jup(option%nflowdof,option%nflowdof), Jdn(option%nflowdof,option%nflowdof)
1588)
1589) PetscReal :: por_up, por_dn
1590) PetscReal :: tor_up, tor_dn
1591) PetscReal :: dist_gravity ! distance along gravity vector
1592) PetscInt :: ispec
1593) PetscReal :: fluxm,fluxe,q
1594) PetscReal :: uh,ukvr,DK,Dq
1595) PetscReal :: upweight,density_ave,cond,gravity,dphi
1596)
1597) PetscReal :: dden_ave_dp_up, dden_ave_dp_dn, dden_ave_dt_up, dden_ave_dt_dn
1598) PetscReal :: dgravity_dden_up, dgravity_dden_dn
1599) PetscReal :: dphi_dp_up, dphi_dp_dn, dphi_dt_up, dphi_dt_dn
1600) PetscReal :: dukvr_dp_up, dukvr_dp_dn, dukvr_dt_up, dukvr_dt_dn
1601) PetscReal :: duh_dp_up, duh_dp_dn, duh_dt_up, duh_dt_dn
1602) PetscReal :: dq_dp_up, dq_dp_dn, dq_dt_up, dq_dt_dn
1603)
1604) PetscReal :: Dk_eff_up, Dk_eff_dn
1605) PetscReal, parameter :: epsilon = 1.d-6
1606) PetscReal :: dKe_dt_up, dKe_dp_up
1607) PetscReal :: dKe_dt_dn, dKe_dp_dn
1608) PetscReal :: dDk_dt_up, dDk_dt_dn
1609) PetscReal :: dDk_dp_up, dDk_dp_dn
1610)
1611) PetscInt :: iphase, ideriv
1612) type(TH_auxvar_type) :: auxvar_pert_up, auxvar_pert_dn
1613) type(global_auxvar_type) :: global_auxvar_pert_up, global_auxvar_pert_dn
1614) PetscReal :: x_up(option%nflowdof), x_dn(option%nflowdof)
1615) PetscReal :: x_pert_up(option%nflowdof), x_pert_dn(option%nflowdof)
1616) PetscReal :: pert_up, pert_dn
1617) PetscReal :: res(option%nflowdof)
1618) PetscReal :: res_pert_up(option%nflowdof)
1619) PetscReal :: res_pert_dn(option%nflowdof)
1620) PetscReal :: J_pert_up(option%nflowdof,option%nflowdof)
1621) PetscReal :: J_pert_dn(option%nflowdof,option%nflowdof)
1622) class(material_auxvar_type), allocatable :: material_auxvar_pert_dn, &
1623) material_auxvar_pert_up
1624)
1625) ! ice variables
1626) PetscReal :: Ddiffgas_avg, Ddiffgas_up, Ddiffgas_dn
1627) PetscReal :: p_g
1628) PetscReal :: deng_up, deng_dn
1629) PetscReal :: psat_up, psat_dn
1630) PetscReal :: molg_up, molg_dn
1631) PetscReal :: satg_up, satg_dn
1632) PetscReal :: Diffg_up, Diffg_dn
1633) PetscReal :: ddeng_dt_up, ddeng_dt_dn
1634) PetscReal :: dpsat_dt_up, dpsat_dt_dn
1635) PetscReal :: dmolg_dt_up, dmolg_dt_dn
1636) PetscReal :: dDiffg_dt_up, dDiffg_dt_dn
1637) PetscReal :: dDiffg_dp_up, dDiffg_dp_dn
1638) PetscReal :: dsatg_dp_up, dsatg_dp_dn
1639) PetscReal :: Diffg_ref, p_ref, T_ref
1640) PetscErrorCode :: ierr
1641) PetscReal :: Ke_fr_up,Ke_fr_dn ! frozen soil Kersten numbers
1642) PetscReal :: dKe_fr_dt_up, dKe_fr_dt_dn
1643) PetscReal :: dKe_fr_dp_up, dKe_fr_dp_dn
1644) PetscReal :: fv_up, fv_dn
1645) PetscReal :: dfv_dt_up, dfv_dt_dn
1646) PetscReal :: dfv_dp_up, dfv_dp_dn
1647) PetscReal :: dmolg_dp_up, dmolg_dp_dn
1648) PetscReal :: fv_up_pert
1649)
1650) call ConnectionCalculateDistances(dist,option%gravity,dd_up,dd_dn, &
1651) dist_gravity,upweight)
1652) call material_auxvar_up%PermeabilityTensorToScalar(dist,perm_up)
1653) call material_auxvar_dn%PermeabilityTensorToScalar(dist,perm_dn)
1654)
1655) por_up = material_auxvar_up%porosity
1656) por_dn = material_auxvar_dn%porosity
1657)
1658) tor_up = material_auxvar_up%tortuosity
1659) tor_dn = material_auxvar_dn%tortuosity
1660)
1661) Dq = (perm_up * perm_dn)/(dd_up*perm_dn + dd_dn*perm_up)
1662)
1663) fluxm = 0.D0
1664) fluxe = 0.D0
1665) v_darcy = 0.D0
1666)
1667) Jup = 0.d0
1668) Jdn = 0.d0
1669)
1670) dden_ave_dp_up = 0.d0
1671) dden_ave_dt_up = 0.d0
1672) dden_ave_dp_dn = 0.d0
1673) dden_ave_dt_dn = 0.d0
1674) dgravity_dden_up = 0.d0
1675) dgravity_dden_dn = 0.d0
1676) dphi_dp_up = 0.d0
1677) dphi_dp_dn = 0.d0
1678) dphi_dt_up = 0.d0
1679) dphi_dt_dn = 0.d0
1680) dukvr_dp_up = 0.d0
1681) dukvr_dp_dn = 0.d0
1682) dukvr_dt_up = 0.d0
1683) dukvr_dt_dn = 0.d0
1684) duh_dp_up = 0.d0
1685) duh_dp_dn = 0.d0
1686) duh_dt_up = 0.d0
1687) duh_dt_dn = 0.d0
1688) dq_dp_up = 0.d0
1689) dq_dp_dn = 0.d0
1690) dq_dt_up = 0.d0
1691) dq_dt_dn = 0.d0
1692) dDk_dt_up = 0.d0
1693) dDk_dt_dn = 0.d0
1694) dDk_dp_up = 0.d0
1695) dDk_dp_dn = 0.d0
1696)
1697) if (option%use_th_freezing) then
1698) dfv_dt_up = 0.d0
1699) dfv_dt_dn = 0.d0
1700) dfv_dp_up = 0.d0
1701) dfv_dp_dn = 0.d0
1702) dmolg_dp_up = 0.d0
1703) dmolg_dp_dn = 0.d0
1704) dmolg_dt_up = 0.d0
1705) dmolg_dt_dn = 0.d0
1706) endif
1707)
1708) ! Flow term
1709) if (global_auxvar_up%sat(1) > sir_up .or. global_auxvar_dn%sat(1) > sir_dn) then
1710) if (global_auxvar_up%sat(1) <eps) then
1711) upweight=0.d0
1712) else if (global_auxvar_dn%sat(1) <eps) then
1713) upweight=1.d0
1714) endif
1715) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_dn%den(1)
1716) dden_ave_dp_up = upweight*auxvar_up%dden_dp
1717) dden_ave_dp_dn = (1.D0-upweight)*auxvar_dn%dden_dp
1718) dden_ave_dt_up = upweight*auxvar_up%dden_dt
1719) dden_ave_dt_dn = (1.D0-upweight)*auxvar_dn%dden_dt
1720)
1721) gravity = (upweight*global_auxvar_up%den(1)*auxvar_up%avgmw + &
1722) (1.D0-upweight)*global_auxvar_dn%den(1)*auxvar_dn%avgmw) &
1723) * dist_gravity
1724) dgravity_dden_up = upweight*auxvar_up%avgmw*dist_gravity
1725) dgravity_dden_dn = (1.d0-upweight)*auxvar_dn%avgmw*dist_gravity
1726)
1727) if (option%ice_model /= DALL_AMICO) then
1728) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
1729) dphi_dp_up = 1.d0 + dgravity_dden_up*auxvar_up%dden_dp
1730) dphi_dp_dn = -1.d0 + dgravity_dden_dn*auxvar_dn%dden_dp
1731) dphi_dt_up = dgravity_dden_up*auxvar_up%dden_dt
1732) dphi_dt_dn = dgravity_dden_dn*auxvar_dn%dden_dt
1733) else
1734) dphi = auxvar_up%ice%pres_fh2o - auxvar_dn%ice%pres_fh2o + gravity
1735) dphi_dp_up = auxvar_up%ice%dpres_fh2o_dp + dgravity_dden_up*auxvar_up%dden_dp
1736) dphi_dp_dn = -auxvar_dn%ice%dpres_fh2o_dp + dgravity_dden_dn*auxvar_dn%dden_dp
1737) dphi_dt_up = auxvar_up%ice%dpres_fh2o_dt + dgravity_dden_up*auxvar_up%dden_dt
1738) dphi_dt_dn = -auxvar_dn%ice%dpres_fh2o_dt + dgravity_dden_dn*auxvar_dn%dden_dt
1739) endif
1740)
1741) if (dphi>=0.D0) then
1742) ukvr = auxvar_up%kvr
1743) dukvr_dp_up = auxvar_up%dkvr_dp
1744) dukvr_dt_up = auxvar_up%dkvr_dt
1745)
1746) uh = auxvar_up%h
1747) duh_dp_up = auxvar_up%dh_dp
1748) duh_dt_up = auxvar_up%dh_dt
1749) else
1750) ukvr = auxvar_dn%kvr
1751) dukvr_dp_dn = auxvar_dn%dkvr_dp
1752) dukvr_dt_dn = auxvar_dn%dkvr_dt
1753)
1754) uh = auxvar_dn%h
1755) duh_dp_dn = auxvar_dn%dh_dp
1756) duh_dt_dn = auxvar_dn%dh_dt
1757) endif
1758)
1759) call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, &
1760) auxvar_up%dkvr_dp, auxvar_dn%dkvr_dp, &
1761) dphi, &
1762) option%rel_perm_aveg, &
1763) ukvr, dukvr_dp_up, dukvr_dp_dn)
1764) call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, &
1765) auxvar_up%dkvr_dt, auxvar_dn%dkvr_dt, &
1766) dphi, &
1767) option%rel_perm_aveg, &
1768) ukvr, dukvr_dt_up, dukvr_dt_dn)
1769)
1770) !call InterfaceApprox(auxvar_up%h, auxvar_dn%h, &
1771) ! auxvar_up%dh_dp, auxvar_dn%dh_dp, &
1772) ! dphi, &
1773) ! option%rel_perm_aveg, &
1774) ! uh, duh_dp_up, duh_dp_dn)
1775) !call InterfaceApprox(auxvar_up%h, auxvar_dn%h, &
1776) ! auxvar_up%dh_dt, auxvar_dn%dh_dt, &
1777) ! dphi, &
1778) ! option%rel_perm_aveg, &
1779) ! uh, duh_dt_up, duh_dp_dn)
1780)
1781) if (ukvr>floweps) then
1782) v_darcy= Dq * ukvr * dphi
1783)
1784) q = v_darcy * area
1785) dq_dp_up = Dq*(dukvr_dp_up*dphi+ukvr*dphi_dp_up)*area
1786) dq_dp_dn = Dq*(dukvr_dp_dn*dphi+ukvr*dphi_dp_dn)*area
1787)
1788) dq_dt_up = Dq*(dukvr_dt_up*dphi+ukvr*dphi_dt_up)*area
1789) dq_dt_dn = Dq*(dukvr_dt_dn*dphi+ukvr*dphi_dt_dn)*area
1790)
1791)
1792) ! If only solving the energy equation, ensure Jup(2,2) & Jdn(2,2)
1793) ! have no contribution from the mass equation
1794) if (option%flow%only_energy_eq) then
1795) v_darcy = 0.d0
1796) q = 0.d0
1797) dq_dt_up = 0.d0
1798) dq_dt_dn = 0.d0
1799) endif
1800)
1801) Jup(1,1) = (dq_dp_up*density_ave+q*dden_ave_dp_up)
1802) Jup(1,2) = (dq_dt_up*density_ave+q*dden_ave_dt_up)
1803)
1804) Jdn(1,1) = (dq_dp_dn*density_ave+q*dden_ave_dp_dn)
1805) Jdn(1,2) = (dq_dt_dn*density_ave+q*dden_ave_dt_dn)
1806)
1807) ! based on flux = q*density_ave*uh
1808) Jup(option%nflowdof,1) = (dq_dp_up*density_ave+q*dden_ave_dp_up)*uh+q*density_ave*duh_dp_up
1809) Jup(option%nflowdof,2) = (dq_dt_up*density_ave+q*dden_ave_dt_up)*uh+q*density_ave*duh_dt_up
1810)
1811) Jdn(option%nflowdof,1) = (dq_dp_dn*density_ave+q*dden_ave_dp_dn)*uh+q*density_ave*duh_dp_dn
1812) Jdn(option%nflowdof,2) = (dq_dt_dn*density_ave+q*dden_ave_dt_dn)*uh+q*density_ave*duh_dt_dn
1813)
1814) endif
1815) endif
1816)
1817) if (option%use_th_freezing) then
1818) ! Added by Satish Karra, updated 11/11/11
1819) satg_up = auxvar_up%ice%sat_gas
1820) satg_dn = auxvar_dn%ice%sat_gas
1821) if ((satg_up > eps) .and. (satg_dn > eps)) then
1822) p_g = option%reference_pressure ! set to reference pressure
1823) deng_up = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + 273.15d0))*1.d-3
1824) deng_dn = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + 273.15d0))*1.d-3
1825)
1826) Diffg_ref = 2.13D-5 ! Reference diffusivity, need to read from input file
1827) p_ref = 1.01325d5 ! in Pa
1828) T_ref = 25.d0 ! in deg C
1829)
1830) Diffg_up = Diffg_ref*(p_ref/p_g)*((global_auxvar_up%temp + 273.15d0)/ &
1831) (T_ref + 273.15d0))**(1.8)
1832) Diffg_dn = Diffg_ref*(p_ref/p_g)*((global_auxvar_dn%temp + 273.15d0)/ &
1833) (T_ref + 273.15d0))**(1.8)
1834)
1835) Ddiffgas_up = por_up*tor_up*satg_up*deng_up*Diffg_up
1836) Ddiffgas_dn = por_dn*tor_dn*satg_dn*deng_dn*Diffg_dn
1837) call EOSWaterSaturationPressure(global_auxvar_up%temp, psat_up, dpsat_dt_up, ierr)
1838) call EOSWaterSaturationPressure(global_auxvar_dn%temp, psat_dn, dpsat_dt_dn, ierr)
1839)
1840) ! vapor pressure lowering due to capillary pressure
1841) fv_up = exp(-auxvar_up%pc/(global_auxvar_up%den(1)* &
1842) IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + 273.15d0)))
1843) fv_dn = exp(-auxvar_dn%pc/(global_auxvar_dn%den(1)* &
1844) IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + 273.15d0)))
1845)
1846) molg_up = psat_up*fv_up/p_g
1847) molg_dn = psat_dn*fv_dn/p_g
1848)
1849) dfv_dt_up = fv_up*(auxvar_up%pc/IDEAL_GAS_CONSTANT/(global_auxvar_up%den(1)* &
1850) (global_auxvar_up%temp + 273.15d0))**2)* &
1851) (auxvar_up%dden_dt*(global_auxvar_up%temp + 273.15d0) &
1852) + global_auxvar_up%den(1))
1853) dfv_dt_dn = fv_dn*(auxvar_dn%pc/IDEAL_GAS_CONSTANT/(global_auxvar_dn%den(1)* &
1854) (global_auxvar_dn%temp + 273.15d0))**2)* &
1855) (auxvar_dn%dden_dt*(global_auxvar_dn%temp + 273.15d0) &
1856) + global_auxvar_dn%den(1))
1857)
1858) dfv_dp_up = fv_up*(auxvar_up%pc/IDEAL_GAS_CONSTANT/(global_auxvar_up%den(1))**2/ &
1859) (global_auxvar_up%temp + 273.15d0)*auxvar_up%dden_dp &
1860) + 1.d0/IDEAL_GAS_CONSTANT/global_auxvar_up%den(1)/ &
1861) (global_auxvar_up%temp + 273.15d0))
1862) dfv_dp_dn = fv_dn*(auxvar_dn%pc/IDEAL_GAS_CONSTANT/(global_auxvar_dn%den(1))**2/ &
1863) (global_auxvar_dn%temp + 273.15d0)*auxvar_dn%dden_dp &
1864) + 1.d0/IDEAL_GAS_CONSTANT/global_auxvar_dn%den(1)/ &
1865) (global_auxvar_dn%temp + 273.15d0))
1866)
1867) dmolg_dt_up = (1/p_g)*dpsat_dt_up*fv_up + psat_up/p_g*dfv_dt_up
1868) dmolg_dt_dn = (1/p_g)*dpsat_dt_dn*fv_dn + psat_dn/p_g*dfv_dt_dn
1869)
1870) dmolg_dp_up = psat_up/p_g*dfv_dp_up
1871) dmolg_dp_dn = psat_dn/p_g*dfv_dp_dn
1872)
1873) ddeng_dt_up = - p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + &
1874) 273.15d0)**2)*1.d-3
1875) ddeng_dt_dn = - p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + &
1876) 273.15d0)**2)*1.d-3
1877)
1878) dDiffg_dt_up = 1.8*Diffg_up/(global_auxvar_up%temp + 273.15d0)
1879) dDiffg_dt_dn = 1.8*Diffg_dn/(global_auxvar_dn%temp + 273.15d0)
1880)
1881) dDiffg_dp_up = 0.d0
1882) dDiffg_dp_dn = 0.d0
1883)
1884) dsatg_dp_up = auxvar_up%ice%dsat_gas_dp
1885) dsatg_dp_dn = auxvar_dn%ice%dsat_gas_dp
1886)
1887) if (molg_up > molg_dn) then
1888) upweight = 0.d0
1889) else
1890) upweight = 1.d0
1891) endif
1892)
1893) Ddiffgas_avg = upweight*Ddiffgas_up + (1.D0 - upweight)*Ddiffgas_dn
1894)
1895) #ifndef NO_VAPOR_DIFFUION
1896) Jup(1,1) = Jup(1,1) + (upweight*por_up*tor_up*deng_up*(Diffg_up*dsatg_dp_up &
1897) + satg_up*dDiffg_dp_up)* &
1898) (molg_up - molg_dn) + Ddiffgas_up*dmolg_dp_up)/ &
1899) (dd_up + dd_dn)*area
1900)
1901) Jup(1,2) = Jup(1,2) + (upweight*por_up*tor_up*satg_up*(Diffg_up* &
1902) ddeng_dt_up + deng_up*dDiffg_dt_up)*(molg_up - molg_dn) &
1903) + Ddiffgas_avg*dmolg_dt_up)/(dd_up + dd_dn)*area
1904)
1905) Jdn(1,1) = Jdn(1,1) + ((1.D0 - upweight)*por_dn*tor_dn*deng_dn* &
1906) (Diffg_dn*dsatg_dp_dn + satg_dn*dDiffg_dp_dn)* &
1907) (molg_up - molg_dn) + Ddiffgas_avg*(-dmolg_dp_dn))/ &
1908) (dd_up + dd_dn)*area
1909)
1910) Jdn(1,2) = Jdn(1,2) + ((1.D0 - upweight)*por_dn*tor_dn*satg_dn*(Diffg_dn* &
1911) ddeng_dt_dn + deng_dn*dDiffg_dp_dn)*(molg_up - molg_dn) &
1912) + Ddiffgas_avg*(-dmolg_dt_dn))/(dd_up + dd_dn)*area
1913) #endif
1914) endif
1915)
1916) endif ! if (use_th_freezing)
1917)
1918)
1919) dKe_dp_up = auxvar_up%dKe_dp
1920) dKe_dp_dn = auxvar_dn%dKe_dp
1921)
1922) dKe_dt_up = auxvar_up%dKe_dt
1923) dKe_dt_dn = auxvar_dn%dKe_dt
1924)
1925) if (option%use_th_freezing) then
1926)
1927) Dk_eff_up = auxvar_up%Dk_eff
1928) Dk_eff_dn = auxvar_dn%Dk_eff
1929)
1930) Ke_fr_up = auxvar_up%ice%Ke_fr
1931) Ke_fr_dn = auxvar_dn%ice%Ke_fr
1932)
1933) dKe_fr_dt_up = auxvar_up%ice%dKe_fr_dt
1934) dKe_fr_dt_dn = auxvar_dn%ice%dKe_fr_dt
1935)
1936) dKe_fr_dp_up = auxvar_up%ice%dKe_fr_dp
1937) dKe_fr_dp_dn = auxvar_dn%ice%dKe_fr_dp
1938)
1939) else
1940)
1941) Dk_eff_up = auxvar_up%Dk_eff
1942) Dk_eff_dn = auxvar_dn%Dk_eff
1943)
1944) endif
1945)
1946) Dk = (Dk_eff_up * Dk_eff_dn) / (dd_dn*Dk_eff_up + dd_up*Dk_eff_dn)
1947)
1948) if (option%use_th_freezing) then
1949)
1950) dDk_dt_up = Dk**2/Dk_eff_up**2*dd_up*(Dk_up*dKe_dt_up + &
1951) Dk_ice_up*dKe_fr_dt_up + (- dKe_dt_up - dKe_fr_dt_up)* &
1952) Dk_dry_up)
1953) dDk_dt_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn*dKe_dt_dn + &
1954) Dk_ice_dn*dKe_fr_dt_dn + (- dKe_dt_dn - dKe_fr_dt_dn)* &
1955) Dk_dry_dn)
1956)
1957) dDk_dp_up = Dk**2/Dk_eff_up**2*dd_up*(Dk_up*dKe_dp_up + &
1958) Dk_ice_up*dKe_fr_dp_up + (- dKe_dp_up - dKe_fr_dp_up)* &
1959) Dk_dry_up)
1960)
1961) dDk_dp_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn*dKe_dp_dn + &
1962) Dk_ice_dn*dKe_fr_dp_dn + (- dKe_dp_dn - dKe_fr_dp_dn)* &
1963) Dk_dry_dn)
1964)
1965) else
1966)
1967) dDk_dt_up = Dk**2/Dk_eff_up**2*dd_up*(Dk_up - Dk_dry_up)*dKe_dt_up
1968) dDk_dt_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn - Dk_dry_dn)*dKe_dt_dn
1969)
1970) dDk_dp_up = Dk**2/Dk_eff_up**2*dd_up*(Dk_up - Dk_dry_up)*dKe_dp_up
1971) dDk_dp_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn - Dk_dry_dn)*dKe_dp_dn
1972)
1973) endif
1974)
1975) ! cond = Dk*area*(global_auxvar_up%temp-global_auxvar_dn%temp)
1976) Jup(option%nflowdof,1) = Jup(option%nflowdof,1) + &
1977) area*(global_auxvar_up%temp - &
1978) global_auxvar_dn%temp)*dDk_dp_up
1979) Jdn(option%nflowdof,1) = Jdn(option%nflowdof,1) + &
1980) area*(global_auxvar_up%temp - &
1981) global_auxvar_dn%temp)*dDk_dp_dn
1982)
1983) Jup(option%nflowdof,2) = Jup(option%nflowdof,2) + Dk*area + &
1984) area*(global_auxvar_up%temp - &
1985) global_auxvar_dn%temp)*dDk_dt_up
1986) Jdn(option%nflowdof,2) = Jdn(option%nflowdof,2) + Dk*area*(-1.d0) + &
1987) area*(global_auxvar_up%temp - &
1988) global_auxvar_dn%temp)*dDk_dt_dn
1989)
1990) ! If only solving the energy equation,
1991) ! - Set jacobian term corresponding to mass-equation to zero, and
1992) ! - Set off-diagonal jacobian terms to zero.
1993) if (option%flow%only_energy_eq) then
1994) Jup(1,1) = 0.d0
1995) Jup(1,2) = 0.d0
1996) Jup(option%nflowdof,1) = 0.d0
1997)
1998) Jdn(1,1) = 0.d0
1999) Jdn(1,2) = 0.d0
2000) Jdn(option%nflowdof,1) = 0.d0
2001)
2002) endif
2003)
2004) ! note: Res is the flux contribution, for node up J = J + Jup
2005) ! dn J = J - Jdn
2006)
2007) if (option%flow%numerical_derivatives) then
2008) call THAuxVarCopy(auxvar_up,auxvar_pert_up,option)
2009) call THAuxVarCopy(auxvar_dn,auxvar_pert_dn,option)
2010)
2011) call GlobalAuxVarInit(global_auxvar_pert_up,option)
2012) call GlobalAuxVarInit(global_auxvar_pert_dn,option)
2013) call GlobalAuxVarCopy(global_auxvar_up,global_auxvar_pert_up,option)
2014) call GlobalAuxVarCopy(global_auxvar_dn,global_auxvar_pert_dn,option)
2015)
2016) allocate(material_auxvar_pert_up,material_auxvar_pert_dn)
2017) call MaterialAuxVarInit(material_auxvar_pert_up,option)
2018) call MaterialAuxVarInit(material_auxvar_pert_dn,option)
2019) call MaterialAuxVarCopy(material_auxvar_up,material_auxvar_pert_up,option)
2020) call MaterialAuxVarCopy(material_auxvar_dn,material_auxvar_pert_dn,option)
2021)
2022) x_up(1) = global_auxvar_up%pres(1)
2023) x_up(2) = global_auxvar_up%temp
2024) x_dn(1) = global_auxvar_dn%pres(1)
2025) x_dn(2) = global_auxvar_dn%temp
2026)
2027) call THFlux( &
2028) auxvar_up,global_auxvar_up, &
2029) material_auxvar_up, &
2030) sir_up, &
2031) Dk_up, &
2032) auxvar_dn,global_auxvar_dn, &
2033) material_auxvar_dn, &
2034) sir_dn, &
2035) Dk_dn, &
2036) area, &
2037) dist, upweight, &
2038) option,v_darcy,Dk_dry_up,Dk_dry_dn, &
2039) Dk_ice_up,Dk_ice_dn, &
2040) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
2041) res)
2042)
2043) do ideriv = 1,option%nflowdof
2044) pert_up = x_up(ideriv)*perturbation_tolerance
2045) pert_dn = x_dn(ideriv)*perturbation_tolerance
2046) x_pert_up = x_up
2047) x_pert_dn = x_dn
2048)
2049) if (option%use_th_freezing) then
2050) if (ideriv == 1) then
2051) if (x_pert_up(ideriv) < option%reference_pressure) then
2052) pert_up = - pert_up
2053) endif
2054) x_pert_up(ideriv) = x_pert_up(ideriv) + pert_up
2055)
2056) if (x_pert_dn(ideriv) < option%reference_pressure) then
2057) pert_dn = - pert_dn
2058) endif
2059) x_pert_dn(ideriv) = x_pert_dn(ideriv) + pert_dn
2060) endif
2061)
2062) if (ideriv == 2) then
2063) if (x_pert_up(ideriv) < 0.d0) then
2064) pert_up = - 1.d-5
2065) else
2066) pert_up = 1.d-5
2067) endif
2068) x_pert_up(ideriv) = x_pert_up(ideriv) + pert_up
2069)
2070) if (x_pert_dn(ideriv) < 0.d0) then
2071) pert_dn = - 1.d-5
2072) else
2073) pert_dn = 1.d-5
2074) endif
2075) x_pert_dn(ideriv) = x_pert_dn(ideriv) + pert_dn
2076) endif
2077)
2078) else
2079) x_pert_up(ideriv) = x_pert_up(ideriv) + pert_up
2080) x_pert_dn(ideriv) = x_pert_dn(ideriv) + pert_dn
2081)
2082) endif
2083)
2084) if (option%use_th_freezing) then
2085) call THAuxVarComputeFreezing(x_pert_up,auxvar_pert_up, &
2086) global_auxvar_pert_up, material_auxvar_pert_up, &
2087) iphase,sat_func_up, &
2088) TH_parameter,ithrm_up, &
2089) option)
2090) call THAuxVarComputeFreezing(x_pert_dn,auxvar_pert_dn, &
2091) global_auxvar_pert_dn, material_auxvar_pert_up, &
2092) iphase,sat_func_dn, &
2093) TH_parameter,ithrm_up, &
2094) option)
2095) else
2096) call THAuxVarComputeNoFreezing(x_pert_up,auxvar_pert_up, &
2097) global_auxvar_pert_up, material_auxvar_pert_up, &
2098) iphase,sat_func_up, &
2099) TH_parameter,ithrm_up, &
2100) option)
2101) call THAuxVarComputeNoFreezing(x_pert_dn,auxvar_pert_dn, &
2102) global_auxvar_pert_dn,material_auxvar_pert_dn, &
2103) iphase,sat_func_dn, &
2104) TH_parameter,ithrm_dn, &
2105) option)
2106) endif
2107)
2108) call THFlux(auxvar_pert_up,global_auxvar_pert_up, &
2109) material_auxvar_pert_up, &
2110) sir_up, &
2111) Dk_up, &
2112) auxvar_dn,global_auxvar_dn, &
2113) material_auxvar_pert_dn, &
2114) sir_dn, &
2115) Dk_dn, &
2116) area, &
2117) dist, upweight, &
2118) option,v_darcy,Dk_dry_up, &
2119) Dk_dry_dn,Dk_ice_up,Dk_ice_dn, &
2120) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
2121) res_pert_up)
2122) call THFlux(auxvar_up,global_auxvar_up, &
2123) material_auxvar_pert_up, &
2124) sir_up,&
2125) Dk_up, &
2126) auxvar_pert_dn,global_auxvar_pert_dn, &
2127) material_auxvar_pert_dn, &
2128) sir_dn, &
2129) Dk_dn, &
2130) area, &
2131) dist, upweight, &
2132) option,v_darcy,Dk_dry_up, &
2133) Dk_dry_dn,Dk_ice_up,Dk_ice_dn, &
2134) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
2135) res_pert_dn)
2136)
2137) J_pert_up(:,ideriv) = (res_pert_up(:)-res(:))/pert_up
2138) J_pert_dn(:,ideriv) = (res_pert_dn(:)-res(:))/pert_dn
2139) enddo
2140)
2141) Jup = J_pert_up
2142) Jdn = J_pert_dn
2143) call GlobalAuxVarStrip(global_auxvar_pert_up)
2144) call GlobalAuxVarStrip(global_auxvar_pert_dn)
2145) call MaterialAuxVarStrip(material_auxvar_pert_up)
2146) call MaterialAuxVarStrip(material_auxvar_pert_dn)
2147) endif
2148)
2149) end subroutine THFluxDerivative
2150)
2151) ! ************************************************************************** !
2152) subroutine THFlux(auxvar_up,global_auxvar_up, &
2153) material_auxvar_up, &
2154) sir_up, &
2155) Dk_up, &
2156) auxvar_dn,global_auxvar_dn, &
2157) material_auxvar_dn, &
2158) sir_dn, &
2159) Dk_dn, &
2160) area, &
2161) dist, &
2162) upweight, &
2163) option,v_darcy,Dk_dry_up, &
2164) Dk_dry_dn,Dk_ice_up,Dk_ice_dn, &
2165) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
2166) Res)
2167) !
2168) ! Computes the internal flux terms for the residual
2169) !
2170) ! Author: ???
2171) ! Date: 12/13/07
2172) !
2173)
2174) use Option_module
2175) use Connection_module
2176) use EOS_Water_module
2177) use Utility_module
2178)
2179) implicit none
2180)
2181) type(TH_auxvar_type) :: auxvar_up, auxvar_dn
2182) type(global_auxvar_type) :: global_auxvar_up, global_auxvar_dn
2183) class(material_auxvar_type) :: material_auxvar_up, material_auxvar_dn
2184) type(option_type) :: option
2185) PetscReal :: sir_up, sir_dn
2186) PetscReal :: dd_up, dd_dn
2187) PetscReal :: Dk_up, Dk_dn
2188) PetscReal :: Dk_dry_up, Dk_dry_dn
2189) PetscReal :: Dk_ice_up, Dk_ice_dn
2190) PetscReal :: alpha_up, alpha_dn
2191) PetscReal :: alpha_fr_up, alpha_fr_dn
2192) PetscReal :: Dk_eff_up, Dk_eff_dn
2193) PetscReal :: v_darcy,area
2194) PetscReal :: Res(1:option%nflowdof)
2195) PetscReal :: dist(-1:3)
2196) PetscInt :: ispec
2197) PetscReal :: fluxm,fluxe,q
2198) PetscReal :: uh,ukvr,DK,Dq
2199) PetscReal :: upweight,density_ave,cond,gravity,dphi
2200) PetscReal, parameter :: epsilon = 1.d-6
2201)
2202) PetscReal :: por_up, por_dn
2203) PetscReal :: tor_up, tor_dn
2204) PetscReal :: perm_up, perm_dn
2205)
2206) ! ice variables
2207) PetscReal :: dist_gravity ! distance along gravity vector
2208) PetscReal :: Ddiffgas_avg, Ddiffgas_up, Ddiffgas_dn
2209) PetscReal :: p_g
2210) PetscReal :: deng_up, deng_dn
2211) PetscReal :: psat_up, psat_dn
2212) PetscReal :: molg_up, molg_dn
2213) PetscReal :: satg_up, satg_dn
2214) PetscReal :: Diffg_up, Diffg_dn
2215) PetscReal :: Diffg_ref, p_ref, T_ref
2216) PetscErrorCode :: ierr
2217) PetscReal :: Ke_fr_up,Ke_fr_dn ! frozen soil Kersten numbers
2218) PetscReal :: fv_up, fv_dn
2219)
2220) call ConnectionCalculateDistances(dist,option%gravity,dd_up,dd_dn, &
2221) dist_gravity,upweight)
2222) call material_auxvar_up%PermeabilityTensorToScalar(dist,perm_up)
2223) call material_auxvar_dn%PermeabilityTensorToScalar(dist,perm_dn)
2224)
2225) por_up = material_auxvar_up%porosity
2226) por_dn = material_auxvar_dn%porosity
2227)
2228) tor_up = material_auxvar_up%tortuosity
2229) tor_dn = material_auxvar_dn%tortuosity
2230)
2231) Dq = (perm_up * perm_dn)/(dd_up*perm_dn + dd_dn*perm_up)
2232)
2233) fluxm = 0.D0
2234) fluxe = 0.D0
2235) v_darcy = 0.D0
2236)
2237) ! Flow term
2238) if (global_auxvar_up%sat(1) > sir_up .or. global_auxvar_dn%sat(1) > sir_dn) then
2239) if (global_auxvar_up%sat(1) < eps) then
2240) upweight=0.d0
2241) else if (global_auxvar_dn%sat(1) < eps) then
2242) upweight=1.d0
2243) endif
2244) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_dn%den(1)
2245)
2246) gravity = (upweight*global_auxvar_up%den(1)*auxvar_up%avgmw + &
2247) (1.D0-upweight)*global_auxvar_dn%den(1)*auxvar_dn%avgmw) &
2248) * dist_gravity
2249)
2250) if (option%ice_model /= DALL_AMICO) then
2251) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
2252) else
2253) dphi = auxvar_up%ice%pres_fh2o - auxvar_dn%ice%pres_fh2o + gravity
2254) endif
2255)
2256) if (dphi >= 0.D0) then
2257) ukvr = auxvar_up%kvr
2258) uh = auxvar_up%h
2259) else
2260) ukvr = auxvar_dn%kvr
2261) uh = auxvar_dn%h
2262) endif
2263)
2264) call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, dphi, &
2265) option%rel_perm_aveg, ukvr)
2266) !call InterfaceApprox(auxvar_up%h, auxvar_dn%h, dphi, &
2267) ! option%rel_perm_aveg, uh)
2268)
2269) if (ukvr > floweps) then
2270) v_darcy = Dq * ukvr * dphi
2271)
2272) ! If only solving the energy equation, ensure Res(2) has no
2273) ! contribution from mass equation by setting darcy velocity
2274) ! to be zero
2275) if (option%flow%only_energy_eq) v_darcy = 0.d0
2276)
2277) q = v_darcy * area
2278)
2279) fluxm = fluxm + q*density_ave
2280) fluxe = fluxe + q*density_ave*uh
2281) endif
2282) endif
2283)
2284)
2285) if (option%use_th_freezing) then
2286) ! Added by Satish Karra, 10/24/11
2287) satg_up = auxvar_up%ice%sat_gas
2288) satg_dn = auxvar_dn%ice%sat_gas
2289) if ((satg_up > eps) .and. (satg_dn > eps)) then
2290) p_g = option%reference_pressure ! set to reference pressure
2291) deng_up = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + 273.15d0))*1.d-3
2292) deng_dn = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + 273.15d0))*1.d-3
2293)
2294) Diffg_ref = 2.13D-5 ! Reference diffusivity, need to read from input file
2295) p_ref = 1.01325d5 ! in Pa
2296) T_ref = 25.d0 ! in deg C
2297)
2298) Diffg_up = Diffg_ref*(p_ref/p_g)*((global_auxvar_up%temp + 273.15d0)/ &
2299) (T_ref + 273.15d0))**(1.8)
2300) Diffg_dn = Diffg_ref*(p_ref/p_g)*((global_auxvar_dn%temp + 273.15d0)/ &
2301) (T_ref + 273.15d0))**(1.8)
2302)
2303) Ddiffgas_up = por_up*tor_up*satg_up*deng_up*Diffg_up
2304) Ddiffgas_dn = por_dn*tor_dn*satg_dn*deng_dn*Diffg_dn
2305) call EOSWaterSaturationPressure(global_auxvar_up%temp, psat_up, ierr)
2306) call EOSWaterSaturationPressure(global_auxvar_dn%temp, psat_dn, ierr)
2307)
2308) ! vapor pressure lowering due to capillary pressure
2309) fv_up = exp(-auxvar_up%pc/(global_auxvar_up%den(1)* &
2310) IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + 273.15d0)))
2311) fv_dn = exp(-auxvar_dn%pc/(global_auxvar_dn%den(1)* &
2312) IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + 273.15d0)))
2313)
2314) molg_up = psat_up*fv_up/p_g
2315) molg_dn = psat_dn*fv_dn/p_g
2316)
2317) if (molg_up > molg_dn) then
2318) upweight = 0.d0
2319) else
2320) upweight = 1.d0
2321) endif
2322)
2323) Ddiffgas_avg = upweight*Ddiffgas_up + (1.D0 - upweight)*Ddiffgas_dn
2324) #ifndef NO_VAPOR_DIFFUSION
2325) fluxm = fluxm + Ddiffgas_avg*area*(molg_up - molg_dn)/ &
2326) (dd_up + dd_dn)
2327) #endif
2328)
2329) endif
2330)
2331) endif ! if (use_th_freezing)
2332)
2333) if (option%use_th_freezing) then
2334)
2335) Ke_fr_up = auxvar_up%ice%Ke_fr
2336) Ke_fr_dn = auxvar_dn%ice%Ke_fr
2337)
2338) Dk_eff_up = auxvar_up%Dk_eff
2339) Dk_eff_dn = auxvar_dn%Dk_eff
2340) else
2341)
2342) Dk_eff_up = auxvar_up%Dk_eff
2343) Dk_eff_dn = auxvar_dn%Dk_eff
2344)
2345) endif
2346)
2347) Dk = (Dk_eff_up * Dk_eff_dn) / (dd_dn*Dk_eff_up + dd_up*Dk_eff_dn)
2348) cond = Dk*area*(global_auxvar_up%temp - global_auxvar_dn%temp)
2349)
2350) fluxe = fluxe + cond
2351)
2352) ! If only solving the energy equation, ensure Res(1) is zero
2353) if (option%flow%only_energy_eq) fluxm = 0.d0
2354)
2355) Res(1:option%nflowdof-1) = fluxm
2356) Res(option%nflowdof) = fluxe
2357)
2358) ! note: Res is the flux contribution, for node 1 R = R + Res_FL
2359) ! 2 R = R - Res_FL
2360)
2361)
2362) end subroutine THFlux
2363)
2364) ! ************************************************************************** !
2365)
2366) subroutine THBCFluxDerivative(ibndtype,auxvars, &
2367) auxvar_up,global_auxvar_up, &
2368) auxvar_dn,global_auxvar_dn, &
2369) material_auxvar_dn, &
2370) sir_dn, &
2371) Dk_dn, &
2372) area, &
2373) dist, &
2374) option, &
2375) sat_func_dn,&
2376) Dk_dry_dn, &
2377) Dk_ice_dn, &
2378) Jdn)
2379) !
2380) ! Computes the derivatives of the boundary flux
2381) ! terms for the Jacobian
2382) !
2383) ! Author: ???
2384) ! Date: 12/13/07
2385) !
2386) use Option_module
2387) use Saturation_Function_module
2388) use Connection_module
2389) use EOS_Water_module
2390) use Utility_module
2391)
2392) implicit none
2393)
2394) PetscInt :: ibndtype(:)
2395) type(TH_auxvar_type) :: auxvar_up, auxvar_dn
2396) type(global_auxvar_type) :: global_auxvar_up, global_auxvar_dn
2397) class(material_auxvar_type) :: material_auxvar_dn
2398) type(option_type) :: option
2399) PetscReal :: sir_dn
2400) PetscReal :: auxvars(:) ! from aux_real_var array in boundary condition
2401) PetscReal :: por_dn,perm_dn,Dk_dn,tor_dn
2402) PetscReal :: area
2403) type(saturation_function_type) :: sat_func_dn
2404) PetscReal :: Dk_dry_dn
2405) PetscReal :: Dk_ice_dn
2406) PetscReal :: alpha_dn
2407) PetscReal :: alpha_fr_dn
2408) PetscReal :: Jdn(option%nflowdof,option%nflowdof)
2409) PetscReal :: dist(-1:3)
2410)
2411) PetscReal :: dist_gravity ! distance along gravity vector
2412)
2413) PetscReal :: dd_dn
2414) PetscInt :: ispec
2415) PetscReal :: v_darcy
2416) PetscReal :: fluxm,fluxe,q,density_ave
2417) PetscReal :: uh,ukvr,diff,diffdp,DK,Dq
2418) PetscReal :: upweight,cond,gravity,dphi
2419)
2420) PetscReal :: ddiff_dp_dn, ddiff_dt_dn
2421) PetscReal :: dden_ave_dp_dn, dden_ave_dt_dn
2422) PetscReal :: dgravity_dden_dn
2423) PetscReal :: dphi_dp_dn, dphi_dt_dn
2424) PetscReal :: dukvr_dp_dn, dukvr_dt_dn
2425) PetscReal :: duh_dp_dn, duh_dt_dn
2426) PetscReal :: dq_dp_dn, dq_dt_dn
2427) PetscReal :: Dk_eff_dn
2428) PetscReal :: dDk_dt_dn, dDk_dp_dn
2429) PetscReal :: dKe_dt_dn, dKe_dp_dn
2430) PetscReal :: dKe_fr_dt_dn, dKe_fr_dp_dn
2431)
2432) PetscInt :: iphase, ideriv
2433) type(TH_auxvar_type) :: auxvar_pert_dn, auxvar_pert_up
2434) type(global_auxvar_type) :: global_auxvar_pert_dn, global_auxvar_pert_up
2435) class(material_auxvar_type), allocatable :: material_auxvar_pert_dn, &
2436) material_auxvar_pert_up
2437)
2438) PetscReal :: perturbation
2439) PetscReal :: x_up(option%nflowdof), x_dn(option%nflowdof)
2440) PetscReal :: x_pert_up(option%nflowdof), x_pert_dn(option%nflowdof)
2441) PetscReal :: pert_up, pert_dn
2442) PetscReal :: res(option%nflowdof)
2443) PetscReal :: res_pert_up(option%nflowdof)
2444) PetscReal :: res_pert_dn(option%nflowdof)
2445) PetscReal :: J_pert_dn(option%nflowdof,option%nflowdof)
2446)
2447) PetscBool :: hw_present
2448)
2449) ! ice variables
2450) PetscReal :: Ddiffgas_avg, Ddiffgas_up, Ddiffgas_dn
2451) PetscReal :: p_g
2452) PetscReal :: deng_up, deng_dn
2453) PetscReal :: psat_up, psat_dn
2454) PetscReal :: molg_up, molg_dn
2455) PetscReal :: satg_up, satg_dn
2456) PetscReal :: Diffg_up, Diffg_dn
2457) PetscReal :: ddeng_dt_dn
2458) PetscReal :: dpsat_dt_dn
2459) PetscReal :: dmolg_dt_dn
2460) PetscReal :: dDiffg_dt_dn
2461) PetscReal :: dDiffg_dp_dn
2462) PetscReal :: dsatg_dp_dn
2463) PetscReal :: Diffg_ref, p_ref, T_ref
2464) PetscErrorCode :: ierr
2465) PetscReal :: v_darcy_allowable
2466) PetscReal :: dum1
2467) PetscReal :: T_th,fct,fctT,dfctT_dT
2468) PetscReal :: rho
2469) PetscReal :: dq_lin,dP_lin
2470) PetscReal :: q_approx,dq_approx
2471)
2472) T_th = 0.5d0
2473)
2474) fluxm = 0.d0
2475) fluxe = 0.d0
2476) v_darcy = 0.d0
2477) density_ave = 0.d0
2478) q = 0.d0
2479)
2480) Jdn = 0.d0
2481)
2482) dden_ave_dp_dn = 0.d0
2483) dden_ave_dt_dn = 0.d0
2484) ddiff_dp_dn = 0.d0
2485) ddiff_dt_dn = 0.d0
2486) dgravity_dden_dn = 0.d0
2487) dphi_dp_dn = 0.d0
2488) dphi_dt_dn = 0.d0
2489) dukvr_dp_dn = 0.d0
2490) dukvr_dt_dn = 0.d0
2491) duh_dp_dn = 0.d0
2492) duh_dt_dn = 0.d0
2493) dq_dp_dn = 0.d0
2494) dq_dt_dn = 0.d0
2495)
2496) hw_present = PETSC_FALSE
2497) if (associated(auxvar_dn%surface)) then
2498) hw_present = auxvar_dn%surface%surf_wat
2499) endif
2500)
2501) dist_gravity = dist(0) * dot_product(option%gravity,dist(1:3))
2502) dd_dn = dist(0)
2503)
2504) call material_auxvar_dn%PermeabilityTensorToScalar(dist,perm_dn)
2505) por_dn = material_auxvar_dn%porosity
2506) tor_dn = material_auxvar_dn%tortuosity
2507)
2508) ! Flow
2509) diffdp = por_dn*tor_dn/dd_dn*area
2510) select case(ibndtype(TH_PRESSURE_DOF))
2511) ! figure out the direction of flow
2512) case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC)
2513) Dq = perm_dn / dd_dn
2514) ! Flow term
2515) if (global_auxvar_up%sat(1) > sir_dn .or. global_auxvar_dn%sat(1) > sir_dn) then
2516) upweight=1.D0
2517) if (global_auxvar_up%sat(1) < eps) then
2518) upweight=0.d0
2519) else if (global_auxvar_dn%sat(1) < eps) then
2520) upweight=1.d0
2521) endif
2522)
2523) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_dn%den(1)
2524) dden_ave_dp_dn = (1.D0-upweight)*auxvar_dn%dden_dp
2525) dden_ave_dt_dn = (1.D0-upweight)*auxvar_dn%dden_dt
2526)
2527) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2528) dden_ave_dt_dn = dden_ave_dt_dn + upweight*auxvar_up%dden_dt
2529) endif
2530)
2531) gravity = (upweight*global_auxvar_up%den(1)*auxvar_up%avgmw + &
2532) (1.D0-upweight)*global_auxvar_dn%den(1)*auxvar_dn%avgmw) &
2533) * dist_gravity
2534) dgravity_dden_dn = (1.d0-upweight)*auxvar_dn%avgmw*dist_gravity
2535)
2536) if (option%ice_model /= DALL_AMICO) then
2537) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
2538) dphi_dp_dn = -1.d0 + dgravity_dden_dn*auxvar_dn%dden_dp
2539) dphi_dt_dn = dgravity_dden_dn*auxvar_dn%dden_dt
2540) else
2541) dphi = auxvar_up%ice%pres_fh2o - auxvar_dn%ice%pres_fh2o + gravity
2542) dphi_dp_dn = -auxvar_dn%ice%dpres_fh2o_dp + dgravity_dden_dn*auxvar_dn%dden_dp
2543) dphi_dt_dn = -auxvar_dn%ice%dpres_fh2o_dt + dgravity_dden_dn*auxvar_dn%dden_dt
2544) endif
2545)
2546) if (ibndtype(TH_PRESSURE_DOF) == SEEPAGE_BC) then
2547) ! flow in ! boundary cell is <= pref
2548) if (dphi > 0.d0 .and. global_auxvar_up%pres(1)-option%reference_pressure < eps) then
2549) dphi = 0.d0
2550) dphi_dp_dn = 0.d0
2551) dphi_dt_dn = 0.d0
2552) endif
2553) endif
2554)
2555) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2556) !( dgravity_dden_up ) (dden_dt_up)
2557) dphi_dt_dn = dphi_dt_dn + upweight*auxvar_up%avgmw*dist_gravity*auxvar_up%dden_dt
2558) endif
2559)
2560) if (dphi>=0.D0) then
2561) ukvr = auxvar_up%kvr
2562) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2563) dukvr_dt_dn = auxvar_up%dkvr_dt
2564) endif
2565) else
2566) ukvr = auxvar_dn%kvr
2567) dukvr_dp_dn = auxvar_dn%dkvr_dp
2568) dukvr_dt_dn = auxvar_dn%dkvr_dt
2569) endif
2570)
2571) if (ukvr*Dq>floweps) then
2572) v_darcy = Dq * ukvr * dphi
2573) q = v_darcy * area
2574) dq_dp_dn = Dq*(dukvr_dp_dn*dphi+ukvr*dphi_dp_dn)*area
2575) dq_dt_dn = Dq*(dukvr_dt_dn*dphi+ukvr*dphi_dt_dn)*area
2576) endif
2577) endif
2578)
2579) case(HET_SURF_SEEPAGE_BC)
2580) Dq = perm_dn / dd_dn
2581) ! Flow term
2582) if (global_auxvar_up%sat(1) > sir_dn .or. global_auxvar_dn%sat(1) > sir_dn) then
2583) upweight=1.D0
2584) if (global_auxvar_up%sat(1) < eps) then
2585) upweight=0.d0
2586) else if (global_auxvar_dn%sat(1) < eps) then
2587) upweight=1.d0
2588) endif
2589)
2590) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_dn%den(1)
2591) dden_ave_dp_dn = (1.D0-upweight)*auxvar_dn%dden_dp
2592) dden_ave_dt_dn = (1.D0-upweight)*auxvar_dn%dden_dt
2593)
2594) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2595) dden_ave_dt_dn = dden_ave_dt_dn + upweight*auxvar_up%dden_dt
2596) endif
2597)
2598) gravity = (upweight*global_auxvar_up%den(1)*auxvar_up%avgmw + &
2599) (1.D0-upweight)*global_auxvar_dn%den(1)*auxvar_dn%avgmw) &
2600) * dist_gravity
2601) dgravity_dden_dn = (1.d0-upweight)*auxvar_dn%avgmw*dist_gravity
2602)
2603) if (option%ice_model /= DALL_AMICO) then
2604) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
2605) dphi_dp_dn = -1.d0 + dgravity_dden_dn*auxvar_dn%dden_dp
2606) dphi_dt_dn = dgravity_dden_dn*auxvar_dn%dden_dt
2607) else
2608) dphi = auxvar_up%ice%pres_fh2o - auxvar_dn%ice%pres_fh2o + gravity
2609) dphi_dp_dn = -auxvar_dn%ice%dpres_fh2o_dp + dgravity_dden_dn*auxvar_dn%dden_dp
2610) dphi_dt_dn = -auxvar_dn%ice%dpres_fh2o_dt + dgravity_dden_dn*auxvar_dn%dden_dt
2611) endif
2612)
2613) ! flow in ! boundary cell is <= pref
2614) if (dphi > 0.d0 .and. global_auxvar_up%pres(1)-option%reference_pressure < eps) then
2615) dphi = 0.d0
2616) dphi_dp_dn = 0.d0
2617) dphi_dt_dn = 0.d0
2618) endif
2619)
2620)
2621) if (option%surf_flow_on) then
2622) ! ---------------------------
2623) ! Surface-subsurface simulation
2624) ! ---------------------------
2625)
2626) ! If surface-water is frozen, zero out the darcy velocity
2627) if (global_auxvar_up%temp < 0.d0) then
2628) dphi = 0.d0
2629) dphi_dp_dn = 0.d0
2630) dphi_dt_dn = 0.d0
2631) endif
2632) endif
2633)
2634) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2635) !( dgravity_dden_up ) (dden_dt_up)
2636) dphi_dt_dn = dphi_dt_dn + upweight*auxvar_up%avgmw*dist_gravity*auxvar_up%dden_dt
2637) endif
2638)
2639) if (dphi>=0.D0) then
2640) ukvr = auxvar_up%kvr
2641) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2642) dukvr_dt_dn = auxvar_up%dkvr_dt
2643) endif
2644) else
2645) ukvr = auxvar_dn%kvr
2646) dukvr_dp_dn = auxvar_dn%dkvr_dp
2647) dukvr_dt_dn = auxvar_dn%dkvr_dt
2648) endif
2649)
2650) !call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, &
2651) ! auxvar_up%dkvr_dp, auxvar_dn%dkvr_dp, &
2652) ! dphi, &
2653) ! option%rel_perm_aveg, &
2654) ! ukvr, dum1, dukvr_dp_dn)
2655) !call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, &
2656) ! auxvar_up%dkvr_dt, auxvar_dn%dkvr_dt, &
2657) ! dphi, &
2658) ! option%rel_perm_aveg, &
2659) ! ukvr, dum1, dukvr_dt_dn)
2660)
2661) if (ukvr*Dq>floweps) then
2662) v_darcy = Dq * ukvr * dphi
2663) q = v_darcy * area
2664) dq_dp_dn = Dq*(dukvr_dp_dn*dphi+ukvr*dphi_dp_dn)*area
2665) dq_dt_dn = Dq*(dukvr_dt_dn*dphi+ukvr*dphi_dt_dn)*area
2666)
2667) if (option%surf_flow_on .and. &
2668) option%subsurf_surf_coupling /= DECOUPLED) then
2669)
2670) ! ---------------------------
2671) ! Surface-subsurface simulation
2672) ! ---------------------------
2673)
2674) ! Temperature-smoothing
2675) fctT = 1.d0
2676) dfctT_dT = 0.d0
2677) if (global_auxvar_up%temp < 0.d0) then
2678) ! surface water is frozen, so no flow can occur
2679) fctT = 0.d0
2680) dfctT_dT = 0.d0
2681) else
2682) ! if subsurface is close to frozen, smoothly throttle down the flow
2683) if (global_auxvar_dn%temp < 0.d0) then
2684) fctT = 0.d0
2685) dfctT_dT = 0.d0
2686) else if (global_auxvar_dn%temp > T_th) then
2687) fctT = 1.d0
2688) dfctT_dt = 0.d0
2689) else
2690) fct = 1.d0-(global_auxvar_dn%temp/T_th)**2.d0
2691) fctT = 1.d0-fct**2.d0
2692) dfctT_dT = 4.d0*global_auxvar_dn%temp/(T_th*T_th)*fct
2693) endif
2694) endif
2695)
2696) ! Pressure-smoothing
2697) if (.not. auxvar_dn%surface%bcflux_default_scheme) then
2698) if (global_auxvar_dn%pres(1) <= auxvar_dn%surface%P_min) then
2699)
2700) ! Linear approximation
2701) call Interpolate(auxvar_dn%surface%range_for_linear_approx(2), &
2702) auxvar_dn%surface%range_for_linear_approx(1), &
2703) global_auxvar_dn%pres(1), &
2704) auxvar_dn%surface%range_for_linear_approx(4), &
2705) auxvar_dn%surface%range_for_linear_approx(3), &
2706) q_approx)
2707) v_darcy = q_approx/area
2708)
2709) dP_lin = auxvar_dn%surface%range_for_linear_approx(2) - &
2710) auxvar_dn%surface%range_for_linear_approx(1)
2711) dq_lin = auxvar_dn%surface%range_for_linear_approx(4) - &
2712) auxvar_dn%surface%range_for_linear_approx(3)
2713) if (abs(dP_lin) < 1.d-10) dP_lin = 1.d-10
2714)
2715) dq_dp_dn = dq_lin/dP_lin
2716)
2717) ! Approximation:
2718) ! q_approx = q_min + slope*(P_dn - P_min)
2719) !
2720) ! Derivative of approximation w.r.t T_dn:
2721) ! d(q_approx)/dT_dn = d(q_min)/dT_dn +
2722) ! d(slope)/dT_dn*(P_dn - P_min) +
2723) ! slope*(0 - d(P_min)/dT_dn)
2724) ! Note:
2725) ! d(q_min)/dT_dn = 0
2726) ! d(P_min)/dT_dn = 0
2727) ! slope*(0 - d(P_min)/dT_dn)
2728) dq_dt_dn = auxvar_dn%surface%dlinear_slope_dT* &
2729) (global_auxvar_dn%pres(1) - &
2730) auxvar_dn%surface%range_for_linear_approx(1))
2731)
2732) else if (global_auxvar_dn%pres(1) <= auxvar_dn%surface%P_max) then
2733)
2734) ! Cubic approximation
2735) call CubicPolynomialEvaluate(auxvar_dn%surface%coeff_for_cubic_approx, &
2736) global_auxvar_dn%pres(1) - option%reference_pressure, &
2737) q_approx, dq_approx)
2738) v_darcy = q_approx/area
2739) dq_dp_dn = dq_approx
2740)
2741) call CubicPolynomialEvaluate(auxvar_dn%surface%coeff_for_deriv_cubic_approx, &
2742) global_auxvar_dn%pres(1) - option%reference_pressure, &
2743) dq_dt_dn, dum1)
2744)
2745) endif
2746) endif
2747)
2748) ! Apply temperature smoothing
2749) v_darcy = v_darcy*fctT
2750) q = v_darcy*area
2751) dq_dp_dn = dq_dp_dn*fctT
2752) dq_dt_dn = dq_dt_dn*fctT + q*dfctT_dT
2753)
2754) endif
2755) endif
2756) endif
2757)
2758) case(NEUMANN_BC)
2759) if (dabs(auxvars(TH_PRESSURE_DOF)) > floweps) then
2760) v_darcy = auxvars(TH_PRESSURE_DOF)
2761) if (v_darcy > 0.d0) then
2762) density_ave = global_auxvar_up%den(1)
2763) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2764) dden_ave_dt_dn = auxvar_up%dden_dt
2765) endif
2766) else
2767) density_ave = global_auxvar_dn%den(1)
2768) dden_ave_dp_dn = auxvar_dn%dden_dp
2769) dden_ave_dt_dn = auxvar_dn%dden_dt
2770) endif
2771) q = v_darcy * area
2772) endif
2773)
2774) case(ZERO_GRADIENT_BC)
2775) ! do nothing
2776)
2777) end select
2778)
2779) if (v_darcy >= 0.D0) then
2780) uh = auxvar_up%h
2781) if (ibndtype(TH_PRESSURE_DOF) == ZERO_GRADIENT_BC) then
2782) duh_dp_dn = auxvar_up%dh_dp
2783) endif
2784) if (ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC) then
2785) duh_dt_dn = auxvar_up%dh_dt
2786) endif
2787) else
2788) uh = auxvar_dn%h
2789) duh_dp_dn = auxvar_dn%dh_dp
2790) duh_dt_dn = auxvar_dn%dh_dt
2791) endif
2792)
2793) !call InterfaceApprox(auxvar_up%h, auxvar_dn%h, &
2794) ! auxvar_up%dh_dp, auxvar_dn%dh_dp, &
2795) ! dphi, &
2796) ! option%rel_perm_aveg, &
2797) ! uh, dum1, duh_dp_dn)
2798) !call InterfaceApprox(auxvar_up%h, auxvar_dn%h, &
2799) ! auxvar_up%dh_dt, auxvar_dn%dh_dt, &
2800) ! dphi, &
2801) ! option%rel_perm_aveg, &
2802) ! uh, dum1, duh_dt_dn)
2803)
2804) Jdn(1,1) = (dq_dp_dn*density_ave+q*dden_ave_dp_dn)
2805) Jdn(1,2) = (dq_dt_dn*density_ave+q*dden_ave_dt_dn)
2806)
2807) ! If only solving the energy equation, ensure Jdn(2,2) has no
2808) ! contribution from mass equation
2809) if (option%flow%only_energy_eq) then
2810) q = 0.d0
2811) dq_dt_dn = 0.d0
2812) endif
2813)
2814) ! based on flux = q*density_ave*uh
2815) Jdn(option%nflowdof,1) = &
2816) ((dq_dp_dn*density_ave+q*dden_ave_dp_dn)*uh+q*density_ave*duh_dp_dn)
2817) Jdn(option%nflowdof,2) = &
2818) ((dq_dt_dn*density_ave+q*dden_ave_dt_dn)*uh+q*density_ave*duh_dt_dn)
2819)
2820) ! Conduction term
2821) select case(ibndtype(TH_TEMPERATURE_DOF))
2822) case(DIRICHLET_BC,HET_DIRICHLET)
2823) Dk = auxvar_dn%Dk_eff / dd_dn
2824) !cond = Dk*area*(global_auxvar_up%temp-global_auxvar_dn%temp)
2825)
2826) if (option%use_th_freezing) then
2827) Dk_eff_dn = auxvar_dn%Dk_eff
2828) dKe_dp_dn = auxvar_dn%dKe_dp
2829) dKe_dt_dn = auxvar_dn%dKe_dt
2830) dKe_fr_dt_dn = auxvar_dn%ice%dKe_fr_dt
2831) dKe_fr_dp_dn = auxvar_dn%ice%dKe_fr_dp
2832) Dk = Dk_eff_dn/dd_dn
2833)
2834) dDk_dt_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn*dKe_dt_dn + &
2835) Dk_ice_dn*dKe_fr_dt_dn + (- dKe_dt_dn - dKe_fr_dt_dn)* &
2836) Dk_dry_dn)
2837) dDk_dp_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn*dKe_dp_dn + &
2838) Dk_ice_dn*dKe_fr_dp_dn + (- dKe_dp_dn - dKe_fr_dp_dn)* &
2839) Dk_dry_dn)
2840)
2841) else
2842)
2843) Dk_eff_dn = auxvar_dn%Dk_eff
2844) dKe_dp_dn = auxvar_dn%dKe_dp
2845) dKe_dt_dn = auxvar_dn%dKe_dt
2846) Dk = Dk_eff_dn/dd_dn
2847)
2848) dDk_dt_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn - Dk_dry_dn)*dKe_dt_dn
2849) dDk_dp_dn = Dk**2/Dk_eff_dn**2*dd_dn*(Dk_dn - Dk_dry_dn)*dKe_dp_dn
2850)
2851) endif
2852)
2853) if (.not. option%surf_flow_on) then
2854) ! ---------------------------
2855) ! Subsurface only simulation
2856) ! ---------------------------
2857) Jdn(option%nflowdof,1) = Jdn(option%nflowdof,1) + &
2858) area*(global_auxvar_up%temp - global_auxvar_dn%temp)*dDk_dp_dn
2859)
2860) Jdn(option%nflowdof,2) = Jdn(option%nflowdof,2) + Dk*area*(-1.d0) + &
2861) area*(global_auxvar_up%temp - global_auxvar_dn%temp)*dDk_dt_dn
2862) else
2863) ! ---------------------------
2864) ! Surface-subsurface simulation
2865) ! ---------------------------
2866) if (ibndtype(TH_PRESSURE_DOF) /= HET_SURF_SEEPAGE_BC) then
2867) if (.not.(hw_present)) then
2868) Jdn(option%nflowdof,1) = Jdn(option%nflowdof,1) + &
2869) area*(global_auxvar_up%temp - global_auxvar_dn%temp)*dDk_dp_dn
2870)
2871) Jdn(option%nflowdof,2) = Jdn(option%nflowdof,2) + Dk*area*(-1.d0) + &
2872) area*(global_auxvar_up%temp - global_auxvar_dn%temp)*dDk_dt_dn
2873) else
2874) Jdn = 0.d0
2875) endif
2876) else
2877) ! Only add contribution to Jacboian term for heat equation if
2878) ! standing water is present
2879) if (hw_present) then
2880) Jdn(option%nflowdof,1) = Jdn(option%nflowdof,1) + &
2881) area*(global_auxvar_up%temp - global_auxvar_dn%temp)*dDk_dp_dn
2882)
2883) Jdn(option%nflowdof,2) = Jdn(option%nflowdof,2) + Dk*area*(-1.d0) + &
2884) area*(global_auxvar_up%temp - global_auxvar_dn%temp)*dDk_dt_dn
2885) endif
2886) endif
2887) endif
2888) if (option%use_th_freezing) then
2889) ! Added by Satish Karra, 11/21/11
2890) satg_up = auxvar_up%ice%sat_gas
2891) satg_dn = auxvar_dn%ice%sat_gas
2892) if ((satg_up > eps) .and. (satg_dn > eps)) then
2893) p_g = option%reference_pressure ! set to reference pressure
2894) deng_up = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + &
2895) 273.15d0))*1.d-3
2896) deng_dn = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + &
2897) 273.15d0))*1.d-3
2898)
2899) Diffg_ref = 2.13D-5 ! Reference diffusivity, need to read from input file
2900) p_ref = 1.01325d5 ! in Pa
2901) T_ref = 25.d0 ! in deg C
2902)
2903) Diffg_up = Diffg_ref*(p_ref/p_g)*((global_auxvar_up%temp + &
2904) 273.15d0)/(T_ref + 273.15d0))**(1.8)
2905) Diffg_dn = Diffg_ref*(p_ref/p_g)*((global_auxvar_dn%temp + &
2906) 273.15d0)/(T_ref + 273.15d0))**(1.8)
2907) Ddiffgas_up = satg_up*deng_up*Diffg_up
2908) Ddiffgas_dn = satg_dn*deng_dn*Diffg_dn
2909) call EOSWaterSaturationPressure(global_auxvar_up%temp, psat_up, ierr)
2910) call EOSWaterSaturationPressure(global_auxvar_dn%temp, psat_dn, dpsat_dt_dn, ierr)
2911) molg_up = psat_up/p_g
2912) molg_dn = psat_dn/p_g
2913) ddeng_dt_dn = - p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + &
2914) 273.15d0)**2)*1.d-3
2915) dmolg_dt_dn = (1/p_g)*dpsat_dt_dn
2916) dDiffg_dt_dn = 1.8*Diffg_dn/(global_auxvar_dn%temp + 273.15d0)
2917) dDiffg_dp_dn = 0.d0
2918) dsatg_dp_dn = auxvar_dn%ice%dsat_gas_dp
2919)
2920) if (molg_up > molg_dn) then
2921) upweight = 0.d0
2922) else
2923) upweight = 1.d0
2924) endif
2925)
2926) Ddiffgas_avg = upweight*Ddiffgas_up+(1.D0 - upweight)*Ddiffgas_dn
2927)
2928) Jdn(1,1) = Jdn(1,1) + por_dn*tor_dn*(1.D0 - upweight)* &
2929) Ddiffgas_dn/satg_dn*dsatg_dp_dn*(molg_up - molg_dn)/dd_dn* &
2930) area
2931) Jdn(1,2) = Jdn(1,2) + por_dn*tor_dn*(1.D0 - upweight)* &
2932) (Ddiffgas_avg/deng_dn*ddeng_dt_dn + Ddiffgas_avg/Diffg_dn* &
2933) dDiffg_dt_dn)*(molg_up - molg_dn)/dd_dn*area + por_dn* &
2934) tor_dn*Ddiffgas_avg*(-dmolg_dt_dn)/dd_dn*area
2935) endif
2936) endif ! if (use_th_freezing)
2937)
2938) end select
2939)
2940) ! If only solving the energy equation,
2941) ! - Set jacobian term corresponding to mass-equation to zero, and
2942) ! - Set off-diagonal jacobian terms to zero.
2943) if (option%flow%only_energy_eq) then
2944) Jdn(1,1) = 0.d0
2945) Jdn(1,2) = 0.d0
2946) Jdn(option%nflowdof,1) = 0.d0
2947) endif
2948)
2949) #if 0
2950) if (option%flow%numerical_derivatives) then
2951) allocate(material_auxvar_pert_up,material_auxvar_pert_dn)
2952)
2953) call MaterialAuxVarInit(material_auxvar_pert_up,option)
2954) call MaterialAuxVarInit(material_auxvar_pert_dn,option)
2955)
2956) call GlobalAuxVarInit(global_auxvar_pert_up,option)
2957) call GlobalAuxVarInit(global_auxvar_pert_dn,option)
2958) call THAuxVarCopy(auxvar_up,auxvar_pert_up,option)
2959) call THAuxVarCopy(auxvar_dn,auxvar_pert_dn,option)
2960) call GlobalAuxVarCopy(global_auxvar_up,global_auxvar_pert_up,option)
2961) call GlobalAuxVarCopy(global_auxvar_dn,global_auxvar_pert_dn,option)
2962)
2963) call MaterialAuxVarCopy(material_auxvar_dn,material_auxvar_pert_up, &
2964) option)
2965) call MaterialAuxVarCopy(material_auxvar_dn,material_auxvar_pert_dn, &
2966) option)
2967)
2968) x_up(1) = global_auxvar_up%pres(1)
2969) x_up(2) = global_auxvar_up%temp
2970) x_dn(1) = global_auxvar_dn%pres(1)
2971) x_dn(2) = global_auxvar_dn%temp
2972) do ideriv = 1,3
2973) if (ibndtype(ideriv) == ZERO_GRADIENT_BC) then
2974) x_up(ideriv) = x_dn(ideriv)
2975) endif
2976) enddo
2977) if (option%use_th_freezing) then
2978) call THAuxVarComputeFreezing(x_dn,auxvar_dn, &
2979) global_auxvar_dn, &
2980) material_auxvar_dn, &
2981) iphase,sat_func_dn, &
2982) TH_parameter,ithrm_up, &
2983) option)
2984) call THAuxVarComputeFreezing(x_up,auxvar_up, &
2985) global_auxvar_up, &
2986) material_auxvar_up, &
2987) iphase,sat_func_dn, &
2988) TH_parameter,ithrm_up, &
2989) option)
2990) else
2991) call THAuxVarComputeNoFreezing(x_dn,auxvar_dn, &
2992) global_auxvar_dn, &
2993) material_auxvar_dn, &
2994) iphase,sat_func_dn, &
2995) option)
2996) call THAuxVarComputeNoFreezing(x_up,auxvar_up, &
2997) global_auxvar_up, &
2998) material_auxvar_up, &
2999) iphase,sat_func_dn, &
3000) option)
3001) endif
3002)
3003) call THBCFlux(ibndtype,auxvars,auxvar_up,global_auxvar_up, &
3004) material_auxvar_up, &
3005) auxvar_dn,global_auxvar_dn, &
3006) material_auxvar_dn, &
3007) sir_dn, &
3008) Dk_dn, &
3009) area,dist_gravity,option,v_darcy, &
3010) fluxe_bulk, fluxe_cond, &
3011) res)
3012) if (ibndtype(TH_PRESSURE_DOF) == ZERO_GRADIENT_BC .or. &
3013) ibndtype(TH_TEMPERATURE_DOF) == ZERO_GRADIENT_BC ) then
3014) x_pert_up = x_up
3015) endif
3016)
3017) do ideriv = 1,option%nflowdof
3018) pert_dn = x_dn(ideriv)*perturbation_tolerance
3019) x_pert_dn = x_dn
3020)
3021) if (option%use_th_freezing) then
3022)
3023) if (ideriv == 1) then
3024) if (x_pert_dn(ideriv) < option%reference_pressure) then
3025) pert_dn = - pert_dn
3026) endif
3027) x_pert_dn(ideriv) = x_pert_dn(ideriv) + pert_dn
3028) endif
3029)
3030) if (ideriv == 2) then
3031) if (x_pert_dn(ideriv) < 0.d0) then
3032) pert_dn = - 1.d-5
3033) else
3034) pert_dn = 1.d-5
3035) endif
3036) x_pert_dn(ideriv) = x_pert_dn(ideriv) + pert_dn
3037) endif
3038) else
3039) x_pert_dn(ideriv) = x_pert_dn(ideriv) + pert_dn
3040) endif
3041)
3042) x_pert_up = x_up
3043) if (ibndtype(ideriv) == ZERO_GRADIENT_BC) then
3044) x_pert_up(ideriv) = x_pert_dn(ideriv)
3045) endif
3046)
3047) if (option%use_th_freezing) then
3048) call THAuxVarComputeFreezing(x_pert_dn,auxvar_pert_dn, &
3049) global_auxvar_pert_dn, &
3050) material_auxvar_pert_dn, &
3051) iphase,sat_func_dn, &
3052) option)
3053) call THAuxVarComputeFreezing(x_pert_up,auxvar_pert_up, &
3054) global_auxvar_pert_up, &
3055) material_auxvar_pert_up, &
3056) iphase,sat_func_dn, &
3057) option)
3058) else
3059) call THAuxVarComputeNoFreezing(x_pert_dn,auxvar_pert_dn, &
3060) global_auxvar_pert_dn, &
3061) material_auxvar_pert_dn, &
3062) iphase,sat_func_dn, &
3063) option)
3064) call THAuxVarComputeNoFreezing(x_pert_up,auxvar_pert_up, &
3065) global_auxvar_pert_up, &
3066) material_auxvar_pert_up, &
3067) iphase,sat_func_dn, &
3068) option)
3069) endif
3070)
3071) call THBCFlux(ibndtype,auxvars,auxvar_pert_up,global_auxvar_pert_up, &
3072) material_auxvar_pert_up, &
3073) auxvar_pert_dn,global_auxvar_pert_dn, &
3074) material_auxvar_pert_dn, &
3075) sir_dn, &
3076) Dk_dn, &
3077) area,dist_gravity,option,v_darcy, &
3078) fluxe_bulk, fluxe_cond, &
3079) res_pert_dn)
3080) J_pert_dn(:,ideriv) = (res_pert_dn(:)-res(:))/pert_dn
3081) enddo
3082) Jdn = J_pert_dn
3083) call GlobalAuxVarStrip(global_auxvar_pert_up)
3084) call GlobalAuxVarStrip(global_auxvar_pert_dn)
3085) endif
3086) #endif
3087)
3088) end subroutine THBCFluxDerivative
3089)
3090) ! ************************************************************************** !
3091)
3092) subroutine THBCFlux(ibndtype,auxvars,auxvar_up,global_auxvar_up, &
3093) auxvar_dn,global_auxvar_dn, &
3094) material_auxvar_dn, &
3095) sir_dn, &
3096) Dk_dn, &
3097) area, &
3098) dist, &
3099) option,v_darcy, &
3100) fluxe_bulk, fluxe_cond, &
3101) Res)
3102) !
3103) ! Computes the boundary flux terms for the residual
3104) !
3105) ! Author: ???
3106) ! Date: 12/13/07
3107) !
3108) use Option_module
3109) use Connection_module
3110) use EOS_Water_module
3111) use Condition_module
3112) use Utility_module
3113)
3114) implicit none
3115)
3116) PetscInt :: ibndtype(:)
3117) type(TH_auxvar_type) :: auxvar_up, auxvar_dn
3118) type(global_auxvar_type) :: global_auxvar_up, global_auxvar_dn
3119) class(material_auxvar_type) :: material_auxvar_dn
3120) type(option_type) :: option
3121) PetscReal :: sir_dn
3122) PetscReal :: auxvars(:) ! from aux_real_var array
3123) PetscReal :: Dk_dn
3124) PetscReal :: v_darcy, area
3125) PetscReal :: Res(1:option%nflowdof)
3126) PetscReal :: dist(-1:3)
3127) PetscReal, intent(out) :: fluxe_bulk, fluxe_cond
3128)
3129) PetscReal :: dist_gravity ! distance along gravity vector
3130) PetscReal :: dd_dn
3131)
3132) PetscReal :: por_dn,perm_dn,tor_dn
3133) PetscInt :: ispec
3134) PetscReal :: fluxm,fluxe,q,density_ave
3135) PetscReal :: uh,ukvr,diff,diffdp,DK,Dq
3136) PetscReal :: upweight,cond,gravity,dphi
3137) PetscReal :: dphi_orig
3138) PetscBool :: hw_present
3139)
3140) ! ice variables
3141) PetscReal :: Ddiffgas_avg, Ddiffgas_dn, Ddiffgas_up
3142) PetscReal :: p_g
3143) PetscReal :: deng_dn, deng_up
3144) PetscReal :: psat_dn, psat_up
3145) PetscReal :: molg_dn, molg_up
3146) PetscReal :: satg_dn, satg_up
3147) PetscReal :: Diffg_dn, Diffg_up
3148) PetscReal :: Diffg_ref, p_ref, T_ref
3149) PetscErrorCode :: ierr
3150) PetscReal :: fv_up, fv_dn
3151) PetscReal :: v_darcy_allowable
3152) PetscReal :: rho,dum1
3153) PetscReal :: q_approx, dq_approx
3154) PetscReal :: T_th,fctT,fct
3155) T_th = 0.5d0
3156)
3157) fluxm = 0.d0
3158) fluxe = 0.d0
3159) v_darcy = 0.d0
3160) density_ave = 0.d0
3161) q = 0.d0
3162) fctT = 0.d0
3163) fluxe_bulk = 0.d0
3164) fluxe_cond = 0.d0
3165)
3166) hw_present = PETSC_FALSE
3167) if (associated(auxvar_dn%surface)) then
3168) hw_present = auxvar_dn%surface%surf_wat
3169) endif
3170)
3171) dist_gravity = dist(0) * dot_product(option%gravity,dist(1:3))
3172) dd_dn = dist(0)
3173)
3174) call material_auxvar_dn%PermeabilityTensorToScalar(dist,perm_dn)
3175) por_dn = material_auxvar_dn%porosity
3176) tor_dn = material_auxvar_dn%tortuosity
3177)
3178) ! Flow
3179) diffdp = por_dn*tor_dn/dd_dn*area
3180) select case(ibndtype(TH_PRESSURE_DOF))
3181) case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC)
3182) Dq = perm_dn / dd_dn
3183) ! Flow term
3184) if (global_auxvar_up%sat(1) > sir_dn .or. global_auxvar_dn%sat(1) > sir_dn) then
3185) upweight=1.D0
3186) if (global_auxvar_up%sat(1) < eps) then
3187) upweight=0.d0
3188) else if (global_auxvar_dn%sat(1) < eps) then
3189) upweight=1.d0
3190) endif
3191) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_dn%den(1)
3192)
3193) gravity = (upweight*global_auxvar_up%den(1)*auxvar_up%avgmw + &
3194) (1.D0-upweight)*global_auxvar_dn%den(1)*auxvar_dn%avgmw) &
3195) * dist_gravity
3196)
3197) if (option%ice_model /= DALL_AMICO) then
3198) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
3199) else
3200) dphi = auxvar_up%ice%pres_fh2o - auxvar_dn%ice%pres_fh2o + gravity
3201) endif
3202)
3203) if (ibndtype(TH_PRESSURE_DOF) == SEEPAGE_BC) then
3204) ! flow in ! boundary cell is <= pref
3205) if (dphi > 0.d0 .and. global_auxvar_up%pres(1) - option%reference_pressure < eps) then
3206) dphi = 0.d0
3207) endif
3208) endif
3209)
3210) if (dphi>=0.D0) then
3211) ukvr = auxvar_up%kvr
3212) else
3213) ukvr = auxvar_dn%kvr
3214) endif
3215)
3216) call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, &
3217) dphi, &
3218) option%rel_perm_aveg, &
3219) ukvr)
3220)
3221) if (ukvr*Dq>floweps) then
3222) v_darcy = Dq * ukvr * dphi
3223) endif
3224) endif
3225)
3226) case(HET_SURF_SEEPAGE_BC)
3227) Dq = perm_dn / dd_dn
3228) ! Flow term
3229) if (global_auxvar_up%sat(1) > sir_dn .or. global_auxvar_dn%sat(1) > sir_dn) then
3230) upweight=1.D0
3231) if (global_auxvar_up%sat(1) < eps) then
3232) upweight=0.d0
3233) else if (global_auxvar_dn%sat(1) < eps) then
3234) upweight=1.d0
3235) endif
3236) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_dn%den(1)
3237)
3238) gravity = (upweight*global_auxvar_up%den(1)*auxvar_up%avgmw + &
3239) (1.D0-upweight)*global_auxvar_dn%den(1)*auxvar_dn%avgmw) &
3240) * dist_gravity
3241)
3242) if (option%ice_model /= DALL_AMICO) then
3243) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
3244) else
3245) dphi = auxvar_up%ice%pres_fh2o - auxvar_dn%ice%pres_fh2o + gravity
3246) endif
3247)
3248) if (dphi > 0.d0 .and. global_auxvar_up%pres(1) - option%reference_pressure < eps) then
3249) dphi = 0.d0
3250) endif
3251)
3252) if (option%surf_flow_on) then
3253) ! If surface-water is frozen, zero out the darcy velocity
3254) if (global_auxvar_up%temp < 0.d0) then
3255) dphi = 0.d0
3256) endif
3257) endif
3258)
3259) if (dphi>=0.D0) then
3260) ukvr = auxvar_up%kvr
3261) else
3262) ukvr = auxvar_dn%kvr
3263) endif
3264)
3265) call InterfaceApprox(auxvar_up%kvr, auxvar_dn%kvr, &
3266) dphi, &
3267) option%rel_perm_aveg, &
3268) ukvr)
3269)
3270) if (ukvr*Dq>floweps) then
3271) v_darcy = Dq * ukvr * dphi
3272)
3273) if (option%surf_flow_on .and. &
3274) option%subsurf_surf_coupling /= DECOUPLED) then
3275)
3276) ! ---------------------------
3277) ! Surface-subsurface simulation
3278) ! ---------------------------
3279)
3280) ! Temperature-smoothing
3281) fctT = 1.d0
3282) if (global_auxvar_up%temp < 0.d0) then
3283) ! surface water is frozen, so no flow can occur
3284) fctT = 0.d0
3285) else
3286) ! if subsurface is close to frozen, smoothly throttle down the flow
3287) if (global_auxvar_dn%temp < 0.d0) then
3288) fctT = 0.d0
3289) else if (global_auxvar_dn%temp > T_th) then
3290) fctT = 1.d0
3291) else
3292) fct = 1.d0-(global_auxvar_dn%temp/T_th)**2.d0
3293) fctT = 1.d0-fct**2.d0
3294) endif
3295) endif
3296)
3297) ! If needed, apply pressure-smoothing
3298) if (.not. auxvar_dn%surface%bcflux_default_scheme) then
3299) if (global_auxvar_dn%pres(1) <= auxvar_dn%surface%P_min) then
3300)
3301) ! Linear approximation
3302) call Interpolate(auxvar_dn%surface%range_for_linear_approx(2), &
3303) auxvar_dn%surface%range_for_linear_approx(1), &
3304) global_auxvar_dn%pres(1), &
3305) auxvar_dn%surface%range_for_linear_approx(4), &
3306) auxvar_dn%surface%range_for_linear_approx(3), &
3307) q_approx)
3308) v_darcy = q_approx/area
3309)
3310) else if (global_auxvar_dn%pres(1) <= auxvar_dn%surface%P_max) then
3311)
3312) ! Cubic approximation
3313) call CubicPolynomialEvaluate(auxvar_dn%surface%coeff_for_cubic_approx, &
3314) global_auxvar_dn%pres(1)-option%reference_pressure, &
3315) !global_auxvar_dn%pres(1), &
3316) q_approx, dq_approx)
3317) v_darcy = q_approx/area
3318) endif
3319) endif
3320)
3321) ! Now apply temperature-smoothing
3322) v_darcy = v_darcy*fctT
3323)
3324) endif
3325)
3326) endif
3327) endif
3328) v_darcy = min(v_darcy,option%max_infiltration_velocity)
3329)
3330) case(NEUMANN_BC)
3331) if (dabs(auxvars(TH_PRESSURE_DOF)) > floweps) then
3332) v_darcy = auxvars(TH_PRESSURE_DOF)
3333) if (v_darcy > 0.d0) then
3334) density_ave = global_auxvar_up%den(1)
3335) else
3336) density_ave = global_auxvar_dn%den(1)
3337) endif
3338) endif
3339)
3340) case(ZERO_GRADIENT_BC)
3341) ! do nothing needed to bypass default case
3342)
3343) case default
3344) option%io_buffer = 'BC type "' // trim(GetSubConditionName(ibndtype(TH_PRESSURE_DOF))) // &
3345) '" not implemented in TH mode.'
3346) call printErrMsg(option)
3347)
3348) end select
3349)
3350) ! If only solving the energy equation, ensure Res(2) has no
3351) ! contribution from mass equation by setting darcy velocity
3352) ! to be zero
3353) if (option%flow%only_energy_eq) q = 0.d0
3354)
3355) q = v_darcy * area
3356)
3357) if (v_darcy >= 0.D0) then
3358) uh = auxvar_up%h
3359) else
3360) uh = auxvar_dn%h
3361) endif
3362)
3363) fluxm = fluxm + q*density_ave
3364) fluxe = fluxe + q*density_ave*uh
3365) fluxe_bulk = q*density_ave*uh
3366)
3367) ! Conduction term
3368) select case(ibndtype(TH_TEMPERATURE_DOF))
3369) case(DIRICHLET_BC,HET_DIRICHLET)
3370) Dk = auxvar_dn%Dk_eff / dd_dn
3371) cond = Dk*area*(global_auxvar_up%temp-global_auxvar_dn%temp)
3372)
3373) if (option%surf_flow_on) then
3374)
3375) ! ---------------------------
3376) ! Surface-subsurface simulation
3377) ! ---------------------------
3378)
3379) ! Check if the pressure BC is associated with surface-flow model and
3380) ! there is no standing water, set heat conduction to be zero.
3381) if (ibndtype(TH_PRESSURE_DOF) == HET_SURF_SEEPAGE_BC .and. &
3382) .not.(hw_present)) then
3383) cond = 0.d0
3384) endif
3385)
3386) if (ibndtype(TH_PRESSURE_DOF) /= HET_SURF_SEEPAGE_BC .and. &
3387) (hw_present)) then
3388) cond = 0.d0
3389) endif
3390) endif
3391) fluxe = fluxe + cond
3392) fluxe_cond = cond
3393)
3394) if (option%use_th_freezing) then
3395) ! Added by Satish Karra,
3396) satg_up = auxvar_up%ice%sat_gas
3397) satg_dn = auxvar_dn%ice%sat_gas
3398) if ((satg_up > eps) .and. (satg_dn > eps)) then
3399) p_g = option%reference_pressure ! set to reference pressure
3400) deng_up = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + 273.15d0))*1.d-3
3401) deng_dn = p_g/(IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + 273.15d0))*1.d-3
3402)
3403) Diffg_ref = 2.13D-5 ! Reference diffusivity, need to read from input file
3404) p_ref = 1.01325d5 ! in Pa
3405) T_ref = 25.d0 ! in deg C
3406)
3407) Diffg_up = Diffg_ref*(p_ref/p_g)*((global_auxvar_up%temp + &
3408) 273.15d0)/(T_ref + 273.15d0))**(1.8)
3409) Diffg_dn = Diffg_ref*(p_ref/p_g)*((global_auxvar_dn%temp + &
3410) 273.15d0)/(T_ref + 273.15d0))**(1.8)
3411) Ddiffgas_up = satg_up*deng_up*Diffg_up
3412) Ddiffgas_dn = satg_dn*deng_dn*Diffg_dn
3413) call EOSWaterSaturationPressure(global_auxvar_up%temp, psat_up, ierr)
3414) call EOSWaterSaturationPressure(global_auxvar_dn%temp, psat_dn, ierr)
3415)
3416) ! vapor pressure lowering due to capillary pressure
3417) fv_up = exp(-auxvar_up%pc/(global_auxvar_up%den(1)* &
3418) IDEAL_GAS_CONSTANT*(global_auxvar_up%temp + 273.15d0)))
3419) fv_dn = exp(-auxvar_dn%pc/(global_auxvar_dn%den(1)* &
3420) IDEAL_GAS_CONSTANT*(global_auxvar_dn%temp + 273.15d0)))
3421)
3422) molg_up = psat_up*fv_up/p_g
3423) molg_dn = psat_dn*fv_dn/p_g
3424)
3425) if (molg_up > molg_dn) then
3426) upweight = 0.d0
3427) else
3428) upweight = 1.d0
3429) endif
3430)
3431) Ddiffgas_avg = upweight*Ddiffgas_up + (1.D0 - upweight)*Ddiffgas_dn
3432) fluxm = fluxm + por_dn*tor_dn*Ddiffgas_avg*(molg_up - molg_dn)/ &
3433) dd_dn*area
3434) endif
3435) endif ! if (use_th_freezing)
3436)
3437) case(NEUMANN_BC)
3438) !geh: default internal energy units are MJ (option%scale = 1.d-6 is for J->MJ)
3439) fluxe = fluxe + auxvars(TH_TEMPERATURE_DOF)*area*(1.d6*option%scale) ! added by SK 10/18/11
3440) fluxe_cond = auxvars(TH_TEMPERATURE_DOF)*area*(1.d6*option%scale)
3441) case(ZERO_GRADIENT_BC)
3442) ! No change in fluxe
3443) case default
3444) option%io_buffer = 'BC type "' // trim(GetSubConditionName(ibndtype(TH_TEMPERATURE_DOF))) // &
3445) '" not implemented in TH mode.'
3446) call printErrMsg(option)
3447) end select
3448)
3449) ! If only solving the energy equation, set Res(1) is 0.d0
3450) if (option%flow%only_energy_eq) fluxm = 0.d0
3451)
3452) Res(1:option%nflowspec) = fluxm
3453) Res(option%nflowdof) = fluxe
3454)
3455) end subroutine THBCFlux
3456)
3457) ! ************************************************************************** !
3458)
3459) subroutine THResidual(snes,xx,r,realization,ierr)
3460) !
3461) ! Computes the residual equation
3462) !
3463) ! Author: ???
3464) ! Date: 12/10/07
3465) !
3466)
3467) use Realization_Subsurface_class
3468) use Patch_module
3469) use Discretization_module
3470) use Field_module
3471) use Option_module
3472) use Variables_module
3473) use Material_module
3474)
3475) implicit none
3476)
3477) SNES :: snes
3478) Vec :: xx
3479) Vec :: r
3480) type(realization_subsurface_type) :: realization
3481) PetscErrorCode :: ierr
3482)
3483) type(discretization_type), pointer :: discretization
3484) type(field_type), pointer :: field
3485) type(patch_type), pointer :: cur_patch
3486) type(option_type), pointer :: option
3487)
3488) field => realization%field
3489) discretization => realization%discretization
3490) option => realization%option
3491)
3492) ! check initial guess -----------------------------------------------
3493) ierr = THInitGuessCheck(xx,option)
3494) if (ierr<0) then
3495) call SNESSetFunctionDomainError(snes,ierr);CHKERRQ(ierr)
3496) return
3497) endif
3498)
3499) ! Communication -----------------------------------------
3500) ! These 3 must be called before THUpdateAuxVars()
3501) call DiscretizationGlobalToLocal(discretization,xx,field%flow_xx_loc,NFLOWDOF)
3502) call DiscretizationLocalToLocal(discretization,field%iphas_loc,field%iphas_loc,ONEDOF)
3503) call DiscretizationLocalToLocal(discretization,field%icap_loc,field%icap_loc,ONEDOF)
3504)
3505) call DiscretizationLocalToLocal(discretization,field%ithrm_loc,field%ithrm_loc,ONEDOF)
3506)
3507) call MaterialGetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
3508) PERMEABILITY_X,ZERO_INTEGER)
3509) call DiscretizationLocalToLocal(discretization,field%work_loc, &
3510) field%work_loc,ONEDOF)
3511) call MaterialSetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
3512) PERMEABILITY_X,ZERO_INTEGER)
3513)
3514) call MaterialGetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
3515) PERMEABILITY_Y,ZERO_INTEGER)
3516) call DiscretizationLocalToLocal(discretization,field%work_loc, &
3517) field%work_loc,ONEDOF)
3518) call MaterialSetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
3519) PERMEABILITY_Y,ZERO_INTEGER)
3520)
3521) call MaterialGetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
3522) PERMEABILITY_Z,ZERO_INTEGER)
3523) call DiscretizationLocalToLocal(discretization,field%work_loc, &
3524) field%work_loc,ONEDOF)
3525) call MaterialSetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
3526) PERMEABILITY_Z,ZERO_INTEGER)
3527)
3528) cur_patch => realization%patch_list%first
3529) do
3530) if (.not.associated(cur_patch)) exit
3531) realization%patch => cur_patch
3532) call THResidualPatch(snes,xx,r,realization,ierr)
3533) cur_patch => cur_patch%next
3534) enddo
3535)
3536) end subroutine THResidual
3537)
3538) ! ************************************************************************** !
3539)
3540) subroutine THResidualPatch(snes,xx,r,realization,ierr)
3541) !
3542) ! Computes the residual equation at patch level
3543) !
3544) ! Author: ???
3545) ! Date: 12/10/07
3546) !
3547)
3548)
3549)
3550) use Connection_module
3551) use Realization_Subsurface_class
3552) use Patch_module
3553) use Grid_module
3554) use Option_module
3555) use Coupler_module
3556) use Field_module
3557) use Debug_module
3558) use Secondary_Continuum_Aux_module
3559) use Secondary_Continuum_module
3560)
3561) implicit none
3562)
3563) SNES, intent(in) :: snes
3564) Vec, intent(inout) :: xx
3565) Vec, intent(out) :: r
3566) type(realization_subsurface_type) :: realization
3567)
3568) PetscErrorCode :: ierr
3569) PetscInt :: i, jn
3570) PetscInt :: ip1, ip2
3571) PetscInt :: local_id, ghosted_id, local_id_up, local_id_dn, ghosted_id_up, ghosted_id_dn
3572)
3573) PetscReal, pointer :: accum_p(:)
3574)
3575) PetscReal, pointer :: r_p(:), xx_loc_p(:), xx_p(:), yy_p(:)
3576) PetscReal, pointer :: iphase_loc_p(:), icap_loc_p(:), ithrm_loc_p(:)
3577)
3578) PetscInt :: iphase
3579) PetscInt :: icap_up, icap_dn, ithrm_up, ithrm_dn
3580) PetscReal :: dd_up, dd_dn
3581) PetscReal :: dd, f_up, f_dn, ff
3582) PetscReal :: perm_up, perm_dn
3583) PetscReal :: D_up, D_dn ! thermal conductivity wet constants at upstream, downstream faces.
3584) PetscReal :: Dk_dry_up, Dk_dry_dn ! dry thermal conductivities
3585) PetscReal :: Dk_ice_up, Dk_ice_dn ! frozen soil thermal conductivities
3586) PetscReal :: alpha_up, alpha_dn
3587) PetscReal :: alpha_fr_up, alpha_fr_dn
3588) PetscReal :: dw_kg, dw_mol
3589) PetscReal :: qsrc1, csrc1, enth_src_h2o, enth_src_co2 , esrc1
3590)
3591) PetscReal :: upweight
3592) PetscReal :: Res(realization%option%nflowdof)
3593) PetscReal :: Res_src(realization%option%nflowdof)
3594) PetscViewer :: viewer
3595)
3596) type(grid_type), pointer :: grid
3597) type(patch_type), pointer :: patch
3598) type(option_type), pointer :: option
3599) type(field_type), pointer :: field
3600) type(TH_parameter_type), pointer :: TH_parameter
3601) type(TH_auxvar_type), pointer :: auxvars(:), auxvars_bc(:)
3602) type(TH_auxvar_type), pointer :: auxvars_ss(:)
3603) type(global_auxvar_type), pointer :: global_auxvars(:), global_auxvars_bc(:)
3604) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
3605) class(material_auxvar_type), pointer :: material_auxvars(:)
3606) type(coupler_type), pointer :: boundary_condition, source_sink
3607) type(connection_set_list_type), pointer :: connection_set_list
3608) type(connection_set_type), pointer :: cur_connection_set
3609) type(sec_heat_type), pointer :: TH_sec_heat_vars(:)
3610) character(len=MAXSTRINGLENGTH) :: string
3611) PetscReal, pointer :: mmsrc(:)
3612) PetscReal :: well_status
3613) PetscReal :: well_factor
3614) PetscReal :: pressure_bh
3615) PetscReal :: pressure_max
3616) PetscReal :: pressure_min
3617) PetscReal :: well_inj_water
3618) PetscReal :: Dq, dphi, v_darcy, ukvr
3619)
3620) PetscInt :: iconn, idof, istart, iend
3621) PetscInt :: sum_connection
3622) PetscReal :: distance, fraction_upwind
3623) PetscReal :: distance_gravity
3624) PetscReal :: vol_frac_prim
3625) PetscReal :: fluxe_bulk, fluxe_cond
3626)
3627) ! secondary continuum variables
3628) PetscReal :: sec_density
3629) PetscReal :: sec_dencpr
3630) PetscReal :: res_sec_heat
3631)
3632) patch => realization%patch
3633) grid => patch%grid
3634) option => realization%option
3635) field => realization%field
3636)
3637) TH_parameter => patch%aux%TH%TH_parameter
3638) auxvars => patch%aux%TH%auxvars
3639) auxvars_bc => patch%aux%TH%auxvars_bc
3640) auxvars_ss => patch%aux%TH%auxvars_ss
3641) global_auxvars => patch%aux%Global%auxvars
3642) global_auxvars_bc => patch%aux%Global%auxvars_bc
3643) global_auxvars_ss => patch%aux%Global%auxvars_ss
3644) material_auxvars => patch%aux%Material%auxvars
3645) TH_sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
3646)
3647) call THUpdateAuxVarsPatch(realization)
3648) ! override flags since they will soon be out of date
3649) patch%aux%TH%auxvars_up_to_date = PETSC_FALSE
3650)
3651) if (option%compute_mass_balance_new) then
3652) call THZeroMassBalDeltaPatch(realization)
3653) endif
3654)
3655)
3656) ! now assign access pointer to local variables
3657) call VecGetArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
3658) call VecGetArrayF90( r, r_p, ierr);CHKERRQ(ierr)
3659) call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
3660)
3661) call VecGetArrayF90(field%flow_yy,yy_p,ierr);CHKERRQ(ierr)
3662) call VecGetArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
3663) call VecGetArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
3664) call VecGetArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
3665) !print *,' Finished scattering non deriv'
3666)
3667) if (option%surf_flow_on) call THComputeCoeffsForSurfFlux(realization)
3668)
3669) ! Calculating volume fractions for primary and secondary continua
3670)
3671) vol_frac_prim = 1.d0
3672) r_p = 0.d0
3673)
3674) ! Accumulation terms ------------------------------------
3675) r_p = - accum_p
3676)
3677) do local_id = 1, grid%nlmax ! For each local node do...
3678) ghosted_id = grid%nL2G(local_id)
3679) if (patch%imat(ghosted_id) <= 0) cycle
3680) iend = local_id*option%nflowdof
3681) istart = iend-option%nflowdof+1
3682)
3683)
3684) if (option%use_mc) then
3685) vol_frac_prim = TH_sec_heat_vars(local_id)%epsilon
3686) endif
3687)
3688) call THAccumulation(auxvars(ghosted_id),global_auxvars(ghosted_id), &
3689) material_auxvars(ghosted_id), &
3690) TH_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
3691) option,vol_frac_prim,Res)
3692) r_p(istart:iend) = r_p(istart:iend) + Res
3693) enddo
3694)
3695)
3696) ! ================== Secondary continuum heat source terms =====================
3697) if (option%use_mc) then
3698) ! Secondary continuum contribution (Added by SK 06/02/2012)
3699) ! only one secondary continuum for now for each primary continuum node
3700) do local_id = 1, grid%nlmax ! For each local node do...
3701) ghosted_id = grid%nL2G(local_id)
3702) if (patch%imat(ghosted_id) <= 0) cycle
3703) iend = local_id*option%nflowdof
3704) istart = iend-option%nflowdof+1
3705)
3706) sec_dencpr = TH_parameter%dencpr(int(ithrm_loc_p(local_id))) ! secondary rho*c_p same as primary for now
3707)
3708) call THSecondaryHeat(TH_sec_heat_vars(local_id), &
3709) global_auxvars(ghosted_id), &
3710) ! TH_parameter%ckdry(int(ithrm_loc_p(local_id))), &
3711) TH_parameter%ckwet(int(ithrm_loc_p(local_id))), &
3712) sec_dencpr, &
3713) option,res_sec_heat)
3714)
3715) r_p(iend) = r_p(iend) - res_sec_heat*material_auxvars(ghosted_id)%volume
3716) enddo
3717) endif
3718) ! ============== end secondary continuum heat source ===========================
3719)
3720) ! Source/sink terms -------------------------------------
3721) source_sink => patch%source_sink_list%first
3722) sum_connection = 0
3723) do
3724) if (.not.associated(source_sink)) exit
3725)
3726) cur_connection_set => source_sink%connection_set
3727)
3728) do iconn = 1, cur_connection_set%num_connections
3729) sum_connection = sum_connection + 1
3730) local_id = cur_connection_set%id_dn(iconn)
3731) iend = local_id * option%nflowdof
3732) istart = iend - option%nflowdof + 1
3733) ghosted_id = grid%nL2G(local_id)
3734) if (patch%imat(ghosted_id) <= 0) cycle
3735)
3736) if (source_sink%flow_condition%rate%itype /= HET_MASS_RATE_SS .and. &
3737) source_sink%flow_condition%itype(1) /= WELL_SS) &
3738) qsrc1 = source_sink%flow_condition%rate%dataset%rarray(1)
3739)
3740) Res_src = 0.d0
3741) select case (source_sink%flow_condition%rate%itype)
3742) case(MASS_RATE_SS)
3743) qsrc1 = qsrc1 / FMWH2O ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
3744) case(SCALED_MASS_RATE_SS)
3745) qsrc1 = qsrc1 / FMWH2O * &
3746) source_sink%flow_aux_real_var(ONE_INTEGER,iconn) ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
3747) case(VOLUMETRIC_RATE_SS) ! assume local density for now
3748) ! qsrc1 = m^3/sec
3749) qsrc1 = qsrc1*global_auxvars(ghosted_id)%den(1) ! den = kmol/m^3
3750) case(SCALED_VOLUMETRIC_RATE_SS) ! assume local density for now
3751) ! qsrc1 = m^3/sec
3752) qsrc1 = qsrc1*global_auxvars(ghosted_id)%den(1)* & ! den = kmol/m^3
3753) source_sink%flow_aux_real_var(ONE_INTEGER,iconn)
3754) case(HET_MASS_RATE_SS)
3755) qsrc1 = source_sink%flow_aux_real_var(ONE_INTEGER,iconn)/FMWH2O
3756) case(WELL_SS) ! production well, Karra 11/10/2015
3757) ! if node pessure is lower than the given extraction pressure, shut it down
3758) ! well parameter explanation
3759) ! 1. well status. 1 injection; -1 production; 0 shut in!
3760) ! 2. well factor [m^3], the effective permeability [m^2/s]
3761) ! 3. bottomhole pressure: [Pa]
3762) ! 4. max pressure: [Pa]
3763) ! 5. min pressure: [Pa]
3764) mmsrc => source_sink%flow_condition%well%dataset%rarray
3765)
3766) well_status = mmsrc(1)
3767) well_factor = mmsrc(2)
3768) pressure_bh = mmsrc(3)
3769) pressure_max = mmsrc(4)
3770) pressure_min = mmsrc(5)
3771)
3772) ! production well (well status = -1)
3773) if (dabs(well_status + 1.d0) < 1.d-1) then
3774) if (global_auxvars(ghosted_id)%pres(1) > pressure_min) then
3775) Dq = well_factor
3776) dphi = global_auxvars(ghosted_id)%pres(1) - pressure_bh
3777) if (dphi >= 0.d0) then ! outflow only
3778) ukvr = auxvars(ghosted_id)%kvr
3779) if (ukvr < 1.d-20) ukvr = 0.d0
3780) v_darcy = 0.d0
3781) if (ukvr*Dq > floweps) then
3782) v_darcy = Dq * ukvr * dphi
3783) ! store volumetric rate for ss_fluid_fluxes()
3784) qsrc1 = -1.d0*v_darcy*global_auxvars(ghosted_id)%den(1)
3785) endif
3786) endif
3787) endif
3788) endif
3789)
3790) case default
3791) write(string,*) source_sink%flow_condition%rate%itype
3792) option%io_buffer='TH mode source_sink%flow_condition%rate%itype = ' // &
3793) trim(adjustl(string)) // ', not implemented.'
3794) end select
3795)
3796) Res_src(TH_PRESSURE_DOF) = qsrc1
3797)
3798) esrc1 = 0.d0
3799) select case(source_sink%flow_condition%itype(TH_TEMPERATURE_DOF))
3800) case (ENERGY_RATE_SS)
3801) esrc1 = source_sink%flow_condition%energy_rate%dataset%rarray(1)
3802) case (SCALED_ENERGY_RATE_SS)
3803) esrc1 = source_sink%flow_condition%energy_rate%dataset%rarray(1) * &
3804) source_sink%flow_aux_real_var(ONE_INTEGER,iconn)
3805) case (HET_ENERGY_RATE_SS)
3806) esrc1 = source_sink%flow_aux_real_var(TWO_INTEGER,iconn)
3807) end select
3808) ! convert J/s --> MJ/s
3809) !geh: default internal energy units are MJ (option%scale = 1.d-6 is for
3810) ! J->MJ)
3811) Res_src(TH_TEMPERATURE_DOF) = esrc1*1.d6*option%scale
3812)
3813) ! Update residual term associated with T
3814) if (qsrc1 > 0.d0) then ! injection
3815) Res_src(TH_TEMPERATURE_DOF) = Res_src(TH_TEMPERATURE_DOF) + &
3816) qsrc1*auxvars_ss(sum_connection)%h
3817) else
3818) ! extraction
3819) Res_src(TH_TEMPERATURE_DOF) = Res_src(TH_TEMPERATURE_DOF) + &
3820) qsrc1*auxvars(ghosted_id)%h
3821) endif
3822)
3823) r_p(istart:iend) = r_p(istart:iend) - Res_src
3824)
3825) if (option%compute_mass_balance_new) then
3826) global_auxvars_ss(sum_connection)%mass_balance_delta(1,1) = &
3827) global_auxvars_ss(sum_connection)%mass_balance_delta(1,1) - Res_src(1)
3828) endif
3829) if (associated(patch%ss_flow_vol_fluxes)) then
3830) ! fluid flux [m^3/sec] = qsrc_mol [kmol/sec] / den [kmol/m^3]
3831) patch%ss_flow_vol_fluxes(1,sum_connection) = qsrc1 / &
3832) global_auxvars(ghosted_id)%den(1)
3833) endif
3834) if (associated(patch%ss_flow_fluxes)) then
3835) patch%ss_flow_fluxes(1,sum_connection) = qsrc1
3836) endif
3837)
3838)
3839) enddo
3840) source_sink => source_sink%next
3841) enddo
3842)
3843) ! Interior Flux Terms -----------------------------------
3844) connection_set_list => grid%internal_connection_set_list
3845) cur_connection_set => connection_set_list%first
3846) sum_connection = 0
3847) do
3848) if (.not.associated(cur_connection_set)) exit
3849) do iconn = 1, cur_connection_set%num_connections
3850) sum_connection = sum_connection + 1
3851)
3852) ghosted_id_up = cur_connection_set%id_up(iconn)
3853) ghosted_id_dn = cur_connection_set%id_dn(iconn)
3854)
3855) local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
3856) local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping
3857)
3858) if (patch%imat(ghosted_id_up) <= 0 .or. &
3859) patch%imat(ghosted_id_dn) <= 0) cycle
3860)
3861) if (option%flow%only_vertical_flow) then
3862) !geh: place second conditional within first to avoid excessive
3863) ! dot products when .not. option%flow%only_vertical_flow
3864) if (dot_product(cur_connection_set%dist(1:3,iconn),unit_z) < &
3865) 1.d-10) cycle
3866) endif
3867)
3868) fraction_upwind = cur_connection_set%dist(-1,iconn)
3869) distance = cur_connection_set%dist(0,iconn)
3870) ! distance = scalar - magnitude of distance
3871) ! gravity = vector(3)
3872) ! dist(1:3,iconn) = vector(3) - unit vector
3873) distance_gravity = distance * &
3874) dot_product(option%gravity, &
3875) cur_connection_set%dist(1:3,iconn))
3876) dd_up = distance*fraction_upwind
3877) dd_dn = distance-dd_up ! should avoid truncation error
3878) ! upweight could be calculated as 1.d0-fraction_upwind
3879) ! however, this introduces ever so slight error causing pflow-overhaul not
3880) ! to match pflow-orig. This can be changed to 1.d0-fraction_upwind
3881) upweight = dd_dn/(dd_up+dd_dn)
3882)
3883) ithrm_up = int(ithrm_loc_p(ghosted_id_up))
3884) ithrm_dn = int(ithrm_loc_p(ghosted_id_dn))
3885) icap_up = int(icap_loc_p(ghosted_id_up))
3886) icap_dn = int(icap_loc_p(ghosted_id_dn))
3887)
3888) D_up = TH_parameter%ckwet(ithrm_up)
3889) D_dn = TH_parameter%ckwet(ithrm_dn)
3890)
3891) Dk_dry_up = TH_parameter%ckdry(ithrm_up)
3892) Dk_dry_dn = TH_parameter%ckdry(ithrm_dn)
3893)
3894) alpha_up = TH_parameter%alpha(ithrm_up)
3895) alpha_dn = TH_parameter%alpha(ithrm_dn)
3896)
3897) if (option%use_th_freezing) then
3898) Dk_ice_up = TH_parameter%ckfrozen(ithrm_up)
3899) DK_ice_dn = TH_parameter%ckfrozen(ithrm_dn)
3900)
3901) alpha_fr_up = TH_parameter%alpha_fr(ithrm_up)
3902) alpha_fr_dn = TH_parameter%alpha_fr(ithrm_dn)
3903) else
3904) Dk_ice_up = Dk_dry_up
3905) Dk_ice_dn = Dk_dry_dn
3906)
3907) alpha_fr_up = alpha_up
3908) alpha_fr_dn = alpha_dn
3909) endif
3910)
3911) call THFlux(auxvars(ghosted_id_up),global_auxvars(ghosted_id_up), &
3912) material_auxvars(ghosted_id_up), &
3913) TH_parameter%sir(1,icap_up), &
3914) D_up, &
3915) auxvars(ghosted_id_dn),global_auxvars(ghosted_id_dn), &
3916) material_auxvars(ghosted_id_dn), &
3917) TH_parameter%sir(1,icap_dn), &
3918) D_dn, &
3919) cur_connection_set%area(iconn), &
3920) cur_connection_set%dist(:,iconn), &
3921) upweight,option,v_darcy,Dk_dry_up, &
3922) Dk_dry_dn,Dk_ice_up,Dk_ice_dn, &
3923) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
3924) Res)
3925)
3926) patch%internal_velocities(1,sum_connection) = v_darcy
3927) patch%internal_flow_fluxes(:,sum_connection) = Res(:)
3928)
3929) if (local_id_up>0) then
3930) iend = local_id_up*option%nflowdof
3931) istart = iend-option%nflowdof+1
3932) r_p(istart:iend) = r_p(istart:iend) + Res(1:option%nflowdof)
3933) endif
3934)
3935) if (local_id_dn>0) then
3936) iend = local_id_dn*option%nflowdof
3937) istart = iend-option%nflowdof+1
3938) r_p(istart:iend) = r_p(istart:iend) - Res(1:option%nflowdof)
3939) endif
3940)
3941) enddo
3942) cur_connection_set => cur_connection_set%next
3943) enddo
3944)
3945) ! Boundary Flux Terms -----------------------------------
3946) boundary_condition => patch%boundary_condition_list%first
3947) sum_connection = 0
3948) do
3949) if (.not.associated(boundary_condition)) exit
3950)
3951) cur_connection_set => boundary_condition%connection_set
3952)
3953) do iconn = 1, cur_connection_set%num_connections
3954) sum_connection = sum_connection + 1
3955)
3956) local_id = cur_connection_set%id_dn(iconn)
3957) ghosted_id = grid%nL2G(local_id)
3958)
3959) if (patch%imat(ghosted_id) <= 0) cycle
3960)
3961) if (ghosted_id<=0) then
3962) print *, "Wrong boundary node index... STOP!!!"
3963) stop
3964) endif
3965)
3966) ithrm_dn = int(ithrm_loc_p(ghosted_id))
3967) D_dn = TH_parameter%ckwet(ithrm_dn)
3968)
3969) distance_gravity = cur_connection_set%dist(0,iconn) * &
3970) dot_product(option%gravity, &
3971) cur_connection_set%dist(1:3,iconn))
3972)
3973) icap_dn = int(icap_loc_p(ghosted_id))
3974)
3975) call THBCFlux(boundary_condition%flow_condition%itype, &
3976) boundary_condition%flow_aux_real_var(:,iconn), &
3977) auxvars_bc(sum_connection), &
3978) global_auxvars_bc(sum_connection), &
3979) auxvars(ghosted_id), &
3980) global_auxvars(ghosted_id), &
3981) material_auxvars(ghosted_id), &
3982) TH_parameter%sir(1,icap_dn), &
3983) D_dn, &
3984) cur_connection_set%area(iconn), &
3985) cur_connection_set%dist(-1:3,iconn), &
3986) option, &
3987) v_darcy, &
3988) fluxe_bulk, fluxe_cond, &
3989) Res)
3990)
3991) patch%boundary_velocities(1,sum_connection) = v_darcy
3992) patch%boundary_flow_fluxes(:,sum_connection) = Res(:)
3993) patch%boundary_energy_flux(1,sum_connection) = fluxe_bulk
3994) patch%boundary_energy_flux(2,sum_connection) = fluxe_cond
3995)
3996) if (option%compute_mass_balance_new) then
3997) ! contribution to boundary
3998) global_auxvars_bc(sum_connection)%mass_balance_delta(1,1) = &
3999) global_auxvars_bc(sum_connection)%mass_balance_delta(1,1) - Res(1)
4000) endif
4001)
4002) iend = local_id*option%nflowdof
4003) istart = iend-option%nflowdof+1
4004) r_p(istart:iend)= r_p(istart:iend) - Res(1:option%nflowdof)
4005) enddo
4006) boundary_condition => boundary_condition%next
4007) enddo
4008)
4009) ! scale the residual by the volume
4010) do local_id = 1, grid%nlmax
4011) ghosted_id = grid%nL2G(local_id)
4012) if (patch%imat(ghosted_id) <= 0) cycle
4013) iend = local_id*option%nflowdof
4014) istart = iend-option%nflowdof+1
4015) r_p (istart:iend)= r_p(istart:iend)/material_auxvars(ghosted_id)%volume
4016) enddo
4017)
4018) if (option%use_isothermal) then
4019) do local_id = 1, grid%nlmax ! For each local node do...
4020) ghosted_id = grid%nL2G(local_id)
4021) if (patch%imat(ghosted_id) <= 0) cycle
4022) istart = TWO_INTEGER + (local_id-1)*option%nflowdof
4023) r_p(istart)=xx_loc_p(2 + (ghosted_id-1)*option%nflowdof)-yy_p(istart-1)
4024) enddo
4025) endif
4026)
4027) if (patch%aux%TH%inactive_cells_exist) then
4028) do i=1,patch%aux%TH%n_zero_rows
4029) r_p(patch%aux%TH%zero_rows_local(i)) = 0.d0
4030) enddo
4031) endif
4032)
4033) call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
4034) call VecRestoreArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
4035) call VecRestoreArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
4036) call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
4037) call VecRestoreArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
4038) call VecRestoreArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
4039) call VecRestoreArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
4040)
4041) if (realization%debug%vecview_residual) then
4042) string = 'THresidual'
4043) call DebugCreateViewer(realization%debug,string,option,viewer)
4044) call VecView(r,viewer,ierr);CHKERRQ(ierr)
4045) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4046) endif
4047) if (realization%debug%vecview_solution) then
4048) string = 'THxx'
4049) call DebugCreateViewer(realization%debug,string,option,viewer)
4050) call VecView(xx,viewer,ierr);CHKERRQ(ierr)
4051) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4052) endif
4053)
4054) end subroutine THResidualPatch
4055)
4056) ! ************************************************************************** !
4057)
4058) subroutine THJacobian(snes,xx,A,B,realization,ierr)
4059) !
4060) ! Computes the Jacobian
4061) !
4062) ! Author: ???
4063) ! Date: 12/10/07
4064) !
4065)
4066) use Realization_Subsurface_class
4067) use Patch_module
4068) use Grid_module
4069) use Option_module
4070) use Debug_module
4071)
4072) implicit none
4073)
4074) SNES :: snes
4075) Vec :: xx
4076) Mat :: A, B
4077) type(realization_subsurface_type) :: realization
4078) PetscErrorCode :: ierr
4079)
4080) Mat :: J
4081) MatType :: mat_type
4082) PetscViewer :: viewer
4083) type(patch_type), pointer :: cur_patch
4084) type(grid_type), pointer :: grid
4085) type(option_type), pointer :: option
4086) PetscReal :: norm
4087)
4088) character(len=MAXSTRINGLENGTH) :: string
4089)
4090) call MatGetType(A,mat_type,ierr);CHKERRQ(ierr)
4091) if (mat_type == MATMFFD) then
4092) J = B
4093) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4094) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4095) else
4096) J = A
4097) endif
4098)
4099) call MatZeroEntries(J,ierr);CHKERRQ(ierr)
4100)
4101) cur_patch => realization%patch_list%first
4102) do
4103) if (.not.associated(cur_patch)) exit
4104) realization%patch => cur_patch
4105) call THJacobianPatch(snes,xx,J,J,realization,ierr)
4106) cur_patch => cur_patch%next
4107) enddo
4108)
4109) if (realization%debug%matview_Jacobian) then
4110) string = 'THjacobian'
4111) call DebugCreateViewer(realization%debug,string,realization%option,viewer)
4112) call MatView(J,viewer,ierr);CHKERRQ(ierr)
4113) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4114) endif
4115) if (realization%debug%norm_Jacobian) then
4116) option => realization%option
4117) call MatNorm(J,NORM_1,norm,ierr);CHKERRQ(ierr)
4118) write(option%io_buffer,'("1 norm: ",es11.4)') norm
4119) call printMsg(option)
4120) call MatNorm(J,NORM_FROBENIUS,norm,ierr);CHKERRQ(ierr)
4121) write(option%io_buffer,'("2 norm: ",es11.4)') norm
4122) call printMsg(option)
4123) call MatNorm(J,NORM_INFINITY,norm,ierr);CHKERRQ(ierr)
4124) write(option%io_buffer,'("inf norm: ",es11.4)') norm
4125) call printMsg(option)
4126) endif
4127)
4128) end subroutine THJacobian
4129)
4130) ! ************************************************************************** !
4131)
4132) subroutine THJacobianPatch(snes,xx,A,B,realization,ierr)
4133) !
4134) ! Computes the Jacobian
4135) !
4136) ! Author: ???
4137) ! Date: 12/13/07
4138) !
4139)
4140)
4141)
4142) use Connection_module
4143) use Option_module
4144) use Grid_module
4145) use Realization_Subsurface_class
4146) use Patch_module
4147) use Coupler_module
4148) use Field_module
4149) use Debug_module
4150) use Secondary_Continuum_Aux_module
4151)
4152) SNES :: snes
4153) Vec :: xx
4154) Mat :: A, B
4155) type(realization_subsurface_type) :: realization
4156)
4157) PetscErrorCode :: ierr
4158) PetscInt :: nvar,neq,nr
4159) PetscInt :: ithrm_up, ithrm_dn, i
4160) PetscInt :: ip1, ip2
4161)
4162) PetscReal, pointer :: xx_loc_p(:)
4163) PetscReal, pointer :: iphase_loc_p(:), icap_loc_p(:), ithrm_loc_p(:)
4164) PetscInt :: icap,iphas,icap_up,icap_dn
4165) PetscInt :: ii, jj
4166) PetscReal :: dw_kg,dw_mol,enth_src_co2,enth_src_h2o,rho
4167) PetscReal :: qsrc1,csrc1
4168) PetscReal :: dd_up, dd_dn, dd, f_up, f_dn
4169) PetscReal :: perm_up, perm_dn
4170) PetscReal :: D_up, D_dn ! thermal conductivity wet constants at upstream, downstream faces.
4171) PetscReal :: Dk_dry_up, Dk_dry_dn ! dry thermal conductivities
4172) PetscReal :: Dk_ice_up, Dk_ice_dn ! frozen soil thermal conductivities
4173) PetscReal :: alpha_up, alpha_dn
4174) PetscReal :: alpha_fr_up, alpha_fr_dn
4175) PetscReal :: zero, norm
4176) PetscReal :: upweight
4177) PetscReal :: max_dev
4178) PetscInt :: local_id, ghosted_id
4179) PetscInt :: local_id_up, local_id_dn
4180) PetscInt :: ghosted_id_up, ghosted_id_dn
4181)
4182) PetscReal :: Jup(realization%option%nflowdof,realization%option%nflowdof), &
4183) Jdn(realization%option%nflowdof,realization%option%nflowdof), &
4184) Jsrc(realization%option%nflowdof,realization%option%nflowdof)
4185)
4186) PetscInt :: istart, iend
4187)
4188) type(coupler_type), pointer :: boundary_condition, source_sink
4189) type(connection_set_list_type), pointer :: connection_set_list
4190) type(connection_set_type), pointer :: cur_connection_set
4191) PetscInt :: iconn, idof
4192) PetscInt :: sum_connection
4193) PetscReal :: distance, fraction_upwind
4194) PetscReal :: distance_gravity
4195) type(grid_type), pointer :: grid
4196) type(patch_type), pointer :: patch
4197) type(option_type), pointer :: option
4198) type(field_type), pointer :: field
4199) type(TH_parameter_type), pointer :: TH_parameter
4200) type(TH_auxvar_type), pointer :: auxvars(:), auxvars_bc(:),auxvars_ss(:)
4201) type(global_auxvar_type), pointer :: global_auxvars(:), global_auxvars_bc(:)
4202) class(material_auxvar_type), pointer :: material_auxvars(:)
4203)
4204) type(sec_heat_type), pointer :: sec_heat_vars(:)
4205) character(len=MAXSTRINGLENGTH) :: string
4206) PetscInt :: ithrm
4207)
4208) PetscViewer :: viewer
4209) Vec :: debug_vec
4210) PetscReal :: vol_frac_prim
4211)
4212) ! secondary continuum variables
4213) PetscReal :: area_prim_sec
4214) PetscReal :: jac_sec_heat
4215)
4216) patch => realization%patch
4217) grid => patch%grid
4218) option => realization%option
4219) field => realization%field
4220)
4221) TH_parameter => patch%aux%TH%TH_parameter
4222) auxvars => patch%aux%TH%auxvars
4223) auxvars_bc => patch%aux%TH%auxvars_bc
4224) auxvars_ss => patch%aux%TH%auxvars_ss
4225) global_auxvars => patch%aux%Global%auxvars
4226) global_auxvars_bc => patch%aux%Global%auxvars_bc
4227) material_auxvars => patch%aux%Material%auxvars
4228)
4229) sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
4230)
4231) #if 0
4232) call THNumericalJacobianTest(xx,realization)
4233) #endif
4234)
4235) call VecGetArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
4236)
4237) call VecGetArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
4238) call VecGetArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
4239) call VecGetArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
4240)
4241) vol_frac_prim = 1.d0
4242)
4243) ! Accumulation terms ------------------------------------
4244) do local_id = 1, grid%nlmax ! For each local node do...
4245) ghosted_id = grid%nL2G(local_id)
4246) ! Ignore inactive cells with inactive materials
4247) if (patch%imat(ghosted_id) <= 0) cycle
4248) iend = local_id*option%nflowdof
4249) istart = iend-option%nflowdof+1
4250) icap = int(icap_loc_p(ghosted_id))
4251)
4252) if (option%use_mc) then
4253) vol_frac_prim = sec_heat_vars(local_id)%epsilon
4254) endif
4255)
4256) ithrm = int(ithrm_loc_p(ghosted_id))
4257) call THAccumDerivative(auxvars(ghosted_id),global_auxvars(ghosted_id), &
4258) material_auxvars(ghosted_id), &
4259) TH_parameter%dencpr(ithrm), &
4260) TH_parameter, ithrm, option, &
4261) patch%saturation_function_array(icap)%ptr, &
4262) vol_frac_prim,Jup)
4263)
4264) if (option%use_mc) then
4265) call THSecondaryHeatJacobian(sec_heat_vars(local_id), &
4266) TH_parameter%ckwet(int(ithrm_loc_p(local_id))), &
4267) TH_parameter%dencpr(int(ithrm_loc_p(local_id))), &
4268) option,jac_sec_heat)
4269)
4270) Jup(option%nflowdof,2) = Jup(option%nflowdof,2) - &
4271) jac_sec_heat*material_auxvars(ghosted_id)%volume
4272) endif
4273)
4274) ! scale by the volume of the cell
4275) Jup = Jup/material_auxvars(ghosted_id)%volume
4276)
4277) call MatSetValuesBlockedLocal(A,1,ghosted_id-1,1,ghosted_id-1,Jup, &
4278) ADD_VALUES,ierr);CHKERRQ(ierr)
4279) enddo
4280)
4281)
4282) if (realization%debug%matview_Jacobian_detailed) then
4283) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4284) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4285) string = 'jacobian_accum'
4286) call DebugCreateViewer(realization%debug,string,option,viewer)
4287) call MatView(A,viewer,ierr);CHKERRQ(ierr)
4288) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4289) endif
4290)
4291) ! Source/sink terms -------------------------------------
4292) source_sink => patch%source_sink_list%first
4293) sum_connection = 0
4294) do
4295) if (.not.associated(source_sink)) exit
4296)
4297) cur_connection_set => source_sink%connection_set
4298)
4299) do iconn = 1, cur_connection_set%num_connections
4300)
4301) sum_connection = sum_connection + 1
4302) local_id = cur_connection_set%id_dn(iconn)
4303) ghosted_id = grid%nL2G(local_id)
4304)
4305) if (patch%imat(ghosted_id) <= 0) cycle
4306)
4307) if (source_sink%flow_condition%rate%itype /= HET_MASS_RATE_SS .and. &
4308) source_sink%flow_condition%itype(1) /= WELL_SS) &
4309) qsrc1 = source_sink%flow_condition%rate%dataset%rarray(1)
4310)
4311) select case (source_sink%flow_condition%rate%itype)
4312) case(MASS_RATE_SS)
4313) qsrc1 = qsrc1 / FMWH2O ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
4314) case(SCALED_MASS_RATE_SS)
4315) qsrc1 = qsrc1 / FMWH2O * &
4316) source_sink%flow_aux_real_var(ONE_INTEGER,iconn) ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
4317) case(VOLUMETRIC_RATE_SS) ! assume local density for now
4318) ! qsrc1 = m^3/sec
4319) qsrc1 = qsrc1*global_auxvars(ghosted_id)%den(1) ! den = kmol/m^3
4320) case(SCALED_VOLUMETRIC_RATE_SS) ! assume local density for now
4321) ! qsrc1 = m^3/sec
4322) qsrc1 = qsrc1*global_auxvars(ghosted_id)%den(1)* & ! den = kmol/m^3
4323) source_sink%flow_aux_real_var(ONE_INTEGER,iconn)
4324) case(HET_MASS_RATE_SS)
4325) qsrc1 = source_sink%flow_aux_real_var(ONE_INTEGER,iconn)/FMWH2O
4326) case default
4327) write(string,*) source_sink%flow_condition%rate%itype
4328) option%io_buffer='TH mode source_sink%flow_condition%rate%itype = ' // &
4329) trim(adjustl(string)) // ', not implemented.'
4330) end select
4331)
4332) Jsrc = 0.d0
4333)
4334) if (qsrc1 > 0.d0) then ! injection
4335) Jsrc(TH_TEMPERATURE_DOF,TH_PRESSURE_DOF) = &
4336) -qsrc1*auxvars_ss(sum_connection)%dh_dp
4337) ! dresT_dt = -qsrc1*hw_dt ! since tsrc1 is prescribed, there is no derivative
4338) istart = ghosted_id*option%nflowdof
4339) else
4340) ! extraction
4341) Jsrc(TH_TEMPERATURE_DOF,TH_PRESSURE_DOF) = &
4342) -qsrc1*auxvars(ghosted_id)%dh_dp
4343) Jsrc(TH_TEMPERATURE_DOF,TH_TEMPERATURE_DOF) = &
4344) -qsrc1*auxvars(ghosted_id)%dh_dt
4345) istart = ghosted_id*option%nflowdof
4346) endif
4347)
4348) ! scale by the volume of the cell
4349) Jsrc = Jsrc/material_auxvars(ghosted_id)%volume
4350)
4351) call MatSetValuesBlockedLocal(A,1,ghosted_id-1,1,ghosted_id-1,Jsrc, &
4352) ADD_VALUES,ierr);CHKERRQ(ierr)
4353)
4354)
4355) enddo
4356) source_sink => source_sink%next
4357) enddo
4358)
4359) if (realization%debug%matview_Jacobian_detailed) then
4360) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4361) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4362) string = 'jacobian_srcsink'
4363) call DebugCreateViewer(realization%debug,string,option,viewer)
4364) call MatView(A,viewer,ierr);CHKERRQ(ierr)
4365) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4366) endif
4367)
4368) ! Interior Flux Terms -----------------------------------
4369) connection_set_list => grid%internal_connection_set_list
4370) cur_connection_set => connection_set_list%first
4371) sum_connection = 0
4372) do
4373) if (.not.associated(cur_connection_set)) exit
4374) do iconn = 1, cur_connection_set%num_connections
4375) sum_connection = sum_connection + 1
4376)
4377) ghosted_id_up = cur_connection_set%id_up(iconn)
4378) ghosted_id_dn = cur_connection_set%id_dn(iconn)
4379)
4380) if (patch%imat(ghosted_id_up) <= 0 .or. &
4381) patch%imat(ghosted_id_dn) <= 0) cycle
4382)
4383) if (option%flow%only_vertical_flow) then
4384) !geh: place second conditional within first to avoid excessive
4385) ! dot products when .not. option%flow%only_vertical_flow
4386) if (dot_product(cur_connection_set%dist(1:3,iconn),unit_z) < &
4387) 1.d-10) cycle
4388) endif
4389)
4390) local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
4391) local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping
4392)
4393) fraction_upwind = cur_connection_set%dist(-1,iconn)
4394) distance = cur_connection_set%dist(0,iconn)
4395) ! distance = scalar - magnitude of distance
4396) ! gravity = vector(3)
4397) ! dist(1:3,iconn) = vector(3) - unit vector
4398) distance_gravity = distance * &
4399) dot_product(option%gravity, &
4400) cur_connection_set%dist(1:3,iconn))
4401) dd_up = distance*fraction_upwind
4402) dd_dn = distance-dd_up ! should avoid truncation error
4403) ! upweight could be calculated as 1.d0-fraction_upwind
4404) ! however, this introduces ever so slight error causing pflow-overhaul not
4405) ! to match pflow-orig. This can be changed to 1.d0-fraction_upwind
4406) upweight = dd_dn/(dd_up+dd_dn)
4407)
4408) ithrm_up = int(ithrm_loc_p(ghosted_id_up))
4409) ithrm_dn = int(ithrm_loc_p(ghosted_id_dn))
4410)
4411) D_up = TH_parameter%ckwet(ithrm_up)
4412) D_dn = TH_parameter%ckwet(ithrm_dn)
4413)
4414) Dk_dry_up = TH_parameter%ckdry(ithrm_up)
4415) Dk_dry_dn = TH_parameter%ckdry(ithrm_dn)
4416)
4417) alpha_up = TH_parameter%alpha(ithrm_up)
4418) alpha_dn = TH_parameter%alpha(ithrm_dn)
4419)
4420) if (option%use_th_freezing) then
4421) Dk_ice_up = TH_parameter%ckfrozen(ithrm_up)
4422) DK_ice_dn = TH_parameter%ckfrozen(ithrm_dn)
4423)
4424) alpha_fr_up = TH_parameter%alpha_fr(ithrm_up)
4425) alpha_fr_dn = TH_parameter%alpha_fr(ithrm_dn)
4426) else
4427) Dk_ice_up = Dk_dry_up
4428) Dk_ice_dn = Dk_dry_dn
4429)
4430) alpha_fr_up = alpha_up
4431) alpha_fr_dn = alpha_dn
4432) endif
4433)
4434) icap_up = int(icap_loc_p(ghosted_id_up))
4435) icap_dn = int(icap_loc_p(ghosted_id_dn))
4436)
4437) call THFluxDerivative(auxvars(ghosted_id_up),global_auxvars(ghosted_id_up), &
4438) material_auxvars(ghosted_id_up), &
4439) TH_parameter%sir(1,icap_up), &
4440) D_up, &
4441) ithrm_up, &
4442) auxvars(ghosted_id_dn),global_auxvars(ghosted_id_dn), &
4443) material_auxvars(ghosted_id_dn), &
4444) TH_parameter%sir(1,icap_dn), &
4445) D_dn, &
4446) ithrm_dn, &
4447) cur_connection_set%area(iconn), &
4448) cur_connection_set%dist(-1:3,iconn), &
4449) upweight,option, &
4450) patch%saturation_function_array(icap_up)%ptr, &
4451) patch%saturation_function_array(icap_dn)%ptr, &
4452) Dk_dry_up,Dk_dry_dn, &
4453) Dk_ice_up,Dk_ice_dn, &
4454) alpha_up,alpha_dn,alpha_fr_up,alpha_fr_dn, &
4455) TH_parameter, &
4456) Jup,Jdn)
4457)
4458) ! scale by the volume of the cell
4459)
4460) if (local_id_up > 0) then
4461) call MatSetValuesBlockedLocal(A,1,ghosted_id_up-1,1,ghosted_id_up-1, &
4462) Jup/material_auxvars(ghosted_id_up)%volume,ADD_VALUES, &
4463) ierr);CHKERRQ(ierr)
4464) call MatSetValuesBlockedLocal(A,1,ghosted_id_up-1,1,ghosted_id_dn-1, &
4465) Jdn/material_auxvars(ghosted_id_up)%volume,ADD_VALUES, &
4466) ierr);CHKERRQ(ierr)
4467) endif
4468) if (local_id_dn > 0) then
4469) Jup = -Jup
4470) Jdn = -Jdn
4471)
4472) call MatSetValuesBlockedLocal(A,1,ghosted_id_dn-1,1,ghosted_id_dn-1, &
4473) Jdn/material_auxvars(ghosted_id_dn)%volume,ADD_VALUES, &
4474) ierr);CHKERRQ(ierr)
4475) call MatSetValuesBlockedLocal(A,1,ghosted_id_dn-1,1,ghosted_id_up-1, &
4476) Jup/material_auxvars(ghosted_id_dn)%volume,ADD_VALUES, &
4477) ierr);CHKERRQ(ierr)
4478) endif
4479) enddo
4480) cur_connection_set => cur_connection_set%next
4481) enddo
4482)
4483) if (realization%debug%matview_Jacobian_detailed) then
4484) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4485) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4486) string = 'jacobian_flux'
4487) call DebugCreateViewer(realization%debug,string,option,viewer)
4488) call MatView(A,viewer,ierr);CHKERRQ(ierr)
4489) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4490) endif
4491)
4492) ! Boundary Flux Terms -----------------------------------
4493) boundary_condition => patch%boundary_condition_list%first
4494) sum_connection = 0
4495) do
4496) if (.not.associated(boundary_condition)) exit
4497)
4498) cur_connection_set => boundary_condition%connection_set
4499)
4500) do iconn = 1, cur_connection_set%num_connections
4501) sum_connection = sum_connection + 1
4502)
4503) local_id = cur_connection_set%id_dn(iconn)
4504) ghosted_id = grid%nL2G(local_id)
4505)
4506) if (patch%imat(ghosted_id) <= 0) cycle
4507)
4508) if (ghosted_id<=0) then
4509) print *, "Wrong boundary node index... STOP!!!"
4510) stop
4511) endif
4512)
4513) ithrm_dn = int(ithrm_loc_p(ghosted_id))
4514) D_dn = TH_parameter%ckwet(ithrm_dn)
4515) Dk_dry_dn = TH_parameter%ckdry(ithrm_dn)
4516) alpha_dn = TH_parameter%alpha(ithrm_dn)
4517)
4518) icap_dn = int(icap_loc_p(ghosted_id))
4519)
4520) if (option%use_th_freezing) then
4521) DK_ice_dn = TH_parameter%ckfrozen(ithrm_dn)
4522) alpha_fr_dn = TH_parameter%alpha_fr(ithrm_dn)
4523) else
4524) Dk_ice_dn = Dk_dry_dn
4525) alpha_fr_dn = alpha_dn
4526) endif
4527)
4528) call THBCFluxDerivative(boundary_condition%flow_condition%itype, &
4529) boundary_condition%flow_aux_real_var(:,iconn), &
4530) auxvars_bc(sum_connection), &
4531) global_auxvars_bc(sum_connection), &
4532) auxvars(ghosted_id), &
4533) global_auxvars(ghosted_id), &
4534) material_auxvars(ghosted_id), &
4535) TH_parameter%sir(1,icap_dn), &
4536) D_dn, &
4537) cur_connection_set%area(iconn), &
4538) cur_connection_set%dist(-1:3,iconn), &
4539) option, &
4540) patch%saturation_function_array(icap_dn)%ptr,&
4541) Dk_dry_dn,Dk_ice_dn, &
4542) Jdn)
4543) Jdn = -Jdn
4544)
4545) ! scale by the volume of the cell
4546) Jdn = Jdn/material_auxvars(ghosted_id)%volume
4547)
4548) call MatSetValuesBlockedLocal(A,1,ghosted_id-1,1,ghosted_id-1,Jdn,ADD_VALUES, &
4549) ierr);CHKERRQ(ierr)
4550)
4551) enddo
4552) boundary_condition => boundary_condition%next
4553) enddo
4554)
4555) if (realization%debug%matview_Jacobian_detailed) then
4556) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4557) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4558) string = 'jacobian_bcflux'
4559) call DebugCreateViewer(realization%debug,string,option,viewer)
4560) call MatView(A,viewer,ierr);CHKERRQ(ierr)
4561) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
4562) endif
4563)
4564) call VecRestoreArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
4565) call VecRestoreArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
4566) call VecRestoreArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
4567) call VecRestoreArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
4568)
4569) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4570) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4571)
4572) ! zero out isothermal and inactive cells
4573) #ifdef ISOTHERMAL_MODE_DOES_NOT_WORK
4574) zero = 0.d0
4575) call MatZeroRowsLocal(A,n_zero_rows,zero_rows_local_ghosted,zero, &
4576) PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
4577) ierr);CHKERRQ(ierr)
4578) do i=1, n_zero_rows
4579) ii = mod(zero_rows_local(i),option%nflowdof)
4580) ip1 = zero_rows_local_ghosted(i)
4581) if (ii == 0) then
4582) ip2 = ip1-1
4583) else if (ii == option%nflowdof-1) then
4584) ip2 = ip1+1
4585) else
4586) ip2 = ip1
4587) endif
4588) call MatSetValuesLocal(A,1,ip1,1,ip2,1.d0,INSERT_VALUES, &
4589) ierr);CHKERRQ(ierr)
4590) enddo
4591)
4592) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4593) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
4594) #else
4595) if (patch%aux%TH%inactive_cells_exist) then
4596) f_up = 1.d0
4597) call MatZeroRowsLocal(A,patch%aux%TH%n_zero_rows, &
4598) patch%aux%TH%zero_rows_local_ghosted,f_up, &
4599) PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
4600) ierr);CHKERRQ(ierr)
4601) endif
4602) #endif
4603)
4604) end subroutine THJacobianPatch
4605)
4606) ! ************************************************************************** !
4607)
4608) subroutine THMaxChange(realization,dpmax,dtmpmax)
4609) !
4610) ! Computes the maximum change in the solution vector
4611) !
4612) ! Author: ???
4613) ! Date: 01/15/08
4614) !
4615)
4616) use Realization_Subsurface_class
4617) use Option_module
4618) use Field_module
4619)
4620) implicit none
4621)
4622) type(realization_subsurface_type) :: realization
4623)
4624) type(option_type), pointer :: option
4625) type(field_type), pointer :: field
4626)
4627) PetscReal :: dpmax, dtmpmax
4628) PetscErrorCode :: ierr
4629)
4630) option => realization%option
4631) field => realization%field
4632)
4633) dpmax = 0.d0
4634) dtmpmax = 0.d0
4635)
4636) call VecWAXPY(field%flow_dxx,-1.d0,field%flow_xx,field%flow_yy, &
4637) ierr);CHKERRQ(ierr)
4638) call VecStrideNorm(field%flow_dxx,ZERO_INTEGER,NORM_INFINITY,dpmax, &
4639) ierr);CHKERRQ(ierr)
4640) call VecStrideNorm(field%flow_dxx,ONE_INTEGER,NORM_INFINITY,dtmpmax, &
4641) ierr);CHKERRQ(ierr)
4642)
4643) end subroutine THMaxChange
4644)
4645) ! ************************************************************************** !
4646)
4647) subroutine THResidualToMass(realization)
4648) !
4649) ! Computes mass balance from residual equation
4650) !
4651) ! Author: ???
4652) ! Date: 12/10/07
4653) !
4654)
4655) use Realization_Subsurface_class
4656) use Patch_module
4657) use Discretization_module
4658) use Field_module
4659) use Option_module
4660) use Grid_module
4661)
4662) implicit none
4663)
4664) Vec :: ts_mass_balance
4665) type(realization_subsurface_type) :: realization
4666)
4667) type(field_type), pointer :: field
4668) type(patch_type), pointer :: cur_patch
4669) type(grid_type), pointer :: grid
4670) type(option_type), pointer :: option
4671)
4672) PetscReal, pointer :: mass_balance_p(:)
4673) type(TH_auxvar_type), pointer :: auxvars(:)
4674) type(global_auxvar_type), pointer :: global_auxvars(:)
4675) PetscErrorCode :: ierr
4676) PetscInt :: local_id, ghosted_id
4677) PetscInt :: istart
4678)
4679) option => realization%option
4680) field => realization%field
4681)
4682) cur_patch => realization%patch_list%first
4683) do
4684) if (.not.associated(cur_patch)) exit
4685)
4686) grid => cur_patch%grid
4687) auxvars => cur_patch%aux%TH%auxvars
4688)
4689) call VecGetArrayF90(field%flow_ts_mass_balance,mass_balance_p, &
4690) ierr);CHKERRQ(ierr)
4691)
4692) do local_id = 1, grid%nlmax
4693) ghosted_id = grid%nL2G(local_id)
4694) if (cur_patch%imat(ghosted_id) <= 0) cycle
4695)
4696) istart = (ghosted_id-1)*option%nflowdof+1
4697) mass_balance_p(istart) = mass_balance_p(istart)/ &
4698) global_auxvars(ghosted_id)%den(1)* &
4699) global_auxvars(ghosted_id)%den_kg(1)
4700) enddo
4701)
4702) call VecRestoreArrayF90(field%flow_ts_mass_balance,mass_balance_p, &
4703) ierr);CHKERRQ(ierr)
4704)
4705) cur_patch => cur_patch%next
4706) enddo
4707)
4708) end subroutine THResidualToMass
4709)
4710) ! ************************************************************************** !
4711)
4712) function THGetTecplotHeader(realization,icolumn)
4713) !
4714) ! THLiteGetTecplotHeader: Returns TH contribution to
4715) ! Tecplot file header
4716) !
4717) ! Author: ???
4718) ! Date: 02/13/08
4719) !
4720)
4721) use Realization_Subsurface_class
4722) use Option_module
4723) use Field_module
4724)
4725) implicit none
4726)
4727) character(len=MAXSTRINGLENGTH) :: THGetTecplotHeader
4728) type(realization_subsurface_type) :: realization
4729) PetscInt :: icolumn
4730)
4731) character(len=MAXSTRINGLENGTH) :: string, string2
4732) type(option_type), pointer :: option
4733) type(field_type), pointer :: field
4734) PetscInt :: i
4735)
4736) option => realization%option
4737) field => realization%field
4738)
4739) string = ''
4740)
4741) if (icolumn > -1) then
4742) icolumn = icolumn + 1
4743) write(string2,'('',"'',i2,''-T [C]"'')') icolumn
4744) else
4745) write(string2,'('',"T [C]"'')')
4746) endif
4747) string = trim(string) // trim(string2)
4748)
4749) if (icolumn > -1) then
4750) icolumn = icolumn + 1
4751) write(string2,'('',"'',i2,''-P [Pa]"'')') icolumn
4752) else
4753) write(string2,'('',"P [Pa]"'')')
4754) endif
4755) string = trim(string) // trim(string2)
4756)
4757) if (icolumn > -1) then
4758) icolumn = icolumn + 1
4759) write(string2,'('',"'',i2,''-Sl"'')') icolumn
4760) else
4761) write(string2,'('',"Sl"'')')
4762) endif
4763) string = trim(string) // trim(string2)
4764)
4765) if (option%use_th_freezing) then
4766) if (icolumn > -1) then
4767) icolumn = icolumn + 1
4768) write(string2,'('',"'',i2,''-Sg"'')') icolumn
4769) else
4770) write(string2,'('',"Sg"'')')
4771) endif
4772) string = trim(string) // trim(string2)
4773)
4774) if (icolumn > -1) then
4775) icolumn = icolumn + 1
4776) write(string2,'('',"'',i2,''-Si"'')') icolumn
4777) else
4778) write(string2,'('',"Si"'')')
4779) endif
4780) string = trim(string) // trim(string2)
4781)
4782) if (icolumn > -1) then
4783) icolumn = icolumn + 1
4784) write(string2,'('',"'',i2,''-deni"'')') icolumn
4785) else
4786) write(string2,'('',"deni"'')')
4787) endif
4788) string = trim(string) // trim(string2)
4789) endif
4790)
4791) if (icolumn > -1) then
4792) icolumn = icolumn + 1
4793) write(string2,'('',"'',i2,''-denl"'')') icolumn
4794) else
4795) write(string2,'('',"denl"'')')
4796) endif
4797) string = trim(string) // trim(string2)
4798)
4799) if (icolumn > -1) then
4800) icolumn = icolumn + 1
4801) write(string2,'('',"'',i2,''-Ul"'')') icolumn
4802) else
4803) write(string2,'('',"Ul"'')')
4804) endif
4805) string = trim(string) // trim(string2)
4806)
4807) if (icolumn > -1) then
4808) icolumn = icolumn + 1
4809) write(string2,'('',"'',i2,''-visl"'')') icolumn
4810) else
4811) write(string2,'('',"visl"'')')
4812) endif
4813) string = trim(string) // trim(string2)
4814)
4815) if (icolumn > -1) then
4816) icolumn = icolumn + 1
4817) write(string2,'('',"'',i2,''-mobilityl"'')') icolumn
4818) else
4819) write(string2,'('',"mobilityl"'')')
4820) endif
4821) string = trim(string) // trim(string2)
4822)
4823) do i=1,option%nflowspec
4824) if (icolumn > -1) then
4825) icolumn = icolumn + 1
4826) write(string2,'('',"'',i2,''-Xl('',i2,'')"'')') icolumn,i
4827) else
4828) write(string2,'('',"Xl('',i2,'')"'')') i
4829) endif
4830) string = trim(string) // trim(string2)
4831) enddo
4832)
4833) THGetTecplotHeader = string
4834)
4835) end function THGetTecplotHeader
4836)
4837) ! ************************************************************************** !
4838)
4839) subroutine THSetPlotVariables(realization,list)
4840) !
4841) ! Adds variables to be printed to list
4842) !
4843) ! Author: Glenn Hammond
4844) ! Date: 10/15/12
4845) !
4846)
4847) use Realization_Subsurface_class
4848) use Output_Aux_module
4849) use Variables_module
4850) use Material_Aux_class
4851) use Option_module
4852)
4853) implicit none
4854)
4855) type(realization_subsurface_type) :: realization
4856) type(output_variable_list_type), pointer :: list
4857)
4858) type(output_variable_type) :: output_variable
4859) character(len=MAXWORDLENGTH) :: name, units
4860)
4861) if (associated(list%first)) then
4862) return
4863) endif
4864)
4865) name = 'Temperature'
4866) units = 'C'
4867) call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4868) TEMPERATURE)
4869)
4870) name = 'Liquid Pressure'
4871) units = 'Pa'
4872) call OutputVariableAddToList(list,name,OUTPUT_PRESSURE,units, &
4873) LIQUID_PRESSURE)
4874)
4875) name = 'Liquid Saturation'
4876) units = ''
4877) call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
4878) LIQUID_SATURATION)
4879)
4880) if (realization%option%use_th_freezing) then
4881) if (realization%option%ice_model /= DALL_AMICO) then
4882) name = 'Gas Saturation'
4883) units = ''
4884) call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
4885) GAS_SATURATION)
4886) endif
4887)
4888) name = 'Ice Saturation'
4889) units = ''
4890) call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
4891) ICE_SATURATION)
4892)
4893) name = 'Ice Density'
4894) units = 'kg/m^3'
4895) call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
4896) ICE_DENSITY)
4897) endif
4898)
4899) name = 'Liquid Density'
4900) units = 'kg/m^3'
4901) call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4902) LIQUID_DENSITY)
4903)
4904) name = 'Liquid Energy'
4905) units = 'kJ/mol'
4906) call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4907) LIQUID_ENERGY)
4908)
4909) name = 'Liquid Viscosity'
4910) units = 'Pa.s'
4911) call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4912) LIQUID_VISCOSITY)
4913)
4914) name = 'Liquid Mobility'
4915) units = '1/Pa.s'
4916) call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4917) LIQUID_MOBILITY)
4918)
4919) if (soil_compressibility_index > 0) then
4920) name = 'Transient Porosity'
4921) units = ''
4922) call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4923) EFFECTIVE_POROSITY)
4924) endif
4925) ! name = 'Phase'
4926) ! units = ''
4927) ! output_variable%iformat = 1 ! integer
4928) ! call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
4929) ! PHASE)
4930)
4931) end subroutine THSetPlotVariables
4932)
4933) ! ************************************************************************** !
4934)
4935) subroutine THComputeGradient(grid, global_auxvars, ghosted_id, gradient, &
4936) option)
4937) !
4938) ! Computes the gradient of temperature (for now) using
4939) ! least square fit of values from neighboring cells
4940) ! See:I. Bijelonja, I. Demirdzic, S. Muzaferija -- A finite volume method
4941) ! for incompressible linear elasticity, CMAME
4942) !
4943) ! Author: Satish Karra, LANL
4944) ! Date: 2/20/12
4945) !
4946)
4947)
4948) use Grid_module
4949) use Global_Aux_module
4950) use Option_module
4951) use Utility_module
4952)
4953) implicit none
4954) #include "petsc/finclude/petscdmda.h"
4955)
4956) type(option_type) :: option
4957) type(grid_type), pointer :: grid
4958) type(global_auxvar_type), pointer :: global_auxvars(:)
4959)
4960)
4961) PetscInt :: ghosted_neighbors_size, ghosted_id
4962) PetscInt :: ghosted_neighbors(26)
4963) PetscReal :: gradient(3), disp_vec(3,1), disp_mat(3,3)
4964) PetscReal :: temp_weighted(3,1)
4965) PetscInt :: i
4966)
4967) PetscInt :: INDX(3)
4968) PetscInt :: D
4969)
4970) call GridGetGhostedNeighborsWithCorners(grid,ghosted_id, &
4971) DMDA_STENCIL_STAR, &
4972) ONE_INTEGER,ONE_INTEGER,ONE_INTEGER, &
4973) ghosted_neighbors_size, &
4974) ghosted_neighbors, &
4975) option)
4976)
4977) disp_vec = 0.d0
4978) disp_mat = 0.d0
4979) temp_weighted = 0.d0
4980) do i = 1, ghosted_neighbors_size
4981) disp_vec(1,1) = grid%x(ghosted_neighbors(i)) - grid%x(ghosted_id)
4982) disp_vec(2,1) = grid%y(ghosted_neighbors(i)) - grid%y(ghosted_id)
4983) disp_vec(3,1) = grid%z(ghosted_neighbors(i)) - grid%z(ghosted_id)
4984) disp_mat = disp_mat + matmul(disp_vec,transpose(disp_vec))
4985) temp_weighted = temp_weighted + disp_vec* &
4986) (global_auxvars(ghosted_neighbors(i))%temp - &
4987) global_auxvars(ghosted_id)%temp)
4988) enddo
4989)
4990) call ludcmp(disp_mat,THREE_INTEGER,INDX,D)
4991) call lubksb(disp_mat,THREE_INTEGER,INDX,temp_weighted)
4992)
4993) gradient(:) = temp_weighted(:,1)
4994)
4995) end subroutine THComputeGradient
4996)
4997) ! ************************************************************************** !
4998)
4999) subroutine THSecondaryHeat(sec_heat_vars,global_auxvar, &
5000) therm_conductivity,dencpr, &
5001) option,res_heat)
5002) !
5003) ! Calculates the source term contribution due to secondary
5004) ! continuum in the primary continuum residual
5005) !
5006) ! Author: Satish Karra, LANL
5007) ! Date: 06/2/12
5008) !
5009)
5010) use Option_module
5011) use Global_Aux_module
5012) use Secondary_Continuum_Aux_module
5013)
5014) implicit none
5015)
5016) type(sec_heat_type) :: sec_heat_vars
5017) type(global_auxvar_type) :: global_auxvar
5018) type(option_type) :: option
5019) PetscReal :: coeff_left(sec_heat_vars%ncells)
5020) PetscReal :: coeff_diag(sec_heat_vars%ncells)
5021) PetscReal :: coeff_right(sec_heat_vars%ncells)
5022) PetscReal :: rhs(sec_heat_vars%ncells)
5023) PetscReal :: area(sec_heat_vars%ncells)
5024) PetscReal :: vol(sec_heat_vars%ncells)
5025) PetscReal :: dm_plus(sec_heat_vars%ncells)
5026) PetscReal :: dm_minus(sec_heat_vars%ncells)
5027) PetscInt :: i, ngcells
5028) PetscReal :: area_fm
5029) PetscReal :: alpha, therm_conductivity, dencpr
5030) PetscReal :: temp_primary_node
5031) PetscReal :: m
5032) PetscReal :: temp_current_N
5033) PetscReal :: res_heat
5034)
5035) ngcells = sec_heat_vars%ncells
5036) area = sec_heat_vars%area
5037) vol = sec_heat_vars%vol
5038) dm_plus = sec_heat_vars%dm_plus
5039) dm_minus = sec_heat_vars%dm_minus
5040) area_fm = sec_heat_vars%interfacial_area
5041) temp_primary_node = global_auxvar%temp
5042)
5043) coeff_left = 0.d0
5044) coeff_diag = 0.d0
5045) coeff_right = 0.d0
5046) rhs = 0.d0
5047)
5048) alpha = option%flow_dt*therm_conductivity/dencpr
5049)
5050)
5051) ! Setting the coefficients
5052) do i = 2, ngcells-1
5053) coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
5054) coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
5055) alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
5056) coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
5057) enddo
5058)
5059) coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
5060) coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
5061)
5062) coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
5063) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
5064) coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
5065) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
5066) + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
5067) + 1.d0
5068)
5069) rhs = sec_heat_vars%sec_temp ! secondary continuum values from previous time step
5070) rhs(ngcells) = rhs(ngcells) + &
5071) alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
5072) temp_primary_node
5073)
5074) ! Thomas algorithm for tridiagonal system
5075) ! Forward elimination
5076) do i = 2, ngcells
5077) m = coeff_left(i)/coeff_diag(i-1)
5078) coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
5079) rhs(i) = rhs(i) - m*rhs(i-1)
5080) enddo
5081)
5082) ! Back substitution
5083) ! We only need the temperature at the outer-most node (closest to primary node)
5084) temp_current_N = rhs(ngcells)/coeff_diag(ngcells)
5085)
5086) ! Calculate the coupling term
5087) res_heat = area_fm*therm_conductivity*(temp_current_N - temp_primary_node)/ &
5088) dm_plus(ngcells)
5089)
5090) end subroutine THSecondaryHeat
5091)
5092) ! ************************************************************************** !
5093)
5094) subroutine THSecondaryHeatJacobian(sec_heat_vars, &
5095) therm_conductivity, &
5096) dencpr, &
5097) option,jac_heat)
5098) !
5099) ! Calculates the source term jacobian contribution
5100) ! due to secondary continuum in the primary continuum residual
5101) !
5102) ! Author: Satish Karra, LANL
5103) ! Date: 06/6/12
5104) !
5105)
5106) use Option_module
5107) use Global_Aux_module
5108) use Secondary_Continuum_Aux_module
5109)
5110) implicit none
5111)
5112) type(sec_heat_type) :: sec_heat_vars
5113) type(option_type) :: option
5114) PetscReal :: coeff_left(sec_heat_vars%ncells)
5115) PetscReal :: coeff_diag(sec_heat_vars%ncells)
5116) PetscReal :: coeff_right(sec_heat_vars%ncells)
5117) PetscReal :: rhs(sec_heat_vars%ncells)
5118) PetscReal :: area(sec_heat_vars%ncells)
5119) PetscReal :: vol(sec_heat_vars%ncells)
5120) PetscReal :: dm_plus(sec_heat_vars%ncells)
5121) PetscReal :: dm_minus(sec_heat_vars%ncells)
5122) PetscInt :: i, ngcells
5123) PetscReal :: area_fm
5124) PetscReal :: alpha, therm_conductivity, dencpr
5125) PetscReal :: m
5126) PetscReal :: Dtemp_N_Dtemp_prim
5127) PetscReal :: jac_heat
5128)
5129) ngcells = sec_heat_vars%ncells
5130) area = sec_heat_vars%area
5131) vol = sec_heat_vars%vol
5132) dm_plus = sec_heat_vars%dm_plus
5133) area_fm = sec_heat_vars%interfacial_area
5134) dm_minus = sec_heat_vars%dm_minus
5135)
5136) coeff_left = 0.d0
5137) coeff_diag = 0.d0
5138) coeff_right = 0.d0
5139) rhs = 0.d0
5140)
5141) alpha = option%flow_dt*therm_conductivity/dencpr
5142)
5143) ! Setting the coefficients
5144) do i = 2, ngcells-1
5145) coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
5146) coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
5147) alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
5148) coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
5149) enddo
5150)
5151) coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
5152) coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
5153)
5154) coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
5155) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
5156) coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
5157) ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
5158) + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
5159) + 1.d0
5160)
5161) ! Thomas algorithm for tridiagonal system
5162) ! Forward elimination
5163) do i = 2, ngcells
5164) m = coeff_left(i)/coeff_diag(i-1)
5165) coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
5166) ! We do not have to calculate rhs terms
5167) enddo
5168)
5169) ! We need the temperature derivative at the outer-most node (closest to primary node)
5170) Dtemp_N_Dtemp_prim = 1.d0/coeff_diag(ngcells)*alpha*area(ngcells)/ &
5171) (dm_plus(ngcells)*vol(ngcells))
5172)
5173) ! Calculate the jacobian term
5174) jac_heat = area_fm*therm_conductivity*(Dtemp_N_Dtemp_prim - 1.d0)/ &
5175) dm_plus(ngcells)
5176)
5177)
5178) end subroutine THSecondaryHeatJacobian
5179)
5180)
5181) ! ************************************************************************** !
5182) function THInitGuessCheck(xx, option)
5183) !
5184) ! Checks if the initial guess is valid.
5185) ! Note: Only implemented for DALL_AMICO formulation.
5186) !
5187) ! Author: Gautam Bisht, LBNL
5188) ! Date: 12/04/2014
5189) !
5190) use Option_module
5191)
5192) Vec :: xx
5193) type(option_type), pointer :: option
5194)
5195) PetscInt :: THInitGuessCheck
5196) PetscInt :: idx
5197) PetscReal :: pres_min, pres_max
5198) PetscReal :: temp_min, temp_max
5199) PetscInt :: ipass, ipass0
5200) PetscErrorCode :: ierr
5201)
5202) ipass = 1
5203)
5204) if (option%ice_model /= DALL_AMICO) then
5205) THInitGuessCheck = ipass
5206) return
5207) endif
5208)
5209) call VecStrideMin(xx,ZERO_INTEGER,idx,pres_min,ierr)
5210) call VecStrideMin(xx,ONE_INTEGER ,idx,temp_min,ierr)
5211) call VecStrideMax(xx,ZERO_INTEGER,idx,pres_max,ierr)
5212) call VecStrideMax(xx,ONE_INTEGER ,idx,temp_max,ierr)
5213)
5214) if (pres_min < -1.d10 .or. pres_min > 1.d10 .or. &
5215) temp_min < -100.d0 .or. temp_max > 100.d0) then
5216) ipass = -1
5217) endif
5218)
5219) call MPI_Barrier(option%mycomm,ierr)
5220) if (option%mycommsize>1)then
5221) call MPI_Allreduce(ipass,ipass0,ONE_INTEGER_MPI,MPIU_INTEGER,MPI_SUM, &
5222) option%mycomm,ierr)
5223) if (ipass0 < option%mycommsize) ipass=-1
5224) endif
5225) THInitGuessCheck = ipass
5226)
5227) end function THInitGuessCheck
5228)
5229) ! ************************************************************************** !
5230)
5231) subroutine EnergyToTemperatureBisection(T,TL,TR,h,energy,Cwi,Pr,option)
5232) !
5233) ! Solves the following nonlinear equation using the bisection method
5234) !
5235) ! R(T) = rho(T) Cwi hw T - energy = 0
5236) !
5237) ! Author: Nathan Collier, ORNL
5238) ! Date: 11/2014
5239) !
5240) use EOS_Water_module
5241) use Option_module
5242)
5243) implicit none
5244)
5245) PetscReal :: T,TL,TR,h,energy,Cwi,Pr
5246) type(option_type), pointer :: option
5247)
5248) PetscReal :: Tp,rho,rho_t,f,fR,fL,rtol
5249) PetscInt :: iter,niter
5250) PetscBool :: found
5251) PetscErrorCode :: ierr
5252)
5253) call EOSWaterdensity(TR,Pr,rho,rho_T,ierr)
5254) fR = rho*Cwi*h*(TR+273.15d0) - energy
5255) call EOSWaterdensity(TL,Pr,rho,rho_T,ierr)
5256) fL = rho*Cwi*h*(TL+273.15d0) - energy
5257)
5258) if (fL*fR > 0.d0) then
5259) print *,"[TL,TR] = ",TL,TR
5260) print *,"[fL,fR] = ",fL,fR
5261) write(option%io_buffer,'("th.F90: EnergyToTemperatureBisection --> root is not bracketed")')
5262) call printErrMsg(option)
5263) endif
5264)
5265) T = 0.5d0*(TL+TR)
5266) call EOSWaterdensity(T,Pr,rho,rho_T,ierr)
5267) f = rho*Cwi*h*(T+273.15d0) - energy
5268)
5269) found = PETSC_FALSE
5270) niter = 200
5271) rtol = 1.d-6
5272) do iter = 1,niter
5273) Tp = T
5274) if (fL*f < 0.d0) then
5275) TR = T
5276) else
5277) TL = T
5278) endif
5279)
5280) T = 0.5d0*(TL+TR)
5281)
5282) call EOSWaterdensity(T,Pr,rho,rho_T,ierr)
5283) f = rho*Cwi*h*(T+273.15d0) - energy
5284)
5285) if (abs((T-Tp)/(T+273.15d0)) < rtol) then
5286) found = PETSC_TRUE
5287) exit
5288) endif
5289) enddo
5290)
5291) if (found .eqv. PETSC_FALSE) then
5292) print *,"[TL,T,TR] = ",TL,T,TR
5293) write(option%io_buffer,'("th.F90: EnergyToTemperatureBisection --> root not found!")')
5294) call printErrMsg(option)
5295) endif
5296)
5297) end subroutine EnergyToTemperatureBisection
5298)
5299) ! ************************************************************************** !
5300)
5301) subroutine THUpdateSurfaceBC(realization)
5302) !
5303) ! Updates pressure and temperature BC associated with surface-flow
5304) !
5305) ! Author: Gautam Bisht
5306) ! Date: 10/23/13
5307) !
5308)
5309) use Realization_Subsurface_class
5310) use Patch_module
5311) use Option_module
5312) use Grid_module
5313) use Region_module
5314) use Coupler_module
5315) use Connection_module
5316) use Fluid_module
5317) use Secondary_Continuum_Aux_module
5318) use Secondary_Continuum_module
5319) use String_module
5320) use EOS_Water_module
5321) use PFLOTRAN_Constants_module, only : DUMMY_VALUE,UNINITIALIZED_DOUBLE
5322)
5323) implicit none
5324)
5325) type(realization_subsurface_type) :: realization
5326)
5327) PetscInt :: ghosted_id
5328) PetscInt :: local_id
5329) PetscInt :: sum_connection
5330) PetscInt :: iconn
5331) PetscInt :: iter
5332) PetscInt :: niter
5333) PetscReal :: eflux
5334) PetscReal :: eflux_bulk
5335) PetscReal :: eflux_cond
5336) PetscReal :: area
5337) PetscReal :: den
5338) PetscReal :: den_surf_at_Told
5339) PetscReal :: den_subsurf
5340) PetscReal :: den_aveg
5341) PetscReal :: dum1
5342) PetscReal :: head_old
5343) PetscReal :: head_new
5344) PetscReal :: dhead
5345) PetscReal :: surfpress_old
5346) PetscReal :: surfpress_new
5347) PetscReal :: eng_per_unitvol_old
5348) PetscReal :: eng_per_unitvol_new
5349) PetscReal :: eng_times_ht_per_unitvol_old
5350) PetscReal :: eng_times_ht_per_unitvol_new
5351) PetscReal :: deng_times_ht_per_unitvol
5352) PetscReal :: enthalpy
5353) PetscReal :: surftemp_old
5354) PetscReal :: Temp_upwind
5355) PetscReal :: surftemp_new,psurftemp_new,rtol
5356) PetscReal :: Cwi,TL,TR,one
5357) PetscBool :: found
5358) PetscErrorCode :: ierr
5359)
5360) type(grid_type), pointer :: grid
5361) type(patch_type), pointer :: patch
5362) type(option_type), pointer :: option
5363) type(coupler_type), pointer :: boundary_condition
5364) type(connection_set_type), pointer :: cur_connection_set
5365) type(global_auxvar_type), pointer :: global_auxvars(:)
5366) type(TH_auxvar_type), pointer :: auxvars(:), auxvars_bc(:)
5367)
5368) option => realization%option
5369) patch => realization%patch
5370) grid => patch%grid
5371) global_auxvars => realization%patch%aux%Global%auxvars
5372) auxvars => patch%aux%TH%auxvars
5373) auxvars_bc => patch%aux%TH%auxvars_bc
5374)
5375) ! GB: Should probably add this as a member of option
5376) Cwi = 4.188d3 ! [J/kg/K]
5377) one = 1.d0
5378)
5379) ! Maximum no. of iterations to compute updated temperature of surface-flow
5380) niter = 20
5381) rtol = 1.d-12
5382)
5383) eflux_bulk = 0.d0
5384) eflux_cond = 0.d0
5385)
5386) ! boundary conditions
5387) boundary_condition => patch%boundary_condition_list%first
5388) sum_connection = 0
5389) do
5390) if (.not.associated(boundary_condition)) exit
5391) cur_connection_set => boundary_condition%connection_set
5392) if (StringCompare(boundary_condition%name,'from_surface_bc')) then
5393)
5394) if (boundary_condition%flow_condition%itype(TH_PRESSURE_DOF) /= &
5395) HET_SURF_SEEPAGE_BC) then
5396) call printErrMsg(option,'from_surface_bc is not of type ' // &
5397) 'HET_SURF_SEEPAGE_BC')
5398) endif
5399)
5400) do iconn = 1, cur_connection_set%num_connections
5401) sum_connection = sum_connection + 1
5402) local_id = cur_connection_set%id_dn(iconn)
5403) ghosted_id = grid%nL2G(local_id)
5404)
5405) eflux = patch%boundary_flow_fluxes(TH_TEMPERATURE_DOF,sum_connection) ! [MJ/s]
5406) eflux_bulk = patch%boundary_energy_flux(1,sum_connection) ! [MJ/s]
5407) eflux_cond = patch%boundary_energy_flux(2,sum_connection) ! [MJ/s]
5408)
5409) ! [MJ/s] to [J/s]
5410) !geh: default internal energy units are MJ (option%scale = 1.d-6 is for J->MJ)
5411) eflux = eflux/(1.d6*option%scale)
5412) area = cur_connection_set%area(iconn) ! [m^2]
5413)
5414) surfpress_old = &
5415) boundary_condition%flow_aux_real_var(TH_PRESSURE_DOF,iconn)
5416) surftemp_old = &
5417) boundary_condition%flow_aux_real_var(TH_TEMPERATURE_DOF,iconn)
5418) call EOSWaterdensity(surftemp_old,option%reference_pressure,den,dum1,ierr)
5419)
5420) head_old = (surfpress_old - option%reference_pressure)/den/abs(option%gravity(3)) ! [m]
5421) dhead = patch%boundary_velocities(1,sum_connection)*option%flow_dt ! [m]
5422) head_new = head_old - dhead ! [m]
5423) surftemp_new = UNINITIALIZED_DOUBLE ! to ensure we end up setting this
5424)
5425) if (head_new <= MIN_SURFACE_WATER_HEIGHT) then
5426) surfpress_new = option%reference_pressure
5427) surftemp_new = DUMMY_VALUE
5428) else
5429)
5430) if (head_old <= MIN_SURFACE_WATER_HEIGHT) then
5431)
5432) ! Surface water was absent prior to subsurface step and exfiltration
5433) ! occured during the subsurface step.
5434)
5435) surftemp_new = global_auxvars(ghosted_id)%temp
5436) call EOSWaterdensity(surftemp_new,option%reference_pressure,den,dum1,ierr)
5437) surfpress_new = head_new*(abs(option%gravity(3)))*den + &
5438) option%reference_pressure
5439) else
5440)
5441) ! Surface water was present prior to subsurface step
5442)
5443) ! Compute the new and old energy states based on the energy flux
5444) call EOSWaterdensity(surftemp_old,option%reference_pressure,den_surf_at_Told,dum1,ierr)
5445)
5446) !noc: surftemp_new is uninitialized at this point, so moving
5447) !these two lines below (1). Alternatively we could
5448) !evaluate this density at global_auxvars(ghosted_id)%temp.
5449) !
5450) !call EOSWaterdensity(surftemp_new,option%reference_pressure,den_subsurf ,dum1,ierr)
5451) !den_aveg = 0.5d0*(den_surf_at_Told + den_subsurf)
5452)
5453) ! 1) Find new surface-temperature due to heat transfer via conduction.
5454) den = den_surf_at_Told
5455) eng_per_unitvol_old = den*Cwi*(surftemp_old + 273.15d0)
5456) !geh: default internal energy units are MJ (option%scale = 1.d-6 is for J->MJ)
5457) eng_per_unitvol_new = eng_per_unitvol_old - eflux_cond/(1.d6*option%scale)*option%flow_dt/area
5458)
5459) TL = -100.d0
5460) TR = 100.d0
5461) if (den*Cwi*(TL+273.15d0) < eng_per_unitvol_new) then
5462) surftemp_new = surftemp_old
5463) else
5464) call EnergyToTemperatureBisection(surftemp_new,TL,TR, &
5465) one, &
5466) eng_per_unitvol_new, &
5467) Cwi, &
5468) option%reference_pressure, &
5469) option)
5470) endif
5471)
5472) ! 2) Find new surface-temperature due to heat transfer via bulk-movement
5473) ! water transport
5474) if (patch%boundary_velocities(1,sum_connection) < 0) then
5475) Temp_upwind = global_auxvars(ghosted_id)%temp
5476) else
5477) Temp_upwind = surftemp_old
5478) endif
5479)
5480) call EOSWaterdensity(surftemp_new,option%reference_pressure,den_subsurf,dum1,ierr)
5481) den_aveg = 0.5d0*(den_surf_at_Told + den_subsurf)
5482)
5483) ! In THBCFlux():
5484) ! fluxe_bulk = (rho*q*H) [kmol/m^3 * m^3/s * MJ/kmol] = [MJ/s]
5485) ! = (rho*v_darcy*area*H) [kmol/m^3 * m/s * m^2 * MJ/kmol]
5486)
5487) ! Retrieve H in units of [J/kg] from fluxe_bulk
5488) ! = [MJ/s * J/MJ * m^3/kg * m^{-2} * s/m]
5489) if (abs(patch%boundary_velocities(1,sum_connection))<1.d-14) then ! avoid division by zero
5490) enthalpy = 0.d0
5491) else
5492) !geh: default internal energy units are MJ (option%scale = 1.d-6 is for J->MJ)
5493) enthalpy = eflux_bulk/(1.d6*option%scale)/den_aveg/area/patch%boundary_velocities(1,sum_connection)
5494) endif
5495)
5496) surftemp_old = surftemp_new
5497) eng_times_ht_per_unitvol_old = den *(Cwi*surftemp_old + Cwi*273.15d0)*head_old
5498) deng_times_ht_per_unitvol = den_aveg*(enthalpy + Cwi*273.15d0)*dhead
5499) eng_times_ht_per_unitvol_new = eng_times_ht_per_unitvol_old - deng_times_ht_per_unitvol
5500)
5501) TL = -100.d0
5502) TR = 100.d0
5503) if (den*Cwi*head_new*(TL+273.15d0) < eng_times_ht_per_unitvol_new) then
5504) surftemp_new = surftemp_old
5505) else
5506) call EnergyToTemperatureBisection(surftemp_new,TL,TR, &
5507) head_new, &
5508) eng_times_ht_per_unitvol_new, &
5509) Cwi, &
5510) option%reference_pressure, &
5511) option)
5512) endif
5513)
5514) call EOSWaterdensity(surftemp_new,option%reference_pressure,den,dum1,ierr)
5515) surfpress_new = head_new*(abs(option%gravity(3)))*den + &
5516) option%reference_pressure
5517) endif
5518) endif
5519)
5520) boundary_condition%flow_aux_real_var(TH_PRESSURE_DOF,iconn) = &
5521) surfpress_new
5522) boundary_condition%flow_aux_real_var(TH_TEMPERATURE_DOF,iconn) = &
5523) surftemp_new
5524) enddo
5525)
5526) else
5527) sum_connection = sum_connection + cur_connection_set%num_connections
5528) endif
5529)
5530) boundary_condition => boundary_condition%next
5531)
5532) enddo
5533)
5534) end subroutine THUpdateSurfaceBC
5535)
5536) ! ************************************************************************** !
5537)
5538) subroutine THUpdateSurfaceWaterFlag(realization)
5539) !
5540) ! For BC cells, set the flag for presence or absence of standing water
5541) !
5542) ! Author: Gautam Bisht
5543) ! Date: 04/17/14
5544) !
5545)
5546) use Realization_Subsurface_class
5547) use Patch_module
5548) use Option_module
5549) use Grid_module
5550) use Coupler_module
5551) use Connection_module
5552) use String_module
5553)
5554) implicit none
5555)
5556) type(realization_subsurface_type) :: realization
5557)
5558) type(coupler_type), pointer :: boundary_condition
5559) type(TH_auxvar_type), pointer :: TH_auxvars_bc(:)
5560) type(TH_auxvar_type), pointer :: TH_auxvars(:)
5561) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
5562) type(grid_type), pointer :: grid
5563) type(patch_type), pointer :: patch
5564) type(option_type), pointer :: option
5565) type(connection_set_type), pointer :: cur_connection_set
5566)
5567) PetscInt :: ghosted_id
5568) PetscInt :: local_id
5569) PetscInt :: sum_connection
5570) PetscInt :: iconn
5571)
5572) option => realization%option
5573) patch => realization%patch
5574) grid => patch%grid
5575) global_auxvars_bc => patch%aux%Global%auxvars_bc
5576) TH_auxvars_bc => patch%aux%TH%auxvars_bc
5577) TH_auxvars => patch%aux%TH%auxvars
5578)
5579) boundary_condition => patch%boundary_condition_list%first
5580) sum_connection = 0
5581) do
5582) if (.not.associated(boundary_condition)) exit
5583)
5584) cur_connection_set => boundary_condition%connection_set
5585)
5586) if (StringCompare(boundary_condition%name,'from_surface_bc')) then
5587)
5588) sum_connection = sum_connection + 1
5589) do iconn = 1, cur_connection_set%num_connections
5590) local_id = cur_connection_set%id_dn(iconn)
5591) ghosted_id = grid%nL2G(local_id)
5592) if (patch%imat(ghosted_id) <= 0) cycle
5593)
5594) if (global_auxvars_bc(sum_connection)%pres(1) - option%reference_pressure < eps) then
5595) TH_auxvars_bc(sum_connection)%surface%surf_wat = PETSC_FALSE
5596) TH_auxvars(ghosted_id)%surface%surf_wat = PETSC_FALSE
5597) else
5598) TH_auxvars_bc(sum_connection)%surface%surf_wat = PETSC_TRUE
5599) TH_auxvars(ghosted_id)%surface%surf_wat = PETSC_TRUE
5600) endif
5601) enddo
5602)
5603) else
5604)
5605) sum_connection = sum_connection + cur_connection_set%num_connections
5606)
5607) endif
5608)
5609) boundary_condition => boundary_condition%next
5610) enddo
5611)
5612) end subroutine THUpdateSurfaceWaterFlag
5613)
5614) ! ************************************************************************** !
5615)
5616) subroutine THComputeCoeffsForSurfFlux(realization)
5617) !
5618) ! This routine computes coefficients for approximation boundary darcy
5619) ! flux between surface and subsurface domains.
5620) !
5621) ! Author: Gautam Bisht, LBNL
5622) ! Date: 05/21/14
5623) !
5624)
5625) use Realization_Subsurface_class
5626) use Patch_module
5627) use Option_module
5628) use Field_module
5629) use Grid_module
5630) use Coupler_module
5631) use Connection_module
5632) use Material_module
5633) use Logging_module
5634) use String_module
5635) use EOS_Water_module
5636) use Material_Aux_class
5637) use Utility_module
5638)
5639) implicit none
5640)
5641) type(realization_subsurface_type) :: realization
5642)
5643) type(option_type), pointer :: option
5644) type(patch_type), pointer :: patch
5645) type(grid_type), pointer :: grid
5646) type(field_type), pointer :: field
5647) type(coupler_type), pointer :: boundary_condition
5648) type(connection_set_type), pointer :: cur_connection_set
5649) type(th_auxvar_type), pointer :: th_auxvars_bc(:)
5650) type(th_auxvar_type), pointer :: th_auxvars(:)
5651) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
5652) type(global_auxvar_type), pointer :: global_auxvars(:)
5653) type(th_parameter_type), pointer :: th_parameter
5654) type(th_auxvar_type) :: th_auxvar_max
5655) type(global_auxvar_type) :: global_auxvar_max
5656) type(th_auxvar_type),pointer :: th_auxvar_up, th_auxvar_dn
5657) type(global_auxvar_type) :: global_auxvar_up, global_auxvar_dn
5658) class(material_auxvar_type), pointer :: material_auxvars(:)
5659) class(material_auxvar_type), pointer :: material_auxvar_dn
5660)
5661) PetscInt :: pressure_bc_type
5662) PetscInt :: ghosted_id
5663) PetscInt :: local_id
5664) PetscInt :: sum_connection
5665) PetscInt :: iconn
5666) PetscInt :: icap_dn
5667) PetscInt :: iphase
5668)
5669) PetscReal :: dist_gravity ! distance along gravity vector
5670) PetscReal :: dist(-1:3)
5671) PetscReal :: gravity
5672) PetscReal :: Dq
5673) PetscReal :: sir_dn
5674) PetscReal :: P_max_pert,P_min_pert,temp_pert
5675) PetscReal :: perm_dn
5676) PetscReal :: area
5677) PetscReal, pointer :: iphase_loc_p(:)
5678) PetscReal :: coeff_for_cubic_approx_pert(4)
5679) PetscReal :: range_for_linear_approx_pert(4)
5680) PetscReal :: slope_1, slope_2
5681) PetscReal :: num, den
5682) PetscErrorCode :: ierr
5683) PetscReal, pointer :: xx_p(:)
5684) PetscReal, pointer :: ithrm_loc_p(:)
5685) PetscInt :: ithrm_up
5686) PetscInt :: ithrm_dn
5687)
5688) option => realization%option
5689) patch => realization%patch
5690) grid => patch%grid
5691) field => realization%field
5692)
5693) th_parameter => patch%aux%TH%th_parameter
5694) material_auxvars => patch%aux%Material%auxvars
5695)
5696) th_auxvars => patch%aux%TH%auxvars
5697) th_auxvars_bc => patch%aux%TH%auxvars_bc
5698) global_auxvars => patch%aux%Global%auxvars
5699) global_auxvars_bc => patch%aux%Global%auxvars_bc
5700)
5701) call VecGetArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
5702) call VecGetArrayF90(field%flow_yy, xx_p, ierr);CHKERRQ(ierr)
5703) call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
5704)
5705) ! boundary conditions
5706) boundary_condition => patch%boundary_condition_list%first
5707) sum_connection = 0
5708) do
5709) if (.not.associated(boundary_condition)) exit
5710) cur_connection_set => boundary_condition%connection_set
5711) if (StringCompare(boundary_condition%name,'from_surface_bc')) then
5712)
5713) pressure_bc_type = boundary_condition%flow_condition%itype(TH_PRESSURE_DOF)
5714)
5715) if (pressure_bc_type /= HET_SURF_SEEPAGE_BC) then
5716) call printErrMsg(option,'from_surface_bc is not of type ' // &
5717) 'HET_SURF_SEEPAGE_BC')
5718) endif
5719)
5720) do iconn = 1, cur_connection_set%num_connections
5721)
5722) sum_connection = sum_connection + 1
5723) local_id = cur_connection_set%id_dn(iconn)
5724) ghosted_id = grid%nL2G(local_id)
5725) iphase = int(iphase_loc_p(ghosted_id))
5726)
5727) ! Step-1: Find P_max/P_min for cubic polynomial approximation
5728)
5729) global_auxvar_up = global_auxvars_bc(sum_connection)
5730) global_auxvar_dn = global_auxvars(ghosted_id)
5731)
5732) th_auxvar_up => th_auxvars_bc(sum_connection)
5733) th_auxvar_dn => th_auxvars(ghosted_id)
5734) material_auxvar_dn => material_auxvars(ghosted_id)
5735)
5736) if (xx_p(ghosted_id*option%nflowdof-1) > 100000.d0) then
5737) th_auxvar_dn%surface%bcflux_default_scheme = PETSC_TRUE
5738) else
5739) th_auxvar_dn%surface%bcflux_default_scheme = PETSC_FALSE
5740) endif
5741)
5742) th_auxvar_dn%surface%coeff_for_cubic_approx(:) = -99999.d0
5743)
5744) dist = cur_connection_set%dist(:,iconn)
5745)
5746) call material_auxvar_dn%PermeabilityTensorToScalar(dist,perm_dn)
5747)
5748) dist_gravity = dist(0) * dot_product(option%gravity,dist(1:3))
5749) Dq = perm_dn / dist(0)
5750) area = cur_connection_set%area(iconn)
5751)
5752) icap_dn = patch%sat_func_id(ghosted_id)
5753) sir_dn = th_parameter%sir(1,icap_dn)
5754)
5755) ithrm_up = int(ithrm_loc_p(ghosted_id))
5756) ithrm_dn = int(ithrm_loc_p(ghosted_id))
5757)
5758) ! Compute coeff
5759) call ComputeCoeffsForApprox(global_auxvar_up%pres(1), &
5760) global_auxvar_up%temp, &
5761) ithrm_up, &
5762) global_auxvar_dn%pres(1), &
5763) global_auxvar_dn%temp, &
5764) ithrm_dn, &
5765) material_auxvars(ghosted_id), &
5766) TH_parameter, &
5767) iphase, &
5768) patch%saturation_function_array(icap_dn)%ptr, &
5769) dist_gravity, &
5770) area, &
5771) Dq, &
5772) sir_dn, &
5773) option, &
5774) th_auxvar_dn%surface%P_min, &
5775) th_auxvar_dn%surface%P_max, &
5776) th_auxvar_dn%surface%coeff_for_cubic_approx, &
5777) th_auxvar_dn%surface%range_for_linear_approx)
5778)
5779) temp_pert = global_auxvar_dn%temp*perturbation_tolerance
5780)
5781) call ComputeCoeffsForApprox(global_auxvar_up%pres(1), &
5782) global_auxvar_up%temp, &
5783) ithrm_up, &
5784) global_auxvar_dn%pres(1), &
5785) global_auxvar_dn%temp + temp_pert, &
5786) ithrm_dn, &
5787) material_auxvars(ghosted_id), &
5788) TH_parameter, &
5789) iphase, &
5790) patch%saturation_function_array(icap_dn)%ptr, &
5791) dist_gravity, &
5792) area, &
5793) Dq, &
5794) sir_dn, &
5795) option, &
5796) P_min_pert, &
5797) P_max_pert, &
5798) coeff_for_cubic_approx_pert, &
5799) range_for_linear_approx_pert)
5800)
5801) th_auxvar_dn%surface%coeff_for_deriv_cubic_approx(1) = &
5802) (coeff_for_cubic_approx_pert(1) - &
5803) th_auxvar_dn%surface%coeff_for_cubic_approx(1))/temp_pert
5804)
5805) th_auxvar_dn%surface%coeff_for_deriv_cubic_approx(2) = &
5806) (coeff_for_cubic_approx_pert(2) - &
5807) th_auxvar_dn%surface%coeff_for_cubic_approx(2))/temp_pert
5808)
5809) th_auxvar_dn%surface%coeff_for_deriv_cubic_approx(3) = &
5810) (coeff_for_cubic_approx_pert(3) - &
5811) th_auxvar_dn%surface%coeff_for_cubic_approx(3))/temp_pert
5812)
5813) th_auxvar_dn%surface%coeff_for_deriv_cubic_approx(4) = &
5814) (coeff_for_cubic_approx_pert(4) - &
5815) th_auxvar_dn%surface%coeff_for_cubic_approx(4))/temp_pert
5816)
5817) num = (th_auxvar_dn%surface%range_for_linear_approx(4) - &
5818) th_auxvar_dn%surface%range_for_linear_approx(3))
5819) den = (th_auxvar_dn%surface%range_for_linear_approx(2) - &
5820) th_auxvar_dn%surface%range_for_linear_approx(1))
5821) if (abs(den) < 1.d-10) den = 1.d-10
5822) slope_1 = num/den
5823)
5824) num = (range_for_linear_approx_pert(4) - &
5825) range_for_linear_approx_pert(3))
5826) den = (range_for_linear_approx_pert(2) - &
5827) range_for_linear_approx_pert(1))
5828) if (abs(den) < 1.d-10) den = 1.d-10
5829) slope_2 = num/den
5830)
5831) th_auxvar_dn%surface%dlinear_slope_dT = (slope_2 - slope_1)/temp_pert
5832)
5833) enddo
5834)
5835) else
5836)
5837) sum_connection = sum_connection + cur_connection_set%num_connections
5838)
5839) endif
5840)
5841) boundary_condition => boundary_condition%next
5842)
5843) enddo
5844)
5845) call VecRestoreArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
5846) call VecRestoreArrayF90(field%flow_yy, xx_p, ierr);CHKERRQ(ierr)
5847) call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
5848)
5849) end subroutine THComputeCoeffsForSurfFlux
5850)
5851)
5852) ! ************************************************************************** !
5853)
5854) subroutine ComputeCoeffsForApprox(P_up, T_up, ithrm_up, &
5855) P_dn, T_dn, ithrm_dn, &
5856) material_auxvar, &
5857) th_parameter, &
5858) iphase, &
5859) saturation_function, &
5860) dist_gravity, &
5861) area, &
5862) Dq, &
5863) sir_dn, &
5864) option, &
5865) P_min, P_max, &
5866) coeff_for_cubic_approx, &
5867) range_for_linear_approx)
5868) !
5869) ! To smoothly approximation boundary darcy flux, this routine computes
5870) ! (i) coefficients for polynomial approximation and
5871) ! (ii) range for linear approximation
5872) !
5873) ! Author: Gautam Bisht, LBNL
5874) ! Date: 05/30/14
5875) !
5876)
5877) use EOS_Water_module
5878) use Field_module
5879) use Material_Aux_class
5880) use Option_module
5881) use Saturation_Function_module
5882) use String_module
5883) use Utility_module
5884)
5885) implicit none
5886)
5887) PetscReal :: P_up, T_up
5888) PetscInt :: ithrm_up
5889) PetscReal :: P_dn, T_dn
5890) PetscInt :: ithrm_dn
5891) class(material_auxvar_type) :: material_auxvar
5892) type(TH_parameter_type) :: th_parameter
5893) PetscInt :: iphase
5894) type(saturation_function_type) :: saturation_function
5895) PetscReal :: dist_gravity
5896) PetscReal :: area
5897) PetscReal :: Dq
5898) PetscReal :: sir_dn
5899) type(option_type) :: option
5900) PetscReal, intent(out) :: P_min
5901) PetscReal, intent(out) :: P_max
5902) PetscReal, intent(out) :: coeff_for_cubic_approx(4)
5903) PetscReal, intent(out) :: range_for_linear_approx(4)
5904)
5905) type(global_auxvar_type) :: global_auxvar_up
5906) type(global_auxvar_type) :: global_auxvar_dn
5907) type(global_auxvar_type) :: global_auxvar_max
5908) type(th_auxvar_type) :: th_auxvar_up
5909) type(th_auxvar_type) :: th_auxvar_dn
5910) type(th_auxvar_type) :: th_auxvar_max
5911)
5912) PetscReal :: xx(option%nflowdof)
5913) PetscReal :: den
5914) PetscReal :: dum1
5915) PetscReal :: upweight,gravity,dphi
5916) PetscReal :: ukvr
5917) PetscReal :: P_allowable
5918) PetscReal :: v_darcy_allowable,v_darcy
5919) PetscReal :: q_allowable,q
5920) PetscReal :: dq_dp_dn
5921) PetscReal :: dP
5922) PetscReal :: density_ave
5923) PetscReal :: dgravity_dden_dn
5924) PetscReal :: dukvr_dp_dn
5925) PetscReal :: dphi_dp_dn
5926) PetscReal :: perm_dn
5927) PetscReal :: slope
5928) PetscErrorCode :: ierr
5929)
5930) ! Distance away from allowable pressure at which cubic approximation begins
5931) dP = 10 ! [Pa]
5932)
5933) call GlobalAuxVarInit(global_auxvar_up,option)
5934) call GlobalAuxVarInit(global_auxvar_dn,option)
5935) call GlobalAuxVarInit(global_auxvar_max,option)
5936)
5937) call THAuxVarInit(th_auxvar_up,option)
5938) call THAuxVarInit(th_auxvar_dn,option)
5939) call THAuxVarInit(th_auxvar_max,option)
5940)
5941) ! Step-1: Set auxvars (global and th) for up/dn
5942) if (option%use_th_freezing) then
5943)
5944) xx(1) = P_up
5945) xx(2) = T_up
5946) call THAuxVarComputeFreezing(xx, &
5947) th_auxvar_up, &
5948) global_auxvar_up, &
5949) material_auxvar, &
5950) iphase, &
5951) saturation_function, &
5952) th_parameter, &
5953) ithrm_up, &
5954) option)
5955)
5956) xx(1) = P_dn
5957) xx(2) = T_dn
5958) call THAuxVarComputeFreezing(xx, &
5959) th_auxvar_dn, &
5960) global_auxvar_dn, &
5961) material_auxvar, &
5962) iphase, &
5963) saturation_function, &
5964) th_parameter, &
5965) ithrm_up, &
5966) option)
5967) else
5968)
5969) xx(1) = P_up
5970) xx(2) = T_up
5971) call THAuxVarComputeNoFreezing(xx, &
5972) th_auxvar_up, &
5973) global_auxvar_up, &
5974) material_auxvar, &
5975) iphase, &
5976) saturation_function, &
5977) th_parameter, &
5978) ithrm_up, &
5979) option)
5980)
5981) xx(1) = P_dn
5982) xx(2) = T_dn
5983) call THAuxVarComputeNoFreezing(xx, &
5984) th_auxvar_dn, &
5985) global_auxvar_dn, &
5986) material_auxvar, &
5987) iphase, &
5988) saturation_function, &
5989) th_parameter, &
5990) ithrm_dn, &
5991) option)
5992) endif
5993)
5994) ! Step-2: Find P_max/P_min for cubic polynomial approximation
5995) call EOSWaterdensity(global_auxvar_up%temp,option%reference_pressure,den,dum1,ierr)
5996)
5997) gravity = den * dist_gravity
5998)
5999) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
6000)
6001) v_darcy_allowable = (global_auxvar_up%pres(1) - option%reference_pressure)/ &
6002) option%flow_dt/(-option%gravity(3))/den
6003) q_allowable = v_darcy_allowable*area
6004)
6005) if (dphi>=0.D0) then
6006) ukvr = th_auxvar_up%kvr
6007) else
6008) ukvr = th_auxvar_dn%kvr
6009) endif
6010)
6011) P_allowable = global_auxvar_up%pres(1) + gravity - v_darcy_allowable/Dq/ukvr
6012)
6013) P_max = P_allowable + dP
6014) P_min = P_allowable
6015)
6016) ! Step-3: Find derivative at P_max
6017)
6018) if (option%use_th_freezing) then
6019)
6020) xx(1) = P_max
6021) xx(2) = T_up
6022) call THAuxVarComputeFreezing(xx, &
6023) th_auxvar_max, &
6024) global_auxvar_max, &
6025) material_auxvar, &
6026) iphase, &
6027) saturation_function, &
6028) th_parameter, &
6029) ithrm_up, &
6030) option)
6031) else
6032)
6033) xx(1) = P_max
6034) xx(2) = T_up
6035) call THAuxVarComputeNoFreezing(xx, &
6036) th_auxvar_max, &
6037) global_auxvar_max, &
6038) material_auxvar, &
6039) iphase, &
6040) saturation_function, &
6041) th_parameter, &
6042) ithrm_dn, &
6043) option)
6044) endif
6045)
6046) if (global_auxvar_up%sat(1) > sir_dn .or. global_auxvar_max%sat(1) > sir_dn) then
6047)
6048) upweight=1.D0
6049) if (global_auxvar_up%sat(1) < eps) then
6050) upweight=0.d0
6051) else if (global_auxvar_max%sat(1) < eps) then
6052) upweight=1.d0
6053) endif
6054)
6055) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_max%den(1)
6056)
6057) gravity = (upweight* global_auxvar_up%den(1) + &
6058) (1.D0-upweight)*global_auxvar_max%den(1)) &
6059) * FMWH2O * dist_gravity
6060) dgravity_dden_dn = (1.d0-upweight)*FMWH2O*dist_gravity
6061)
6062) if (option%ice_model /= DALL_AMICO) then
6063) dphi = global_auxvar_up%pres(1) - global_auxvar_max%pres(1) + gravity
6064) dphi_dp_dn = -1.d0 + dgravity_dden_dn*th_auxvar_max%dden_dp
6065) else
6066) dphi = th_auxvar_up%ice%pres_fh2o - th_auxvar_max%ice%pres_fh2o + gravity
6067) dphi_dp_dn = -th_auxvar_max%ice%dpres_fh2o_dp + dgravity_dden_dn*th_auxvar_max%dden_dp
6068) endif
6069)
6070) ! flow in ! boundary cell is <= pref
6071) if (dphi > 0.d0 .and. global_auxvar_up%pres(1) - option%reference_pressure < eps) then
6072) dphi = 0.d0
6073) dphi_dp_dn = 0.d0
6074) endif
6075)
6076) if (dphi>=0.D0) then
6077) ukvr = th_auxvar_up%kvr
6078) dukvr_dp_dn = 0.d0
6079) else
6080) ukvr = th_auxvar_max%kvr
6081) dukvr_dp_dn = th_auxvar_max%dkvr_dp
6082) endif
6083)
6084) call InterfaceApprox(th_auxvar_up%kvr, th_auxvar_max%kvr, &
6085) th_auxvar_up%dkvr_dp, th_auxvar_max%dkvr_dp, &
6086) dphi, &
6087) option%rel_perm_aveg, &
6088) ukvr, dum1, dukvr_dp_dn)
6089)
6090) if (ukvr*Dq>floweps) then
6091)
6092) v_darcy = Dq * ukvr * dphi
6093) q = v_darcy*area
6094)
6095) dq_dp_dn = Dq*(dukvr_dp_dn*dphi + ukvr*dphi_dp_dn)*area
6096)
6097) ! Step-3: Find coefficients of cubic polynomial curve
6098)
6099) ! Values of function at min/max
6100) coeff_for_cubic_approx(1) = 0.99d0*q_allowable
6101) coeff_for_cubic_approx(2) = q
6102)
6103) ! Values of function derivatives at min/max
6104) slope = min(-0.01d0*q_allowable/P_min, -1.d-8)
6105) slope = -0.01d0*q_allowable/P_min
6106) coeff_for_cubic_approx(3) = slope
6107) coeff_for_cubic_approx(4) = dq_dp_dn
6108)
6109) call CubicPolynomialSetup(P_min - option%reference_pressure, &
6110) P_max - option%reference_pressure, &
6111) coeff_for_cubic_approx)
6112)
6113) ! Step-4: Save values for linear approximation
6114) if (q_allowable == 0.d0) then
6115) range_for_linear_approx(1) = 0.d0
6116) else
6117) range_for_linear_approx(1) = P_min + 0.01d0*q_allowable/slope ! - option%reference_pressure
6118) endif
6119) range_for_linear_approx(2) = P_min
6120) range_for_linear_approx(3) = q_allowable
6121) range_for_linear_approx(4) = 0.99d0*q_allowable
6122)
6123) endif
6124)
6125) endif
6126)
6127) call GlobalAuxVarStrip(global_auxvar_up)
6128) call GlobalAuxVarStrip(global_auxvar_dn)
6129) call GlobalAuxVarStrip(global_auxvar_max)
6130)
6131) call THAuxVarDestroy(th_auxvar_up)
6132) call THAuxVarDestroy(th_auxvar_dn)
6133) call THAuxVarDestroy(th_auxvar_max)
6134)
6135) end subroutine ComputeCoeffsForApprox
6136)
6137) ! ************************************************************************** !
6138)
6139) subroutine THDestroy(patch)
6140) !
6141) ! Deallocates variables associated with Richard
6142) !
6143) ! Author: ???
6144) ! Date: 02/14/08
6145) !
6146)
6147) use Patch_module
6148)
6149) implicit none
6150)
6151) type(patch_type) :: patch
6152)
6153) ! need to free array in aux vars
6154) call THAuxDestroy(patch%aux%TH)
6155)
6156) end subroutine THDestroy
6157)
6158) end module TH_module