immis.F90       coverage:  0.00 %func     0.00 %block


     1) module Immis_module
     2)   
     3)   use Immis_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) !#endif
    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 ImmisResidual,ImmisJacobian, &
    47)          ImmisUpdateFixedAccumulation,ImmisTimeCut, &
    48)          ImmisSetup,ImmisUpdateReason, &
    49)          ImmisMaxChange,ImmisUpdateSolution, &
    50)          ImmisGetTecplotHeader,ImmisInitializeTimestep, &
    51)          ImmisUpdateAuxVars, &
    52)          ImmisComputeMassBalance, &
    53)          ImmisDestroy
    54) 
    55) contains
    56) 
    57) ! ************************************************************************** !
    58) 
    59) subroutine ImmisTimeCut(realization)
    60)   ! 
    61)   ! Resets arrays for time step cut
    62)   ! 
    63)   ! Author: Chuan Lu
    64)   ! Date: 9/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) end subroutine ImmisTimeCut
    85) 
    86) ! ************************************************************************** !
    87) 
    88) subroutine ImmisSetup(realization)
    89)   ! 
    90)   ! Author: Chuan Lu
    91)   ! Date: 9/13/08
    92)   ! 
    93) 
    94)   use Realization_Subsurface_class
    95)   use Patch_module
    96)   use Output_Aux_module
    97)   use co2_span_wagner_module
    98)   use co2_sw_module
    99)   use co2_span_wagner_spline_module
   100)    
   101)   type(realization_subsurface_type) :: realization
   102)   
   103)   type(patch_type), pointer :: cur_patch
   104)   type(output_variable_list_type), pointer :: list
   105) 
   106)   cur_patch => realization%patch_list%first
   107)   do
   108)     if (.not.associated(cur_patch)) exit
   109)     realization%patch => cur_patch
   110)     call ImmisSetupPatch(realization)
   111)     cur_patch => cur_patch%next
   112)   enddo
   113) 
   114)   list => realization%output_option%output_snap_variable_list
   115)   call ImmisSetPlotVariables(list)
   116)   list => realization%output_option%output_obs_variable_list
   117)   call ImmisSetPlotVariables(list)
   118) 
   119) end subroutine ImmisSetup
   120) 
   121) ! ************************************************************************** !
   122) 
   123) subroutine ImmisSetupPatch(realization)
   124)   ! 
   125)   ! Creates arrays for auxiliary variables
   126)   ! 
   127)   ! Author: Chuan Lu
   128)   ! Date: 10/1/08
   129)   ! 
   130) 
   131)   use Realization_Subsurface_class
   132)   use Patch_module
   133)   use Option_module
   134)   use Coupler_module
   135)   use Connection_module
   136)   use Grid_module
   137)  
   138)   implicit none
   139)   
   140)   type(realization_subsurface_type) :: realization
   141) 
   142)   type(option_type), pointer :: option
   143)   type(patch_type),pointer :: patch
   144)   type(grid_type), pointer :: grid
   145)   type(coupler_type), pointer :: boundary_condition
   146)   type(coupler_type), pointer :: source_sink
   147) 
   148)   PetscInt :: ghosted_id, iconn, sum_connection, ipara
   149)   type(Immis_auxvar_type), pointer :: auxvars(:)
   150)   type(Immis_auxvar_type), pointer :: auxvars_bc(:)  
   151)   type(Immis_auxvar_type), pointer :: auxvars_ss(:)  
   152)   
   153)   option => realization%option
   154)   patch => realization%patch
   155)   grid => patch%grid
   156) 
   157)   patch%aux%Immis => ImmisAuxCreate()
   158)   
   159) !  option%io_buffer = 'Before Immis can be run, the thc_parameter object ' // &
   160) !                     'must be initialized with the proper variables ' // &
   161) !                     'ImmisAuxCreate() is called anyhwere.'
   162) !  call printErrMsg(option)
   163) ! print *,' ims setup get Aux', option%nphase, size(patch%saturation_function_array)     
   164) ! immis_parameters create *********************************************
   165) ! Sir
   166)   allocate(patch%aux%Immis%Immis_parameter%sir(option%nphase, &
   167)                                   size(patch%saturation_function_array)))
   168)                                 
   169)   do ipara = 1, size(patch%saturation_function_array)
   170)     patch%aux%Immis%immis_parameter%sir(:,patch% &
   171)         saturation_function_array(ipara)%ptr%id) = &
   172)       patch%saturation_function_array(ipara)%ptr%Sr(:)
   173)   enddo
   174) 
   175) ! dencpr  
   176)   allocate(patch%aux%Immis%Immis_parameter%dencpr(size(patch%material_property_array)))
   177)   do ipara = 1, size(patch%material_property_array)
   178)     patch%aux%Immis%Immis_parameter%dencpr(iabs(patch% &
   179)         material_property_array(ipara)%ptr%internal_id)) = &
   180)       patch%material_property_array(ipara)%ptr%rock_density*option%scale*&
   181)       patch%material_property_array(ipara)%ptr%specific_heat
   182)   enddo
   183) ! ckwet
   184)   allocate(patch%aux%Immis%Immis_parameter%ckwet(size(patch%material_property_array)))
   185)   do ipara = 1, size(patch%material_property_array)
   186)     patch%aux%Immis%Immis_parameter%ckwet(iabs(patch% &
   187)         material_property_array(ipara)%ptr%internal_id)) = &
   188)       patch%material_property_array(ipara)%ptr%thermal_conductivity_wet*option%scale
   189)   enddo
   190) ! immis_parameters create_end *****************************************
   191) 
   192) ! allocate auxvar data structures for all grid cells  
   193)   allocate(auxvars(grid%ngmax))
   194)   ! print *,' ims setup get Aux alloc', grid%ngmax
   195)   do ghosted_id = 1, grid%ngmax
   196)     call ImmisAuxVarInit(auxvars(ghosted_id),option)
   197)   enddo
   198)   patch%aux%Immis%auxvars => auxvars
   199)   patch%aux%Immis%num_aux = grid%ngmax
   200)   ! print *,' ims setup get Aux init'
   201) 
   202)   allocate(patch%aux%Immis%delx(option%nflowdof, grid%ngmax))
   203)   allocate(patch%aux%Immis%res_old_AR(grid%nlmax,option%nflowdof))
   204)   allocate(patch%aux%Immis%res_old_FL(ConnectionGetNumberInList(patch%grid%&
   205)            internal_connection_set_list),option%nflowdof))
   206)   ! print *,' ims setup allocate app array'
   207)    ! count the number of boundary connections and allocate
   208)   ! auxvar data structures for them  
   209)   boundary_condition => patch%boundary_condition_list%first
   210)   sum_connection = 0    
   211)   do 
   212)     if (.not.associated(boundary_condition)) exit
   213)     sum_connection = sum_connection + &
   214)                      boundary_condition%connection_set%num_connections
   215)     boundary_condition => boundary_condition%next
   216)   enddo
   217)   allocate(auxvars_bc(sum_connection))
   218)   ! print *,' ims setup get AuxBc alloc', sum_connection
   219)   do iconn = 1, sum_connection
   220)     call ImmisAuxVarInit(auxvars_bc(iconn),option)
   221)   enddo
   222)   patch%aux%Immis%auxvars_bc => auxvars_bc
   223)   patch%aux%Immis%num_aux_bc = sum_connection
   224)   
   225)  ! Allocate source /sink  
   226)   source_sink => patch%source_sink_list%first
   227)   sum_connection = 0    
   228)   do 
   229)     if (.not.associated(source_sink)) exit
   230)     sum_connection = sum_connection + &
   231)                      source_sink%connection_set%num_connections
   232)     source_sink => source_sink%next
   233)   enddo
   234)   allocate(auxvars_ss(sum_connection))
   235)   do iconn = 1, sum_connection
   236)     call ImmisAuxVarInit(auxvars_ss(iconn),option)
   237)   enddo
   238)   patch%aux%Immis%auxvars_ss => auxvars_ss
   239)   patch%aux%Immis%num_aux_ss = sum_connection
   240)   
   241)   option%flow%numerical_derivatives = PETSC_TRUE
   242) 
   243) end subroutine ImmisSetupPatch
   244) 
   245) ! ************************************************************************** !
   246) 
   247) subroutine ImmisComputeMassBalance(realization,mass_balance)
   248)   ! 
   249)   ! Author: Glenn Hammond
   250)   ! Date: 02/22/08
   251)   ! 
   252) 
   253)   use Realization_Subsurface_class
   254)   use Patch_module
   255) 
   256)   type(realization_subsurface_type) :: realization
   257) ! PetscReal :: mass_balance(realization%option%nflowspec,realization%option%nphase)
   258)   PetscReal :: mass_balance(realization%option%nflowspec,1)
   259)   
   260)   type(patch_type), pointer :: cur_patch
   261)   
   262)   mass_balance = 0.d0
   263)   
   264)   cur_patch => realization%patch_list%first
   265)   do
   266)     if (.not.associated(cur_patch)) exit
   267)     realization%patch => cur_patch
   268)     call ImmisComputeMassBalancePatch(realization,mass_balance)
   269)     cur_patch => cur_patch%next
   270)   enddo
   271) 
   272) end subroutine ImmisComputeMassBalance
   273) 
   274) ! ************************************************************************** !
   275) 
   276) subroutine ImmisComputeMassBalancePatch(realization,mass_balance)
   277)   ! 
   278)   ! Initializes mass balance
   279)   ! 
   280)   ! Author: Glenn Hammond
   281)   ! Date: 12/19/08
   282)   ! 
   283)  
   284)   use Realization_Subsurface_class
   285)   use Option_module
   286)   use Patch_module
   287)   use Field_module
   288)   use Grid_module
   289)   use Material_Aux_class
   290)  
   291)   implicit none
   292)   
   293)   type(realization_subsurface_type) :: realization
   294) ! PetscReal :: mass_balance(realization%option%nflowspec,realization%option%nphase)
   295)   PetscReal :: mass_balance(realization%option%nflowspec,1)
   296) 
   297)   type(option_type), pointer :: option
   298)   type(patch_type), pointer :: patch
   299)   type(field_type), pointer :: field
   300)   type(grid_type), pointer :: grid
   301)   type(immis_auxvar_type), pointer :: immis_auxvars(:)
   302)   class(material_auxvar_type), pointer :: material_auxvars(:)
   303) 
   304)   PetscErrorCode :: ierr
   305)   PetscInt :: local_id
   306)   PetscInt :: ghosted_id
   307)   PetscInt :: iphase
   308)   PetscInt :: ispec_start, ispec_end, ispec
   309) 
   310)   option => realization%option
   311)   patch => realization%patch
   312)   grid => patch%grid
   313)   field => realization%field
   314)   material_auxvars => realization%patch%aux%Material%auxvars
   315) 
   316)   immis_auxvars => patch%aux%immis%auxvars
   317) 
   318)   do local_id = 1, grid%nlmax
   319)     ghosted_id = grid%nL2G(local_id)
   320)     !geh - Ignore inactive cells with inactive materials
   321)     if (associated(patch%imat)) then
   322)       if (patch%imat(ghosted_id) <= 0) cycle
   323)     endif
   324)     ! mass = volume * saturation * density
   325)     do iphase = 1, option%nphase
   326)       ispec = iphase
   327)       mass_balance(ispec,1) = mass_balance(ispec,1) + &
   328)           immis_auxvars(ghosted_id)%auxvar_elem(0)%den(iphase)* &
   329)           immis_auxvars(ghosted_id)%auxvar_elem(0)%sat(iphase)* &
   330)           material_auxvars(ghosted_id)%porosity* &
   331)           material_auxvars(ghosted_id)%volume
   332)     enddo
   333)   enddo
   334) 
   335) end subroutine ImmisComputeMassBalancePatch
   336) 
   337) ! ************************************************************************** !
   338) 
   339) subroutine ImmisZeroMassBalDeltaPatch(realization)
   340)   ! 
   341)   ! Zeros mass balance delta array
   342)   ! 
   343)   ! Author: Glenn Hammond
   344)   ! Date: 12/19/08
   345)   ! 
   346)  
   347)   use Realization_Subsurface_class
   348)   use Option_module
   349)   use Patch_module
   350)   use Grid_module
   351)  
   352)   implicit none
   353)   
   354)   type(realization_subsurface_type) :: realization
   355) 
   356)   type(option_type), pointer :: option
   357)   type(patch_type), pointer :: patch
   358)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
   359)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
   360) 
   361)   PetscInt :: iconn
   362) 
   363)   option => realization%option
   364)   patch => realization%patch
   365) 
   366)   global_auxvars_bc => patch%aux%Global%auxvars_bc
   367)   global_auxvars_ss => patch%aux%Global%auxvars_ss
   368) 
   369) #ifdef COMPUTE_INTERNAL_MASS_FLUX
   370)   do iconn = 1, patch%aux%Immis%num_aux
   371)     patch%aux%Global%auxvars(iconn)%mass_balance_delta = 0.d0
   372)   enddo
   373) #endif
   374) 
   375)   ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
   376)   ! placed around the internal do loop - geh
   377)   if (patch%aux%Immis%num_aux_bc > 0) then
   378)     do iconn = 1, patch%aux%Immis%num_aux_bc
   379)       global_auxvars_bc(iconn)%mass_balance_delta = 0.d0
   380)     enddo
   381)   endif
   382)   
   383)   if (patch%aux%Immis%num_aux_ss > 0) then
   384)     do iconn = 1, patch%aux%Immis%num_aux_ss
   385)       global_auxvars_ss(iconn)%mass_balance_delta = 0.d0
   386)     enddo
   387)   endif
   388) 
   389) end subroutine ImmisZeroMassBalDeltaPatch
   390) 
   391) ! ************************************************************************** !
   392) 
   393)   function  ImmisInitGuessCheck(realization)
   394)   ! 
   395)   ! Immisinitguesscheckpatch:
   396)   ! 
   397)   ! Author: Chuan Lu
   398)   ! Date: 12/10/07
   399)   ! 
   400)  
   401)   use Realization_Subsurface_class
   402)   use Patch_module
   403)   use Option_module
   404)   
   405)   PetscInt ::  ImmisInitGuessCheck
   406)   type(realization_subsurface_type) :: realization
   407)   type(option_type), pointer :: option
   408)   type(patch_type), pointer :: cur_patch
   409)   PetscInt :: ipass, ipass0
   410)   PetscErrorCode :: ierr    
   411) 
   412)   option => realization%option
   413)   ipass = 1
   414)   cur_patch => realization%patch_list%first
   415)   do
   416)     if (.not.associated(cur_patch)) exit
   417)     realization%patch => cur_patch
   418)     ipass= ImmisInitGuessCheckPatch(realization)
   419)     if (ipass<=0)then
   420)       exit 
   421)     endif
   422)     cur_patch => cur_patch%next
   423)   enddo
   424) 
   425)   call MPI_Barrier(option%mycomm,ierr)
   426)   if (option%mycommsize >1)then
   427)       call MPI_Allreduce(ipass,ipass0,ONE_INTEGER_MPI,MPIU_INTEGER, &
   428)                          MPI_SUM,option%mycomm,ierr)
   429)       if (ipass0 < option%mycommsize) ipass=-1
   430)    endif
   431)    ImmisInitGuessCheck =ipass
   432) 
   433) end function ImmisInitGuessCheck
   434) 
   435) ! ************************************************************************** !
   436) 
   437) subroutine ImmisUpdateReasonPatch(reason,realization)
   438)   ! 
   439)   ! Immisinitguesscheckpatch:
   440)   ! 
   441)   ! Author: Chuan Lu
   442)   ! Date: 10/10/08
   443)   ! 
   444)    use Realization_Subsurface_class
   445)    use Patch_module
   446)    use Field_module
   447)    use Option_module
   448)    use Grid_module
   449) 
   450)   implicit none
   451)  
   452)   PetscInt, intent(out) :: reason
   453)   type(realization_subsurface_type) :: realization  
   454)   type(patch_type),pointer :: patch
   455)   type(grid_type), pointer :: grid
   456)   type(field_type), pointer :: field
   457)   type(option_type), pointer :: option 
   458)   PetscReal, pointer :: xx_p(:), yy_p(:) 
   459)   PetscInt :: n,n0,re
   460)   PetscInt :: re0
   461)   PetscErrorCode :: ierr
   462)   
   463)   option => realization%option
   464)   field => realization%field  
   465)   patch => realization%patch
   466)   grid => patch%grid
   467) 
   468)   re=1
   469)  
   470)   if (re>0)then
   471)      call VecGetArrayReadF90(field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
   472)      call VecGetArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
   473) 
   474)      do n = 1,grid%nlmax
   475) !**** clu-Ignore inactive cells with inactive materials **************
   476)         if (associated(patch%imat)) then
   477)            if (patch%imat(grid%nL2G(n)) <= 0) cycle
   478)         endif
   479)         n0=(n-1)* option%nflowdof
   480)   
   481) ! ******** Too huge change in pressure ****************     
   482) !geh: I don't believe that this code is being used.  Therefore, I will add an
   483) !     error message and let someone sort the use of option%dpmxe later
   484)         option%io_buffer = 'option%dpmxe and option%dtmpmxe needs to be ' // &
   485)           'refactored in ImmisUpdateReasonPatch'
   486)         call printErrMsg(option)
   487) !geh        if (dabs(xx_p(n0 + 1)- yy_p(n0 + 1))> (10.0D0 * option%dpmxe))then
   488)            re=0; print *,'huge change in p', xx_p(n0 + 1), yy_p(n0 + 1)
   489)            exit
   490) !geh        endif
   491) 
   492) ! ******** Too huge change in temperature ****************
   493) !geh        if (dabs(xx_p(n0 + 2)- yy_p(n0 + 2))> (10.0D0 * option%dtmpmxe))then
   494)            re=0; print *,'huge change in T', xx_p(n0 + 2), yy_p(n0 + 2)
   495)            exit
   496) !geh        endif
   497)  
   498) ! ******* Check 0<=sat/con<=1 **************************
   499)            if (xx_p(n0 + 3) > 1.D0)then
   500)               re=0; exit
   501)            endif
   502)            if (xx_p(n0 + 3) < 0.)then
   503)               re=0; exit
   504)            endif
   505)      end do
   506)   
   507)     if (re<=0) print *,'Sat out of Region at: ',n,xx_p(n0+1:n0+3)
   508)     call VecRestoreArrayReadF90(field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
   509)     call VecRestoreArrayF90(field%flow_yy, yy_p, ierr);CHKERRQ(ierr)
   510) 
   511)    endif
   512)   
   513) end subroutine ImmisUpdateReasonPatch
   514) 
   515) ! ************************************************************************** !
   516) 
   517) subroutine ImmisUpdateReason(reason, realization)
   518)   ! 
   519)   ! ImmisUpdateAuxVars: Updates the auxiliary variables associated with
   520)   ! the Richards problem
   521)   ! 
   522)   ! Author: Chuan Lu
   523)   ! Date: 10/10/08
   524)   ! 
   525) 
   526)   use Realization_Subsurface_class
   527)   use Patch_module
   528)   implicit none
   529) 
   530)   type(realization_subsurface_type) :: realization
   531)   
   532)   type(patch_type), pointer :: cur_patch
   533)   PetscInt :: reason
   534) 
   535)   PetscInt :: re, re0
   536)   PetscErrorCode :: ierr
   537) 
   538)   re = 1
   539)   cur_patch => realization%patch_list%first
   540)   do
   541)     if (.not.associated(cur_patch)) exit
   542)     realization%patch => cur_patch
   543)     call ImmisUpdateReasonPatch(re, realization)
   544)     if (re<=0)then
   545)       exit 
   546)     endif
   547)     cur_patch => cur_patch%next
   548)   enddo
   549) 
   550)   call MPI_Barrier(realization%option%mycomm,ierr)
   551)   
   552)   if (realization%option%mycommsize >1)then
   553)      call MPI_Allreduce(re,re0,ONE_INTEGER_MPI,MPIU_INTEGER,MPI_SUM, &
   554)           realization%option%mycomm,ierr)
   555)      if (re0<realization%option%mycommsize) re=0
   556)   endif
   557)   reason=re
   558)   
   559)   if (reason<=0 .and. realization%option%myrank ==0) print *,'Sat or Con out of Region', re
   560) end subroutine ImmisUpdateReason
   561) 
   562) ! ************************************************************************** !
   563) 
   564)   function ImmisInitGuessCheckPatch(realization)
   565)   ! 
   566)   ! Author: Chuan Lu
   567)   ! Date: 10/10/08
   568)   ! 
   569)    
   570)     use co2_span_wagner_module
   571)      
   572)     use Realization_Subsurface_class
   573)     use Patch_module
   574)     use Field_module
   575)     use Grid_module
   576)     use Option_module
   577)     implicit none
   578)     
   579)     PetscInt :: ImmisInitGuessCheckPatch 
   580)     type(realization_subsurface_type) :: realization
   581)     type(grid_type), pointer :: grid
   582)     type(patch_type), pointer :: patch
   583)     type(option_type), pointer :: option
   584)     type(field_type), pointer :: field
   585)       
   586)     PetscInt :: local_id, ghosted_id, ipass
   587)     PetscReal, pointer :: xx_p(:)
   588)     PetscErrorCode :: ierr
   589) 
   590) 
   591)     patch => realization%patch
   592)     grid => patch%grid
   593)     option => realization%option
   594)     field => realization%field
   595)     
   596)     call VecGetArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
   597)     
   598)     ipass=1
   599)     do local_id = 1, grid%nlmax
   600)        ghosted_id = grid%nL2G(local_id)
   601)        !geh - Ignore inactive cells with inactive materials
   602)        if (associated(patch%imat)) then
   603)           if (patch%imat(ghosted_id) <= 0) cycle
   604)        endif
   605)       
   606) !   insure zero liquid sat not passed to ptran (no effect on pflow)
   607)        if (xx_p((local_id-1)*option%nflowdof+3) < 0.D0)xx_p((local_id-1)*option%nflowdof+3) = zerocut
   608)        if (xx_p((local_id-1)*option%nflowdof+3) > 1.D0)xx_p((local_id-1)*option%nflowdof+3) = 1.D0 - zerocut
   609)     
   610) !   check if p,T within range of table  
   611)        if (xx_p((local_id-1)*option%nflowdof+1)< p0_tab*1D6 &
   612)             .or. xx_p((local_id-1)*option%nflowdof+1)>(ntab_p*dp_tab + p0_tab)*1D6)then
   613)           ipass=-1; exit  
   614)        endif
   615)        if (xx_p((local_id-1)*option%nflowdof+2)< t0_tab -273.15D0 &
   616)             .or. xx_p((local_id-1)*option%nflowdof+2)>ntab_t*dt_tab + t0_tab-273.15D0)then
   617)           ipass=-1; exit
   618)        endif
   619)     enddo
   620) 
   621)     call VecRestoreArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
   622)     ImmisInitGuessCheckPatch = ipass
   623)   end function ImmisInitGuessCheckPatch
   624) 
   625) ! ************************************************************************** !
   626) 
   627) subroutine ImmisUpdateAuxVars(realization)
   628)   ! 
   629)   ! Updates the auxiliary variables associated with
   630)   ! the Immis problem
   631)   ! 
   632)   ! Author: Chuan Lu
   633)   ! Date: 10/10/08
   634)   ! 
   635) 
   636)   use Realization_Subsurface_class
   637)   use Patch_module
   638) 
   639)   type(realization_subsurface_type) :: realization
   640)   
   641)   type(patch_type), pointer :: cur_patch
   642)   
   643)   cur_patch => realization%patch_list%first
   644)   do
   645)     if (.not.associated(cur_patch)) exit
   646)     realization%patch => cur_patch
   647)     call ImmisUpdateAuxVarsPatch(realization)
   648)     cur_patch => cur_patch%next
   649)   enddo
   650) 
   651) end subroutine ImmisUpdateAuxVars
   652) 
   653) ! ************************************************************************** !
   654) 
   655) subroutine ImmisUpdateAuxVarsPatch(realization)
   656)   ! 
   657)   ! Updates the auxiliary variables associated with
   658)   ! the Immis problem
   659)   ! 
   660)   ! Author: Chuan Lu
   661)   ! Date: 12/10/07
   662)   ! 
   663) 
   664)   use Realization_Subsurface_class
   665)   use Patch_module
   666)   use Field_module
   667)   use Option_module
   668)   use Grid_module
   669)   use Coupler_module
   670)   use Connection_module
   671)   use Material_module
   672)   
   673)   implicit none
   674) 
   675)   type(realization_subsurface_type) :: realization
   676)   
   677)   type(option_type), pointer :: option
   678)   type(patch_type), pointer :: patch
   679)   type(grid_type), pointer :: grid
   680)   type(field_type), pointer :: field
   681)   type(coupler_type), pointer :: boundary_condition
   682)   type(coupler_type), pointer :: source_sink
   683)   type(connection_set_type), pointer :: cur_connection_set
   684)   type(Immis_auxvar_type), pointer :: auxvars(:)
   685)   type(Immis_auxvar_type), pointer :: auxvars_bc(:)
   686)   type(Immis_auxvar_type), pointer :: auxvars_ss(:)
   687)   type(global_auxvar_type), pointer :: global_auxvars(:)
   688)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
   689)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
   690) 
   691)   PetscInt :: ghosted_id, local_id, istart, iend, sum_connection, idof, iconn
   692)   PetscReal, pointer :: xx_loc_p(:), icap_loc_p(:)
   693)   PetscReal :: xxbc(realization%option%nflowdof)
   694)   PetscErrorCode :: ierr
   695)   
   696)   option => realization%option
   697)   patch => realization%patch
   698)   grid => patch%grid
   699)   field => realization%field
   700)   
   701)   auxvars => patch%aux%Immis%auxvars
   702)   auxvars_bc => patch%aux%Immis%auxvars_bc
   703)   auxvars_ss => patch%aux%Immis%auxvars_ss
   704) 
   705)   global_auxvars => patch%aux%Global%auxvars
   706)   global_auxvars_bc => patch%aux%Global%auxvars_bc
   707)   global_auxvars_ss => patch%aux%Global%auxvars_ss
   708) 
   709)   
   710)   call VecGetArrayF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
   711)   call VecGetArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
   712) 
   713)   do ghosted_id = 1, grid%ngmax
   714)     if (grid%nG2L(ghosted_id) < 0) cycle ! bypass ghosted corner cells
   715)     !geh - Ignore inactive cells with inactive materials
   716)     if (associated(patch%imat)) then
   717)       if (patch%imat(ghosted_id) <= 0) cycle
   718)     endif
   719)     iend = ghosted_id*option%nflowdof
   720)     istart = iend-option%nflowdof+1
   721)     if (.not. associated(patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr))then
   722)        print*, 'error!!! saturation function not allocated', ghosted_id,icap_loc_p(ghosted_id)
   723)     endif
   724)    
   725)     call ImmisAuxVarCompute_NINC(xx_loc_p(istart:iend), &
   726)                        auxvars(ghosted_id)%auxvar_elem(0), &
   727)                        patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
   728)                        realization%fluid_properties,option)
   729) 
   730)  ! update global variables
   731)     if (associated(global_auxvars))then
   732)       global_auxvars(ghosted_id)%pres(:) = auxvars(ghosted_id)%auxvar_elem(0)%pres -&
   733)                auxvars(ghosted_id)%auxvar_elem(0)%pc(:)
   734)       global_auxvars(ghosted_id)%temp = auxvars(ghosted_id)%auxvar_elem(0)%temp
   735)       global_auxvars(ghosted_id)%sat(:) = auxvars(ghosted_id)%auxvar_elem(0)%sat(:)
   736)       global_auxvars(ghosted_id)%den(:) = auxvars(ghosted_id)%auxvar_elem(0)%den(:)
   737)       global_auxvars(ghosted_id)%den_kg(:) = auxvars(ghosted_id)%auxvar_elem(0)%den(:) &
   738)                                           * auxvars(ghosted_id)%auxvar_elem(0)%avgmw(:)
   739)       
   740) !     print *,'immis: update_global:den ',global_auxvars(ghosted_id)%den_kg(:), &
   741) !                               auxvars(ghosted_id)%auxvar_elem(0)%avgmw(:)
   742)     else
   743)       print *,'Not associated global for IMS'
   744)     endif
   745)   enddo
   746) 
   747)   boundary_condition => patch%boundary_condition_list%first
   748)   sum_connection = 0    
   749)   do 
   750)     if (.not.associated(boundary_condition)) exit
   751)     cur_connection_set => boundary_condition%connection_set
   752)     do iconn = 1, cur_connection_set%num_connections
   753)       sum_connection = sum_connection + 1
   754)       local_id = cur_connection_set%id_dn(iconn)
   755)       ghosted_id = grid%nL2G(local_id)
   756)       if (associated(patch%imat)) then
   757)         if (patch%imat(ghosted_id) <= 0) cycle
   758)       endif
   759)       do idof = 1, option%nflowdof
   760)         select case(boundary_condition%flow_condition%itype(idof))
   761)         case(DIRICHLET_BC)
   762) !         xxbc(:) = boundary_condition%flow_aux_real_var(:,iconn)
   763)           xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
   764)         case(HYDROSTATIC_BC)
   765) !         xxbc(1) = boundary_condition%flow_aux_real_var(1,iconn)
   766) !         xxbc(2:option%nflowdof) = &
   767) !           xx_loc_p((ghosted_id-1)*option%nflowdof+2:ghosted_id*option%nflowdof)
   768)           xxbc(MPH_PRESSURE_DOF) = boundary_condition%flow_aux_real_var(MPH_PRESSURE_DOF,iconn)
   769)           if (idof >= MPH_PRESSURE_DOF) then
   770)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
   771)           endif
   772)         case(NEUMANN_BC,ZERO_GRADIENT_BC)
   773) !         xxbc(:) = xx_loc_p((ghosted_id-1)*option%nflowdof+1:ghosted_id*option%nflowdof)
   774)           xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
   775)         end select
   776)       enddo
   777)  
   778)       call ImmisAuxVarCompute_NINC(xxbc,auxvars_bc(sum_connection)%auxvar_elem(0), &
   779)               patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr, &
   780)                          realization%fluid_properties, option)
   781) 
   782)       if (associated(global_auxvars_bc)) then
   783)         global_auxvars_bc(sum_connection)%pres(:)= auxvars_bc(sum_connection)%auxvar_elem(0)%pres -&
   784)                      auxvars(ghosted_id)%auxvar_elem(0)%pc(:)
   785)         global_auxvars_bc(sum_connection)%temp=auxvars_bc(sum_connection)%auxvar_elem(0)%temp
   786)         global_auxvars_bc(sum_connection)%sat(:)=auxvars_bc(sum_connection)%auxvar_elem(0)%sat(:)
   787)         !    global_auxvars(ghosted_id)%sat_store = 
   788)         global_auxvars_bc(sum_connection)%den(:)=auxvars_bc(sum_connection)%auxvar_elem(0)%den(:)
   789)         global_auxvars_bc(sum_connection)%den_kg = auxvars_bc(sum_connection)%auxvar_elem(0)%den(:) &
   790)               * auxvars_bc(sum_connection)%auxvar_elem(0)%avgmw(:)
   791)   !     global_auxvars(ghosted_id)%den_kg_store
   792)   !     global_auxvars(ghosted_id)%mass_balance
   793)   !     global_auxvars(ghosted_id)%mass_balance_delta
   794)       endif
   795) 
   796)     enddo
   797)     boundary_condition => boundary_condition%next
   798)   enddo
   799) 
   800) 
   801) ! source/sinks
   802)   source_sink => patch%source_sink_list%first
   803)   sum_connection = 0    
   804)   do 
   805)     if (.not.associated(source_sink)) exit
   806)     cur_connection_set => source_sink%connection_set
   807)     do iconn = 1, cur_connection_set%num_connections
   808)       sum_connection = sum_connection + 1
   809)       local_id = cur_connection_set%id_dn(iconn)
   810)       ghosted_id = grid%nL2G(local_id)
   811)       if (patch%imat(ghosted_id) <= 0) cycle
   812) 
   813)       call ImmisAuxVarCopy(auxvars(ghosted_id)%auxvar_elem(0), &
   814)                           auxvars_ss(sum_connection)%auxvar_elem(0),option)
   815)       call GlobalAuxVarCopy(global_auxvars(ghosted_id), &
   816)                           global_auxvars_ss(sum_connection),option)
   817) 
   818)     enddo
   819)     source_sink => source_sink%next
   820)   enddo
   821) 
   822) 
   823)   call VecRestoreArrayF90(field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
   824)   call VecRestoreArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
   825)   
   826)   patch%aux%Immis%auxvars_up_to_date = PETSC_TRUE
   827) 
   828) end subroutine ImmisUpdateAuxVarsPatch
   829) 
   830) ! ************************************************************************** !
   831) 
   832) subroutine ImmisInitializeTimestep(realization)
   833)   ! 
   834)   ! Update data in module prior to time step
   835)   ! 
   836)   ! Author: Chuan Lu
   837)   ! Date: 10/12/08
   838)   ! 
   839) 
   840)   use Realization_Subsurface_class
   841)   
   842)   implicit none
   843)   
   844)   type(realization_subsurface_type) :: realization
   845) 
   846)   call ImmisUpdateFixedAccumulation(realization)
   847) 
   848) end subroutine ImmisInitializeTimestep
   849) 
   850) ! ************************************************************************** !
   851) 
   852) subroutine ImmisUpdateSolution(realization)
   853)   ! 
   854)   ! Updates data in module after a successful time step
   855)   ! 
   856)   ! Author: Chuan Lu
   857)   ! Date: 10/13/08
   858)   ! 
   859) 
   860)   use Realization_Subsurface_class
   861)   use Field_module
   862)   use Patch_module
   863)   
   864)   implicit none
   865)   
   866)   type(realization_subsurface_type) :: realization
   867) 
   868)   type(field_type), pointer :: field
   869)   type(patch_type), pointer :: cur_patch
   870)   PetscErrorCode :: ierr
   871)   PetscViewer :: viewer
   872)   
   873)   field => realization%field
   874)   
   875)   cur_patch => realization%patch_list%first
   876)   do
   877)     if (.not.associated(cur_patch)) exit
   878)     realization%patch => cur_patch
   879) !     call ImmisUpdateSolutionPatch(realization)
   880)     cur_patch => cur_patch%next
   881)   enddo
   882) 
   883) ! make room for hysteric s-Pc-kr
   884) 
   885) end subroutine ImmisUpdateSolution
   886) 
   887) ! ************************************************************************** !
   888) 
   889) subroutine ImmisUpdateSolutionPatch(realization)
   890)   ! 
   891)   ! Updates mass balance
   892)   ! 
   893)   ! Author: PCL
   894)   ! Date: 11/18/11
   895)   ! 
   896) 
   897)   use Realization_Subsurface_class
   898)     
   899)   implicit none
   900)   
   901)   type(realization_subsurface_type) :: realization
   902) 
   903)   if (realization%option%compute_mass_balance_new) then
   904)     call ImmisUpdateMassBalancePatch(realization)
   905)   endif
   906) 
   907) end subroutine ImmisUpdateSolutionPatch
   908) 
   909) ! ************************************************************************** !
   910) 
   911) subroutine ImmisUpdateMassBalancePatch(realization)
   912)   ! 
   913)   ! Updates mass balance
   914)   ! 
   915)   ! Author: Glenn Hammond
   916)   ! Date: 12/19/08
   917)   ! 
   918)  
   919)   use Realization_Subsurface_class
   920)   use Option_module
   921)   use Patch_module
   922)   use Grid_module
   923)  
   924)   implicit none
   925)   
   926)   type(realization_subsurface_type) :: realization
   927) 
   928)   type(option_type), pointer :: option
   929)   type(patch_type), pointer :: patch
   930)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
   931)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
   932) 
   933)   PetscInt :: iconn
   934) 
   935)   option => realization%option
   936)   patch => realization%patch
   937) 
   938)   global_auxvars_bc => patch%aux%Global%auxvars_bc
   939)   global_auxvars_ss => patch%aux%Global%auxvars_ss
   940) 
   941)   ! Intel 10.1 on Chinook reports a SEGV if this conditional is not
   942)   ! placed around the internal do loop - geh
   943)   if (patch%aux%immis%num_aux_bc > 0) then
   944)     do iconn = 1, patch%aux%immis%num_aux_bc
   945)       global_auxvars_bc(iconn)%mass_balance = &
   946)         global_auxvars_bc(iconn)%mass_balance + &
   947)         global_auxvars_bc(iconn)%mass_balance_delta*option%flow_dt
   948)     enddo
   949)   endif
   950)   
   951)   if (patch%aux%immis%num_aux_ss > 0) then
   952)     do iconn = 1, patch%aux%immis%num_aux_ss
   953)       global_auxvars_ss(iconn)%mass_balance = &
   954)         global_auxvars_ss(iconn)%mass_balance + &
   955)         global_auxvars_ss(iconn)%mass_balance_delta*option%flow_dt
   956)     enddo
   957)   endif
   958) 
   959) end subroutine ImmisUpdateMassBalancePatch
   960) 
   961) ! ************************************************************************** !
   962) 
   963) subroutine ImmisUpdateFixedAccumulation(realization)
   964)   ! 
   965)   ! Updates the fixed portion of the
   966)   ! accumulation term
   967)   ! 
   968)   ! Author: Chuan Lu
   969)   ! Date: 10/12/08
   970)   ! 
   971) 
   972)   use Realization_Subsurface_class
   973)   use Patch_module
   974) 
   975)   type(realization_subsurface_type) :: realization
   976)   
   977)   type(patch_type), pointer :: cur_patch
   978)   
   979)   cur_patch => realization%patch_list%first
   980)   do
   981)     if (.not.associated(cur_patch)) exit
   982)     realization%patch => cur_patch
   983)     call ImmisUpdateFixedAccumPatch(realization)
   984)     cur_patch => cur_patch%next
   985)   enddo
   986) 
   987) end subroutine ImmisUpdateFixedAccumulation
   988) 
   989) ! ************************************************************************** !
   990) 
   991) subroutine ImmisUpdateFixedAccumPatch(realization)
   992)   ! 
   993)   ! Updates the fixed portion of the
   994)   ! accumulation term
   995)   ! 
   996)   ! Author: Chuan Lu
   997)   ! Date: 10/12/08
   998)   ! 
   999) 
  1000)   use Realization_Subsurface_class
  1001)   use Patch_module
  1002)   use Option_module
  1003)   use Field_module
  1004)   use Grid_module
  1005) 
  1006)   implicit none
  1007)   
  1008)   type(realization_subsurface_type) :: realization
  1009)   
  1010)   type(option_type), pointer :: option
  1011)   type(patch_type), pointer :: patch
  1012)   type(grid_type), pointer :: grid
  1013)   type(field_type), pointer :: field
  1014)   type(Immis_parameter_type), pointer :: immis_parameter
  1015)   type(Immis_auxvar_type), pointer :: auxvars(:)
  1016) 
  1017)   PetscInt :: ghosted_id, local_id, istart, iend
  1018)   PetscReal, pointer :: xx_p(:), icap_loc_p(:)
  1019)   PetscReal, pointer :: porosity_loc_p(:), tortuosity_loc_p(:), volume_p(:), &
  1020)                         ithrm_loc_p(:), accum_p(:)
  1021)                           
  1022)   PetscErrorCode :: ierr
  1023)   
  1024)   call ImmisUpdateAuxVarsPatch(realization) 
  1025)   option => realization%option
  1026)   field => realization%field
  1027)   patch => realization%patch
  1028)   grid => patch%grid
  1029) 
  1030) 
  1031)   immis_parameter => patch%aux%Immis%immis_parameter
  1032)   auxvars => patch%aux%Immis%auxvars
  1033)     
  1034)   call VecGetArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
  1035)   call VecGetArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
  1036) !geh: refactor  call VecGetArrayF90(field%porosity_loc,porosity_loc_p,ierr)
  1037) !geh: refactor  call VecGetArrayF90(field%tortuosity_loc,tortuosity_loc_p,ierr)
  1038) !geh: refactor  call VecGetArrayF90(field%volume,volume_p,ierr)
  1039)   call VecGetArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
  1040) 
  1041)   call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  1042) 
  1043)   do local_id = 1, grid%nlmax
  1044)     ghosted_id = grid%nL2G(local_id)
  1045)     !geh - Ignore inactive cells with inactive materials
  1046)     if (associated(patch%imat)) then
  1047)       if (patch%imat(ghosted_id) <= 0) cycle
  1048)     endif
  1049)     iend = local_id*option%nflowdof
  1050)     istart = iend-option%nflowdof+1
  1051) 
  1052)     call ImmisAccumulation(auxvars(ghosted_id)%auxvar_elem(0), &
  1053)                               porosity_loc_p(ghosted_id), &
  1054)                               volume_p(local_id), &
  1055)                               immis_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  1056)                               option,ZERO_INTEGER, accum_p(istart:iend)) 
  1057)   enddo
  1058) 
  1059)   call VecRestoreArrayReadF90(field%flow_xx,xx_p, ierr);CHKERRQ(ierr)
  1060)   call VecRestoreArrayF90(field%icap_loc,icap_loc_p,ierr);CHKERRQ(ierr)
  1061) !geh refactor  call VecRestoreArrayF90(field%porosity_loc,porosity_loc_p,ierr)
  1062) !geh refactor  call VecRestoreArrayF90(field%tortuosity_loc,tortuosity_loc_p,ierr)
  1063) !geh refactor  call VecRestoreArrayF90(field%volume,volume_p,ierr)
  1064)   call VecRestoreArrayF90(field%ithrm_loc,ithrm_loc_p,ierr);CHKERRQ(ierr)
  1065) 
  1066)   call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  1067) 
  1068) #if 0
  1069) !  call ImmisNumericalJacobianTest(field%flow_xx,realization)
  1070) #endif
  1071) 
  1072) end subroutine ImmisUpdateFixedAccumPatch
  1073) 
  1074) ! ************************************************************************** !
  1075) 
  1076) subroutine ImmisAccumulation(auxvar,por,vol,rock_dencpr,option,iireac,Res)
  1077)   ! 
  1078)   ! Computes the non-fixed portion of the accumulation
  1079)   ! term for the residual
  1080)   ! 
  1081)   ! Author: Chuan Lu
  1082)   ! Date: 10/12/08
  1083)   ! 
  1084) 
  1085)   use Option_module
  1086)   
  1087)   implicit none
  1088) 
  1089)   type(Immis_auxvar_elem_type) :: auxvar
  1090)   type(option_type) :: option
  1091)   PetscReal Res(1:option%nflowdof) 
  1092)   PetscReal vol,por,rock_dencpr
  1093)      
  1094)   PetscInt :: ispec, np, iireac
  1095)   PetscReal :: porXvol, mol(option%nflowspec), eng
  1096)   
  1097) ! if (present(ireac)) iireac=ireac
  1098) 
  1099)   porXvol = por*vol
  1100)   mol=0.d0; eng=0.D0
  1101)   do np = 1, option%nphase
  1102)     mol(np) = mol(np) + auxvar%sat(np) * auxvar%den(np)
  1103)     eng = eng + auxvar%sat(np) * auxvar%den(np) * auxvar%u(np)
  1104)   enddo
  1105)   mol = mol * porXvol
  1106)  ! if (option%use_isothermal == PETSC_FALSE) &
  1107)   eng = eng * porXvol + (1.d0 - por) * vol * rock_dencpr * auxvar%temp 
  1108)  
  1109) ! Reaction terms here
  1110) ! Note if iireac >0, then it is the node global index
  1111) ! if (option%run_coupled == PETSC_TRUE .and. iireac>0) then
  1112) !H2O
  1113) !   mol(1)= mol(1) - option%flow_dt * option%rtot(iireac,1)
  1114) !   mol(2)= mol(2) - option%flow_dt * option%rtot(iireac,2)
  1115) ! endif
  1116)   
  1117) ! if (option%use_isothermal) then
  1118) !   Res(1:option%nflowdof) = mol(:)
  1119) ! else
  1120)     Res(1:option%nphase) = mol(:)
  1121)     Res(option%nflowdof) = eng
  1122) ! endif
  1123) end subroutine ImmisAccumulation
  1124) 
  1125) ! ************************************************************************** !
  1126) 
  1127) subroutine ImmisSourceSink(mmsrc,nsrcpara,psrc,tsrc,hsrc,auxvar,isrctype,Res, &
  1128)                            qsrc_phase,energy_flag,option)
  1129)   ! 
  1130)   ! Computes source/sink
  1131)   ! 
  1132)   ! Author: Chuan Lu
  1133)   ! Date: 10/12/08
  1134)   ! 
  1135) 
  1136)   use Option_module
  1137)   
  1138)   use EOS_Water_module
  1139) ! use Gas_EOS_module  
  1140)   use co2eos_module
  1141)   use co2_span_wagner_spline_module, only: sw_prop
  1142)   use co2_sw_module, only: co2_sw_interp
  1143)   use co2_span_wagner_module 
  1144)   
  1145)   implicit none
  1146) 
  1147)   type(Immis_auxvar_elem_type) :: auxvar
  1148)   type(option_type) :: option
  1149)   PetscReal :: Res(1:option%nflowdof) 
  1150)   PetscReal, pointer :: mmsrc(:)
  1151) ! PetscReal :: mmsrc(option%nflowspec), psrc(option%nphase),tsrc,hsrc 
  1152)   PetscReal :: psrc(option%nphase),tsrc,hsrc 
  1153)   PetscInt :: isrctype
  1154)   PetscInt :: nsrcpara
  1155)   PetscBool :: energy_flag
  1156)   PetscReal :: qsrc_phase(:) ! volumetric rate of injection/extraction for each phase
  1157)      
  1158)   PetscReal, allocatable :: msrc(:)
  1159) ! PetscReal :: msrc(option%nflowspec),dw_kg, dw_mol,dddt,dddp
  1160)   PetscReal :: dw_kg, dw_mol,dddt,dddp
  1161)   PetscReal :: enth_src_h2o, enth_src_co2 
  1162)   PetscReal :: rho, fg, dfgdp, dfgdt, eng, dhdt, dhdp, visc, dvdt, dvdp, xphi
  1163)   PetscReal :: ukvr, v_darcy, dq, dphi
  1164)   PetscReal :: well_status, well_diameter
  1165)   PetscReal :: pressure_bh, well_factor, pressure_max, pressure_min
  1166)   PetscReal :: well_inj_water, well_inj_co2
  1167)   PetscInt :: np
  1168)   PetscInt :: iflag
  1169)   PetscErrorCode :: ierr
  1170)   
  1171)   Res = 0.D0
  1172)   allocate(msrc(nsrcpara))
  1173)   msrc = mmsrc(1:nsrcpara)
  1174) 
  1175) ! if (present(ireac)) iireac=ireac
  1176) ! if (energy_flag) then
  1177) !   Res(option%nflowdof) = Res(option%nflowdof) + hsrc * option%flow_dt   
  1178) ! endif         
  1179) 
  1180)   qsrc_phase = 0.d0
  1181)  
  1182)   select case(isrctype)
  1183)     case(MASS_RATE_SS)
  1184)       msrc(1) =  msrc(1) / FMWH2O
  1185)       msrc(2) =  msrc(2) / FMWCO2
  1186)       if (msrc(1) /= 0.d0) then ! H2O injection
  1187)         call EOSWaterDensity(tsrc,auxvar%pres,dw_kg,dw_mol,ierr)
  1188)         call EOSWaterEnthalpy(tsrc,auxvar%pres,enth_src_h2o,ierr)
  1189)         ! J/kmol -> whatever units
  1190)         enth_src_h2o = enth_src_h2o * option%scale
  1191) !           units: dw_mol [mol/dm^3]; dw_kg [kg/m^3]
  1192) !           qqsrc = qsrc1/dw_mol ! [kmol/s (mol/dm^3 = kmol/m^3)]
  1193) !       Res(jh2o) = Res(jh2o) + msrc(1)*(1.d0-csrc)*option%flow_dt
  1194) !       Res(jco2) = Res(jco2) + msrc(1)*csrc*option%flow_dt
  1195)         Res(jh2o) = Res(jh2o) + msrc(1)*option%flow_dt
  1196)         Res(jco2) = Res(jco2) + msrc(1)*option%flow_dt
  1197)         if (energy_flag) Res(option%nflowdof) = Res(option%nflowdof) + &
  1198)           msrc(1)*enth_src_h2o*option%flow_dt
  1199)           
  1200)         ! store volumetric rate for ss_fluid_fluxes()
  1201)         qsrc_phase(1) = msrc(1)/dw_mol
  1202)       endif  
  1203)     
  1204)       if (msrc(2) > 0.d0) then ! CO2 injection
  1205) !       call printErrMsg(option,"concentration source not yet implemented in Immis")
  1206)         if (option%co2eos == EOS_SPAN_WAGNER) then
  1207)          !  span-wagner
  1208)           rho = auxvar%den(jco2)*FMWCO2  
  1209)           select case(option%itable)  
  1210)             case(0,1,2,4,5)
  1211)               if (option%itable >=4) then
  1212)               call co2_sw_interp(auxvar%pres*1.D-6,&
  1213)                 tsrc,rho,dddt,dddp,fg,dfgdp,dfgdt, &
  1214)                 eng,enth_src_co2,dhdt,dhdp,visc,dvdt,dvdp,option%itable)
  1215)               else
  1216)                 iflag = 1
  1217)                 call co2_span_wagner(auxvar%pres*1.D-6,&
  1218)                   tsrc+273.15D0,rho,dddt,dddp,fg,dfgdp,dfgdt, &
  1219)                   eng,enth_src_co2,dhdt,dhdp,visc,dvdt,dvdp,iflag,option%itable)
  1220)               endif 
  1221)             case(3) 
  1222)               call sw_prop(tsrc,auxvar%pres*1.D-6,rho, &
  1223)                      enth_src_co2, eng, fg)
  1224)           end select     
  1225) 
  1226)          !  units: rho [kg/m^3]; csrc1 [kmol/s]
  1227)           enth_src_co2 = enth_src_co2 * FMWCO2
  1228)           
  1229)           ! store volumetric rate for ss_fluid_fluxes()
  1230)           ! qsrc_phase [m^3/sec] = msrc [kmol/sec] / [kg/m^3] * [kg/kmol]  
  1231)           qsrc_phase(2) = msrc(2)/auxvar%den(jco2)
  1232)           
  1233)         else if (option%co2eos == EOS_MRK)then
  1234) ! MRK eos [modified version from  Kerrick and Jacobs (1981) and Weir et al. (1996).]
  1235)           call CO2(tsrc,auxvar%pres, rho,fg, xphi,enth_src_co2)
  1236)           qsrc_phase(2) = msrc(2)/auxvar%den(jco2)
  1237)           enth_src_co2 = enth_src_co2*FMWCO2*option%scale
  1238)       else
  1239)          call printErrMsg(option,'pflow Immis ERROR: Need specify CO2 EOS')
  1240)       endif
  1241)               
  1242)       Res(jco2) = Res(jco2) + msrc(2)*option%flow_dt
  1243)       if (energy_flag) Res(option%nflowdof) = Res(option%nflowdof) + msrc(2) * &
  1244)            enth_src_co2 *option%flow_dt
  1245)        endif
  1246) 
  1247) 
  1248)     case(WELL_SS) ! production well
  1249)      !if node pessure is lower than the given extraction pressure, shut it down
  1250)     ! Flow term
  1251) !  well parameter explaination
  1252) !   1. well status. 1 injection; -1 production; 0 shut in
  1253) !                   2 rate controled injection (same as rate_ss, with max pressure control, not completed yet) 
  1254) !                  -2 rate controled production(not implemented for now) 
  1255) !
  1256) !   2. well factor [m^3],  the effective permeability [m^2/s]
  1257) !   3. bottomhole pressure:  [Pa]
  1258) !   4. max pressure: [Pa]
  1259) !   5. min pressure: [Pa]   
  1260) !   6. preferred mass flux of water [kg/s]
  1261) !   7. preferred mass flux of Co2 [kg/s]
  1262) !   8. well diameter, not used now
  1263) !   9. skin factor, not used now
  1264) 
  1265)       well_status = msrc(1)
  1266)       well_factor = msrc(2)
  1267)       pressure_bh = msrc(3)
  1268)       pressure_max = msrc(4)
  1269)       pressure_min = msrc(5)
  1270)       well_inj_water = msrc(6)
  1271)       well_inj_co2 = msrc(7)
  1272)     
  1273) !     if (pressure_min < 0D0) pressure_min = 0D0 !not limited by pressure lower bound   
  1274) 
  1275)     ! production well (well status = -1)
  1276)       if ( dabs(well_status + 1D0) < 1D-1) then 
  1277)         if (auxvar%pres > pressure_min) then
  1278)           Dq = well_factor 
  1279)           do np = 1, option%nphase
  1280)             dphi = auxvar%pres - auxvar%pc(np) - pressure_bh
  1281)             if (dphi>=0.D0) then ! outflow only
  1282)               ukvr = auxvar%kvr(np)
  1283)               if (ukvr<1e-20) ukvr=0D0
  1284)               v_darcy=0D0
  1285)               if (ukvr*Dq>floweps) then
  1286)                 v_darcy = Dq * ukvr * dphi
  1287)                 ! store volumetric rate for ss_fluid_fluxes()
  1288)                 qsrc_phase(1) = -1.d0*v_darcy
  1289)                 Res(1) = Res(1) - v_darcy* auxvar%den(np)* &
  1290) !                 auxvar%xmol((np-1)*option%nflowspec+1)*
  1291)                   option%flow_dt
  1292)                 Res(2) = Res(2) - v_darcy* auxvar%den(np)* &
  1293) !                 auxvar%xmol((np-1)*option%nflowspec+2)*
  1294)                   option%flow_dt
  1295)                 if (energy_flag) Res(3) = Res(3) - v_darcy * auxvar%den(np)* &
  1296)                   auxvar%h(np)*option%flow_dt
  1297)               ! print *,'produce: ',np,v_darcy
  1298)               endif
  1299)             endif
  1300)           enddo
  1301)         endif
  1302)       endif 
  1303)      !print *,'well-prod: ',  auxvar%pres,psrc(1), res
  1304)     ! injection well (well status = 2)
  1305)       if ( dabs(well_status - 2.D0) < 1.D-1) then 
  1306) 
  1307)         call EOSWaterDensity(tsrc,auxvar%pres,dw_kg,dw_mol,ierr)
  1308)         call EOSWaterEnthalpy(tsrc,auxvar%pres,enth_src_h2o,ierr)
  1309)         ! J/kmol -> whatever units
  1310)         enth_src_h2o = enth_src_h2o * option%scale
  1311) 
  1312)         Dq = msrc(2) ! well parameter, read in input file
  1313)                       ! Take the place of 2nd parameter 
  1314)         ! Flow term
  1315)         if ( auxvar%pres < pressure_max)then  
  1316)           do np = 1, option%nphase
  1317)             dphi = pressure_bh - auxvar%pres + auxvar%pc(np)
  1318)             if (dphi>=0.D0) then ! outflow only
  1319)               ukvr = auxvar%kvr(np)
  1320)               v_darcy=0.D0
  1321)               if (ukvr*Dq>floweps) then
  1322)                 v_darcy = Dq * ukvr * dphi
  1323)                 ! store volumetric rate for ss_fluid_fluxes()
  1324)                 qsrc_phase(1) = v_darcy
  1325)                 Res(1) = Res(1) + v_darcy* auxvar%den(np)* &
  1326) !                 auxvar%xmol((np-1)*option%nflowspec+1) * option%flow_dt
  1327) !                 (1.d0-csrc) * option%flow_dt
  1328)                   option%flow_dt
  1329)                 Res(2) = Res(2) + v_darcy* auxvar%den(np)* &
  1330) !                 auxvar%xmol((np-1)*option%nflowspec+2) * option%flow_dt
  1331) !                 csrc * option%flow_dt
  1332)                   option%flow_dt
  1333) !               if (energy_flag) Res(3) = Res(3) + v_darcy*auxvar%den(np)* &
  1334) !                 auxvar%h(np)*option%flow_dt
  1335)                 if (energy_flag) Res(3) = Res(3) + v_darcy*auxvar%den(np)* &
  1336)                   enth_src_h2o*option%flow_dt
  1337)                 
  1338) !               print *,'inject: ',np,v_darcy
  1339)               endif
  1340)             endif
  1341)           enddo
  1342)         endif
  1343)       endif    
  1344)     case default
  1345)       print *,'Unrecognized Source/Sink condition: ', isrctype 
  1346)   end select      
  1347)   deallocate(msrc)
  1348)       
  1349) end subroutine ImmisSourceSink
  1350) 
  1351) ! ************************************************************************** !
  1352) 
  1353) subroutine ImmisFlux(auxvar_up,por_up,tor_up,sir_up,dd_up,perm_up,Dk_up, &
  1354)                         auxvar_dn,por_dn,tor_dn,sir_dn,dd_dn,perm_dn,Dk_dn, &
  1355)                         area,dist_gravity,upweight, &
  1356)                         option,vv_darcy,Res)
  1357)   ! 
  1358)   ! Computes the internal flux terms for the residual
  1359)   ! 
  1360)   ! Author: Chuan Lu
  1361)   ! Date: 10/12/08
  1362)   ! 
  1363)   use Option_module                              
  1364)   
  1365)   implicit none
  1366)   
  1367)   type(Immis_auxvar_elem_type) :: auxvar_up, auxvar_dn
  1368)   type(option_type) :: option
  1369)   PetscReal :: sir_up(:), sir_dn(:)
  1370)   PetscReal :: por_up, por_dn
  1371)   PetscReal :: tor_up, tor_dn
  1372)   PetscReal :: dd_up, dd_dn
  1373)   PetscReal :: perm_up, perm_dn
  1374)   PetscReal :: Dk_up, Dk_dn
  1375)   PetscReal :: vv_darcy(:),area
  1376)   PetscReal :: Res(1:option%nflowdof) 
  1377)   PetscReal :: dist_gravity  ! distance along gravity vector
  1378)      
  1379)   PetscInt :: ispec, np, ind
  1380)   PetscReal :: fluxm(option%nflowspec),fluxe,q, v_darcy
  1381)   PetscReal :: uh,uxmol(1:option%nflowspec),ukvr,difff,diffdp, DK,Dq
  1382)   PetscReal :: upweight,density_ave,cond,gravity,dphi
  1383)      
  1384)   Dq = (perm_up * perm_dn)/(dd_up*perm_dn + dd_dn*perm_up)
  1385) !  diffdp = (por_up *tor_up * por_dn*tor_dn) / (dd_dn*por_up*tor_up + dd_up*por_dn*tor_dn)*area
  1386)   
  1387)   fluxm = 0.D0
  1388)   fluxe = 0.D0
  1389)   vv_darcy =0.D0 
  1390)   
  1391) ! Flow term
  1392)   do np = 1, option%nphase
  1393) !   if (auxvar_up%sat(np) > sir_up(np) .or. auxvar_dn%sat(np) > sir_dn(np)) then
  1394)     if ((auxvar_up%kvr(np) + auxvar_dn%kvr(np)) > eps) then
  1395)       upweight= dd_dn/(dd_up+dd_dn)
  1396)       if (auxvar_up%sat(np) <eps) then
  1397)         upweight=0.d0
  1398)       else if (auxvar_dn%sat(np) <eps) then
  1399)         upweight=1.d0
  1400)       endif
  1401)       density_ave = upweight*auxvar_up%den(np) + (1.D0-upweight)*auxvar_dn%den(np)
  1402)         
  1403)       gravity = (upweight*auxvar_up%den(np) * auxvar_up%avgmw(np) + &
  1404)              (1.D0-upweight)*auxvar_dn%den(np) * auxvar_dn%avgmw(np)) &
  1405)              * dist_gravity
  1406) 
  1407)       dphi = auxvar_up%pres - auxvar_dn%pres &
  1408)              - auxvar_up%pc(np) + auxvar_dn%pc(np) &
  1409)              + gravity
  1410) 
  1411)       v_darcy = 0.D0
  1412)       ukvr = 0.D0
  1413)       uh = 0.D0
  1414)       uxmol = 0.D0
  1415) 
  1416)       ! note uxmol only contains one phase xmol
  1417)       if (dphi >= 0.D0) then
  1418)         ukvr = auxvar_up%kvr(np)
  1419)         ! if (option%use_isothermal == PETSC_FALSE)&
  1420)         uh = auxvar_up%h(np)
  1421)       else
  1422)         ukvr = auxvar_dn%kvr(np)
  1423)         ! if (option%use_isothermal == PETSC_FALSE)&
  1424)         uh = auxvar_dn%h(np)
  1425)       endif
  1426)    
  1427) 
  1428)       if (ukvr > floweps) then
  1429)         v_darcy = Dq * ukvr * dphi
  1430)         vv_darcy(np) = v_darcy
  1431)         q = v_darcy * area
  1432)         fluxm(np)=fluxm(np) + q * density_ave
  1433)         ! if (option%use_isothermal == PETSC_FALSE)&
  1434)         fluxe = fluxe + q*density_ave*uh
  1435)       endif
  1436)     endif
  1437) 
  1438) #if 0 
  1439) ! Diffusion term   
  1440) ! Note : average rule may not be correct  
  1441)     if ((auxvar_up%sat(np) > eps) .and. (auxvar_dn%sat(np) > eps)) then
  1442)       difff = diffdp * 0.25D0*(auxvar_up%sat(np) + auxvar_dn%sat(np))* &
  1443)              (auxvar_up%den(np) + auxvar_dn%den(np))
  1444)       do ispec=1, option%nflowspec
  1445)         ind = ispec + (np-1)*option%nflowspec
  1446)         fluxm(ispec) = fluxm(ispec) + difff * .5D0 * &
  1447)                 (auxvar_up%diff(ind) + auxvar_dn%diff(ind))* &
  1448)                 (auxvar_up%xmol(ind) - auxvar_dn%xmol(ind))
  1449)       enddo
  1450)     endif
  1451) #endif
  1452)   enddo
  1453) 
  1454) ! conduction term
  1455)   !if (option%use_isothermal == PETSC_FALSE) then     
  1456)   Dk = (Dk_up * Dk_dn) / (dd_dn*Dk_up + dd_up*Dk_dn)
  1457)   cond = Dk*area*(auxvar_up%temp-auxvar_dn%temp)
  1458)   fluxe = fluxe + cond
  1459)  ! end if
  1460) 
  1461)   !if (option%use_isothermal)then
  1462)   !   Res(1:option%nflowdof) = fluxm(:) * option%flow_dt
  1463)  ! else
  1464)   Res(1:option%nphase) = fluxm(:) * option%flow_dt
  1465)   Res(option%nflowdof) = fluxe * option%flow_dt
  1466)  ! end if
  1467)  ! note: Res is the flux contribution, for node 1 R = R + Res_FL
  1468)  !                                              2 R = R - Res_FL  
  1469) 
  1470) end subroutine ImmisFlux
  1471) 
  1472) ! ************************************************************************** !
  1473) 
  1474) subroutine ImmisBCFlux(ibndtype,auxvars,auxvar_up,auxvar_dn, &
  1475)      por_dn,tor_dn,sir_dn,dd_up,perm_dn,Dk_dn, &
  1476)      area,dist_gravity,option,vv_darcy,Res)
  1477)   ! 
  1478)   ! Computes the  boundary flux terms for the residual
  1479)   ! 
  1480)   ! Author: Chuan Lu
  1481)   ! Date: 10/12/08
  1482)   ! 
  1483)   use Option_module
  1484)   
  1485)   implicit none
  1486)   
  1487)   PetscInt :: ibndtype(:)
  1488)   type(Immis_auxvar_elem_type) :: auxvar_up, auxvar_dn
  1489)   type(option_type) :: option
  1490)   PetscReal :: dd_up, sir_dn(:)
  1491)   PetscReal :: auxvars(:) ! from aux_real_var array
  1492)   PetscReal :: por_dn,perm_dn,Dk_dn,tor_dn
  1493)   PetscReal :: vv_darcy(:), area
  1494)   PetscReal :: Res(1:option%nflowdof) 
  1495)   
  1496)   PetscReal :: dist_gravity  ! distance along gravity vector
  1497)           
  1498)   PetscInt :: ispec, np
  1499)   PetscReal :: fluxm(option%nflowspec),fluxe,q,density_ave, v_darcy
  1500)   PetscReal :: uh,uxmol(1:option%nflowspec),ukvr,diff,diffdp,DK,Dq
  1501)   PetscReal :: upweight,cond,gravity,dphi
  1502) 
  1503)   fluxm = 0.d0
  1504)   fluxe = 0.d0
  1505) 
  1506)   do np = 1, option%nphase
  1507)     v_darcy = 0.d0
  1508)     density_ave = 0.d0
  1509)     q = 0.d0
  1510)     ukvr=0.D0
  1511)     select case(ibndtype(MPH_PRESSURE_DOF))
  1512)     case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC)
  1513)       Dq = perm_dn / dd_up
  1514) 
  1515)       ! only consider phase that exists, this also deals with IPHASE=1,2
  1516) !     if (auxvar_up%sat(np) > sir_dn(np) .or. auxvar_dn%sat(np) > sir_dn(np)) then
  1517)       if ((auxvar_up%kvr(np) + auxvar_dn%kvr(np)) > eps) then
  1518) 
  1519)         ! upweight according to saturation?
  1520)         upweight = 1.D0
  1521)         if (auxvar_up%sat(np) < eps) then 
  1522)           upweight = 0.d0
  1523)         else if (auxvar_dn%sat(np) < eps) then 
  1524)           upweight = 1.d0
  1525)         endif
  1526)         density_ave = upweight*auxvar_up%den(np) + (1.D0-upweight)*auxvar_dn%den(np)
  1527) 
  1528)         gravity = (upweight*auxvar_up%den(np) * auxvar_up%avgmw(np) + &
  1529)              (1.D0-upweight)*auxvar_dn%den(np) * auxvar_dn%avgmw(np)) &
  1530)              * dist_gravity
  1531) 
  1532)         ! calculate the pressure gradient
  1533)         dphi = auxvar_up%pres - auxvar_dn%pres &
  1534)              - auxvar_up%pc(np) + auxvar_dn%pc(np) &
  1535)              + gravity
  1536) 
  1537)         ! upwind rel perm by the pressure gradient
  1538)         if (dphi>=0.D0) then
  1539)           ukvr = auxvar_up%kvr(np)
  1540)         else
  1541)           ukvr = auxvar_dn%kvr(np)
  1542)         endif
  1543) 
  1544)         if (ukvr*Dq>floweps) then
  1545)           v_darcy = Dq * ukvr * dphi
  1546)         endif
  1547)       endif
  1548) 
  1549)     case(NEUMANN_BC) ! fixed by etc, 1/23/2012
  1550)       ! only consider phase that exists, this also deals with IPHASE=1,2
  1551)       if (auxvar_up%sat(np) > sir_dn(np) .or. auxvar_dn%sat(np) > sir_dn(np)) then
  1552) 
  1553)         ! upwind by imposed Neumann velocity
  1554)         if (dabs(auxvars(MPH_PRESSURE_DOF)) > floweps) then
  1555)           v_darcy = auxvars(MPH_PRESSURE_DOF)
  1556)           if (v_darcy > 0.d0) then
  1557)             density_ave = auxvar_up%den(np)
  1558)           else
  1559)             density_ave = auxvar_dn%den(np)
  1560)           endif
  1561)         endif
  1562)       end if
  1563)      end select
  1564) 
  1565)      q = v_darcy * area
  1566)      vv_darcy(np) = v_darcy
  1567)      uh=0.D0
  1568)      uxmol=0.D0
  1569) 
  1570)      if (v_darcy >= 0.D0) then
  1571)         !if (option%use_isothermal == PETSC_FALSE)&
  1572)          uh = auxvar_up%h(np)
  1573)         ! uxmol(:)=auxvar_up%xmol((np-1)*option%nflowspec+1 : np * option%nflowspec)
  1574)      else
  1575)          !if (option%use_isothermal == PETSC_FALSE)&
  1576)         uh = auxvar_dn%h(np)
  1577)          ! uxmol(:)=auxvar_dn%xmol((np-1)*option%nflowspec+1 : np * option%nflowspec)
  1578)      endif
  1579) 
  1580)         fluxm(np) = fluxm(np) + q*density_ave ! *uxmol(ispec)
  1581) 
  1582)       !if (option%use_isothermal == PETSC_FALSE) &
  1583)       fluxe = fluxe + q*density_ave*uh
  1584)  !print *,'FLBC', ibndtype(1),np, ukvr, v_darcy, uh, uxmol
  1585)    enddo
  1586) 
  1587) #if 0 
  1588)     ! Diffusion term   
  1589)   select case(ibndtype(3))
  1590)   case(DIRICHLET_BC) 
  1591)      !      if (auxvar_up%sat > eps .and. auxvar_dn%sat > eps) then
  1592)      !        diff = diffdp * 0.25D0*(auxvar_up%sat+auxvar_dn%sat)*(auxvar_up%den+auxvar_dn%den)
  1593)         do np = 1, option%nphase
  1594)           if (auxvar_up%sat(np)>eps .and. auxvar_dn%sat(np)>eps)then
  1595)               diff =diffdp * 0.25D0*(auxvar_up%sat(np)+auxvar_dn%sat(np))*&
  1596)                     (auxvar_up%den(np)+auxvar_up%den(np))
  1597)            do ispec = 1, option%nflowspec
  1598)               fluxm(ispec) = fluxm(ispec) + diff * auxvar_dn%diff((np-1)* option%nflowspec+ispec)* &
  1599)                    (auxvar_up%xmol((np-1)* option%nflowspec+ispec) &
  1600)                    -auxvar_dn%xmol((np-1)* option%nflowspec+ispec))
  1601)            enddo
  1602)           endif         
  1603)         enddo
  1604) 
  1605)   end select
  1606) #endif
  1607)   ! Conduction term
  1608) ! if (option%use_isothermal == PETSC_FALSE) then
  1609)     select case(ibndtype(2))
  1610)     case(DIRICHLET_BC)
  1611)        Dk =  Dk_dn / dd_up
  1612)        cond = Dk*area*(auxvar_up%temp - auxvar_dn%temp) 
  1613)        fluxe = fluxe + cond
  1614)     case(NEUMANN_BC)
  1615)        fluxe = fluxe + auxvars(2)*area*option%scale
  1616)        ! from W to MW, Added by Satish Karra 10/19/11
  1617)     case(ZERO_GRADIENT_BC)
  1618)        ! No change in fluxe	
  1619)     end select
  1620) ! end if
  1621) 
  1622)   Res(1:option%nphase)=fluxm(:)* option%flow_dt
  1623)   Res(option%nflowdof)=fluxe * option%flow_dt
  1624) 
  1625) end subroutine ImmisBCFlux
  1626) 
  1627) ! ************************************************************************** !
  1628) 
  1629) subroutine ImmisResidual(snes,xx,r,realization,ierr)
  1630)   ! 
  1631)   ! Computes the residual equation
  1632)   ! 
  1633)   ! Author: Chuan Lu
  1634)   ! Date: 10/10/08
  1635)   ! 
  1636) 
  1637)   use Realization_Subsurface_class
  1638)   use Patch_module
  1639)   use Discretization_module
  1640)   use Field_module
  1641)   use Option_module
  1642)   use Grid_module 
  1643) 
  1644)   implicit none
  1645) 
  1646)   SNES :: snes
  1647)   Vec :: xx
  1648)   Vec :: r
  1649)   type(realization_subsurface_type) :: realization
  1650)   PetscErrorCode :: ierr
  1651)   
  1652)   type(discretization_type), pointer :: discretization
  1653)   type(option_type), pointer :: option
  1654)   type(grid_type), pointer :: grid
  1655)   type(field_type), pointer :: field
  1656)   type(patch_type), pointer :: cur_patch
  1657)   PetscInt :: ichange  
  1658) 
  1659)   field => realization%field
  1660)   grid => realization%patch%grid
  1661)   option => realization%option
  1662)   discretization => realization%discretization
  1663)   
  1664)  
  1665) !  call DiscretizationGlobalToLocal(discretization,xx,field%flow_xx_loc,NFLOWDOF)
  1666)  ! check initial guess -----------------------------------------------
  1667)   ierr = ImmisInitGuessCheck(realization)
  1668)   if (ierr<0)then
  1669)     !ierr = PETSC_ERR_ARG_OUTOFRANGE
  1670)     if (option%myrank==0) print *,'table out of range: ',ierr
  1671)     call SNESSetFunctionDomainError() 
  1672)     return
  1673)   endif 
  1674)   ! end check ---------------------------------------------------------
  1675) 
  1676)   ! Communication -----------------------------------------
  1677)   ! These 3 must be called before ImmisUpdateAuxVars()
  1678)   call DiscretizationGlobalToLocal(discretization,xx,field%flow_xx_loc,NFLOWDOF)
  1679)   call DiscretizationLocalToLocal(discretization,field%icap_loc,field%icap_loc,ONEDOF)
  1680) 
  1681) !geh refactor  call DiscretizationLocalToLocal(discretization,field%perm_xx_loc,field%perm_xx_loc,ONEDOF)
  1682) !geh refactor  call DiscretizationLocalToLocal(discretization,field%perm_yy_loc,field%perm_yy_loc,ONEDOF)
  1683) !geh refactor  call DiscretizationLocalToLocal(discretization,field%perm_zz_loc,field%perm_zz_loc,ONEDOF)
  1684)   call DiscretizationLocalToLocal(discretization,field%ithrm_loc,field%ithrm_loc,ONEDOF)
  1685)   
  1686)   cur_patch => realization%patch_list%first
  1687)   do
  1688)     if (.not.associated(cur_patch)) exit
  1689)     realization%patch => cur_patch
  1690)     call ImmisResidualPatch(snes,xx,r,realization,ierr)
  1691)     cur_patch => cur_patch%next
  1692)   enddo
  1693) 
  1694) end subroutine ImmisResidual
  1695) 
  1696) ! ************************************************************************** !
  1697) 
  1698) subroutine ImmisResidualPatch(snes,xx,r,realization,ierr)
  1699)   ! 
  1700)   ! Computes the residual equation at patch level
  1701)   ! 
  1702)   ! Author: Chuan Lu
  1703)   ! Date: 10/10/08
  1704)   ! 
  1705) 
  1706)   use Connection_module
  1707)   use Realization_Subsurface_class
  1708)   use Patch_module
  1709)   use Grid_module
  1710)   use Option_module
  1711)   use Coupler_module  
  1712)   use Field_module
  1713)   use Debug_module
  1714)   
  1715)   implicit none
  1716) 
  1717)   SNES, intent(in) :: snes
  1718)   Vec, intent(inout) :: xx
  1719)   Vec, intent(out) :: r
  1720)   type(realization_subsurface_type) :: realization
  1721) 
  1722)   PetscErrorCode :: ierr
  1723)   PetscInt :: i, iphase, jn
  1724)   PetscInt :: ip1, ip2
  1725)   PetscInt :: local_id, ghosted_id, local_id_up, local_id_dn, ghosted_id_up, ghosted_id_dn
  1726) 
  1727)   PetscReal, pointer ::accum_p(:)
  1728) 
  1729)   PetscReal, pointer :: r_p(:), porosity_loc_p(:), volume_p(:), &
  1730)                xx_loc_p(:), xx_p(:), yy_p(:),&
  1731)                tortuosity_loc_p(:),&
  1732)                perm_xx_loc_p(:), perm_yy_loc_p(:), perm_zz_loc_p(:)
  1733)                           
  1734)                
  1735)   PetscReal, pointer :: icap_loc_p(:), ithrm_loc_p(:)
  1736) 
  1737)   PetscInt :: icap_up, icap_dn, ithrm_up, ithrm_dn
  1738)   PetscReal :: dd_up, dd_dn
  1739)   PetscReal :: dd, f_up, f_dn, ff
  1740)   PetscReal :: perm_up, perm_dn
  1741)   PetscReal :: D_up, D_dn  ! "Diffusion" constants at upstream, downstream faces.
  1742)   PetscReal :: dw_kg, dw_mol,dddt,dddp
  1743)   PetscReal :: tsrc1, qsrc1, csrc1, enth_src_h2o, enth_src_co2 , hsrc1
  1744)   PetscReal :: rho, fg, dfgdp, dfgdt, eng, dhdt, dhdp, visc, dvdt, dvdp, xphi
  1745)   PetscReal :: upweight
  1746)   PetscReal :: Res(realization%option%nflowdof), v_darcy(realization%option%nphase)
  1747)   PetscReal :: xxbc(realization%option%nflowdof)
  1748) ! PetscReal :: msrc(1:realization%option%nflowspec)
  1749)   PetscReal :: psrc(1:realization%option%nphase)
  1750)   PetscViewer :: viewer
  1751) 
  1752) 
  1753)   type(grid_type), pointer :: grid
  1754)   type(patch_type), pointer :: patch
  1755)   type(option_type), pointer :: option
  1756)   type(field_type), pointer :: field
  1757)   type(immis_type), pointer :: immis
  1758)   type(Immis_parameter_type), pointer :: immis_parameter
  1759)   
  1760)   type(Immis_auxvar_type), pointer :: auxvars(:), auxvars_bc(:), auxvars_ss(:)
  1761)   type(global_auxvar_type), pointer :: global_auxvars(:)
  1762)   type(global_auxvar_type), pointer :: global_auxvars_bc(:)
  1763)   type(global_auxvar_type), pointer :: global_auxvars_ss(:)
  1764)   
  1765)   type(coupler_type), pointer :: boundary_condition, source_sink
  1766)   type(connection_set_list_type), pointer :: connection_set_list
  1767)   type(connection_set_type), pointer :: cur_connection_set
  1768)   PetscReal, pointer :: msrc(:)
  1769) 
  1770)   PetscBool :: enthalpy_flag
  1771)   PetscInt :: ng
  1772)   PetscInt :: iconn, idof, istart, iend
  1773)   PetscInt :: nsrcpara
  1774)   PetscInt :: sum_connection
  1775)   PetscReal :: distance, fraction_upwind
  1776)   PetscReal :: distance_gravity
  1777)   PetscReal :: ss_flow_vol_flux(realization%option%nphase)
  1778)   
  1779)   character(len=MAXSTRINGLENGTH) :: string
  1780) 
  1781)   patch => realization%patch
  1782)   grid => patch%grid
  1783)   option => realization%option
  1784)   field => realization%field
  1785) 
  1786)   immis => patch%aux%Immis
  1787)   immis_parameter => patch%aux%Immis%immis_parameter
  1788)   auxvars => patch%aux%Immis%auxvars
  1789)   auxvars_bc => patch%aux%Immis%auxvars_bc
  1790)   auxvars_ss => patch%aux%Immis%auxvars_ss
  1791)   global_auxvars => patch%aux%Global%auxvars
  1792)   global_auxvars_bc => patch%aux%Global%auxvars_bc
  1793)   global_auxvars_ss => patch%aux%Global%auxvars_ss
  1794)   
  1795) 
  1796)  ! call ImmisUpdateAuxVarsPatchNinc(realization)
  1797)   ! override flags since they will soon be out of date  
  1798)  ! patch%ImmisAux%auxvars_up_to_date = PETSC_FALSE 
  1799)  
  1800)   if (option%compute_mass_balance_new) then
  1801)     call ImmisZeroMassBalDeltaPatch(realization)
  1802)   endif
  1803) 
  1804) ! now assign access pointer to local variables
  1805)   call VecGetArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  1806)   call VecGetArrayF90(r, r_p, ierr);CHKERRQ(ierr)
  1807)   call VecGetArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  1808)  
  1809) ! call VecGetArrayF90(field%flow_yy,yy_p,ierr)
  1810) !geh refactor  call VecGetArrayF90(field%porosity_loc, porosity_loc_p, ierr)
  1811) !geh refactor  call VecGetArrayF90(field%tortuosity_loc, tortuosity_loc_p, ierr)
  1812) !geh refactor  call VecGetArrayF90(field%perm_xx_loc, perm_xx_loc_p, ierr)
  1813) !geh refactor  call VecGetArrayF90(field%perm_yy_loc, perm_yy_loc_p, ierr)
  1814) !geh refactor  call VecGetArrayF90(field%perm_zz_loc, perm_zz_loc_p, ierr)
  1815) !geh refactor  call VecGetArrayF90(field%volume, volume_p, ierr)
  1816)   call VecGetArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  1817)   call VecGetArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  1818)  
  1819)  
  1820) ! Multiphase flash calculation is more expensive, so calculate once per iteration
  1821) #if 1
  1822)   ! Pertubations for aux terms --------------------------------
  1823)   do ng = 1, grid%ngmax
  1824)     if (grid%nG2L(ng) < 0) cycle
  1825)     if (associated(patch%imat)) then
  1826)       if (patch%imat(ng) <= 0) cycle
  1827)     endif
  1828)         
  1829)     istart = (ng-1)*option%nflowdof + 1; iend = istart - 1 + option%nflowdof
  1830)     call ImmisAuxVarCompute_Ninc(xx_loc_p(istart:iend),auxvars(ng)%auxvar_elem(0), &
  1831)       patch%saturation_function_array(int(icap_loc_p(ng)))%ptr, &
  1832)       realization%fluid_properties,option)
  1833) 
  1834)     if (option%flow%numerical_derivatives) then
  1835)       patch%aux%Immis%delx(1,ng) = xx_loc_p((ng-1)*option%nflowdof+1)*dfac * 1.D-3
  1836)         patch%aux%Immis%delx(2,ng) = xx_loc_p((ng-1)*option%nflowdof+2)*dfac
  1837)  
  1838)       if (xx_loc_p((ng-1)*option%nflowdof+3) <=0.9)then
  1839)         patch%aux%Immis%delx(3,ng) = dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  1840)       else
  1841)         patch%aux%Immis%delx(3,ng) = -dfac*xx_loc_p((ng-1)*option%nflowdof+3) 
  1842)       endif
  1843)            
  1844)       if (patch%aux%Immis%delx(3,ng) < 1D-12 .and. patch%aux%Immis%delx(3,ng) >= 0.D0) &
  1845)         patch%aux%Immis%delx(3,ng) = 1D-12
  1846)       if (patch%aux%Immis%delx(3,ng) > -1D-12 .and. patch%aux%Immis%delx(3,ng) < 0.D0) &
  1847)         patch%aux%Immis%delx(3,ng) = -1D-12
  1848)         
  1849)       if ((patch%aux%Immis%delx(3,ng)+xx_loc_p((ng-1)*option%nflowdof+3))>1.D0) then
  1850)         patch%aux%Immis%delx(3,ng) = (1.D0-xx_loc_p((ng-1)*option%nflowdof+3))*1D-6
  1851)       endif
  1852)       if (( patch%aux%Immis%delx(3,ng)+xx_loc_p((ng-1)*option%nflowdof+3))<0.D0)then
  1853)         patch%aux%Immis%delx(3,ng) = xx_loc_p((ng-1)*option%nflowdof+3)*1D-6
  1854)       endif
  1855)       call ImmisAuxVarCompute_Winc(xx_loc_p(istart:iend),patch%aux%Immis%delx(:,ng), &
  1856)           auxvars(ng)%auxvar_elem(1:option%nflowdof), &
  1857)           patch%saturation_function_array(int(icap_loc_p(ng)))%ptr, &
  1858)           realization%fluid_properties,option)
  1859)     endif
  1860)   enddo
  1861) #endif
  1862) 
  1863)    patch%aux%Immis%res_old_AR=0.D0
  1864)    patch%aux%Immis%res_old_FL=0.D0
  1865)    r_p = 0.d0
  1866) 
  1867) #if 1
  1868)   ! Accumulation terms ------------------------------------
  1869)   r_p = - accum_p
  1870) 
  1871)   do local_id = 1, grid%nlmax  ! For each local node do...
  1872)     ghosted_id = grid%nL2G(local_id)
  1873)     !geh - Ignore inactive cells with inactive materials
  1874)     if (associated(patch%imat)) then
  1875)       if (patch%imat(ghosted_id) <= 0) cycle
  1876)     endif
  1877)     iend = local_id*option%nflowdof
  1878)     istart = iend-option%nflowdof+1
  1879)     call ImmisAccumulation(auxvars(ghosted_id)%auxvar_elem(0),porosity_loc_p(ghosted_id), &
  1880)                               volume_p(local_id), &
  1881)                               immis_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  1882)                               option,ONE_INTEGER,Res) 
  1883)     r_p(istart:iend) = r_p(istart:iend) + Res(1:option%nflowdof)
  1884)     !print *,'REs, acm: ', res
  1885)     patch%aux%Immis%res_old_AR(local_id, :) = Res(1:option%nflowdof)
  1886)   enddo
  1887) #endif
  1888) 
  1889) #if 1
  1890)   ! Source/sink terms -------------------------------------
  1891)   source_sink => patch%source_sink_list%first 
  1892)   sum_connection = 0
  1893)   do 
  1894)     if (.not.associated(source_sink)) exit
  1895)     !print *, 'RES s/s begin'
  1896)     ! check whether enthalpy dof is included
  1897)   !  if (source_sink%flow_condition%num_sub_conditions > 3) then
  1898)       enthalpy_flag = PETSC_TRUE
  1899)    ! else
  1900)    !   enthalpy_flag = PETSC_FALSE
  1901)    ! endif
  1902)       
  1903)     if (associated(source_sink%flow_condition%pressure)) then
  1904)       psrc(:) = source_sink%flow_condition%pressure%dataset%rarray(:)
  1905)     endif
  1906) !    qsrc1 = source_sink%flow_condition%pressure%dataset%rarray(1)
  1907)     tsrc1 = source_sink%flow_condition%temperature%dataset%rarray(1)
  1908)     csrc1 = source_sink%flow_condition%concentration%dataset%rarray(1)
  1909)     if (enthalpy_flag) hsrc1 = source_sink%flow_condition%enthalpy%dataset%rarray(1)
  1910) !     hsrc1=0D0
  1911) !     qsrc1 = qsrc1 / FMWH2O ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
  1912) !     csrc1 = csrc1 / FMWCO2
  1913) !     msrc(1) = qsrc1; msrc(2) =csrc1
  1914) !     msrc(:) = psrc(:)
  1915) !     msrc(1) = msrc(1) / FMWH2O
  1916) !     msrc(2) = msrc(2) / FMWCO2
  1917)       
  1918) !clu add
  1919)     select case(source_sink%flow_condition%itype(1))
  1920)       case(MASS_RATE_SS)
  1921)       msrc => source_sink%flow_condition%rate%dataset%rarray
  1922)       nsrcpara = 2
  1923)     case(WELL_SS)
  1924)       msrc => source_sink%flow_condition%well%dataset%rarray
  1925)       nsrcpara = 7 + option%nflowspec 
  1926)      
  1927) !     print *,'src/sink: ',nsrcpara,msrc
  1928)     case default
  1929)       print *, 'IMS mode does not support source/sink type: ', source_sink%flow_condition%itype(1)
  1930)       stop  
  1931)     end select
  1932) 
  1933) !clu end change
  1934) 
  1935)     cur_connection_set => source_sink%connection_set
  1936)     do iconn = 1, cur_connection_set%num_connections      
  1937)       local_id = cur_connection_set%id_dn(iconn)
  1938)       ghosted_id = grid%nL2G(local_id)
  1939)       if (patch%imat(ghosted_id) <= 0) cycle
  1940)       sum_connection = sum_connection + 1
  1941)       call ImmisSourceSink(msrc,nsrcpara,psrc,tsrc1,hsrc1,auxvars(ghosted_id)%auxvar_elem(0),&
  1942)             source_sink%flow_condition%itype(1),Res, &
  1943)             ss_flow_vol_flux, &
  1944)             enthalpy_flag, option)
  1945)       if (associated(patch%ss_flow_fluxes)) then
  1946)         patch%ss_flow_fluxes(:,sum_connection) = Res(:)/option%flow_dt
  1947)       endif
  1948)       if (associated(patch%ss_flow_vol_fluxes)) then
  1949)         patch%ss_flow_vol_fluxes(:,sum_connection) = ss_flow_vol_flux/option%flow_dt
  1950)       endif
  1951)       if (option%compute_mass_balance_new) then
  1952)         global_auxvars_ss(sum_connection)%mass_balance_delta(:,1) = &
  1953)           global_auxvars_ss(sum_connection)%mass_balance_delta(:,1) - &
  1954)             Res(:)/option%flow_dt
  1955)       endif
  1956)  
  1957)       r_p((local_id-1)*option%nflowdof + jh2o) = &
  1958)            r_p((local_id-1)*option%nflowdof + jh2o) - Res(jh2o)
  1959)       r_p((local_id-1)*option%nflowdof + jco2) = &
  1960)            r_p((local_id-1)*option%nflowdof + jco2) - Res(jco2)
  1961)       patch%aux%Immis%res_old_AR(local_id,jh2o) = &
  1962)            patch%aux%Immis%res_old_AR(local_id,jh2o) - Res(jh2o)
  1963)       patch%aux%Immis%res_old_AR(local_id,jco2) = &
  1964)            patch%aux%Immis%res_old_AR(local_id,jco2) - Res(jco2)
  1965)       if (enthalpy_flag) then
  1966)         r_p( local_id*option%nflowdof) = r_p(local_id*option%nflowdof) - Res(option%nflowdof)
  1967)            patch%aux%Immis%res_old_AR(local_id,option%nflowdof) = &
  1968)              patch%aux%Immis%res_old_AR(local_id,option%nflowdof) - Res(option%nflowdof)
  1969)       endif 
  1970)   !  else if (qsrc1 < 0.d0) then ! withdrawal
  1971)   !  endif
  1972)     enddo
  1973)     source_sink => source_sink%next
  1974)   enddo
  1975) #endif
  1976) 
  1977) #if 1
  1978)   ! Boundary Flux Terms -----------------------------------
  1979)   boundary_condition => patch%boundary_condition_list%first
  1980)   sum_connection = 0    
  1981)   do 
  1982)     if (.not.associated(boundary_condition)) exit
  1983)     
  1984)     cur_connection_set => boundary_condition%connection_set
  1985)         
  1986)     do iconn = 1, cur_connection_set%num_connections
  1987)       sum_connection = sum_connection + 1
  1988)     
  1989)       local_id = cur_connection_set%id_dn(iconn)
  1990)       ghosted_id = grid%nL2G(local_id)
  1991) 
  1992)       if (associated(patch%imat)) then
  1993)         if (patch%imat(ghosted_id) <= 0) cycle
  1994)       endif
  1995) 
  1996)       if (ghosted_id<=0) then
  1997)         print *, "Wrong boundary node index... STOP!!!"
  1998)         stop
  1999)       endif
  2000) 
  2001)       ithrm_dn = int(ithrm_loc_p(ghosted_id))
  2002)       D_dn = immis_parameter%ckwet(ithrm_dn)
  2003) 
  2004)       ! for now, just assume diagonal tensor
  2005)       perm_dn = perm_xx_loc_p(ghosted_id)*abs(cur_connection_set%dist(1,iconn))+ &
  2006)                 perm_yy_loc_p(ghosted_id)*abs(cur_connection_set%dist(2,iconn))+ &
  2007)                 perm_zz_loc_p(ghosted_id)*abs(cur_connection_set%dist(3,iconn))
  2008)       ! dist(0,iconn) = scalar - magnitude of distance
  2009)       ! gravity = vector(3)
  2010)       ! dist(1:3,iconn) = vector(3) - unit vector
  2011)       distance_gravity = cur_connection_set%dist(0,iconn) * &
  2012)                          dot_product(option%gravity, &
  2013)                                      cur_connection_set%dist(1:3,iconn))
  2014) 
  2015)       icap_dn = int(icap_loc_p(ghosted_id))  
  2016) ! Then need fill up increments for BCs
  2017)        do idof = 1, option%nflowdof
  2018)          select case(boundary_condition%flow_condition%itype(idof))
  2019)            case(DIRICHLET_BC)
  2020)              xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
  2021)            case(HYDROSTATIC_BC)
  2022)              xxbc(MPH_PRESSURE_DOF) = boundary_condition%flow_aux_real_var(MPH_PRESSURE_DOF,iconn)
  2023)              if (idof>=MPH_TEMPERATURE_DOF)then
  2024)                xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2025)              endif
  2026)            case(NEUMANN_BC, ZERO_GRADIENT_BC)
  2027)           ! solve for pb from Darcy's law given qb /= 0
  2028)              xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2029)          end select
  2030)       enddo
  2031) 
  2032)  
  2033)       call ImmisAuxVarCompute_Ninc(xxbc,auxvars_bc(sum_connection)%auxvar_elem(0),&
  2034)          patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr,&
  2035)          realization%fluid_properties, option)
  2036) 
  2037)       call ImmisBCFlux(boundary_condition%flow_condition%itype, &
  2038)          boundary_condition%flow_aux_real_var(:,iconn), &
  2039)          auxvars_bc(sum_connection)%auxvar_elem(0), &
  2040)          auxvars(ghosted_id)%auxvar_elem(0), &
  2041)          porosity_loc_p(ghosted_id), &
  2042)          tortuosity_loc_p(ghosted_id), &
  2043)          immis_parameter%sir(:,icap_dn), &
  2044)          cur_connection_set%dist(0,iconn),perm_dn,D_dn, &
  2045)          cur_connection_set%area(iconn), &
  2046)          distance_gravity,option, &
  2047)          v_darcy,Res)
  2048) 
  2049)       if (option%compute_mass_balance_new) then
  2050)         ! contribution to boundary
  2051)         do iphase = 1, option%nphase
  2052)           global_auxvars_bc(sum_connection)%mass_balance_delta(iphase,iphase) = &
  2053)             global_auxvars_bc(sum_connection)%mass_balance_delta(iphase,iphase) - &
  2054)             Res(iphase)/option%flow_dt
  2055)         enddo
  2056)       endif
  2057) 
  2058)       patch%boundary_velocities(:,sum_connection) = v_darcy(:)
  2059)       if (associated(patch%boundary_flow_fluxes)) then
  2060)         patch%boundary_flow_fluxes(:,sum_connection) = Res(:)
  2061)       endif        
  2062)       iend = local_id*option%nflowdof
  2063)       istart = iend-option%nflowdof+1
  2064)       r_p(istart:iend) = r_p(istart:iend) - Res(1:option%nflowdof)
  2065)       patch%aux%Immis%res_old_AR(local_id,1:option%nflowdof) = &
  2066)         patch%aux%Immis%res_old_AR(local_id,1:option%nflowdof) - Res(1:option%nflowdof)
  2067)     enddo
  2068)     boundary_condition => boundary_condition%next
  2069)   enddo
  2070) #endif
  2071) 
  2072) #if 1
  2073)   ! Interior Flux Terms -----------------------------------
  2074)   connection_set_list => grid%internal_connection_set_list
  2075)   cur_connection_set => connection_set_list%first
  2076)   sum_connection = 0  
  2077)   do 
  2078)     if (.not.associated(cur_connection_set)) exit
  2079)     do iconn = 1, cur_connection_set%num_connections
  2080)       sum_connection = sum_connection + 1
  2081) 
  2082)       ghosted_id_up = cur_connection_set%id_up(iconn)
  2083)       ghosted_id_dn = cur_connection_set%id_dn(iconn)
  2084) 
  2085)       local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
  2086)       local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping   
  2087) 
  2088)       if (associated(patch%imat)) then
  2089)         if (patch%imat(ghosted_id_up) <= 0 .or.  &
  2090)             patch%imat(ghosted_id_dn) <= 0) cycle
  2091)       endif
  2092) 
  2093)       fraction_upwind = cur_connection_set%dist(-1,iconn)
  2094)       distance = cur_connection_set%dist(0,iconn)
  2095)       ! distance = scalar - magnitude of distance
  2096)       ! gravity = vector(3)
  2097)       ! dist(1:3,iconn) = vector(3) - unit vector
  2098)       distance_gravity = distance * &
  2099)                          dot_product(option%gravity, &
  2100)                                      cur_connection_set%dist(1:3,iconn))
  2101)       dd_up = distance*fraction_upwind
  2102)       dd_dn = distance-dd_up ! should avoid truncation error
  2103)       ! upweight could be calculated as 1.d0-fraction_upwind
  2104)       ! however, this introduces ever so slight error causing pflow-overhaul not
  2105)       ! to match pflow-orig.  This can be changed to 1.d0-fraction_upwind
  2106)       upweight = dd_dn/(dd_up+dd_dn)
  2107)         
  2108)       ! for now, just assume diagonal tensor
  2109)       perm_up = perm_xx_loc_p(ghosted_id_up)*abs(cur_connection_set%dist(1,iconn))+ &
  2110)                 perm_yy_loc_p(ghosted_id_up)*abs(cur_connection_set%dist(2,iconn))+ &
  2111)                 perm_zz_loc_p(ghosted_id_up)*abs(cur_connection_set%dist(3,iconn))
  2112) 
  2113)       perm_dn = perm_xx_loc_p(ghosted_id_dn)*abs(cur_connection_set%dist(1,iconn))+ &
  2114)                 perm_yy_loc_p(ghosted_id_dn)*abs(cur_connection_set%dist(2,iconn))+ &
  2115)                 perm_zz_loc_p(ghosted_id_dn)*abs(cur_connection_set%dist(3,iconn))
  2116) 
  2117)       ithrm_up = int(ithrm_loc_p(ghosted_id_up))
  2118)       ithrm_dn = int(ithrm_loc_p(ghosted_id_dn))
  2119)       icap_up = int(icap_loc_p(ghosted_id_up))
  2120)       icap_dn = int(icap_loc_p(ghosted_id_dn))
  2121)    
  2122)       D_up = immis_parameter%ckwet(ithrm_up)
  2123)       D_dn = immis_parameter%ckwet(ithrm_dn)
  2124) 
  2125)       call ImmisFlux(auxvars(ghosted_id_up)%auxvar_elem(0),porosity_loc_p(ghosted_id_up), &
  2126)                 tortuosity_loc_p(ghosted_id_up),immis_parameter%sir(:,icap_up), &
  2127)                 dd_up,perm_up,D_up, &
  2128)                 auxvars(ghosted_id_dn)%auxvar_elem(0),porosity_loc_p(ghosted_id_dn), &
  2129)                 tortuosity_loc_p(ghosted_id_dn),immis_parameter%sir(:,icap_dn), &
  2130)                 dd_dn,perm_dn,D_dn, &
  2131)                 cur_connection_set%area(iconn),distance_gravity, &
  2132)                 upweight,option,v_darcy,Res)
  2133) 
  2134)       patch%internal_velocities(:,sum_connection) = v_darcy(:)
  2135)       if (associated(patch%internal_flow_fluxes)) then
  2136)         patch%internal_flow_fluxes(:,sum_connection) = Res(:)
  2137)       endif      
  2138)       patch%aux%Immis%res_old_FL(sum_connection,1:option%nflowdof)= Res(1:option%nflowdof)
  2139)  
  2140)       if (local_id_up>0) then
  2141)         iend = local_id_up*option%nflowdof
  2142)         istart = iend-option%nflowdof+1
  2143)         r_p(istart:iend) = r_p(istart:iend) + Res(1:option%nflowdof)
  2144)       endif
  2145)    
  2146)       if (local_id_dn>0) then
  2147)         iend = local_id_dn*option%nflowdof
  2148)         istart = iend-option%nflowdof+1
  2149)         r_p(istart:iend) = r_p(istart:iend) - Res(1:option%nflowdof)
  2150)       endif
  2151) 
  2152)     enddo
  2153)     cur_connection_set => cur_connection_set%next
  2154)   enddo    
  2155) #endif
  2156) 
  2157) ! adjust residual to R/dt
  2158)   select case (option%idt_switch) 
  2159)   case(1) 
  2160)     r_p(:) = r_p(:)/option%flow_dt
  2161)   case(-1)
  2162)     if (option%flow_dt>1.D0) r_p(:) = r_p(:)/option%flow_dt
  2163)   end select
  2164)   
  2165)   do local_id = 1, grid%nlmax
  2166)     if (associated(patch%imat)) then
  2167)       if (patch%imat(grid%nL2G(local_id)) <= 0) cycle
  2168)     endif
  2169) 
  2170)     istart = 1 + (local_id-1)*option%nflowdof
  2171)     if (volume_p(local_id)>1.D0) r_p (istart:istart+2)=r_p(istart:istart+2)/volume_p(local_id)
  2172)     if (r_p(istart) >1E20 .or. r_p(istart) <-1E20) print *, r_p (istart:istart+2)
  2173)   enddo
  2174) 
  2175) ! print *,'finished rp vol scale'
  2176) !  if (option%use_isothermal) then
  2177) #ifdef ISOTHERMAL
  2178)     do local_id = 1, grid%nlmax  ! For each local node do...
  2179)       ghosted_id = grid%nL2G(local_id)   ! corresponding ghost index
  2180)       if (associated(patch%imat)) then
  2181)         if (patch%imat(ghosted_id) <= 0) cycle
  2182)       endif
  2183)       istart = 3 + (local_id-1)*option%nflowdof
  2184)       r_p(istart) = 0.D0 ! xx_loc_p(2 + (ng-1)*option%nflowdof) - yy_p(p1-1)
  2185)     enddo
  2186) #endif
  2187) !  endif
  2188)   !call VecRestoreArrayF90(r, r_p, ierr)
  2189) 
  2190) 
  2191)   if (patch%aux%Immis%inactive_cells_exist) then
  2192)     do i=1,patch%aux%Immis%n_zero_rows
  2193)       r_p(patch%aux%Immis%zero_rows_local(i)) = 0.d0
  2194)     enddo
  2195)   endif
  2196) 
  2197)   call VecRestoreArrayF90(r, r_p, ierr);CHKERRQ(ierr)
  2198) ! call VecRestoreArrayF90(field%flow_yy, yy_p, ierr)
  2199)   call VecRestoreArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  2200)   call VecRestoreArrayF90(field%flow_accum, accum_p, ierr);CHKERRQ(ierr)
  2201) !geh refactor  call VecRestoreArrayF90(field%porosity_loc, porosity_loc_p, ierr)
  2202) !geh refactor  call VecRestoreArrayF90(field%tortuosity_loc, tortuosity_loc_p, ierr)
  2203) !geh refactor  call VecRestoreArrayF90(field%perm_xx_loc, perm_xx_loc_p, ierr)
  2204) !geh refactor  call VecRestoreArrayF90(field%perm_yy_loc, perm_yy_loc_p, ierr)
  2205) !geh refactor  call VecRestoreArrayF90(field%perm_zz_loc, perm_zz_loc_p, ierr)
  2206) !geh refactor  call VecRestoreArrayF90(field%volume, volume_p, ierr)
  2207)   call VecRestoreArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  2208)   call VecRestoreArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  2209) 
  2210)   if (realization%debug%vecview_residual) then
  2211)     string = 'Iresidual'
  2212)     call DebugCreateViewer(realization%debug,string,option,viewer)
  2213)     call VecView(r,viewer,ierr);CHKERRQ(ierr)
  2214)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  2215)   endif
  2216)   if (realization%debug%vecview_solution) then
  2217)     string = 'Ixx'
  2218)     call DebugCreateViewer(realization%debug,string,option,viewer)
  2219)     call VecView(xx,viewer,ierr);CHKERRQ(ierr)
  2220)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  2221)   endif
  2222) end subroutine ImmisResidualPatch
  2223) 
  2224) ! ************************************************************************** !
  2225) 
  2226) subroutine ImmisJacobian(snes,xx,A,B,realization,ierr)
  2227)   ! 
  2228)   ! Computes the Jacobian
  2229)   ! 
  2230)   ! Author: Chuan Lu
  2231)   ! Date: 10/10/08
  2232)   ! 
  2233) 
  2234)   use Realization_Subsurface_class
  2235)   use Patch_module
  2236)   use Grid_module
  2237)   use Option_module
  2238) 
  2239)   implicit none
  2240) 
  2241)   SNES :: snes
  2242)   Vec :: xx
  2243)   Mat :: A, B, J
  2244)   type(realization_subsurface_type) :: realization
  2245)   PetscErrorCode :: ierr
  2246)   
  2247)   type(patch_type), pointer :: cur_patch
  2248)   type(grid_type),  pointer :: grid
  2249)   
  2250)   cur_patch => realization%patch_list%first
  2251)   do
  2252)     if (.not.associated(cur_patch)) exit
  2253)     realization%patch => cur_patch
  2254)     call ImmisJacobianPatch(snes,xx,A,B,realization,ierr)
  2255)     cur_patch => cur_patch%next
  2256)   enddo
  2257) 
  2258) end subroutine ImmisJacobian
  2259) 
  2260) ! ************************************************************************** !
  2261) 
  2262) subroutine ImmisJacobianPatch(snes,xx,A,B,realization,ierr)
  2263)   ! 
  2264)   ! Computes the Jacobian
  2265)   ! 
  2266)   ! Author: Chuan Lu
  2267)   ! Date: 10/13/08
  2268)   ! 
  2269) 
  2270)   use Connection_module
  2271)   use Option_module
  2272)   use Grid_module
  2273)   use Realization_Subsurface_class
  2274)   use Patch_module
  2275)   use Coupler_module
  2276)   use Field_module
  2277)   use Debug_module
  2278)   
  2279)   implicit none
  2280) 
  2281)   SNES :: snes
  2282)   Vec :: xx
  2283)   Mat :: A, B
  2284)   type(realization_subsurface_type) :: realization
  2285) 
  2286)   PetscErrorCode :: ierr
  2287)   PetscInt :: nvar,neq,nr
  2288)   PetscInt :: ithrm_up, ithrm_dn, i
  2289)   PetscInt :: ip1, ip2 
  2290) 
  2291)   PetscReal, pointer :: porosity_loc_p(:), volume_p(:), &
  2292)                           xx_loc_p(:), tortuosity_loc_p(:),&
  2293)                           perm_xx_loc_p(:), perm_yy_loc_p(:), perm_zz_loc_p(:)
  2294)   PetscReal, pointer :: icap_loc_p(:), ithrm_loc_p(:)
  2295)   PetscInt :: icap,icap_up,icap_dn
  2296)   PetscInt :: ii, jj
  2297)   PetscReal :: dw_kg,dw_mol,enth_src_co2,enth_src_h2o,rho
  2298)   PetscReal :: tsrc1,qsrc1,csrc1,hsrc1
  2299)   PetscReal :: dd_up, dd_dn, dd, f_up, f_dn
  2300)   PetscReal :: perm_up, perm_dn
  2301)   PetscReal :: dw_dp,dw_dt,hw_dp,hw_dt,dresT_dp,dresT_dt
  2302)   PetscReal :: D_up, D_dn  ! "Diffusion" constants upstream and downstream of a face.
  2303)   PetscReal :: zero, norm
  2304)   PetscReal :: upweight
  2305)   PetscReal :: max_dev  
  2306)   PetscInt :: local_id, ghosted_id
  2307)   PetscInt :: local_id_up, local_id_dn
  2308)   PetscInt :: ghosted_id_up, ghosted_id_dn
  2309)   PetscInt ::  natural_id_up,natural_id_dn
  2310)   
  2311)   PetscReal :: Jup(1:realization%option%nflowdof,1:realization%option%nflowdof), &
  2312)             Jdn(1:realization%option%nflowdof,1:realization%option%nflowdof)
  2313)   
  2314)   PetscInt :: istart, iend
  2315)   
  2316)   type(coupler_type), pointer :: boundary_condition, source_sink
  2317)   type(connection_set_list_type), pointer :: connection_set_list
  2318)   type(connection_set_type), pointer :: cur_connection_set
  2319)   PetscBool :: enthalpy_flag
  2320)   PetscInt :: iconn, idof
  2321)   PetscInt :: sum_connection  
  2322)   PetscReal :: distance, fraction_upwind
  2323)   PetscReal :: distance_gravity
  2324)   PetscReal :: Res(realization%option%nflowdof) 
  2325)   PetscReal :: xxbc(1:realization%option%nflowdof), delxbc(1:realization%option%nflowdof)
  2326)   PetscReal :: ResInc(realization%patch%grid%nlmax,realization%option%nflowdof,&
  2327)            realization%option%nflowdof)
  2328)   type(grid_type), pointer :: grid
  2329)   type(patch_type), pointer :: patch
  2330)   type(option_type), pointer :: option 
  2331)   type(field_type), pointer :: field 
  2332)   type(Immis_parameter_type), pointer :: immis_parameter
  2333)   type(Immis_auxvar_type), pointer :: auxvars(:), auxvars_bc(:)
  2334)   
  2335)   PetscReal :: vv_darcy(realization%option%nphase), voltemp
  2336)   PetscReal :: ra(1:realization%option%nflowdof,1:realization%option%nflowdof*2) 
  2337)   PetscReal, pointer :: msrc(:)
  2338) ! PetscReal :: msrc(1:realization%option%nflowspec)
  2339)   PetscReal :: psrc(1:realization%option%nphase), ss_flow(1:realization%option%nphase)
  2340)   PetscReal :: dddt, dddp, fg, dfgdp, dfgdt, eng, dhdt, dhdp, visc, dvdt,&
  2341)                dvdp, xphi
  2342)   PetscInt :: nsrcpara  
  2343)   
  2344)   PetscViewer :: viewer
  2345)   Vec :: debug_vec
  2346)   character(len=MAXSTRINGLENGTH) :: string
  2347) 
  2348) !-----------------------------------------------------------------------
  2349) ! R stand for residual
  2350) !  ra       1              2              3              4          5              6            7      8
  2351) ! 1: p     dR/dpi         dR/dTi          dR/dci        dR/dsi   dR/dpim        dR/dTim
  2352) ! 2: T
  2353) ! 3: c
  2354) ! 4  s         
  2355) !-----------------------------------------------------------------------
  2356) 
  2357)   patch => realization%patch
  2358)   grid => patch%grid
  2359)   option => realization%option
  2360)   field => realization%field
  2361) 
  2362)   immis_parameter => patch%aux%Immis%immis_parameter
  2363)   auxvars => patch%aux%Immis%auxvars
  2364)   auxvars_bc => patch%aux%Immis%auxvars_bc
  2365)   
  2366) ! dropped derivatives:
  2367) !   1.D0 gas phase viscocity to all p,t,c,s
  2368) !   2. Average molecular weights to p,t,s
  2369) 
  2370) #if 0
  2371) !  call ImmisNumericalJacobianTest(xx,realization)
  2372) #endif
  2373) 
  2374)  ! print *,'*********** In Jacobian ********************** '
  2375)   call MatZeroEntries(A,ierr);CHKERRQ(ierr)
  2376) 
  2377)   call VecGetArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  2378) !geh refactor  call VecGetArrayF90(field%porosity_loc, porosity_loc_p, ierr)
  2379) !geh refactor  call VecGetArrayF90(field%tortuosity_loc, tortuosity_loc_p, ierr)
  2380) !geh refactor  call VecGetArrayF90(field%perm_xx_loc, perm_xx_loc_p, ierr)
  2381) !geh refactor  call VecGetArrayF90(field%perm_yy_loc, perm_yy_loc_p, ierr)
  2382) !geh refactor  call VecGetArrayF90(field%perm_zz_loc, perm_zz_loc_p, ierr)
  2383) !geh refactor  call VecGetArrayF90(field%volume, volume_p, ierr)
  2384) 
  2385)   call VecGetArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  2386)   call VecGetArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  2387) 
  2388)  ResInc = 0.D0
  2389) #if 1
  2390)   ! Accumulation terms ------------------------------------
  2391)   do local_id = 1, grid%nlmax  ! For each local node do...
  2392)      ghosted_id = grid%nL2G(local_id)
  2393)      !geh - Ignore inactive cells with inactive materials
  2394)      if (associated(patch%imat)) then
  2395)         if (patch%imat(ghosted_id) <= 0) cycle
  2396)      endif
  2397)      iend = local_id*option%nflowdof
  2398)      istart = iend-option%nflowdof+1
  2399)      icap = int(icap_loc_p(ghosted_id))
  2400)      
  2401)      do nvar =1, option%nflowdof
  2402)         call ImmisAccumulation(auxvars(ghosted_id)%auxvar_elem(nvar), &
  2403)              porosity_loc_p(ghosted_id), &
  2404)              volume_p(local_id), &
  2405)              immis_parameter%dencpr(int(ithrm_loc_p(ghosted_id))), &
  2406)              option,ONE_INTEGER, res) 
  2407)         ResInc( local_id,:,nvar) =  ResInc(local_id,:,nvar) + Res(:)
  2408)      enddo
  2409)      
  2410)   enddo
  2411) #endif
  2412) #if 1
  2413)   ! Source/sink terms -------------------------------------
  2414)   source_sink => patch%source_sink_list%first 
  2415)   do 
  2416)     if (.not.associated(source_sink)) exit
  2417)     
  2418)     ! check whether enthalpy dof is included
  2419)   !  if (source_sink%flow_condition%num_sub_conditions > 3) then
  2420)       enthalpy_flag = PETSC_TRUE
  2421)    ! else
  2422)    !   enthalpy_flag = PETSC_FALSE
  2423)    ! endif
  2424) 
  2425)     if (associated(source_sink%flow_condition%pressure)) then
  2426)       psrc(:) = source_sink%flow_condition%pressure%dataset%rarray(:)
  2427)     endif
  2428)     tsrc1 = source_sink%flow_condition%temperature%dataset%rarray(1)
  2429)     csrc1 = source_sink%flow_condition%concentration%dataset%rarray(1)
  2430)  !   hsrc1=0.D0
  2431)     if (enthalpy_flag) hsrc1 = source_sink%flow_condition%enthalpy%dataset%rarray(1)
  2432) 
  2433)    ! qsrc1 = qsrc1 / FMWH2O ! [kg/s -> kmol/s; fmw -> g/mol = kg/kmol]
  2434)    ! csrc1 = csrc1 / FMWCO2
  2435) !     msrc(:)= psrc(:)
  2436) !     msrc(1) =  msrc(1) / FMWH2O
  2437) !     msrc(2) =  msrc(2) / FMWCO2
  2438) 
  2439) !clu add
  2440)     select case(source_sink%flow_condition%itype(1))
  2441)       case(MASS_RATE_SS)
  2442)         msrc => source_sink%flow_condition%rate%dataset%rarray
  2443)         nsrcpara= 2
  2444)       case(WELL_SS)
  2445)         msrc => source_sink%flow_condition%well%dataset%rarray
  2446)         nsrcpara = 7 + option%nflowspec 
  2447)       case default
  2448)         print *, 'ims mode does not support source/sink type: ', source_sink%flow_condition%itype(1)
  2449)         stop  
  2450)     end select
  2451)  
  2452)     cur_connection_set => source_sink%connection_set
  2453)  
  2454)     do iconn = 1, cur_connection_set%num_connections      
  2455)       local_id = cur_connection_set%id_dn(iconn)
  2456)       ghosted_id = grid%nL2G(local_id)
  2457) 
  2458)       if (associated(patch%imat)) then
  2459)         if (patch%imat(ghosted_id) <= 0) cycle
  2460)       endif
  2461) !     if (enthalpy_flag) then
  2462) !       r_p(local_id*option%nflowdof) = r_p(local_id*option%nflowdof) - hsrc1 * option%flow_dt   
  2463) !     endif         
  2464)       do nvar =1, option%nflowdof
  2465)         call ImmisSourceSink(msrc,nsrcpara,psrc,tsrc1,hsrc1,auxvars(ghosted_id)%auxvar_elem(nvar),&
  2466)         source_sink%flow_condition%itype(1),Res,ss_flow,enthalpy_flag, option)
  2467)       
  2468)         ResInc(local_id,jh2o,nvar)=  ResInc(local_id,jh2o,nvar) - Res(jh2o)
  2469)         ResInc(local_id,jco2,nvar)=  ResInc(local_id,jco2,nvar) - Res(jco2)
  2470)         if (enthalpy_flag) & 
  2471)            ResInc(local_id,option%nflowdof,nvar)=&
  2472)            ResInc(local_id,option%nflowdof,nvar)- Res(option%nflowdof) 
  2473) 
  2474)       enddo 
  2475)     enddo
  2476)     source_sink => source_sink%next
  2477)   enddo
  2478) #endif
  2479) ! Boundary conditions
  2480) #if 1
  2481)   ! Boundary Flux Terms -----------------------------------
  2482)   boundary_condition => patch%boundary_condition_list%first
  2483)   sum_connection = 0    
  2484)   do 
  2485)     if (.not.associated(boundary_condition)) exit
  2486)     
  2487)     cur_connection_set => boundary_condition%connection_set
  2488)     
  2489)     do iconn = 1, cur_connection_set%num_connections
  2490)       sum_connection = sum_connection + 1
  2491)     
  2492)       local_id = cur_connection_set%id_dn(iconn)
  2493)       ghosted_id = grid%nL2G(local_id)
  2494) 
  2495)       if (associated(patch%imat)) then
  2496)         if (patch%imat(ghosted_id) <= 0) cycle
  2497)       endif
  2498) 
  2499)       if (ghosted_id<=0) then
  2500)         print *, "Wrong boundary node index... STOP!!!"
  2501)         stop
  2502)       endif
  2503) 
  2504)       ithrm_dn = int(ithrm_loc_p(ghosted_id))
  2505)       D_dn = immis_parameter%ckwet(ithrm_dn)
  2506) 
  2507)       ! for now, just assume diagonal tensor
  2508)       perm_dn = perm_xx_loc_p(ghosted_id)*abs(cur_connection_set%dist(1,iconn))+ &
  2509)                 perm_yy_loc_p(ghosted_id)*abs(cur_connection_set%dist(2,iconn))+ &
  2510)                 perm_zz_loc_p(ghosted_id)*abs(cur_connection_set%dist(3,iconn))
  2511)       ! dist(0,iconn) = scalar - magnitude of distance
  2512)       ! gravity = vector(3)
  2513)       ! dist(1:3,iconn) = vector(3) - unit vector
  2514)       distance_gravity = cur_connection_set%dist(0,iconn) * &
  2515)                          dot_product(option%gravity, &
  2516)                                      cur_connection_set%dist(1:3,iconn))
  2517)       icap_dn = int(icap_loc_p(ghosted_id))
  2518) 
  2519) ! Then need fill up increments for BCs
  2520)       delxbc=0.D0;
  2521)       do idof =1, option%nflowdof
  2522)         select case(boundary_condition%flow_condition%itype(idof))
  2523)         case(DIRICHLET_BC)
  2524)           xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
  2525)           delxbc(idof) = 0.D0
  2526)         case(HYDROSTATIC_BC,SEEPAGE_BC)
  2527)           xxbc(MPH_PRESSURE_DOF) = boundary_condition%flow_aux_real_var(MPH_PRESSURE_DOF,iconn)
  2528)           if (idof >= MPH_TEMPERATURE_DOF) then
  2529)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2530)             delxbc(idof) = patch%aux%Immis%delx(idof,ghosted_id)
  2531)           endif
  2532)         case(NEUMANN_BC, ZERO_GRADIENT_BC)
  2533)           ! solve for pb from Darcy's law given qb /= 0
  2534)           xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  2535)           delxbc(idof) = patch%aux%Immis%delx(idof,ghosted_id)
  2536)         end select
  2537)       enddo
  2538)     !print *,'BC:',boundary_condition%flow_condition%itype, xxbc, delxbc
  2539) 
  2540)  
  2541)       call ImmisAuxVarCompute_Ninc(xxbc,auxvars_bc(sum_connection)%auxvar_elem(0),&
  2542)          patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr,&
  2543)          realization%fluid_properties, option)
  2544)       call ImmisAuxVarCompute_Winc(xxbc,delxbc,&
  2545)          auxvars_bc(sum_connection)%auxvar_elem(1:option%nflowdof),&
  2546)          patch%saturation_function_array(int(icap_loc_p(ghosted_id)))%ptr,&
  2547)          realization%fluid_properties,option)
  2548)     
  2549)       do nvar=1,option%nflowdof
  2550)         call ImmisBCFlux(boundary_condition%flow_condition%itype, &
  2551)           boundary_condition%flow_aux_real_var(:,iconn), &
  2552)           auxvars_bc(sum_connection)%auxvar_elem(nvar), &
  2553)           auxvars(ghosted_id)%auxvar_elem(nvar), &
  2554)           porosity_loc_p(ghosted_id), &
  2555)           tortuosity_loc_p(ghosted_id), &
  2556)           immis_parameter%sir(:,icap_dn), &
  2557)           cur_connection_set%dist(0,iconn),perm_dn,D_dn, &
  2558)           cur_connection_set%area(iconn), &
  2559)           distance_gravity,option, &
  2560)           vv_darcy,Res)
  2561)         ResInc(local_id,1:option%nflowdof,nvar) = ResInc(local_id,1:option%nflowdof,nvar) - Res(1:option%nflowdof)
  2562)       enddo
  2563)     enddo
  2564)     boundary_condition => boundary_condition%next
  2565)    enddo
  2566) #endif
  2567) ! Set matrix values related to single node terms: Accumulation, Source/Sink, BC
  2568)   do local_id = 1, grid%nlmax  ! For each local node do...
  2569)     ghosted_id = grid%nL2G(local_id)
  2570)     !geh - Ignore inactive cells with inactive materials
  2571)     if (associated(patch%imat)) then
  2572)       if (patch%imat(ghosted_id) <= 0) cycle
  2573)     endif
  2574) 
  2575)     ra=0.D0
  2576)     max_dev=0.D0
  2577)     do neq=1, option%nflowdof
  2578)       do nvar=1, option%nflowdof
  2579)         ra(neq,nvar)=(ResInc(local_id,neq,nvar)-patch%aux%Immis%res_old_AR(local_id,neq))/patch%aux%Immis%delx(nvar,ghosted_id)
  2580)         if (max_dev < dabs(ra(3,nvar))) max_dev = dabs(ra(3,nvar))
  2581)       enddo
  2582)     enddo
  2583)    
  2584)     select case(option%idt_switch)
  2585)       case(1) 
  2586)         ra(1:option%nflowdof,1:option%nflowdof) =ra(1:option%nflowdof,1:option%nflowdof) /option%flow_dt
  2587)       case(-1)
  2588)         if (option%flow_dt>1) ra(1:option%nflowdof,1:option%nflowdof) =ra(1:option%nflowdof,1:option%nflowdof) /option%flow_dt
  2589)     end select
  2590) 
  2591)     Jup=ra(1:option%nflowdof,1:option%nflowdof)
  2592)     if (volume_p(local_id)>1.D0 ) Jup=Jup / volume_p(local_id)
  2593)    
  2594)      ! if (n==1) print *,  blkmat11, volume_p(n), ra
  2595)     call MatSetValuesBlockedLocal(A,1,ghosted_id-1,1,ghosted_id-1,Jup,ADD_VALUES, &
  2596)                                   ierr);CHKERRQ(ierr)
  2597)   end do
  2598) 
  2599)   if (realization%debug%matview_Jacobian_detailed) then
  2600)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2601)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2602)     string = 'jacobian_srcsink'
  2603)     call DebugCreateViewer(realization%debug,string,option,viewer)
  2604)     call MatView(A,PETSC_VIEWER_STDOUT_WORLD,ierr);CHKERRQ(ierr)
  2605)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  2606)   endif
  2607) #if 1
  2608)   ! Interior Flux Terms -----------------------------------  
  2609)   connection_set_list => grid%internal_connection_set_list
  2610)   cur_connection_set => connection_set_list%first
  2611)   sum_connection = 0    
  2612)   ResInc = 0.D0
  2613)   do 
  2614)     if (.not.associated(cur_connection_set)) exit
  2615)     do iconn = 1, cur_connection_set%num_connections
  2616)       sum_connection = sum_connection + 1
  2617)     
  2618)       ghosted_id_up = cur_connection_set%id_up(iconn)
  2619)       ghosted_id_dn = cur_connection_set%id_dn(iconn)
  2620) 
  2621)       if (associated(patch%imat)) then
  2622)         if (patch%imat(ghosted_id_up) <= 0 .or. &
  2623)             patch%imat(ghosted_id_dn) <= 0) cycle
  2624)       endif
  2625) 
  2626)       local_id_up = grid%nG2L(ghosted_id_up) ! = zero for ghost nodes
  2627)       local_id_dn = grid%nG2L(ghosted_id_dn) ! Ghost to local mapping   
  2628)      ! natural_id_up = grid%nG2N(ghosted_id_up)
  2629)      ! natural_id_dn = grid%nG2N(ghosted_id_dn)
  2630)    
  2631)       fraction_upwind = cur_connection_set%dist(-1,iconn)
  2632)       distance = cur_connection_set%dist(0,iconn)
  2633)       ! distance = scalar - magnitude of distance
  2634)       ! gravity = vector(3)
  2635)       ! dist(1:3,iconn) = vector(3) - unit vector
  2636)       distance_gravity = distance * &
  2637)                          dot_product(option%gravity, &
  2638)                                      cur_connection_set%dist(1:3,iconn))
  2639)       dd_up = distance*fraction_upwind
  2640)       dd_dn = distance-dd_up ! should avoid truncation error
  2641)       ! upweight could be calculated as 1.d0-fraction_upwind
  2642)       ! however, this introduces ever so slight error causing pflow-overhaul not
  2643)       ! to match pflow-orig.  This can be changed to 1.d0-fraction_upwind
  2644)       upweight = dd_dn/(dd_up+dd_dn)
  2645)     
  2646)       ! for now, just assume diagonal tensor
  2647)       perm_up = perm_xx_loc_p(ghosted_id_up)*abs(cur_connection_set%dist(1,iconn))+ &
  2648)                 perm_yy_loc_p(ghosted_id_up)*abs(cur_connection_set%dist(2,iconn))+ &
  2649)                 perm_zz_loc_p(ghosted_id_up)*abs(cur_connection_set%dist(3,iconn))
  2650) 
  2651)       perm_dn = perm_xx_loc_p(ghosted_id_dn)*abs(cur_connection_set%dist(1,iconn))+ &
  2652)                 perm_yy_loc_p(ghosted_id_dn)*abs(cur_connection_set%dist(2,iconn))+ &
  2653)                 perm_zz_loc_p(ghosted_id_dn)*abs(cur_connection_set%dist(3,iconn))
  2654)     
  2655)       ithrm_up = int(ithrm_loc_p(ghosted_id_up))
  2656)       ithrm_dn = int(ithrm_loc_p(ghosted_id_dn))
  2657)       D_up = immis_parameter%ckwet(ithrm_up)
  2658)       D_dn = immis_parameter%ckwet(ithrm_dn)
  2659)     
  2660)       icap_up = int(icap_loc_p(ghosted_id_up))
  2661)       icap_dn = int(icap_loc_p(ghosted_id_dn))
  2662)       
  2663)       do nvar = 1, option%nflowdof 
  2664)          call ImmisFlux(auxvars(ghosted_id_up)%auxvar_elem(nvar),porosity_loc_p(ghosted_id_up), &
  2665)                           tortuosity_loc_p(ghosted_id_up),immis_parameter%sir(:,icap_up), &
  2666)                           dd_up,perm_up,D_up, &
  2667)                           auxvars(ghosted_id_dn)%auxvar_elem(0),porosity_loc_p(ghosted_id_dn), &
  2668)                           tortuosity_loc_p(ghosted_id_dn),immis_parameter%sir(:,icap_dn), &
  2669)                           dd_dn,perm_dn,D_dn, &
  2670)                           cur_connection_set%area(iconn),distance_gravity, &
  2671)                           upweight, option, vv_darcy, Res)
  2672)             ra(:,nvar)= (Res(:)-patch%aux%Immis%res_old_FL(iconn,:))/patch%aux%Immis%delx(nvar,ghosted_id_up)
  2673) 
  2674)          call ImmisFlux(auxvars(ghosted_id_up)%auxvar_elem(0),porosity_loc_p(ghosted_id_up), &
  2675)                           tortuosity_loc_p(ghosted_id_up),immis_parameter%sir(:,icap_up), &
  2676)                           dd_up,perm_up,D_up, &
  2677)                           auxvars(ghosted_id_dn)%auxvar_elem(nvar),porosity_loc_p(ghosted_id_dn),&
  2678)                           tortuosity_loc_p(ghosted_id_dn),immis_parameter%sir(:,icap_dn), &
  2679)                           dd_dn,perm_dn,D_dn, &
  2680)                           cur_connection_set%area(iconn),distance_gravity, &
  2681)                           upweight, option, vv_darcy, Res)
  2682)          ra(:,nvar+option%nflowdof)= (Res(:)-patch%aux%Immis%res_old_FL(iconn,:))/patch%aux%Immis%delx(nvar,ghosted_id_dn)
  2683)     enddo
  2684) 
  2685)     select case(option%idt_switch)
  2686)     case(1)
  2687)        ra =ra / option%flow_dt
  2688)     case(-1)  
  2689)        if (option%flow_dt>1)  ra =ra / option%flow_dt
  2690)     end select
  2691)     
  2692)     if (local_id_up > 0) then
  2693)        voltemp=1.D0
  2694)        if (volume_p(local_id_up)>1.D0)then
  2695)          voltemp = 1.D0/volume_p(local_id_up)
  2696)        endif
  2697)        Jup(:,1:option%nflowdof)= ra(:,1:option%nflowdof)*voltemp !11
  2698)        jdn(:,1:option%nflowdof)= ra(:, 1 + option%nflowdof:2 * option%nflowdof)*voltemp !12
  2699) 
  2700)        call MatSetValuesBlockedLocal(A,1,ghosted_id_up-1,1,ghosted_id_up-1, &
  2701)             Jup,ADD_VALUES,ierr);CHKERRQ(ierr)
  2702)        call MatSetValuesBlockedLocal(A,1,ghosted_id_up-1,1,ghosted_id_dn-1, &
  2703)             Jdn,ADD_VALUES,ierr);CHKERRQ(ierr)
  2704)     endif
  2705)     if (local_id_dn > 0) then
  2706)        voltemp=1.D0
  2707)        if (volume_p(local_id_dn)>1.D0)then
  2708)          voltemp=1.D0/volume_p(local_id_dn)
  2709)        endif
  2710)        Jup(:,1:option%nflowdof)= -ra(:,1:option%nflowdof)*voltemp !21
  2711)        jdn(:,1:option%nflowdof)= -ra(:, 1 + option%nflowdof:2 * option%nflowdof)*voltemp !22
  2712) 
  2713)  
  2714)        call MatSetValuesBlockedLocal(A,1,ghosted_id_dn-1,1,ghosted_id_dn-1, &
  2715)             Jdn,ADD_VALUES,ierr);CHKERRQ(ierr)
  2716)        call MatSetValuesBlockedLocal(A,1,ghosted_id_dn-1,1,ghosted_id_up-1, &
  2717)             Jup,ADD_VALUES,ierr);CHKERRQ(ierr)
  2718)     endif
  2719)  enddo
  2720)     cur_connection_set => cur_connection_set%next
  2721)   enddo
  2722) #endif
  2723)   if (realization%debug%matview_Jacobian_detailed) then
  2724)  ! print *,'end inter flux'
  2725)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2726)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2727)     string = 'jacobian_flux'
  2728)     call DebugCreateViewer(realization%debug,string,option,viewer)
  2729)     call MatView(A,PETSC_VIEWER_STDOUT_WORLD,ierr);CHKERRQ(ierr)
  2730)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  2731)   endif
  2732) #if 0
  2733)   if (realization%debug%matview_Jacobian_detailed) then
  2734)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2735)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2736)     call PetscViewerASCIIOpen(option%mycomm,'jacobian_bcflux.out',viewer, &
  2737)                               ierr);CHKERRQ(ierr)
  2738)     call MatView(A,viewer,ierr);CHKERRQ(ierr)
  2739)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  2740)   endif
  2741) #endif
  2742)   
  2743)   call VecRestoreArrayF90(field%flow_xx_loc, xx_loc_p, ierr);CHKERRQ(ierr)
  2744) !geh refactor  call VecRestoreArrayF90(field%porosity_loc, porosity_loc_p, ierr)
  2745) !geh refactor  call VecRestoreArrayF90(field%tortuosity_loc, tortuosity_loc_p, ierr)
  2746) !geh refactor  call VecRestoreArrayF90(field%perm_xx_loc, perm_xx_loc_p, ierr)
  2747) !geh refactor  call VecRestoreArrayF90(field%perm_yy_loc, perm_yy_loc_p, ierr)
  2748) !geh refactor  call VecRestoreArrayF90(field%perm_zz_loc, perm_zz_loc_p, ierr)
  2749) !geh refactor  call VecRestoreArrayF90(field%volume, volume_p, ierr)
  2750) 
  2751)    
  2752)   call VecRestoreArrayF90(field%ithrm_loc, ithrm_loc_p, ierr);CHKERRQ(ierr)
  2753)   call VecRestoreArrayF90(field%icap_loc, icap_loc_p, ierr);CHKERRQ(ierr)
  2754) ! print *,'end jac'
  2755)   call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2756)   call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2757)  ! call MatView(A,PETSC_VIEWER_STDOUT_WORLD,ierr)
  2758) #if 0
  2759) ! zero out isothermal and inactive cells
  2760) #ifdef ISOTHERMAL
  2761)   zero = 0.d0
  2762)   call MatZeroRowsLocal(A,n_zero_rows,zero_rows_local_ghosted,zero, &
  2763)                         PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
  2764)                         ierr);CHKERRQ(ierr)
  2765)   do i=1, n_zero_rows
  2766)     ii = mod(zero_rows_local(i),option%nflowdof)
  2767)     ip1 = zero_rows_local_ghosted(i)
  2768)     if (ii == 0) then
  2769)       ip2 = ip1-1
  2770)     elseif (ii == option%nflowdof-1) then
  2771)       ip2 = ip1+1
  2772)     else
  2773)       ip2 = ip1
  2774)     endif
  2775)     call MatSetValuesLocal(A,1,ip1,1,ip2,1.d0,INSERT_VALUES, &
  2776)                            ierr);CHKERRQ(ierr)
  2777)   enddo
  2778) 
  2779)   call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2780)   call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  2781) #else
  2782) #endif
  2783) #endif
  2784) 
  2785)   if (patch%aux%Immis%inactive_cells_exist) then
  2786)     f_up = 1.d0
  2787)     call MatZeroRowsLocal(A,patch%aux%Immis%n_zero_rows, &
  2788)                           patch%aux%Immis%zero_rows_local_ghosted,f_up, &
  2789)                           PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
  2790)                           ierr);CHKERRQ(ierr)
  2791)   endif
  2792) 
  2793)   if (realization%debug%matview_Jacobian) then
  2794)     string = 'Ijacobian'
  2795)     call DebugCreateViewer(realization%debug,string,option,viewer)
  2796)     call MatView(A,viewer,ierr);CHKERRQ(ierr)
  2797)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  2798)   endif
  2799)   if (realization%debug%norm_Jacobian) then
  2800)     call MatNorm(A,NORM_1,norm,ierr);CHKERRQ(ierr)
  2801)     write(option%io_buffer,'("1 norm: ",es11.4)') norm
  2802)     call printMsg(option)
  2803)     call MatNorm(A,NORM_FROBENIUS,norm,ierr);CHKERRQ(ierr)
  2804)     write(option%io_buffer,'("2 norm: ",es11.4)') norm
  2805)     call printMsg(option)
  2806)     call MatNorm(A,NORM_INFINITY,norm,ierr);CHKERRQ(ierr)
  2807)     write(option%io_buffer,'("inf norm: ",es11.4)') norm
  2808)     call printMsg(option)
  2809) !    call GridCreateVector(grid,ONEDOF,debug_vec,GLOBAL)
  2810) !    call MatGetRowMaxAbs(A,debug_vec,PETSC_NULL_INTEGER,ierr)
  2811) !    call VecMax(debug_vec,i,norm,ierr)
  2812) !    call VecDestroy(debug_vec,ierr)
  2813)   endif
  2814) end subroutine ImmisJacobianPatch
  2815) 
  2816) ! ************************************************************************** !
  2817) 
  2818) subroutine ImmisMaxChange(realization,dpmax,dtmpmax,dsmax)
  2819)   ! 
  2820)   ! Computes the maximum change in the solution vector
  2821)   ! 
  2822)   ! Author: Chuan Lu
  2823)   ! Date: 01/15/08
  2824)   ! 
  2825) 
  2826)   use Realization_Subsurface_class
  2827)   use Field_module
  2828)   use Option_module
  2829)   use Field_module
  2830) 
  2831)   implicit none
  2832)   
  2833)   type(realization_subsurface_type) :: realization
  2834) 
  2835)   type(option_type), pointer :: option
  2836)   type(field_type), pointer :: field
  2837)   PetscReal :: dpmax, dtmpmax, dsmax
  2838)   PetscErrorCode :: ierr 
  2839) 
  2840)   option => realization%option
  2841)   field => realization%field
  2842) 
  2843)   dpmax=0.D0
  2844)   dtmpmax=0.D0 
  2845)   dsmax=0.D0
  2846) 
  2847)   call VecWAXPY(field%flow_dxx,-1.d0,field%flow_xx,field%flow_yy, &
  2848)                 ierr);CHKERRQ(ierr)
  2849)   call VecStrideNorm(field%flow_dxx,ZERO_INTEGER,NORM_INFINITY,dpmax, &
  2850)                      ierr);CHKERRQ(ierr)
  2851)   call VecStrideNorm(field%flow_dxx,ONE_INTEGER,NORM_INFINITY,dtmpmax, &
  2852)                      ierr);CHKERRQ(ierr)
  2853)   call VecStrideNorm(field%flow_dxx,TWO_INTEGER,NORM_INFINITY,dsmax, &
  2854)                      ierr);CHKERRQ(ierr)
  2855) 
  2856)   !print *, 'Max changes=', option%dpmax,option%dtmpmax, option%dcmax,option%dsmax
  2857) end subroutine ImmisMaxChange
  2858) 
  2859) ! ************************************************************************** !
  2860) 
  2861) function ImmisGetTecplotHeader(realization, icolumn)
  2862)   ! 
  2863)   ! Returns Richards contribution to
  2864)   ! Tecplot file header
  2865)   ! 
  2866)   ! Author: Chuan Lu
  2867)   ! Date: 10/13/08
  2868)   ! 
  2869) 
  2870)   use Realization_Subsurface_class
  2871)   use Option_module
  2872)   use Field_module
  2873) 
  2874)   implicit none
  2875)   
  2876)   character(len=MAXSTRINGLENGTH) :: ImmisGetTecplotHeader
  2877)   type(realization_subsurface_type) :: realization
  2878)   PetscInt :: icolumn
  2879)   
  2880)   character(len=MAXSTRINGLENGTH) :: string, string2
  2881)   type(option_type), pointer :: option
  2882)   type(field_type), pointer :: field  
  2883)   PetscInt :: i
  2884)   
  2885)   option => realization%option
  2886)   field => realization%field
  2887)   
  2888)   string = ''
  2889) 
  2890)   if (icolumn > -1) then
  2891)     icolumn = icolumn + 1
  2892)     write(string2,'('',"'',i2,''-T [C]"'')') icolumn
  2893)   else
  2894)     write(string2,'('',"T [C]"'')')
  2895)   endif
  2896)   string = trim(string) // trim(string2)
  2897)   
  2898)   if (icolumn > -1) then
  2899)     icolumn = icolumn + 1
  2900)     write(string2,'('',"'',i2,''-P [Pa]"'')') icolumn
  2901)   else
  2902)     write(string2,'('',"P [Pa]"'')')
  2903)   endif
  2904)   string = trim(string) // trim(string2)
  2905)   
  2906) ! if (icolumn > -1) then
  2907) !   icolumn = icolumn + 1
  2908) !   write(string2,'('',"'',i2,''-PHASE"'')') icolumn
  2909) ! else
  2910) !   write(string2,'('',"PHASE"'')')
  2911) ! endif
  2912) ! string = trim(string) // trim(string2)
  2913)   
  2914)   if (icolumn > -1) then
  2915)     icolumn = icolumn + 1
  2916)     write(string2,'('',"'',i2,''-S(l)"'')') icolumn
  2917)   else
  2918)     write(string2,'('',"S(l)"'')')
  2919)   endif
  2920)   string = trim(string) // trim(string2)
  2921) 
  2922)   if (icolumn > -1) then
  2923)     icolumn = icolumn + 1
  2924)     write(string2,'('',"'',i2,''-S(g)"'')') icolumn
  2925)   else
  2926)     write(string2,'('',"S(g)"'')')
  2927)   endif
  2928)   string = trim(string) // trim(string2)
  2929)     
  2930)   if (icolumn > -1) then
  2931)     icolumn = icolumn + 1
  2932)     write(string2,'('',"'',i2,''-D(l)"'')') icolumn
  2933)   else
  2934)     write(string2,'('',"D(l)"'')')
  2935)   endif
  2936)   string = trim(string) // trim(string2)
  2937) 
  2938)   if (icolumn > -1) then
  2939)     icolumn = icolumn + 1
  2940)     write(string2,'('',"'',i2,''-D(g)"'')') icolumn
  2941)   else
  2942)     write(string2,'('',"D(g)"'')')
  2943)   endif
  2944)   string = trim(string) // trim(string2)
  2945)     
  2946)   if (icolumn > -1) then
  2947)     icolumn = icolumn + 1
  2948)     write(string2,'('',"'',i2,''-U(l)"'')') icolumn
  2949)   else
  2950)     write(string2,'('',"U(l)"'')')
  2951)   endif
  2952)   string = trim(string) // trim(string2)
  2953) 
  2954)   if (icolumn > -1) then
  2955)     icolumn = icolumn + 1
  2956)     write(string2,'('',"'',i2,''-U(g)"'')') icolumn
  2957)   else
  2958)     write(string2,'('',"U(g)"'')')
  2959)   endif
  2960)   string = trim(string) // trim(string2)
  2961)     
  2962)   if (icolumn > -1) then
  2963)     icolumn = icolumn + 1
  2964)     write(string2,'('',"'',i2,''-Vis(l)"'')') icolumn
  2965)   else
  2966)     write(string2,'('',"Vis(l)"'')')
  2967)   endif
  2968)   string = trim(string) // trim(string2)
  2969) 
  2970)   if (icolumn > -1) then
  2971)     icolumn = icolumn + 1
  2972)     write(string2,'('',"'',i2,''-Vis(g)"'')') icolumn
  2973)   else
  2974)     write(string2,'('',"Vis(g)"'')')
  2975)   endif
  2976)   string = trim(string) // trim(string2)
  2977)     
  2978)   if (icolumn > -1) then
  2979)     icolumn = icolumn + 1
  2980)     write(string2,'('',"'',i2,''-Mob(l)"'')') icolumn
  2981)   else
  2982)     write(string2,'('',"Mob(l)"'')')
  2983)   endif
  2984)   string = trim(string) // trim(string2)
  2985) 
  2986)   if (icolumn > -1) then
  2987)     icolumn = icolumn + 1
  2988)     write(string2,'('',"'',i2,''-Mob(g)"'')') icolumn
  2989)   else
  2990)     write(string2,'('',"Mob(g)"'')')
  2991)   endif
  2992)   string = trim(string) // trim(string2)
  2993)   
  2994)   if (icolumn > -1) then
  2995)     icolumn = icolumn + 1
  2996)     write(string2,'('',"'',i2,''-PHASE"'')') icolumn
  2997)   else
  2998)     write(string2,'('',"PHASE"'')')
  2999)   endif
  3000)   string = trim(string) // trim(string2)
  3001) 
  3002)   ImmisGetTecplotHeader = string
  3003) 
  3004) end function ImmisGetTecplotHeader
  3005) 
  3006) ! ************************************************************************** !
  3007) 
  3008) subroutine ImmisSetPlotVariables(list)
  3009)   ! 
  3010)   ! Adds variables to be printed to list
  3011)   ! 
  3012)   ! Author: Glenn Hammond
  3013)   ! Date: 10/15/12
  3014)   ! 
  3015)   
  3016)   use Output_Aux_module
  3017)   use Variables_module
  3018) 
  3019)   implicit none
  3020) 
  3021)   type(output_variable_list_type), pointer :: list
  3022) 
  3023)   type(output_variable_type) :: output_variable
  3024)   character(len=MAXWORDLENGTH) :: name, units
  3025)   
  3026)   if (associated(list%first)) then
  3027)     return
  3028)   endif
  3029) 
  3030)   name = 'Temperature'
  3031)   units = 'C'
  3032)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3033)                                TEMPERATURE)
  3034)   
  3035)   name = 'Liquid Pressure'
  3036)   units = 'Pa'
  3037)   call OutputVariableAddToList(list,name,OUTPUT_PRESSURE,units, &
  3038)                                LIQUID_PRESSURE)
  3039) 
  3040)   name = 'Gas Pressure'
  3041)   units = 'Pa'
  3042)   call OutputVariableAddToList(list,name,OUTPUT_PRESSURE,units, &
  3043)                                GAS_PRESSURE)
  3044) 
  3045)   name = 'Liquid Saturation'
  3046)   units = ''
  3047)   call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
  3048)                                LIQUID_SATURATION)
  3049) 
  3050)   name = 'Gas Saturation'
  3051)   units = ''
  3052)   call OutputVariableAddToList(list,name,OUTPUT_SATURATION,units, &
  3053)                                GAS_SATURATION)
  3054) 
  3055)   name = 'Liquid Density'
  3056)   units = 'kg/m^3'
  3057)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3058)                                LIQUID_DENSITY)
  3059) 
  3060)   name = 'Gas Density'
  3061)   units = 'kg/m^3'
  3062)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3063)                                GAS_DENSITY)
  3064) 
  3065)   name = 'Liquid Energy'
  3066)   units = 'kJ/mol'
  3067)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3068)                                LIQUID_ENERGY)
  3069) 
  3070)   name = 'Gas Energy'
  3071)   units = 'kJ/mol'
  3072)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3073)                                GAS_ENERGY)
  3074) 
  3075)   name = 'Liquid Viscosity'
  3076)   units = 'Pa.s'
  3077)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3078)                                LIQUID_VISCOSITY)
  3079) 
  3080)   name = 'Gas Viscosity'
  3081)   units = 'Pa.s'
  3082)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3083)                                GAS_VISCOSITY)
  3084) 
  3085)   name = 'Liquid Mobility'
  3086)   units = '1/Pa.s'
  3087)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3088)                                LIQUID_MOBILITY)
  3089) 
  3090)   name = 'Gas Mobility'
  3091)   units = '1/Pa.s'
  3092)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3093)                                GAS_MOBILITY)
  3094) 
  3095) ! name = 'Phase'
  3096) ! units = ''
  3097) ! output_variable%iformat = 1 ! integer
  3098) ! call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
  3099) !                              PHASE)
  3100) 
  3101) end subroutine ImmisSetPlotVariables
  3102) 
  3103) ! ************************************************************************** !
  3104) 
  3105) subroutine ImmisDestroy(realization)
  3106)   ! 
  3107)   ! Deallocates variables associated with Immis
  3108)   ! 
  3109)   ! Author: Chuan Lu
  3110)   ! Date: 10/14/08
  3111)   ! 
  3112) 
  3113)   use Realization_Subsurface_class
  3114) 
  3115)   implicit none
  3116)   
  3117)   type(realization_subsurface_type) :: realization
  3118)   
  3119)   ! need to free array in aux vars
  3120)   !call ImmisAuxDestroy(patch%aux%Immis)
  3121) 
  3122) end subroutine ImmisDestroy
  3123) 
  3124) 
  3125) #if 0
  3126) 
  3127) ! ************************************************************************** !
  3128) 
  3129) subroutine ImmisCheckpointWrite(discretization, viewer)
  3130)   ! 
  3131)   ! Writes vecs to checkpoint file
  3132)   ! Author: Chuan Lu
  3133)   ! 
  3134) 
  3135)   use Discretization_module
  3136) 
  3137)   implicit none
  3138)   
  3139)   type(discretization_type) :: discretization
  3140)   PetscViewer :: viewer
  3141)   
  3142)   Vec :: global_var
  3143)   PetscErrorCode :: ierr
  3144)   
  3145)   call VecView(global_var,viewer,ierr);CHKERRQ(ierr)
  3146)   call VecDestroy(global_var,ierr);CHKERRQ(ierr)
  3147)   
  3148)   
  3149) end subroutine ImmisCheckpointWrite
  3150) 
  3151) ! ************************************************************************** !
  3152) 
  3153) subroutine ImmisCheckpointRead(discretization,viewer)
  3154)   ! 
  3155)   ! Reads vecs from checkpoint file
  3156)   ! Author: Chuan Lu
  3157)   ! 
  3158) 
  3159)   use Discretization_module
  3160) 
  3161)   implicit none
  3162)   
  3163)   type(discretization_type) :: discretization
  3164)   PetscViewer :: viewer
  3165)   
  3166)   Vec :: global_var
  3167)   PetscErrorCode :: ierr
  3168)   
  3169)   call VecLoad(global_var, viewer, ierr);CHKERRQ(ierr)
  3170)   call VecDestroy(global_var,ierr);CHKERRQ(ierr)
  3171)   
  3172) end subroutine ImmisCheckpointRead
  3173) 
  3174) #endif
  3175) 
  3176) end module Immis_module

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