th.F90       coverage:  82.05 %func     56.55 %block


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

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