mphase.F90       coverage:  76.47 %func     61.39 %block


     1) module Mphase_module
     2)   
     3)   use Mphase_Aux_module
     4)   use Global_Aux_module
     5)   
     6)   use PFLOTRAN_Constants_module
     7) 
     8)   implicit none
     9)   
    10)   private 
    11) 
    12) #include "petsc/finclude/petscsys.h"
    13)   
    14) !#include "include/petscf90.h"
    15) #include "petsc/finclude/petscvec.h"
    16) #include "petsc/finclude/petscvec.h90"
    17)   ! It is VERY IMPORTANT to make sure that the above .h90 file gets included.
    18)   ! Otherwise some very strange things will happen and PETSc will give no
    19)   ! indication of what the problem is.
    20) #include "petsc/finclude/petscmat.h"
    21) #include "petsc/finclude/petscmat.h90"
    22) #include "petsc/finclude/petscdm.h"
    23) #include "petsc/finclude/petscdm.h90"
    24) !#ifdef USE_PETSC216
    25) !#include "petsc/finclude/petscsles.h"
    26) !#endiff
    27) #include "petsc/finclude/petscsnes.h"
    28) #include "petsc/finclude/petscviewer.h"
    29) #include "petsc/finclude/petscsysdef.h"
    30) #include "petsc/finclude/petscis.h"
    31) #include "petsc/finclude/petscis.h90"
    32) #include "petsc/finclude/petsclog.h"
    33) #include "petsc/finclude/petscerror.h"
    34) 
    35) ! Cutoff parameters
    36)   PetscReal, parameter :: formeps = 1.D-4
    37)   PetscReal, parameter :: eps = 1.D-8 
    38)   PetscReal, parameter :: dfac = 1D-8
    39)   PetscReal, parameter :: floweps = 1.D-24
    40) !  PetscReal, parameter :: satcuteps = 1.D-5
    41)   PetscReal, parameter :: zerocut =0.D0  !1D-8
    42)   
    43) 
    44)   PetscInt, parameter :: jh2o=1, jco2=2
    45) 
    46)   public MphaseResidual,MphaseJacobian, &
    47)          MphaseUpdateFixedAccumulation,MphaseTimeCut, &
    48)          MphaseSetup,MphaseUpdateReason, &
    49)          MphaseMaxChange,MphaseUpdateSolution, &
    50)          MphaseGetTecplotHeader,MphaseInitializeTimestep, &
    51)          MphaseUpdateAuxVars, &
    52)          MphaseSecondaryHeat,MphaseSecondaryHeatJacobian, &
    53)          MphaseComputeMassBalance,MphaseDestroy
    54) 
    55) contains
    56) 
    57) ! ************************************************************************** !
    58) 
    59) subroutine MphaseTimeCut(realization)
    60)   ! 
    61)   ! Resets arrays for time step cut
    62)   ! 
    63)   ! Author: Chuan Lu
    64)   ! Date: 5/13/08
    65)   ! 
    66)  
    67)   use Realization_Subsurface_class
    68)   use Option_module
    69)   use Field_module
    70)  
    71)   implicit none
    72)   
    73)   type(realization_subsurface_type) :: realization
    74)   type(option_type), pointer :: option
    75)   type(field_type), pointer :: field
    76)   
    77)   PetscReal, pointer :: xx_p(:),yy_p(:)
    78)   PetscErrorCode :: ierr
    79)   PetscInt :: local_id
    80) 
    81)   option => realization%option
    82)   field => realization%field
    83) 
    84)   call VecCopy(field%iphas_old_loc,field%iphas_loc,ierr);CHKERRQ(ierr)
    85) 
    86) end subroutine MphaseTimeCut
    87) 
    88) ! ************************************************************************** !
    89) 
    90) subroutine MphaseSetup(realization)
    91)   ! 
    92)   ! Author: Chuan Lu
    93)   ! Date: 5/13/08
    94)   ! 
    95) 
    96)   use Realization_Subsurface_class
    97)   use Patch_module
    98)   use Output_Aux_module
    99)    
   100)   type(realization_subsurface_type) :: realization
   101)   
   102)   type(patch_type), pointer :: cur_patch
   103)   type(output_variable_list_type), pointer :: list
   104)   
   105)   cur_patch => realization%patch_list%first
   106)   do
   107)     if (.not.associated(cur_patch)) exit
   108)     realization%patch => cur_patch
   109)     call MphaseSetupPatch(realization)
   110)     cur_patch => cur_patch%next
   111)   enddo
   112) 
   113)   list => realization%output_option%output_snap_variable_list
   114)   call MPhaseSetPlotVariables(list)
   115)   list => realization%output_option%output_obs_variable_list
   116)   call MPhaseSetPlotVariables(list)
   117) 
   118) end subroutine MphaseSetup
   119) 
   120) ! ************************************************************************** !
   121) 
   122) subroutine MphaseSetupPatch(realization)
   123)   ! 
   124)   ! Creates arrays for auxiliary variables
   125)   ! 
   126)   ! Author: Chuan Lu
   127)   ! Date: 5/13/08
   128)   ! 
   129) 
   130)   use Realization_Subsurface_class
   131)   use Patch_module
   132)   use Option_module
   133)   use Coupler_module
   134)   use Connection_module
   135)   use Grid_module
   136)   use Secondary_Continuum_Aux_module
   137)   use Secondary_Continuum_module
   138)  
   139)   implicit none
   140)   
   141)   type(realization_subsurface_type) :: realization
   142) 
   143)   type(option_type), pointer :: option
   144)   type(patch_type),pointer :: patch
   145)   type(mphase_type),pointer :: mphase
   146)   type(grid_type), pointer :: grid
   147)   type(coupler_type), pointer :: boundary_condition
   148)   type(coupler_type), pointer :: source_sink
   149) 
   150)   PetscInt :: ghosted_id, iconn, sum_connection, ipara
   151)   type(Mphase_auxvar_type), pointer :: auxvars(:)
   152)   type(Mphase_auxvar_type), pointer :: auxvars_bc(:)
   153)   type(Mphase_auxvar_type), pointer :: auxvars_ss(:)  
   154)   type(sec_heat_type), pointer :: mphase_sec_heat_vars(:)
   155)   type(coupler_type), pointer :: initial_condition
   156)   PetscReal :: area_per_vol
   157)   PetscInt :: local_id
   158) 
   159)   option => realization%option
   160)   patch => realization%patch
   161)   grid => patch%grid 
   162) 
   163)   patch%aux%Mphase => MphaseAuxCreate()
   164)   patch%aux%SC_heat => SecondaryAuxHeatCreate(option)
   165)   mphase => patch%aux%Mphase
   166) 
   167)   
   168) !  option%io_buffer = 'Before Mphase can be run, the thc_parameter object ' // &
   169) !                     'must be initialized with the proper variables ' // &
   170) !                     'MphaseAuxCreate() is called anywhere.'
   171) !  call printErrMsg(option)  
   172) 
   173) ! mphase_parameters create *********************************************
   174) ! Sir
   175)   allocate(mphase%Mphase_parameter%sir(option%nphase, &
   176)                                   size(patch%saturation_function_array)))
   177)   do ipara = 1, size(patch%saturation_function_array)
   178)     mphase%mphase_parameter%sir(:,patch% &
   179)                                    saturation_function_array(ipara)%ptr%id) = &
   180)       patch%saturation_function_array(ipara)%ptr%Sr(:)
   181)   enddo
   182) 
   183) ! dencpr  
   184)   allocate(mphase%Mphase_parameter%dencpr(size(patch%material_property_array)))
   185)   do ipara = 1, size(patch%material_property_array)
   186)     mphase%mphase_parameter%dencpr(iabs(patch%material_property_array(ipara)% &
   187)                                         ptr%internal_id)) = &
   188)       patch%material_property_array(ipara)%ptr%rock_density*option%scale*&
   189)       patch%material_property_array(ipara)%ptr%specific_heat
   190)   enddo
   191) ! ckwet
   192)   allocate(mphase%Mphase_parameter%ckwet(size(patch%material_property_array)))
   193)   do ipara = 1, size(patch%material_property_array)
   194)     mphase%mphase_parameter%ckwet(iabs(patch%material_property_array(ipara)% &
   195)                                        ptr%internal_id)) = &
   196)       patch%material_property_array(ipara)%ptr%thermal_conductivity_wet*option%scale
   197)   enddo
   198)   
   199) 
   200) ! mphase_parameters create_end *****************************************
   201) 
   202) ! Create secondary continuum variables - Added by SK 06/28/12
   203) 
   204)   if (option%use_mc) then
   205)  
   206)     initial_condition => patch%initial_condition_list%first
   207)     allocate(mphase_sec_heat_vars(grid%nlmax))
   208)   
   209)     do local_id = 1, grid%nlmax
   210)   
   211)     ! Assuming the same secondary continuum for all regions (need to make it an array)
   212)     ! S. Karra 07/18/12
   213)       call SecondaryContinuumSetProperties( &
   214)         mphase_sec_heat_vars(local_id)%sec_continuum, &
   215)         patch%material_property_array(1)%ptr%secondary_continuum_name, &
   216)         patch%material_property_array(1)%ptr%secondary_continuum_length, &
   217)         patch%material_property_array(1)%ptr%secondary_continuum_matrix_block_size, &
   218)         patch%material_property_array(1)%ptr%secondary_continuum_fracture_spacing, &
   219)         patch%material_property_array(1)%ptr%secondary_continuum_radius, &
   220)         patch%material_property_array(1)%ptr%secondary_continuum_area, &
   221)         option)
   222)         
   223)       mphase_sec_heat_vars(local_id)%ncells = &
   224)         patch%material_property_array(1)%ptr%secondary_continuum_ncells
   225)       mphase_sec_heat_vars(local_id)%aperture = &
   226)         patch%material_property_array(1)%ptr%secondary_continuum_aperture
   227)       mphase_sec_heat_vars(local_id)%epsilon = &
   228)         patch%material_property_array(1)%ptr%secondary_continuum_epsilon
   229)       mphase_sec_heat_vars(local_id)%log_spacing = &
   230)         patch%material_property_array(1)%ptr%secondary_continuum_log_spacing
   231)       mphase_sec_heat_vars(local_id)%outer_spacing = &
   232)         patch%material_property_array(1)%ptr%secondary_continuum_outer_spacing
   233)         
   234) 
   235)       allocate(mphase_sec_heat_vars(local_id)%area(mphase_sec_heat_vars(local_id)%ncells))
   236)       allocate(mphase_sec_heat_vars(local_id)%vol(mphase_sec_heat_vars(local_id)%ncells))
   237)       allocate(mphase_sec_heat_vars(local_id)%dm_minus(mphase_sec_heat_vars(local_id)%ncells))
   238)       allocate(mphase_sec_heat_vars(local_id)%dm_plus(mphase_sec_heat_vars(local_id)%ncells))
   239)       allocate(mphase_sec_heat_vars(local_id)%sec_continuum% &
   240)                distance(mphase_sec_heat_vars(local_id)%ncells))
   241)     
   242)       call SecondaryContinuumType(&
   243)                               mphase_sec_heat_vars(local_id)%sec_continuum, &
   244)                               mphase_sec_heat_vars(local_id)%ncells, &
   245)                               mphase_sec_heat_vars(local_id)%area, &
   246)                               mphase_sec_heat_vars(local_id)%vol, &
   247)                               mphase_sec_heat_vars(local_id)%dm_minus, &
   248)                               mphase_sec_heat_vars(local_id)%dm_plus, &
   249)                               mphase_sec_heat_vars(local_id)%aperture, &
   250)                               mphase_sec_heat_vars(local_id)%epsilon, &
   251)                               mphase_sec_heat_vars(local_id)%log_spacing, &
   252)                               mphase_sec_heat_vars(local_id)%outer_spacing, &
   253)                               area_per_vol,option)
   254)                                 
   255)       mphase_sec_heat_vars(local_id)%interfacial_area = area_per_vol* &
   256)           (1.d0 - mphase_sec_heat_vars(local_id)%epsilon)* &
   257)           patch%material_property_array(1)%ptr% &
   258)           secondary_continuum_area_scaling
   259) 
   260) 
   261)     ! Setting the initial values of all secondary node temperatures same as primary node 
   262)     ! temperatures (with initial dirichlet BC only) -- sk 06/26/12
   263)       allocate(mphase_sec_heat_vars(local_id)%sec_temp(mphase_sec_heat_vars(local_id)%ncells))
   264)       
   265)       if (option%set_secondary_init_temp) then
   266)         mphase_sec_heat_vars(local_id)%sec_temp = &
   267)           patch%material_property_array(1)%ptr%secondary_continuum_init_temp
   268)       else
   269)         mphase_sec_heat_vars(local_id)%sec_temp = &
   270)         initial_condition%flow_condition%temperature%dataset%rarray(1)
   271)       endif
   272)           
   273)     enddo
   274)       
   275)     patch%aux%SC_heat%sec_heat_vars => mphase_sec_heat_vars    
   276)   
   277)   endif
   278) 
   279)   
   280)   ! allocate auxvar data structures for all grid cells  
   281)   allocate(auxvars(grid%ngmax))
   282) 
   283)   do ghosted_id = 1, grid%ngmax
   284)     call MphaseAuxVarInit(auxvars(ghosted_id),option)
   285)   enddo
   286)   mphase%auxvars => auxvars
   287)   mphase%num_aux = grid%ngmax
   288) 
   289)   allocate(mphase%delx(option%nflowdof,grid%ngmax))
   290)   allocate(mphase%res_old_AR(grid%nlmax,option%nflowdof))
   291)   allocate(mphase%res_old_FL(ConnectionGetNumberInList(patch%grid%&
   292)            internal_connection_set_list),option%nflowdof))
   293)            
   294)   ! count the number of boundary connections and allocate
   295)   ! auxvar data structures for them  
   296)   boundary_condition => patch%boundary_condition_list%first
   297)   sum_connection = 0    
   298)   do 
   299)     if (.not.associated(boundary_condition)) exit
   300)     sum_connection = sum_connection + &
   301)                      boundary_condition%connection_set%num_connections
   302)     boundary_condition => boundary_condition%next
   303)   enddo
   304) 
   305)   allocate(auxvars_bc(sum_connection))
   306) 
   307)   do iconn = 1, sum_connection
   308)     call MphaseAuxVarInit(auxvars_bc(iconn),option)
   309)   enddo
   310) 
   311)   mphase%auxvars_bc => auxvars_bc
   312)   mphase%num_aux_bc = sum_connection
   313)   
   314)  ! Allocate source /sink  
   315)   source_sink => patch%source_sink_list%first
   316)   sum_connection = 0    
   317)   do 
   318)     if (.not.associated(source_sink)) exit
   319)     sum_connection = sum_connection + &
   320)                      source_sink%connection_set%num_connections
   321)     source_sink => source_sink%next
   322)   enddo
   323)   allocate(auxvars_ss(sum_connection))
   324)   do iconn = 1, sum_connection
   325)     call MphaseAuxVarInit(auxvars_ss(iconn),option)
   326)   enddo
   327)   mphase%auxvars_ss => auxvars_ss
   328)   mphase%num_aux_ss = sum_connection
   329)   
   330)   option%flow%numerical_derivatives = PETSC_TRUE
   331) 
   332) end subroutine MphaseSetupPatch
   333) 
   334) ! ************************************************************************** !
   335) 
   336) subroutine MphaseComputeMassBalance(realization,mass_balance,mass_trapped)
   337)   ! 
   338)   ! Author: Glenn Hammond
   339)   ! Date: 02/22/08
   340)   ! 
   341) 
   342)   use Realization_Subsurface_class
   343)   use Patch_module
   344) 
   345)   type(realization_subsurface_type) :: realization
   346)   PetscReal :: mass_balance(realization%option%nflowspec,realization%option%nphase)
   347)   PetscReal :: mass_trapped(realization%option%nphase)
   348) 
   349)   type(patch_type), pointer :: cur_patch
   350)   
   351)   mass_balance = 0.d0
   352)   mass_trapped = 0.d0
   353)   
   354)   cur_patch => realization%patch_list%first
   355)   do
   356)     if (.not.associated(cur_patch)) exit
   357)     realization%patch => cur_patch
   358)     call MphaseComputeMassBalancePatch(realization,mass_balance,mass_trapped)
   359)     cur_patch => cur_patch%next
   360)   enddo
   361) 
   362) end subroutine MphaseComputeMassBalance
   363) 
   364) ! ************************************************************************** !
   365) 
   366) subroutine MphaseComputeMassBalancePatch(realization,mass_balance,mass_trapped)
   367)   ! 
   368)   ! Initializes mass balance
   369)   ! 
   370)   ! Author: Glenn Hammond
   371)   ! Date: 12/19/08
   372)   ! 
   373)  
   374)   use Realization_Subsurface_class
   375)   use Option_module
   376)   use Patch_module
   377)   use Field_module
   378)   use Grid_module
   379)   use Material_Aux_class
   380) ! use Saturation_Function_module
   381) ! use Mphase_pckr_module
   382)  
   383)   implicit none
   384)   
   385)   type(realization_subsurface_type) :: realization
   386) ! type(saturation_function_type) :: saturation_function_type
   387) 
   388)   PetscReal :: mass_balance(realization%option%nflowspec,realization%option%nphase)
   389)   PetscReal :: mass_trapped(realization%option%nphase)
   390) 
   391)   type(option_type), pointer :: option
   392)   type(patch_type), pointer :: patch
   393)   type(field_type), pointer :: field
   394)   type(grid_type), pointer :: grid
   395)   type(mphase_auxvar_type), pointer :: mphase_auxvars(:)
   396)   class(material_auxvar_type), pointer :: material_auxvars(:)
   397)   PetscReal, pointer :: icap_loc_p(:)
   398) 
   399)   PetscErrorCode :: ierr
   400)   PetscInt :: local_id
   401)   PetscInt :: ghosted_id
   402)   PetscInt :: iphase
   403)   PetscInt :: ispec_start, ispec_end, ispec
   404)   PetscReal :: pckr_sir(realization%option%nphase)
   405) 
   406)   option => realization%option
   407)   patch => realization%patch
   408)   grid => patch%grid
   409)   field => realization%field
   410) 
   411)   mphase_auxvars => patch%aux%MPhase%auxvars
   412)   material_auxvars => patch%aux%Material%auxvars
   413)   
   414)   call VecGetArrayF90(field%icap_loc,icap_loc_p, ierr);CHKERRQ(ierr)
   415) 
   416)   do local_id = 1, grid%nlmax
   417)     ghosted_id = grid%nL2G(local_id)
   418) 
   419)     !geh - Ignore inactive cells with inactive materials
   420)     if (associated(patch%imat)) then
   421)       if (patch%imat(ghosted_id) <= 0) cycle
   422)     endif
   423) 
   424)     ! mass = volume * saturation * density * mole fraction
   425)     do iphase = 1, option%nphase
   426)       do ispec = 1, option%nflowspec
   427)         mass_balance(ispec,iphase) = mass_balance(ispec,iphase) + &
   428)           mphase_auxvars(ghosted_id)%auxvar_elem(0)%xmol(ispec+(iphase-1)*option%nflowspec)* &
   429)           mphase_auxvars(ghosted_id)%auxvar_elem(0)%den(iphase)* &
   430)           mphase_auxvars(ghosted_id)%auxvar_elem(0)%sat(iphase)* &
   431)           material_auxvars(ghosted_id)%porosity*material_auxvars(ghosted_id)%volume
   432)       enddo
   433) 
   434)       pckr_sir(iphase) = &
   435)         patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr%sr(iphase)
   436) 
   437)       if (iphase == 1 .and. &
   438)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%sat(iphase) <= pckr_sir(iphase)) then
   439)         ispec = 1
   440)         mass_trapped(iphase) = mass_trapped(iphase) + &
   441)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%xmol(ispec+(iphase-1)*option%nflowspec)* &
   442)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%den(iphase)* &
   443)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%sat(iphase)* &
   444)         material_auxvars(ghosted_id)%porosity*material_auxvars(ghosted_id)%volume
   445)       endif
   446) 
   447)       if (iphase == 2 .and. &
   448)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%sat(iphase) <= pckr_sir(iphase)) then
   449)         ispec = 2
   450)         mass_trapped(iphase) = mass_trapped(iphase) + &
   451)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%xmol(ispec+(iphase-1)*option%nflowspec)* &
   452)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%den(iphase)* &
   453)         mphase_auxvars(ghosted_id)%auxvar_elem(0)%sat(iphase)* &
   454)         material_auxvars(ghosted_id)%porosity*material_auxvars(ghosted_id)%volume
   455)       endif
   456)     enddo
   457)   enddo
   458) 
   459)   call VecRestoreArrayF90(field%icap_loc,icap_loc_p, ierr);CHKERRQ(ierr)
   460)   
   461) end subroutine MphaseComputeMassBalancePatch
   462) 
   463) ! ************************************************************************** !
   464) 
   465) subroutine MphaseZeroMassBalDeltaPatch(realization)
   466)   ! 
   467)   ! Zeros mass balance delta array
   468)   ! 
   469)   ! Author: Glenn Hammond
   470)   ! Date: 12/19/08
   471)   ! 
   472)  
   473)   use Realization_Subsurface_class
   474)   use Option_module
   475)   use Patch_module
   476)   use Grid_module
   477)  
   478)   implicit none
   479)   
   480)   type(realization_subsurface_type) :: realization
   481) 
   482)   type(option_type), pointer :: option
   483)   type(patch_type), pointer :: patch
   484)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
   485)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
   486) 
   487)   PetscInt :: iconn
   488) 
   489)   option => realization%option
   490)   patch => realization%patch
   491) 
   492)   global_auxvars_bc => patch%aux%Global%auxvars_bc
   493)   global_auxvars_ss => patch%aux%Global%auxvars_ss
   494) 
   495) #ifdef COMPUTE_INTERNAL_MASS_FLUX
   496)   do iconn = 1, patch%aux%Mphase%num_aux
   497)     patch%aux%Global%auxvars(iconn)%mass_balance_delta = 0.d0
   498)   enddo
   499) #endif
   500) 
   501)   ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
   502)   ! placed around the internal do loop - geh
   503)   if (patch%aux%Mphase%num_aux_bc > 0) then
   504)     do iconn = 1, patch%aux%Mphase%num_aux_bc
   505)       global_auxvars_bc(iconn)%mass_balance_delta = 0.d0
   506)     enddo
   507)   endif
   508)   
   509)   if (patch%aux%Mphase%num_aux_ss > 0) then
   510)     do iconn = 1, patch%aux%Mphase%num_aux_ss
   511)       global_auxvars_ss(iconn)%mass_balance_delta = 0.d0
   512)     enddo
   513)   endif
   514) 
   515) end subroutine MphaseZeroMassBalDeltaPatch
   516) 
   517) ! ************************************************************************** !
   518) 
   519) subroutine MphaseUpdateMassBalancePatch(realization)
   520)   ! 
   521)   ! Updates mass balance
   522)   ! 
   523)   ! Author: Glenn Hammond
   524)   ! Date: 12/19/08
   525)   ! 
   526)  
   527)   use Realization_Subsurface_class
   528)   use Option_module
   529)   use Patch_module
   530)   use Grid_module
   531)  
   532)   implicit none
   533)   
   534)   type(realization_subsurface_type) :: realization
   535) 
   536)   type(option_type), pointer :: option
   537)   type(patch_type), pointer :: patch
   538)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
   539)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
   540) 
   541)   PetscInt :: iconn
   542) 
   543)   option => realization%option
   544)   patch => realization%patch
   545) 
   546)   global_auxvars_bc => patch%aux%Global%auxvars_bc
   547)   global_auxvars_ss => patch%aux%Global%auxvars_ss
   548) 
   549) #ifdef COMPUTE_INTERNAL_MASS_FLUX
   550)   do iconn = 1, patch%aux%Mphase%num_aux
   551)     patch%aux%Global%auxvars(iconn)%mass_balance = &
   552)       patch%aux%Global%auxvars(iconn)%mass_balance + &
   553)       patch%aux%Global%auxvars(iconn)%mass_balance_delta* &
   554)       option%flow_dt
   555)   enddo
   556) #endif
   557) 
   558)   ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
   559)   ! placed around the internal do loop - geh
   560)   if (patch%aux%Mphase%num_aux_bc > 0) then
   561)     do iconn = 1, patch%aux%Mphase%num_aux_bc
   562)       global_auxvars_bc(iconn)%mass_balance = &
   563)         global_auxvars_bc(iconn)%mass_balance + &
   564)         global_auxvars_bc(iconn)%mass_balance_delta*option%flow_dt
   565)     enddo
   566)   endif
   567)   
   568)   if (patch%aux%Mphase%num_aux_ss > 0) then
   569)     do iconn = 1, patch%aux%Mphase%num_aux_ss
   570)       global_auxvars_ss(iconn)%mass_balance = &
   571)         global_auxvars_ss(iconn)%mass_balance + &
   572)         global_auxvars_ss(iconn)%mass_balance_delta*option%flow_dt
   573)     enddo
   574)   endif
   575) 
   576) end subroutine MphaseUpdateMassBalancePatch
   577) 
   578) ! ************************************************************************** !
   579) 
   580) function MphaseInitGuessCheck(realization)
   581)   ! 
   582)   ! Mphaseinitguesscheckpatch:
   583)   ! 
   584)   ! Author: Chuan Lu
   585)   ! Date: 12/10/07
   586)   ! 
   587)  
   588)   use Realization_Subsurface_class
   589)   use Patch_module
   590)   use Option_module
   591)   
   592)   PetscInt ::  MphaseInitGuessCheck
   593)   type(realization_subsurface_type) :: realization
   594)   type(option_type), pointer :: option
   595)   type(patch_type), pointer :: cur_patch
   596)   PetscInt :: ipass, ipass0
   597)   PetscErrorCode :: ierr    
   598) 
   599)   option => realization%option
   600)   ipass = 1
   601)   cur_patch => realization%patch_list%first
   602)   do while(ipass > 0)
   603)     if (.not.associated(cur_patch)) exit
   604)     realization%patch => cur_patch
   605)     ipass = MphaseInitGuessCheckPatch(realization)
   606)     cur_patch => cur_patch%next
   607)   enddo
   608) 
   609)   call MPI_Barrier(option%mycomm,ierr)
   610)   if (option%mycommsize > 1) then
   611)     call MPI_Allreduce(ipass,ipass0,ONE_INTEGER_MPI,MPIU_INTEGER,MPI_SUM, &
   612)                          option%mycomm,ierr)
   613)     if (ipass0 < option%mycommsize) ipass=-1
   614)   endif
   615)   MphaseInitGuessCheck =ipass
   616) end function MphaseInitGuessCheck
   617) 
   618) ! ************************************************************************** !
   619) 
   620) subroutine MPhaseUpdateReasonPatch(reason,realization)
   621)   ! 
   622)   ! Mphaseinitguesscheckpatch:
   623)   ! 
   624)   ! Author: Chuan Lu
   625)   ! Date: 12/10/07
   626)   ! 
   627)   use Realization_Subsurface_class
   628)   use Patch_module
   629)   use Field_module
   630)   use Option_module
   631)   use Grid_module
   632) 
   633)   implicit none
   634)  
   635)   PetscInt, intent(out) :: reason
   636)   type(realization_subsurface_type) :: realization  
   637)   type(patch_type),pointer :: patch
   638)   type(grid_type), pointer :: grid
   639)   type(field_type), pointer :: field
   640)   type(option_type), pointer :: option 
   641)   PetscReal, pointer :: xx_p(:),iphase_loc_p(:), yy_p(:) 
   642)   PetscInt :: n,n0,re
   643)   PetscInt :: re0, iipha
   644)   PetscErrorCode :: ierr
   645)   
   646)   option => realization%option
   647)   field => realization%field  
   648)   patch => realization%patch
   649)   grid => patch%grid
   650) 
   651)   re = 1
   652)  
   653) ! if (re > 0) then
   654)     call VecGetArrayReadF90(field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
   655)     call VecGetArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
   656)     call VecGetArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
   657)   
   658)     do n = 1,grid%nlmax
   659) !**** clu-Ignore inactive cells with inactive materials **************
   660)       if (associated(patch%imat)) then
   661)         if (patch%imat(grid%nL2G(n)) <= 0) cycle
   662)       endif
   663)       n0 = (n-1)*option%nflowdof
   664)       iipha = int(iphase_loc_p(grid%nL2G(n)))
   665)   
   666) ! ******** Too huge change in pressure ****************     
   667) !geh: I don't believe that this code is being used.  Therefore, I will add an
   668) !     error message and let someone sort the use of option%dpmxe later
   669)         option%io_buffer = 'option%dpmxe and option%dtmpmxe needs to be ' // &
   670)           'refactored in MPhaseUpdateReasonPatch'
   671)         call printErrMsg(option)      
   672) !geh      if (dabs(xx_p(n0 + 1) - yy_p(n0 + 1)) > (1000.0D0 * option%dpmxe)) then
   673)         re = 0; print *,'large change in p', xx_p(n0 + 1), yy_p(n0 + 1)
   674)         exit
   675) !geh      endif
   676) 
   677) ! ******** Too huge change in temperature ****************
   678) !geh      if (dabs(xx_p(n0 + 2) - yy_p(n0 + 2)) > (10.0D0 * option%dtmpmxe)) then
   679)         re = 0; print *,'large change in T', xx_p(n0 + 2), yy_p(n0 + 2)
   680)         exit
   681) !geh      endif
   682)  
   683) ! ******* Check 0 <= sat/con <= 1 **************************
   684)       select case(iipha)
   685)         case (1) ! liquid
   686)           if (xx_p(n0 + 3) > 1.0D0) then
   687)             re = 0; exit
   688)           endif
   689)           if (xx_p(n0 + 3) < 0.D0) then
   690) !           if (xx_p(n0 + 3) > -1D-14) then
   691) !             xx_p(n0 + 3) = 0.D0
   692) !           else
   693) !!            print *,'MPhaseUpdate: ',iipha,n,n0,option%nflowdof,xx_p(n0+3)
   694)               re = 0; exit
   695) !           endif          ! clu removed 05/02/2011
   696)           endif
   697)         case (2) ! gas
   698)           if (xx_p(n0 + 3) > 1.0D0) then
   699)             re=0; exit
   700)           endif
   701)           if (xx_p(n0 + 3) < 0.D-0) then
   702) !           if (xx_p(n0 + 3) > -1D-14) then
   703) !             xx_p(n0 + 3) = 0.D0
   704) !           else
   705)               re = 0; exit
   706) !           endif
   707)           endif
   708)         case (3) ! two-phase
   709)           if (xx_p(n0 + 3) > 1.D0) then
   710)             re=0; exit
   711)           endif
   712)           if (xx_p(n0 + 3) < 0.) then
   713) !           if (xx_p(n0 + 3) > -1D-14) then
   714) !             xx_p(n0 + 3) = 0.D0
   715) !           else
   716)               re = 0; exit
   717) !           endif
   718)           endif
   719)       end select
   720)     end do
   721)   
   722) !   if (re <= 0) print *,'Sat or Con out of Region at: ',n,iipha,xx_p(n0+1:n0+3)
   723)     call VecRestoreArrayReadF90(field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
   724)     call VecRestoreArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
   725)     call VecRestoreArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
   726) 
   727) ! endif
   728)   ! print *,' update reason', grid%myrank, re,n,grid%nlmax
   729)   reason=re
   730)   
   731) end subroutine MPhaseUpdateReasonPatch
   732) 
   733) ! ************************************************************************** !
   734) 
   735) subroutine MPhaseUpdateReason(reason, realization)
   736)   ! 
   737)   ! MphaseUpdateAuxVars: Updates the auxiliary variables associated with
   738)   ! the Mphase problem
   739)   ! 
   740)   ! Author: Glenn Hammond
   741)   ! Date: 12/10/07
   742)   ! 
   743) 
   744)   use Realization_Subsurface_class
   745)   use Patch_module
   746)   implicit none
   747) 
   748)   type(realization_subsurface_type) :: realization
   749)   
   750)   type(patch_type), pointer :: cur_patch
   751)   PetscInt :: reason
   752) 
   753)   PetscInt :: re, re0
   754)   PetscErrorCode :: ierr
   755) 
   756)   re = 1
   757)   cur_patch => realization%patch_list%first
   758)   do
   759)     if (.not.associated(cur_patch)) exit
   760)     realization%patch => cur_patch
   761)     call MPhaseUpdateReasonPatch(re, realization)
   762)     if (re<=0)then
   763)       exit 
   764)     endif
   765)     cur_patch => cur_patch%next
   766)   enddo
   767) 
   768) 
   769)   call MPI_Barrier(realization%option%mycomm,ierr)
   770)   
   771)   if (realization%option%mycommsize > 1) then
   772)     call MPI_Allreduce(re,re0,ONE_INTEGER_MPI,MPIU_INTEGER,MPI_SUM, &
   773)                         realization%option%mycomm,ierr)
   774)     if (re0<realization%option%mycommsize) re=0
   775)   endif
   776)   reason=re
   777)   
   778)   if (reason <= 0 .and. realization%option%myrank == 0) print *,'Sat or Con out of Region', re
   779) end subroutine MPhaseUpdateReason
   780) 
   781) ! ************************************************************************** !
   782) 
   783)   function  MphaseInitGuessCheckPatch(realization)
   784)   ! 
   785)   ! Author: Chuan Lu
   786)   ! Date: 12/10/07
   787)   ! 
   788)    
   789)     use co2_span_wagner_module
   790)      
   791)     use Realization_Subsurface_class
   792)     use Patch_module
   793)     use Field_module
   794)     use Grid_module
   795)     use Option_module
   796)     implicit none
   797)     
   798)     PetscInt :: MphaseInitGuessCheckPatch 
   799)     type(realization_subsurface_type) :: realization
   800)     type(grid_type), pointer :: grid
   801)     type(patch_type), pointer :: patch
   802)     type(option_type), pointer :: option
   803)     type(field_type), pointer :: field
   804)       
   805)     PetscInt :: local_id, ghosted_id, ipass
   806)     PetscReal, pointer :: xx_p(:)
   807)     PetscErrorCode :: ierr
   808) 
   809) 
   810)     patch => realization%patch
   811)     grid => patch%grid
   812)     option => realization%option
   813)     field => realization%field
   814)     
   815)     call VecGetArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
   816)     
   817)     ipass=1
   818)     do local_id = 1, grid%nlmax
   819)       ghosted_id = grid%nL2G(local_id)
   820)        !geh - Ignore inactive cells with inactive materials
   821)       if (associated(patch%imat)) then
   822)         if (patch%imat(ghosted_id) <= 0) cycle
   823)       endif
   824)       
   825) !   insure zero liquid sat not passed to ptran (no effect on pflow)
   826)       if (xx_p((local_id-1)*option%nflowdof+3) < 0.D0)xx_p((local_id-1)*option%nflowdof+3) = zerocut
   827)       if (xx_p((local_id-1)*option%nflowdof+3) > 1.D0)xx_p((local_id-1)*option%nflowdof+3) = 1.D0 - zerocut
   828)     
   829) !   check if p,T within range of table  
   830)       if (xx_p((local_id-1)*option%nflowdof+1)< p0_tab*1D6 &
   831)             .or. xx_p((local_id-1)*option%nflowdof+1)>(ntab_p*dp_tab + p0_tab)*1D6)then
   832)           ipass=-1; exit  
   833)       endif
   834)       if (xx_p((local_id-1)*option%nflowdof+2)< t0_tab -273.15D0 &
   835)             .or. xx_p((local_id-1)*option%nflowdof+2)>ntab_t*dt_tab + t0_tab-273.15D0)then
   836)           ipass=-1; exit
   837)       endif
   838)     enddo
   839) 
   840)     call VecRestoreArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
   841) 
   842)     MphaseInitGuessCheckPatch = ipass
   843) 
   844)   end function MphaseInitGuessCheckPatch
   845) 
   846) ! ************************************************************************** !
   847) 
   848) subroutine MphaseUpdateAuxVars(realization)
   849)   ! 
   850)   ! Updates the auxiliary variables associated with
   851)   ! the Mphase problem
   852)   ! 
   853)   ! Author: Glenn Hammond
   854)   ! Date: 12/10/07
   855)   ! 
   856) 
   857)   use Realization_Subsurface_class
   858)   use Patch_module
   859) 
   860)   type(realization_subsurface_type) :: realization
   861)   
   862)   type(patch_type), pointer :: cur_patch
   863)   
   864)   cur_patch => realization%patch_list%first
   865)   do
   866)     if (.not.associated(cur_patch)) exit
   867)     realization%patch => cur_patch
   868)     call MphaseUpdateAuxVarsPatch(realization)
   869)     cur_patch => cur_patch%next
   870)   enddo
   871) 
   872) end subroutine MphaseUpdateAuxVars
   873) 
   874) ! ************************************************************************** !
   875) 
   876) subroutine MphaseUpdateAuxVarsPatch(realization)
   877)   ! 
   878)   ! Updates the auxiliary variables associated with
   879)   ! the Mphase problem
   880)   ! 
   881)   ! Author: Chuan Lu
   882)   ! Date: 12/10/07
   883)   ! 
   884) 
   885)   use Realization_Subsurface_class
   886)   use Patch_module
   887)   use Field_module
   888)   use Option_module
   889)   use Grid_module
   890)   use Coupler_module
   891)   use Connection_module
   892)   use Material_module
   893)   
   894)   implicit none
   895) 
   896)   type(realization_subsurface_type) :: realization
   897)   
   898)   type(option_type), pointer :: option
   899)   type(patch_type), pointer :: patch
   900)   type(grid_type), pointer :: grid
   901)   type(field_type), pointer :: field
   902)   type(coupler_type), pointer :: boundary_condition
   903)   type(coupler_type), pointer :: source_sink
   904)   type(connection_set_type), pointer :: cur_connection_set
   905)   type(Mphase_auxvar_type), pointer :: auxvars(:)
   906)   type(Mphase_auxvar_type), pointer :: auxvars_bc(:) 
   907)   type(Mphase_auxvar_type), pointer :: auxvars_ss(:)
   908)   type(global_auxvar_type), pointer :: global_auxvars(:)
   909)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
   910)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
   911) 
   912)   PetscInt :: ghosted_id, local_id, istart, iend, sum_connection, idof, iconn
   913)   PetscInt :: iphase
   914)   PetscReal, pointer :: xx_loc_p(:), icap_loc_p(:), iphase_loc_p(:)
   915)   PetscReal :: xxbc(realization%option%nflowdof)
   916)   PetscErrorCode :: ierr
   917)   PetscReal :: xphi, ynacl, mnacl
   918)   
   919)   option => realization%option
   920)   patch => realization%patch
   921)   grid => patch%grid
   922)   field => realization%field
   923)   
   924)   auxvars => patch%aux%Mphase%auxvars
   925)   auxvars_bc => patch%aux%Mphase%auxvars_bc
   926)   auxvars_ss => patch%aux%Mphase%auxvars_ss
   927) 
   928)   global_auxvars => patch%aux%Global%auxvars
   929)   global_auxvars_bc => patch%aux%Global%auxvars_bc
   930)   global_auxvars_ss => patch%aux%Global%auxvars_ss
   931)   
   932)   call VecGetArrayF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
   933)   call VecGetArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
   934)   call VecGetArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
   935) 
   936)   do ghosted_id = 1, grid%ngmax
   937)     if (grid%nG2L(ghosted_id) < 0) cycle ! bypass ghosted corner cells
   938)     !geh - Ignore inactive cells with inactive materials
   939)     if (associated(patch%imat)) then
   940)       if (patch%imat(ghosted_id) <= 0) cycle
   941)     endif
   942)     iend = ghosted_id*option%nflowdof
   943)     istart = iend-option%nflowdof+1
   944)     iphase = int(iphase_loc_p(ghosted_id))
   945)     if (.not. associated(patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr))then
   946)       print *, 'error!!! saturation function not allocated', ghosted_id,icap_loc_p(ghosted_id)
   947)     endif
   948)    
   949)     call MphaseAuxVarCompute_NINC(xx_loc_p(istart:iend), &
   950)         auxvars(ghosted_id)%auxvar_elem(0),&
   951)         global_auxvars(ghosted_id), &
   952)         iphase, &
   953)         patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
   954)         realization%fluid_properties,option,xphi)
   955) !   update global variables
   956)     if (associated(global_auxvars)) then
   957)       global_auxvars(ghosted_id)%pres(:) = auxvars(ghosted_id)%auxvar_elem(0)%pres
   958)       if (iphase == 3) then ! 2-phase
   959)         global_auxvars(ghosted_id)%pres(1) = auxvars(ghosted_id)%auxvar_elem(0)%pres - &
   960)                auxvars(ghosted_id)%auxvar_elem(0)%pc(1)
   961)       endif
   962) 
   963) !     print *,'UPdate mphase and global vars ', ghosted_id, &
   964) !        auxvars(ghosted_id)%auxvar_elem(0)%pc(:),auxvars(ghosted_id)%auxvar_elem(0)%pres, &
   965) !        global_auxvars(ghosted_id)%pres(:)
   966) 
   967)       global_auxvars(ghosted_id)%temp = auxvars(ghosted_id)%auxvar_elem(0)%temp
   968)       global_auxvars(ghosted_id)%sat(:) = auxvars(ghosted_id)%auxvar_elem(0)%sat(:)
   969)       global_auxvars(ghosted_id)%fugacoeff(1) = xphi
   970)       global_auxvars(ghosted_id)%den(:) = auxvars(ghosted_id)%auxvar_elem(0)%den(:)
   971)       global_auxvars(ghosted_id)%den_kg(:) = auxvars(ghosted_id)%auxvar_elem(0)%den(:) &
   972)                                           * auxvars(ghosted_id)%auxvar_elem(0)%avgmw(:)
   973)       
   974)       mnacl = global_auxvars(ghosted_id)%m_nacl(1)
   975)       if (global_auxvars(ghosted_id)%m_nacl(2) > mnacl) mnacl = global_auxvars(ghosted_id)%m_nacl(2)
   976)       ynacl = mnacl/(1.d3/FMWH2O + mnacl)
   977)       global_auxvars(ghosted_id)%xmass(1) = (1.d0-ynacl) &
   978)         *auxvars(ghosted_id)%auxvar_elem(0)%xmol(1) * FMWH2O &
   979)         /((1.d0-ynacl)*auxvars(ghosted_id)%auxvar_elem(0)%xmol(1) * FMWH2O &
   980)         +auxvars(ghosted_id)%auxvar_elem(0)%xmol(2) * FMWCO2 &
   981)         +ynacl*auxvars(ghosted_id)%auxvar_elem(0)%xmol(1)*FMWNACL)
   982)       global_auxvars(ghosted_id)%xmass(2) = auxvars(ghosted_id)%auxvar_elem(0)%xmol(3) * FMWH2O &
   983)         /(auxvars(ghosted_id)%auxvar_elem(0)%xmol(3) * FMWH2O &
   984)         +auxvars(ghosted_id)%auxvar_elem(0)%xmol(4) * FMWCO2) 
   985)       global_auxvars(ghosted_id)%reaction_rate_store(:) = global_auxvars(ghosted_id)%reaction_rate(:)
   986)       global_auxvars(ghosted_id)%reaction_rate(:) = 0.D0
   987)     else
   988)       print *,'Not associated global for mph'
   989)     endif
   990)     iphase_loc_p(ghosted_id) = iphase
   991)   enddo
   992)   
   993)   boundary_condition => patch%boundary_condition_list%first
   994)   sum_connection = 0    
   995)   do 
   996)     if (.not.associated(boundary_condition)) exit
   997)     cur_connection_set => boundary_condition%connection_set
   998)     do iconn = 1, cur_connection_set%num_connections
   999)       sum_connection = sum_connection + 1
  1000)       local_id = cur_connection_set%id_dn(iconn)
  1001)       ghosted_id = grid%nL2G(local_id)
  1002)       if (associated(patch%imat)) then
  1003)         if (patch%imat(ghosted_id) <= 0) cycle
  1004)       endif
  1005) 
  1006) ! Added the following by Satish Karra 10/05/11
  1007)       do idof = 1, option%nflowdof
  1008)         select case(boundary_condition%flow_condition%itype(idof))
  1009)           case(DIRICHLET_BC)
  1010)             xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
  1011)           case(HYDROSTATIC_BC,SEEPAGE_BC)
  1012)             xxbc(MPH_PRESSURE_DOF) = boundary_condition%flow_aux_real_var(MPH_PRESSURE_DOF,iconn)
  1013)             if (idof >= MPH_TEMPERATURE_DOF) then
  1014)               xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  1015)             endif
  1016)           case(NEUMANN_BC, ZERO_GRADIENT_BC)
  1017)           ! solve for pb from Darcy's law given qb /= 0
  1018)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  1019)             iphase = int(iphase_loc_p(ghosted_id))
  1020)         end select
  1021)       enddo
  1022) 
  1023)       select case(boundary_condition%flow_condition%itype(MPH_CONCENTRATION_DOF))
  1024)         case(DIRICHLET_BC,SEEPAGE_BC,HYDROSTATIC_BC)
  1025)           iphase = boundary_condition%flow_aux_int_var(1,iconn)
  1026)         case(NEUMANN_BC,ZERO_GRADIENT_BC)
  1027)           iphase = int(iphase_loc_p(ghosted_id))                               
  1028)       end select
  1029) 	  
  1030)       call MphaseAuxVarCompute_NINC(xxbc,auxvars_bc(sum_connection)%auxvar_elem(0), &
  1031)           global_auxvars_bc(sum_connection),iphase, &
  1032)           patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
  1033)           realization%fluid_properties, option, xphi)
  1034)     
  1035)       if (associated(global_auxvars_bc)) then
  1036)         global_auxvars_bc(sum_connection)%pres(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%pres -&
  1037)                      auxvars_bc(sum_connection)%auxvar_elem(0)%pc(:)
  1038)         global_auxvars_bc(sum_connection)%temp = auxvars_bc(sum_connection)%auxvar_elem(0)%temp
  1039)         global_auxvars_bc(sum_connection)%sat(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%sat(:)
  1040)         !    global_auxvars(ghosted_id)%sat_store = 
  1041)         global_auxvars_bc(sum_connection)%fugacoeff(1) = xphi
  1042)         global_auxvars_bc(sum_connection)%den(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%den(:)
  1043)         global_auxvars_bc(sum_connection)%den_kg(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%den(:) &
  1044)                                           * auxvars_bc(sum_connection)%auxvar_elem(0)%avgmw(:)
  1045) !       print *,'xxbc ', xxbc, iphasebc, global_auxvars_bc(sum_connection)%den_kg(:)
  1046)         mnacl= global_auxvars_bc(sum_connection)%m_nacl(1)
  1047)         if (global_auxvars_bc(sum_connection)%m_nacl(2)>mnacl) mnacl = global_auxvars_bc(sum_connection)%m_nacl(2)
  1048)         ynacl =  mnacl/(1.d3/FMWH2O + mnacl)
  1049)         global_auxvars_bc(sum_connection)%xmass(1) = (1.d0-ynacl)&
  1050)                               *auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(1) * FMWH2O&
  1051)                               /((1.d0-ynacl)*auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(1) * FMWH2O &
  1052)                               +auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(2) * FMWCO2 &
  1053)                               +ynacl*auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(1)*FMWNACL)
  1054)         global_auxvars_bc(sum_connection)%xmass(2) = auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(3) * FMWH2O&
  1055)                               /(auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(3) * FMWH2O&
  1056)                               +auxvars_bc(sum_connection)%auxvar_elem(0)%xmol(4) * FMWCO2) 
  1057)  
  1058)       endif
  1059) 
  1060)     enddo
  1061)     boundary_condition => boundary_condition%next
  1062)   enddo
  1063) 
  1064) 
  1065) ! source/sinks
  1066)   source_sink => patch%source_sink_list%first
  1067)   sum_connection = 0    
  1068)   do 
  1069)     if (.not.associated(source_sink)) exit
  1070)     cur_connection_set => source_sink%connection_set
  1071)     do iconn = 1, cur_connection_set%num_connections
  1072)       sum_connection = sum_connection + 1
  1073)       local_id = cur_connection_set%id_dn(iconn)
  1074)       ghosted_id = grid%nL2G(local_id)
  1075)       if (patch%imat(ghosted_id) <= 0) cycle
  1076) 
  1077)       call MphaseAuxVarCopy(auxvars(ghosted_id)%auxvar_elem(0), &
  1078)                               auxvars_ss(sum_connection)%auxvar_elem(0),option)
  1079)       call GlobalAuxVarCopy(global_auxvars(ghosted_id), &
  1080)                             global_auxvars_ss(sum_connection),option)
  1081) 
  1082)     enddo
  1083)     source_sink => source_sink%next
  1084)   enddo
  1085) 
  1086) 
  1087)   call VecRestoreArrayF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
  1088)   call VecRestoreArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
  1089)   call VecRestoreArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
  1090)   
  1091)   patch%aux%Mphase%auxvars_up_to_date = PETSC_TRUE
  1092) 
  1093) end subroutine MphaseUpdateAuxVarsPatch
  1094) 
  1095) ! ************************************************************************** !
  1096) 
  1097) subroutine MphaseInitializeTimestep(realization)
  1098)   ! 
  1099)   ! Update data in module prior to time step
  1100)   ! 
  1101)   ! Author: Glenn Hammond
  1102)   ! Date: 02/20/08
  1103)   ! 
  1104) 
  1105)   use Realization_Subsurface_class
  1106)   
  1107)   implicit none
  1108)   
  1109)   type(realization_subsurface_type) :: realization
  1110) 
  1111)   call MphaseUpdateFixedAccumulation(realization)
  1112) 
  1113) end subroutine MphaseInitializeTimestep
  1114) 
  1115) ! ************************************************************************** !
  1116) 
  1117) subroutine MphaseUpdateSolution(realization)
  1118)   ! 
  1119)   ! Updates data in module after a successful time step
  1120)   ! 
  1121)   ! Author: Glenn Hammond
  1122)   ! Date: 02/13/08
  1123)   ! 
  1124) 
  1125)   use Realization_Subsurface_class
  1126)   use Field_module
  1127)   use Patch_module
  1128)   
  1129)   implicit none
  1130)   
  1131)   type(realization_subsurface_type) :: realization
  1132)   
  1133)   type(field_type), pointer :: field
  1134)   type(patch_type), pointer :: cur_patch
  1135) 
  1136)   PetscErrorCode :: ierr
  1137)   PetscViewer :: viewer
  1138)   
  1139)   field => realization%field
  1140)   
  1141)   call VecCopy(field%iphas_loc,field%iphas_old_loc,ierr);CHKERRQ(ierr)
  1142)   
  1143) ! call VecCopy(realization%field%flow_xx,realization%field%flow_yy,ierr)
  1144) ! call VecCopy(realization%field%iphas_loc,realization%field%iphas_old_loc,ierr)
  1145) 
  1146)   cur_patch => realization%patch_list%first
  1147)   do 
  1148)     if (.not.associated(cur_patch)) exit
  1149)     realization%patch => cur_patch
  1150)     call MphaseUpdateSolutionPatch(realization)
  1151)     cur_patch => cur_patch%next
  1152)   enddo
  1153) 
  1154) ! make room for hysteric s-Pc-kr
  1155) 
  1156) end subroutine MphaseUpdateSolution
  1157) 
  1158) ! ************************************************************************** !
  1159) 
  1160) subroutine MphaseUpdateSolutionPatch(realization)
  1161)   ! 
  1162)   ! Updates data in module after a successful time
  1163)   ! step
  1164)   ! written based on RichardsUpdateSolutionPatch
  1165)   ! 
  1166)   ! Author: Satish Karra, LANL
  1167)   ! Date: 08/23/11, 02/27/14
  1168)   ! 
  1169) 
  1170)   use Realization_Subsurface_class
  1171)   use Patch_module
  1172)   use Grid_module
  1173)   use Option_module
  1174)   use Field_module
  1175)   use Secondary_Continuum_Aux_module
  1176)   use Secondary_Continuum_module
  1177)     
  1178)   implicit none
  1179)   
  1180)   type(realization_subsurface_type) :: realization
  1181)   type(grid_type), pointer :: grid
  1182)   type(patch_type), pointer :: patch
  1183)   type(option_type), pointer :: option
  1184)   type(field_type), pointer :: field
  1185)   type(mphase_type), pointer :: mphase
  1186)   type(mphase_parameter_type), pointer :: mphase_parameter
  1187)   type(mphase_auxvar_type), pointer :: auxvars(:)
  1188)   type(global_auxvar_type), pointer :: global_auxvars(:)
  1189)   type(sec_heat_type), pointer :: mphase_sec_heat_vars(:)
  1190) 
  1191)   PetscInt :: istart, iend  
  1192)   PetscInt :: local_id, ghosted_id
  1193)   ! secondary continuum variables
  1194)   PetscReal :: sec_dencpr
  1195)   PetscErrorCode :: ierr
  1196)   PetscReal, pointer :: ithrm_loc_p(:)
  1197) 
  1198)   patch => realization%patch
  1199)   grid => patch%grid
  1200)   option => realization%option
  1201)   field => realization%field
  1202) 
  1203)   mphase => patch%aux%Mphase
  1204)   mphase_parameter => mphase%mphase_parameter
  1205)   auxvars => mphase%auxvars
  1206)   global_auxvars => patch%aux%Global%auxvars
  1207) 
  1208)   if (option%use_mc) then
  1209)     mphase_sec_heat_vars => patch%aux%SC_heat%sec_heat_vars  
  1210)   endif
  1211) 
  1212)   if (realization%option%compute_mass_balance_new) then
  1213)     call MphaseUpdateMassBalancePatch(realization)
  1214)   endif
  1215) 
  1216)   if (option%use_mc) then
  1217)  
  1218)     call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
  1219)   
  1220)   ! Secondary continuum contribution (Added by SK 06/26/2012)
  1221)   ! only one secondary continuum for now for each primary continuum node
  1222)     do local_id = 1, grid%nlmax  ! For each local node do...
  1223)       ghosted_id = grid%nL2G(local_id)
  1224)       if (associated(patch%imat)) then
  1225)         if (patch%imat(ghosted_id) <= 0) cycle
  1226)       endif
  1227)       iend = local_id*option%nflowdof
  1228)       istart = iend-option%nflowdof+1
  1229)     
  1230)       sec_dencpr = mphase_parameter%dencpr(int(ithrm_loc_p(ghosted_id))) ! secondary rho*c_p same as primary for now
  1231) 
  1232)       call MphaseSecHeatAuxVarCompute(mphase_sec_heat_vars(local_id), &
  1233)                         auxvars(ghosted_id)%auxvar_elem(0), &
  1234)                         global_auxvars(ghosted_id), &
  1235)                         mphase_parameter%ckwet(int(ithrm_loc_p(ghosted_id))), &
  1236)                         sec_dencpr, &
  1237)                         option)
  1238)     enddo   
  1239)     
  1240)     call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
  1241)     
  1242)   endif  
  1243) 
  1244) end subroutine MphaseUpdateSolutionPatch
  1245) 
  1246) ! ************************************************************************** !
  1247) 
  1248) subroutine MphaseUpdateFixedAccumulation(realization)
  1249)   ! 
  1250)   ! Updates the fixed portion of the
  1251)   ! accumulation term
  1252)   ! 
  1253)   ! Author: Chuan Lu
  1254)   ! Date: 05/12/08
  1255)   ! 
  1256) 
  1257)   use Realization_Subsurface_class
  1258)   use Patch_module
  1259) 
  1260)   type(realization_subsurface_type) :: realization
  1261)   
  1262)   type(patch_type), pointer :: cur_patch
  1263)   
  1264)   cur_patch => realization%patch_list%first
  1265)   do
  1266)     if (.not.associated(cur_patch)) exit
  1267)     realization%patch => cur_patch
  1268)     call MphaseUpdateFixedAccumPatch(realization)
  1269)     cur_patch => cur_patch%next
  1270)   enddo
  1271) 
  1272) end subroutine MphaseUpdateFixedAccumulation
  1273) 
  1274) ! ************************************************************************** !
  1275) 
  1276) subroutine MphaseUpdateFixedAccumPatch(realization)
  1277)   ! 
  1278)   ! Updates the fixed portion of the
  1279)   ! accumulation term
  1280)   ! 
  1281)   ! Author: Chuan Lu
  1282)   ! Date: 05/12/08
  1283)   ! 
  1284) 
  1285)   use Realization_Subsurface_class
  1286)   use Patch_module
  1287)   use Option_module
  1288)   use Field_module
  1289)   use Grid_module
  1290)   use Secondary_Continuum_Aux_module
  1291)   use Material_Aux_class
  1292) 
  1293)   implicit none
  1294)   
  1295)   type(realization_subsurface_type) :: realization
  1296)   
  1297)   type(option_type), pointer :: option
  1298)   type(patch_type), pointer :: patch
  1299)   type(grid_type), pointer :: grid
  1300)   type(field_type), pointer :: field
  1301)   type(mphase_parameter_type), pointer :: mphase_parameter
  1302)   type(mphase_auxvar_type), pointer :: auxvars(:)
  1303)   type(global_auxvar_type), pointer :: global_auxvars(:)
  1304)   type(sec_heat_type), pointer :: mphase_sec_heat_vars(:)
  1305)   class(material_auxvar_type), pointer :: material_auxvars(:)  
  1306)   
  1307)   PetscInt :: ghosted_id, local_id, istart, iend !, iphase
  1308)   PetscReal, pointer :: xx_p(:), icap_loc_p(:), iphase_loc_p(:)
  1309)   PetscReal, pointer :: ithrm_loc_p(:), accum_p(:)
  1310)                           
  1311)   PetscErrorCode :: ierr
  1312)   PetscReal :: vol_frac_prim
  1313)     
  1314)   call MphaseUpdateAuxVarsPatch(realization)
  1315) 
  1316)   option => realization%option
  1317)   field => realization%field
  1318)   patch => realization%patch
  1319)   grid => patch%grid
  1320)   
  1321)  
  1322)   mphase_parameter => patch%aux%Mphase%mphase_parameter
  1323)   auxvars => patch%aux%Mphase%auxvars
  1324)   global_auxvars => patch%aux%Global%auxvars
  1325)   mphase_sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
  1326)   material_auxvars => patch%aux%Material%auxvars
  1327)       
  1328)   call VecGetArrayF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
  1329)   call VecGetArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
  1330)   call VecGetArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
  1331)   call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
  1332) 
  1333)   call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  1334) 
  1335)   vol_frac_prim = 1.d0
  1336) 
  1337)   do local_id = 1, grid%nlmax
  1338)     ghosted_id = grid%nL2G(local_id)
  1339)     !geh - Ignore inactive cells with inactive materials
  1340)     if (associated(patch%imat)) then
  1341)       if (patch%imat(ghosted_id) <= 0) cycle
  1342)     endif
  1343)     iend = local_id*option%nflowdof
  1344)     istart = iend-option%nflowdof+1
  1345)     
  1346)     if (option%use_mc) then
  1347)       vol_frac_prim = mphase_sec_heat_vars(local_id)%epsilon
  1348)     endif
  1349)     
  1350) !    iphase = int(iphase_loc_p(ghosted_id))
  1351) !    call MphaseAuxVarCompute_Ninc(xx_p(istart:iend), &
  1352) !                       auxvars(ghosted_id)%auxvar_elem(0), &
  1353) !                       iphase, &
  1354) !                       patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
  1355) !                       realization%fluid_properties,option)
  1356) !    iphase_loc_p(ghosted_id) = iphase
  1357)    ! print *, 'MphaseUpdateFixedAccumPatch1'
  1358)     !if (.not.associated(auxvars(ghosted_id))) print *,'no var'
  1359)     if (.not.associated(mphase_parameter%dencpr)) print *,'no para'
  1360) 
  1361)     call MphaseAccumulation(auxvars(ghosted_id)%auxvar_elem(0), &
  1362)                               global_auxvars(ghosted_id), &
  1363)                               material_auxvars(ghosted_id)%porosity, &
  1364)                               material_auxvars(ghosted_id)%volume, &
  1365)                               mphase_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  1366)                               option,ZERO_INTEGER,vol_frac_prim, &
  1367)                               accum_p(istart:iend))
  1368)   enddo
  1369) 
  1370)   call VecRestoreArrayF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
  1371)   call VecRestoreArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
  1372)   call VecRestoreArrayF90(field%iphas_loc,iphase_loc_p,ierr);CHKERRQ(ierr)
  1373)   call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
  1374) 
  1375)   call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  1376) 
  1377) #if 0
  1378) !  call MphaseNumericalJacobianTest(field%flow_xx,realization)
  1379) #endif
  1380) 
  1381) end subroutine MphaseUpdateFixedAccumPatch
  1382) 
  1383) ! ************************************************************************** !
  1384) 
  1385) subroutine MphaseAccumulation(auxvar,global_auxvar,por,vol,rock_dencpr, &
  1386)                               option,iireac,vol_frac_prim,Res)
  1387)   ! 
  1388)   ! Computes the non-fixed portion of the accumulation
  1389)   ! term for the residual
  1390)   ! 
  1391)   ! Author: Chuan Lu
  1392)   ! Date: 05/12/08
  1393)   ! 
  1394) 
  1395)   use Option_module
  1396)   
  1397)   implicit none
  1398) 
  1399)   type(mphase_auxvar_elem_type) :: auxvar
  1400)   type(option_type) :: option
  1401)   PetscReal Res(1:option%nflowdof) 
  1402)   PetscReal vol,por,rock_dencpr
  1403)   type(global_auxvar_type) :: global_auxvar
  1404)         
  1405)   PetscInt :: ispec, np, iireac
  1406)   PetscReal :: porXvol, mol(option%nflowspec), eng
  1407)   PetscReal :: vol_frac_prim
  1408)   
  1409)  ! if (present(ireac)) iireac=ireac
  1410) 
  1411)   porXvol = por*vol
  1412)       
  1413)   mol=0.d0; eng=0.D0
  1414)   do np = 1, option%nphase
  1415)     do ispec = 1, option%nflowspec  
  1416)       mol(ispec) = mol(ispec) + auxvar%sat(np) * auxvar%den(np) * &
  1417)         auxvar%xmol(ispec + (np-1)*option%nflowspec)
  1418)     enddo
  1419)     eng = eng + auxvar%sat(np) * auxvar%den(np) * auxvar%u(np)
  1420)   enddo
  1421)   mol = mol * porXvol
  1422)  ! if (option%use_isothermal == PETSC_FALSE) &
  1423)   eng = eng * porXvol + (1.d0 - por) * vol * rock_dencpr * auxvar%temp 
  1424) 
  1425) ! Reaction terms here
  1426) ! Note if iireac > 0, then it is the node global index
  1427) 
  1428) !#if 0
  1429)   if (option%ntrandof > 0) then
  1430)     if (iireac > 0) then
  1431)       !H2O
  1432)       mol(1) = mol(1) + vol * global_auxvar%reaction_rate_store(1) &
  1433)         *option%flow_dt*1.D-3
  1434) 
  1435)       !CO2     
  1436)       mol(2) = mol(2) + vol * global_auxvar%reaction_rate_store(2) &
  1437)         *option%flow_dt*1.D-3
  1438)     endif
  1439)   endif
  1440) !#endif
  1441) ! if (option%use_isothermal)then
  1442) !   Res(1:option%nflowdof) = mol(:)
  1443) ! else
  1444)     Res(1:option%nflowdof-1) = vol_frac_prim * mol(:)
  1445)     Res(option%nflowdof) = vol_frac_prim * eng
  1446) 
  1447) ! endif
  1448) end subroutine MphaseAccumulation
  1449) 
  1450) ! ************************************************************************** !
  1451) 
  1452) subroutine MphaseSourceSink(mmsrc,nsrcpara,psrc,tsrc,hsrc,csrc,auxvar,isrctype,Res, &
  1453)                             qsrc_vol,energy_flag,option)
  1454)   ! 
  1455)   ! Computes the source/sink portion for the residual
  1456)   ! 
  1457)   ! Author: Chuan Lu
  1458)   ! Date: 05/12/08
  1459)   ! 
  1460) 
  1461)   use Option_module
  1462)   
  1463)   use EOS_Water_module
  1464) !   use Gas_EOS_module  
  1465)   use co2eos_module
  1466)   use co2_span_wagner_spline_module, only: sw_prop
  1467)   use co2_sw_module, only: co2_sw_interp
  1468)   use co2_span_wagner_module
  1469)   
  1470)   implicit none
  1471) 
  1472)   type(mphase_auxvar_elem_type) :: auxvar
  1473)   type(option_type) :: option
  1474)   PetscReal :: Res(1:option%nflowdof) 
  1475)   PetscReal, pointer :: mmsrc(:)
  1476)   PetscReal :: psrc(option%nphase),tsrc,hsrc,csrc 
  1477)   PetscInt :: isrctype
  1478)   PetscInt :: nsrcpara
  1479)   PetscBool :: energy_flag
  1480)   PetscReal :: qsrc_vol(option%nphase) ! volumetric rate of injection/extraction for each phase
  1481)      
  1482)   PetscReal, allocatable :: msrc(:)
  1483)   PetscReal :: dw_kg, dw_mol,dddt,dddp
  1484)   PetscReal :: enth_src_h2o, enth_src_co2 
  1485)   PetscReal :: rho, fg, dfgdp, dfgdt, eng, dhdt, dhdp, visc, dvdt, dvdp, xphi
  1486)   PetscReal :: ukvr, v_darcy, dq, dphi
  1487)   PetscReal :: well_status, well_diameter
  1488)   PetscReal :: pressure_bh, well_factor, pressure_max, pressure_min
  1489)   PetscReal :: well_inj_water, well_inj_co2
  1490)   PetscInt :: np
  1491)   PetscInt :: iflag
  1492)   PetscErrorCode :: ierr
  1493)   
  1494)   Res = 0.D0
  1495)   allocate(msrc(nsrcpara))
  1496)   msrc = mmsrc(1:nsrcpara)
  1497) 
  1498) ! if (present(ireac)) iireac=ireac
  1499) ! if (energy_flag) then
  1500) !   Res(option%nflowdof) = Res(option%nflowdof) + hsrc * option%flow_dt   
  1501) ! endif         
  1502) 
  1503)   qsrc_vol(:) = 0.d0
  1504)   
  1505)   select case(isrctype)
  1506)     case(MASS_RATE_SS)
  1507)       msrc(1) =  msrc(1) / FMWH2O
  1508)       msrc(2) =  msrc(2) / FMWCO2
  1509)       if (msrc(1) > 0.d0) then ! H2O injection
  1510)         call EOSWaterDensity(tsrc,auxvar%pres,dw_kg,dw_mol,ierr)
  1511)         call EOSWaterEnthalpy(tsrc,auxvar%pres,enth_src_h2o,ierr)
  1512)         ! J/kmol -> whatever units
  1513)         enth_src_h2o = enth_src_h2o * option%scale
  1514)                                      
  1515) !           units: dw_mol [mol/dm^3]; dw_kg [kg/m^3]
  1516) !           qqsrc = qsrc1/dw_mol ! [kmol/s (mol/dm^3 = kmol/m^3)]
  1517)         Res(jh2o) = Res(jh2o) + msrc(1)*(1.d0-csrc)*option%flow_dt
  1518)         Res(jco2) = Res(jco2) + msrc(1)*csrc*option%flow_dt
  1519)         if (energy_flag) Res(option%nflowdof) = Res(option%nflowdof) + &
  1520)           msrc(1)*enth_src_h2o*option%flow_dt
  1521)           
  1522) !       print *,'soure/sink: ',msrc,csrc,enth_src_h2o,option%flow_dt,option%nflowdof
  1523) 
  1524)         ! store volumetric rate for ss_fluid_fluxes()
  1525)         qsrc_vol(1) = msrc(1)/dw_mol
  1526)       elseif (msrc(1) < 0.d0) then ! H2O extraction
  1527)         call EOSWaterDensity(auxvar%temp,auxvar%pres,dw_kg,dw_mol,ierr)
  1528)         call EOSWaterEnthalpy(auxvar%temp,auxvar%pres,enth_src_h2o,ierr)
  1529)         ! J/kmol -> whatever
  1530)         enth_src_h2o = enth_src_h2o * option%scale                            
  1531) !           units: dw_mol [mol/dm^3]; dw_kg [kg/m^3]
  1532) !           qqsrc = qsrc1/dw_mol ! [kmol/s (mol/dm^3 = kmol/m^3)]
  1533)         Res(jh2o) = Res(jh2o) + msrc(1)*(1.d0-csrc)*option%flow_dt
  1534)         Res(jco2) = Res(jco2) + msrc(1)*csrc*option%flow_dt
  1535)         if (energy_flag) Res(option%nflowdof) = Res(option%nflowdof) + &
  1536)           msrc(1)*enth_src_h2o*option%flow_dt
  1537)           
  1538) !       print *,'soure/sink: ',msrc,csrc,enth_src_h2o,option%flow_dt,option%nflowdof
  1539) 
  1540)         ! store volumetric rate for ss_fluid_fluxes()
  1541)         qsrc_vol(1) = msrc(1)/dw_mol
  1542)       endif  
  1543)     
  1544)       if (msrc(2) > 0.d0) then ! CO2 injection
  1545) !       call printErrMsg(option,"concentration source not yet implemented in Mphase")
  1546)         if (option%co2eos == EOS_SPAN_WAGNER) then
  1547)          !  span-wagner
  1548)           rho = auxvar%den(jco2)*FMWCO2  
  1549)           select case(option%itable)  
  1550)             case(0,1,2,4,5)
  1551)               if (option%itable >=4) then
  1552)                 call co2_sw_interp(auxvar%pres*1.D-6, &
  1553)                   tsrc,rho,dddt,dddp,fg,dfgdp,dfgdt, &
  1554)                   eng,enth_src_co2,dhdt,dhdp,visc,dvdt,dvdp,option%itable)
  1555)               else
  1556)                 iflag = 1
  1557)                 call co2_span_wagner(auxvar%pres*1.D-6, &
  1558)                   tsrc+273.15D0,rho,dddt,dddp,fg,dfgdp,dfgdt, &
  1559)                   eng,enth_src_co2,dhdt,dhdp,visc,dvdt,dvdp,iflag,option%itable)
  1560)               endif 
  1561)             case(3) 
  1562)               call sw_prop(tsrc,auxvar%pres*1.D-6,rho, &
  1563)                      enth_src_co2, eng, fg)
  1564)           end select     
  1565) 
  1566)          !  units: rho [kg/m^3]; csrc1 [kmol/s]
  1567)           enth_src_co2 = enth_src_co2 * FMWCO2
  1568)           
  1569)           ! store volumetric rate for ss_fluid_fluxes()
  1570)           ! qsrc_phase [m^3/sec] = msrc [kmol/sec] / [kmol/m^3]
  1571)           qsrc_vol(2) = msrc(2)/auxvar%den(jco2)
  1572) 
  1573)         else if (option%co2eos == EOS_MRK) then
  1574) ! MRK eos [modified version from  Kerrick and Jacobs (1981) and Weir et al. (1996).]
  1575)           call CO2(tsrc,auxvar%pres, rho,fg, xphi,enth_src_co2)
  1576)           !geh: this is never used as the conversion is performed inside 
  1577)           !     reactive transport
  1578)           !qsrc_phase(2) = msrc(2)*rho/FMWCO2
  1579)           enth_src_co2 = enth_src_co2*FMWCO2*option%scale
  1580)         else
  1581)           call printErrMsg(option,'pflow mphase ERROR: Need specify CO2 EOS')
  1582)         endif
  1583)               
  1584)         Res(jco2) = Res(jco2) + msrc(2)*option%flow_dt
  1585)         if (energy_flag) Res(option%nflowdof) = Res(option%nflowdof) + msrc(2) * &
  1586)           enth_src_co2 *option%flow_dt
  1587)         endif
  1588) 
  1589)     case(WELL_SS) ! production well
  1590)      !if node pessure is lower than the given extraction pressure, shut it down
  1591)     ! Flow term
  1592) !  well parameter explaination
  1593) !   1. well status. 1 injection; -1 production; 0 shut in
  1594) !                   2 rate controled injection (same as rate_ss, with max pressure control, not completed yet) 
  1595) !                  -2 rate controled production(not implemented for now) 
  1596) !
  1597) !   2. well factor [m^3],  the effective permeability [m^2/s]
  1598) !   3. bottomhole pressure:  [Pa]
  1599) !   4. max pressure: [Pa]
  1600) !   5. min pressure: [Pa]   
  1601) !   6. conc. of water 
  1602) !   7. conc. of Co2 (1 - conc. of water)
  1603) !   8. well diameter, not used now
  1604) !   9. skin factor, not used now
  1605) 
  1606)       well_status = msrc(1)
  1607)       well_factor = msrc(2)
  1608)       pressure_bh = msrc(3)
  1609)       pressure_max = msrc(4)
  1610)       pressure_min = msrc(5)
  1611)       well_inj_water = msrc(6)
  1612)       well_inj_co2 = msrc(7)
  1613)     
  1614) !     if (pressure_min < 0D0) pressure_min = 0D0 !not limited by pressure lower bound   
  1615) 
  1616)     ! production well (well status = -1)
  1617)       if ( dabs(well_status + 1.D0) < 1.D-1) then
  1618)         if (auxvar%pres > pressure_min) then
  1619)           Dq = well_factor 
  1620)           do np = 1, option%nphase
  1621)             dphi = auxvar%pres - auxvar%pc(np) - pressure_bh
  1622)             if (dphi >= 0.D0) then ! outflow only
  1623)               ukvr = auxvar%kvr(np)
  1624)               if (ukvr < 1.e-20) ukvr = 0.D0
  1625)               v_darcy = 0.D0
  1626)               if (ukvr*Dq > floweps) then
  1627)                 v_darcy = Dq * ukvr * dphi
  1628)                 ! store volumetric rate for ss_fluid_fluxes()
  1629)                 qsrc_vol(1) = -1.d0*v_darcy
  1630)                 Res(1) = Res(1) - v_darcy* auxvar%den(np)* &
  1631)                   auxvar%xmol((np-1)*option%nflowspec+1)*option%flow_dt
  1632)                 Res(2) = Res(2) - v_darcy* auxvar%den(np)* &
  1633)                   auxvar%xmol((np-1)*option%nflowspec+2)*option%flow_dt
  1634)                 if (energy_flag) Res(3) = Res(3) - v_darcy * auxvar%den(np)* &
  1635)                   auxvar%h(np)*option%flow_dt
  1636)               ! print *,'produce: ',np,v_darcy
  1637)               endif
  1638)             endif
  1639)           enddo
  1640)         endif
  1641)       endif 
  1642)      !print *,'well-prod: ',  auxvar%pres,psrc(1), res
  1643)     ! injection well (well status = 2)
  1644)       if ( dabs(well_status - 2.D0) < 1.D-1) then
  1645) 
  1646)         call EOSWaterDensity(tsrc,auxvar%pres,dw_kg,dw_mol,ierr)
  1647)         call EOSWaterEnthalpy(tsrc,auxvar%pres,enth_src_h2o,ierr)
  1648)         ! J/kmol -> whatever units
  1649)         enth_src_h2o = enth_src_h2o * option%scale
  1650) 
  1651)         Dq = msrc(2) ! well parameter, read in input file
  1652)                       ! Take the place of 2nd parameter 
  1653)         ! Flow term
  1654)         if ( auxvar%pres < pressure_max)then  
  1655)           do np = 1, option%nphase
  1656)             dphi = pressure_bh - auxvar%pres + auxvar%pc(np)
  1657)             if (dphi >= 0.D0) then ! outflow only
  1658)               ukvr = auxvar%kvr(np)
  1659)               v_darcy = 0.D0
  1660)               if (ukvr*Dq>floweps) then
  1661)                 v_darcy = Dq * ukvr * dphi
  1662)                 ! store volumetric rate for ss_fluid_fluxes()
  1663)                 qsrc_vol(1) = v_darcy
  1664)                 Res(1) = Res(1) + v_darcy* auxvar%den(np)* &
  1665) !                 auxvar%xmol((np-1)*option%nflowspec+1) * option%flow_dt
  1666)                   well_inj_water * option%flow_dt
  1667)                 Res(2) = Res(2) + v_darcy* auxvar%den(np)* &
  1668) !                 auxvar%xmol((np-1)*option%nflowspec+2) * option%flow_dt
  1669)                   well_inj_co2 * option%flow_dt
  1670) !               if (energy_flag) Res(3) = Res(3) + v_darcy*auxvar%den(np)*auxvar%h(np)*option%flow_dt
  1671)                 if (energy_flag) Res(3) = Res(3) + v_darcy*auxvar%den(np) * &
  1672)                   enth_src_h2o*option%flow_dt
  1673)                 
  1674) !               print *,'inject: ',np,v_darcy
  1675)               endif
  1676)             endif
  1677)           enddo
  1678)         endif
  1679)       endif    
  1680)     case default
  1681)       print *,'Unrecognized Source/Sink condition: ', isrctype 
  1682)   end select      
  1683)   deallocate(msrc)
  1684)       
  1685) end subroutine MphaseSourceSink
  1686) 
  1687) ! ************************************************************************** !
  1688) 
  1689) subroutine MphaseFlux(auxvar_up,por_up,tor_up,sir_up,dd_up,perm_up,Dk_up, &
  1690)                         auxvar_dn,por_dn,tor_dn,sir_dn,dd_dn,perm_dn,Dk_dn, &
  1691)                         area,dist_gravity,upweight, &
  1692)                         option,vv_darcy,vol_frac_prim,Res)
  1693)   ! 
  1694)   ! Computes the internal flux terms for the residual
  1695)   ! 
  1696)   ! Author: Chuan Lu
  1697)   ! Date: 05/12/08
  1698)   ! 
  1699)   use Option_module                              
  1700)   
  1701)   implicit none
  1702)   
  1703)   type(mphase_auxvar_elem_type) :: auxvar_up, auxvar_dn
  1704)   type(option_type) :: option
  1705)   PetscReal :: sir_up(:), sir_dn(:)
  1706)   PetscReal :: por_up, por_dn
  1707)   PetscReal :: tor_up, tor_dn
  1708)   PetscReal :: dd_up, dd_dn
  1709)   PetscReal :: perm_up, perm_dn
  1710)   PetscReal :: Dk_up, Dk_dn
  1711)   PetscReal :: vv_darcy(:),area,vol_frac_prim
  1712)   PetscReal :: Res(1:option%nflowdof) 
  1713)   PetscReal :: dist_gravity  ! distance along gravity vector
  1714)      
  1715)   PetscInt :: ispec, np, ind
  1716)   PetscReal :: fluxm(option%nflowspec),fluxe,q, v_darcy
  1717)   PetscReal :: uh,uxmol(1:option%nflowspec),ukvr,difff,diffdp, DK,Dq
  1718)   PetscReal :: upweight,density_ave,cond,gravity,dphi
  1719)      
  1720)   Dq = (perm_up * perm_dn)/(dd_up*perm_dn + dd_dn*perm_up)
  1721) #if 0
  1722) ! This factor 2/3 is multiplied to get bulk perm k=delta^3/12/l, karra 05/14/2013   
  1723)   if (option%use_mc) Dq = Dq*2.d0/3.d0*vol_frac_prim
  1724) #endif
  1725)   diffdp = (por_up*tor_up * por_dn*tor_dn) / &
  1726)     (dd_dn*por_up*tor_up + dd_up*por_dn*tor_dn)*area*vol_frac_prim 
  1727)   
  1728)   fluxm = 0.D0
  1729)   fluxe = 0.D0
  1730)   vv_darcy =0.D0 
  1731)   
  1732) ! Flow term
  1733)   do np = 1, option%nphase
  1734)     
  1735) !   if (auxvar_up%sat(np) > sir_up(np) .or. auxvar_dn%sat(np) > sir_dn(np)) then
  1736)     if ((auxvar_up%kvr(np) + auxvar_dn%kvr(np)) > eps) then
  1737)       upweight = dd_dn/(dd_up+dd_dn)
  1738)       if (auxvar_up%sat(np) < eps) then 
  1739)         upweight = 0.d0
  1740)       else if (auxvar_dn%sat(np) < eps) then 
  1741)         upweight = 1.d0
  1742)       endif
  1743)       density_ave = upweight*auxvar_up%den(np) + (1.D0-upweight)*auxvar_dn%den(np) 
  1744)         
  1745)       gravity = (upweight*auxvar_up%den(np) * auxvar_up%avgmw(np) + &
  1746)              (1.D0-upweight)*auxvar_dn%den(np) * auxvar_dn%avgmw(np)) &
  1747)              * dist_gravity
  1748) 
  1749)       dphi = auxvar_up%pres - auxvar_dn%pres &
  1750)              - auxvar_up%pc(np) + auxvar_dn%pc(np) &
  1751)              + gravity
  1752) 
  1753)       v_darcy = 0.D0
  1754)       ukvr = 0.D0
  1755)       uh = 0.D0
  1756)       uxmol = 0.D0
  1757) 
  1758)       ! note uxmol only contains one phase xmol
  1759)       ! upstream weighting
  1760)       if (dphi >= 0.D0) then
  1761)         ukvr = auxvar_up%kvr(np)
  1762)         ! if (option%use_isothermal == PETSC_FALSE) &
  1763)         uh = auxvar_up%h(np)
  1764)         uxmol(1:option%nflowspec) = &
  1765)           auxvar_up%xmol((np-1)*option%nflowspec + 1 : np*option%nflowspec)
  1766)       else
  1767)         ukvr = auxvar_dn%kvr(np)
  1768)       ! if (option%use_isothermal == PETSC_FALSE) &
  1769)         uh = auxvar_dn%h(np)
  1770)         uxmol(1:option%nflowspec) = &
  1771)           auxvar_dn%xmol((np-1)*option%nflowspec + 1 : np*option%nflowspec)
  1772)       endif
  1773) 
  1774)       if (ukvr > floweps) then
  1775)         v_darcy = Dq * ukvr * dphi
  1776)         vv_darcy(np) = v_darcy
  1777)         q = v_darcy * area
  1778)         
  1779)         do ispec=1, option%nflowspec 
  1780)           fluxm(ispec)=fluxm(ispec) + q * density_ave * uxmol(ispec)
  1781)         enddo
  1782)       ! if (option%use_isothermal == PETSC_FALSE) &
  1783)         fluxe = fluxe + q*density_ave*uh 
  1784)       endif
  1785)     endif
  1786) 
  1787) !   Diffusion term   
  1788) !   Note : average rule may not be correct
  1789) 
  1790) #ifdef PCL
  1791) 
  1792)     if ((auxvar_up%sat(np) >= 1.d0) .and. (auxvar_dn%sat(np) >= 1.d0) .or. &
  1793)     (auxvar_up%sat(np) <= 0.d0) .and. (auxvar_dn%sat(np) <= 0.d0) &
  1794)     ) then
  1795) !     single phase
  1796)       difff = diffdp * 0.25D0*(auxvar_up%sat(np) + auxvar_dn%sat(np))* &
  1797)              (auxvar_up%den(np) + auxvar_dn%den(np))
  1798)       do ispec=1, option%nflowspec
  1799)         ind = ispec + (np-1)*option%nflowspec
  1800)         fluxm(ispec) = fluxm(ispec) + difff * .5D0 * &
  1801)                 (auxvar_up%diff(ind) + auxvar_dn%diff(ind))* &
  1802)                 (auxvar_up%xmol(ind) - auxvar_dn%xmol(ind))
  1803) !       print *,'mphaseflux1: ',ind,auxvar_up%diff(ind),auxvar_dn%diff(ind)
  1804)       enddo
  1805)       
  1806)     else
  1807) 
  1808) !     two-phase
  1809)       difff = diffdp * 0.5D0*(auxvar_up%den(np) + auxvar_dn%den(np))
  1810)       do ispec=1, option%nflowspec
  1811)         ind = ispec + (np-1)*option%nflowspec
  1812)         
  1813)         if (auxvar_up%xmol(ind) > auxvar_dn%xmol(ind)) then
  1814)           upweight = 1.d0
  1815)         else
  1816)           upweight = 0.d0
  1817)         endif
  1818)         
  1819)         fluxm(ispec) = fluxm(ispec) + difff * &
  1820)           0.5D0 * (auxvar_up%diff(ind) + auxvar_dn%diff(ind))* &
  1821)           (upweight*auxvar_up%sat(np)+(1.d0-upweight)*auxvar_dn%sat(np))* &
  1822)           (auxvar_up%xmol(ind) - auxvar_dn%xmol(ind))
  1823) !       print *,'mphaseflux1: ',ind,auxvar_up%diff(ind),auxvar_dn%diff(ind)
  1824)       enddo
  1825)     endif
  1826)     
  1827) #else
  1828) 
  1829) !   print *,'mphaseflux: ',np,auxvar_up%sat(np),auxvar_dn%sat(np),eps, &
  1830) !     auxvar_up%den(np),auxvar_dn%den(np),diffdp
  1831) 
  1832)     if ((auxvar_up%sat(np) > eps) .and. (auxvar_dn%sat(np) > eps)) then
  1833)       difff = diffdp * 0.25D0*(auxvar_up%sat(np) + auxvar_dn%sat(np))* &
  1834)              (auxvar_up%den(np) + auxvar_dn%den(np))
  1835)       do ispec=1, option%nflowspec
  1836)         ind = ispec + (np-1)*option%nflowspec
  1837)         fluxm(ispec) = fluxm(ispec) + difff * .5D0 * &
  1838)                 (auxvar_up%diff(ind) + auxvar_dn%diff(ind))* &
  1839)                 (auxvar_up%xmol(ind) - auxvar_dn%xmol(ind))
  1840) !       print *,'mphaseflux1: ',ind,auxvar_up%diff(ind),auxvar_dn%diff(ind)
  1841)       enddo
  1842)     endif
  1843) 
  1844) #endif
  1845) 
  1846)   enddo
  1847) 
  1848) ! conduction term
  1849)   !if (option%use_isothermal == PETSC_FALSE) then     
  1850)   Dk = (Dk_up * Dk_dn) / (dd_dn*Dk_up + dd_up*Dk_dn)
  1851)   cond = vol_frac_prim * Dk*area * (auxvar_up%temp-auxvar_dn%temp)
  1852)   fluxe = fluxe + cond
  1853)  ! end if
  1854) 
  1855)   !if (option%use_isothermal)then
  1856)   !   Res(1:option%nflowdof) = fluxm(:) * option%flow_dt
  1857)  ! else
  1858)   Res(1:option%nflowdof-1) = fluxm(:) * option%flow_dt
  1859)   Res(option%nflowdof) = fluxe * option%flow_dt
  1860)  ! end if
  1861)  ! note: Res is the flux contribution, for node 1 R = R + Res_FL
  1862)  !                                              2 R = R - Res_FL  
  1863) 
  1864) end subroutine MphaseFlux
  1865) 
  1866) ! ************************************************************************** !
  1867) 
  1868) subroutine MphaseBCFlux(ibndtype,auxvars,auxvar_up,auxvar_dn, &
  1869)      por_dn,tor_dn,sir_dn,dd_up,perm_dn,Dk_dn, &
  1870)      area,dist_gravity,option,vv_darcy,vol_frac_prim,Res)
  1871)   ! 
  1872)   ! Computes boundary flux terms for the residual function
  1873)   ! 
  1874)   ! Author: Chuan Lu
  1875)   ! Date: 05/12/08
  1876)   ! 
  1877)   use Option_module
  1878)   
  1879)   implicit none
  1880)   
  1881)   PetscInt :: ibndtype(:)
  1882)   type(mphase_auxvar_elem_type) :: auxvar_up, auxvar_dn
  1883)   type(option_type) :: option
  1884)   PetscReal :: dd_up, sir_dn(:)
  1885)   PetscReal :: auxvars(:) ! from aux_real_var array
  1886)   PetscReal :: por_dn,perm_dn,Dk_dn,tor_dn
  1887)   PetscReal :: vv_darcy(:), area, vol_frac_prim
  1888)   PetscReal :: Res(1:option%nflowdof) 
  1889)   
  1890)   PetscReal :: dist_gravity  ! distance along gravity vector
  1891)           
  1892)   PetscInt :: ispec, np
  1893)   PetscReal :: fluxm(option%nflowspec),fluxe,q,density_ave, v_darcy
  1894)   PetscReal :: uh,uxmol(1:option%nflowspec),ukvr,diff,diffdp,DK,Dq
  1895)   PetscReal :: upweight,cond,gravity,dphi
  1896)   PetscReal :: Neuman_total_mass_flux, Neuman_mass_flux_spec(option%nflowspec)
  1897)   PetscReal :: mol_total_flux(option%nphase)
  1898)   PetscInt :: pressure_bc_type
  1899) 
  1900)   fluxm = 0.d0
  1901)   fluxe = 0.d0
  1902)   v_darcy = 0.d0
  1903)   vv_darcy = 0.d0
  1904)   density_ave = 0.d0
  1905)   q = 0.d0
  1906)   ukvr = 0.d0
  1907)   uh = 0.d0
  1908) 
  1909)   mol_total_flux = 0.d0
  1910)   uxmol = 0.d0
  1911) 
  1912)   diffdp = por_dn*tor_dn/dd_up*area*vol_frac_prim
  1913) 
  1914)   ! Flow   
  1915)   do np = 1, option%nphase
  1916)     pressure_bc_type = ibndtype(MPH_PRESSURE_DOF)
  1917) 
  1918)     select case(ibndtype(MPH_PRESSURE_DOF))
  1919)         ! figure out the direction of flow
  1920)       case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC)
  1921)         Dq = perm_dn / dd_up
  1922) #if 0        
  1923) ! This factor 2/3 is multiplied to get bulk perm k=delta^3/12/l, karra 05/14/2013   
  1924)         if (option%use_mc) Dq = Dq*2.d0/3.d0*vol_frac_prim
  1925) #endif
  1926)         ! Flow term
  1927)         ukvr = 0.D0
  1928)         v_darcy = 0.D0
  1929) 
  1930) !       print *,'Seepage BC: pc/sat ',np, &
  1931) !         auxvar_up%pc(np),auxvar_dn%pc(np),auxvar_up%sat(np),auxvar_dn%sat(np)
  1932) 
  1933) !      if (auxvar_up%sat(np) > sir_dn(np) .or. auxvar_dn%sat(np) > sir_dn(np)) then
  1934)        if ((auxvar_up%kvr(np) + auxvar_dn%kvr(np)) > eps) then
  1935)           upweight = 1.D0
  1936)           if (auxvar_up%sat(np) < eps) then 
  1937)             upweight = 0.d0
  1938)           else if (auxvar_dn%sat(np) < eps) then 
  1939)             upweight = 1.d0
  1940)           endif
  1941)           density_ave = upweight*auxvar_up%den(np) + (1.D0-upweight)*auxvar_dn%den(np)
  1942)            
  1943)           gravity = (upweight*auxvar_up%den(np) * auxvar_up%avgmw(np) + &
  1944)                 (1.D0-upweight)*auxvar_dn%den(np) * auxvar_dn%avgmw(np)) &
  1945)                 * dist_gravity
  1946)        
  1947)           dphi = auxvar_up%pres - auxvar_dn%pres &
  1948)                 - auxvar_up%pc(np) + auxvar_dn%pc(np) + gravity
  1949) 
  1950) !         print *,'Seepage BC: press ',np,auxvar_up%pres,auxvar_dn%pres,dphi,gravity
  1951) 
  1952)           if ((pressure_bc_type == SEEPAGE_BC .or. &
  1953)             pressure_bc_type == CONDUCTANCE_BC ) .and. np == 2) then
  1954)               ! flow in         ! boundary cell is <= pref
  1955)             if (dphi > 0.d0) then
  1956)               dphi = 0.d0
  1957)             endif
  1958)           endif
  1959) 
  1960)           if (dphi >= 0.D0) then
  1961)             ukvr = auxvar_up%kvr(np)
  1962)           else
  1963)             ukvr = auxvar_dn%kvr(np)
  1964)           endif
  1965)      
  1966)           if (ukvr*Dq > floweps) then
  1967)             v_darcy = Dq * ukvr * dphi
  1968)           endif
  1969) 
  1970) !         print *,'Seepage: vD/kvr/dphi ',np,V_darcy,ukvr,Dq,dphi
  1971)         endif
  1972) 
  1973)         q = v_darcy * area 
  1974)         vv_darcy(np) = v_darcy
  1975) 
  1976)         uh = 0.D0
  1977)         uxmol = 0.D0
  1978)         mol_total_flux(np) = q*density_ave  
  1979)         if (v_darcy >= 0.D0) then
  1980) !     if (option%use_isothermal == PETSC_FALSE) &
  1981)           uh = auxvar_up%h(np)
  1982)           uxmol(:) = auxvar_up%xmol((np-1)*option%nflowspec+1 : np * option%nflowspec)
  1983)         else
  1984) !     if (option%use_isothermal == PETSC_FALSE) &
  1985)           uh = auxvar_dn%h(np)
  1986)           uxmol(:) = auxvar_dn%xmol((np-1)*option%nflowspec+1 : np * option%nflowspec)
  1987)         endif
  1988)  
  1989)      
  1990)       case(NEUMANN_BC)
  1991)         v_darcy = 0.D0
  1992)         if (dabs(auxvars(1)) > floweps) then
  1993)           Neuman_total_mass_flux = auxvars(MPH_PRESSURE_DOF)
  1994)           if (v_darcy > 0.d0) then 
  1995)             density_ave = auxvar_up%den(np)
  1996)           else 
  1997)             density_ave = auxvar_dn%den(np)
  1998)           endif
  1999)           if (np == 1) then
  2000)             Neuman_mass_flux_spec(np) = &
  2001)             Neuman_total_mass_flux * (1.D0-auxvars(MPH_CONCENTRATION_DOF))
  2002)             uxmol(1) = 1.D0; uxmol(2)=0.D0
  2003)             mol_total_flux(np) = Neuman_mass_flux_spec(np)/FMWH2O
  2004)             uh = auxvar_dn%h(np)
  2005)           else
  2006)             Neuman_mass_flux_spec(np) = &
  2007)             Neuman_total_mass_flux * auxvars(MPH_CONCENTRATION_DOF)
  2008)             uxmol(1) = 0.D0; uxmol(2) = 1.D0
  2009)             mol_total_flux(np) = Neuman_mass_flux_spec(np)/FMWCO2
  2010)             uh = auxvar_dn%h(np)
  2011)           endif
  2012)           vv_darcy(np) = mol_total_flux(np)/density_ave
  2013)         endif
  2014) 
  2015)       case(ZERO_GRADIENT_BC)
  2016) 
  2017)     end select
  2018) 
  2019)     do ispec=1, option%nflowspec 
  2020)       fluxm(ispec) = fluxm(ispec) + mol_total_flux(np)*uxmol(ispec)
  2021)     enddo
  2022)       !if (option%use_isothermal == PETSC_FALSE) &
  2023)     fluxe = fluxe + mol_total_flux(np)*uh
  2024) !   print *,'FLBC', ibndtype(1),np, ukvr, v_darcy, uh, uxmol, mol_total_flux
  2025)   enddo
  2026)   
  2027) ! Diffusion term   
  2028)   select case(ibndtype(MPH_CONCENTRATION_DOF))
  2029)     case(DIRICHLET_BC) 
  2030)   ! if (auxvar_up%sat > eps .and. auxvar_dn%sat > eps) then
  2031)      !diff = diffdp * 0.25D0*(auxvar_up%sat+auxvar_dn%sat)*(auxvar_up%den+auxvar_dn%den)
  2032)       do np = 1, option%nphase
  2033)         if (auxvar_up%sat(np)>eps .and. auxvar_dn%sat(np) > eps) then
  2034)           diff = diffdp * 0.25D0*(auxvar_up%sat(np)+auxvar_dn%sat(np))* &
  2035)                     (auxvar_up%den(np)+auxvar_up%den(np))
  2036)           do ispec = 1, option%nflowspec
  2037)             fluxm(ispec) = fluxm(ispec) + &
  2038)               diff * auxvar_dn%diff((np-1)* option%nflowspec+ispec)* &
  2039)               (auxvar_up%xmol((np-1)* option%nflowspec+ispec) &
  2040)               -auxvar_dn%xmol((np-1)* option%nflowspec+ispec))
  2041)           enddo
  2042)         endif         
  2043)       enddo
  2044)      
  2045)   end select
  2046) 
  2047) ! Conduction term
  2048) ! if (option%use_isothermal == PETSC_FALSE) then
  2049)     select case(ibndtype(MPH_TEMPERATURE_DOF))
  2050)       case(DIRICHLET_BC)
  2051)         Dk =  Dk_dn / dd_up
  2052)         cond = vol_frac_prim * Dk*area*(auxvar_up%temp - auxvar_dn%temp)
  2053)         fluxe = fluxe + cond
  2054)       case(NEUMANN_BC)
  2055)         fluxe = fluxe + auxvars(MPH_TEMPERATURE_DOF)*area*option%scale
  2056) 	  ! auxvars(MPH_TEMPERATURE_DOF) stores heat flux, 1.d-6 is to convert
  2057) 	  ! from W to MW, Added by Satish Karra, LANL 10/05/11
  2058)       case(ZERO_GRADIENT_BC)
  2059)       ! No change in fluxe
  2060)     end select
  2061) !   print *, fluxe, auxvars
  2062) ! end if
  2063) 
  2064)   Res(1:option%nflowspec) = fluxm(:) * option%flow_dt
  2065)   Res(option%nflowdof) = fluxe * option%flow_dt
  2066) 
  2067) end subroutine MphaseBCFlux
  2068) 
  2069) ! ************************************************************************** !
  2070) 
  2071) subroutine MphaseResidual(snes,xx,r,realization,ierr)
  2072)   ! 
  2073)   ! Computes the residual equation
  2074)   ! 
  2075)   ! Author: Glenn Hammond
  2076)   ! Date: 12/10/07
  2077)   ! 
  2078) 
  2079)   use Realization_Subsurface_class
  2080)   use Patch_module
  2081)   use Discretization_module
  2082)   use Field_module
  2083)   use Option_module
  2084)   use Grid_module
  2085)   use Material_module
  2086)   use Variables_module, only : PERMEABILITY_X, PERMEABILITY_Y, PERMEABILITY_Z
  2087) 
  2088)   implicit none
  2089) 
  2090)   SNES :: snes
  2091)   Vec :: xx
  2092)   Vec :: r
  2093)   type(realization_subsurface_type) :: realization
  2094)   PetscErrorCode :: ierr
  2095)   
  2096)   type(discretization_type), pointer :: discretization
  2097)   type(option_type), pointer :: option
  2098)   type(grid_type), pointer :: grid
  2099)   type(field_type), pointer :: field
  2100)   type(patch_type), pointer :: patch
  2101)   PetscInt :: ichange, i  
  2102) 
  2103)   field => realization%field
  2104)   grid => realization%patch%grid
  2105)   option => realization%option
  2106)   discretization => realization%discretization
  2107)   patch => realization%patch
  2108)  
  2109) !  call DiscretizationGlobalToLocal(discretization,xx,field%flow_xx_loc,NFLOWDOF)
  2110)   call DiscretizationLocalToLocal(discretization,field%iphas_loc,field%iphas_loc,ONEDOF)
  2111)  ! check initial guess -----------------------------------------------
  2112)   ierr = MphaseInitGuessCheck(realization)
  2113)   if (ierr<0)then
  2114)     !ierr = PETSC_ERR_ARG_OUTOFRANGE
  2115)     if (option%myrank==0) print *,'table out of range: ',ierr
  2116)     call SNESSetFunctionDomainError(snes,ierr);CHKERRQ(ierr)
  2117)     return
  2118)   endif 
  2119)   ! end check ---------------------------------------------------------
  2120) 
  2121) 
  2122)   ! Variable switching-------------------------------------------------
  2123)   call MphaseVarSwitchPatch(xx, realization, ZERO_INTEGER, ichange)
  2124)   call MPI_Allreduce(ichange,i,ONE_INTEGER_MPI,MPIU_INTEGER, &
  2125)                       MPI_MIN,option%mycomm,ierr)
  2126)   ichange = i 
  2127)   if (ichange < 0) then
  2128)     call SNESSetFunctionDomainError(snes,ierr);CHKERRQ(ierr)
  2129)     return
  2130)   endif
  2131) ! end switching ------------------------------------------------------
  2132) 
  2133)   ! Communication -----------------------------------------
  2134)   ! These 3 must be called before MphaseUpdateAuxVars()
  2135)   call DiscretizationGlobalToLocal(discretization,xx,field%flow_xx_loc,NFLOWDOF)
  2136)   call DiscretizationLocalToLocal(discretization,field%iphas_loc,field%iphas_loc,ONEDOF)
  2137)   call DiscretizationLocalToLocal(discretization,field%icap_loc,field%icap_loc,ONEDOF)
  2138) 
  2139)   call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2140)                                PERMEABILITY_X,ZERO_INTEGER)
  2141)   call DiscretizationLocalToLocal(discretization,field%work_loc, &
  2142)                                   field%work_loc,ONEDOF)
  2143)   call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2144)                                PERMEABILITY_X,ZERO_INTEGER)
  2145)   call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2146)                                PERMEABILITY_Y,ZERO_INTEGER)
  2147)   call DiscretizationLocalToLocal(discretization,field%work_loc, &
  2148)                                   field%work_loc,ONEDOF)
  2149)   call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2150)                                PERMEABILITY_Y,ZERO_INTEGER)
  2151)   call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2152)                                PERMEABILITY_Z,ZERO_INTEGER)
  2153)   call DiscretizationLocalToLocal(discretization,field%work_loc, &
  2154)                                   field%work_loc,ONEDOF)
  2155)   call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2156)                                PERMEABILITY_Z,ZERO_INTEGER)
  2157)   
  2158)   call DiscretizationLocalToLocal(discretization,field%ithrm_loc,field%ithrm_loc,ONEDOF)
  2159)   
  2160)   call MphaseResidualPatch(snes,xx,r,realization,ierr)
  2161) 
  2162) end subroutine MphaseResidual
  2163) 
  2164) ! ************************************************************************** !
  2165) 
  2166) subroutine MphaseVarSwitchPatch(xx, realization, icri, ichange)
  2167)   ! 
  2168)   ! Computes the residual equation at patch level
  2169)   ! 
  2170)   ! Author: Chuan Lu
  2171)   ! Date: 3/10/08
  2172)   ! 
  2173) 
  2174)   use Realization_Subsurface_class
  2175)   use Option_module
  2176)   use Field_module
  2177)   use Grid_module
  2178)   use Patch_module
  2179)   
  2180)   use EOS_Water_module
  2181)   use Gas_EOS_module  
  2182)   use co2eos_module
  2183)   use co2_span_wagner_spline_module, only: sw_prop
  2184)   use co2_sw_module, only: co2_sw_interp
  2185)   use co2_span_wagner_module
  2186) 
  2187)   implicit none
  2188)   
  2189)   type(realization_subsurface_type) :: realization
  2190)   
  2191)   Vec, intent(in) :: xx
  2192)   PetscInt :: icri,ichange 
  2193) 
  2194)   PetscReal, pointer :: xx_p(:), yy_p(:),iphase_loc_p(:)
  2195)   PetscReal :: den(realization%option%nphase)
  2196)   PetscInt :: ipr
  2197)   PetscInt :: iipha 
  2198)   PetscErrorCode :: ierr
  2199) ! PetscInt :: index,i
  2200)   PetscReal :: p2,p,tmp,t
  2201)   PetscReal :: dg,dddt,dddp,fg,dfgdp,dfgdt,eng,hg,dhdt,dhdp,visg,dvdt,dvdp
  2202)   PetscReal :: ug,xphi,henry,sat_pressure
  2203)   PetscReal :: k1, k2, z1, z2, xg, vmco2, vmh2o, sg, sgg
  2204)   PetscReal :: xmol(realization%option%nphase*realization%option%nflowspec),&
  2205)                satu(realization%option%nphase)
  2206)   PetscReal :: yh2o_in_co2 = 1.d-2
  2207) ! PetscReal :: yh2o_in_co2 = 0.d0
  2208)   PetscReal :: wat_sat_x, co2_sat_x
  2209)   PetscReal :: lngamco2, m_na, m_cl, m_nacl, Qkco2, mco2, xco2eq, temp
  2210) ! PetscReal :: xla,co2_poyn
  2211)   PetscInt :: local_id, ghosted_id, dof_offset
  2212)   PetscInt :: iflag
  2213)   PetscInt :: idum
  2214)   PetscReal :: min_value
  2215)   
  2216)   type(grid_type), pointer :: grid
  2217)   type(option_type), pointer :: option
  2218)   type(field_type), pointer :: field
  2219)   type(patch_type), pointer :: patch
  2220)   type(global_auxvar_type), pointer :: global_auxvars(:)
  2221) 
  2222) ! xmol(1) = X_H2O^l
  2223) ! xmol(2) = X_CO2^l
  2224) ! xmol(3) = X_H2O^g = Psat(T)/P_g
  2225) ! xmol(4) = X_CO2^g = (1-Psat(T))/P_g
  2226) 
  2227)   patch => realization%patch  
  2228)   grid => patch%grid
  2229)   option => realization%option
  2230)   field => realization%field
  2231)   global_auxvars => patch%aux%Global%auxvars
  2232) 
  2233) #if 0
  2234)   option%force_newton_iteration = PETSC_FALSE
  2235)   ! checking for negative saturation/mole fraction
  2236)   call VecStrideMin(xx,TWO_INTEGER,idum,min_value,ierr);CHKERRQ(ierr)
  2237)   if (min_value < 0.d0) then
  2238)     write(option%io_buffer,*) 'Warning: saturation or mole fraction negative at cell ', &
  2239)       idum, min_value 
  2240)     call printMsg(option)
  2241)     option%force_newton_iteration = PETSC_TRUE
  2242)   endif
  2243) #endif
  2244)     
  2245) ! mphase code need assemble 
  2246)   call VecLockPop(xx,ierr); CHKERRQ(ierr)
  2247)   call VecGetArrayF90(xx, xx_p, ierr);CHKERRQ(ierr)
  2248)   call VecLockPush(xx,ierr); CHKERRQ(ierr)
  2249)   call VecGetArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
  2250)   call VecGetArrayF90(field%iphas_loc, iphase_loc_p,ierr);CHKERRQ(ierr)
  2251)   
  2252)   ichange = 0   
  2253)   do local_id = 1,grid%nlmax
  2254)     ghosted_id = grid%nL2G(local_id)
  2255)     if (associated(patch%imat)) then
  2256)       if (patch%imat(ghosted_id) <= 0) cycle
  2257)     endif
  2258)     ipr=0 
  2259)     dof_offset=(local_id-1)* option%nflowdof
  2260)     iipha=int(iphase_loc_p(ghosted_id))
  2261)     p = xx_p(dof_offset+1)
  2262)     t = xx_p(dof_offset+2)
  2263)     den(1:option%nphase) = patch%aux%Mphase%auxvars(ghosted_id)%auxvar_elem(0)%den(1:option%nphase)
  2264)     select case(iipha) 
  2265)       case(1) ! liquid
  2266)         xmol(2) = xx_p(dof_offset+3)
  2267)         xmol(1) = 1.D0 - xmol(2)
  2268)         satu(1) = 1.D0; satu(2) = 0.D0
  2269)       case(2) ! gas
  2270)         xmol(4) = xx_p(dof_offset+3)
  2271)         xmol(3) = 1.D0 - xmol(4)
  2272)         satu(1) = 0.d0; satu(2) = 1.D0
  2273)       case(3) ! two-phase
  2274)         satu(2) = xx_p(dof_offset+3) 
  2275)         satu(1) = 1.D0 - satu(2)
  2276)         xmol(3) = yh2o_in_co2; xmol(4) = 1.D0-xmol(3)
  2277)     end select
  2278) 
  2279) ! Pure CO2 phase properties ------------------------------------------    
  2280)     p2 = p
  2281) !   p2 = p*xmol(4)
  2282)     if (p2 >= 5.d4) then
  2283)       if (option%co2eos == EOS_SPAN_WAGNER) then
  2284)         select case(option%itable)  
  2285)           case(0,1,2,4,5)
  2286)             if (option%itable >=4) then
  2287)               call co2_sw_interp(p2*1.D-6,t,dg,dddt,dddp,fg, &
  2288)                   dfgdp,dfgdt,eng,hg,dhdt,dhdp,visg,dvdt,dvdp,option%itable)
  2289)             else
  2290)               iflag = 1
  2291)               call co2_span_wagner(p2*1.D-6,t+273.15D0,dg,dddt,dddp,fg, &
  2292)                   dfgdp,dfgdt,eng,hg,dhdt,dhdp,visg,dvdt,dvdp,iflag,option%itable)
  2293)               if (iflag < 1) then
  2294)                 ichange = -1
  2295)                 return
  2296)               endif
  2297)             endif
  2298)             dg = dg / FMWCO2
  2299)             fg = fg * 1.D6
  2300)             hg = hg * FMWCO2
  2301) ! Span-Wagner EOS with Bi-Cubic Spline interpolation
  2302)           case(3) 
  2303)             call sw_prop(t,p2*1D-6,dg,hg, eng, fg)
  2304)             dg = dg / FMWCO2
  2305)             fg = fg * 1.D6
  2306)             hg = hg * FMWCO2
  2307)         end select     
  2308)       elseif (option%co2eos == EOS_MRK) then
  2309) ! MRK eos [modified version from  Kerrick and Jacobs (1981) and Weir et al. (1996).]     
  2310)         call CO2( t,p2, dg,fg, xphi, hg)
  2311)         dg = dg / FMWCO2
  2312)         hg = hg * FMWCO2 *option%scale
  2313)       endif
  2314)     else      
  2315)       call ideal_gaseos_noderiv(p2,t,dg,hg,ug)
  2316)       ! J/kmol -> whatever
  2317)       hg = hg * option%scale                            
  2318)       ug = ug * option%scale                            
  2319)       fg = p2
  2320)     endif
  2321)    
  2322)     xphi = fg/p2
  2323)     call EOSWaterSaturationPressure(t, sat_pressure, ierr)
  2324)     sat_pressure = sat_pressure/1.D5
  2325)   
  2326)     m_na=option%m_nacl; m_cl=m_na; m_nacl = m_na 
  2327)     if (associated(realization%reaction)) then
  2328)       if (associated(realization%reaction%species_idx)) then
  2329)         if (realization%reaction%species_idx%na_ion_id /= 0 .and. &
  2330)           realization%reaction%species_idx%cl_ion_id /= 0) then
  2331)           m_na = global_auxvars(ghosted_id)%m_nacl(1)
  2332)           m_cl = global_auxvars(ghosted_id)%m_nacl(2)
  2333)           m_nacl = m_na
  2334)           if (m_cl > m_na) m_nacl = m_cl
  2335)         endif
  2336)       endif  
  2337)     endif
  2338) 
  2339)     call Henry_duan_sun(t,p2*1.D-5,henry,lngamco2,m_na,m_cl)
  2340) 
  2341)     Qkco2 = henry*xphi ! QkCO2 = xphi * exp(-mu0) / gamma
  2342) 
  2343)     sat_pressure = sat_pressure * 1.D5
  2344)     mco2 = (p - sat_pressure)*1.D-5 * Qkco2 ! molality CO2, y * P = P - Psat(T)
  2345) 
  2346)     xco2eq = mco2/(1.D3/fmwh2o + mco2 + m_nacl) ! mole fraction CO2
  2347) 
  2348)     henry = 1.D8 / FMWH2O / henry / xphi !note: henry = H/phi
  2349)     wat_sat_x = sat_pressure/p ! X_w^sc
  2350)     co2_sat_x = (1.D0-wat_sat_x)/(henry/p-wat_sat_x)*henry/p  ! xmol(4) = xmol(2)*henry/p
  2351) 
  2352) !     tmp = 1.D0-tmp ! approximate form
  2353) 
  2354)     select case(icri) ! icri = 0 in call statement
  2355)       case(0)
  2356)       select case(iipha)     
  2357)         case(1) ! liquid
  2358)           xmol(4) = xmol(2)*henry/p   
  2359) 
  2360) !         print *,'phase chg: ',xmol(2),xco2eq,mco2,m_nacl,p,t
  2361) 
  2362) !         if (xmol(4)+ wat_sat_x > 1.05d0) then
  2363) !         if (xmol(2) > xco2eq) then
  2364)           if (xmol(2) >= xco2eq) then
  2365) 
  2366)         !   Rachford-Rice initial guess: 1=H2O, 2=CO2
  2367)             k1 = wat_sat_x !sat_pressure*1.D5/p
  2368)             k2 = henry/p
  2369)             z1 = xmol(1); z2 = xmol(2)
  2370)             xg = ((1.d0-k2)*z2+(1.d0-k1)*z1)/((1.d0-k2)*(1.d0-k1)*(z1+z2))
  2371)             vmco2 = 1.d0/dg
  2372)             vmh2o = 1.D0 /den(1)   ! FMWH2O/0.9d3
  2373)             
  2374)        !    calculate initial guess for sg
  2375)             sg = vmco2*xg/(vmco2*xg+vmh2o*(1.d0-xg))
  2376)             if (sg > 1.D-4) then
  2377)               write(*,'('' Liq -> 2ph '',''rank='',i6,'' n='',i8,'' p='',1pe10.4, &
  2378)        &      '' T='',1pe10.4,'' Xl='',1pe11.4, &
  2379)        &      '' Xco2eq='',1pe11.4,'' sg='',1pe11.4)') &
  2380)               option%myrank,local_id,xx_p(dof_offset+1:dof_offset+3),xco2eq,sg
  2381) 
  2382)               iphase_loc_p(ghosted_id) = 3 ! Liq -> 2ph
  2383)         
  2384) !             write(*,'(''Rachford-Rice: '','' z1, z2='', &
  2385) !       &     1p2e12.4,'' xeq='',1pe12.4,'' xg='',1pe12.4, &
  2386) !       &     '' sg='',1pe12.4)') z1,z2,xco2eq,xg,sg
  2387)         
  2388) !             write(*,'(''Rachford-Rice: '',''K1,2='',1p2e12.4,'' z1,2='', &
  2389) !       &     1p2e12.4,'' xeq='',1pe12.4,'' xg='',1pe12.4, &
  2390) !       &     '' sg='',1pe12.4,'' dg='',1p2e12.4)') &
  2391) !             k1,k2,z1,z2,xco2eq,xg,sg,den(1),dg
  2392) 
  2393) !             sgg = den(1)*(z2-xco2eq)/(den(1)*(z2-xco2eq) - &
  2394) !               dg*(z2-(1.d0-wat_sat_x)))
  2395) !             write(*,'(''Rachford-Rice: sg = '',1p2e12.4)') sgg,sg
  2396)               
  2397)               xx_p(dof_offset+3) = sg   
  2398)               ichange = 1
  2399)             endif
  2400)           endif
  2401) 
  2402)         case(2) ! gas
  2403)           
  2404) !         if (xmol(3) > wat_sat_x * 1.05d0) then
  2405)           if (xmol(3) > wat_sat_x * 1.001d0) then
  2406) 
  2407) !           print *,'gas -> 2ph: ',xmol(3),wat_sat_x,xco2eq,sat_pressure
  2408)           
  2409) !         if (xmol(3) > (1.d0+1.d-6)*tmp .and. iipha==2) then
  2410)             write(*,'('' Gas -> 2ph '',''rank='',i6,'' n='',i8, &
  2411)        &    '' p= '',1pe10.4,'' T= '',1pe10.4,'' Xg= '',1pe11.4,'' Ps/P='', 1pe11.4)') &
  2412)             option%myrank,local_id,xx_p(dof_offset+1:dof_offset+3),wat_sat_x
  2413) 
  2414)             iphase_loc_p(ghosted_id) = 3 ! Gas -> 2ph
  2415)             xx_p(dof_offset+3) = 1.D0-formeps
  2416) !            xx_p(dof_offset+3) = 1.D0
  2417)             ichange = 1
  2418)           endif
  2419) 
  2420)         case(3) ! two-phase
  2421)           tmp = wat_sat_x
  2422)           
  2423) !         xmol(2)= (1.D0-tmp)/(Henry/p-tmp) ! solve: x1+x2=1, y1+y2=1, y1=k1*x1, y2=k2*x2
  2424) !         xmol(2)= p*(1.D0-tmp)/Henry ! approximate form
  2425) !         xmol(1)= 1.D0-xmol(2)
  2426) !         xmol(3)= xmol(1)*tmp
  2427) !         xmol(4)= 1.D0-xmol(3)
  2428) 
  2429)           xmol(1) = 1.D0 - xco2eq  ! x_h2o^h2o
  2430)           xmol(2) = xco2eq         ! x_co2^h2o
  2431)           xmol(3) = tmp            ! x_h2o^co2
  2432)           xmol(4) = 1.D0 - tmp     ! x_co2^co2
  2433) 
  2434) !         if (satu(2) >= 1.D0) then
  2435) !         if (satu(2) >= 1.01D0) then
  2436)           if (satu(2) >= 1.001D0) then
  2437) 
  2438)             write(*,'('' 2ph -> Gas '',''rank='',i6,'' n='',i8, &
  2439)        &  '' p='',1pe10.4,'' T='',1pe10.4,'' sg='',1pe11.4)') &
  2440)             option%myrank,local_id,xx_p(dof_offset+1:dof_offset+3)
  2441) 
  2442)             iphase_loc_p(ghosted_id) = 2 ! 2ph -> Gas
  2443) !           xx_p(dof_offset+3) = 1.D0 - 1.D-8
  2444)             xx_p(dof_offset+3) = 1.D0
  2445)             ichange = 1
  2446)             
  2447)           else if (satu(2) <= 0.D0) then
  2448)           
  2449)             write(*,'('' 2ph -> Liq '',''rank= '',i6,'' n='',i8,'' p='',1pe10.4, &
  2450)       &     '' T='',1pe10.4,'' sg ='',1pe11.4,'' Xco2eq='',1pe11.4)')  &
  2451)             option%myrank,local_id, xx_p(dof_offset+1:dof_offset+3),xmol(2)
  2452) 
  2453)             iphase_loc_p(ghosted_id) = 1 ! 2ph -> Liq
  2454)             ichange = 1
  2455)             tmp = xmol(2) * 0.99
  2456)             xx_p(dof_offset+3) = tmp
  2457)           endif
  2458) 
  2459)       end select
  2460) 
  2461)     case(1)
  2462)     
  2463)       select case(iipha)     
  2464)         case(2)   
  2465)           if (xmol(3) > wat_sat_x) then
  2466) !           write(*,'(''** Gas -> 2ph '',i8,1p10e12.4)') local_id, &
  2467) !           xx_p(dof_offset+1:dof_offset+3)
  2468)           endif
  2469)         case(1) 
  2470)           xmol(4) = xmol(2)*henry/p 
  2471)           if (xmol(4) >co2_sat_x ) then
  2472) !           write(*,'(''** Liq -> 2ph '',i8,1p10e12.4)') local_id, &
  2473) !           xx_p(dof_offset+1:dof_offset+3),xmol(4), co2_sat_x
  2474)           endif
  2475)         case(3) 
  2476)           if (satu(2) > 1.D0 .and. iipha == 3) then
  2477) !            write(*,'(''** 2ph -> Gas '',i8,1p10e12.4)') local_id, &
  2478) !            xx_p(dof_offset+1:dof_offset+3)
  2479)           endif
  2480)           if (satu(2) <= 0.D0 .and. iipha == 3) then
  2481) !           write(*,'(''** 2ph -> Liq '',i8,1p10e12.4)') local_id, &
  2482) !           xx_p(dof_offset+1:dof_offset+3),satu(1),satu(2)
  2483)           endif
  2484)       end select
  2485)     end select
  2486)   enddo
  2487) 
  2488)   call VecRestoreArrayReadF90(xx, xx_p, ierr);CHKERRQ(ierr)
  2489)   call VecRestoreArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
  2490)   call VecRestoreArrayF90(field%iphas_loc, iphase_loc_p,ierr);CHKERRQ(ierr)
  2491) 
  2492) end subroutine MphaseVarSwitchPatch
  2493) 
  2494) ! ************************************************************************** !
  2495) 
  2496) subroutine MphaseResidualPatch(snes,xx,r,realization,ierr)
  2497)   ! 
  2498)   ! Computes the residual equation at patch level
  2499)   ! 
  2500)   ! Author: Glenn Hammond
  2501)   ! Date: 12/10/07
  2502)   ! 
  2503) 
  2504)   use Connection_module
  2505)   use Realization_Subsurface_class
  2506)   use Patch_module
  2507)   use Grid_module
  2508)   use Option_module
  2509)   use Coupler_module  
  2510)   use Field_module
  2511)   use Debug_module
  2512)   use Secondary_Continuum_Aux_module
  2513)   use Secondary_Continuum_module
  2514)   use Material_Aux_class
  2515)   
  2516)   implicit none
  2517) 
  2518)   SNES, intent(in) :: snes
  2519)   Vec, intent(inout) :: xx
  2520)   Vec, intent(out) :: r
  2521)   type(realization_subsurface_type) :: realization
  2522) 
  2523)   PetscErrorCode :: ierr
  2524)   PetscInt :: i, jn
  2525)   PetscInt :: ip1, ip2
  2526)   PetscInt :: local_id, ghosted_id, local_id_up, local_id_dn, ghosted_id_up, ghosted_id_dn
  2527) 
  2528)   PetscReal, pointer :: accum_p(:)
  2529) 
  2530)   PetscReal, pointer :: r_p(:), xx_loc_p(:), xx_p(:), yy_p(:)
  2531) 
  2532)   PetscReal, pointer :: iphase_loc_p(:), icap_loc_p(:), ithrm_loc_p(:)
  2533) 
  2534)   PetscInt :: iphase
  2535)   PetscInt :: icap_up, icap_dn, ithrm_up, ithrm_dn
  2536)   PetscReal :: dd_up, dd_dn
  2537)   PetscReal :: dd, f_up, f_dn, ff
  2538)   PetscReal :: perm_up, perm_dn
  2539)   PetscReal :: D_up, D_dn  ! "Diffusion" constants at upstream, downstream faces.
  2540)   PetscReal :: dw_kg, dw_mol,dddt,dddp
  2541)   PetscReal :: tsrc1, qsrc1, csrc1, enth_src_h2o, enth_src_co2 , hsrc1
  2542)   PetscReal :: rho, fg, dfgdp, dfgdt, eng, dhdt, dhdp, visc, dvdt, dvdp, xphi
  2543)   PetscReal :: upweight
  2544)   PetscReal :: Res(realization%option%nflowdof), v_darcy(realization%option%nphase)
  2545)   PetscReal :: xxbc(realization%option%nflowdof)
  2546)   PetscReal :: psrc(1:realization%option%nphase)
  2547)   PetscViewer :: viewer
  2548) 
  2549) 
  2550)   type(grid_type), pointer :: grid
  2551)   type(patch_type), pointer :: patch
  2552)   type(option_type), pointer :: option
  2553)   type(field_type), pointer :: field
  2554)   type(mphase_type), pointer :: mphase
  2555)   type(mphase_parameter_type), pointer :: mphase_parameter
  2556)   type(mphase_auxvar_type), pointer :: auxvars(:)
  2557)   type(mphase_auxvar_type), pointer :: auxvars_bc(:)
  2558)   type(mphase_auxvar_type), pointer :: auxvars_ss(:)
  2559)   type(global_auxvar_type), pointer :: global_auxvars(:)
  2560)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
  2561)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
  2562)   class(material_auxvar_type), pointer :: material_auxvars(:)  
  2563)   type(coupler_type), pointer :: boundary_condition
  2564)   type(coupler_type), pointer :: source_sink
  2565)   type(connection_set_list_type), pointer :: connection_set_list
  2566)   type(connection_set_type), pointer :: cur_connection_set
  2567)   PetscReal, pointer :: msrc(:)
  2568)   PetscReal :: ss_flow_vol_flux(realization%option%nphase)
  2569) 
  2570)   type(sec_heat_type), pointer :: mphase_sec_heat_vars(:)
  2571) 
  2572)   PetscBool :: enthalpy_flag
  2573)   PetscInt :: ng
  2574)   PetscInt :: iconn, idof, istart, iend
  2575)   PetscInt :: nsrcpara
  2576)   PetscInt :: sum_connection
  2577)   PetscReal :: distance, fraction_upwind
  2578)   PetscReal :: distance_gravity
  2579)   PetscReal :: vol_frac_prim
  2580)   
  2581)   ! secondary continuum variables
  2582)   PetscReal :: sec_dencpr
  2583)   PetscReal :: area_prim_sec
  2584)   PetscReal :: res_sec_heat
  2585)   
  2586)   character(len=MAXSTRINGLENGTH) :: string
  2587) 
  2588)   patch => realization%patch
  2589)   grid => patch%grid
  2590)   option => realization%option
  2591)   field => realization%field
  2592) 
  2593)   mphase => patch%aux%Mphase
  2594)   mphase_parameter => mphase%mphase_parameter
  2595)   auxvars => mphase%auxvars
  2596)   auxvars_bc => mphase%auxvars_bc
  2597)   auxvars_ss => mphase%auxvars_ss
  2598)   global_auxvars => patch%aux%Global%auxvars
  2599)   global_auxvars_bc => patch%aux%Global%auxvars_bc
  2600)   global_auxvars_ss => patch%aux%Global%auxvars_ss
  2601)   material_auxvars => patch%aux%Material%auxvars
  2602)   mphase_sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
  2603) 
  2604)  ! call MphaseUpdateAuxVarsPatchNinc(realization)
  2605)   ! override flags since they will soon be out of date  
  2606)  ! patch%MphaseAux%auxvars_up_to_date = PETSC_FALSE 
  2607)  
  2608)   if (option%compute_mass_balance_new) then
  2609)     call MphaseZeroMassBalDeltaPatch(realization)
  2610)   endif
  2611) 
  2612) ! now assign access pointer to local variables
  2613)   call VecGetArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  2614)   call VecGetArrayF90(r, r_p, ierr);CHKERRQ(ierr)
  2615)   call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  2616)  
  2617) ! call VecGetArrayF90(field%flow_yy,yy_p,ierr)
  2618)   call VecGetArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  2619)   call VecGetArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  2620)   call VecGetArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
  2621)  
  2622) 
  2623)   vol_frac_prim = 1.d0
  2624)   
  2625) #if 1
  2626)   ! Pertubations for aux terms --------------------------------
  2627)   do ng = 1, grid%ngmax
  2628)     if (grid%nG2L(ng) < 0) cycle
  2629)     if (associated(patch%imat)) then
  2630)       if (patch%imat(ng) <= 0) cycle
  2631)     endif
  2632)         
  2633)     istart = (ng-1) * option%nflowdof + 1; iend = istart - 1 + option%nflowdof
  2634)     iphase = int(iphase_loc_p(ng))
  2635)     ghosted_id = ng
  2636)     call MphaseAuxVarCompute_Ninc(xx_loc_p(istart:iend),auxvars(ng)%auxvar_elem(0), &
  2637)       global_auxvars(ng), iphase, &
  2638)       patch%saturation_function_array(int(icap_loc_p(ng)))%ptr, &
  2639)       realization%fluid_properties,option,xphi)
  2640) 
  2641) #if 1
  2642)     if (associated(global_auxvars)) then
  2643)        global_auxvars(ghosted_id)%pres(:) = auxvars(ghosted_id)%auxvar_elem(0)%pres - &
  2644)                auxvars(ghosted_id)%auxvar_elem(0)%pc(:)
  2645)        global_auxvars(ghosted_id)%temp = auxvars(ghosted_id)%auxvar_elem(0)%temp
  2646)        global_auxvars(ghosted_id)%sat(:) = auxvars(ghosted_id)%auxvar_elem(0)%sat(:)
  2647)        global_auxvars(ghosted_id)%fugacoeff(1) = xphi
  2648)        global_auxvars(ghosted_id)%den(:) = auxvars(ghosted_id)%auxvar_elem(0)%den(:)
  2649)        global_auxvars(ghosted_id)%den_kg(:) = auxvars(ghosted_id)%auxvar_elem(0)%den(:) &
  2650)                                           * auxvars(ghosted_id)%auxvar_elem(0)%avgmw(:)
  2651) !       global_auxvars(ghosted_id)%reaction_rate(:)=0D0
  2652) !      print *,'UPdate mphase and gloable vars', ghosted_id, global_auxvars(ghosted_id) %m_nacl(:), & 
  2653) !      global_auxvars(ghosted_id)%pres(:)
  2654) !      global_auxvars(ghosted_id)%mass_balance 
  2655) !      global_auxvars(ghosted_id)%mass_balance_delta                   
  2656)     else
  2657)        print *,'Not associated global for mph'
  2658)     endif
  2659) #endif
  2660) 
  2661)     if (option%flow%numerical_derivatives) then
  2662)       mphase%delx(1,ng) = xx_loc_p((ng-1)*option%nflowdof+1)*dfac !* 1.D-3
  2663)       mphase%delx(2,ng) = xx_loc_p((ng-1)*option%nflowdof+2)*dfac
  2664) 
  2665) !     print *,'mphase_delx: ',dfac,mphase%delx(1,ng),mphase%delx(2,ng),mphase%delx(3,ng), &
  2666) !     xx_loc_p((ng-1)*option%nflowdof+1),xx_loc_p((ng-1)*option%nflowdof+2),xx_loc_p((ng-1)*option%nflowdof+3)
  2667) 
  2668)       select case (iphase)
  2669)         case (1)
  2670)           if (xx_loc_p((ng-1)*option%nflowdof+3) < 5D-5) then
  2671)             mphase%delx(3,ng) =  dfac*xx_loc_p((ng-1)*option%nflowdof+3)
  2672)           else
  2673)             mphase%delx(3,ng) = -dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  2674)           endif
  2675)           if (mphase%delx(3,ng) < 1D-8 .and. mphase%delx(3,ng) >= 0.D0) mphase%delx(3,ng) = 1D-8
  2676)           if (mphase%delx(3,ng) > -1D-8 .and. mphase%delx(3,ng) < 0.D0) mphase%delx(3,ng) = -1D-8
  2677)         case(2)  
  2678)           if (xx_loc_p((ng-1)*option%nflowdof+3) < 0.9995) then
  2679)             mphase%delx(3,ng) =  dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  2680)           else
  2681)             mphase%delx(3,ng) = -dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  2682)           endif
  2683)           if (mphase%delx(3,ng) < 1D-8 .and. mphase%delx(3,ng) >= 0.D0) mphase%delx(3,ng) = 1D-8
  2684)           if (mphase%delx(3,ng) > -1D-8 .and. mphase%delx(3,ng) < 0.D0) mphase%delx(3,ng) = -1D-8
  2685)         case(3)
  2686)           if (xx_loc_p((ng-1)*option%nflowdof+3) <= 0.9) then
  2687)             mphase%delx(3,ng) = dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  2688)           else
  2689)             mphase%delx(3,ng) = -dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  2690)           endif
  2691)            
  2692)           if (mphase%delx(3,ng) < 1D-12 .and. mphase%delx(3,ng) >= 0.D0) mphase%delx(3,ng) = 1D-12
  2693)           if (mphase%delx(3,ng) > -1D-12 .and. mphase%delx(3,ng) < 0.D0) mphase%delx(3,ng) = -1D-12
  2694)         
  2695)           if ((mphase%delx(3,ng)+xx_loc_p((ng-1)*option%nflowdof+3)) > 1.D0) then
  2696)             mphase%delx(3,ng) = (1.D0-xx_loc_p((ng-1)*option%nflowdof+3))*1D-6
  2697)           endif
  2698)           if ((mphase%delx(3,ng)+xx_loc_p((ng-1)*option%nflowdof+3)) < 0.D0) then
  2699)             mphase%delx(3,ng) = xx_loc_p((ng-1)*option%nflowdof+3)*1D-6
  2700)           endif
  2701)       end select
  2702)       call MphaseAuxVarCompute_Winc(xx_loc_p(istart:iend),mphase%delx(:,ng),&
  2703)             auxvars(ng)%auxvar_elem(1:option%nflowdof),global_auxvars(ng),iphase,&
  2704)             patch%saturation_function_array(int(icap_loc_p(ng)))%ptr,&
  2705)             realization%fluid_properties,option)
  2706)     endif
  2707)   enddo
  2708) ! print *,'mphase resi patch: end numerical increments'
  2709) #endif
  2710) 
  2711)   mphase%res_old_AR=0.D0; mphase%res_old_FL=0.D0; r_p = 0.d0
  2712) 
  2713) #if 1
  2714)   ! Accumulation terms ------------------------------------
  2715)   r_p = - accum_p
  2716) 
  2717)   do local_id = 1, grid%nlmax  ! For each local node do...
  2718)     ghosted_id = grid%nL2G(local_id)
  2719)     !geh - Ignore inactive cells with inactive materials
  2720)     if (associated(patch%imat)) then
  2721)       if (patch%imat(ghosted_id) <= 0) cycle
  2722)     endif
  2723)     iend = local_id*option%nflowdof
  2724)     istart = iend-option%nflowdof+1
  2725)     
  2726)     if (option%use_mc) then
  2727)       vol_frac_prim = mphase_sec_heat_vars(local_id)%epsilon
  2728)     endif
  2729) 
  2730)     call MphaseAccumulation(auxvars(ghosted_id)%auxvar_elem(0), &
  2731)                             global_auxvars(ghosted_id), &
  2732)                             material_auxvars(ghosted_id)%porosity, &
  2733)                             material_auxvars(ghosted_id)%volume, &
  2734)                             mphase_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  2735)                             option,ONE_INTEGER,vol_frac_prim,Res) 
  2736)     r_p(istart:iend) = r_p(istart:iend) + Res(1:option%nflowdof)
  2737) 
  2738)     mphase%res_old_AR(local_id, :)= Res(1:option%nflowdof)
  2739)   enddo
  2740) #endif
  2741) 
  2742) 
  2743) ! ================== Secondary continuum heat source terms =====================
  2744) #if 1
  2745)   if (option%use_mc) then
  2746)   ! Secondary continuum contribution (Added by SK 06/26/2012)
  2747)   ! only one secondary continuum for now for each primary continuum node
  2748)     do local_id = 1, grid%nlmax  ! For each local node do...
  2749)       ghosted_id = grid%nL2G(local_id)
  2750)       if (associated(patch%imat)) then
  2751)         if (patch%imat(ghosted_id) <= 0) cycle
  2752)       endif
  2753)       iend = local_id*option%nflowdof
  2754)       istart = iend-option%nflowdof+1
  2755)     
  2756)       sec_dencpr = mphase_parameter%dencpr(int(ithrm_loc_p(ghosted_id))) ! secondary rho*c_p same as primary for now   
  2757)     
  2758)       call MphaseSecondaryHeat(mphase_sec_heat_vars(local_id), &
  2759)                         auxvars(ghosted_id)%auxvar_elem(0), &
  2760)                         global_auxvars(ghosted_id), &
  2761)                         mphase_parameter%ckwet(int(ithrm_loc_p(ghosted_id))), &
  2762)                         sec_dencpr, &
  2763)                         option,res_sec_heat) 
  2764)       r_p(iend) = r_p(iend) - res_sec_heat*option%flow_dt* &
  2765)                               material_auxvars(ghosted_id)%volume
  2766) 
  2767)     enddo   
  2768)   endif
  2769) #endif
  2770) 
  2771) ! ============== end secondary continuum heat source ===========================
  2772) 
  2773) #if 1
  2774)   ! Source/sink terms -------------------------------------
  2775) ! print *, 'Mphase residual patch 2' 
  2776)   source_sink => patch%source_sink_list%first 
  2777)   sum_connection = 0
  2778)   do 
  2779)     if (.not.associated(source_sink)) exit
  2780)     !print *, 'RES s/s begin'
  2781)     ! check whether enthalpy dof is included
  2782)   !  if (source_sink%flow_condition%num_sub_conditions > 3) then
  2783)     enthalpy_flag = PETSC_TRUE
  2784)    ! else
  2785)    !   enthalpy_flag = PETSC_FALSE
  2786)    ! endif
  2787) 
  2788)     if (associated(source_sink%flow_condition%pressure)) then
  2789)       psrc(:) = source_sink%flow_condition%pressure%dataset%rarray(:)
  2790)     endif
  2791) !   qsrc1 = source_sink%flow_condition%pressure%dataset%rarray(1)
  2792)     tsrc1 = source_sink%flow_condition%temperature%dataset%rarray(1)
  2793)     csrc1 = source_sink%flow_condition%concentration%dataset%rarray(1)
  2794)     if (enthalpy_flag) hsrc1 = source_sink%flow_condition%enthalpy%dataset%rarray(1)
  2795)     
  2796) !   print *,'src/sink: ',tsrc1,csrc1,hsrc1,psrc
  2797)     
  2798) !   hsrc1=0D0
  2799) !   qsrc1 = qsrc1 / FMWH2O ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
  2800) !   csrc1 = csrc1 / FMWCO2
  2801) !   msrc(1)=qsrc1; msrc(2) =csrc1
  2802) !geh begin change
  2803) !geh remove
  2804) !geh    msrc(:)= psrc(:)
  2805) !clu add
  2806)   select case(source_sink%flow_condition%itype(1))
  2807)     case(MASS_RATE_SS)
  2808)       msrc => source_sink%flow_condition%rate%dataset%rarray
  2809)       nsrcpara= 2
  2810)     case(WELL_SS)
  2811)       msrc => source_sink%flow_condition%well%dataset%rarray
  2812)       nsrcpara = 7 + option%nflowspec 
  2813)      
  2814) !    print *,'src/sink: ',nsrcpara,msrc
  2815)     case default
  2816)       print *, 'mphase mode does not support source/sink type: ', source_sink%flow_condition%itype(1)
  2817)       stop  
  2818)   end select
  2819) 
  2820) !clu end change
  2821) 
  2822)     cur_connection_set => source_sink%connection_set
  2823)     do iconn = 1, cur_connection_set%num_connections      
  2824)       sum_connection = sum_connection + 1
  2825)       local_id = cur_connection_set%id_dn(iconn)
  2826)       ghosted_id = grid%nL2G(local_id)
  2827)       
  2828)       if (associated(patch%imat)) then
  2829)         if (patch%imat(ghosted_id) <= 0) cycle
  2830)       endif
  2831) 
  2832)       call MphaseSourceSink(msrc,nsrcpara, psrc,tsrc1,hsrc1,csrc1, &
  2833)                             auxvars(ghosted_id)%auxvar_elem(0),&
  2834)                             source_sink%flow_condition%itype(1),Res, &
  2835)                     ! fluid flux [m^3/sec] = Res [kmol/mol] / den [kmol/m^3]
  2836)                             ss_flow_vol_flux, &
  2837)                             enthalpy_flag,option)
  2838) 
  2839)       ! included by SK, 08/23/11 to print mass fluxes at source/sink						
  2840)       if (option%compute_mass_balance_new) then
  2841)         global_auxvars_ss(sum_connection)%mass_balance_delta(1:2,1) = &
  2842)           global_auxvars_ss(sum_connection)%mass_balance_delta(1:2,1) - &
  2843)           Res(1:2)/option%flow_dt
  2844)       endif
  2845)       if (associated(patch%ss_flow_fluxes)) then
  2846)         patch%ss_flow_fluxes(:,sum_connection) = Res(:)/option%flow_dt
  2847)       endif
  2848)       if (associated(patch%ss_flow_vol_fluxes)) then
  2849)         patch%ss_flow_vol_fluxes(:,sum_connection) = ss_flow_vol_flux/option%flow_dt
  2850)       endif
  2851)       r_p((local_id-1)*option%nflowdof + jh2o) = r_p((local_id-1)*option%nflowdof + jh2o)-Res(jh2o)
  2852)       r_p((local_id-1)*option%nflowdof + jco2) = r_p((local_id-1)*option%nflowdof + jco2)-Res(jco2)
  2853)       mphase%res_old_AR(local_id,jh2o) = mphase%res_old_AR(local_id,jh2o) - Res(jh2o)    
  2854)       mphase%res_old_AR(local_id,jco2) = mphase%res_old_AR(local_id,jco2) - Res(jco2)    
  2855)       if (enthalpy_flag) then
  2856)         r_p(local_id*option%nflowdof) = r_p(local_id*option%nflowdof) - &
  2857)           Res(option%nflowdof)
  2858)         mphase%res_old_AR(local_id,option%nflowdof) = &
  2859)           mphase%res_old_AR(local_id,option%nflowdof) - Res(option%nflowdof)
  2860)       endif 
  2861)   !   else if (qsrc1 < 0.d0) then ! withdrawal
  2862)   !   endif
  2863)     enddo
  2864)     source_sink => source_sink%next
  2865)   enddo
  2866) #endif
  2867) 
  2868) #if 1
  2869)  ! print *, 'Mphase residual patch 3' 
  2870)    ! Boundary Flux Terms -----------------------------------
  2871)   boundary_condition => patch%boundary_condition_list%first
  2872)   sum_connection = 0    
  2873)   do 
  2874)     if (.not.associated(boundary_condition)) exit
  2875)     
  2876)     cur_connection_set => boundary_condition%connection_set
  2877)         
  2878)     do iconn = 1, cur_connection_set%num_connections
  2879)       sum_connection = sum_connection + 1
  2880)     
  2881)       local_id = cur_connection_set%id_dn(iconn)
  2882)       ghosted_id = grid%nL2G(local_id)
  2883) 
  2884)       if (associated(patch%imat)) then
  2885)         if (patch%imat(ghosted_id) <= 0) cycle
  2886)       endif
  2887) 
  2888)       if (ghosted_id<=0) then
  2889)         print *, "Wrong boundary node index... STOP!!!"
  2890)         stop
  2891)       endif
  2892) 
  2893)       ithrm_dn = int(ithrm_loc_p(ghosted_id))
  2894)       D_dn = mphase_parameter%ckwet(ithrm_dn)
  2895) 
  2896)       ! for now, just assume diagonal tensor
  2897)       call material_auxvars(ghosted_id)%PermeabilityTensorToScalar( &
  2898)                             cur_connection_set%dist(:,iconn),perm_dn)
  2899)       ! dist(0,iconn) = scalar - magnitude of distance
  2900)       ! gravity = vector(3)
  2901)       ! dist(1:3,iconn) = vector(3) - unit vector
  2902)       distance_gravity = cur_connection_set%dist(0,iconn) * &
  2903)                          dot_product(option%gravity, &
  2904)                                      cur_connection_set%dist(1:3,iconn))
  2905) 
  2906)       icap_dn = int(icap_loc_p(ghosted_id))  
  2907) ! Then need fill up increments for BCs
  2908)       do idof =1, option%nflowdof
  2909)         select case(boundary_condition%flow_condition%itype(idof))
  2910)           case(DIRICHLET_BC)
  2911)             xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
  2912)           case(HYDROSTATIC_BC,SEEPAGE_BC)
  2913)             xxbc(MPH_PRESSURE_DOF) = boundary_condition%flow_aux_real_var(MPH_PRESSURE_DOF,iconn)
  2914)             if (idof>=MPH_TEMPERATURE_DOF)then
  2915)               xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2916)             endif 
  2917)           case(ZERO_GRADIENT_BC)
  2918)           ! solve for pb from Darcy's law given qb /= 0
  2919)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2920)             iphase = int(iphase_loc_p(ghosted_id))
  2921)           case(NEUMANN_BC)  
  2922)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2923)             iphase = int(iphase_loc_p(ghosted_id))
  2924)         end select
  2925)       enddo
  2926) 
  2927)       select case(boundary_condition%flow_condition%itype(MPH_CONCENTRATION_DOF))
  2928)         case(DIRICHLET_BC,SEEPAGE_BC,HYDROSTATIC_BC)
  2929)           iphase = boundary_condition%flow_aux_int_var(1,iconn)
  2930)         case(NEUMANN_BC,ZERO_GRADIENT_BC)
  2931)           iphase=int(iphase_loc_p(ghosted_id))                               
  2932)       end select
  2933)  
  2934)       call MphaseAuxVarCompute_Ninc(xxbc,auxvars_bc(sum_connection)%auxvar_elem(0),&
  2935)             global_auxvars_bc(sum_connection), iphase,&
  2936)             patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr,&
  2937)             realization%fluid_properties, option, xphi)
  2938) 
  2939) #if 1
  2940)       if ( associated(global_auxvars_bc))then
  2941)         global_auxvars_bc(sum_connection)%pres(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%pres -&
  2942)                      auxvars(ghosted_id)%auxvar_elem(0)%pc(:)
  2943)         global_auxvars_bc(sum_connection)%temp = auxvars_bc(sum_connection)%auxvar_elem(0)%temp
  2944)         global_auxvars_bc(sum_connection)%sat(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%sat(:)
  2945)       !    global_auxvars(ghosted_id)%sat_store = 
  2946)         global_auxvars_bc(sum_connection)%fugacoeff(1) = xphi
  2947)         global_auxvars_bc(sum_connection)%den(:) = auxvars_bc(sum_connection)%auxvar_elem(0)%den(:)
  2948)         global_auxvars_bc(sum_connection)%den_kg = auxvars_bc(sum_connection)%auxvar_elem(0)%den(:) &
  2949)                                           * auxvars_bc(sum_connection)%auxvar_elem(0)%avgmw(:)
  2950)   !     global_auxvars(ghosted_id)%den_kg_store
  2951)   !     global_auxvars(ghosted_id)%mass_balance 
  2952)   !     global_auxvars(ghosted_id)%mass_balance_delta                   
  2953)       endif
  2954) #endif
  2955) 
  2956) 
  2957)       call MphaseBCFlux(boundary_condition%flow_condition%itype, &
  2958)          boundary_condition%flow_aux_real_var(:,iconn), &
  2959)          auxvars_bc(sum_connection)%auxvar_elem(0), &
  2960)          auxvars(ghosted_id)%auxvar_elem(0), &
  2961)          material_auxvars(ghosted_id)%porosity, &
  2962)          material_auxvars(ghosted_id)%tortuosity, &
  2963)          mphase_parameter%sir(:,icap_dn), &
  2964)          cur_connection_set%dist(0,iconn),perm_dn,D_dn, &
  2965)          cur_connection_set%area(iconn), &
  2966)          distance_gravity,option, &
  2967)          v_darcy,vol_frac_prim,Res)
  2968) 
  2969)       patch%boundary_velocities(:,sum_connection) = v_darcy(:)
  2970) 
  2971)       iend = local_id*option%nflowdof
  2972)       istart = iend-option%nflowdof+1
  2973)       r_p(istart:iend) = r_p(istart:iend) - Res(1:option%nflowdof)
  2974) 
  2975)       mphase%res_old_AR(local_id,1:option%nflowdof) = &
  2976)            mphase%res_old_AR(local_id,1:option%nflowdof) - Res(1:option%nflowdof)
  2977) 
  2978)       if (associated(patch%boundary_flow_fluxes)) then
  2979)         patch%boundary_flow_fluxes(1:option%nflowdof,sum_connection) = &
  2980)                                    Res(1:option%nflowdof)/option%flow_dt
  2981)       endif
  2982)       if (option%compute_mass_balance_new) then
  2983)         ! contribution to boundary
  2984)         global_auxvars_bc(sum_connection)%mass_balance_delta(1:2,1) = &
  2985)           global_auxvars_bc(sum_connection)%mass_balance_delta(1:2,1) &
  2986)             - Res(1:2)/option%flow_dt 
  2987)       endif
  2988) 
  2989)     enddo
  2990)     boundary_condition => boundary_condition%next
  2991)   enddo
  2992) #endif
  2993) #if 1
  2994)   ! Interior Flux Terms -----------------------------------
  2995)   connection_set_list => grid%internal_connection_set_list
  2996)   cur_connection_set => connection_set_list%first
  2997)   sum_connection = 0  
  2998)   do 
  2999)     if (.not.associated(cur_connection_set)) exit
  3000)     do iconn = 1, cur_connection_set%num_connections
  3001)       sum_connection = sum_connection + 1
  3002) 
  3003)       ghosted_id_up = cur_connection_set%id_up(iconn)
  3004)       ghosted_id_dn = cur_connection_set%id_dn(iconn)
  3005) 
  3006)       local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
  3007)       local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping   
  3008) 
  3009)       if (associated(patch%imat)) then
  3010)         if (patch%imat(ghosted_id_up) <= 0 .or.  &
  3011)             patch%imat(ghosted_id_dn) <= 0) cycle
  3012)       endif
  3013) 
  3014)       fraction_upwind = cur_connection_set%dist(-1,iconn)
  3015)       distance = cur_connection_set%dist(0,iconn)
  3016)       ! distance = scalar - magnitude of distance
  3017)       ! gravity = vector(3)
  3018)       ! dist(1:3,iconn) = vector(3) - unit vector
  3019)       distance_gravity = distance * &
  3020)                          dot_product(option%gravity, &
  3021)                                      cur_connection_set%dist(1:3,iconn))
  3022)       dd_up = distance*fraction_upwind
  3023)       dd_dn = distance-dd_up ! should avoid truncation error
  3024)       ! upweight could be calculated as 1.d0-fraction_upwind
  3025)       ! however, this introduces ever so slight error causing pflow-overhaul not
  3026)       ! to match pflow-orig.  This can be changed to 1.d0-fraction_upwind
  3027)       upweight = dd_dn/(dd_up+dd_dn)
  3028)         
  3029)       ! for now, just assume diagonal tensor
  3030)       call material_auxvars(ghosted_id_up)%PermeabilityTensorToScalar( &
  3031)                             cur_connection_set%dist(:,iconn),perm_up)
  3032)       call material_auxvars(ghosted_id_dn)%PermeabilityTensorToScalar( &
  3033)                             cur_connection_set%dist(:,iconn),perm_dn)
  3034) 
  3035)       ithrm_up = int(ithrm_loc_p(ghosted_id_up))
  3036)       ithrm_dn = int(ithrm_loc_p(ghosted_id_dn))
  3037)       icap_up = int(icap_loc_p(ghosted_id_up))
  3038)       icap_dn = int(icap_loc_p(ghosted_id_dn))
  3039)    
  3040)       D_up = mphase_parameter%ckwet(ithrm_up)
  3041)       D_dn = mphase_parameter%ckwet(ithrm_dn)
  3042) 
  3043) 
  3044)       call MphaseFlux(auxvars(ghosted_id_up)%auxvar_elem(0), &
  3045)           material_auxvars(ghosted_id_up)%porosity, &
  3046)           material_auxvars(ghosted_id_up)%tortuosity, &
  3047)           mphase_parameter%sir(:,icap_up), &
  3048)           dd_up,perm_up,D_up, &
  3049)           auxvars(ghosted_id_dn)%auxvar_elem(0), &
  3050)           material_auxvars(ghosted_id_dn)%porosity, &
  3051)           material_auxvars(ghosted_id_dn)%tortuosity, &
  3052)           mphase_parameter%sir(:,icap_dn), &
  3053)           dd_dn,perm_dn,D_dn, &
  3054)           cur_connection_set%area(iconn),distance_gravity, &
  3055)           upweight,option,v_darcy,vol_frac_prim,Res)
  3056) 
  3057)       patch%internal_velocities(:,sum_connection) = v_darcy(:)
  3058)       mphase%res_old_FL(sum_connection,1:option%nflowdof)= Res(1:option%nflowdof)
  3059) 
  3060)       if (local_id_up > 0) then
  3061)         iend = local_id_up*option%nflowdof
  3062)         istart = iend-option%nflowdof+1
  3063)         r_p(istart:iend) = r_p(istart:iend) + Res(1:option%nflowdof)
  3064)       endif
  3065)    
  3066)       if (local_id_dn > 0) then
  3067)         iend = local_id_dn*option%nflowdof
  3068)         istart = iend-option%nflowdof+1
  3069)         r_p(istart:iend) = r_p(istart:iend) - Res(1:option%nflowdof)
  3070)       endif
  3071) 
  3072)       if (associated(patch%internal_flow_fluxes)) then
  3073)         patch%internal_flow_fluxes(:,sum_connection) = Res(:)/option%flow_dt
  3074)       endif
  3075) 
  3076)     enddo
  3077)     cur_connection_set => cur_connection_set%next
  3078)   enddo    
  3079) #endif
  3080) 
  3081) ! adjust residual to R/dt
  3082)   select case (option%idt_switch) 
  3083)   case(1) 
  3084)     r_p(:) = r_p(:)/option%flow_dt
  3085)   case(-1)
  3086)     if (option%flow_dt > 1.D0) r_p(:) = r_p(:)/option%flow_dt
  3087)   end select
  3088)   
  3089)   do local_id = 1, grid%nlmax
  3090)     if (associated(patch%imat)) then
  3091)       if (patch%imat(grid%nL2G(local_id)) <= 0) cycle
  3092)     endif
  3093) 
  3094)     istart = 1 + (local_id-1)*option%nflowdof
  3095) !   if (volume_p(local_id) > 1.D0) &    ! karra added 05/06/2013
  3096) 
  3097) !   scale residual with volume
  3098)     r_p (istart:istart+option%nflowdof-1) = &
  3099)         r_p(istart:istart+option%nflowdof-1) / &
  3100)         material_auxvars(grid%nL2G(local_id))%volume
  3101) 
  3102)     if (r_p(istart) > 1E20 .or. r_p(istart) < -1E20) print *,'mphase residual: ', r_p (istart:istart+2)
  3103) 
  3104)   enddo
  3105) 
  3106) ! print *,'finished rp vol scale'
  3107)   if (option%use_isothermal) then
  3108)     do local_id = 1, grid%nlmax  ! For each local node do...
  3109)       ghosted_id = grid%nL2G(local_id)   ! corresponding ghost index
  3110)       if (associated(patch%imat)) then
  3111)         if (patch%imat(ghosted_id) <= 0) cycle
  3112)       endif
  3113)       istart = 3 + (local_id-1)*option%nflowdof
  3114)       r_p(istart) = 0.D0 ! xx_loc_p(2 + (ng-1)*option%nflowdof) - yy_p(p1-1)
  3115)     enddo
  3116)   endif
  3117)   !call VecRestoreArrayF90(r, r_p, ierr)
  3118) 
  3119) 
  3120)   if (mphase%inactive_cells_exist) then
  3121)     do i=1,mphase%n_zero_rows
  3122)       r_p(mphase%zero_rows_local(i)) = 0.d0
  3123)     enddo
  3124)   endif
  3125) 
  3126)   call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
  3127) ! call VecRestoreArrayF90(field%flow_yy, yy_p, ierr)
  3128)   call VecRestoreArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  3129)   call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  3130)   call VecRestoreArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  3131)   call VecRestoreArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  3132)   call VecRestoreArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
  3133) 
  3134)   if (realization%debug%vecview_residual) then
  3135)     string = 'MPHresidual'
  3136)     call DebugCreateViewer(realization%debug,string,option,viewer)
  3137)     call VecView(r,viewer,ierr);CHKERRQ(ierr)
  3138)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  3139)   endif
  3140)   if (realization%debug%vecview_solution) then
  3141)     string = 'MPHxx'
  3142)     call DebugCreateViewer(realization%debug,string,option,viewer)
  3143)     call VecView(xx,viewer,ierr);CHKERRQ(ierr)
  3144)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  3145)   endif
  3146) end subroutine MphaseResidualPatch
  3147) 
  3148) ! ************************************************************************** !
  3149) 
  3150) subroutine MphaseJacobian(snes,xx,A,B,realization,ierr)
  3151)   ! 
  3152)   ! Computes the Jacobian
  3153)   ! 
  3154)   ! Author: Chuan Lu
  3155)   ! Date: 12/10/07
  3156)   ! 
  3157) 
  3158)   use Realization_Subsurface_class
  3159)   use Patch_module
  3160)   use Grid_module
  3161)   use Option_module
  3162)   use Debug_module
  3163) 
  3164)   implicit none
  3165) 
  3166)   SNES :: snes
  3167)   Vec :: xx
  3168)   Mat :: A, B
  3169)   type(realization_subsurface_type) :: realization
  3170)   PetscErrorCode :: ierr
  3171)   
  3172)   Mat :: J
  3173)   MatType :: mat_type
  3174)   PetscViewer :: viewer
  3175)   type(patch_type), pointer :: cur_patch
  3176)   type(grid_type),  pointer :: grid
  3177)   type(option_type), pointer :: option
  3178)   PetscReal :: norm
  3179)   character(len=MAXSTRINGLENGTH) :: string
  3180) 
  3181)   call MatGetType(A,mat_type,ierr);CHKERRQ(ierr)
  3182)   if (mat_type == MATMFFD) then
  3183)     J = B
  3184)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3185)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3186)   else
  3187)     J = A
  3188)   endif
  3189) 
  3190)   call MatZeroEntries(J,ierr);CHKERRQ(ierr)
  3191)   
  3192)   cur_patch => realization%patch_list%first
  3193)   do
  3194)     if (.not.associated(cur_patch)) exit
  3195)     realization%patch => cur_patch
  3196)     call MphaseJacobianPatch(snes,xx,J,J,realization,ierr)
  3197)     cur_patch => cur_patch%next
  3198)   enddo
  3199) 
  3200)   if (realization%debug%matview_Jacobian) then
  3201)     string = 'MPHjacobian'
  3202)     call DebugCreateViewer(realization%debug,string,realization%option,viewer)
  3203)     call MatView(J,viewer,ierr);CHKERRQ(ierr)
  3204)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  3205)   endif
  3206)   if (realization%debug%norm_Jacobian) then
  3207)     option => realization%option
  3208)     call MatNorm(J,NORM_1,norm,ierr);CHKERRQ(ierr)
  3209)     write(option%io_buffer,'("1 norm: ",es11.4)') norm
  3210)     call printMsg(option)    
  3211)     call MatNorm(J,NORM_FROBENIUS,norm,ierr);CHKERRQ(ierr)
  3212)     write(option%io_buffer,'("2 norm: ",es11.4)') norm
  3213)     call printMsg(option)    
  3214)     call MatNorm(J,NORM_INFINITY,norm,ierr);CHKERRQ(ierr)
  3215)     write(option%io_buffer,'("inf norm: ",es11.4)') norm
  3216)     call printMsg(option)
  3217)   endif
  3218) 
  3219) end subroutine MphaseJacobian
  3220) 
  3221) ! ************************************************************************** !
  3222) 
  3223) subroutine MphaseJacobianPatch(snes,xx,A,B,realization,ierr)
  3224)   ! 
  3225)   ! Computes the Jacobian
  3226)   ! 
  3227)   ! Author: Chuan Lu
  3228)   ! Date: 12/13/07
  3229)   ! 
  3230) 
  3231)   use Connection_module
  3232)   use Option_module
  3233)   use Grid_module
  3234)   use Realization_Subsurface_class
  3235)   use Patch_module
  3236)   use Coupler_module
  3237)   use Field_module
  3238)   use Debug_module
  3239)   use Secondary_Continuum_Aux_module
  3240)   use Material_Aux_class
  3241)   
  3242)   implicit none
  3243) 
  3244)   SNES :: snes
  3245)   Vec :: xx
  3246)   Mat :: A, B
  3247)   type(realization_subsurface_type) :: realization
  3248) 
  3249)   PetscErrorCode :: ierr
  3250)   PetscInt :: nvar,neq,nr
  3251)   PetscInt :: ithrm_up, ithrm_dn, i, j
  3252)   PetscInt :: ip1, ip2 
  3253) 
  3254)   PetscReal, pointer :: xx_loc_p(:)
  3255)   PetscReal, pointer :: iphase_loc_p(:), icap_loc_p(:), ithrm_loc_p(:)
  3256)   PetscInt :: icap,iphas,iphas_up,iphas_dn,icap_up,icap_dn
  3257)   PetscInt :: ii, jj
  3258)   PetscReal :: dw_kg,dw_mol,enth_src_co2,enth_src_h2o,rho
  3259)   PetscReal :: tsrc1,qsrc1,csrc1,hsrc1
  3260)   PetscReal :: dd_up, dd_dn, dd, f_up, f_dn
  3261)   PetscReal :: perm_up, perm_dn
  3262)   PetscReal :: dw_dp,dw_dt,hw_dp,hw_dt,dresT_dp,dresT_dt
  3263)   PetscReal :: D_up, D_dn  ! "Diffusion" constants upstream and downstream of a face.
  3264)   PetscReal :: zero, norm
  3265)   PetscReal :: upweight
  3266) ! PetscReal :: max_dev
  3267)   PetscInt :: local_id, ghosted_id
  3268)   PetscInt :: local_id_up, local_id_dn
  3269)   PetscInt :: ghosted_id_up, ghosted_id_dn
  3270)   PetscInt :: natural_id_up,natural_id_dn
  3271)   
  3272)   PetscReal :: Jup(1:realization%option%nflowdof,1:realization%option%nflowdof), &
  3273)                Jdn(1:realization%option%nflowdof,1:realization%option%nflowdof)
  3274)   
  3275)   PetscInt :: istart, iend
  3276)   
  3277)   type(coupler_type), pointer :: boundary_condition, source_sink
  3278)   type(connection_set_list_type), pointer :: connection_set_list
  3279)   type(connection_set_type), pointer :: cur_connection_set
  3280)   PetscBool :: enthalpy_flag
  3281)   PetscInt :: iconn, idof
  3282)   PetscInt :: sum_connection  
  3283)   PetscReal :: distance, fraction_upwind
  3284)   PetscReal :: distance_gravity
  3285)   PetscReal :: Res(realization%option%nflowdof) 
  3286)   PetscReal :: xxbc(1:realization%option%nflowdof), delxbc(1:realization%option%nflowdof)
  3287)   PetscReal :: ResInc(realization%patch%grid%nlmax,realization%option%nflowdof,&
  3288)            realization%option%nflowdof)
  3289)   PetscReal :: dummy_real(realization%option%nphase)
  3290)   type(grid_type), pointer :: grid
  3291)   type(patch_type), pointer :: patch
  3292)   type(option_type), pointer :: option 
  3293)   type(field_type), pointer :: field 
  3294)   type(mphase_type), pointer :: mphase
  3295)   type(mphase_parameter_type), pointer :: mphase_parameter
  3296)   type(mphase_auxvar_type), pointer :: auxvars(:), auxvars_bc(:)
  3297)   type(global_auxvar_type), pointer :: global_auxvars(:), global_auxvars_bc(:)
  3298)   class(material_auxvar_type), pointer :: material_auxvars(:)
  3299)   
  3300)   type(sec_heat_type), pointer :: sec_heat_vars(:)
  3301)   
  3302)   PetscReal :: vv_darcy(realization%option%nphase), voltemp
  3303)   PetscReal :: ra(1:realization%option%nflowdof,1:realization%option%nflowdof*2) 
  3304)   PetscReal, pointer :: msrc(:)
  3305)   PetscReal :: psrc(1:realization%option%nphase)
  3306)   PetscReal :: dddt, dddp, fg, dfgdp, dfgdt, eng, dhdt, dhdp, visc, dvdt,&
  3307)                dvdp, xphi
  3308)   PetscInt :: iphasebc                
  3309)   PetscInt :: nsrcpara  
  3310)    
  3311)   PetscViewer :: viewer
  3312)   Vec :: debug_vec
  3313)   PetscReal :: vol_frac_prim
  3314) 
  3315)   ! secondary continuum variables
  3316)   PetscReal :: area_prim_sec
  3317)   PetscReal :: jac_sec_heat
  3318)   
  3319)   character(len=MAXSTRINGLENGTH) :: string
  3320) 
  3321) !-----------------------------------------------------------------------
  3322) ! R stand for residual
  3323) !  ra       1              2              3              4          5              6            7      8
  3324) ! 1: p     dR/dpi         dR/dTi          dR/dci        dR/dsi   dR/dpim        dR/dTim
  3325) ! 2: T
  3326) ! 3: c
  3327) ! 4  s         
  3328) !-----------------------------------------------------------------------
  3329) 
  3330)   patch => realization%patch
  3331)   grid => patch%grid
  3332)   option => realization%option
  3333)   field => realization%field
  3334) 
  3335)   mphase => patch%aux%mphase
  3336)   mphase_parameter => mphase%mphase_parameter
  3337)   auxvars => mphase%auxvars
  3338)   auxvars_bc => mphase%auxvars_bc
  3339)   global_auxvars => patch%aux%Global%auxvars
  3340)   global_auxvars_bc => patch%aux%Global%auxvars_bc
  3341)   material_auxvars => patch%aux%Material%auxvars
  3342) 
  3343)   sec_heat_vars => patch%aux%SC_heat%sec_heat_vars
  3344)   
  3345) ! dropped derivatives:
  3346) !   1.D0 gas phase viscocity to all p,t,c,s
  3347) !   2. Average molecular weights to p,t,s
  3348) #if 0
  3349) !  call MphaseNumericalJacobianTest(xx,realization)
  3350) #endif
  3351) 
  3352)  ! print *,'*********** In Jacobian ********************** '
  3353)   call VecGetArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  3354) 
  3355)   call VecGetArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  3356)   call VecGetArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  3357)   call VecGetArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
  3358) 
  3359)   ResInc = 0.D0
  3360)   vol_frac_prim = 1.d0
  3361)  
  3362) #if 1
  3363)   ! Accumulation terms ------------------------------------
  3364)   do local_id = 1, grid%nlmax  ! For each local node do...
  3365)     ghosted_id = grid%nL2G(local_id)
  3366)     !geh - Ignore inactive cells with inactive materials
  3367)     if (associated(patch%imat)) then
  3368)       if (patch%imat(ghosted_id) <= 0) cycle
  3369)     endif
  3370)     iend = local_id*option%nflowdof
  3371)     istart = iend-option%nflowdof+1
  3372)     icap = int(icap_loc_p(ghosted_id))
  3373)      
  3374)     if (option%use_mc) then
  3375)       vol_frac_prim = sec_heat_vars(local_id)%epsilon
  3376)     endif
  3377)      
  3378)     do nvar =1, option%nflowdof
  3379)       call MphaseAccumulation(auxvars(ghosted_id)%auxvar_elem(nvar), &
  3380)              global_auxvars(ghosted_id), &
  3381)              material_auxvars(ghosted_id)%porosity, &
  3382)              material_auxvars(ghosted_id)%volume, &
  3383)              mphase_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  3384)              option,ONE_INTEGER,vol_frac_prim,res) 
  3385)       ResInc(local_id,:,nvar) = ResInc(local_id,:,nvar) + Res(:)
  3386)     enddo
  3387)      
  3388)   enddo
  3389) #endif
  3390) 
  3391) #if 1
  3392)   ! Source/sink terms -------------------------------------
  3393)   source_sink => patch%source_sink_list%first 
  3394)   do 
  3395)     if (.not.associated(source_sink)) exit
  3396)     
  3397)     ! check whether enthalpy dof is included
  3398)   !  if (source_sink%flow_condition%num_sub_conditions > 3) then
  3399)       enthalpy_flag = PETSC_TRUE
  3400)    ! else
  3401)    !   enthalpy_flag = PETSC_FALSE
  3402)    ! endif
  3403) 
  3404)     if (associated(source_sink%flow_condition%pressure)) then
  3405)       psrc(:) = source_sink%flow_condition%pressure%dataset%rarray(:)
  3406)     endif
  3407)     tsrc1 = source_sink%flow_condition%temperature%dataset%rarray(1)
  3408)     csrc1 = source_sink%flow_condition%concentration%dataset%rarray(1)
  3409)  !   hsrc1=0.D0
  3410)     if (enthalpy_flag) hsrc1 = source_sink%flow_condition%enthalpy%dataset%rarray(1)
  3411) 
  3412)    ! qsrc1 = qsrc1 / FMWH2O ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
  3413)    ! csrc1 = csrc1 / FMWCO2
  3414) !geh begin change
  3415) !geh remove
  3416) !geh      msrc(:)= psrc(:)
  3417) !clu add
  3418)      select case(source_sink%flow_condition%itype(1))
  3419)      case(MASS_RATE_SS)
  3420)        msrc => source_sink%flow_condition%rate%dataset%rarray
  3421)        nsrcpara= 2
  3422)      case(WELL_SS)
  3423)        msrc => source_sink%flow_condition%well%dataset%rarray
  3424)        nsrcpara = 7 + option%nflowspec 
  3425)      case default
  3426)        print *, 'mphase mode does not support source/sink type: ', source_sink%flow_condition%itype(1)
  3427)        stop  
  3428)      end select
  3429) 
  3430)      cur_connection_set => source_sink%connection_set
  3431)  
  3432)      do iconn = 1, cur_connection_set%num_connections      
  3433)        local_id = cur_connection_set%id_dn(iconn)
  3434)        ghosted_id = grid%nL2G(local_id)
  3435) 
  3436)        if (associated(patch%imat)) then
  3437)          if (patch%imat(ghosted_id) <= 0) cycle
  3438)        endif
  3439) !      if (enthalpy_flag) then
  3440) !        r_p(local_id*option%nflowdof) = r_p(local_id*option%nflowdof) - hsrc1 * option%flow_dt   
  3441) !      endif 
  3442)         
  3443)        do nvar = 1, option%nflowdof
  3444)          call MphaseSourceSink(msrc,nsrcpara,psrc,tsrc1,hsrc1,csrc1, &
  3445)                                auxvars(ghosted_id)%auxvar_elem(nvar), &
  3446)                                source_sink%flow_condition%itype(1),Res, &
  3447)                                dummy_real,enthalpy_flag,option)
  3448)       
  3449)          ResInc(local_id,jh2o,nvar) =  ResInc(local_id,jh2o,nvar) - Res(jh2o)
  3450)          ResInc(local_id,jco2,nvar) =  ResInc(local_id,jco2,nvar) - Res(jco2)
  3451)          if (enthalpy_flag) & 
  3452)            ResInc(local_id,option%nflowdof,nvar) = &
  3453)            ResInc(local_id,option%nflowdof,nvar) - Res(option%nflowdof) 
  3454) 
  3455)         enddo 
  3456)       enddo
  3457)     source_sink => source_sink%next
  3458)   enddo
  3459) #endif
  3460) 
  3461) ! Boundary conditions
  3462) #if 1
  3463)   ! Boundary Flux Terms -----------------------------------
  3464)   boundary_condition => patch%boundary_condition_list%first
  3465)   sum_connection = 0    
  3466)   do 
  3467)     if (.not.associated(boundary_condition)) exit
  3468)     
  3469)     cur_connection_set => boundary_condition%connection_set
  3470)     
  3471)     do iconn = 1, cur_connection_set%num_connections
  3472)       sum_connection = sum_connection + 1
  3473)     
  3474)       local_id = cur_connection_set%id_dn(iconn)
  3475)       ghosted_id = grid%nL2G(local_id)
  3476) 
  3477)       if (associated(patch%imat)) then
  3478)         if (patch%imat(ghosted_id) <= 0) cycle
  3479)       endif
  3480) 
  3481)       if (ghosted_id<=0) then
  3482)         print *, "Wrong boundary node index... STOP!!!"
  3483)         stop
  3484)       endif
  3485) 
  3486)       ithrm_dn = int(ithrm_loc_p(ghosted_id))
  3487)       D_dn = mphase_parameter%ckwet(ithrm_dn)
  3488)       
  3489)  
  3490)       ! for now, just assume diagonal tensor
  3491)       call material_auxvars(ghosted_id)%PermeabilityTensorToScalar( &
  3492)                             cur_connection_set%dist(:,iconn),perm_dn)
  3493)       ! dist(0,iconn) = scalar - magnitude of distance
  3494)       ! gravity = vector(3)
  3495)       ! dist(1:3,iconn) = vector(3) - unit vector
  3496)       distance_gravity = cur_connection_set%dist(0,iconn) * &
  3497)                          dot_product(option%gravity, &
  3498)                                      cur_connection_set%dist(1:3,iconn))
  3499)       icap_dn = int(icap_loc_p(ghosted_id))
  3500) 
  3501) ! Then need fill up increments for BCs
  3502)       delxbc = 0.D0;
  3503)       do idof = 1, option%nflowdof   
  3504)         select case(boundary_condition%flow_condition%itype(idof))
  3505)         case(DIRICHLET_BC)
  3506)           xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
  3507)           delxbc(idof) = 0.D0
  3508)         case(HYDROSTATIC_BC,SEEPAGE_BC)
  3509)           xxbc(MPH_PRESSURE_DOF) = boundary_condition%flow_aux_real_var(MPH_PRESSURE_DOF,iconn)
  3510)           if (idof >= MPH_TEMPERATURE_DOF) then
  3511)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  3512)             delxbc(idof) = mphase%delx(idof,ghosted_id)
  3513)           endif 
  3514)         case(ZERO_GRADIENT_BC,NEUMANN_BC)
  3515)           ! solve for pb from Darcy's law given qb /= 0
  3516)           xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  3517)           !iphasebc = int(iphase_loc_p(ghosted_id))
  3518)           delxbc(idof) = mphase%delx(idof,ghosted_id)
  3519)         end select
  3520)       enddo
  3521)     !print *,'BC:',boundary_condition%flow_condition%itype, xxbc, delxbc
  3522) 
  3523) 
  3524)       select case(boundary_condition%flow_condition%itype(MPH_CONCENTRATION_DOF))
  3525)       case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC)
  3526)         iphasebc = boundary_condition%flow_aux_int_var(1,iconn)
  3527)       case(ZERO_GRADIENT_BC)
  3528)         iphasebc=int(iphase_loc_p(ghosted_id))                               
  3529)       end select
  3530)       if (boundary_condition%flow_condition%itype(MPH_PRESSURE_DOF) /= NEUMANN_BC) then
  3531)         call MphaseAuxVarCompute_Ninc(xxbc,auxvars_bc(sum_connection)%auxvar_elem(0), &
  3532)            global_auxvars_bc(sum_connection),iphasebc,&
  3533)            patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
  3534)            realization%fluid_properties,option)
  3535)         call MphaseAuxVarCompute_Winc(xxbc,delxbc,&
  3536)            auxvars_bc(sum_connection)%auxvar_elem(1:option%nflowdof),&
  3537)            global_auxvars_bc(sum_connection),iphasebc, &
  3538)            patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
  3539)            realization%fluid_properties,option)
  3540)     
  3541)         do nvar=1,option%nflowdof
  3542)           call MphaseBCFlux(boundary_condition%flow_condition%itype, &
  3543)             boundary_condition%flow_aux_real_var(:,iconn), &
  3544)             auxvars_bc(sum_connection)%auxvar_elem(nvar), &
  3545)             auxvars(ghosted_id)%auxvar_elem(nvar), &
  3546)             material_auxvars(ghosted_id)%porosity, &
  3547)             material_auxvars(ghosted_id)%tortuosity, &
  3548)             mphase_parameter%sir(:,icap_dn), &
  3549)             cur_connection_set%dist(0,iconn),perm_dn,D_dn, &
  3550)             cur_connection_set%area(iconn), &
  3551)             distance_gravity,option, &
  3552)             vv_darcy,vol_frac_prim,Res)
  3553)           ResInc(local_id,1:option%nflowdof,nvar) = &
  3554)               ResInc(local_id,1:option%nflowdof,nvar) - Res(1:option%nflowdof)
  3555)         enddo
  3556)       endif
  3557)     enddo
  3558)     boundary_condition => boundary_condition%next
  3559)   enddo
  3560) #endif
  3561) 
  3562) ! Set matrix values related to single node terms: Accumulation, Source/Sink, BC
  3563)   do local_id = 1, grid%nlmax  ! For each local node do...
  3564)     ghosted_id = grid%nL2G(local_id)
  3565)     !geh - Ignore inactive cells with inactive materials
  3566)     if (associated(patch%imat)) then
  3567)       if (patch%imat(ghosted_id) <= 0) cycle
  3568)     endif
  3569) 
  3570)     ra = 0.D0
  3571) !   max_dev = 0.D0
  3572)     do neq = 1, option%nflowdof
  3573)       do nvar = 1, option%nflowdof
  3574)         ra(neq,nvar) = (ResInc(local_id,neq,nvar) - mphase%res_old_AR(local_id,neq)) &
  3575)                      /mphase%delx(nvar,ghosted_id)
  3576) 
  3577) !       print *,'finite dif: ',neq,nvar,ra(neq,nvar),ResInc(local_id,neq,nvar),mphase%res_old_AR(local_id,neq), &
  3578) !       mphase%delx(nvar,ghosted_id)
  3579) 
  3580) !       if (max_dev < dabs(ra(3,nvar))) max_dev = dabs(ra(3,nvar))
  3581)       enddo
  3582)     enddo
  3583)    
  3584)     select case(option%idt_switch)
  3585)       case(1) 
  3586)         ra(1:option%nflowdof,1:option%nflowdof) = ra(1:option%nflowdof,1:option%nflowdof)/option%flow_dt
  3587)       case(-1)
  3588)         if (option%flow_dt > 1) ra(1:option%nflowdof,1:option%nflowdof) = ra(1:option%nflowdof,1:option%nflowdof)/option%flow_dt
  3589)     end select
  3590) 
  3591)     Jup = ra(1:option%nflowdof,1:option%nflowdof)
  3592) 
  3593)     if (option%use_mc) then
  3594) 
  3595)       call MphaseSecondaryHeatJacobian(sec_heat_vars(local_id), &
  3596)                         mphase_parameter%ckwet(int(ithrm_loc_p(ghosted_id))), &
  3597)                         mphase_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  3598)                         option,jac_sec_heat)
  3599)  ! sk - option%flow_dt cancels out with option%flow_dt in the denominator for the term below                                      
  3600)       Jup(option%nflowdof,2) = Jup(option%nflowdof,2) - &
  3601)                                jac_sec_heat* &
  3602)                                material_auxvars(ghosted_id)%volume
  3603)     endif
  3604) 
  3605) !   if (volume_p(local_id) > 1.D0) &    ! karra added 05/06/2013
  3606)       Jup = Jup / material_auxvars(ghosted_id)%volume
  3607) 
  3608)      ! if (n==1) print *,  blkmat11, volume_p(n), ra
  3609)     call MatSetValuesBlockedLocal(A,1,ghosted_id-1,1,ghosted_id-1,Jup,ADD_VALUES, &
  3610)                                   ierr);CHKERRQ(ierr)
  3611)   end do
  3612) 
  3613)   if (realization%debug%matview_Jacobian_detailed) then
  3614)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3615)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3616)     string = 'jacobian_srcsink'
  3617)     call DebugCreateViewer(realization%debug,string,option,viewer)
  3618)     call MatView(A,PETSC_VIEWER_STDOUT_WORLD,ierr);CHKERRQ(ierr)
  3619)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  3620)   endif
  3621) #if 1
  3622)   ! Interior Flux Terms -----------------------------------  
  3623)   connection_set_list => grid%internal_connection_set_list
  3624)   cur_connection_set => connection_set_list%first
  3625)   sum_connection = 0    
  3626)   ResInc = 0.D0
  3627)   do 
  3628)     if (.not.associated(cur_connection_set)) exit
  3629)     do iconn = 1, cur_connection_set%num_connections
  3630)       sum_connection = sum_connection + 1
  3631)     
  3632)       ghosted_id_up = cur_connection_set%id_up(iconn)
  3633)       ghosted_id_dn = cur_connection_set%id_dn(iconn)
  3634) 
  3635)       if (associated(patch%imat)) then
  3636)         if (patch%imat(ghosted_id_up) <= 0 .or. &
  3637)             patch%imat(ghosted_id_dn) <= 0) cycle
  3638)       endif
  3639) 
  3640)       local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
  3641)       local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping   
  3642)      ! natural_id_up = grid%nG2N(ghosted_id_up)
  3643)      ! natural_id_dn = grid%nG2N(ghosted_id_dn)
  3644)    
  3645)       fraction_upwind = cur_connection_set%dist(-1,iconn)
  3646)       distance = cur_connection_set%dist(0,iconn)
  3647)       ! distance = scalar - magnitude of distance
  3648)       ! gravity = vector(3)
  3649)       ! dist(1:3,iconn) = vector(3) - unit vector
  3650)       distance_gravity = distance * &
  3651)                          dot_product(option%gravity, &
  3652)                                      cur_connection_set%dist(1:3,iconn))
  3653)       dd_up = distance*fraction_upwind
  3654)       dd_dn = distance-dd_up ! should avoid truncation error
  3655)       ! upweight could be calculated as 1.d0-fraction_upwind
  3656)       ! however, this introduces ever so slight error causing pflow-overhaul not
  3657)       ! to match pflow-orig.  This can be changed to 1.d0-fraction_upwind
  3658)       upweight = dd_dn/(dd_up+dd_dn)
  3659)     
  3660)       ! for now, just assume diagonal tensor
  3661)       call material_auxvars(ghosted_id_up)%PermeabilityTensorToScalar( &
  3662)                             cur_connection_set%dist(:,iconn),perm_up)
  3663)       call material_auxvars(ghosted_id_dn)%PermeabilityTensorToScalar( &
  3664)                             cur_connection_set%dist(:,iconn),perm_dn)
  3665)     
  3666)       iphas_up = int(iphase_loc_p(ghosted_id_up))
  3667)       iphas_dn = int(iphase_loc_p(ghosted_id_dn))
  3668) 
  3669)       ithrm_up = int(ithrm_loc_p(ghosted_id_up))
  3670)       ithrm_dn = int(ithrm_loc_p(ghosted_id_dn))
  3671)       D_up = mphase_parameter%ckwet(ithrm_up)
  3672)       D_dn = mphase_parameter%ckwet(ithrm_dn)
  3673)     
  3674)       icap_up = int(icap_loc_p(ghosted_id_up))
  3675)       icap_dn = int(icap_loc_p(ghosted_id_dn))
  3676) 
  3677)       
  3678)       do nvar = 1, option%nflowdof 
  3679)         call MphaseFlux(auxvars(ghosted_id_up)%auxvar_elem(nvar), &
  3680)                          material_auxvars(ghosted_id_up)%porosity, &
  3681)                          material_auxvars(ghosted_id_up)%tortuosity, &
  3682)                          mphase_parameter%sir(:,icap_up), &
  3683)                          dd_up,perm_up,D_up, &
  3684)                          auxvars(ghosted_id_dn)%auxvar_elem(0), &
  3685)                          material_auxvars(ghosted_id_dn)%porosity, &
  3686)                          material_auxvars(ghosted_id_dn)%tortuosity, &
  3687)                          mphase_parameter%sir(:,icap_dn), &
  3688)                          dd_dn,perm_dn,D_dn, &
  3689)                          cur_connection_set%area(iconn), &
  3690)                          distance_gravity, &
  3691)                          upweight, option, vv_darcy, vol_frac_prim, Res)
  3692)                          
  3693)         ra(:,nvar) = (Res(:)-mphase%res_old_FL(iconn,:))/ &
  3694)                      mphase%delx(nvar,ghosted_id_up)
  3695) 
  3696)         call MphaseFlux(auxvars(ghosted_id_up)%auxvar_elem(0), &
  3697)                          material_auxvars(ghosted_id_up)%porosity, &
  3698)                          material_auxvars(ghosted_id_up)%tortuosity, &
  3699)                          mphase_parameter%sir(:,icap_up), &
  3700)                          dd_up,perm_up,D_up, &
  3701)                          auxvars(ghosted_id_dn)%auxvar_elem(nvar), &
  3702)                          material_auxvars(ghosted_id_dn)%porosity,&
  3703)                          material_auxvars(ghosted_id_dn)%tortuosity, &
  3704)                          mphase_parameter%sir(:,icap_dn), &
  3705)                          dd_dn,perm_dn,D_dn, &
  3706)                          cur_connection_set%area(iconn),distance_gravity, &
  3707)                          upweight, option, vv_darcy, vol_frac_prim, Res)
  3708)       
  3709)         ra(:,nvar+option%nflowdof) = (Res(:)-mphase%res_old_FL(iconn,:)) &
  3710)                                       /mphase%delx(nvar,ghosted_id_dn)
  3711)       enddo
  3712) 
  3713)       select case(option%idt_switch)
  3714)       case(1)
  3715)         ra = ra / option%flow_dt
  3716)       case(-1)  
  3717)         if (option%flow_dt>1)  ra = ra / option%flow_dt
  3718)       end select
  3719)     
  3720)       if (local_id_up > 0) then
  3721)         voltemp=1.D0
  3722) !       if (volume_p(local_id_up) > 1.D0)then   ! karra added 05/06/2013
  3723)           voltemp = 1.D0 / material_auxvars(ghosted_id_up)%volume
  3724) !       endif
  3725)         Jup(:,1:option%nflowdof)= ra(:,1:option%nflowdof)*voltemp !11
  3726)         Jdn(:,1:option%nflowdof)= &
  3727)           ra(:,1 + option%nflowdof:2 * option%nflowdof)*voltemp !12
  3728) 
  3729)         call MatSetValuesBlockedLocal(A,1,ghosted_id_up-1,1,ghosted_id_up-1, &
  3730)             Jup,ADD_VALUES,ierr);CHKERRQ(ierr)
  3731)         call MatSetValuesBlockedLocal(A,1,ghosted_id_up-1,1,ghosted_id_dn-1, &
  3732)             Jdn,ADD_VALUES,ierr);CHKERRQ(ierr)
  3733)       endif
  3734)       if (local_id_dn > 0) then
  3735)         voltemp = 1.D0
  3736) !       if (volume_p(local_id_dn) > 1.D0) then   ! karra added 05/06/2013
  3737)           voltemp = 1.D0 / material_auxvars(ghosted_id_dn)%volume
  3738) !       endif
  3739)         Jup(:,1:option%nflowdof) = -ra(:,1:option%nflowdof)*voltemp !21
  3740)         Jdn(:,1:option%nflowdof) = -ra(:, 1 + option%nflowdof:2 * option%nflowdof)*voltemp !22
  3741) 
  3742)         call MatSetValuesBlockedLocal(A,1,ghosted_id_dn-1,1,ghosted_id_dn-1, &
  3743)             Jdn,ADD_VALUES,ierr);CHKERRQ(ierr)
  3744)         call MatSetValuesBlockedLocal(A,1,ghosted_id_dn-1,1,ghosted_id_up-1, &
  3745)             Jup,ADD_VALUES,ierr);CHKERRQ(ierr)
  3746)       endif
  3747)     enddo
  3748)     cur_connection_set => cur_connection_set%next
  3749)   enddo
  3750) #endif
  3751)   if (realization%debug%matview_Jacobian_detailed) then
  3752)  ! print *,'end inter flux'
  3753)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3754)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3755)     string = 'jacobian_flux'
  3756)     call DebugCreateViewer(realization%debug,string,option,viewer)
  3757)     call MatView(A,PETSC_VIEWER_STDOUT_WORLD,ierr);CHKERRQ(ierr)
  3758)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  3759)   endif
  3760) #if 0
  3761)   if (realization%debug%matview_Jacobian_detailed) then
  3762)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3763)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3764)     call PetscViewerASCIIOpen(option%mycomm,'jacobian_bcflux.out',viewer, &
  3765)                               ierr);CHKERRQ(ierr)
  3766)     call MatView(A,viewer,ierr);CHKERRQ(ierr)
  3767)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  3768)   endif
  3769) #endif
  3770)   
  3771)   call VecRestoreArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  3772)    
  3773)   call VecRestoreArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  3774)   call VecRestoreArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  3775)   call VecRestoreArrayF90(field%iphas_loc, iphase_loc_p, ierr);CHKERRQ(ierr)
  3776)  !print *,'end jac'
  3777)   call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3778)   call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3779)  ! call MatView(A,PETSC_VIEWER_STDOUT_WORLD,ierr)
  3780) #if 0
  3781) ! zero out isothermal and inactive cells
  3782) #ifdef ISOTHERMAL
  3783)   zero = 0.d0
  3784)   call MatZeroRowsLocal(A,n_zero_rows,zero_rows_local_ghosted,zero, &
  3785)                         PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
  3786)                         ierr);CHKERRQ(ierr)
  3787)   do i=1, n_zero_rows
  3788)     ii = mod(zero_rows_local(i),option%nflowdof)
  3789)     ip1 = zero_rows_local_ghosted(i)
  3790)     if (ii == 0) then
  3791)       ip2 = ip1-1
  3792)     elseif (ii == option%nflowdof-1) then
  3793)       ip2 = ip1+1
  3794)     else
  3795)       ip2 = ip1
  3796)     endif
  3797)     call MatSetValuesLocal(A,1,ip1,1,ip2,1.d0,INSERT_VALUES, &
  3798)                            ierr);CHKERRQ(ierr)
  3799)   enddo
  3800) 
  3801)   call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3802)   call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  3803) #else
  3804) #endif
  3805) #endif
  3806) 
  3807)   if (mphase%inactive_cells_exist) then
  3808)     f_up = 1.d0
  3809)     call MatZeroRowsLocal(A,mphase%n_zero_rows, &
  3810)                           mphase%zero_rows_local_ghosted,f_up, &
  3811)                           PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
  3812)                           ierr);CHKERRQ(ierr)
  3813)   endif
  3814) 
  3815) end subroutine MphaseJacobianPatch
  3816) 
  3817) ! ************************************************************************** !
  3818) 
  3819) subroutine MphaseMaxChange(realization,dpmax,dtmpmax,dsmax,dcmax)
  3820)   ! 
  3821)   ! Computes the maximum change in the solution vector
  3822)   ! 
  3823)   ! Author: Glenn Hammond
  3824)   ! Date: 01/15/08
  3825)   ! 
  3826) 
  3827)   use Realization_Subsurface_class
  3828)   use Field_module
  3829)   use Option_module
  3830)   use Field_module
  3831) 
  3832)   implicit none
  3833)   
  3834)   type(realization_subsurface_type) :: realization
  3835) 
  3836)   type(option_type), pointer :: option
  3837)   type(field_type), pointer :: field
  3838)   PetscReal :: dpmax, dtmpmax, dsmax, dcmax
  3839)   PetscErrorCode :: ierr 
  3840) 
  3841)   option => realization%option
  3842)   field => realization%field
  3843) 
  3844)   dpmax = 0.d0
  3845)   dtmpmax = 0.d0
  3846)   dcmax = 0.d0
  3847)   dsmax = 0.d0
  3848) 
  3849)   call VecWAXPY(field%flow_dxx,-1.d0,field%flow_xx,field%flow_yy, &
  3850)                 ierr);CHKERRQ(ierr)
  3851)   call VecStrideNorm(field%flow_dxx,ZERO_INTEGER,NORM_INFINITY,dpmax, &
  3852)                      ierr);CHKERRQ(ierr)
  3853)   call VecStrideNorm(field%flow_dxx,ONE_INTEGER,NORM_INFINITY,dtmpmax, &
  3854)                      ierr);CHKERRQ(ierr)
  3855) 
  3856)   call MphaseMaxChangePatch(realization, dcmax, dsmax)
  3857) 
  3858)   call MPI_Allreduce(MPI_IN_PLACE,dcmax,ONE_INTEGER_MPI,MPI_DOUBLE_PRECISION, &
  3859)                      MPI_MAX,option%mycomm,ierr)
  3860)   call MPI_Allreduce(MPI_IN_PLACE,dsmax,ONE_INTEGER_MPI,MPI_DOUBLE_PRECISION, &
  3861)                      MPI_MAX,option%mycomm,ierr)
  3862) 
  3863) end subroutine MphaseMaxChange
  3864) 
  3865) ! ************************************************************************** !
  3866) 
  3867) subroutine MphaseMaxChangePatch(realization,  max_c, max_s)
  3868) 
  3869)   use Realization_Subsurface_class
  3870)   use Grid_module
  3871)   use Patch_module
  3872)   use Field_module
  3873)   use Option_module
  3874)   implicit none
  3875)   
  3876)   type(realization_subsurface_type) :: realization
  3877)   PetscReal :: max_s, max_c 
  3878) 
  3879) 
  3880)   type(grid_type), pointer :: grid
  3881)   type(patch_type), pointer :: patch
  3882)   type(field_type), pointer :: field
  3883)   type(option_type), pointer :: option 
  3884)   PetscErrorCode :: ierr
  3885)   PetscReal, pointer :: xx_p(:), yy_p(:),  iphase_loc_p(:),  iphase_old_loc_p(:) 
  3886)   PetscInt :: local_id, ghosted_id, n0 
  3887)   PetscReal :: cmp
  3888)   
  3889)   patch => realization%patch
  3890)   grid => patch%grid
  3891)   field => realization%field
  3892)   option => realization%option
  3893) 
  3894)   max_c=0.D0
  3895)   max_s=0.D0
  3896)   
  3897)  
  3898) 
  3899)   call VecGetArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
  3900)   call VecGetArrayF90(field%flow_yy,yy_p, ierr);CHKERRQ(ierr)
  3901)   call VecGetArrayF90(field%iphas_loc,iphase_loc_p, ierr);CHKERRQ(ierr)
  3902)   call VecGetArrayF90(field%iphas_old_loc,iphase_old_loc_p,  &
  3903)                       ierr);CHKERRQ(ierr)
  3904) 
  3905)   do local_id =1, grid%nlmax
  3906)     ghosted_id = grid%nL2G(local_id)
  3907)        if (associated(patch%imat)) then
  3908)         if (patch%imat(ghosted_id) <= 0) cycle
  3909)      endif
  3910)     n0 = (local_id-1)*option%nflowdof 
  3911)     if (int(iphase_loc_p(ghosted_id)) == int(iphase_old_loc_p(ghosted_id)))then
  3912)        cmp=dabs(xx_p(n0+3)-yy_p(n0+3))
  3913)        if (int(iphase_loc_p(ghosted_id))==1 .or.int(iphase_loc_p(ghosted_id))==2)then
  3914)           if (max_c<cmp) max_c = cmp
  3915)        endif
  3916)        if (int(iphase_loc_p(ghosted_id))==3)then
  3917)          if (max_s<cmp) max_s=cmp
  3918)       endif
  3919)    end if
  3920)   end do
  3921) 
  3922)   call VecRestoreArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
  3923)   call VecRestoreArrayF90(field%flow_yy,yy_p, ierr);CHKERRQ(ierr)
  3924)   call VecRestoreArrayF90(field%iphas_loc,iphase_loc_p, ierr);CHKERRQ(ierr)
  3925)   call VecRestoreArrayF90(field%iphas_old_loc,iphase_old_loc_p,  &
  3926)                           ierr);CHKERRQ(ierr)
  3927) 
  3928) 
  3929)   
  3930) end subroutine MphaseMaxChangePatch
  3931) 
  3932) ! ************************************************************************** !
  3933) 
  3934) function MphaseGetTecplotHeader(realization,icolumn)
  3935)   ! 
  3936)   ! Returns Mphase contribution to
  3937)   ! Tecplot file header
  3938)   ! 
  3939)   ! Author: Glenn Hammond
  3940)   ! Date: 02/13/08
  3941)   ! 
  3942) 
  3943)   use Realization_Subsurface_class
  3944)   use Option_module
  3945)   use Field_module
  3946) 
  3947)   implicit none
  3948)   
  3949)   character(len=MAXSTRINGLENGTH) :: MphaseGetTecplotHeader
  3950)   type(realization_subsurface_type) :: realization
  3951)   PetscInt :: icolumn
  3952)   
  3953)   character(len=MAXSTRINGLENGTH) :: string, string2
  3954)   type(option_type), pointer :: option
  3955)   type(field_type), pointer :: field  
  3956)   PetscInt :: i
  3957)   
  3958)   option => realization%option
  3959)   field => realization%field
  3960)   
  3961)   string = ''
  3962) 
  3963)   if (icolumn > -1) then
  3964)     icolumn = icolumn + 1
  3965)     write(string2,'('',"'',i2,''-T [C]"'')') icolumn
  3966)   else
  3967)     write(string2,'('',"T [C]"'')')
  3968)   endif
  3969)   string = trim(string) // trim(string2)
  3970)   
  3971)   if (icolumn > -1) then
  3972)     icolumn = icolumn + 1
  3973)     write(string2,'('',"'',i2,''-P(l) [Pa]"'')') icolumn
  3974)   else
  3975)     write(string2,'('',"P(l) [Pa]"'')')
  3976)   endif
  3977)   string = trim(string) // trim(string2)
  3978)   
  3979)   if (icolumn > -1) then
  3980)     icolumn = icolumn + 1
  3981)     write(string2,'('',"'',i2,''-P(g) [Pa]"'')') icolumn
  3982)   else
  3983)     write(string2,'('',"P(g) [Pa]"'')')
  3984)   endif
  3985)   string = trim(string) // trim(string2)
  3986)   
  3987)   if (icolumn > -1) then
  3988)     icolumn = icolumn + 1
  3989)     write(string2,'('',"'',i2,''-S(l)"'')') icolumn
  3990)   else
  3991)     write(string2,'('',"S(l)"'')')
  3992)   endif
  3993)   string = trim(string) // trim(string2)
  3994) 
  3995)   if (icolumn > -1) then
  3996)     icolumn = icolumn + 1
  3997)     write(string2,'('',"'',i2,''-S(g)"'')') icolumn
  3998)   else
  3999)     write(string2,'('',"S(g)"'')')
  4000)   endif
  4001)   string = trim(string) // trim(string2)
  4002)     
  4003)   if (icolumn > -1) then
  4004)     icolumn = icolumn + 1
  4005)     write(string2,'('',"'',i2,''-d(l)"'')') icolumn
  4006)   else
  4007)     write(string2,'('',"d(l)"'')')
  4008)   endif
  4009)   string = trim(string) // trim(string2)
  4010) 
  4011)   if (icolumn > -1) then
  4012)     icolumn = icolumn + 1
  4013)     write(string2,'('',"'',i2,''-d(g)"'')') icolumn
  4014)   else
  4015)     write(string2,'('',"d(g)"'')')
  4016)   endif
  4017)   string = trim(string) // trim(string2)
  4018)     
  4019)   if (icolumn > -1) then
  4020)     icolumn = icolumn + 1
  4021)     write(string2,'('',"'',i2,''-u(l)"'')') icolumn
  4022)   else
  4023)     write(string2,'('',"u(l)"'')')
  4024)   endif
  4025)   string = trim(string) // trim(string2)
  4026) 
  4027)   if (icolumn > -1) then
  4028)     icolumn = icolumn + 1
  4029)     write(string2,'('',"'',i2,''-u(g)"'')') icolumn
  4030)   else
  4031)     write(string2,'('',"u(g)"'')')
  4032)   endif
  4033)   string = trim(string) // trim(string2)
  4034)   
  4035)   if (icolumn > -1) then
  4036)     icolumn = icolumn + 1
  4037)     write(string2,'('',"'',i2,''-vis(l)"'')') icolumn
  4038)   else
  4039)     write(string2,'('',"vis(l)"'')')
  4040)   endif
  4041)   string = trim(string) // trim(string2)
  4042) 
  4043)   if (icolumn > -1) then
  4044)     icolumn = icolumn + 1
  4045)     write(string2,'('',"'',i2,''-vis(g)"'')') icolumn
  4046)   else
  4047)     write(string2,'('',"vis(g)"'')')
  4048)   endif
  4049)   string = trim(string) // trim(string2)
  4050)     
  4051)   if (icolumn > -1) then
  4052)     icolumn = icolumn + 1
  4053)     write(string2,'('',"'',i2,''-kvr(l)"'')') icolumn
  4054)   else
  4055)     write(string2,'('',"kvr(l)"'')')
  4056)   endif
  4057)   string = trim(string) // trim(string2)
  4058) 
  4059)   if (icolumn > -1) then
  4060)     icolumn = icolumn + 1
  4061)     write(string2,'('',"'',i2,''-kvr(g)"'')') icolumn
  4062)   else
  4063)     write(string2,'('',"kvr(g)"'')')
  4064)   endif
  4065)   string = trim(string) // trim(string2)
  4066)     
  4067)   do i=1,option%nflowspec
  4068)     if (icolumn > -1) then
  4069)       icolumn = icolumn + 1
  4070)       write(string2,'('',"'',i2,''-Xl('',i1,'')"'')') icolumn, i
  4071)     else
  4072)       write(string2,'('',"Xl('',i1,'')"'')') i
  4073)     endif
  4074)     string = trim(string) // trim(string2)
  4075)   enddo
  4076) 
  4077)   do i=1,option%nflowspec
  4078)     if (icolumn > -1) then
  4079)       icolumn = icolumn + 1
  4080)       write(string2,'('',"'',i2,''-Xg('',i1,'')"'')') icolumn, i
  4081)     else
  4082)       write(string2,'('',"Xg('',i1,'')"'')') i
  4083)     endif
  4084)     string = trim(string) // trim(string2)
  4085)   enddo
  4086)   
  4087)   if (icolumn > -1) then
  4088)     icolumn = icolumn + 1
  4089)     write(string2,'('',"'',i2,''-PHASE"'')') icolumn
  4090)   else
  4091)     write(string2,'('',"PHASE"'')')
  4092)   endif
  4093)   string = trim(string) // trim(string2)
  4094)   
  4095)   MphaseGetTecplotHeader = string
  4096) 
  4097) end function MphaseGetTecplotHeader
  4098) 
  4099) ! ************************************************************************** !
  4100) 
  4101) subroutine MphaseSetPlotVariables(list)
  4102)   ! 
  4103)   ! Adds variables to be printed to list
  4104)   ! 
  4105)   ! Author: Glenn Hammond
  4106)   ! Date: 10/15/12
  4107)   ! 
  4108)   
  4109)   use Output_Aux_module
  4110)   use Variables_module
  4111) 
  4112)   implicit none
  4113) 
  4114)   type(output_variable_list_type), pointer :: list
  4115)   
  4116)   character(len=MAXWORDLENGTH) :: name, units
  4117)   type(output_variable_type) :: output_variable
  4118)   
  4119)   if (associated(list%first)) then
  4120)     return
  4121)   endif
  4122) 
  4123)   name = 'Temperature'
  4124)   units = 'C'
  4125)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4126)                                TEMPERATURE)
  4127)   
  4128)   name = 'Liquid Pressure'
  4129)   units = 'Pa'
  4130)   call OutputVariableAddToList(list,name,OUTPUT_PRESSURE,units, &
  4131)                                LIQUID_PRESSURE)
  4132)   
  4133)   name = 'Gas Pressure'
  4134)   units = 'Pa'
  4135)   call OutputVariableAddToList(list,name,OUTPUT_PRESSURE,units, &
  4136)                                GAS_PRESSURE)
  4137) 
  4138)   name = 'Liquid Saturation'
  4139)   units = ''
  4140)   call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
  4141)                                LIQUID_SATURATION)
  4142) 
  4143)   name = 'Gas Saturation'
  4144)   units = ''
  4145)   call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
  4146)                                GAS_SATURATION)
  4147) 
  4148)   name = 'Liquid Density'
  4149)   units = 'kg/m^3'
  4150)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4151)                                LIQUID_DENSITY)
  4152) 
  4153)   name = 'Gas Density'
  4154)   units = 'kg/m^3'
  4155)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4156)                                GAS_DENSITY)
  4157) 
  4158)   name = 'Liquid Energy'
  4159)   units = 'kJ/mol'
  4160)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4161)                                LIQUID_ENERGY)
  4162) 
  4163)   name = 'Gas Energy'
  4164)   units = 'kJ/mol'
  4165)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4166)                                GAS_ENERGY)
  4167) 
  4168)   name = 'Liquid Viscosity'
  4169)   units = 'Pa.s'
  4170)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4171)                                LIQUID_VISCOSITY)
  4172) 
  4173)   name = 'Gas Viscosity'
  4174)   units = 'Pa.s'
  4175)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4176)                                GAS_VISCOSITY)
  4177) 
  4178)   name = 'Liquid Mobility'
  4179)   units = '1/Pa.s'
  4180)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4181)                                LIQUID_MOBILITY)
  4182) 
  4183)   name = 'Gas Mobility'
  4184)   units = '1/Pa.s'
  4185)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4186)                                GAS_MOBILITY)
  4187) 
  4188)   name = 'Liquid Mole Fraction H2O'
  4189)   units = ''
  4190)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4191)                                LIQUID_MOLE_FRACTION,ONE_INTEGER)
  4192) 
  4193)   name = 'Liquid Mole Fraction CO2'
  4194)   units = ''
  4195)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4196)                                LIQUID_MOLE_FRACTION,TWO_INTEGER)
  4197) 
  4198)   name = 'Gas Mole Fraction H2O'
  4199)   units = ''
  4200)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4201)                                GAS_MOLE_FRACTION,ONE_INTEGER)
  4202) 
  4203)   name = 'Gas Mole Fraction CO2'
  4204)   units = ''
  4205)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4206)                                GAS_MOLE_FRACTION,TWO_INTEGER)
  4207) 
  4208)   name = 'Phase'
  4209)   units = ''
  4210)   output_variable%iformat = 1 ! integer
  4211)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  4212)                                PHASE)
  4213) 
  4214) end subroutine MphaseSetPlotVariables
  4215) 
  4216) ! ************************************************************************** !
  4217) 
  4218) subroutine MphaseSecondaryHeat(sec_heat_vars,auxvar,global_auxvar, &
  4219)                             therm_conductivity,dencpr, &
  4220)                             option,res_heat)
  4221)   ! 
  4222)   ! Calculates the source term contribution due to secondary
  4223)   ! continuum in the primary continuum residual
  4224)   ! 
  4225)   ! Author: Satish Karra, LANL
  4226)   ! Date: 06/26/12
  4227)   ! 
  4228)                             
  4229)   use Option_module 
  4230)   use Global_Aux_module
  4231)   use Secondary_Continuum_Aux_module
  4232) 
  4233)   implicit none
  4234)   
  4235)   type(sec_heat_type) :: sec_heat_vars
  4236)   type(mphase_auxvar_elem_type) :: auxvar
  4237)   type(global_auxvar_type) :: global_auxvar
  4238)   type(option_type) :: option
  4239)   PetscReal :: coeff_left(sec_heat_vars%ncells)
  4240)   PetscReal :: coeff_diag(sec_heat_vars%ncells)
  4241)   PetscReal :: coeff_right(sec_heat_vars%ncells)
  4242)   PetscReal :: rhs(sec_heat_vars%ncells)
  4243)   PetscReal :: sec_temp(sec_heat_vars%ncells)
  4244)   PetscReal :: area(sec_heat_vars%ncells)
  4245)   PetscReal :: vol(sec_heat_vars%ncells)
  4246)   PetscReal :: dm_plus(sec_heat_vars%ncells)
  4247)   PetscReal :: dm_minus(sec_heat_vars%ncells)
  4248)   PetscInt :: i, ngcells
  4249)   PetscReal :: area_fm
  4250)   PetscReal :: alpha, therm_conductivity, dencpr
  4251)   PetscReal :: temp_primary_node
  4252)   PetscReal :: m
  4253)   PetscReal :: temp_current_N
  4254)   PetscReal :: res_heat
  4255) 
  4256)   ngcells = sec_heat_vars%ncells
  4257)   area = sec_heat_vars%area
  4258)   vol = sec_heat_vars%vol
  4259)   dm_plus = sec_heat_vars%dm_plus
  4260)   dm_minus = sec_heat_vars%dm_minus
  4261)   area_fm = sec_heat_vars%interfacial_area
  4262) ! temp_primary_node = global_auxvar%temp
  4263)   temp_primary_node = auxvar%temp
  4264) 
  4265)   coeff_left = 0.d0
  4266)   coeff_diag = 0.d0
  4267)   coeff_right = 0.d0
  4268)   rhs = 0.d0
  4269)   
  4270)   alpha = option%flow_dt*therm_conductivity/dencpr
  4271) 
  4272)   
  4273)   ! Setting the coefficients
  4274)   do i = 2, ngcells-1
  4275)     coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
  4276)     coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
  4277)                     alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
  4278)     coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
  4279)   enddo
  4280)   
  4281)   coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
  4282)   coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
  4283)   
  4284)   coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
  4285)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
  4286)   coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
  4287)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
  4288)                        + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
  4289)                        + 1.d0
  4290)                         
  4291)   rhs = sec_heat_vars%sec_temp  ! secondary continuum values from previous time step
  4292)   rhs(ngcells) = rhs(ngcells) + & 
  4293)                  alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
  4294)                  temp_primary_node
  4295)                 
  4296)   ! Thomas algorithm for tridiagonal system
  4297)   ! Forward elimination
  4298)   do i = 2, ngcells
  4299)     m = coeff_left(i)/coeff_diag(i-1)
  4300)     coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
  4301)     rhs(i) = rhs(i) - m*rhs(i-1)
  4302)   enddo
  4303) 
  4304)   ! Back substitution
  4305)   ! We only need the temperature at the outer-most node (closest to primary node)
  4306)   temp_current_N = rhs(ngcells)/coeff_diag(ngcells)
  4307)   
  4308)   ! Calculate the coupling term
  4309)   res_heat = area_fm*therm_conductivity*(temp_current_N - temp_primary_node)/ &
  4310)              dm_plus(ngcells)
  4311)                           
  4312) end subroutine MphaseSecondaryHeat
  4313) 
  4314) ! ************************************************************************** !
  4315) 
  4316) subroutine MphaseSecondaryHeatJacobian(sec_heat_vars, &
  4317)                                     therm_conductivity, &
  4318)                                     dencpr, &
  4319)                                     option,jac_heat)
  4320)   ! 
  4321)   ! Calculates the source term jacobian contribution
  4322)   ! due to secondary continuum in the primary continuum residual
  4323)   ! 
  4324)   ! Author: Satish Karra, LANL
  4325)   ! Date: 06/6/12
  4326)   ! 
  4327)                                     
  4328)   use Option_module 
  4329)   use Global_Aux_module
  4330)   use Secondary_Continuum_Aux_module
  4331) 
  4332)   implicit none
  4333)   
  4334)   type(sec_heat_type) :: sec_heat_vars
  4335)   type(option_type) :: option
  4336)   PetscReal :: coeff_left(sec_heat_vars%ncells)
  4337)   PetscReal :: coeff_diag(sec_heat_vars%ncells)
  4338)   PetscReal :: coeff_right(sec_heat_vars%ncells)
  4339)   PetscReal :: rhs(sec_heat_vars%ncells)
  4340)   PetscReal :: area(sec_heat_vars%ncells)
  4341)   PetscReal :: vol(sec_heat_vars%ncells)
  4342)   PetscReal :: dm_plus(sec_heat_vars%ncells)
  4343)   PetscReal :: dm_minus(sec_heat_vars%ncells)
  4344)   PetscInt :: i, ngcells
  4345)   PetscReal :: area_fm
  4346)   PetscReal :: alpha, therm_conductivity, dencpr
  4347)   PetscReal :: m
  4348)   PetscReal :: Dtemp_N_Dtemp_prim
  4349)   PetscReal :: jac_heat
  4350)   
  4351)   ngcells = sec_heat_vars%ncells
  4352)   area = sec_heat_vars%area
  4353)   vol = sec_heat_vars%vol
  4354)   dm_plus = sec_heat_vars%dm_plus
  4355)   area_fm = sec_heat_vars%interfacial_area
  4356)   dm_minus = sec_heat_vars%dm_minus
  4357)  
  4358)   coeff_left = 0.d0
  4359)   coeff_diag = 0.d0
  4360)   coeff_right = 0.d0
  4361)   rhs = 0.d0
  4362)   
  4363)   alpha = option%flow_dt*therm_conductivity/dencpr
  4364) 
  4365)   
  4366) ! Setting the coefficients
  4367)   do i = 2, ngcells-1
  4368)     coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
  4369)     coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
  4370)                     alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
  4371)     coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
  4372)   enddo
  4373)   
  4374)   coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
  4375)   coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
  4376)   
  4377)   coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
  4378)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
  4379)   coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
  4380)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
  4381)                        + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
  4382)                        + 1.d0
  4383)                                         
  4384)   ! Thomas algorithm for tridiagonal system
  4385)   ! Forward elimination
  4386)   do i = 2, ngcells
  4387)     m = coeff_left(i)/coeff_diag(i-1)
  4388)     coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
  4389)     ! We do not have to calculate rhs terms
  4390)   enddo
  4391) 
  4392)   ! We need the temperature derivative at the outer-most node (closest to primary node)
  4393)   Dtemp_N_Dtemp_prim = 1.d0/coeff_diag(ngcells)*alpha*area(ngcells)/ &
  4394)                        (dm_plus(ngcells)*vol(ngcells))
  4395)   
  4396)   ! Calculate the jacobian term
  4397)   jac_heat = area_fm*therm_conductivity*(Dtemp_N_Dtemp_prim - 1.d0)/ &
  4398)              dm_plus(ngcells)
  4399)                             
  4400)               
  4401) end subroutine MphaseSecondaryHeatJacobian
  4402) 
  4403) ! ************************************************************************** !
  4404) 
  4405) subroutine MphaseDestroy(realization)
  4406)   ! 
  4407)   ! Deallocates variables associated with Richard
  4408)   ! 
  4409)   ! Author: Glenn Hammond
  4410)   ! Date: 02/14/08
  4411)   ! 
  4412) 
  4413)   use Realization_Subsurface_class
  4414) 
  4415)   implicit none
  4416)   
  4417)   type(realization_subsurface_type) :: realization
  4418)   
  4419)   ! need to free array in aux vars
  4420)   !call MphaseAuxDestroy(patch%aux%mphase)
  4421) 
  4422) end subroutine MphaseDestroy
  4423) 
  4424) #if 0
  4425) 
  4426) ! ************************************************************************** !
  4427) 
  4428) subroutine MphaseCheckpointWrite(discretization, viewer)
  4429)   ! 
  4430)   ! Writes vecs to checkpoint file
  4431)   ! 
  4432)   use Discretization_module
  4433) 
  4434)   implicit none
  4435)   
  4436)   type(discretization_type) :: discretization
  4437)   PetscViewer :: viewer
  4438)   
  4439)   Vec :: global_var
  4440)   PetscErrorCode :: ierr
  4441)   
  4442)   call VecView(global_var,viewer,ierr);CHKERRQ(ierr)
  4443)   call VecDestroy(global_var,ierr);CHKERRQ(ierr)
  4444)   
  4445)   ! solid volume fraction
  4446)   if (mphase_option%rk > 0.d0) then
  4447)     call VecView(mphase_field%phis, viewer, ierr);CHKERRQ(ierr)
  4448)   endif  
  4449)   
  4450) end subroutine MphaseCheckpointWrite
  4451) 
  4452) ! ************************************************************************** !
  4453) 
  4454) subroutine MphaseCheckpointRead(discretization,viewer)
  4455)   ! 
  4456)   ! Reads vecs from checkpoint file
  4457)   ! 
  4458)   use Discretization_module
  4459) 
  4460)   implicit none
  4461)   
  4462)   type(discretization_type) :: discretization
  4463)   PetscViewer :: viewer
  4464)   
  4465)   Vec :: global_var
  4466)   PetscErrorCode :: ierr
  4467)   
  4468)   call VecLoad(global_var, viewer, ierr);CHKERRQ(ierr)
  4469)   call VecDestroy(global_var,ierr);CHKERRQ(ierr)
  4470)   ! solid volume fraction
  4471)   if (mphase_option%rk > 0.d0) then
  4472)     call VecLoad(mphase_field%phis, viewer, ierr);CHKERRQ(ierr)
  4473)   endif  
  4474)   
  4475) end subroutine MphaseCheckpointRead
  4476) 
  4477) #endif
  4478) 
  4479) end module Mphase_module

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