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

generated by
Intel(R) C++/Fortran Compiler code-coverage tool
Web-Page Owner: Nobody