richards.F90 coverage: 84.62 %func 53.28 %block
1) module Richards_module
2)
3) use Richards_Aux_module
4) use Richards_Common_module
5) use Global_Aux_module
6) use Material_Aux_class
7) #ifdef BUFFER_MATRIX
8) use Matrix_Buffer_module
9) #endif
10)
11) use PFLOTRAN_Constants_module
12)
13) implicit none
14)
15) private
16)
17) #include "petsc/finclude/petscsys.h"
18)
19) #include "petsc/finclude/petscvec.h"
20) #include "petsc/finclude/petscvec.h90"
21) #include "petsc/finclude/petscmat.h"
22) #include "petsc/finclude/petscmat.h90"
23) #include "petsc/finclude/petscsnes.h"
24) #include "petsc/finclude/petscviewer.h"
25) #include "petsc/finclude/petsclog.h"
26)
27) ! Cutoff parameters
28) PetscReal, parameter :: eps = 1.D-8
29) PetscReal, parameter :: floweps = 1.D-24
30) PetscReal, parameter :: perturbation_tolerance = 1.d-6
31) PetscReal, parameter :: unit_z(3) = [0.d0,0.d0,1.d0]
32) PetscInt, parameter :: NO_CONN = 1
33) PetscInt, parameter :: VERT_CONN = 2
34) PetscInt, parameter :: HORZ_CONN = 3
35)
36) public RichardsResidual, &
37) RichardsJacobian, &
38) RichardsTimeCut,&
39) RichardsSetup, &
40) RichardsInitializeTimestep, &
41) RichardsUpdateAuxVars, &
42) RichardsMaxChange, &
43) RichardsUpdateSolution, &
44) RichardsComputeMassBalance, &
45) RichardsDestroy, &
46) RichardsUpdateSurfacePress
47)
48) contains
49)
50) ! ************************************************************************** !
51)
52) subroutine RichardsTimeCut(realization)
53) !
54) ! Resets arrays for time step cut
55) !
56) ! Author: Glenn Hammond
57) ! Date: 12/13/07
58) !
59)
60) use Realization_Subsurface_class
61) use Option_module
62) use Field_module
63)
64) implicit none
65)
66) type(realization_subsurface_type) :: realization
67)
68) call RichardsInitializeTimestep(realization)
69)
70) end subroutine RichardsTimeCut
71)
72) ! ************************************************************************** !
73)
74) subroutine RichardsSetup(realization)
75) !
76) ! Author: Glenn Hammond
77) ! Date: 02/22/08
78) !
79)
80) use Realization_Subsurface_class
81) use Patch_module
82) use Output_Aux_module
83)
84) type(realization_subsurface_type) :: realization
85)
86) type(output_variable_list_type), pointer :: list
87)
88) call RichardsSetupPatch(realization)
89)
90) list => realization%output_option%output_snap_variable_list
91) call RichardsSetPlotVariables(list)
92) list => realization%output_option%output_obs_variable_list
93) call RichardsSetPlotVariables(list)
94)
95) end subroutine RichardsSetup
96)
97) ! ************************************************************************** !
98)
99) subroutine RichardsSetupPatch(realization)
100) !
101) ! Creates arrays for auxiliary variables
102) !
103) ! Author: Glenn Hammond
104) ! Date: 12/13/07
105) !
106)
107) use Realization_Subsurface_class
108) use Patch_module
109) use Option_module
110) use Coupler_module
111) use Connection_module
112) use Grid_module
113)
114) implicit none
115)
116) type(realization_subsurface_type) :: realization
117)
118) type(option_type), pointer :: option
119) type(patch_type),pointer :: patch
120) type(grid_type), pointer :: grid
121) type(coupler_type), pointer :: boundary_condition
122) type(coupler_type), pointer :: source_sink
123)
124) PetscInt :: local_id, ghosted_id, iconn, sum_connection
125) PetscInt :: i, ierr
126) PetscBool :: error_found
127) PetscInt :: flag(10)
128) type(material_parameter_type), pointer :: material_parameter
129) class(material_auxvar_type), pointer :: material_auxvars(:)
130) type(richards_auxvar_type), pointer :: rich_auxvars(:)
131) type(richards_auxvar_type), pointer :: rich_auxvars_bc(:)
132) type(richards_auxvar_type), pointer :: rich_auxvars_ss(:)
133)
134) option => realization%option
135) patch => realization%patch
136) grid => patch%grid
137)
138) patch%aux%Richards => RichardsAuxCreate()
139)
140) ! ensure that material properties specific to this module are properly
141) ! initialized
142) material_parameter => patch%aux%Material%material_parameter
143) error_found = PETSC_FALSE
144) if (minval(material_parameter%soil_residual_saturation(:,:)) < 0.d0) then
145) option%io_buffer = 'Non-initialized soil residual saturation.'
146) call printMsg(option)
147) error_found = PETSC_TRUE
148) endif
149) material_auxvars => patch%aux%Material%auxvars
150) flag = 0
151) !TODO(geh): change to looping over ghosted ids once the legacy code is
152) ! history and the communicator can be passed down.
153) do local_id = 1, grid%nlmax
154) ghosted_id = grid%nL2G(local_id)
155) if (patch%imat(ghosted_id) <= 0) cycle
156) if (material_auxvars(ghosted_id)%volume < 0.d0 .and. flag(1) == 0) then
157) flag(1) = 1
158) option%io_buffer = 'Non-initialized cell volume.'
159) call printMsg(option)
160) endif
161) if (material_auxvars(ghosted_id)%porosity < 0.d0 .and. flag(2) == 0) then
162) flag(2) = 1
163) option%io_buffer = 'Non-initialized porosity.'
164) call printMsg(option)
165) endif
166) if (minval(material_auxvars(ghosted_id)%permeability) < 0.d0 .and. &
167) flag(5) == 0) then
168) option%io_buffer = 'Non-initialized permeability.'
169) call printMsg(option)
170) flag(5) = 1
171) endif
172) enddo
173)
174) if (error_found .or. maxval(flag) > 0) then
175) option%io_buffer = 'Material property errors found in RichardsSetup.'
176) call printErrMsg(option)
177) endif
178)
179) ! allocate auxvar data structures for all grid cells
180) allocate(rich_auxvars(grid%ngmax))
181) do ghosted_id = 1, grid%ngmax
182) call RichardsAuxVarInit(rich_auxvars(ghosted_id),option)
183) enddo
184) patch%aux%Richards%auxvars => rich_auxvars
185) patch%aux%Richards%num_aux = grid%ngmax
186)
187) ! count the number of boundary connections and allocate
188) ! auxvar data structures for them
189) sum_connection = CouplerGetNumConnectionsInList(patch%boundary_condition_list)
190) if (sum_connection > 0) then
191) allocate(rich_auxvars_bc(sum_connection))
192) do iconn = 1, sum_connection
193) call RichardsAuxVarInit(rich_auxvars_bc(iconn),option)
194) enddo
195) patch%aux%Richards%auxvars_bc => rich_auxvars_bc
196) endif
197) patch%aux%Richards%num_aux_bc = sum_connection
198)
199) ! count the number of source/sink connections and allocate
200) ! auxvar data structures for them
201) sum_connection = CouplerGetNumConnectionsInList(patch%source_sink_list)
202) if (sum_connection > 0) then
203) allocate(rich_auxvars_ss(sum_connection))
204) do iconn = 1, sum_connection
205) call RichardsAuxVarInit(rich_auxvars_ss(iconn),option)
206) enddo
207) patch%aux%Richards%auxvars_ss => rich_auxvars_ss
208) endif
209) patch%aux%Richards%num_aux_ss = sum_connection
210)
211) end subroutine RichardsSetupPatch
212)
213) ! ************************************************************************** !
214)
215) subroutine RichardsComputeMassBalance(realization,mass_balance)
216) !
217) ! Author: Glenn Hammond
218) ! Date: 02/22/08
219) !
220)
221) use Realization_Subsurface_class
222)
223) type(realization_subsurface_type) :: realization
224) PetscReal :: mass_balance(realization%option%nphase)
225)
226) mass_balance = 0.d0
227)
228) call RichardsComputeMassBalancePatch(realization,mass_balance)
229)
230) end subroutine RichardsComputeMassBalance
231)
232) ! ************************************************************************** !
233)
234) subroutine RichardsComputeMassBalancePatch(realization,mass_balance)
235) !
236) ! Initializes mass balance
237) !
238) ! Author: Glenn Hammond
239) ! Date: 12/19/08
240) !
241)
242) use Realization_Subsurface_class
243) use Option_module
244) use Patch_module
245) use Field_module
246) use Grid_module
247)
248) implicit none
249)
250) type(realization_subsurface_type) :: realization
251) PetscReal :: mass_balance(realization%option%nphase)
252)
253) type(option_type), pointer :: option
254) type(patch_type), pointer :: patch
255) type(field_type), pointer :: field
256) type(grid_type), pointer :: grid
257) type(global_auxvar_type), pointer :: global_auxvars(:)
258) class(material_auxvar_type), pointer :: material_auxvars(:)
259)
260) PetscErrorCode :: ierr
261) PetscInt :: local_id
262) PetscInt :: ghosted_id
263)
264) option => realization%option
265) patch => realization%patch
266) grid => patch%grid
267) field => realization%field
268)
269) global_auxvars => patch%aux%Global%auxvars
270) material_auxvars => patch%aux%Material%auxvars
271)
272) do local_id = 1, grid%nlmax
273) ghosted_id = grid%nL2G(local_id)
274) !geh - Ignore inactive cells with inactive materials
275) if (patch%imat(ghosted_id) <= 0) cycle
276) ! mass = volume*saturation*density
277) mass_balance = mass_balance + &
278) global_auxvars(ghosted_id)%den_kg* &
279) global_auxvars(ghosted_id)%sat* &
280) material_auxvars(ghosted_id)%porosity* &
281) material_auxvars(ghosted_id)%volume
282) enddo
283)
284) end subroutine RichardsComputeMassBalancePatch
285)
286) ! ************************************************************************** !
287)
288) subroutine RichardsZeroMassBalDeltaPatch(realization)
289) !
290) ! Zeros mass balance delta array
291) !
292) ! Author: Glenn Hammond
293) ! Date: 12/19/08
294) !
295)
296) use Realization_Subsurface_class
297) use Option_module
298) use Patch_module
299) use Grid_module
300)
301) implicit none
302)
303) type(realization_subsurface_type) :: realization
304)
305) type(option_type), pointer :: option
306) type(patch_type), pointer :: patch
307) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
308) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
309)
310) PetscInt :: iconn
311)
312) option => realization%option
313) patch => realization%patch
314)
315) global_auxvars_bc => patch%aux%Global%auxvars_bc
316) global_auxvars_ss => patch%aux%Global%auxvars_ss
317)
318) #ifdef COMPUTE_INTERNAL_MASS_FLUX
319) do iconn = 1, patch%aux%Richards%num_aux
320) patch%aux%Global%auxvars(iconn)%mass_balance_delta = 0.d0
321) enddo
322) #endif
323)
324) ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
325) ! placed around the internal do loop - geh
326) if (patch%aux%Richards%num_aux_bc > 0) then
327) do iconn = 1, patch%aux%Richards%num_aux_bc
328) global_auxvars_bc(iconn)%mass_balance_delta = 0.d0
329) enddo
330) endif
331) if (patch%aux%Richards%num_aux_ss > 0) then
332) do iconn = 1, patch%aux%Richards%num_aux_ss
333) global_auxvars_ss(iconn)%mass_balance_delta = 0.d0
334) enddo
335) endif
336)
337) end subroutine RichardsZeroMassBalDeltaPatch
338)
339) ! ************************************************************************** !
340)
341) subroutine RichardsUpdateMassBalancePatch(realization)
342) !
343) ! Updates mass balance
344) !
345) ! Author: Glenn Hammond
346) ! Date: 12/19/08
347) !
348)
349) use Realization_Subsurface_class
350) use Option_module
351) use Patch_module
352) use Grid_module
353)
354) implicit none
355)
356) type(realization_subsurface_type) :: realization
357)
358) type(option_type), pointer :: option
359) type(patch_type), pointer :: patch
360) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
361) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
362)
363) PetscInt :: iconn
364)
365) option => realization%option
366) patch => realization%patch
367)
368) global_auxvars_bc => patch%aux%Global%auxvars_bc
369) global_auxvars_ss => patch%aux%Global%auxvars_ss
370)
371) #ifdef COMPUTE_INTERNAL_MASS_FLUX
372) do iconn = 1, patch%aux%Richards%num_aux
373) patch%aux%Global%auxvars(iconn)%mass_balance = &
374) patch%aux%Global%auxvars(iconn)%mass_balance + &
375) patch%aux%Global%auxvars(iconn)%mass_balance_delta*FMWH2O* &
376) option%flow_dt
377) enddo
378) #endif
379)
380) ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
381) ! placed around the internal do loop - geh
382) if (patch%aux%Richards%num_aux_bc > 0) then
383) do iconn = 1, patch%aux%Richards%num_aux_bc
384) global_auxvars_bc(iconn)%mass_balance = &
385) global_auxvars_bc(iconn)%mass_balance + &
386) global_auxvars_bc(iconn)%mass_balance_delta*FMWH2O*option%flow_dt
387) enddo
388) endif
389)
390) if (patch%aux%Richards%num_aux_ss > 0) then
391) do iconn = 1, patch%aux%Richards%num_aux_ss
392) global_auxvars_ss(iconn)%mass_balance = &
393) global_auxvars_ss(iconn)%mass_balance + &
394) global_auxvars_ss(iconn)%mass_balance_delta*FMWH2O*option%flow_dt
395) enddo
396) endif
397)
398) end subroutine RichardsUpdateMassBalancePatch
399)
400) ! ************************************************************************** !
401)
402) subroutine RichardsUpdatePermPatch(realization)
403) !
404) ! Updates the permeability based on pressure
405) !
406) ! Author: Satish Karra, LANL
407) ! Date: 01/09/12
408) !
409)
410) use Grid_module
411) use Realization_Subsurface_class
412) use Option_module
413) use Discretization_module
414) use Patch_module
415) use Field_module
416) use Material_module
417) use Material_Aux_class
418) use Variables_module
419)
420) implicit none
421)
422) type(realization_subsurface_type) :: realization
423)
424) type(option_type), pointer :: option
425) type(patch_type), pointer :: patch
426) type(field_type), pointer :: field
427) type(grid_type), pointer :: grid
428) type(material_property_ptr_type), pointer :: material_property_array(:)
429) type(discretization_type), pointer :: discretization
430) class(material_auxvar_type), pointer :: material_auxvars(:)
431)
432) PetscInt :: local_id, ghosted_id
433) PetscReal :: scale
434) PetscReal :: p_min, p_max, permfactor_max
435) PetscReal, pointer :: xx_loc_p(:)
436) PetscReal, pointer :: perm0_xx_p(:), perm0_yy_p(:), perm0_zz_p(:)
437) PetscReal, pointer :: perm_ptr(:)
438) PetscErrorCode :: ierr
439)
440) option => realization%option
441) discretization => realization%discretization
442) patch => realization%patch
443) field => realization%field
444) grid => patch%grid
445) material_property_array => patch%material_property_array
446) material_auxvars => patch%aux%Material%auxvars
447)
448) if (.not.associated(patch%imat)) then
449) option%io_buffer = 'Materials IDs not present in run. Material ' // &
450) ' properties cannot be updated without material ids'
451) call printErrMsg(option)
452) endif
453)
454) call VecGetArrayF90(field%perm0_xx,perm0_xx_p,ierr);CHKERRQ(ierr)
455) call VecGetArrayF90(field%perm0_zz,perm0_zz_p,ierr);CHKERRQ(ierr)
456) call VecGetArrayF90(field%perm0_yy,perm0_yy_p,ierr);CHKERRQ(ierr)
457) call VecGetArrayReadF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
458)
459) do local_id = 1, grid%nlmax
460) ghosted_id = grid%nL2G(local_id)
461) if (patch%imat(ghosted_id) <= 0) cycle
462) p_min = material_property_array(patch%imat(ghosted_id))%ptr%min_pressure
463) p_max = material_property_array(patch%imat(ghosted_id))%ptr%max_pressure
464) permfactor_max = material_property_array(patch%imat(ghosted_id))%ptr% &
465) max_permfactor
466) if (xx_loc_p(local_id) < p_min) then
467) scale = 1
468) else
469) if (xx_loc_p(local_id) < p_max) then
470) scale = (xx_loc_p(local_id) - p_min)/ &
471) (p_max - p_min)*(permfactor_max - 1.d0) + 1.d0
472) else
473) scale = permfactor_max
474) endif
475) endif
476) !geh: this is a kludge for gfortran. the code reports errors when
477) ! material_auxvars(ghosted_id)%permeability is used.
478) ! Not an issue with Intel
479) perm_ptr => material_auxvars(ghosted_id)%permeability
480) perm_ptr(perm_xx_index) = perm0_xx_p(local_id)*scale
481) perm_ptr(perm_yy_index) = perm0_yy_p(local_id)*scale
482) perm_ptr(perm_zz_index) = perm0_zz_p(local_id)*scale
483) ! material_auxvars(ghosted_id)%permeability(perm_xx_index) = &
484) ! perm0_xx_p(local_id)*scale
485) ! material_auxvars(ghosted_id)%permeability(perm_yy_index) = &
486) ! perm0_yy_p(local_id)*scale
487) ! material_auxvars(ghosted_id)%permeability(perm_zz_index) = &
488) ! perm0_zz_p(local_id)*scale
489) enddo
490)
491) call VecRestoreArrayF90(field%perm0_xx,perm0_xx_p,ierr);CHKERRQ(ierr)
492) call VecRestoreArrayF90(field%perm0_zz,perm0_zz_p,ierr);CHKERRQ(ierr)
493) call VecRestoreArrayF90(field%perm0_yy,perm0_yy_p,ierr);CHKERRQ(ierr)
494) call VecRestoreArrayReadF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
495)
496) call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
497) PERMEABILITY_X,ZERO_INTEGER)
498) call DiscretizationLocalToLocal(discretization,field%work_loc, &
499) field%work_loc,ONEDOF)
500) call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
501) PERMEABILITY_X,ZERO_INTEGER)
502) call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
503) PERMEABILITY_Y,ZERO_INTEGER)
504) call DiscretizationLocalToLocal(discretization,field%work_loc, &
505) field%work_loc,ONEDOF)
506) call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
507) PERMEABILITY_Y,ZERO_INTEGER)
508) call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
509) PERMEABILITY_Z,ZERO_INTEGER)
510) call DiscretizationLocalToLocal(discretization,field%work_loc, &
511) field%work_loc,ONEDOF)
512) call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
513) PERMEABILITY_Z,ZERO_INTEGER)
514)
515)
516) end subroutine RichardsUpdatePermPatch
517)
518) ! ************************************************************************** !
519)
520) subroutine RichardsUpdateAuxVars(realization)
521) !
522) ! Updates the auxiliary variables associated with
523) ! the Richards problem
524) !
525) ! Author: Glenn Hammond
526) ! Date: 12/10/07
527) !
528)
529) use Realization_Subsurface_class
530) type(realization_subsurface_type) :: realization
531)
532) call RichardsUpdateAuxVarsPatch(realization)
533)
534) end subroutine RichardsUpdateAuxVars
535)
536) ! ************************************************************************** !
537)
538) subroutine RichardsUpdateAuxVarsPatch(realization)
539) !
540) ! Updates the auxiliary variables associated with
541) ! the Richards problem
542) !
543) ! Author: Glenn Hammond
544) ! Date: 12/10/07
545) !
546)
547) use Realization_Subsurface_class
548) use Patch_module
549) use Option_module
550) use Field_module
551) use Grid_module
552) use Coupler_module
553) use Connection_module
554) use Material_module
555) use Logging_module
556)
557) implicit none
558)
559) type(realization_subsurface_type) :: realization
560)
561) type(option_type), pointer :: option
562) type(patch_type), pointer :: patch
563) type(grid_type), pointer :: grid
564) type(field_type), pointer :: field
565) type(coupler_type), pointer :: boundary_condition
566) type(coupler_type), pointer :: source_sink
567) type(connection_set_type), pointer :: cur_connection_set
568) type(richards_auxvar_type), pointer :: rich_auxvars(:)
569) type(richards_auxvar_type), pointer :: rich_auxvars_bc(:)
570) type(richards_auxvar_type), pointer :: rich_auxvars_ss(:)
571) type(global_auxvar_type), pointer :: global_auxvars(:)
572) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
573) type(global_auxvar_type), pointer :: global_auxvars_ss(:)
574) class(material_auxvar_type), pointer :: material_auxvars(:)
575) PetscInt :: ghosted_id, local_id, sum_connection, idof, iconn
576) PetscInt :: iphasebc, iphase, i
577) PetscReal, pointer :: xx_loc_p(:)
578) PetscReal :: xxbc(realization%option%nflowdof)
579) PetscErrorCode :: ierr
580) Vec :: phi
581)
582) call PetscLogEventBegin(logging%event_r_auxvars,ierr);CHKERRQ(ierr)
583)
584) option => realization%option
585) patch => realization%patch
586) grid => patch%grid
587) field => realization%field
588)
589) rich_auxvars => patch%aux%Richards%auxvars
590) rich_auxvars_bc => patch%aux%Richards%auxvars_bc
591) rich_auxvars_ss => patch%aux%Richards%auxvars_ss
592) global_auxvars => patch%aux%Global%auxvars
593) global_auxvars_bc => patch%aux%Global%auxvars_bc
594) global_auxvars_ss => patch%aux%Global%auxvars_ss
595) material_auxvars => patch%aux%Material%auxvars
596)
597) call VecGetArrayReadF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
598)
599) do ghosted_id = 1, grid%ngmax
600) if (grid%nG2L(ghosted_id) < 0) cycle ! bypass ghosted corner cells
601)
602) !geh - Ignore inactive cells with inactive materials
603) if (patch%imat(ghosted_id) <= 0) cycle
604)
605) call RichardsAuxVarCompute(xx_loc_p(ghosted_id:ghosted_id), &
606) rich_auxvars(ghosted_id), &
607) global_auxvars(ghosted_id), &
608) material_auxvars(ghosted_id), &
609) patch%characteristic_curves_array( &
610) patch%sat_func_id(ghosted_id))%ptr, &
611) option)
612) enddo
613)
614) call PetscLogEventEnd(logging%event_r_auxvars,ierr);CHKERRQ(ierr)
615)
616) call PetscLogEventBegin(logging%event_r_auxvars_bc,ierr);CHKERRQ(ierr)
617)
618) ! boundary conditions
619) boundary_condition => patch%boundary_condition_list%first
620) sum_connection = 0
621) do
622) if (.not.associated(boundary_condition)) exit
623) cur_connection_set => boundary_condition%connection_set
624) do iconn = 1, cur_connection_set%num_connections
625) sum_connection = sum_connection + 1
626) local_id = cur_connection_set%id_dn(iconn)
627) ghosted_id = grid%nL2G(local_id)
628) if (patch%imat(ghosted_id) <= 0) cycle
629)
630) select case(boundary_condition%flow_condition%itype(RICHARDS_PRESSURE_DOF))
631) case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC,CONDUCTANCE_BC,HET_SURF_SEEPAGE_BC, &
632) HET_DIRICHLET)
633) xxbc(1) = boundary_condition%flow_aux_real_var(RICHARDS_PRESSURE_DOF,iconn)
634) case(NEUMANN_BC,ZERO_GRADIENT_BC,UNIT_GRADIENT_BC)
635) xxbc(1) = xx_loc_p(ghosted_id)
636) end select
637)
638)
639) call RichardsAuxVarCompute(xxbc(1),rich_auxvars_bc(sum_connection), &
640) global_auxvars_bc(sum_connection), &
641) material_auxvars(ghosted_id), &
642) patch%characteristic_curves_array( &
643) patch%sat_func_id(ghosted_id))%ptr, &
644) option)
645) enddo
646) boundary_condition => boundary_condition%next
647) enddo
648)
649) ! source/sinks
650) source_sink => patch%source_sink_list%first
651) sum_connection = 0
652) do
653) if (.not.associated(source_sink)) exit
654) cur_connection_set => source_sink%connection_set
655) do iconn = 1, cur_connection_set%num_connections
656) sum_connection = sum_connection + 1
657) local_id = cur_connection_set%id_dn(iconn)
658) ghosted_id = grid%nL2G(local_id)
659) if (patch%imat(ghosted_id) <= 0) cycle
660)
661) call RichardsAuxVarCopy(rich_auxvars(ghosted_id), &
662) rich_auxvars_ss(sum_connection),option)
663) call GlobalAuxVarCopy(global_auxvars(ghosted_id), &
664) global_auxvars_ss(sum_connection),option)
665)
666) enddo
667) source_sink => source_sink%next
668) enddo
669)
670) call VecRestoreArrayReadF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
671)
672) patch%aux%Richards%auxvars_up_to_date = PETSC_TRUE
673)
674) call PetscLogEventEnd(logging%event_r_auxvars_bc,ierr);CHKERRQ(ierr)
675)
676) end subroutine RichardsUpdateAuxVarsPatch
677)
678) ! ************************************************************************** !
679)
680) subroutine RichardsInitializeTimestep(realization)
681) !
682) ! Update data in module prior to time step
683) !
684) ! Author: Glenn Hammond
685) ! Date: 02/20/08
686) !
687)
688) use Realization_Subsurface_class
689) use Field_module
690)
691) implicit none
692)
693)
694)
695) type(realization_subsurface_type) :: realization
696)
697) PetscViewer :: viewer
698) PetscErrorCode :: ierr
699)
700) type(field_type), pointer :: field
701)
702)
703) field => realization%field
704)
705)
706) call RichardsUpdateFixedAccum(realization)
707)
708) if (realization%option%flow%quasi_3d) call RichardsComputeLateralMassFlux(realization)
709)
710) ! call PetscViewerASCIIOpen(realization%option%mycomm,'flow_yy.out', &
711) ! viewer,ierr)
712) ! call VecView(field%flow_xx_faces, viewer, ierr)
713) ! call VecView(field%flow_yy, viewer, ierr)
714) !
715) ! call PetscViewerDestroy(viewer,ierr)
716) ! write(*,*) "Flow_yy"
717) ! read(*,*)
718)
719) end subroutine RichardsInitializeTimestep
720)
721) ! ************************************************************************** !
722)
723) subroutine RichardsUpdateSolution(realization)
724) !
725) ! Updates data in module after a successful time
726) ! step
727) !
728) ! Author: Glenn Hammond
729) ! Date: 02/13/08
730) !
731)
732) use Realization_Subsurface_class
733) use Field_module
734)
735) implicit none
736)
737) type(realization_subsurface_type) :: realization
738)
739) call RichardsUpdateSolutionPatch(realization)
740)
741) end subroutine RichardsUpdateSolution
742)
743) ! ************************************************************************** !
744)
745) subroutine RichardsUpdateSolutionPatch(realization)
746) !
747) ! Updates data in module after a successful time
748) ! step
749) !
750) ! Author: Glenn Hammond
751) ! Date: 02/13/08
752) !
753)
754) use Realization_Subsurface_class
755)
756) implicit none
757)
758) type(realization_subsurface_type) :: realization
759)
760) if (realization%option%compute_mass_balance_new) then
761) call RichardsUpdateMassBalancePatch(realization)
762) endif
763)
764) if (realization%option%update_flow_perm) then
765) !TODO(geh): this is in the wrong place
766) call RichardsUpdatePermPatch(realization)
767) endif
768)
769) end subroutine RichardsUpdateSolutionPatch
770)
771) ! ************************************************************************** !
772)
773) subroutine RichardsUpdateFixedAccum(realization)
774) !
775) ! Updates the fixed portion of the
776) ! accumulation term
777) !
778) ! Author: Glenn Hammond
779) ! Date: 12/10/07
780) !
781)
782) use Realization_Subsurface_class
783)
784) type(realization_subsurface_type) :: realization
785)
786) call RichardsUpdateFixedAccumPatch(realization)
787)
788) end subroutine RichardsUpdateFixedAccum
789)
790) ! ************************************************************************** !
791)
792) subroutine RichardsUpdateFixedAccumPatch(realization)
793) !
794) ! Updates the fixed portion of the
795) ! accumulation term
796) !
797) ! Author: Glenn Hammond
798) ! Date: 12/10/07
799) !
800)
801) use Realization_Subsurface_class
802) use Patch_module
803) use Option_module
804) use Field_module
805) use Grid_module
806) use Connection_module
807)
808) implicit none
809)
810) type(realization_subsurface_type) :: realization
811)
812) type(option_type), pointer :: option
813) type(patch_type), pointer :: patch
814) type(grid_type), pointer :: grid
815) type(field_type), pointer :: field
816) type(richards_auxvar_type), pointer :: rich_auxvars(:)
817) type(global_auxvar_type), pointer :: global_auxvars(:)
818) class(material_auxvar_type), pointer :: material_auxvars(:)
819)
820) PetscInt :: ghosted_id, local_id, numfaces, jface, ghost_face_id, j
821) PetscReal, pointer :: xx_p(:), iphase_loc_p(:)
822) PetscReal, pointer :: accum_p(:)
823) PetscErrorCode :: ierr
824)
825) option => realization%option
826) field => realization%field
827) patch => realization%patch
828) grid => patch%grid
829)
830) rich_auxvars => patch%aux%Richards%auxvars
831) global_auxvars => patch%aux%Global%auxvars
832) material_auxvars => patch%aux%Material%auxvars
833)
834) call VecGetArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
835)
836) call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
837)
838) ! numfaces = 6 ! hex only
839) ! allocate(sq_faces(numfaces))
840) ! allocate(faces_pr(numfaces))
841)
842) do local_id = 1, grid%nlmax
843)
844) ghosted_id = grid%nL2G(local_id)
845)
846) !geh - Ignore inactive cells with inactive materials
847) if (patch%imat(ghosted_id) <= 0) cycle
848) call RichardsAuxVarCompute(xx_p(local_id:local_id), &
849) rich_auxvars(ghosted_id),global_auxvars(ghosted_id), &
850) material_auxvars(ghosted_id), &
851) patch%characteristic_curves_array( &
852) patch%sat_func_id(ghosted_id))%ptr, &
853) option)
854) call RichardsAccumulation(rich_auxvars(ghosted_id),global_auxvars(ghosted_id), &
855) material_auxvars(ghosted_id), &
856) option,accum_p(local_id:local_id))
857) enddo
858)
859) call VecRestoreArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
860)
861)
862) call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
863)
864) end subroutine RichardsUpdateFixedAccumPatch
865)
866) ! ************************************************************************** !
867)
868) subroutine RichardsNumericalJacTest(xx,realization)
869) !
870) ! Computes the a test numerical jacobian
871) !
872) ! Author: Glenn Hammond
873) ! Date: 12/13/07
874) !
875)
876) use Realization_Subsurface_class
877) use Patch_module
878) use Option_module
879) use Grid_module
880) use Field_module
881)
882) implicit none
883)
884) Vec :: xx
885) type(realization_subsurface_type) :: realization
886)
887) Vec :: xx_pert
888) Vec :: res
889) Vec :: res_pert
890) Mat :: A
891) PetscViewer :: viewer
892) PetscErrorCode :: ierr
893)
894) PetscReal :: derivative, perturbation
895)
896) PetscReal, pointer :: vec_p(:), vec2_p(:)
897)
898) type(grid_type), pointer :: grid
899) type(option_type), pointer :: option
900) type(patch_type), pointer :: patch
901) type(field_type), pointer :: field
902)
903) PetscInt :: idof, idof2, icell
904)
905) patch => realization%patch
906) grid => patch%grid
907) option => realization%option
908) field => realization%field
909)
910) call VecDuplicate(xx,xx_pert,ierr);CHKERRQ(ierr)
911) call VecDuplicate(xx,res,ierr);CHKERRQ(ierr)
912) call VecDuplicate(xx,res_pert,ierr);CHKERRQ(ierr)
913)
914) call MatCreate(option%mycomm,A,ierr);CHKERRQ(ierr)
915) call MatSetSizes(A,PETSC_DECIDE,PETSC_DECIDE,grid%nlmax*option%nflowdof,grid%nlmax*option%nflowdof, &
916) ierr);CHKERRQ(ierr)
917) call MatSetType(A,MATAIJ,ierr);CHKERRQ(ierr)
918) call MatSetFromOptions(A,ierr);CHKERRQ(ierr)
919)
920) call RichardsResidual(PETSC_NULL_OBJECT,xx,res,realization,ierr)
921) call VecGetArrayF90(res,vec2_p,ierr);CHKERRQ(ierr)
922) do icell = 1,grid%nlmax
923) if (patch%imat(grid%nL2G(icell)) <= 0) cycle
924) idof = icell
925) ! do idof = (icell-1)*option%nflowdof+1,icell*option%nflowdof
926) call veccopy(xx,xx_pert,ierr);CHKERRQ(ierr)
927) call vecgetarrayf90(xx_pert,vec_p,ierr);CHKERRQ(ierr)
928) perturbation = vec_p(idof)*perturbation_tolerance
929) vec_p(idof) = vec_p(idof)+perturbation
930) call vecrestorearrayf90(xx_pert,vec_p,ierr);CHKERRQ(ierr)
931) call RichardsResidual(PETSC_NULL_OBJECT,xx_pert,res_pert,realization,ierr)
932) call vecgetarrayf90(res_pert,vec_p,ierr);CHKERRQ(ierr)
933) do idof2 = 1, grid%nlmax*option%nflowdof
934) derivative = (vec_p(idof2)-vec2_p(idof2))/perturbation
935) if (dabs(derivative) > 1.d-30) then
936) call matsetvalue(a,idof2-1,idof-1,derivative,insert_values, &
937) ierr);CHKERRQ(ierr)
938) endif
939) enddo
940) call VecRestoreArrayF90(res_pert,vec_p,ierr);CHKERRQ(ierr)
941) ! enddo
942) enddo
943) call VecRestoreArrayF90(res,vec2_p,ierr);CHKERRQ(ierr)
944)
945) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
946) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
947) call PetscViewerASCIIOpen(option%mycomm,'numerical_jacobian.out',viewer, &
948) ierr);CHKERRQ(ierr)
949) call MatView(A,viewer,ierr);CHKERRQ(ierr)
950) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
951)
952) call MatDestroy(A,ierr);CHKERRQ(ierr)
953)
954) call VecDestroy(xx_pert,ierr);CHKERRQ(ierr)
955) call VecDestroy(res,ierr);CHKERRQ(ierr)
956) call VecDestroy(res_pert,ierr);CHKERRQ(ierr)
957)
958) end subroutine RichardsNumericalJacTest
959)
960) ! ************************************************************************** !
961)
962) subroutine RichardsResidual(snes,xx,r,realization,ierr)
963) !
964) ! Computes the residual equation
965) !
966) ! Author: Glenn Hammond
967) ! Date: 12/10/07
968) !
969)
970) use Realization_Subsurface_class
971) use Field_module
972) use Discretization_module
973) use Option_module
974) use Logging_module
975) use Material_module
976) use Material_Aux_class
977) use Variables_module
978) use Debug_module
979)
980) implicit none
981)
982) SNES :: snes
983) Vec :: xx
984) Vec :: r
985) type(realization_subsurface_type) :: realization
986) PetscViewer :: viewer
987) PetscInt :: skip_conn_type
988) PetscErrorCode :: ierr
989)
990) type(discretization_type), pointer :: discretization
991) type(field_type), pointer :: field
992) type(option_type), pointer :: option
993) character(len=MAXSTRINGLENGTH) :: string
994)
995) call PetscLogEventBegin(logging%event_r_residual,ierr);CHKERRQ(ierr)
996)
997) field => realization%field
998) option => realization%option
999)
1000) call RichardsResidualPreliminaries(xx,r,realization,ierr)
1001)
1002) skip_conn_type = NO_CONN
1003) if (option%flow%only_vertical_flow) skip_conn_type = HORZ_CONN
1004)
1005) call RichardsResidualInternalConn(r,realization,skip_conn_type,ierr)
1006) call RichardsResidualBoundaryConn(r,realization,ierr)
1007) call RichardsResidualAccumulation(r,realization,ierr)
1008) call RichardsResidualSourceSink(r,realization,ierr)
1009)
1010) if (realization%debug%vecview_residual) then
1011) string = 'Rresidual'
1012) call DebugCreateViewer(realization%debug,string,option,viewer)
1013) call VecView(r,viewer,ierr);CHKERRQ(ierr)
1014) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1015) endif
1016) if (realization%debug%vecview_solution) then
1017) string = 'Rxx'
1018) call DebugCreateViewer(realization%debug,string,option,viewer)
1019) call VecView(xx,viewer,ierr);CHKERRQ(ierr)
1020) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1021) endif
1022)
1023) call PetscLogEventEnd(logging%event_r_residual,ierr);CHKERRQ(ierr)
1024)
1025) end subroutine RichardsResidual
1026)
1027) ! ************************************************************************** !
1028)
1029) subroutine RichardsResidualPreliminaries(xx,r,realization,ierr)
1030) !
1031) ! Perform preliminary work prior to residual computation
1032) !
1033) ! Author: Gautam Bisht, LBNL
1034) ! Date: 03/09/2016
1035) !
1036)
1037) use Connection_module
1038) use Realization_Subsurface_class
1039) use Patch_module
1040) use Option_module
1041) use Coupler_module
1042) use Field_module
1043) use Debug_module
1044)
1045) implicit none
1046)
1047) Vec, intent(inout) :: xx
1048) Vec, intent(out) :: r
1049) type(realization_subsurface_type) :: realization
1050)
1051) type(patch_type), pointer :: patch
1052) type(option_type), pointer :: option
1053) PetscErrorCode :: ierr
1054)
1055) patch => realization%patch
1056) option => realization%option
1057)
1058) call VecZeroEntries(r, ierr); CHKERRQ(ierr)
1059)
1060) call RichardsUpdateLocalVecs(xx,realization,ierr)
1061)
1062) call RichardsUpdateAuxVarsPatch(realization)
1063)
1064) patch%aux%Richards%auxvars_up_to_date = PETSC_FALSE ! override flags since they will soon be out of date
1065) patch%aux%Richards%auxvars_cell_pressures_up_to_date = PETSC_FALSE ! override flags since they will soon be out of date
1066)
1067) if (option%compute_mass_balance_new) call RichardsZeroMassBalDeltaPatch(realization)
1068)
1069) if (option%surf_flow_on) call RichardsComputeCoeffsForSurfFlux(realization)
1070)
1071) end subroutine RichardsResidualPreliminaries
1072)
1073) ! ************************************************************************** !
1074)
1075) subroutine RichardsUpdateLocalVecs(xx,realization,ierr)
1076) !
1077) ! Updates local vectors needed for residual computation
1078) !
1079) ! Author: Gautam Bisht, LBNL
1080) ! Date: 03/09/2016
1081) !
1082)
1083) use Realization_Subsurface_class
1084) use Field_module
1085) use Discretization_module
1086) use Option_module
1087) use Logging_module
1088) use Material_module
1089) use Material_Aux_class
1090) use Variables_module
1091) use Debug_module
1092)
1093) implicit none
1094)
1095) Vec :: xx
1096) type(realization_subsurface_type) :: realization
1097) PetscErrorCode :: ierr
1098)
1099) type(discretization_type), pointer :: discretization
1100) type(field_type), pointer :: field
1101) type(option_type), pointer :: option
1102) character(len=MAXSTRINGLENGTH) :: string
1103)
1104) field => realization%field
1105) discretization => realization%discretization
1106) option => realization%option
1107)
1108) ! Communication -----------------------------------------
1109) ! These 3 must be called before RichardsUpdateAuxVars()
1110) call DiscretizationGlobalToLocal(discretization,xx,field%flow_xx_loc,NFLOWDOF)
1111) call DiscretizationLocalToLocal(discretization,field%iphas_loc, &
1112) field%iphas_loc,ONEDOF)
1113)
1114) call MaterialGetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
1115) PERMEABILITY_X,ZERO_INTEGER)
1116) call DiscretizationLocalToLocal(discretization,field%work_loc, &
1117) field%work_loc,ONEDOF)
1118) call MaterialSetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
1119) PERMEABILITY_X,ZERO_INTEGER)
1120) call MaterialGetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
1121) PERMEABILITY_Y,ZERO_INTEGER)
1122) call DiscretizationLocalToLocal(discretization,field%work_loc, &
1123) field%work_loc,ONEDOF)
1124) call MaterialSetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
1125) PERMEABILITY_Y,ZERO_INTEGER)
1126) call MaterialGetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
1127) PERMEABILITY_Z,ZERO_INTEGER)
1128) call DiscretizationLocalToLocal(discretization,field%work_loc, &
1129) field%work_loc,ONEDOF)
1130) call MaterialSetAuxVarVecLoc(realization%patch%aux%Material,field%work_loc, &
1131) PERMEABILITY_Z,ZERO_INTEGER)
1132)
1133) end subroutine RichardsUpdateLocalVecs
1134)
1135) ! ************************************************************************** !
1136)
1137) subroutine RichardsResidualInternalConn(r,realization,skip_conn_type,ierr)
1138) !
1139) ! Computes the interior flux terms of the residual equation
1140) !
1141) ! Author: Glenn Hammond
1142) ! Date: 12/10/07
1143) !
1144)
1145) use Connection_module
1146) use Realization_Subsurface_class
1147) use Patch_module
1148) use Grid_module
1149) use Option_module
1150) use Coupler_module
1151) use Debug_module
1152)
1153) implicit none
1154)
1155) Vec :: r
1156) type(realization_subsurface_type) :: realization
1157) PetscInt :: skip_conn_type
1158) PetscErrorCode :: ierr
1159)
1160) type(grid_type), pointer :: grid
1161) type(patch_type), pointer :: patch
1162) type(option_type), pointer :: option
1163) type(material_parameter_type), pointer :: material_parameter
1164) type(richards_auxvar_type), pointer :: rich_auxvars(:)
1165) type(global_auxvar_type), pointer :: global_auxvars(:)
1166) class(material_auxvar_type), pointer :: material_auxvars(:)
1167) type(connection_set_list_type), pointer :: connection_set_list
1168) type(connection_set_type), pointer :: cur_connection_set
1169)
1170) PetscInt :: istart
1171) PetscInt :: local_id_up
1172) PetscInt :: local_id_dn
1173) PetscInt :: ghosted_id_up
1174) PetscInt :: ghosted_id_dn
1175) PetscInt :: icap_up
1176) PetscInt :: icap_dn
1177) PetscInt :: iconn
1178) PetscInt :: sum_connection
1179)
1180) PetscReal :: Res(realization%option%nflowdof)
1181) PetscReal :: v_darcy
1182) PetscReal, pointer :: r_p(:)
1183)
1184) patch => realization%patch
1185) grid => patch%grid
1186) option => realization%option
1187) material_parameter => patch%aux%Material%material_parameter
1188) rich_auxvars => patch%aux%Richards%auxvars
1189) global_auxvars => patch%aux%Global%auxvars
1190) material_auxvars => patch%aux%Material%auxvars
1191)
1192) call VecGetArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1193)
1194) ! Interior Flux Terms -----------------------------------
1195) connection_set_list => grid%internal_connection_set_list
1196) cur_connection_set => connection_set_list%first
1197) sum_connection = 0
1198) do
1199) if (.not.associated(cur_connection_set)) exit
1200) do iconn = 1, cur_connection_set%num_connections
1201) sum_connection = sum_connection + 1
1202)
1203) ghosted_id_up = cur_connection_set%id_up(iconn)
1204) ghosted_id_dn = cur_connection_set%id_dn(iconn)
1205)
1206) local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
1207) local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping
1208)
1209) if (patch%imat(ghosted_id_up) <= 0 .or. &
1210) patch%imat(ghosted_id_dn) <= 0) cycle
1211)
1212) if (.not.(skip_conn_type == NO_CONN)) then
1213) if (skip_conn(cur_connection_set%dist(1:3,iconn), skip_conn_type)) cycle
1214) endif
1215)
1216) icap_up = patch%sat_func_id(ghosted_id_up)
1217) icap_dn = patch%sat_func_id(ghosted_id_dn)
1218)
1219) call RichardsFlux(rich_auxvars(ghosted_id_up), &
1220) global_auxvars(ghosted_id_up), &
1221) material_auxvars(ghosted_id_up), &
1222) material_parameter%soil_residual_saturation(1,icap_up), &
1223) rich_auxvars(ghosted_id_dn), &
1224) global_auxvars(ghosted_id_dn), &
1225) material_auxvars(ghosted_id_dn), &
1226) material_parameter%soil_residual_saturation(1,icap_dn), &
1227) cur_connection_set%area(iconn), &
1228) cur_connection_set%dist(:,iconn), &
1229) option,v_darcy,Res)
1230)
1231) patch%internal_velocities(1,sum_connection) = v_darcy
1232) if (associated(patch%internal_flow_fluxes)) then
1233) patch%internal_flow_fluxes(1,sum_connection) = Res(1)
1234) endif
1235) if (local_id_up>0) then
1236) istart = (local_id_up-1)*option%nflowdof + 1
1237) r_p(istart) = r_p(istart) + Res(1)
1238) endif
1239)
1240) if (local_id_dn>0) then
1241) istart = (local_id_dn-1)*option%nflowdof + 1
1242) r_p(istart) = r_p(istart) - Res(1)
1243) endif
1244)
1245) enddo
1246)
1247) cur_connection_set => cur_connection_set%next
1248) enddo
1249)
1250) call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1251)
1252) end subroutine RichardsResidualInternalConn
1253)
1254) ! ************************************************************************** !
1255)
1256) subroutine RichardsResidualBoundaryConn(r,realization,ierr)
1257) !
1258) ! Computes the boundary flux terms of the residual equation
1259) !
1260) ! Author: Glenn Hammond
1261) ! Date: 12/10/07
1262) !
1263)
1264) use Connection_module
1265) use Realization_Subsurface_class
1266) use Patch_module
1267) use Grid_module
1268) use Option_module
1269) use Coupler_module
1270) use Debug_module
1271)
1272) implicit none
1273)
1274) Vec :: r
1275) type(realization_subsurface_type) :: realization
1276)
1277) type(grid_type), pointer :: grid
1278) type(patch_type), pointer :: patch
1279) type(option_type), pointer :: option
1280) type(coupler_type), pointer :: boundary_condition
1281) type(material_parameter_type), pointer :: material_parameter
1282) type(richards_auxvar_type), pointer :: rich_auxvars(:), rich_auxvars_bc(:)
1283) type(global_auxvar_type), pointer :: global_auxvars(:), global_auxvars_bc(:)
1284) class(material_auxvar_type), pointer :: material_auxvars(:)
1285) type(connection_set_list_type), pointer :: connection_set_list
1286) type(connection_set_type), pointer :: cur_connection_set
1287)
1288) PetscInt :: local_id
1289) PetscInt :: ghosted_id
1290) PetscInt :: istart
1291) PetscInt :: icap_up
1292) PetscInt :: icap_dn
1293) PetscInt :: iconn
1294) PetscInt :: sum_connection
1295)
1296) PetscReal :: Res(realization%option%nflowdof), v_darcy
1297) PetscReal, pointer :: r_p(:)
1298)
1299) PetscErrorCode :: ierr
1300)
1301) patch => realization%patch
1302) grid => patch%grid
1303) option => realization%option
1304) material_parameter => patch%aux%Material%material_parameter
1305) rich_auxvars => patch%aux%Richards%auxvars
1306) rich_auxvars_bc => patch%aux%Richards%auxvars_bc
1307) global_auxvars => patch%aux%Global%auxvars
1308) global_auxvars_bc => patch%aux%Global%auxvars_bc
1309) material_auxvars => patch%aux%Material%auxvars
1310)
1311) call VecGetArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1312)
1313) ! Boundary Flux Terms -----------------------------------
1314) boundary_condition => patch%boundary_condition_list%first
1315) sum_connection = 0
1316) do
1317) if (.not.associated(boundary_condition)) exit
1318)
1319) cur_connection_set => boundary_condition%connection_set
1320)
1321) do iconn = 1, cur_connection_set%num_connections
1322) sum_connection = sum_connection + 1
1323)
1324) local_id = cur_connection_set%id_dn(iconn)
1325) ghosted_id = grid%nL2G(local_id)
1326)
1327) if (patch%imat(ghosted_id) <= 0) cycle
1328)
1329) if (ghosted_id<=0) then
1330) print *, "Wrong boundary node index... STOP!!!"
1331) stop
1332) endif
1333)
1334) icap_dn = patch%sat_func_id(ghosted_id)
1335)
1336) call RichardsBCFlux(boundary_condition%flow_condition%itype, &
1337) boundary_condition%flow_aux_real_var(:,iconn), &
1338) rich_auxvars_bc(sum_connection), &
1339) global_auxvars_bc(sum_connection), &
1340) rich_auxvars(ghosted_id), &
1341) global_auxvars(ghosted_id), &
1342) material_auxvars(ghosted_id), &
1343) material_parameter%soil_residual_saturation(1,icap_dn), &
1344) cur_connection_set%area(iconn), &
1345) cur_connection_set%dist(:,iconn), &
1346) option, &
1347) v_darcy,Res)
1348) patch%boundary_velocities(1,sum_connection) = v_darcy
1349) if (associated(patch%boundary_flow_fluxes)) then
1350) patch%boundary_flow_fluxes(1,sum_connection) = Res(1)
1351) endif
1352)
1353) if (option%compute_mass_balance_new) then
1354) ! contribution to boundary
1355) global_auxvars_bc(sum_connection)%mass_balance_delta(1,1) = &
1356) global_auxvars_bc(sum_connection)%mass_balance_delta(1,1) - Res(1)
1357) endif
1358)
1359) istart = (local_id-1)*option%nflowdof + 1
1360) r_p(istart)= r_p(istart) - Res(1)
1361)
1362) enddo
1363) boundary_condition => boundary_condition%next
1364) enddo
1365)
1366) call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1367)
1368) end subroutine RichardsResidualBoundaryConn
1369)
1370) ! ************************************************************************** !
1371)
1372) subroutine RichardsResidualSourceSink(r,realization,ierr)
1373) !
1374) ! Computes the accumulation and source/sink terms of
1375) ! the residual equation on a single patch
1376) !
1377) ! Author: Glenn Hammond
1378) ! Date: 12/10/07
1379) !
1380)
1381) use Connection_module
1382) use Realization_Subsurface_class
1383) use Patch_module
1384) use Grid_module
1385) use Option_module
1386) use Coupler_module
1387) use Field_module
1388) use Debug_module
1389)
1390) implicit none
1391)
1392) Vec :: r
1393) type(realization_subsurface_type) :: realization
1394)
1395) type(grid_type), pointer :: grid
1396) type(patch_type), pointer :: patch
1397) type(option_type), pointer :: option
1398) type(field_type), pointer :: field
1399) type(richards_auxvar_type), pointer :: rich_auxvars(:), rich_auxvars_ss(:)
1400) type(global_auxvar_type), pointer :: global_auxvars(:), global_auxvars_ss(:)
1401) class(material_auxvar_type), pointer :: material_auxvars(:)
1402) type(coupler_type), pointer :: source_sink
1403) type(connection_set_type), pointer :: cur_connection_set
1404)
1405) PetscInt :: i
1406) PetscInt :: local_id, ghosted_id
1407) PetscInt :: istart
1408) PetscInt :: iconn
1409) PetscInt :: sum_connection
1410)
1411) PetscReal :: qsrc, qsrc_mol
1412) PetscReal :: Res(realization%option%nflowdof)
1413) PetscReal, pointer :: r_p(:), accum_p(:)
1414) PetscReal, pointer :: mmsrc(:)
1415) PetscReal, allocatable :: msrc(:)
1416) PetscReal :: well_status
1417) PetscReal :: well_factor
1418) PetscReal :: pressure_bh
1419) PetscReal :: pressure_max
1420) PetscReal :: pressure_min
1421) PetscReal :: well_inj_water
1422) PetscReal :: Dq, dphi, v_darcy, ukvr
1423)
1424) Mat, parameter :: null_mat = 0
1425)
1426) PetscErrorCode :: ierr
1427)
1428) patch => realization%patch
1429) grid => patch%grid
1430) option => realization%option
1431) field => realization%field
1432) rich_auxvars => patch%aux%Richards%auxvars
1433) rich_auxvars_ss => patch%aux%Richards%auxvars_ss
1434) global_auxvars => patch%aux%Global%auxvars
1435) global_auxvars_ss => patch%aux%Global%auxvars_ss
1436) material_auxvars => patch%aux%Material%auxvars
1437)
1438) ! now assign access pointer to local variables
1439) call VecGetArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1440)
1441) ! Source/sink terms -------------------------------------
1442) source_sink => patch%source_sink_list%first
1443) sum_connection = 0
1444) do
1445) if (.not.associated(source_sink)) exit
1446)
1447) cur_connection_set => source_sink%connection_set
1448)
1449) do iconn = 1, cur_connection_set%num_connections
1450) sum_connection = sum_connection + 1
1451) local_id = cur_connection_set%id_dn(iconn)
1452) ghosted_id = grid%nL2G(local_id)
1453) if (patch%imat(ghosted_id) <= 0) cycle
1454)
1455) if (source_sink%flow_condition%itype(1)/=HET_VOL_RATE_SS .and. &
1456) source_sink%flow_condition%itype(1)/=HET_MASS_RATE_SS .and. &
1457) source_sink%flow_condition%itype(1)/=WELL_SS) &
1458) qsrc = source_sink%flow_condition%rate%dataset%rarray(1)
1459)
1460) select case(source_sink%flow_condition%itype(1))
1461) case(MASS_RATE_SS)
1462) qsrc_mol = qsrc/FMWH2O ! kg/sec -> kmol/sec
1463) case(SCALED_MASS_RATE_SS)
1464) qsrc_mol = qsrc/FMWH2O* & ! kg/sec -> kmol/sec
1465) source_sink%flow_aux_real_var(ONE_INTEGER,iconn)
1466) case(VOLUMETRIC_RATE_SS) ! assume local density for now
1467) ! qsrc1 = m^3/sec
1468) qsrc_mol = qsrc*global_auxvars(ghosted_id)%den(1) ! den = kmol/m^3
1469) case(SCALED_VOLUMETRIC_RATE_SS) ! assume local density for now
1470) ! qsrc1 = m^3/sec
1471) qsrc_mol = qsrc*global_auxvars(ghosted_id)%den(1)* & ! den = kmol/m^3
1472) source_sink%flow_aux_real_var(ONE_INTEGER,iconn)
1473) case(HET_VOL_RATE_SS)
1474) ! qsrc1 = m^3/sec
1475) qsrc_mol = source_sink%flow_aux_real_var(ONE_INTEGER,iconn)* & ! flow = m^3/s
1476) global_auxvars(ghosted_id)%den(1) ! den = kmol/m^3
1477) case(HET_MASS_RATE_SS)
1478) qsrc_mol = source_sink%flow_aux_real_var(ONE_INTEGER,iconn)/FMWH2O ! kg/sec -> kmol/sec
1479)
1480) case(WELL_SS) ! production well, SK 12/19/13
1481) ! if node pessure is lower than the given extraction pressure, shut it down
1482) ! well parameter explanation
1483) ! 1. well status. 1 injection; -1 production; 0 shut in!
1484) ! 2. well factor [m^3], the effective permeability [m^2/s]
1485) ! 3. bottomhole pressure: [Pa]
1486) ! 4. max pressure: [Pa]
1487) ! 5. min pressure: [Pa]
1488) mmsrc => source_sink%flow_condition%well%dataset%rarray
1489)
1490) well_status = mmsrc(1)
1491) well_factor = mmsrc(2)
1492) pressure_bh = mmsrc(3)
1493) pressure_max = mmsrc(4)
1494) pressure_min = mmsrc(5)
1495)
1496) ! production well (well status = -1)
1497) if (dabs(well_status + 1.D0) < 1.D-1) then
1498) if (global_auxvars(ghosted_id)%pres(1) > pressure_min) then
1499) Dq = well_factor
1500) dphi = global_auxvars(ghosted_id)%pres(1) - pressure_bh
1501) if (dphi >= 0.D0) then ! outflow only
1502) ukvr = rich_auxvars(ghosted_id)%kvr
1503) if (ukvr < 1.e-20) ukvr = 0.D0
1504) v_darcy = 0.D0
1505) if (ukvr*Dq > floweps) then
1506) v_darcy = Dq * ukvr * dphi
1507) ! store volumetric rate for ss_fluid_fluxes()
1508) qsrc_mol = -1.d0*v_darcy*global_auxvars(ghosted_id)%den(1)
1509) endif
1510) endif
1511) endif
1512) endif
1513) end select
1514)
1515) if (option%compute_mass_balance_new) then
1516) ! need to added global auxvar for src/sink
1517) global_auxvars_ss(sum_connection)%mass_balance_delta(1,1) = &
1518) global_auxvars_ss(sum_connection)%mass_balance_delta(1,1) - &
1519) qsrc_mol
1520) endif
1521)
1522) istart = (local_id-1)*option%nflowdof + 1
1523) r_p(istart) = r_p(istart) - qsrc_mol
1524)
1525) if (associated(patch%ss_flow_vol_fluxes)) then
1526) ! fluid flux [m^3/sec] = qsrc_mol [kmol/sec] / den [kmol/m^3]
1527) patch%ss_flow_vol_fluxes(1,sum_connection) = qsrc_mol / &
1528) global_auxvars(ghosted_id)%den(1)
1529) endif
1530) if (associated(patch%ss_flow_fluxes)) then
1531) ! fluid flux [m^3/sec] = qsrc_mol [kmol/sec] / den [kmol/m^3]
1532) patch%ss_flow_fluxes(1,sum_connection) = qsrc_mol
1533) endif
1534) enddo
1535) source_sink => source_sink%next
1536) enddo
1537)
1538) call RichardsSSSandbox(r,null_mat,PETSC_FALSE,grid,material_auxvars, &
1539) global_auxvars,rich_auxvars,option)
1540)
1541) if (patch%aux%Richards%inactive_cells_exist) then
1542) do i=1,patch%aux%Richards%n_zero_rows
1543) r_p(patch%aux%Richards%zero_rows_local(i)) = 0.d0
1544) enddo
1545) endif
1546)
1547) call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1548)
1549) ! Mass Transfer
1550) if (field%flow_mass_transfer /= 0) then
1551) ! scale by -1.d0 for contribution to residual. A negative contribution
1552) ! indicates mass being added to system.
1553) call VecAXPY(r,-1.d0,field%flow_mass_transfer,ierr);CHKERRQ(ierr)
1554) endif
1555)
1556) end subroutine RichardsResidualSourceSink
1557)
1558) ! ************************************************************************** !
1559)
1560) subroutine RichardsResidualAccumulation(r,realization,ierr)
1561) !
1562) ! Computes the accumulation terms of the residual equation
1563) !
1564) ! Author: Glenn Hammond
1565) ! Date: 12/10/07
1566) !
1567)
1568) use Connection_module
1569) use Realization_Subsurface_class
1570) use Patch_module
1571) use Grid_module
1572) use Option_module
1573) use Coupler_module
1574) use Field_module
1575) use Debug_module
1576)
1577) implicit none
1578)
1579) Vec :: r
1580) type(realization_subsurface_type) :: realization
1581)
1582) type(grid_type), pointer :: grid
1583) type(patch_type), pointer :: patch
1584) type(option_type), pointer :: option
1585) type(field_type), pointer :: field
1586) type(richards_auxvar_type), pointer :: rich_auxvars(:)
1587) type(global_auxvar_type), pointer :: global_auxvars(:)
1588) class(material_auxvar_type), pointer :: material_auxvars(:)
1589)
1590) PetscInt :: local_id, ghosted_id
1591) PetscInt :: istart
1592)
1593) PetscReal, pointer :: r_p(:), accum_p(:)
1594) PetscReal :: Res(realization%option%nflowdof)
1595)
1596) PetscErrorCode :: ierr
1597)
1598) patch => realization%patch
1599) grid => patch%grid
1600) option => realization%option
1601) field => realization%field
1602) rich_auxvars => patch%aux%Richards%auxvars
1603) global_auxvars => patch%aux%Global%auxvars
1604) material_auxvars => patch%aux%Material%auxvars
1605)
1606) ! now assign access pointer to local variables
1607) call VecGetArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1608) call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
1609)
1610) ! Accumulation terms ------------------------------------
1611) if (.not.option%steady_state) then
1612) r_p = r_p - accum_p
1613)
1614) do local_id = 1, grid%nlmax ! For each local node do...
1615) ghosted_id = grid%nL2G(local_id)
1616) !geh - Ignore inactive cells with inactive materials
1617) if (patch%imat(ghosted_id) <= 0) cycle
1618) call RichardsAccumulation(rich_auxvars(ghosted_id), &
1619) global_auxvars(ghosted_id), &
1620) material_auxvars(ghosted_id), &
1621) option,Res)
1622) istart = (local_id-1)*option%nflowdof + 1
1623) r_p(istart) = r_p(istart) + Res(1)
1624) enddo
1625) endif
1626)
1627) call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
1628) call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
1629)
1630) end subroutine RichardsResidualAccumulation
1631)
1632) ! ************************************************************************** !
1633)
1634) subroutine RichardsJacobian(snes,xx,A,B,realization,ierr)
1635) !
1636) ! Computes the Jacobian
1637) !
1638) ! Author: Glenn Hammond
1639) ! Date: 12/10/07
1640) !
1641)
1642) use Realization_Subsurface_class
1643) use Patch_module
1644) use Grid_module
1645) use Option_module
1646) use Logging_module
1647) use Debug_module
1648)
1649) implicit none
1650)
1651) SNES :: snes
1652) Vec :: xx
1653) Mat :: A, B
1654) type(realization_subsurface_type) :: realization
1655) PetscErrorCode :: ierr
1656)
1657) Mat :: J
1658) MatType :: mat_type
1659) PetscViewer :: viewer
1660) type(grid_type), pointer :: grid
1661) type(option_type), pointer :: option
1662) PetscReal :: norm
1663) character(len=MAXSTRINGLENGTH) :: string
1664)
1665) call PetscLogEventBegin(logging%event_r_jacobian,ierr);CHKERRQ(ierr)
1666)
1667) option => realization%option
1668)
1669) call MatGetType(A,mat_type,ierr);CHKERRQ(ierr)
1670) if (mat_type == MATMFFD) then
1671) J = B
1672) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
1673) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
1674) else
1675) J = A
1676) endif
1677)
1678) call MatZeroEntries(J,ierr);CHKERRQ(ierr)
1679)
1680) call RichardsJacobianInternalConn(J,realization,ierr)
1681) call RichardsJacobianBoundaryConn(J,realization,ierr)
1682) call RichardsJacobianAccumulation(J,realization,ierr)
1683) call RichardsJacobianSourceSink(J,realization,ierr)
1684)
1685) if (realization%debug%matview_Jacobian) then
1686) string = 'Rjacobian'
1687) call DebugCreateViewer(realization%debug,string,option,viewer)
1688) call MatView(J,viewer,ierr);CHKERRQ(ierr)
1689) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1690) endif
1691) if (realization%debug%norm_Jacobian) then
1692) option => realization%option
1693) call MatNorm(J,NORM_1,norm,ierr);CHKERRQ(ierr)
1694) write(option%io_buffer,'("1 norm: ",es11.4)') norm
1695) call printMsg(option)
1696) call MatNorm(J,NORM_FROBENIUS,norm,ierr);CHKERRQ(ierr)
1697) write(option%io_buffer,'("2 norm: ",es11.4)') norm
1698) call printMsg(option)
1699) call MatNorm(J,NORM_INFINITY,norm,ierr);CHKERRQ(ierr)
1700) write(option%io_buffer,'("inf norm: ",es11.4)') norm
1701) call printMsg(option)
1702) endif
1703)
1704) #if 0
1705) call PetscViewerASCIIOpen(realization%option%mycomm,'flow_dxx.out', &
1706) viewer,ierr);CHKERRQ(ierr)
1707) call VecView(realization%field%flow_dxx,viewer,ierr);CHKERRQ(ierr)
1708)
1709) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1710)
1711)
1712) call PetscViewerASCIIOpen(realization%option%mycomm,'flow_yy.out', &
1713) viewer,ierr);CHKERRQ(ierr)
1714) call VecView(realization%field%flow_yy,viewer,ierr);CHKERRQ(ierr)
1715) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1716) #endif
1717)
1718) call PetscLogEventEnd(logging%event_r_jacobian,ierr);CHKERRQ(ierr)
1719) ! call printErrMsg(option)
1720)
1721)
1722) end subroutine RichardsJacobian
1723)
1724) ! ************************************************************************** !
1725)
1726) subroutine RichardsJacobianInternalConn(A,realization,ierr)
1727) !
1728) ! Computes the interior flux terms of the Jacobian
1729) !
1730) ! Author: Glenn Hammond
1731) ! Date: 12/13/07
1732) !
1733)
1734) use Connection_module
1735) use Realization_Subsurface_class
1736) use Option_module
1737) use Patch_module
1738) use Grid_module
1739) use Coupler_module
1740) use Field_module
1741) use Debug_module
1742) use Material_Aux_class
1743)
1744) implicit none
1745)
1746) Mat, intent(out) :: A
1747) type(realization_subsurface_type) :: realization
1748)
1749) PetscErrorCode :: ierr
1750)
1751) PetscInt :: icap_up,icap_dn
1752) PetscInt :: local_id_up, local_id_dn
1753) PetscInt :: ghosted_id_up, ghosted_id_dn
1754) PetscInt :: istart_up, istart_dn, istart
1755)
1756) PetscReal :: Jup(realization%option%nflowdof,realization%option%nflowdof), &
1757) Jdn(realization%option%nflowdof,realization%option%nflowdof)
1758)
1759) type(coupler_type), pointer :: boundary_condition, source_sink
1760) type(connection_set_list_type), pointer :: connection_set_list
1761) type(connection_set_type), pointer :: cur_connection_set
1762) PetscInt :: iconn
1763) PetscInt :: sum_connection
1764) type(grid_type), pointer :: grid
1765) type(patch_type), pointer :: patch
1766) type(option_type), pointer :: option
1767) type(field_type), pointer :: field
1768) type(material_parameter_type), pointer :: material_parameter
1769) type(richards_auxvar_type), pointer :: rich_auxvars(:)
1770) type(global_auxvar_type), pointer :: global_auxvars(:)
1771) class(material_auxvar_type), pointer :: material_auxvars(:)
1772)
1773) character(len=MAXSTRINGLENGTH) :: string
1774)
1775) PetscViewer :: viewer
1776)
1777) patch => realization%patch
1778) grid => patch%grid
1779) option => realization%option
1780) field => realization%field
1781) material_parameter => patch%aux%Material%material_parameter
1782) rich_auxvars => patch%aux%Richards%auxvars
1783) global_auxvars => patch%aux%Global%auxvars
1784) material_auxvars => patch%aux%Material%auxvars
1785)
1786) #ifdef BUFFER_MATRIX
1787) if (option%use_matrix_buffer) then
1788) if (associated(patch%aux%Richards%matrix_buffer)) then
1789) call MatrixBufferZero(patch%aux%Richards%matrix_buffer)
1790) else
1791) patch%aux%Richards%matrix_buffer => MatrixBufferCreate()
1792) call MatrixBufferInit(A,patch%aux%Richards%matrix_buffer,grid)
1793) endif
1794) endif
1795) #endif
1796)
1797) ! Interior Flux Terms -----------------------------------
1798) connection_set_list => grid%internal_connection_set_list
1799) cur_connection_set => connection_set_list%first
1800) sum_connection = 0
1801) do
1802) if (.not.associated(cur_connection_set)) exit
1803) do iconn = 1, cur_connection_set%num_connections
1804) sum_connection = sum_connection + 1
1805)
1806) ghosted_id_up = cur_connection_set%id_up(iconn)
1807) ghosted_id_dn = cur_connection_set%id_dn(iconn)
1808)
1809) if (patch%imat(ghosted_id_up) <= 0 .or. &
1810) patch%imat(ghosted_id_dn) <= 0) cycle
1811)
1812) if (option%flow%only_vertical_flow) then
1813) !geh: place second conditional within first to avoid excessive
1814) ! dot products when .not. option%flow%only_vertical_flow
1815) if (abs(dot_product(cur_connection_set%dist(1:3,iconn),unit_z)) < &
1816) 0.99d0) cycle
1817) endif
1818)
1819) local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
1820) local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping
1821)
1822) icap_up = patch%sat_func_id(ghosted_id_up)
1823) icap_dn = patch%sat_func_id(ghosted_id_dn)
1824)
1825) call RichardsFluxDerivative(rich_auxvars(ghosted_id_up), &
1826) global_auxvars(ghosted_id_up), &
1827) material_auxvars(ghosted_id_up), &
1828) material_parameter%soil_residual_saturation(1,icap_up), &
1829) rich_auxvars(ghosted_id_dn), &
1830) global_auxvars(ghosted_id_dn), &
1831) material_auxvars(ghosted_id_dn), &
1832) material_parameter%soil_residual_saturation(1,icap_dn), &
1833) cur_connection_set%area(iconn), &
1834) cur_connection_set%dist(-1:3,iconn),&
1835) option,&
1836) patch%characteristic_curves_array(icap_up)%ptr, &
1837) patch%characteristic_curves_array(icap_dn)%ptr, &
1838) Jup,Jdn)
1839)
1840) if (local_id_up > 0) then
1841)
1842) #ifdef BUFFER_MATRIX
1843) if (option%use_matrix_buffer) then
1844) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id_up, &
1845) ghosted_id_up,Jup(1,1))
1846) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id_up, &
1847) ghosted_id_dn,Jdn(1,1))
1848) else
1849) #endif
1850) istart_up = (ghosted_id_up-1)*option%nflowdof + 1
1851) istart_dn = (ghosted_id_dn-1)*option%nflowdof + 1
1852)
1853) call MatSetValuesLocal(A,1,istart_up-1,1,istart_up-1, &
1854) Jup,ADD_VALUES,ierr);CHKERRQ(ierr)
1855) call MatSetValuesLocal(A,1,istart_up-1,1,istart_dn-1, &
1856) Jdn,ADD_VALUES,ierr);CHKERRQ(ierr)
1857) #ifdef BUFFER_MATRIX
1858) endif
1859) #endif
1860) endif
1861)
1862) if (local_id_dn > 0) then
1863) Jup = -Jup
1864) Jdn = -Jdn
1865) #ifdef BUFFER_MATRIX
1866) if (option%use_matrix_buffer) then
1867) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id_dn, &
1868) ghosted_id_dn,Jdn(1,1))
1869) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id_dn, &
1870) ghosted_id_up,Jup(1,1))
1871) else
1872) #endif
1873) istart_up = (ghosted_id_up-1)*option%nflowdof + 1
1874) istart_dn = (ghosted_id_dn-1)*option%nflowdof + 1
1875)
1876) call MatSetValuesLocal(A,1,istart_dn-1,1,istart_dn-1, &
1877) Jdn,ADD_VALUES,ierr);CHKERRQ(ierr)
1878) call MatSetValuesLocal(A,1,istart_dn-1,1,istart_up-1, &
1879) Jup,ADD_VALUES,ierr);CHKERRQ(ierr)
1880) #ifdef BUFFER_MATRIX
1881) endif
1882) #endif
1883) endif
1884) enddo
1885) cur_connection_set => cur_connection_set%next
1886) enddo
1887)
1888) if (realization%debug%matview_Jacobian_detailed) then
1889) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
1890) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
1891) string = 'jacobian_flux'
1892) call DebugCreateViewer(realization%debug,string,option,viewer)
1893) call MatView(A,viewer,ierr);CHKERRQ(ierr)
1894) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
1895) endif
1896)
1897) end subroutine RichardsJacobianInternalConn
1898)
1899) ! ************************************************************************** !
1900)
1901) subroutine RichardsJacobianBoundaryConn(A,realization,ierr)
1902) !
1903) ! Computes the boundary flux terms of the Jacobian
1904) !
1905) ! Author: Glenn Hammond
1906) ! Date: 12/13/07
1907) !
1908)
1909) use Connection_module
1910) use Realization_Subsurface_class
1911) use Option_module
1912) use Patch_module
1913) use Grid_module
1914) use Coupler_module
1915) use Field_module
1916) use Debug_module
1917) use Material_Aux_class
1918)
1919) implicit none
1920)
1921) Mat, intent(out) :: A
1922) type(realization_subsurface_type) :: realization
1923)
1924) PetscErrorCode :: ierr
1925)
1926) PetscInt :: icap_up,icap_dn
1927) PetscInt :: local_id, ghosted_id
1928) PetscInt :: local_id_up, local_id_dn
1929) PetscInt :: ghosted_id_up, ghosted_id_dn
1930) PetscInt :: istart_up, istart_dn, istart
1931)
1932) PetscReal :: Jup(realization%option%nflowdof,realization%option%nflowdof), &
1933) Jdn(realization%option%nflowdof,realization%option%nflowdof)
1934)
1935) type(coupler_type), pointer :: boundary_condition, source_sink
1936) type(connection_set_list_type), pointer :: connection_set_list
1937) type(connection_set_type), pointer :: cur_connection_set
1938) PetscInt :: iconn
1939) PetscInt :: sum_connection
1940) type(grid_type), pointer :: grid
1941) type(patch_type), pointer :: patch
1942) type(option_type), pointer :: option
1943) type(field_type), pointer :: field
1944) type(material_parameter_type), pointer :: material_parameter
1945) type(richards_auxvar_type), pointer :: rich_auxvars(:), rich_auxvars_bc(:)
1946) type(global_auxvar_type), pointer :: global_auxvars(:), global_auxvars_bc(:)
1947) class(material_auxvar_type), pointer :: material_auxvars(:)
1948)
1949) character(len=MAXSTRINGLENGTH) :: string
1950)
1951) PetscViewer :: viewer
1952)
1953) patch => realization%patch
1954) grid => patch%grid
1955) option => realization%option
1956) field => realization%field
1957) material_parameter => patch%aux%Material%material_parameter
1958) rich_auxvars => patch%aux%Richards%auxvars
1959) rich_auxvars_bc => patch%aux%Richards%auxvars_bc
1960) global_auxvars => patch%aux%Global%auxvars
1961) global_auxvars_bc => patch%aux%Global%auxvars_bc
1962) material_auxvars => patch%aux%Material%auxvars
1963)
1964) ! Boundary Flux Terms -----------------------------------
1965) boundary_condition => patch%boundary_condition_list%first
1966) sum_connection = 0
1967) do
1968) if (.not.associated(boundary_condition)) exit
1969)
1970) cur_connection_set => boundary_condition%connection_set
1971)
1972) do iconn = 1, cur_connection_set%num_connections
1973) sum_connection = sum_connection + 1
1974)
1975) local_id = cur_connection_set%id_dn(iconn)
1976) ghosted_id = grid%nL2G(local_id)
1977)
1978) if (patch%imat(ghosted_id) <= 0) cycle
1979)
1980) if (ghosted_id<=0) then
1981) print *, "Wrong boundary node index... STOP!!!"
1982) stop
1983) endif
1984)
1985) icap_dn = patch%sat_func_id(ghosted_id)
1986)
1987) call RichardsBCFluxDerivative(boundary_condition%flow_condition%itype, &
1988) boundary_condition%flow_aux_real_var(:,iconn), &
1989) rich_auxvars_bc(sum_connection), &
1990) global_auxvars_bc(sum_connection), &
1991) rich_auxvars(ghosted_id), &
1992) global_auxvars(ghosted_id), &
1993) material_auxvars(ghosted_id), &
1994) material_parameter%soil_residual_saturation(1,icap_dn), &
1995) cur_connection_set%area(iconn), &
1996) cur_connection_set%dist(:,iconn), &
1997) option, &
1998) patch%characteristic_curves_array(icap_dn)%ptr, &
1999) Jdn)
2000) Jdn = -Jdn
2001)
2002) #ifdef BUFFER_MATRIX
2003) if (option%use_matrix_buffer) then
2004) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id, &
2005) ghosted_id,Jdn(1,1))
2006) else
2007) #endif
2008) istart = (ghosted_id-1)*option%nflowdof + 1
2009)
2010) call MatSetValuesLocal(A,1,istart-1,1,istart-1,Jdn, &
2011) ADD_VALUES,ierr);CHKERRQ(ierr)
2012) #ifdef BUFFER_MATRIX
2013) endif
2014) #endif
2015)
2016) enddo
2017) boundary_condition => boundary_condition%next
2018) enddo
2019)
2020) if (realization%debug%matview_Jacobian_detailed) then
2021) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2022) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2023) string = 'jacobian_bcflux'
2024) call DebugCreateViewer(realization%debug,string,option,viewer)
2025) call MatView(A,viewer,ierr);CHKERRQ(ierr)
2026) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
2027) endif
2028)
2029) end subroutine RichardsJacobianBoundaryConn
2030)
2031) ! ************************************************************************** !
2032)
2033) subroutine RichardsJacobianAccumulation(A,realization,ierr)
2034) !
2035) ! Computes the accumulation terms of the Jacobian
2036) !
2037) ! Author: Glenn Hammond
2038) ! Date: 12/13/07
2039) !
2040)
2041) use Connection_module
2042) use Realization_Subsurface_class
2043) use Option_module
2044) use Patch_module
2045) use Grid_module
2046) use Coupler_module
2047) use Debug_module
2048)
2049) implicit none
2050)
2051) Mat, intent(out) :: A
2052) type(realization_subsurface_type) :: realization
2053)
2054) PetscErrorCode :: ierr
2055)
2056) PetscInt :: local_id, ghosted_id
2057) PetscInt :: istart
2058)
2059) PetscReal :: Jup(realization%option%nflowdof,realization%option%nflowdof)
2060)
2061) type(grid_type), pointer :: grid
2062) type(patch_type), pointer :: patch
2063) type(option_type), pointer :: option
2064) type(richards_auxvar_type), pointer :: rich_auxvars(:)
2065) type(global_auxvar_type), pointer :: global_auxvars(:)
2066) class(material_auxvar_type), pointer :: material_auxvars(:)
2067) PetscViewer :: viewer
2068) character(len=MAXSTRINGLENGTH) :: string
2069)
2070) patch => realization%patch
2071) grid => patch%grid
2072) option => realization%option
2073) rich_auxvars => patch%aux%Richards%auxvars
2074) global_auxvars => patch%aux%Global%auxvars
2075) material_auxvars => patch%aux%Material%auxvars
2076)
2077) if (.not.option%steady_state) then
2078)
2079) ! Accumulation terms ------------------------------------
2080) do local_id = 1, grid%nlmax ! For each local node do...
2081) ghosted_id = grid%nL2G(local_id)
2082) !geh - Ignore inactive cells with inactive materials
2083) if (patch%imat(ghosted_id) <= 0) cycle
2084) call RichardsAccumDerivative(rich_auxvars(ghosted_id), &
2085) global_auxvars(ghosted_id), &
2086) material_auxvars(ghosted_id), &
2087) option, &
2088) patch%characteristic_curves_array( &
2089) patch%sat_func_id(ghosted_id))%ptr, &
2090) Jup)
2091)
2092) #ifdef BUFFER_MATRIX
2093) if (option%use_matrix_buffer) then
2094) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id, &
2095) ghosted_id,Jup(1,1))
2096) else
2097) #endif
2098) istart = (ghosted_id-1)*option%nflowdof + 1
2099)
2100) call MatSetValuesLocal(A,1,istart-1,1,istart-1,Jup, &
2101) ADD_VALUES,ierr);CHKERRQ(ierr)
2102) #ifdef BUFFER_MATRIX
2103) endif
2104) #endif
2105) enddo
2106)
2107) endif
2108)
2109) if (realization%debug%matview_Jacobian_detailed) then
2110) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2111) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2112) string = 'jacobian_accum'
2113) call DebugCreateViewer(realization%debug,string,option,viewer)
2114) call MatView(A,viewer,ierr);CHKERRQ(ierr)
2115) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
2116) endif
2117)
2118) end subroutine RichardsJacobianAccumulation
2119)
2120) ! ************************************************************************** !
2121)
2122) subroutine RichardsJacobianSourceSink(A,realization,ierr)
2123) !
2124) ! Computes the accumulation and source/sink terms of
2125) ! the Jacobian
2126) !
2127) ! Author: Glenn Hammond
2128) ! Date: 12/13/07
2129) !
2130)
2131) use Connection_module
2132) use Realization_Subsurface_class
2133) use Option_module
2134) use Patch_module
2135) use Grid_module
2136) use Coupler_module
2137) use Field_module
2138) use Debug_module
2139)
2140) implicit none
2141)
2142) Mat, intent(out) :: A
2143) type(realization_subsurface_type) :: realization
2144)
2145) PetscErrorCode :: ierr
2146)
2147) PetscReal :: qsrc
2148) PetscInt :: local_id, ghosted_id
2149) PetscInt :: istart
2150)
2151) PetscReal :: Jup(realization%option%nflowdof,realization%option%nflowdof)
2152)
2153) type(coupler_type), pointer :: source_sink
2154) type(connection_set_type), pointer :: cur_connection_set
2155) PetscInt :: iconn
2156) type(grid_type), pointer :: grid
2157) type(patch_type), pointer :: patch
2158) type(option_type), pointer :: option
2159) type(field_type), pointer :: field
2160) type(richards_auxvar_type), pointer :: rich_auxvars(:)
2161) type(global_auxvar_type), pointer :: global_auxvars(:)
2162) class(material_auxvar_type), pointer :: material_auxvars(:)
2163) PetscInt :: flow_pc
2164) PetscViewer :: viewer
2165) PetscReal, pointer :: mmsrc(:)
2166) PetscReal :: well_status
2167) PetscReal :: well_factor
2168) PetscReal :: pressure_bh
2169) PetscReal :: pressure_max
2170) PetscReal :: pressure_min
2171) PetscReal :: ukvr, Dq, dphi, v_darcy
2172) Vec, parameter :: null_vec = 0
2173) character(len=MAXSTRINGLENGTH) :: string
2174)
2175) patch => realization%patch
2176) grid => patch%grid
2177) option => realization%option
2178) field => realization%field
2179) rich_auxvars => patch%aux%Richards%auxvars
2180) global_auxvars => patch%aux%Global%auxvars
2181) material_auxvars => patch%aux%Material%auxvars
2182)
2183) ! Source/sink terms -------------------------------------
2184) source_sink => patch%source_sink_list%first
2185) do
2186) if (.not.associated(source_sink)) exit
2187)
2188) if (source_sink%flow_condition%itype(1)/=HET_VOL_RATE_SS.and. &
2189) source_sink%flow_condition%itype(1)/=HET_MASS_RATE_SS .and. &
2190) source_sink%flow_condition%itype(1)/=WELL_SS) &
2191) qsrc = source_sink%flow_condition%rate%dataset%rarray(1)
2192)
2193) cur_connection_set => source_sink%connection_set
2194)
2195) do iconn = 1, cur_connection_set%num_connections
2196) local_id = cur_connection_set%id_dn(iconn)
2197) ghosted_id = grid%nL2G(local_id)
2198)
2199) if (patch%imat(ghosted_id) <= 0) cycle
2200)
2201) Jup = 0.d0
2202) select case(source_sink%flow_condition%itype(1))
2203) case(MASS_RATE_SS,SCALED_MASS_RATE_SS,HET_MASS_RATE_SS)
2204) case(VOLUMETRIC_RATE_SS) ! assume local density for now
2205) Jup(1,1) = -qsrc*rich_auxvars(ghosted_id)%dden_dp*FMWH2O
2206) case(SCALED_VOLUMETRIC_RATE_SS) ! assume local density for now
2207) Jup(1,1) = -qsrc*rich_auxvars(ghosted_id)%dden_dp*FMWH2O* &
2208) source_sink%flow_aux_real_var(ONE_INTEGER,iconn)
2209) case(HET_VOL_RATE_SS)
2210) Jup(1,1) = -source_sink%flow_aux_real_var(ONE_INTEGER,iconn)* &
2211) rich_auxvars(ghosted_id)%dden_dp*FMWH2O
2212) case(WELL_SS) ! production well, SK 12/19/13
2213) ! if node pessure is lower than the given extraction pressure, shut it down
2214) ! well parameter explanation
2215) ! 1. well status. 1 injection; -1 production; 0 shut in!
2216) ! 2. well factor [m^3], the effective permeability [m^2/s]
2217) ! 3. bottomhole pressure: [Pa]
2218) ! 4. max pressure: [Pa]
2219) ! 5. min pressure: [Pa]
2220) mmsrc => source_sink%flow_condition%well%dataset%rarray
2221)
2222) well_status = mmsrc(1)
2223) well_factor = mmsrc(2)
2224) pressure_bh = mmsrc(3)
2225) pressure_max = mmsrc(4)
2226) pressure_min = mmsrc(5)
2227)
2228) ! production well (well status = -1)
2229) if (dabs(well_status + 1.D0) < 1.D-1) then
2230) if (global_auxvars(ghosted_id)%pres(1) > pressure_min) then
2231) Dq = well_factor
2232) dphi = global_auxvars(ghosted_id)%pres(1) - pressure_bh
2233) if (dphi >= 0.D0) then ! outflow only
2234) ukvr = rich_auxvars(ghosted_id)%kvr
2235) if (ukvr < 1.e-20) ukvr = 0.D0
2236) v_darcy = 0.D0
2237) if (ukvr*Dq > floweps) then
2238) v_darcy = Dq * ukvr * dphi
2239) ! store volumetric rate for ss_fluid_fluxes()
2240) Jup(1,1) = -1.d0*(-Dq*rich_auxvars(ghosted_id)%dkvr_dp*dphi* &
2241) global_auxvars(ghosted_id)%den(1) &
2242) -Dq*ukvr*1.d0*global_auxvars(ghosted_id)%den(1) &
2243) -Dq*ukvr*dphi*rich_auxvars(ghosted_id)%dden_dp)
2244) endif
2245) endif
2246) endif
2247) endif
2248) end select
2249) #ifdef BUFFER_MATRIX
2250) if (option%use_matrix_buffer) then
2251) call MatrixBufferAdd(patch%aux%Richards%matrix_buffer,ghosted_id, &
2252) ghosted_id,Jup(1,1))
2253) else
2254) #endif
2255) istart = (ghosted_id-1)*option%nflowdof + 1
2256)
2257) call MatSetValuesLocal(A,1,istart-1,1,istart-1,Jup,ADD_VALUES, &
2258) ierr);CHKERRQ(ierr)
2259) #ifdef BUFFER_MATRIX
2260) endif
2261) #endif
2262) enddo
2263) source_sink => source_sink%next
2264) enddo
2265)
2266) call RichardsSSSandbox(null_vec,A,PETSC_TRUE,grid,material_auxvars, &
2267) global_auxvars,rich_auxvars,option)
2268)
2269) if (realization%debug%matview_Jacobian_detailed) then
2270) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2271) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2272) string = 'jacobian_srcsink'
2273) call DebugCreateViewer(realization%debug,string,option,viewer)
2274) call MatView(A,viewer,ierr);CHKERRQ(ierr)
2275) call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
2276) endif
2277)
2278) #ifdef BUFFER_MATRIX
2279) if (option%use_matrix_buffer) then
2280) if (patch%aux%Richards%inactive_cells_exist) then
2281) call MatrixBufferZeroRows(patch%aux%Richards%matrix_buffer, &
2282) patch%aux%Richards%n_zero_rows, &
2283) patch%aux%Richards%zero_rows_local_ghosted)
2284) endif
2285) call MatrixBufferSetValues(A,patch%aux%Richards%matrix_buffer)
2286) endif
2287) #endif
2288)
2289) call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2290) call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
2291)
2292) ! zero out isothermal and inactive cells
2293) #ifdef BUFFER_MATRIX
2294) if (.not.option%use_matrix_buffer) then
2295) #endif
2296) if (patch%aux%Richards%inactive_cells_exist) then
2297) qsrc = 1.d0 ! solely a temporary variable in this conditional
2298) call MatZeroRowsLocal(A,patch%aux%Richards%n_zero_rows, &
2299) patch%aux%Richards%zero_rows_local_ghosted, &
2300) qsrc,PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
2301) ierr);CHKERRQ(ierr)
2302) endif
2303) #ifdef BUFFER_MATRIX
2304) endif
2305) #endif
2306)
2307) end subroutine RichardsJacobianSourceSink
2308)
2309) ! ************************************************************************** !
2310)
2311) subroutine RichardsMaxChange(realization,dpmax)
2312) !
2313) ! Computes the maximum change in the solution vector
2314) !
2315) ! Author: Glenn Hammond
2316) ! Date: 01/15/08
2317) !
2318)
2319) use Realization_Base_class
2320) use Option_module
2321) use Field_module
2322)
2323) implicit none
2324)
2325) class(realization_base_type) :: realization
2326)
2327) type(option_type), pointer :: option
2328) type(field_type), pointer :: field
2329) PetscReal :: dpmax
2330)
2331) PetscErrorCode :: ierr
2332) PetscViewer :: viewer
2333)
2334) option => realization%option
2335) field => realization%field
2336)
2337) dpmax = 0.d0
2338) call VecWAXPY(field%flow_dxx,-1.d0,field%flow_xx,field%flow_yy, &
2339) ierr);CHKERRQ(ierr)
2340) call VecStrideNorm(field%flow_dxx,ZERO_INTEGER,NORM_INFINITY, &
2341) dpmax,ierr);CHKERRQ(ierr)
2342)
2343) end subroutine RichardsMaxChange
2344)
2345) ! ************************************************************************** !
2346)
2347) subroutine RichardsSetPlotVariables(list)
2348) !
2349) ! Adds variables to be printed to list
2350) !
2351) ! Author: Glenn Hammond
2352) ! Date: 10/15/12
2353) !
2354)
2355) use Output_Aux_module
2356) use Variables_module
2357)
2358) implicit none
2359)
2360) type(output_variable_list_type), pointer :: list
2361)
2362) character(len=MAXWORDLENGTH) :: name, units
2363)
2364) if (associated(list%first)) then
2365) return
2366) endif
2367)
2368) name = 'Liquid Pressure'
2369) units = 'Pa'
2370) call OutputVariableAddToList(list,name,OUTPUT_PRESSURE,units, &
2371) LIQUID_PRESSURE)
2372)
2373) name = 'Liquid Saturation'
2374) units = ''
2375) call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
2376) LIQUID_SATURATION)
2377)
2378) end subroutine RichardsSetPlotVariables
2379)
2380) ! ************************************************************************** !
2381)
2382) subroutine RichardsPrintAuxVars(richards_auxvar,global_auxvar,cell_id)
2383) !
2384) ! Prints out the contents of an auxvar
2385) !
2386) ! Author: Glenn Hammond
2387) ! Date: 02/21/12
2388) !
2389)
2390) use Global_Aux_module
2391)
2392) implicit none
2393)
2394) type(richards_auxvar_type) :: richards_auxvar
2395) type(global_auxvar_type) :: global_auxvar
2396) PetscInt :: cell_id
2397)
2398) print *, ' cell: ', cell_id
2399) print *, ' pressure: ', global_auxvar%pres(1)
2400) print *, 'saturation: ', global_auxvar%sat(1)
2401) print *, ' density: ', global_auxvar%den_kg(1)
2402) print *, ' pc: ', richards_auxvar%pc
2403) print *, ' kvr: ', richards_auxvar%kvr
2404) print *, ' dkvr_dp: ', richards_auxvar%dkvr_dp
2405) print *, ' dsat_dp: ', richards_auxvar%dsat_dp
2406) print *, ' dden_dp: ', richards_auxvar%dden_dp
2407)
2408) end subroutine RichardsPrintAuxVars
2409)
2410) ! ************************************************************************** !
2411)
2412) subroutine RichardsUpdateSurfacePress(realization)
2413) !
2414) ! This routine updates the boundary pressure condition corresponding on
2415) ! the top surface of the subsurface domain accounting for the amount of
2416) ! infilitration/exfiltration in the previous subsurface timestep.
2417) !
2418) ! Author: Gautam Bisht, LBNL
2419) ! Date: 07/31/13
2420) !
2421)
2422) use Realization_Subsurface_class
2423) use Patch_module
2424) use Option_module
2425) use Field_module
2426) use Grid_module
2427) use Coupler_module
2428) use Connection_module
2429) use Material_module
2430) use Logging_module
2431) use String_module
2432) use EOS_Water_module
2433)
2434) implicit none
2435)
2436) type(realization_subsurface_type) :: realization
2437)
2438) type(option_type), pointer :: option
2439) type(patch_type), pointer :: patch
2440) type(grid_type), pointer :: grid
2441) type(coupler_type), pointer :: boundary_condition
2442) type(connection_set_type), pointer :: cur_connection_set
2443) type(richards_auxvar_type), pointer :: rich_auxvars_bc(:)
2444) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
2445) PetscInt :: ghosted_id
2446) PetscInt :: local_id
2447) PetscInt :: sum_connection
2448) PetscInt :: iconn
2449) PetscReal :: den
2450) PetscReal :: dum1
2451) PetscReal :: surfpress_old
2452) PetscReal :: surfpress_new
2453) PetscErrorCode :: ierr
2454)
2455) option => realization%option
2456) patch => realization%patch
2457) grid => patch%grid
2458)
2459) rich_auxvars_bc => patch%aux%Richards%auxvars_bc
2460) global_auxvars_bc => patch%aux%Global%auxvars_bc
2461)
2462) call EOSWaterdensity(option%reference_temperature, &
2463) option%reference_pressure,den,dum1,ierr)
2464)
2465) ! boundary conditions
2466) boundary_condition => patch%boundary_condition_list%first
2467) sum_connection = 0
2468) do
2469) if (.not.associated(boundary_condition)) exit
2470) cur_connection_set => boundary_condition%connection_set
2471) if (StringCompare(boundary_condition%name,'from_surface_bc')) then
2472)
2473) if (boundary_condition%flow_condition%itype(RICHARDS_PRESSURE_DOF) /= &
2474) HET_SURF_SEEPAGE_BC) then
2475) call printErrMsg(option,'from_surface_bc is not of type ' // &
2476) 'HET_SURF_SEEPAGE_BC')
2477) endif
2478)
2479) do iconn = 1, cur_connection_set%num_connections
2480) sum_connection = sum_connection + 1
2481) local_id = cur_connection_set%id_dn(iconn)
2482) ghosted_id = grid%nL2G(local_id)
2483)
2484) surfpress_old = &
2485) boundary_condition%flow_aux_real_var(RICHARDS_PRESSURE_DOF,iconn)
2486)
2487) surfpress_new = surfpress_old - &
2488) patch%boundary_velocities(1,sum_connection)*option%flow_dt* &
2489) (abs(option%gravity(3)))*den
2490)
2491) surfpress_new = max(surfpress_new,option%reference_pressure)
2492)
2493) boundary_condition%flow_aux_real_var(RICHARDS_PRESSURE_DOF,iconn) = &
2494) surfpress_new
2495) enddo
2496)
2497) else
2498) sum_connection = sum_connection + cur_connection_set%num_connections
2499) endif
2500)
2501) boundary_condition => boundary_condition%next
2502)
2503) enddo
2504)
2505) end subroutine RichardsUpdateSurfacePress
2506)
2507) ! ************************************************************************** !
2508)
2509) subroutine RichardsComputeCoeffsForSurfFlux(realization)
2510) !
2511) ! This routine computes coefficients for approximation boundary darcy
2512) ! flux between surface and subsurface domains.
2513) !
2514) ! Author: Gautam Bisht, LBNL
2515) ! Date: 05/21/14
2516) !
2517)
2518) use Realization_Subsurface_class
2519) use Patch_module
2520) use Option_module
2521) use Field_module
2522) use Grid_module
2523) use Coupler_module
2524) use Connection_module
2525) use Material_module
2526) use Logging_module
2527) use String_module
2528) use EOS_Water_module
2529) use Material_Aux_class
2530) use Utility_module
2531)
2532) implicit none
2533)
2534) type(realization_subsurface_type) :: realization
2535)
2536) type(option_type), pointer :: option
2537) type(patch_type), pointer :: patch
2538) type(grid_type), pointer :: grid
2539) type(coupler_type), pointer :: boundary_condition
2540) type(connection_set_type), pointer :: cur_connection_set
2541) type(richards_auxvar_type), pointer :: rich_auxvars_bc(:)
2542) type(richards_auxvar_type), pointer :: rich_auxvars(:)
2543) type(global_auxvar_type), pointer :: global_auxvars_bc(:)
2544) type(global_auxvar_type), pointer :: global_auxvars(:)
2545) type(material_parameter_type), pointer :: material_parameter
2546) type(richards_auxvar_type) :: rich_auxvar_max
2547) type(global_auxvar_type) :: global_auxvar_max
2548) type(richards_auxvar_type),pointer :: rich_auxvar_up, rich_auxvar_dn
2549) type(global_auxvar_type) :: global_auxvar_up, global_auxvar_dn
2550) class(material_auxvar_type), pointer :: material_auxvars(:)
2551) class(material_auxvar_type), pointer :: material_auxvar_dn
2552)
2553) PetscInt :: pressure_bc_type
2554) PetscInt :: ghosted_id
2555) PetscInt :: local_id
2556) PetscInt :: sum_connection
2557) PetscInt :: iconn
2558) PetscInt :: icap_dn
2559)
2560) PetscReal :: den
2561) PetscReal :: dum1
2562) PetscReal :: dist_gravity ! distance along gravity vector
2563) PetscReal :: dist(-1:3)
2564) PetscReal :: upweight,gravity,dphi
2565) PetscReal :: ukvr,Dq
2566) PetscReal :: P_allowable
2567) PetscReal :: sir_dn
2568) PetscReal :: v_darcy_allowable,v_darcy
2569) PetscReal :: q
2570) PetscReal :: q_allowable
2571) PetscReal :: dq_dp_dn
2572) PetscReal :: P_max,P_min,dP
2573) PetscReal :: density_ave
2574) PetscReal :: dgravity_dden_dn
2575) PetscReal :: dukvr_dp_dn
2576) PetscReal :: dphi_dp_dn
2577) PetscReal :: perm_dn
2578) PetscReal :: area
2579) PetscReal :: slope
2580) PetscReal :: xxbc(realization%option%nflowdof)
2581) PetscReal, pointer :: xx_p(:)
2582)
2583) PetscErrorCode :: ierr
2584)
2585) option => realization%option
2586) patch => realization%patch
2587) grid => patch%grid
2588)
2589) material_parameter => patch%aux%Material%material_parameter
2590) material_auxvars => patch%aux%Material%auxvars
2591)
2592) rich_auxvars => patch%aux%Richards%auxvars
2593) rich_auxvars_bc => patch%aux%Richards%auxvars_bc
2594) global_auxvars => patch%aux%Global%auxvars
2595) global_auxvars_bc => patch%aux%Global%auxvars_bc
2596)
2597) ! Distance away from allowable pressure at which cubic approximation begins
2598) dP = 10.d0 ! [Pa]
2599)
2600) call EOSWaterdensity(option%reference_temperature, &
2601) option%reference_pressure,den,dum1,ierr)
2602)
2603) call VecGetArrayReadF90(realization%field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
2604)
2605) ! boundary conditions
2606) boundary_condition => patch%boundary_condition_list%first
2607) sum_connection = 0
2608) do
2609) if (.not.associated(boundary_condition)) exit
2610) cur_connection_set => boundary_condition%connection_set
2611) if (StringCompare(boundary_condition%name,'from_surface_bc')) then
2612)
2613) pressure_bc_type = boundary_condition%flow_condition%itype(RICHARDS_PRESSURE_DOF)
2614)
2615) if (pressure_bc_type /= HET_SURF_SEEPAGE_BC) then
2616) call printErrMsg(option,'from_surface_bc is not of type ' // &
2617) 'HET_SURF_SEEPAGE_BC')
2618) endif
2619)
2620) do iconn = 1, cur_connection_set%num_connections
2621)
2622) sum_connection = sum_connection + 1
2623) local_id = cur_connection_set%id_dn(iconn)
2624) ghosted_id = grid%nL2G(local_id)
2625)
2626) rich_auxvar_up => rich_auxvars_bc(sum_connection)
2627) rich_auxvar_dn => rich_auxvars(ghosted_id)
2628)
2629) if (xx_p(ghosted_id) > 101000.d0) then
2630) rich_auxvar_dn%vars_for_sflow(11) = 1.d0
2631) else
2632) rich_auxvar_dn%vars_for_sflow(11) = 0.d0
2633) endif
2634)
2635) ! Step-1: Find P_max/P_min for polynomial curve
2636)
2637) global_auxvar_up = global_auxvars_bc(sum_connection)
2638) global_auxvar_dn = global_auxvars(ghosted_id)
2639)
2640) material_auxvar_dn => material_auxvars(ghosted_id)
2641)
2642) rich_auxvar_dn%vars_for_sflow(3:6) = -99999.d0
2643)
2644) dist = cur_connection_set%dist(:,iconn)
2645)
2646) call material_auxvar_dn%PermeabilityTensorToScalar(dist,perm_dn)
2647)
2648) dist_gravity = dist(0) * dot_product(option%gravity,dist(1:3))
2649) Dq = perm_dn / dist(0)
2650) area = cur_connection_set%area(iconn)
2651)
2652) v_darcy_allowable = (global_auxvar_up%pres(1) - option%reference_pressure)/ &
2653) option%flow_dt/(-option%gravity(3))/den
2654) q_allowable = v_darcy_allowable*area
2655) gravity = den * dist_gravity
2656)
2657) dphi = global_auxvar_up%pres(1) - global_auxvar_dn%pres(1) + gravity
2658) if (dphi>=0.D0) then
2659) ukvr = rich_auxvar_up%kvr
2660) else
2661) ukvr = rich_auxvar_dn%kvr
2662) endif
2663)
2664) P_allowable = global_auxvar_up%pres(1) + gravity - v_darcy_allowable/Dq/ukvr
2665)
2666) P_max = P_allowable + dP
2667) !P_max = global_auxvar_up%pres(1) + gravity
2668) P_min = P_allowable! - dP
2669)
2670)
2671) ! Step-2: Find derivative at P_max
2672) icap_dn = patch%sat_func_id(ghosted_id)
2673)
2674) xxbc(1) = P_max
2675)
2676) call GlobalAuxVarInit(global_auxvar_max,option)
2677) call RichardsAuxVarInit(rich_auxvar_max,option)
2678) call RichardsAuxVarCompute(xxbc,rich_auxvar_max, &
2679) global_auxvar_max, &
2680) material_auxvars(ghosted_id), &
2681) patch%characteristic_curves_array(icap_dn)%ptr, &
2682) option)
2683)
2684) sir_dn = material_parameter%soil_residual_saturation(1,icap_dn)
2685)
2686) if (global_auxvar_up%sat(1) > sir_dn .or. global_auxvar_max%sat(1) > sir_dn) then
2687)
2688) upweight=1.D0
2689) if (global_auxvar_up%sat(1) < eps) then
2690) upweight=0.d0
2691) else if (global_auxvar_max%sat(1) < eps) then
2692) upweight=1.d0
2693) endif
2694)
2695) density_ave = upweight*global_auxvar_up%den(1)+(1.D0-upweight)*global_auxvar_max%den(1)
2696)
2697) gravity = (upweight* global_auxvar_up%den(1) + &
2698) (1.D0-upweight)*global_auxvar_max%den(1)) &
2699) * FMWH2O * dist_gravity
2700) dgravity_dden_dn = (1.d0-upweight)*FMWH2O*dist_gravity
2701)
2702) dphi = global_auxvar_up%pres(1) - global_auxvar_max%pres(1) + gravity
2703) dphi_dp_dn = -1.d0 + dgravity_dden_dn*rich_auxvar_max%dden_dp
2704)
2705) if (pressure_bc_type == HET_SURF_SEEPAGE_BC) then
2706) ! flow in ! boundary cell is <= pref
2707) if (dphi > 0.d0 .and. global_auxvar_up%pres(1)-option%reference_pressure < eps) then
2708) dphi = 0.d0
2709) dphi_dp_dn = 0.d0
2710) endif
2711) endif
2712)
2713) if (dphi>=0.D0) then
2714) ukvr = rich_auxvar_up%kvr
2715) dukvr_dp_dn = 0.d0
2716) else
2717) ukvr = rich_auxvar_max%kvr
2718) dukvr_dp_dn = rich_auxvar_max%dkvr_dp
2719) endif
2720)
2721) if (ukvr*Dq>floweps) then
2722)
2723) v_darcy = Dq * ukvr * dphi
2724) q = v_darcy*area
2725)
2726) dq_dp_dn = Dq*(dukvr_dp_dn*dphi + ukvr*dphi_dp_dn)*area
2727)
2728) ! Values of function at min/max
2729) rich_auxvar_dn%vars_for_sflow(3) = 0.99d0*q_allowable
2730) rich_auxvar_dn%vars_for_sflow(4) = q
2731)
2732) ! Values of function derivatives at min/max
2733) slope = min(-0.01d0*q_allowable/P_min, -1.d-8)
2734) slope = -0.01d0*q_allowable/P_min
2735)
2736) rich_auxvar_dn%vars_for_sflow(5) = slope
2737) rich_auxvar_dn%vars_for_sflow(6) = dq_dp_dn
2738)
2739) rich_auxvar_dn%vars_for_sflow(1) = P_min
2740) rich_auxvar_dn%vars_for_sflow(2) = P_max
2741)
2742) call CubicPolynomialSetup(P_min - option%reference_pressure, &
2743) P_max - option%reference_pressure, &
2744) rich_auxvar_dn%vars_for_sflow(3:6))
2745)
2746) ! Step-4: Save values for linear approximation
2747) rich_auxvar_dn%vars_for_sflow(7) = 0.01d0*q_allowable/slope + P_min
2748) if (q_allowable == 0.d0) then
2749) rich_auxvar_dn%vars_for_sflow(7) = 0.d0
2750) else
2751) rich_auxvar_dn%vars_for_sflow(7) = P_min + 0.01d0*q_allowable/slope
2752) endif
2753) rich_auxvar_dn%vars_for_sflow(8) = P_min
2754) rich_auxvar_dn%vars_for_sflow(9) = q_allowable
2755) rich_auxvar_dn%vars_for_sflow(10) = 0.99d0*q_allowable
2756)
2757) endif
2758)
2759) endif
2760) enddo
2761)
2762) else
2763)
2764) sum_connection = sum_connection + cur_connection_set%num_connections
2765)
2766) endif
2767)
2768) boundary_condition => boundary_condition%next
2769)
2770) enddo
2771) call VecRestoreArrayReadF90(realization%field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
2772)
2773) end subroutine RichardsComputeCoeffsForSurfFlux
2774)
2775) ! ************************************************************************** !
2776)
2777) subroutine RichardsSSSandbox(residual,Jacobian,compute_derivative, &
2778) grid,material_auxvars,global_auxvars,rich_auxvars,option)
2779) !
2780) ! Evaluates source/sink term storing residual and/or Jacobian
2781) !
2782) ! Author: Guoping Tang
2783) ! Date: 06/03/14
2784) !
2785) ! Modified by: Ayman Alzraiee on 04/05/2016
2786)
2787) use Option_module
2788) use Grid_module
2789) use Material_Aux_class, only: material_auxvar_type
2790) use SrcSink_Sandbox_module
2791) use SrcSink_Sandbox_Base_class
2792)
2793) implicit none
2794)
2795) #include "petsc/finclude/petscvec.h"
2796) #include "petsc/finclude/petscvec.h90"
2797) #include "petsc/finclude/petscmat.h"
2798) #include "petsc/finclude/petscmat.h90"
2799)
2800) PetscBool :: compute_derivative
2801) Vec :: residual
2802) Mat :: Jacobian
2803) class(material_auxvar_type), pointer :: material_auxvars(:)
2804) type(global_auxvar_type), pointer :: global_auxvars(:)
2805) type(richards_auxvar_type), pointer :: rich_auxvars(:)
2806) type(grid_type) :: grid
2807) type(option_type) :: option
2808)
2809) PetscReal, pointer :: r_p(:)
2810) PetscReal :: res(option%nflowdof)
2811) PetscReal :: Jac(option%nflowdof,option%nflowdof)
2812) class(srcsink_sandbox_base_type), pointer :: cur_srcsink
2813) PetscInt :: local_id, ghosted_id, istart, iend
2814) PetscReal :: aux_real(10)
2815) PetscErrorCode :: ierr
2816)
2817) if (.not.compute_derivative) then
2818) call VecGetArrayF90(residual,r_p,ierr);CHKERRQ(ierr)
2819) endif
2820)
2821) cur_srcsink => ss_sandbox_list
2822) do
2823) if (.not.associated(cur_srcsink)) exit
2824) aux_real = 0.d0
2825) local_id = cur_srcsink%local_cell_id
2826) ghosted_id = grid%nL2G(local_id)
2827) res = 0.d0
2828) Jac = 0.d0
2829) call RichardsSSSandboxLoadAuxReal(cur_srcsink,aux_real, &
2830) global_auxvars(ghosted_id),rich_auxvars(ghosted_id),option)
2831) call cur_srcsink%Evaluate(res,Jac,PETSC_FALSE, &
2832) material_auxvars(ghosted_id), &
2833) aux_real,option)
2834) if (compute_derivative) then
2835) call RichardsSSSandboxLoadAuxReal(cur_srcsink,aux_real, &
2836) global_auxvars(ghosted_id),rich_auxvars(ghosted_id),option)
2837) call cur_srcsink%Evaluate(res,Jac,PETSC_TRUE, &
2838) material_auxvars(ghosted_id), &
2839) aux_real,option)
2840) call MatSetValuesBlockedLocal(Jacobian,1,ghosted_id-1,1, &
2841) ghosted_id-1,Jac,ADD_VALUES, &
2842) ierr);CHKERRQ(ierr)
2843) else
2844) iend = local_id*option%nflowdof
2845) istart = iend - option%nflowdof + 1
2846) r_p(istart:iend) = r_p(istart:iend) - res
2847) endif
2848) cur_srcsink => cur_srcsink%next
2849) enddo
2850)
2851) if (.not.compute_derivative) then
2852) call VecRestoreArrayF90(residual,r_p,ierr);CHKERRQ(ierr)
2853) endif
2854)
2855) end subroutine RichardsSSSandbox
2856)
2857) ! ************************************************************************** !
2858)
2859) subroutine RichardsSSSandboxLoadAuxReal(srcsink,aux_real,global_auxvar,rich_auxvars,option)
2860) ! Modified by: Ayman Alzraiee on 04/05/2016
2861) use Option_module
2862) use SrcSink_Sandbox_Base_class
2863) use SrcSink_Sandbox_Downreg_class
2864)
2865) implicit none
2866)
2867) class(srcsink_sandbox_base_type) :: srcsink
2868) PetscReal :: aux_real(:)
2869) type(global_auxvar_type) :: global_auxvar
2870) type(richards_auxvar_type) :: rich_auxvars
2871) type(option_type) :: option
2872)
2873) aux_real = 0.d0
2874)
2875) !select type(srcsink)
2876) ! class is(srcsink_sandbox_downreg_type)
2877) aux_real(1) = rich_auxvars%kvr ! fluid mobility
2878) aux_real(3) = global_auxvar%pres(1)
2879) aux_real(9) = global_auxvar%den(1)
2880) !end select
2881)
2882) end subroutine RichardsSSSandboxLoadAuxReal
2883)
2884) ! ************************************************************************** !
2885)
2886) subroutine RichardsComputeLateralMassFlux(realization)
2887) !
2888) ! Computes lateral flux source/sink term when QUASI_3D is true
2889) !
2890) ! Author: Gautam Bisht, LBNL
2891) ! Date: 03/09/2016
2892) !
2893)
2894) use Connection_module
2895) use Realization_Subsurface_class
2896) use Field_module
2897)
2898) implicit none
2899)
2900) type(realization_subsurface_type) :: realization
2901) type(field_type), pointer :: field
2902) PetscErrorCode :: ierr
2903)
2904) field => realization%field
2905)
2906) call RichardsUpdateLocalVecs(field%flow_xx, realization, ierr)
2907)
2908) call RichardsUpdateAuxVarsPatch(realization)
2909)
2910) call VecZeroEntries(field%flow_mass_transfer, ierr); CHKERRQ(ierr)
2911)
2912) call RichardsResidualInternalConn(field%flow_mass_transfer, &
2913) realization, VERT_CONN, ierr)
2914)
2915) call VecScale(field%flow_mass_transfer, -1.d0, ierr); CHKERRQ(ierr)
2916)
2917) end subroutine RichardsComputeLateralMassFlux
2918)
2919) ! ************************************************************************** !
2920)
2921) function skip_conn(dist,skip_conn_type)
2922) !
2923) ! Returns if a connection should be skipped depending on the skip_conn_type
2924) !
2925) ! Author: Gautam Bisht, LBNL
2926) ! Date: 03/10/2016
2927) !
2928)
2929) implicit none
2930)
2931) PetscReal :: dist(1:3)
2932) PetscInt :: skip_conn_type
2933)
2934) PetscBool :: skip_conn
2935) PetscBool :: is_conn_vertical
2936)
2937) skip_conn = PETSC_FALSE
2938)
2939) is_conn_vertical = (abs(dot_product(dist(1:3),unit_z)) < 0.99d0)
2940)
2941) select case(skip_conn_type)
2942) case (HORZ_CONN)
2943) if (is_conn_vertical) skip_conn = PETSC_TRUE
2944) case (VERT_CONN)
2945) if (.not.is_conn_vertical) skip_conn = PETSC_TRUE
2946) end select
2947)
2948) end function skip_conn
2949)
2950) ! ************************************************************************** !
2951)
2952) subroutine RichardsDestroy(realization)
2953) !
2954) ! Deallocates variables associated with Richard
2955) !
2956) ! Author: Glenn Hammond
2957) ! Date: 02/14/08
2958) !
2959)
2960) use Realization_Subsurface_class
2961)
2962) implicit none
2963)
2964) type(realization_subsurface_type) :: realization
2965)
2966) call RichardsDestroyPatch(realization)
2967)
2968) end subroutine RichardsDestroy
2969)
2970) ! ************************************************************************** !
2971)
2972) subroutine RichardsDestroyPatch(realization)
2973) !
2974) ! Deallocates variables associated with Richard
2975) !
2976) ! Author: Glenn Hammond
2977) ! Date: 02/03/09
2978) !
2979)
2980) use Realization_Subsurface_class
2981)
2982) implicit none
2983)
2984) type(realization_subsurface_type) :: realization
2985)
2986) ! taken care of in auxiliary.F90
2987)
2988) end subroutine RichardsDestroyPatch
2989)
2990) end module Richards_module