pm_richards.F90 coverage: 76.47 %func 43.53 %block
1) module PM_Richards_class
2)
3) use PM_Base_class
4) use PM_Subsurface_Flow_class
5)
6) use PFLOTRAN_Constants_module
7)
8) implicit none
9)
10) private
11)
12) #include "petsc/finclude/petscsys.h"
13)
14) #include "petsc/finclude/petscvec.h"
15) #include "petsc/finclude/petscvec.h90"
16) #include "petsc/finclude/petscmat.h"
17) #include "petsc/finclude/petscmat.h90"
18) #include "petsc/finclude/petscsnes.h"
19)
20) type, public, extends(pm_subsurface_flow_type) :: pm_richards_type
21) contains
22) procedure, public :: Read => PMRichardsRead
23) procedure, public :: InitializeTimestep => PMRichardsInitializeTimestep
24) procedure, public :: Residual => PMRichardsResidual
25) procedure, public :: Jacobian => PMRichardsJacobian
26) procedure, public :: UpdateTimestep => PMRichardsUpdateTimestep
27) procedure, public :: PreSolve => PMRichardsPreSolve
28) procedure, public :: PostSolve => PMRichardsPostSolve
29) procedure, public :: CheckUpdatePre => PMRichardsCheckUpdatePre
30) procedure, public :: CheckUpdatePost => PMRichardsCheckUpdatePost
31) procedure, public :: TimeCut => PMRichardsTimeCut
32) procedure, public :: UpdateSolution => PMRichardsUpdateSolution
33) procedure, public :: UpdateAuxVars => PMRichardsUpdateAuxVars
34) procedure, public :: MaxChange => PMRichardsMaxChange
35) procedure, public :: ComputeMassBalance => PMRichardsComputeMassBalance
36) procedure, public :: InputRecord => PMRichardsInputRecord
37) procedure, public :: Destroy => PMRichardsDestroy
38) end type pm_richards_type
39)
40) public :: PMRichardsCreate
41)
42) contains
43)
44) ! ************************************************************************** !
45)
46) function PMRichardsCreate()
47) !
48) ! Creates Richards process models shell
49) !
50) ! Author: Glenn Hammond
51) ! Date: 03/14/13
52) !
53)
54) implicit none
55)
56) class(pm_richards_type), pointer :: PMRichardsCreate
57)
58) class(pm_richards_type), pointer :: richards_pm
59)
60) allocate(richards_pm)
61) call PMSubsurfaceFlowCreate(richards_pm)
62) richards_pm%name = 'PMRichards'
63)
64) PMRichardsCreate => richards_pm
65)
66) end function PMRichardsCreate
67)
68) ! ************************************************************************** !
69)
70) subroutine PMRichardsRead(this,input)
71) !
72) ! Reads input file parameters associated with the Richards process model
73) !
74) ! Author: Glenn Hammond
75) ! Date: 01/29/15
76) use Input_Aux_module
77) use String_module
78) use Utility_module
79) use EOS_Water_module
80) use Option_module
81) use Richards_Aux_module
82)
83) implicit none
84)
85) class(pm_richards_type) :: this
86) type(input_type), pointer :: input
87)
88) character(len=MAXWORDLENGTH) :: word
89) character(len=MAXSTRINGLENGTH) :: error_string
90) type(option_type), pointer :: option
91) PetscBool :: found
92)
93) option => this%option
94)
95) error_string = 'Richards Options'
96)
97) input%ierr = 0
98) do
99)
100) call InputReadPflotranString(input,option)
101) if (InputError(input)) exit
102) if (InputCheckExit(input,option)) exit
103)
104) call InputReadWord(input,option,word,PETSC_TRUE)
105) call InputErrorMsg(input,option,'keyword',error_string)
106) call StringToUpper(word)
107)
108) found = PETSC_FALSE
109) call PMSubsurfaceFlowReadSelectCase(this,input,word,found,option)
110) if (found) cycle
111)
112) select case(trim(word))
113) case('ITOL_SCALED_RESIDUAL')
114) call InputReadDouble(input,option,richards_itol_scaled_res)
115) call InputDefaultMsg(input,option,'itol_scaled_residual')
116) this%check_post_convergence = PETSC_TRUE
117) case('ITOL_RELATIVE_UPDATE')
118) call InputReadDouble(input,option,richards_itol_rel_update)
119) call InputDefaultMsg(input,option,'richards_itol_rel_update')
120) this%check_post_convergence = PETSC_TRUE
121) case default
122) call InputKeywordUnrecognized(word,error_string,option)
123) end select
124) enddo
125)
126) end subroutine PMRichardsRead
127)
128) ! ************************************************************************** !
129)
130) subroutine PMRichardsInitializeTimestep(this)
131) !
132) ! Should not need this as it is called in PreSolve.
133) !
134) ! Author: Glenn Hammond
135) ! Date: 03/14/13
136) !
137)
138) use Richards_module, only : RichardsInitializeTimestep
139)
140) implicit none
141)
142) class(pm_richards_type) :: this
143)
144) call PMSubsurfaceFlowInitializeTimestepA(this)
145)
146) if (this%option%print_screen_flag) then
147) write(*,'(/,2("=")," RICHARDS FLOW ",63("="))')
148) endif
149)
150) call RichardsInitializeTimestep(this%realization)
151) call PMSubsurfaceFlowInitializeTimestepB(this)
152)
153) end subroutine PMRichardsInitializeTimestep
154)
155) ! ************************************************************************** !
156)
157) subroutine PMRichardsPreSolve(this)
158) !
159) ! Author: Glenn Hammond
160) ! Date: 03/14/13
161)
162) implicit none
163)
164) class(pm_richards_type) :: this
165)
166) end subroutine PMRichardsPreSolve
167)
168) ! ************************************************************************** !
169)
170) subroutine PMRichardsPostSolve(this)
171) !
172) ! Author: Glenn Hammond
173) ! Date: 03/14/13
174)
175) implicit none
176)
177) class(pm_richards_type) :: this
178)
179) end subroutine PMRichardsPostSolve
180)
181) ! ************************************************************************** !
182)
183) subroutine PMRichardsUpdateTimestep(this,dt,dt_min,dt_max,iacceleration, &
184) num_newton_iterations,tfac)
185) !
186) ! Author: Glenn Hammond
187) ! Date: 03/14/13
188) !
189)
190) implicit none
191)
192) class(pm_richards_type) :: this
193) PetscReal :: dt
194) PetscReal :: dt_min,dt_max
195) PetscInt :: iacceleration
196) PetscInt :: num_newton_iterations
197) PetscReal :: tfac(:)
198)
199) PetscReal :: fac
200) PetscReal :: ut
201) PetscReal :: up
202) PetscReal :: dtt
203) PetscReal :: dt_p
204) PetscReal :: dt_tfac
205) PetscInt :: ifac
206)
207) if (iacceleration > 0) then
208) fac = 0.5d0
209) if (num_newton_iterations >= iacceleration) then
210) fac = 0.33d0
211) ut = 0.d0
212) else
213) up = this%pressure_change_governor/(this%max_pressure_change+0.1)
214) ut = up
215) endif
216) dtt = fac * dt * (1.d0 + ut)
217) else
218) ifac = max(min(num_newton_iterations,size(tfac)),1)
219) dt_tfac = tfac(ifac) * dt
220)
221) fac = 0.5d0
222) up = this%pressure_change_governor/(this%max_pressure_change+0.1)
223) dt_p = fac * dt * (1.d0 + up)
224)
225) dtt = min(dt_tfac,dt_p)
226) endif
227)
228) if (dtt > 2.d0 * dt) dtt = 2.d0 * dt
229) if (dtt > dt_max) dtt = dt_max
230) ! geh: There used to be code here that cut the time step if it is too
231) ! large relative to the simulation time. This has been removed.
232) dtt = max(dtt,dt_min)
233) dt = dtt
234)
235) call PMSubsurfaceFlowLimitDTByCFL(this,dt)
236)
237) end subroutine PMRichardsUpdateTimestep
238)
239) ! ************************************************************************** !
240)
241) subroutine PMRichardsResidual(this,snes,xx,r,ierr)
242) !
243) ! Author: Glenn Hammond
244) ! Date: 03/14/13
245) !
246)
247) use Richards_module, only : RichardsResidual
248)
249) implicit none
250)
251) class(pm_richards_type) :: this
252) SNES :: snes
253) Vec :: xx
254) Vec :: r
255) PetscErrorCode :: ierr
256)
257) call PMSubsurfaceFlowUpdatePropertiesNI(this)
258) call RichardsResidual(snes,xx,r,this%realization,ierr)
259)
260) end subroutine PMRichardsResidual
261)
262) ! ************************************************************************** !
263)
264) subroutine PMRichardsJacobian(this,snes,xx,A,B,ierr)
265) !
266) ! Author: Glenn Hammond
267) ! Date: 03/14/13
268) !
269)
270) use Richards_module, only : RichardsJacobian
271)
272) implicit none
273)
274) class(pm_richards_type) :: this
275) SNES :: snes
276) Vec :: xx
277) Mat :: A, B
278) PetscErrorCode :: ierr
279)
280) call RichardsJacobian(snes,xx,A,B,this%realization,ierr)
281)
282) end subroutine PMRichardsJacobian
283)
284) ! ************************************************************************** !
285)
286) subroutine PMRichardsCheckUpdatePre(this,line_search,X,dX,changed,ierr)
287) !
288) ! Author: Glenn Hammond
289) ! Date: 03/14/13
290) !
291)
292) use Realization_Subsurface_class
293) use Grid_module
294) use Field_module
295) use Option_module
296) use Characteristic_Curves_module
297) use Patch_module
298) use Richards_Aux_module
299) use Global_Aux_module
300) use Patch_module
301)
302) implicit none
303)
304) class(pm_richards_type) :: this
305) SNESLineSearch :: line_search
306) Vec :: X
307) Vec :: dX
308) PetscBool :: changed
309) PetscErrorCode :: ierr
310)
311) PetscReal, pointer :: X_p(:)
312) PetscReal, pointer :: dX_p(:)
313) PetscReal, pointer :: r_p(:)
314) type(grid_type), pointer :: grid
315) type(option_type), pointer :: option
316) type(patch_type), pointer :: patch
317) type(field_type), pointer :: field
318) type(richards_auxvar_type), pointer :: rich_auxvars(:)
319) type(global_auxvar_type), pointer :: global_auxvars(:)
320) PetscInt :: local_id, ghosted_id
321) PetscReal :: P_R, P0, P1, delP
322) PetscReal :: scale, sat, sat_pert, pert, pc_pert, press_pert, delP_pert
323)
324) patch => this%realization%patch
325) grid => patch%grid
326) option => this%realization%option
327) field => this%realization%field
328) rich_auxvars => patch%aux%Richards%auxvars
329) global_auxvars => patch%aux%Global%auxvars
330)
331) if (Initialized(this%saturation_change_limit)) then
332)
333) changed = PETSC_TRUE
334)
335) call VecGetArrayF90(dX,dX_p,ierr);CHKERRQ(ierr)
336) call VecGetArrayF90(X,X_p,ierr);CHKERRQ(ierr)
337)
338) pert = dabs(this%saturation_change_limit)
339) do local_id = 1, grid%nlmax
340) ghosted_id = grid%nL2G(local_id)
341) sat = global_auxvars(ghosted_id)%sat(1)
342) sat_pert = sat - sign(1.d0,sat-0.5d0)*pert
343) call patch%characteristic_curves_array( &
344) patch%sat_func_id(ghosted_id))%ptr% &
345) saturation_function%CapillaryPressure(sat_pert,pc_pert,option)
346) press_pert = option%reference_pressure - pc_pert
347) P0 = X_p(local_id)
348) delP = dX_p(local_id)
349) delP_pert = dabs(P0 - press_pert)
350) if (delP_pert < dabs(delP)) then
351) write(option%io_buffer,'("dP_trunc:",1i7,2es15.7)') &
352) grid%nG2A(grid%nL2G(local_id)),delP_pert,dabs(delP)
353) call printMsgAnyRank(option)
354) endif
355) delP = sign(min(dabs(delP),delP_pert),delP)
356) dX_p(local_id) = delP
357) enddo
358)
359) call VecRestoreArrayF90(dX,dX_p,ierr);CHKERRQ(ierr)
360) call VecRestoreArrayF90(X,X_p,ierr);CHKERRQ(ierr)
361)
362) endif
363)
364) if (Initialized(this%pressure_dampening_factor)) then
365) changed = PETSC_TRUE
366) ! P^p+1 = P^p - dP^p
367) P_R = option%reference_pressure
368) scale = this%pressure_dampening_factor
369)
370) call VecGetArrayF90(dX,dX_p,ierr);CHKERRQ(ierr)
371) call VecGetArrayF90(X,X_p,ierr);CHKERRQ(ierr)
372) call VecGetArrayF90(field%flow_r,r_p,ierr);CHKERRQ(ierr)
373) do local_id = 1, grid%nlmax
374) delP = dX_p(local_id)
375) P0 = X_p(local_id)
376) P1 = P0 - delP
377) if (P0 < P_R .and. P1 > P_R) then
378) write(option%io_buffer,'("U -> S:",1i7,2f12.1)') &
379) grid%nG2A(grid%nL2G(local_id)),P0,P1
380) call printMsgAnyRank(option)
381) #if 0
382) ghosted_id = grid%nL2G(local_id)
383) call RichardsPrintAuxVars(rich_auxvars(ghosted_id), &
384) global_auxvars(ghosted_id),ghosted_id)
385) write(option%io_buffer,'("Residual:",es15.7)') r_p(local_id)
386) call printMsgAnyRank(option)
387) #endif
388) else if (P1 < P_R .and. P0 > P_R) then
389) write(option%io_buffer,'("S -> U:",1i7,2f12.1)') &
390) grid%nG2A(grid%nL2G(local_id)),P0,P1
391) call printMsgAnyRank(option)
392) #if 0
393) ghosted_id = grid%nL2G(local_id)
394) call RichardsPrintAuxVars(rich_auxvars(ghosted_id), &
395) global_auxvars(ghosted_id),ghosted_id)
396) write(option%io_buffer,'("Residual:",es15.7)') r_p(local_id)
397) call printMsgAnyRank(option)
398) #endif
399) endif
400) ! transition from unsaturated to saturated
401) if (P0 < P_R .and. P1 > P_R) then
402) dX_p(local_id) = scale*delP
403) endif
404) enddo
405) call VecRestoreArrayF90(dX,dX_p,ierr);CHKERRQ(ierr)
406) call VecRestoreArrayF90(X,X_p,ierr);CHKERRQ(ierr)
407) call VecGetArrayF90(field%flow_r,r_p,ierr);CHKERRQ(ierr)
408) endif
409)
410) end subroutine PMRichardsCheckUpdatePre
411)
412) ! ************************************************************************** !
413)
414) subroutine PMRichardsCheckUpdatePost(this,line_search,X0,dX,X1,dX_changed, &
415) X1_changed,ierr)
416) !
417) ! Author: Glenn Hammond
418) ! Date: 03/14/13
419) !
420) use Realization_Subsurface_class
421) use Grid_module
422) use Field_module
423) use Option_module
424) use Richards_Aux_module
425) use Global_Aux_module
426) use Material_Aux_class
427) use Patch_module
428) use Richards_Common_module
429)
430) implicit none
431)
432) class(pm_richards_type) :: this
433) SNESLineSearch :: line_search
434) Vec :: X0
435) Vec :: dX
436) Vec :: X1
437) PetscBool :: dX_changed
438) PetscBool :: X1_changed
439) PetscErrorCode :: ierr
440)
441) PetscReal, pointer :: X0_p(:)
442) PetscReal, pointer :: dX_p(:)
443) PetscReal, pointer :: r_p(:)
444) type(grid_type), pointer :: grid
445) type(option_type), pointer :: option
446) type(field_type), pointer :: field
447) type(patch_type), pointer :: patch
448) type(richards_auxvar_type), pointer :: rich_auxvars(:)
449) type(global_auxvar_type), pointer :: global_auxvars(:)
450) class(material_auxvar_type), pointer :: material_auxvars(:)
451) PetscInt :: local_id, ghosted_id
452) PetscInt :: istart
453) PetscReal :: Res(1)
454) PetscReal :: inf_norm, global_inf_norm
455)
456) patch => this%realization%patch
457) grid => patch%grid
458) option => this%realization%option
459) field => this%realization%field
460) rich_auxvars => patch%aux%Richards%auxvars
461) global_auxvars => patch%aux%Global%auxvars
462) material_auxvars => patch%aux%Material%auxvars
463)
464) dX_changed = PETSC_FALSE
465) X1_changed = PETSC_FALSE
466)
467) option%converged = PETSC_FALSE
468) if (this%check_post_convergence) then
469) call VecGetArrayF90(dX,dX_p,ierr);CHKERRQ(ierr)
470) call VecGetArrayF90(X0,X0_p,ierr);CHKERRQ(ierr)
471) call VecGetArrayF90(field%flow_r,r_p,ierr);CHKERRQ(ierr)
472)
473) inf_norm = 0.d0
474) do local_id = 1, grid%nlmax
475) ghosted_id = grid%nL2G(local_id)
476) istart = (local_id-1)*option%nflowdof + 1
477)
478) if (patch%imat(ghosted_id) <= 0) cycle
479)
480) call RichardsAccumulation(rich_auxvars(ghosted_id), &
481) global_auxvars(ghosted_id), &
482) material_auxvars(ghosted_id), &
483) option,Res)
484) inf_norm = max(inf_norm,min(dabs(dX_p(local_id)/X0_p(local_id)), &
485) dabs(r_p(istart)/Res(1))))
486) enddo
487) call MPI_Allreduce(inf_norm,global_inf_norm,ONE_INTEGER_MPI, &
488) MPI_DOUBLE_PRECISION, &
489) MPI_MAX,option%mycomm,ierr)
490) option%converged = PETSC_TRUE
491) if (global_inf_norm > richards_itol_scaled_res) &
492) option%converged = PETSC_FALSE
493) call VecRestoreArrayF90(dX,dX_p,ierr);CHKERRQ(ierr)
494) call VecRestoreArrayF90(X0,X0_p,ierr);CHKERRQ(ierr)
495) call VecGetArrayF90(field%flow_r,r_p,ierr);CHKERRQ(ierr)
496) endif
497)
498) end subroutine PMRichardsCheckUpdatePost
499)
500) ! ************************************************************************** !
501)
502) subroutine PMRichardsTimeCut(this)
503) !
504) ! Author: Glenn Hammond
505) ! Date: 03/14/13
506) !
507)
508) use Richards_module, only : RichardsTimeCut
509)
510) implicit none
511)
512) class(pm_richards_type) :: this
513)
514) call PMSubsurfaceFlowTimeCut(this)
515) call RichardsTimeCut(this%realization)
516)
517) end subroutine PMRichardsTimeCut
518)
519) ! ************************************************************************** !
520)
521) subroutine PMRichardsUpdateSolution(this)
522) !
523) ! Author: Glenn Hammond
524) ! Date: 03/14/13
525) !
526)
527) use Richards_module, only : RichardsUpdateSolution, &
528) RichardsUpdateSurfacePress
529)
530) implicit none
531)
532) class(pm_richards_type) :: this
533)
534) call PMSubsurfaceFlowUpdateSolution(this)
535) call RichardsUpdateSolution(this%realization)
536) if (this%option%surf_flow_on) &
537) call RichardsUpdateSurfacePress(this%realization)
538)
539) end subroutine PMRichardsUpdateSolution
540)
541) ! ************************************************************************** !
542)
543) subroutine PMRichardsUpdateAuxVars(this)
544) !
545) ! Author: Glenn Hammond
546) ! Date: 04/21/14
547)
548) use Richards_module, only : RichardsUpdateAuxVars
549)
550) implicit none
551)
552) class(pm_richards_type) :: this
553)
554) call RichardsUpdateAuxVars(this%realization)
555)
556) end subroutine PMRichardsUpdateAuxVars
557)
558) ! ************************************************************************** !
559)
560) subroutine PMRichardsMaxChange(this)
561) !
562) ! Not needed given RichardsMaxChange is called in PostSolve
563) !
564) ! Author: Glenn Hammond
565) ! Date: 03/14/13
566) !
567)
568) use Richards_module, only : RichardsMaxChange
569)
570) implicit none
571)
572) class(pm_richards_type) :: this
573)
574) call RichardsMaxChange(this%realization,this%max_pressure_change)
575) if (this%option%print_screen_flag) then
576) write(*,'(" --> max chng: dpmx= ",1pe12.4)') this%max_pressure_change
577) endif
578) if (this%option%print_file_flag) then
579) write(this%option%fid_out,'(" --> max chng: dpmx= ",1pe12.4)') &
580) this%max_pressure_change
581) endif
582)
583) end subroutine PMRichardsMaxChange
584)
585) ! ************************************************************************** !
586)
587) subroutine PMRichardsComputeMassBalance(this,mass_balance_array)
588) !
589) ! Author: Glenn Hammond
590) ! Date: 03/14/13
591) !
592)
593) use Richards_module, only : RichardsComputeMassBalance
594)
595) implicit none
596)
597) class(pm_richards_type) :: this
598) PetscReal :: mass_balance_array(:)
599)
600) call RichardsComputeMassBalance(this%realization,mass_balance_array)
601)
602) end subroutine PMRichardsComputeMassBalance
603)
604) ! ************************************************************************** !
605)
606) subroutine PMRichardsInputRecord(this)
607) !
608) ! Writes ingested information to the input record file.
609) !
610) ! Author: Jenn Frederick, SNL
611) ! Date: 03/21/2016
612) !
613)
614) implicit none
615)
616) class(pm_richards_type) :: this
617)
618) character(len=MAXWORDLENGTH) :: word
619) PetscInt :: id
620)
621) id = INPUT_RECORD_UNIT
622)
623) write(id,'(a29)',advance='no') 'pm: '
624) write(id,'(a)') this%name
625) write(id,'(a29)',advance='no') 'mode: '
626) write(id,'(a)') 'richards'
627) if (this%check_post_convergence) then
628) write(id,'(a29)',advance='no') 'ITOL_SCALED_RESIDUAL: '
629) write(id,'(a)') 'ON'
630) write(id,'(a29)',advance='no') 'ITOL_RELATIVE_UPDATE: '
631) write(id,'(a)') 'ON'
632) endif
633)
634) end subroutine PMRichardsInputRecord
635)
636) ! ************************************************************************** !
637)
638) subroutine PMRichardsDestroy(this)
639) !
640) ! Destroys Richards process model
641) !
642) ! Author: Glenn Hammond
643) ! Date: 03/14/13
644) !
645)
646) use Richards_module, only : RichardsDestroy
647)
648) implicit none
649)
650) class(pm_richards_type) :: this
651)
652) if (associated(this%next)) then
653) call this%next%Destroy()
654) endif
655)
656) ! preserve this ordering
657) call RichardsDestroy(this%realization)
658) call PMSubsurfaceFlowDestroy(this)
659)
660) end subroutine PMRichardsDestroy
661)
662) end module PM_Richards_class