secondary_continuum.F90       coverage:  68.75 %func     63.08 %block


     1) ! added by S. Karra 07/11/12
     2) 
     3) module Secondary_Continuum_module
     4)   
     5)   use Secondary_Continuum_Aux_module
     6) 
     7)   use PFLOTRAN_Constants_module
     8) 
     9)   implicit none
    10) 
    11)   private
    12) 
    13) #include "petsc/finclude/petscsys.h"
    14)   
    15) #include "petsc/finclude/petscvec.h"
    16) #include "petsc/finclude/petscvec.h90"
    17) #include "petsc/finclude/petscmat.h"
    18) #include "petsc/finclude/petscmat.h90"
    19) #include "petsc/finclude/petscsnes.h"
    20) #include "petsc/finclude/petscviewer.h"
    21) #include "petsc/finclude/petsclog.h"
    22) 
    23)   ! secondary continuum cell type
    24)   PetscInt, parameter, public :: SLAB = 0
    25)   PetscInt, parameter, public :: NESTED_CUBE = 1
    26)   PetscInt, parameter, public :: NESTED_SPHERE = 2
    27) 
    28)   PetscReal, parameter :: perturbation_tolerance = 1.d-5
    29) 
    30)   public :: SecondaryContinuumType, &
    31)             SecondaryContinuumSetProperties, &
    32)             SecondaryRTAuxVarInit, &
    33)             SecondaryRTResJacMulti, &
    34)             SecondaryRTAuxVarComputeMulti, &
    35)             THCSecHeatAuxVarCompute, &
    36)             THSecHeatAuxVarCompute, &
    37)             MphaseSecHeatAuxVarCompute, &
    38)             SecondaryRTUpdateIterate, &
    39)             SecondaryRTUpdateEquilState, &
    40)             SecondaryRTUpdateKineticState, &
    41)             SecondaryRTTimeCut
    42) 
    43) contains
    44) 
    45) ! ************************************************************************** !
    46) 
    47) subroutine SecondaryContinuumType(sec_continuum,nmat,aream, &
    48)             volm,dm1,dm2,aperture,epsilon,log_spacing,outer_spacing, &
    49)             interfacial_area,option)
    50)   ! 
    51)   ! The area, volume, grid sizes for secondary continuum
    52)   ! are calculated based on the input dimensions and geometry
    53)   ! 
    54)   ! Author: Satish Karra, LANL
    55)   ! Date: 07/11/12
    56)   ! 
    57) 
    58)   use Option_module
    59) 
    60)   implicit none
    61)   
    62)   type(sec_continuum_type) :: sec_continuum
    63) 
    64)   type(option_type) :: option
    65) 
    66)   character(len=MAXSTRINGLENGTH) :: string
    67) 
    68)   PetscInt :: igeom, nmat, m
    69)   PetscReal :: aream(nmat), volm(nmat), dm1(nmat), dm2(nmat)
    70)   PetscReal :: dy, r0, r1, aream0, am0, vm0, interfacial_area
    71)   PetscReal :: num_density, aperture, epsilon, fracture_spacing
    72)   PetscReal :: outer_spacing, matrix_block_size
    73)   PetscReal :: grid_spacing(nmat)
    74)   PetscBool :: log_spacing
    75)   PetscReal :: sum
    76) 
    77)   PetscInt, save :: icall
    78) 
    79)   data icall/0/
    80) 
    81)   igeom = sec_continuum%itype
    82)   option%nsec_cells = nmat
    83)     
    84)   select case (igeom)      
    85)     case(SLAB)
    86)     
    87)       dy = sec_continuum%slab%length/nmat
    88)       aream0 = sec_continuum%slab%area
    89)       do m = 1, nmat
    90)         volm(m) = dy*aream0
    91)       enddo
    92)       am0 = aream0
    93)       vm0 = nmat*dy*aream0
    94)       interfacial_area = am0/vm0
    95)      
    96)       do m = 1, nmat
    97)         aream(m) = aream0
    98)         dm1(m) = 0.5d0*dy
    99)         dm2(m) = 0.5d0*dy
   100)       enddo
   101) 
   102)       if (icall == 0 .and. OptionPrintToFile(option)) then
   103)         icall = 1
   104)         string = 'DCDM Multiple Continuum Model'
   105)         write(option%fid_out,'(/,2x,a,/)') trim(string)
   106)         string = 'Slab'
   107)         write(option%fid_out,'(2x,a,/)') trim(string)
   108)         num_density = (1.d0-epsilon)/vm0
   109)         write(option%fid_out,'(2x,"number density: ",11x,1pe12.4," m^(-3)")') num_density
   110)         write(option%fid_out,'(2x,"matrix block size: ",8x,1pe12.4," m")') sec_continuum%slab%length
   111)         write(option%fid_out,'(2x,"epsilon: ",18x,1pe12.4)') epsilon
   112)         write(option%fid_out,'(2x,"specific interfacial area: ",1pe12.4," m^(-1)")') interfacial_area
   113)         do m = 1, nmat
   114)           if (m == 1) write(option%fid_out,'(/,2x,"node matrix volume fraction")') 
   115)           write(option%fid_out,'(2x,i3,3x,1pe12.4)') m,volm(m)/vm0 !*(1.d0 - epsilon)
   116)         enddo
   117) !       aperture = r0*(1.d0/(1.d0-epsilon)**(1.d0/3.d0)-1.d0)
   118) !       write(option%fid_out,'(2x,"aperture: ",17x,1pe12.4," m")') aperture
   119)       endif
   120)       
   121)       ! Store the distances
   122)       sec_continuum%distance(1) = dm1(1)
   123)       do m = 2, nmat
   124)         sec_continuum%distance(m) = sec_continuum%distance(m-1) + &
   125)                                       dm2(m-1) + dm1(m)
   126)       enddo
   127)           
   128)     case(NESTED_CUBE)
   129) 
   130)       if (sec_continuum%nested_cube%fracture_spacing > 0.d0) then
   131) 
   132)         fracture_spacing = sec_continuum%nested_cube%fracture_spacing
   133) !        override epsilon if aperture defined
   134)         if (aperture > 0.d0) then
   135)           r0 = fracture_spacing - aperture
   136)           epsilon = 1.d0 - (1.d0 + aperture/r0)**(-3.d0)
   137)         else if (epsilon > 0.d0) then
   138)           r0 = fracture_spacing*(1.d0-epsilon)**(1.d0/3.d0)
   139)           aperture = r0*((1.d0-epsilon)**(-1.d0/3.d0)-1.d0)
   140)         endif
   141)                                             
   142)       else if (sec_continuum%nested_cube%matrix_block_size > 0.d0) then
   143) 
   144)         r0 = sec_continuum%nested_cube%matrix_block_size
   145) 
   146) !        override epsilon if aperture defined
   147)         if (aperture > 0.d0) then
   148)           fracture_spacing = r0 + aperture
   149)           epsilon = 1.d0 - (1.d0 + aperture/r0)**(-3.d0)
   150)         else if (epsilon > 0.d0) then
   151)           fracture_spacing = r0*(1.d0-epsilon)**(-1.d0/3.d0)
   152)           aperture = fracture_spacing - r0
   153)         endif
   154)       endif
   155)       
   156)       if (log_spacing) then 
   157)         
   158)         matrix_block_size = r0
   159)         call SecondaryContinuumCalcLogSpacing(matrix_block_size,outer_spacing, &
   160)                                               nmat,grid_spacing,option)
   161)         
   162)         r0 = 2.d0*grid_spacing(1)
   163)         dm1(1) = 0.5d0*grid_spacing(1)
   164)         dm2(1) = 0.5d0*grid_spacing(1)
   165)         volm(1) = r0**3.d0
   166)         aream(1) = 6.d0*r0**2.d0
   167)         do m = 2, nmat
   168)           dm1(m) = 0.5d0*grid_spacing(m)
   169)           dm2(m) = 0.5d0*grid_spacing(m)
   170)           r1 = r0 + 2.d0*(dm1(m) + dm2(m))
   171)           volm(m) = r1**3.d0 - r0**3.d0
   172)           aream(m) = 6.d0*r1**2.d0
   173)           r0 = r1
   174)         enddo
   175)         r0 = matrix_block_size
   176)         am0 = 6.d0*r0**2.d0
   177)         vm0 = r0**3.d0
   178)         interfacial_area = am0/vm0
   179) 
   180)       else
   181)         dy = r0/nmat/2.d0
   182)      
   183)         r0 = 2.d0*dy
   184)         volm(1) = r0**3.d0
   185)         do m = 2, nmat
   186)           r1 = r0 + 2.d0*dy
   187)           volm(m) = r1**3.d0 - r0**3.d0
   188)           r0 = r1
   189)         enddo
   190)       
   191)         r0 = 2.d0*dy
   192)         aream(1) = 6.d0*r0**2.d0
   193)         dm1(1) = 0.5d0*dy
   194)         dm2(1) = 0.5d0*dy
   195)         do m = 2, nmat
   196)           dm1(m) = 0.5d0*dy
   197)           dm2(m) = 0.5d0*dy
   198)           r0 = r0 + 2.d0*dy
   199)           aream(m) = 6.d0*r0**2.d0
   200)         enddo
   201)         r0 = real(2.d0*nmat)*dy
   202)         am0 = 6.d0*r0**2.d0
   203)         vm0 = r0**3.d0
   204)         interfacial_area = am0/vm0
   205)       endif
   206) 
   207)       if (icall == 0 .and. OptionPrintToFile(option)) then
   208)         icall = 1
   209)         string = 'DCDM Multiple Continuum Model'
   210)         write(option%fid_out,'(/,2x,a,/)') trim(string)
   211)         string = 'Nested Cubes'
   212)         write(option%fid_out,'(2x,a,/)') trim(string)
   213)         num_density = (1.d0-epsilon)/vm0
   214)         write(option%fid_out,'(2x,"number density: ",11x,1pe12.4," m^(-3)")') num_density
   215)         write(option%fid_out,'(2x,"matrix block size: ",8x,1pe12.4," m")') r0
   216)         write(option%fid_out,'(2x,"epsilon: ",18x,1pe12.4)') epsilon
   217)         write(option%fid_out,'(2x,"specific interfacial area: ",1pe12.4," m^(-1)")') interfacial_area
   218)         write(option%fid_out,'(2x,"fracture aperture: ",8x,1pe12.4," m")') aperture
   219)         write(option%fid_out,'(2x,"fracture spacing: ",9x,1pe12.4," m")') fracture_spacing
   220)         write(option%fid_out,'(/,2x,"node  vol. frac.      dm1         dm2         aream       dy          y")')
   221)         r0 = 0.d0
   222)         do m = 1, nmat
   223)           if (m == 1) then
   224)             r0 = r0 + dm1(m)
   225)           else
   226)             r0 = r0 + dm2(m-1)+dm1(m)
   227)           endif
   228)           write(option%fid_out,'(2x,i3,3x,1p6e12.4)') m,volm(m)/vm0,dm1(m),dm2(m),aream(m), &
   229)           dm1(m)+dm2(m),r0
   230)         enddo
   231)       endif
   232) 
   233)       ! Store the distances
   234)       sec_continuum%distance(1) = dm1(1)
   235)       do m = 2, nmat
   236)         sec_continuum%distance(m) = sec_continuum%distance(m-1) + &
   237)                                       dm2(m-1) + dm1(m)
   238)       enddo     
   239) 
   240)     case(NESTED_SPHERE)
   241)     
   242)       dy = sec_continuum%nested_sphere%radius/nmat
   243)       r0 = dy
   244) 
   245)       volm(1) = 4.d0/3.d0*pi*r0**3.d0
   246)       do m = 2, nmat
   247)         r1 = r0 + dy
   248)         volm(m) = 4.d0/3.d0*pi*(r1**3.d0 - r0**3.d0)
   249)         r0 = r1
   250)       enddo
   251)       
   252)       r0 = dy
   253)       aream(1) = 4.d0*pi*r0**2.d0
   254)       dm1(1) = 0.5d0*dy
   255)       dm2(1) = 0.5d0*dy
   256)       do m = 2, nmat
   257)         r0 = r0 + dy
   258)         dm1(m) = 0.5d0*dy
   259)         dm2(m) = 0.5d0*dy
   260)         aream(m) = 4.d0*pi*r0**2.d0
   261)       enddo
   262)       r0 = 0.5d0*real(2.d0*nmat)*dy
   263)       am0 = 4.d0*pi*r0**2.d0
   264)       vm0 = am0*r0/3.d0
   265)       interfacial_area = am0/vm0
   266) 
   267)       if (icall == 0 .and. OptionPrintToFile(option)) then
   268)         icall = 1
   269)         string = 'DCDM Multiple Continuum Model'
   270)         write(option%fid_out,'(/,2x,a,/)') trim(string)
   271)         string = 'Nested Spheres'
   272)         write(option%fid_out,'(2x,a,/)') trim(string)
   273)         num_density = (1.d0-epsilon)/vm0
   274)         write(option%fid_out,'(2x,"number density: ",11x,1pe12.4," m^(-3)")') num_density
   275)         write(option%fid_out,'(2x,"sphere radius: ",8x,1pe12.4," m")') sec_continuum%nested_sphere%radius
   276)         write(option%fid_out,'(2x,"epsilon: ",18x,1pe12.4)') epsilon
   277)         write(option%fid_out,'(2x,"specific interfacial area: ",1pe12.4," m^(-1)")') interfacial_area
   278)         do m = 1, nmat
   279)           if (m == 1) write(option%fid_out,'(/,2x,"node matrix volume fraction")') 
   280)           write(option%fid_out,'(2x,i3,3x,1pe12.4)') m,volm(m)/vm0*(1.d0 - epsilon)
   281)         enddo
   282) 
   283) !       aperture = r0*(1.d0/(1.d0-epsilon)**(1.d0/3.d0)-1.d0)
   284) !       write(option%fid_out,'(2x,"aperture: ",17x,1pe12.4," m")') aperture
   285)       endif
   286)       
   287)       ! Store the distances
   288)       sec_continuum%distance(1) = dm1(1)
   289)       do m = 2, nmat
   290)         sec_continuum%distance(m) = sec_continuum%distance(m-1) + &
   291)                                       dm2(m-1) + dm1(m)
   292)       enddo
   293)                         
   294)   end select
   295)   
   296)   
   297)   sum = 0.d0
   298)   do m = 1,nmat
   299)     if (volm(m)/vm0 > 1.d0) then
   300)       print *, 'Error: volume fraction for cell', m, 'is greater than 1.'
   301)       stop
   302)     else 
   303)       sum = sum + volm(m)/vm0
   304)     endif
   305)   enddo
   306)   
   307)   if (icall /= 2 .and. OptionPrintToFile(Option)) then
   308)     icall = 2
   309)     write(option%fid_out,'(/,"sum of volume fractions:",1x,1pe12.4)') sum
   310)   endif
   311)   
   312)   if (abs(sum - 1.d0) > 1.d-6) then
   313)     option%io_buffer = 'Error: Sum of the volume fractions of the' // &
   314)                        ' secondary cells is not equal to 1.'
   315)     call printErrMsg(option)
   316)   endif
   317)   
   318) end subroutine SecondaryContinuumType
   319) 
   320) ! ************************************************************************** !
   321) 
   322) subroutine SecondaryContinuumSetProperties(sec_continuum, &
   323)                                            sec_continuum_name, & 
   324)                                            sec_continuum_length, &
   325)                                            sec_continuum_matrix_block_size, &
   326)                                            sec_continuum_fracture_spacing, &
   327)                                            sec_continuum_radius, &
   328)                                            sec_continuum_area, &
   329)                                            option)
   330)   ! 
   331)   ! The type, dimensions of the secondary
   332)   ! continuum are set
   333)   ! 
   334)   ! Author: Satish Karra, LANL
   335)   ! Date: 07/17/12
   336)   ! 
   337)                                     
   338)   use Option_module
   339)   use String_module
   340)   
   341)   implicit none
   342)   
   343)   type(sec_continuum_type) :: sec_continuum
   344)   type(option_type) :: option
   345)   PetscReal :: sec_continuum_matrix_block_size
   346)   PetscReal :: sec_continuum_fracture_spacing
   347)   PetscReal :: sec_continuum_length
   348)   PetscReal :: sec_continuum_area
   349)   PetscReal :: sec_continuum_radius
   350)   character(len=MAXWORDLENGTH) :: sec_continuum_name
   351) 
   352)   call StringToUpper(sec_continuum_name)
   353)   
   354)   select case(trim(sec_continuum_name))
   355)     case("SLAB")
   356)       sec_continuum%itype = SLAB
   357)       sec_continuum%slab%length = sec_continuum_length
   358)       if (sec_continuum_area == 0.d0) then
   359)         option%io_buffer = 'Keyword "AREA" not specified for SLAB type ' // &
   360)                            'under SECONDARY_CONTINUUM'
   361)         call printErrMsg(option)
   362)       endif
   363)       sec_continuum%slab%area = sec_continuum_area
   364)     case("NESTED_CUBES")
   365)       sec_continuum%itype = NESTED_CUBE
   366)       sec_continuum%nested_cube%matrix_block_size = sec_continuum_matrix_block_size
   367)       sec_continuum%nested_cube%fracture_spacing = sec_continuum_fracture_spacing
   368)     case("NESTED_SPHERES")
   369)       sec_continuum%itype = NESTED_SPHERE
   370)       sec_continuum%nested_sphere%radius = sec_continuum_radius
   371)     case default
   372)       option%io_buffer = 'Keyword "' // trim(sec_continuum_name) // '" not ' // &
   373)                          'recognized in SecondaryContinuumSetProperties()'
   374)       call printErrMsg(option)  
   375)   end select
   376)       
   377) end subroutine SecondaryContinuumSetProperties  
   378) 
   379) ! ************************************************************************** !
   380) 
   381) subroutine SecondaryContinuumCalcLogSpacing(matrix_size,outer_grid_size, &
   382)                                             sec_num_cells,grid_spacing,option)
   383)   ! 
   384)   ! Given the matrix block size and the
   385)   ! grid spacing of the outer most secondary continuum cell, a geometric
   386)   ! series is assumed and the grid spacing of the rest of the cells is
   387)   ! calculated
   388)   ! 
   389)   ! Equation:
   390)   ! \frac{1 - \rho}{1 - \rho_M}*\rho*(M-1) = \frac{2\Delta\xi_m}{l_M}
   391)   !
   392)   ! where
   393)   !   \Delta\xi_m: Grid spacing of the outer most continuum cell (INPUT)
   394)   !   l_M        : Matrix block size (INPUT)
   395)   !   M          : Number of secondary continuum cells (INPUT)
   396)   !   \rho       : Logarithmic grid spacing factor (COMPUTED)
   397)   !
   398)   ! Author: Satish Karra, LANL
   399)   ! Date: 07/17/12
   400)   ! 
   401)                                               
   402)   use Option_module
   403)   
   404)   implicit none
   405)   
   406)   type(option_type) :: option
   407)   PetscReal :: matrix_size, outer_grid_size
   408)   PetscInt :: sec_num_cells
   409)   PetscReal :: grid_spacing(sec_num_cells)
   410)   PetscReal :: delta, delta_new, inner_grid_size
   411)   PetscReal :: F, dF
   412)   PetscReal, parameter :: tol = 1.d-12
   413)   PetscInt, parameter :: maxit = 50
   414)   PetscInt :: i 
   415)   
   416)   
   417)   if (mod(sec_num_cells,2) /= 0) then
   418)      option%io_buffer = 'NUM_CELLS under SECONDARY_CONTINUUM has to be' // &
   419)                         ' even for logarithmic grid spacing'
   420)       call printErrMsg(option)
   421)   endif
   422)   
   423)   delta = 0.99d0
   424)   
   425)   do i = 1, maxit
   426)     F = (1.d0 - delta)/(1.d0 - delta**sec_num_cells)*delta**(sec_num_cells - 1.d0) - &
   427)         2.d0*outer_grid_size/matrix_size
   428)     dF = (1.d0 + sec_num_cells*(delta - 1.d0) - delta**sec_num_cells)/ &
   429)          (delta**sec_num_cells - 1.d0)**2.d0*delta**(sec_num_cells - 2.d0)
   430)     delta_new = delta + F/dF
   431)     if ((abs(F) < tol)) exit
   432)     delta = delta_new
   433)     if (delta < 0.d0) delta = 0.5d0
   434) !   if (delta > 1.d0) delta = 0.9d0
   435)   enddo
   436)   
   437)   if (i == maxit) then
   438)      option%io_buffer = 'Log Grid spacing solution has not converged' // &
   439)                         ' with given fracture values.'
   440)      call printErrMsg(option)    
   441)   endif
   442) 
   443)   inner_grid_size = outer_grid_size/delta**(sec_num_cells - 1)
   444)   
   445)   do i = 1, sec_num_cells
   446)     grid_spacing(i) = inner_grid_size*delta**(i-1)
   447)   enddo
   448) 
   449) !  write(option%fid_out,'("  Logarithmic grid spacing: delta = ",1pe12.4)') delta
   450)     
   451) end subroutine SecondaryContinuumCalcLogSpacing
   452) 
   453) ! ************************************************************************** !
   454) 
   455) subroutine SecondaryRTTimeCut(realization)
   456)   ! 
   457)   ! Resets secondary concentrations to previous time
   458)   ! step when there is a time cut
   459)   ! 
   460)   ! Author: Satish Karra, LANL
   461)   ! Date: 05/29/13
   462)   ! 
   463) 
   464)   use Realization_Subsurface_class
   465)   use Grid_module
   466)   use Reaction_Aux_module
   467)   
   468)   implicit none
   469)   class(realization_subsurface_type) :: realization
   470)   type(reaction_type), pointer :: reaction
   471)   type(sec_transport_type), pointer :: rt_sec_transport_vars(:)
   472)   type(grid_type), pointer :: grid
   473)   
   474)   PetscInt :: local_id, ghosted_id
   475)   PetscInt :: ngcells, ncomp
   476)   PetscInt :: cell, comp
   477) 
   478)   reaction => realization%reaction
   479)   rt_sec_transport_vars => realization%patch%aux%SC_RT%sec_transport_vars
   480)   grid => realization%patch%grid  
   481)   
   482)   ncomp = reaction%naqcomp
   483)   
   484)   do local_id = 1, grid%nlmax
   485)     ghosted_id = grid%nL2G(local_id)
   486)     if (realization%patch%imat(ghosted_id) <= 0) cycle
   487)     do comp = 1, ncomp
   488)       ngcells = rt_sec_transport_vars(local_id)%ncells
   489)       do cell = 1, ngcells
   490)         rt_sec_transport_vars(local_id)%updated_conc(comp,cell) = &
   491)           rt_sec_transport_vars(local_id)%sec_rt_auxvar(cell)%pri_molal(comp)
   492)       enddo
   493)     enddo
   494)   enddo
   495)  
   496) end subroutine SecondaryRTTimeCut
   497) 
   498) ! ************************************************************************** !
   499) 
   500) subroutine SecondaryRTAuxVarInit(ptr,rt_sec_transport_vars,reaction, &
   501)                                  initial_condition,constraint,option)
   502)   ! 
   503)   ! Initializes all the secondary continuum reactive
   504)   ! transport variables
   505)   ! 
   506)   ! Author: Satish Karra, LANL
   507)   ! Date: 02/05/13
   508)   ! 
   509)   
   510)   use Coupler_module
   511)   use Transport_Constraint_module
   512)   use Condition_module
   513)   use Global_Aux_module
   514)   use Material_module
   515)   use Option_module
   516)   use Reaction_module
   517)   use Reaction_Aux_module
   518)   use Reactive_Transport_Aux_module
   519)   use Material_Aux_class
   520)   
   521)   use EOS_Water_module
   522)   
   523)   implicit none 
   524)   
   525)   type(sec_transport_type) :: rt_sec_transport_vars
   526)   type(material_property_type), pointer :: ptr
   527)   type(reaction_type), pointer :: reaction
   528)   type(coupler_type), pointer :: initial_condition
   529)   type(option_type), pointer :: option
   530)   type(reactive_transport_auxvar_type), pointer :: rt_auxvar
   531)   type(global_auxvar_type), pointer :: global_auxvar
   532)   class(material_auxvar_type), allocatable :: material_auxvar
   533)   type(tran_constraint_type), pointer :: constraint
   534)   type(flow_condition_type), pointer :: initial_flow_condition
   535)   
   536) 
   537)   PetscReal :: equil_conc(reaction%mineral%nmnrl)
   538)   PetscInt :: i, cell
   539)   PetscReal :: area_per_vol
   540)   PetscReal :: dum1
   541)   PetscInt :: num_iterations
   542)   PetscErrorCode :: ierr
   543)   
   544)   num_iterations = 0
   545) 
   546)   allocate(material_auxvar)
   547)   call MaterialAuxVarInit(material_auxvar,option)
   548)   material_auxvar%porosity = option%reference_porosity
   549) 
   550)   call SecondaryContinuumSetProperties( &
   551)         rt_sec_transport_vars%sec_continuum, &
   552)         ptr%secondary_continuum_name, &
   553)         ptr%secondary_continuum_length, &
   554)         ptr%secondary_continuum_matrix_block_size, &
   555)         ptr%secondary_continuum_fracture_spacing, &
   556)         ptr%secondary_continuum_radius, &
   557)         ptr%secondary_continuum_area, &
   558)         option)
   559)         
   560)   rt_sec_transport_vars%ncells = ptr%secondary_continuum_ncells
   561)   rt_sec_transport_vars%aperture = ptr%secondary_continuum_aperture
   562)   rt_sec_transport_vars%epsilon = ptr%secondary_continuum_epsilon 
   563)   rt_sec_transport_vars%log_spacing = ptr%secondary_continuum_log_spacing
   564)   rt_sec_transport_vars%outer_spacing = ptr%secondary_continuum_outer_spacing    
   565)         
   566)   allocate(rt_sec_transport_vars%area(rt_sec_transport_vars%ncells))
   567)   allocate(rt_sec_transport_vars%vol(rt_sec_transport_vars%ncells))
   568)   allocate(rt_sec_transport_vars%dm_minus(rt_sec_transport_vars%ncells))
   569)   allocate(rt_sec_transport_vars%dm_plus(rt_sec_transport_vars%ncells))
   570)   allocate(rt_sec_transport_vars%sec_continuum% &
   571)              distance(rt_sec_transport_vars%ncells))
   572)     
   573)   call SecondaryContinuumType(rt_sec_transport_vars%sec_continuum, &
   574)                               rt_sec_transport_vars%ncells, &
   575)                               rt_sec_transport_vars%area, &
   576)                               rt_sec_transport_vars%vol, &
   577)                               rt_sec_transport_vars%dm_minus, &
   578)                               rt_sec_transport_vars%dm_plus, &
   579)                               rt_sec_transport_vars%aperture, &
   580)                               rt_sec_transport_vars%epsilon, &
   581)                               rt_sec_transport_vars%log_spacing, &
   582)                               rt_sec_transport_vars%outer_spacing, &
   583)                               area_per_vol,option)                                
   584)   rt_sec_transport_vars%interfacial_area = area_per_vol* &
   585)          (1.d0 - rt_sec_transport_vars%epsilon)*ptr% &
   586)          secondary_continuum_area_scaling
   587)   
   588)   ! Initializing the secondary RT auxvars
   589)   allocate(rt_sec_transport_vars%sec_rt_auxvar(rt_sec_transport_vars%ncells))
   590)   do cell = 1, rt_sec_transport_vars%ncells
   591)     call RTAuxVarInit(rt_sec_transport_vars%sec_rt_auxvar(cell),reaction,option)
   592)   enddo
   593) 
   594)   allocate(rt_sec_transport_vars%sec_jac(reaction%naqcomp,reaction%naqcomp))    
   595)            
   596)   ! Allocate diagonal terms
   597)   allocate(rt_sec_transport_vars%cxm(reaction%naqcomp,reaction%naqcomp,&
   598)            rt_sec_transport_vars%ncells)) 
   599)   allocate(rt_sec_transport_vars%cxp(reaction%naqcomp,reaction%naqcomp,&
   600)            rt_sec_transport_vars%ncells))  
   601)   allocate(rt_sec_transport_vars%cdl(reaction%naqcomp,reaction%naqcomp,&
   602)            rt_sec_transport_vars%ncells)) 
   603)   allocate(rt_sec_transport_vars% &
   604)            r(reaction%naqcomp*rt_sec_transport_vars%ncells))
   605)   allocate(rt_sec_transport_vars% &
   606)            updated_conc(reaction%naqcomp,rt_sec_transport_vars%ncells))
   607)            
   608)   
   609)   initial_flow_condition => initial_condition%flow_condition
   610)   do cell = 1, rt_sec_transport_vars%ncells
   611)     global_auxvar => initial_condition%tran_condition% &
   612)                        constraint_coupler_list%global_auxvar
   613)     rt_auxvar => rt_sec_transport_vars%sec_rt_auxvar(cell)
   614)     if (associated(initial_flow_condition)) then
   615)       if (associated(initial_flow_condition%pressure)) then
   616)         if (associated(initial_flow_condition%pressure%dataset)) then
   617)           global_auxvar%pres = &
   618)             initial_flow_condition%pressure%dataset%rarray(1)
   619)         else
   620)           global_auxvar%pres = option%reference_pressure
   621)         endif
   622)       else 
   623)         global_auxvar%pres = option%reference_pressure
   624)       endif
   625)       if (associated(initial_flow_condition%temperature)) then
   626)         if (associated(initial_flow_condition%temperature%dataset)) then
   627)           global_auxvar%temp  = &
   628)             initial_flow_condition%temperature%dataset%rarray(1)
   629)         else
   630)           global_auxvar%temp = option%reference_temperature
   631)         endif
   632)       else
   633)         global_auxvar%temp = option%reference_temperature
   634)       endif
   635)         
   636)       call EOSWaterDensity(global_auxvar%temp, &
   637)                            global_auxvar%pres(1), &
   638)                            global_auxvar%den_kg(1), &
   639)                            dum1,ierr)
   640)     else
   641)       global_auxvar%pres = option%reference_pressure
   642)       global_auxvar%temp = option%reference_temperature
   643)       global_auxvar%den_kg = option%reference_water_density
   644)     endif
   645)     global_auxvar%sat = option%reference_saturation
   646)                       
   647)     call ReactionEquilibrateConstraint(rt_auxvar,global_auxvar, &
   648)                           material_auxvar, &
   649)                           reaction,constraint%name, &
   650)                           constraint%aqueous_species, &
   651)                           constraint%free_ion_guess, &
   652)                           constraint%minerals, &
   653)                           constraint%surface_complexes, &
   654)                           constraint%colloids, &
   655)                           constraint%immobile_species, &
   656)                           num_iterations, &
   657)                           PETSC_FALSE,option)   
   658)                           
   659)     rt_sec_transport_vars%updated_conc(:,cell) =  rt_auxvar%pri_molal   
   660)        
   661)   enddo                                    
   662)   
   663)   call MaterialAuxVarStrip(material_auxvar)
   664)   deallocate(material_auxvar)
   665)   
   666)   rt_sec_transport_vars%sec_jac_update = PETSC_FALSE
   667)   rt_sec_transport_vars%sec_jac = 0.d0
   668)   rt_sec_transport_vars%cxm = 0.d0
   669)   rt_sec_transport_vars%cxp = 0.d0
   670)   rt_sec_transport_vars%cdl = 0.d0
   671)   rt_sec_transport_vars%r = 0.d0
   672)       
   673) end subroutine SecondaryRTAuxVarInit  
   674) 
   675) ! ************************************************************************** !
   676) 
   677) subroutine SecondaryRTResJacMulti(sec_transport_vars,auxvar, &
   678)                                   global_auxvar,prim_vol, &
   679)                                   reaction,diffusion_coefficient, &
   680)                                   porosity,option,res_transport)
   681)   ! 
   682)   ! RTSecondaryTransportMulti:  Calculates the source term contribution due to
   683)   ! secondary continuum in the primary continuum residual for multicomponent
   684)   ! system assuming only aqueous reaction
   685)   ! 
   686)   ! Author: Satish Karra, LANL
   687)   ! Date: 1/31/13
   688)   ! 
   689)                                
   690)                             
   691)   use Option_module 
   692)   use Global_Aux_module
   693)   use Block_Solve_module
   694)   use Block_Tridiag_module
   695)   use Utility_module
   696)   use Reaction_module
   697)   use Reaction_Aux_module
   698)   use Reactive_Transport_Aux_module
   699)   use Material_Aux_class
   700) 
   701)   implicit none
   702)   
   703)   type(sec_transport_type) :: sec_transport_vars
   704)   type(reactive_transport_auxvar_type) :: auxvar
   705)   type(reactive_transport_auxvar_type) :: rt_auxvar
   706)   type(global_auxvar_type) :: global_auxvar
   707)   type(reaction_type), pointer :: reaction
   708)   type(option_type) :: option
   709)   PetscReal :: coeff_left(reaction%naqcomp,reaction%naqcomp, &
   710)                           sec_transport_vars%ncells)
   711)   PetscReal :: coeff_diag(reaction%naqcomp,reaction%naqcomp, &
   712)                           sec_transport_vars%ncells)
   713)   PetscReal :: coeff_right(reaction%naqcomp,reaction%naqcomp, &
   714)                            sec_transport_vars%ncells)
   715)   PetscReal :: res(sec_transport_vars%ncells*reaction%naqcomp)
   716)   PetscReal :: rhs(sec_transport_vars%ncells*reaction%naqcomp)
   717)   PetscReal :: D_M(reaction%naqcomp,reaction%naqcomp)
   718)   PetscReal :: identity(reaction%naqcomp,reaction%naqcomp)
   719)   PetscReal :: b_M(reaction%naqcomp,reaction%naqcomp)
   720)   PetscReal :: sec_jac(reaction%naqcomp,reaction%naqcomp)
   721)   PetscReal :: inv_D_M(reaction%naqcomp,reaction%naqcomp)
   722)   PetscReal :: conc_upd(reaction%naqcomp,sec_transport_vars%ncells) 
   723)   PetscReal :: total_upd(reaction%naqcomp,sec_transport_vars%ncells)
   724)   PetscReal :: total_prev(reaction%naqcomp,sec_transport_vars%ncells)
   725)   PetscReal :: conc_current_M(reaction%naqcomp)
   726)   PetscReal :: total_current_M(reaction%naqcomp)
   727)   PetscReal :: res_transport(reaction%naqcomp)
   728)   PetscReal :: total_primary_node(reaction%naqcomp)
   729)   PetscReal :: area(sec_transport_vars%ncells)
   730)   PetscReal :: vol(sec_transport_vars%ncells)
   731)   PetscReal :: dm_plus(sec_transport_vars%ncells)
   732)   PetscReal :: dm_minus(sec_transport_vars%ncells)
   733)   PetscReal :: res_react(reaction%naqcomp)
   734)   PetscReal :: jac_react(reaction%naqcomp,reaction%naqcomp)
   735)   PetscReal :: dtotal(reaction%naqcomp,reaction%naqcomp,sec_transport_vars%ncells)
   736)   PetscReal :: dtotal_prim(reaction%naqcomp,reaction%naqcomp)
   737)   PetscInt :: i, j, k, n, l
   738)   PetscInt :: ngcells, ncomp
   739)   PetscReal :: area_fm
   740)   PetscReal :: diffusion_coefficient
   741)   PetscReal :: porosity
   742)   PetscReal :: arrhenius_factor
   743)   PetscReal :: pordt, pordiff
   744)   PetscReal :: prim_vol ! volume of primary grid cell
   745)   PetscReal :: dCsec_dCprim(reaction%naqcomp,reaction%naqcomp)
   746)   PetscReal :: dPsisec_dCprim(reaction%naqcomp,reaction%naqcomp)
   747)   PetscInt :: jcomp, lcomp, kcomp, icplx, ncompeq
   748)   PetscReal :: sec_sec_molal_M(reaction%neqcplx)   ! secondary species molality of secondary continuum
   749)   
   750)   PetscInt :: pivot(reaction%naqcomp,sec_transport_vars%ncells)
   751)   PetscInt :: indx(reaction%naqcomp)
   752)   PetscInt :: d, ier
   753)   PetscReal :: m
   754)   
   755)   ! Quantities for numerical jacobian
   756)   PetscReal :: conc_prim(reaction%naqcomp)
   757)   PetscReal :: conc_prim_pert(reaction%naqcomp)
   758)   PetscReal :: sec_jac_num(reaction%naqcomp,reaction%naqcomp)
   759)   PetscReal :: conc_current_M_pert(reaction%naqcomp)
   760)   PetscReal :: total_current_M_pert(reaction%naqcomp)
   761)   PetscReal :: res_transport_pert(reaction%naqcomp)
   762)   PetscReal :: total_primary_node_pert(reaction%naqcomp)
   763)   PetscReal :: dtotal_prim_num(reaction%naqcomp,reaction%naqcomp)
   764)   PetscReal :: dPsisec_dCprim_num(reaction%naqcomp,reaction%naqcomp)
   765)   PetscReal :: pert
   766)   PetscReal :: coeff_diag_dm(reaction%naqcomp,reaction%naqcomp, &
   767)                           sec_transport_vars%ncells)
   768)   PetscReal :: coeff_left_dm(reaction%naqcomp,reaction%naqcomp, &
   769)                           sec_transport_vars%ncells)
   770)   PetscReal :: coeff_right_dm(reaction%naqcomp,reaction%naqcomp, &
   771)                           sec_transport_vars%ncells)
   772)   PetscReal :: coeff_left_pert(reaction%naqcomp,reaction%naqcomp, &
   773)                           sec_transport_vars%ncells)
   774)   PetscReal :: coeff_diag_pert(reaction%naqcomp,reaction%naqcomp, &
   775)                           sec_transport_vars%ncells)
   776)   PetscReal :: coeff_right_pert(reaction%naqcomp,reaction%naqcomp, &
   777)                            sec_transport_vars%ncells)
   778)   PetscReal :: coeff_left_copy(reaction%naqcomp,reaction%naqcomp, &
   779)                           sec_transport_vars%ncells)
   780)   PetscReal :: coeff_diag_copy(reaction%naqcomp,reaction%naqcomp, &
   781)                           sec_transport_vars%ncells)
   782)   PetscReal :: coeff_right_copy(reaction%naqcomp,reaction%naqcomp, &
   783)                            sec_transport_vars%ncells)
   784) 
   785)   PetscReal :: total_sorb_upd(reaction%naqcomp,sec_transport_vars%ncells) 
   786)   PetscReal :: total_sorb_prev(reaction%naqcomp,sec_transport_vars%ncells)
   787)   PetscReal :: dtotal_sorb_upd(reaction%naqcomp,reaction%naqcomp,sec_transport_vars%ncells)
   788) 
   789)   class(material_auxvar_type), allocatable :: material_auxvar
   790)   
   791)   ngcells = sec_transport_vars%ncells
   792)   area = sec_transport_vars%area
   793)   vol = sec_transport_vars%vol          
   794)   dm_plus = sec_transport_vars%dm_plus
   795)   dm_minus = sec_transport_vars%dm_minus
   796)   area_fm = sec_transport_vars%interfacial_area
   797)   ncomp = reaction%naqcomp
   798)   
   799)   do j = 1, ncomp
   800)     do i = 1, ngcells
   801)       total_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total(j,1)
   802)       if (reaction%neqsorb > 0) then
   803)         total_sorb_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total_sorb_eq(j)
   804)       endif
   805)     enddo
   806)   enddo
   807)   conc_upd = sec_transport_vars%updated_conc
   808)     
   809)   ! Note that sec_transport_vars%sec_rt_auxvar(i)%pri_molal(j) units are in mol/kg
   810)   ! Need to convert to mol/L since the units of total. in the Thomas 
   811)   ! algorithm are in mol/L 
   812)   
   813)   coeff_left = 0.d0
   814)   coeff_diag = 0.d0
   815)   coeff_right = 0.d0
   816)   res = 0.d0
   817)   rhs = 0.d0
   818)   D_M = 0.d0
   819)   identity = 0.d0
   820)   b_M = 0.d0
   821)   inv_D_M = 0.d0
   822)   total_current_M = 0.d0
   823)   dPsisec_dCprim = 0.d0
   824)   dCsec_dCprim = 0.d0
   825)   
   826)   total_primary_node = auxvar%total(:,1)                         ! in mol/L 
   827)   dtotal_prim = auxvar%aqueous%dtotal(:,:,1)
   828)   pordt = porosity/option%tran_dt
   829)   pordiff = porosity*diffusion_coefficient
   830) 
   831)   call RTAuxVarInit(rt_auxvar,reaction,option)
   832)   do i = 1, ngcells
   833)     call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i),option)
   834)     rt_auxvar%pri_molal = conc_upd(:,i)
   835)     call RTotal(rt_auxvar,global_auxvar,reaction,option)
   836)     if (reaction%neqsorb > 0) then
   837)       call SecondaryRTotalSorb(rt_auxvar,global_auxvar,material_auxvar,reaction,option)
   838)     endif
   839)     total_upd(:,i) = rt_auxvar%total(:,1)
   840)     dtotal(:,:,i) = rt_auxvar%aqueous%dtotal(:,:,1)
   841)     if (reaction%neqsorb > 0) then 
   842)       total_sorb_upd(:,i) = rt_auxvar%total_sorb_eq(:)
   843)       dtotal_sorb_upd(:,:,i) = rt_auxvar%dtotal_sorb_eq(:,:)
   844)     endif
   845)   enddo 
   846)                           
   847) !================ Calculate the secondary residual =============================        
   848) 
   849)   do j = 1, ncomp
   850)       
   851)     ! Accumulation
   852)     do i = 1, ngcells
   853)       n = j + (i-1)*ncomp
   854)       res(n) = pordt*(total_upd(j,i) - total_prev(j,i))*vol(i)    ! in mol/L*m3/s
   855)       if (reaction%neqsorb > 0) then 
   856)         res(n) = res(n) + vol(i)/option%tran_dt*(total_sorb_upd(j,i) - total_sorb_prev(j,i))
   857)       endif      
   858)     enddo
   859)   
   860)     ! Flux terms
   861)     do i = 2, ngcells - 1
   862)       n = j + (i-1)*ncomp
   863)       res(n) = res(n) - pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))* &
   864)                         (total_upd(j,i+1) - total_upd(j,i))
   865)       res(n) = res(n) + pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))* &
   866)                         (total_upd(j,i) - total_upd(j,i-1))                      
   867)     enddo
   868)          
   869)               
   870)     ! Apply boundary conditions
   871)     ! Inner boundary
   872)     res(j) = res(j) - pordiff*area(1)/(dm_minus(2) + dm_plus(1))* &
   873)                       (total_upd(j,2) - total_upd(j,1))
   874)                                       
   875)     ! Outer boundary
   876)     res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) - &
   877)                                pordiff*area(ngcells)/dm_plus(ngcells)* &
   878)                                (total_primary_node(j) - total_upd(j,ngcells))
   879)     res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) + &
   880)                                pordiff*area(ngcells-1)/(dm_minus(ngcells) &
   881)                                + dm_plus(ngcells-1))*(total_upd(j,ngcells) - &
   882)                                total_upd(j,ngcells-1))  
   883)                                
   884)   enddo
   885)                          
   886)   res = res*1.d3 ! Convert mol/L*m3/s to mol/s                                                    
   887)                                                                                                           
   888) !================ Calculate the secondary jacobian =============================        
   889) 
   890) 
   891)   do j = 1, ncomp
   892)     do k = 1, ncomp  
   893)         ! Accumulation
   894)         do i = 1, ngcells 
   895)           coeff_diag(j,k,i) = coeff_diag(j,k,i) + pordt*vol(i)
   896)           if (reaction%neqsorb > 0) then
   897)             coeff_diag(j,k,i) = coeff_diag(j,k,i) + vol(i)/option%tran_dt*(dtotal_sorb_upd(j,k,i))
   898)           endif
   899)         enddo
   900)   
   901)         ! Flux terms
   902)         do i = 2, ngcells-1
   903)           coeff_diag(j,k,i) = coeff_diag(j,k,i) + &
   904)                               pordiff*area(i)/(dm_minus(i+1) + dm_plus(i)) + &
   905)                               pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))
   906)           coeff_left(j,k,i) = coeff_left(j,k,i) - &
   907)                               pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))
   908)           coeff_right(j,k,i) = coeff_right(j,k,i) - &
   909)                                pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))
   910)         enddo
   911)   
   912)   
   913)         ! Apply boundary conditions
   914)         ! Inner boundary
   915)         coeff_diag(j,k,1) = coeff_diag(j,k,1) + &
   916)                             pordiff*area(1)/(dm_minus(2) + dm_plus(1))
   917)                    
   918)         coeff_right(j,k,1) = coeff_right(j,k,1) - &
   919)                              pordiff*area(1)/(dm_minus(2) + dm_plus(1))
   920)   
   921)         ! Outer boundary -- closest to primary node
   922)         coeff_diag(j,k,ngcells) = coeff_diag(j,k,ngcells) + &
   923)                                   pordiff*area(ngcells-1)/(dm_minus(ngcells) &
   924)                                   + dm_plus(ngcells-1)) + &
   925)                                   pordiff*area(ngcells)/dm_plus(ngcells)
   926)         coeff_left(j,k,ngcells) = coeff_left(j,k,ngcells) - &
   927)                                   pordiff*area(ngcells-1)/(dm_minus(ngcells) + &
   928)                                   dm_plus(ngcells-1)) 
   929) 
   930)     enddo    
   931)   enddo
   932) 
   933) !============================= Include dtotal ==================================        
   934)   
   935)   ! Include dtotal (units of kg water/ L water)
   936)   i = 1
   937)   do j = 1, ncomp
   938)     do k = 1, ncomp
   939)       coeff_diag(j,k,i) = coeff_diag(j,k,i)*dtotal(j,k,i) ! m3/s*kg/L
   940)       coeff_right(j,k,i) = coeff_right(j,k,i)*dtotal(j,k,i+1)
   941)     enddo
   942)   enddo
   943)   do i = 2, ngcells-1
   944)     do j = 1, ncomp
   945)       do k = 1, ncomp
   946)         coeff_diag(j,k,i) = coeff_diag(j,k,i)*dtotal(j,k,i) ! m3/s*kg/L
   947)         coeff_left(j,k,i) = coeff_left(j,k,i)*dtotal(j,k,i-1)
   948)         coeff_right(j,k,i) = coeff_right(j,k,i)*dtotal(j,k,i+1)
   949)       enddo
   950)     enddo
   951)   enddo
   952)   i = ngcells
   953)   do j = 1, ncomp
   954)     do k = 1, ncomp
   955)       coeff_diag(j,k,i) = coeff_diag(j,k,i)*dtotal(j,k,i) ! m3/s*kg/L
   956)       coeff_left(j,k,i) = coeff_left(j,k,i)*dtotal(j,k,i-1)
   957)     enddo
   958)   enddo
   959)   
   960)   ! Sorption
   961)   do j = 1, ncomp
   962)     do k = 1, ncomp  
   963)       ! Accumulation
   964)       do i = 1, ngcells 
   965)         if (reaction%neqsorb > 0) then
   966)           coeff_diag(j,k,i) = coeff_diag(j,k,i) + vol(i)/option%tran_dt*(dtotal_sorb_upd(j,k,i))
   967)         endif
   968)       enddo
   969)     enddo
   970)   enddo
   971)     
   972)   
   973)   ! Convert m3/s*kg/L to kg water/s
   974)   coeff_right = coeff_right*1.d3
   975)   coeff_left = coeff_left*1.d3
   976)   coeff_diag = coeff_diag*1.d3
   977)   
   978) !====================== Add reaction contributions =============================        
   979)   
   980)   ! Reaction 
   981)   allocate(material_auxvar)
   982)   call MaterialAuxVarInit(material_auxvar,option)
   983)   do i = 1, ngcells
   984)     res_react = 0.d0
   985)     jac_react = 0.d0
   986)     call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i), &
   987)                       option)
   988)     rt_auxvar%pri_molal = conc_upd(:,i) ! in mol/kg
   989)     call RTotal(rt_auxvar,global_auxvar,reaction,option)
   990)     material_auxvar%porosity = porosity
   991)     material_auxvar%volume = vol(i)
   992)     call RReaction(res_react,jac_react,PETSC_TRUE, &
   993)                    rt_auxvar,global_auxvar,material_auxvar,reaction,option)                     
   994)     do j = 1, ncomp
   995)       res(j+(i-1)*ncomp) = res(j+(i-1)*ncomp) + res_react(j) 
   996)     enddo
   997)     coeff_diag(:,:,i) = coeff_diag(:,:,i) + jac_react  ! in kg water/s
   998)   enddo  
   999)   call MaterialAuxVarStrip(material_auxvar)
  1000)   deallocate(material_auxvar)
  1001)          
  1002) !============================== Forward solve ==================================        
  1003)                         
  1004)   rhs = -res   
  1005)   
  1006)   if (reaction%use_log_formulation) then
  1007)   ! scale the jacobian by concentrations
  1008)     i = 1
  1009)     do k = 1, ncomp
  1010)       coeff_diag(:,k,i) = coeff_diag(:,k,i)*conc_upd(k,i) ! m3/s*kg/L
  1011)       coeff_right(:,k,i) = coeff_right(:,k,i)*conc_upd(k,i+1)
  1012)     enddo
  1013)     do i = 2, ngcells-1
  1014)       do k = 1, ncomp
  1015)         coeff_diag(:,k,i) = coeff_diag(:,k,i)*conc_upd(k,i) ! m3/s*kg/L
  1016)         coeff_left(:,k,i) = coeff_left(:,k,i)*conc_upd(k,i-1)
  1017)         coeff_right(:,k,i) = coeff_right(:,k,i)*conc_upd(k,i+1)
  1018)       enddo
  1019)     enddo
  1020)     i = ngcells
  1021)       do k = 1, ncomp
  1022)         coeff_diag(:,k,i) = coeff_diag(:,k,i)*conc_upd(k,i) ! m3/s*kg/L
  1023)         coeff_left(:,k,i) = coeff_left(:,k,i)*conc_upd(k,i-1)
  1024)       enddo
  1025)   endif 
  1026)   
  1027)   ! First do an LU decomposition for calculating D_M matrix
  1028)   coeff_diag_dm = coeff_diag
  1029)   coeff_left_dm = coeff_left
  1030)   coeff_right_dm = coeff_right
  1031)   
  1032)   select case (option%secondary_continuum_solver)
  1033)     case(1) 
  1034)       do i = 2, ngcells
  1035)         coeff_left_dm(:,:,i-1) = coeff_left_dm(:,:,i)
  1036)       enddo
  1037)       coeff_left_dm(:,:,ngcells) = 0.d0
  1038)       call bl3dfac(ngcells,ncomp,coeff_right_dm,coeff_diag_dm,coeff_left_dm,pivot)  
  1039)     case(2)
  1040)       call decbt(ncomp,ngcells,ncomp,coeff_diag_dm,coeff_right_dm,coeff_left_dm,pivot,ier)
  1041)       if (ier /= 0) then
  1042)         print *,'error in matrix decbt: ier = ',ier
  1043)         stop
  1044)       endif
  1045)     case(3)
  1046)       ! Thomas algorithm for tridiagonal system
  1047)       ! Forward elimination
  1048)       if (ncomp /= 1) then
  1049)         option%io_buffer = 'THOMAS algorithm can be used only with single '// &
  1050)                            'component chemistry'
  1051)         call printErrMsg(option)
  1052)       endif
  1053)       do i = 2, ngcells
  1054)         m = coeff_left_dm(ncomp,ncomp,i)/coeff_diag_dm(ncomp,ncomp,i-1)
  1055)         coeff_diag_dm(ncomp,ncomp,i) = coeff_diag_dm(ncomp,ncomp,i) - &
  1056)                                     m*coeff_right_dm(ncomp,ncomp,i-1)
  1057)       enddo        
  1058)     case default
  1059)       option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
  1060)                          'HINDMARSH or KEARST. For single component'// &
  1061)                          'chemistry THOMAS can be used.'
  1062)       call printErrMsg(option)  
  1063)   end select
  1064)   
  1065)   ! Set the values of D_M matrix and create identity matrix of size ncomp x ncomp  
  1066)   do i = 1, ncomp
  1067)     do j = 1, ncomp
  1068)       D_M(i,j) = coeff_diag_dm(i,j,ngcells)
  1069)       if (j == i) then
  1070)         identity(i,j) = 1.d0
  1071)       else
  1072)         identity(i,j) = 0.d0
  1073)       endif
  1074)     enddo
  1075)   enddo
  1076)   
  1077)   ! Find the inverse of D_M
  1078)   call ludcmp(D_M,ncomp,indx,d) 
  1079)   do j = 1, ncomp
  1080)     call lubksb(D_M,ncomp,indx,identity(1,j))
  1081)   enddo  
  1082)   inv_D_M = identity      
  1083)   
  1084)   if (option%numerical_derivatives_multi_coupling) then  
  1085)     ! Store the coeffs for numerical jacobian
  1086)     coeff_diag_copy = coeff_diag
  1087)     coeff_left_copy = coeff_left
  1088)     coeff_right_copy = coeff_right
  1089)   endif
  1090) 
  1091)   select case (option%secondary_continuum_solver)
  1092)     case(1) 
  1093)       do i = 2, ngcells
  1094)         coeff_left(:,:,i-1) = coeff_left(:,:,i)
  1095)       enddo
  1096)       coeff_left(:,:,ngcells) = 0.d0
  1097)       call bl3dfac(ngcells,ncomp,coeff_right,coeff_diag,coeff_left,pivot)  
  1098)       call bl3dsolf(ngcells,ncomp,coeff_right,coeff_diag,coeff_left,pivot, &
  1099)                     ONE_INTEGER,rhs)
  1100)     case(2)
  1101)       call decbt(ncomp,ngcells,ncomp,coeff_diag,coeff_right,coeff_left, &
  1102)                  pivot,ier)
  1103)       if (ier /= 0) then
  1104)         print *,'error in matrix decbt: ier = ',ier
  1105)         stop
  1106)       endif
  1107)       call solbtf(ncomp,ngcells,ncomp,coeff_diag,coeff_right,coeff_left, &
  1108)                   pivot,rhs)
  1109)     case(3)
  1110)       ! Thomas algorithm for tridiagonal system
  1111)       ! Forward elimination
  1112)       if (ncomp /= 1) then
  1113)         option%io_buffer = 'THOMAS algorithm can be used only with single '// &
  1114)                            'component chemistry'
  1115)         call printErrMsg(option)
  1116)       endif
  1117)       do i = 2, ngcells
  1118)         m = coeff_left(ncomp,ncomp,i)/coeff_diag(ncomp,ncomp,i-1)
  1119)         coeff_diag(ncomp,ncomp,i) = coeff_diag(ncomp,ncomp,i) - &
  1120)                                     m*coeff_right(ncomp,ncomp,i-1)
  1121)         rhs(i) = rhs(i) - m*rhs(i-1)
  1122)       enddo        
  1123)       rhs(ngcells) = rhs(ngcells)/coeff_diag(ncomp,ncomp,ngcells)
  1124)     case default
  1125)       option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
  1126)                          'HINDMARSH or KEARST. For single component'// &
  1127)                          'chemistry THOMAS can be used.'
  1128)       call printErrMsg(option)  
  1129)   end select
  1130)     
  1131)   ! Update the secondary concentrations
  1132)   do i = 1, ncomp
  1133)     if (reaction%use_log_formulation) then
  1134)       ! convert log concentration to concentration
  1135)       rhs(i+(ngcells-1)*ncomp) = dsign(1.d0,rhs(i+(ngcells-1)*ncomp))* &
  1136)         min(dabs(rhs(i+(ngcells-1)*ncomp)),reaction%max_dlnC)
  1137)       conc_current_M(i) = conc_upd(i,ngcells)*exp(rhs(i+(ngcells-1)*ncomp))
  1138)     else
  1139)       conc_current_M(i) = conc_upd(i,ngcells) + rhs(i+(ngcells-1)*ncomp)
  1140)     endif
  1141)   enddo
  1142) 
  1143)   ! Update the secondary continuum totals at the outer matrix node
  1144)   call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(ngcells), &
  1145)                     option)
  1146)   rt_auxvar%pri_molal = conc_current_M ! in mol/kg
  1147)   call RTotal(rt_auxvar,global_auxvar,reaction,option)
  1148)   total_current_M = rt_auxvar%total(:,1)
  1149)   if (reaction%neqcplx > 0) sec_sec_molal_M = rt_auxvar%sec_molal
  1150)   call RTAuxVarStrip(rt_auxvar)
  1151)   
  1152) 
  1153)   b_m = pordiff/dm_plus(ngcells)*area(ngcells)*inv_D_M ! in m3/kg
  1154)   b_m = b_m*1.d3 ! in L/kg  For log formulation, L/mol
  1155)   
  1156)   dCsec_dCprim = b_m*dtotal_prim
  1157)       
  1158)   ! Calculate the dervative of outer matrix node total with respect to the 
  1159)   ! primary node concentration
  1160)   
  1161)   if (reaction%use_log_formulation) then ! log formulation
  1162)     do j = 1, ncomp
  1163)       do l = 1, ncomp
  1164)         dPsisec_dCprim(j,l) = dCsec_dCprim(j,l)*conc_current_M(j)
  1165)       enddo
  1166)     enddo
  1167)    
  1168)     if (reaction%neqcplx > 0) then
  1169)       do icplx = 1, reaction%neqcplx
  1170)         ncompeq = reaction%eqcplxspecid(0,icplx)
  1171)         do j = 1, ncompeq
  1172)           jcomp = reaction%eqcplxspecid(j,icplx)
  1173)           do l = 1, ncompeq
  1174)             lcomp = reaction%eqcplxspecid(l,icplx)
  1175)             do k = 1, ncompeq
  1176)               kcomp = reaction%eqcplxspecid(k,icplx)
  1177)               dPsisec_dCprim(jcomp,lcomp) = dPsisec_dCprim(jcomp,lcomp) + &
  1178)                                             reaction%eqcplxstoich(j,icplx)* &
  1179)                                             reaction%eqcplxstoich(k,icplx)* &
  1180)                                             dCsec_dCprim(kcomp,lcomp)* &
  1181)                                             sec_sec_molal_M(icplx)
  1182)             enddo
  1183)           enddo      
  1184)         enddo
  1185)       enddo
  1186)     endif
  1187)    
  1188)   else   ! linear case  
  1189)   
  1190)     dPsisec_dCprim = dCsec_dCprim       ! dimensionless
  1191)   
  1192)     if (reaction%neqcplx > 0) then
  1193)       do icplx = 1, reaction%neqcplx
  1194)         ncompeq = reaction%eqcplxspecid(0,icplx)
  1195)         do j = 1, ncompeq
  1196)           jcomp = reaction%eqcplxspecid(j,icplx)
  1197)           do l = 1, ncompeq
  1198)             lcomp = reaction%eqcplxspecid(l,icplx)
  1199)             do k = 1, ncompeq
  1200)               kcomp = reaction%eqcplxspecid(k,icplx)
  1201)               dPsisec_dCprim(jcomp,lcomp) = dPsisec_dCprim(jcomp,lcomp) + &
  1202)                                             reaction%eqcplxstoich(j,icplx)* &
  1203)                                             reaction%eqcplxstoich(k,icplx)* &
  1204)                                             dCsec_dCprim(kcomp,lcomp)* &
  1205)                                             sec_sec_molal_M(icplx)/ &
  1206)                                             conc_current_M(kcomp)
  1207)             enddo
  1208)           enddo      
  1209)         enddo
  1210)       enddo
  1211)     endif
  1212)   
  1213)   endif
  1214)   
  1215)   dPsisec_dCprim = dPsisec_dCprim*global_auxvar%den_kg(1)*1.d-3 ! in kg/L
  1216)             
  1217)   ! Calculate the coupling term
  1218)   res_transport = pordiff/dm_plus(ngcells)*area_fm* &
  1219)                   (total_current_M - total_primary_node)*prim_vol*1.d3 ! in mol/s
  1220)                                            
  1221)   ! Calculate the jacobian contribution due to coupling term
  1222)   sec_jac = area_fm*pordiff/dm_plus(ngcells)*(dPsisec_dCprim - dtotal_prim)* &
  1223)             prim_vol*1.d3 ! in kg water/s
  1224)       
  1225)   ! Store the contribution to the primary jacobian term
  1226)   sec_transport_vars%sec_jac = sec_jac 
  1227)   sec_transport_vars%sec_jac_update = PETSC_TRUE
  1228)   
  1229)   ! Store the coefficients from LU decomposition of the block tridiagonal
  1230)   ! sytem. These will be called later to perform backsolve to the get the
  1231)   ! updated secondary continuum concentrations at the end of the timestep
  1232)   sec_transport_vars%cxm = coeff_left
  1233)   sec_transport_vars%cxp = coeff_right
  1234)   sec_transport_vars%cdl = coeff_diag
  1235)   
  1236)   ! Store the solution of the forward solve
  1237)   sec_transport_vars%r = rhs
  1238)   
  1239) !============== Numerical jacobian for coupling term ===========================
  1240) 
  1241) 
  1242)   if (option%numerical_derivatives_multi_coupling) then
  1243) 
  1244)     call RTAuxVarInit(rt_auxvar,reaction,option)
  1245)     conc_prim = auxvar%pri_molal
  1246)     conc_prim_pert = conc_prim
  1247)   
  1248)     do l = 1, ncomp
  1249)       
  1250)       conc_prim_pert = conc_prim
  1251)       pert = conc_prim(l)*perturbation_tolerance
  1252)       conc_prim_pert(l) = conc_prim_pert(l) + pert
  1253)   
  1254)       res = 0.d0
  1255)       rhs = 0.d0
  1256)     
  1257)       coeff_diag_pert = coeff_diag_copy
  1258)       coeff_left_pert = coeff_left_copy
  1259)       coeff_right_pert = coeff_right_copy
  1260) 
  1261)       call RTAuxVarCopy(rt_auxvar,auxvar,option)
  1262)       rt_auxvar%pri_molal = conc_prim_pert ! in mol/kg
  1263)       call RTotal(rt_auxvar,global_auxvar,reaction,option)
  1264)       total_primary_node_pert = rt_auxvar%total(:,1)
  1265)                           
  1266) !================ Calculate the secondary residual =============================        
  1267) 
  1268)       do j = 1, ncomp
  1269)       
  1270)         ! Accumulation
  1271)         do i = 1, ngcells
  1272)           n = j + (i-1)*ncomp
  1273)           res(n) = pordt*(total_upd(j,i) - total_prev(j,i))*vol(i)    ! in mol/L*m3/s
  1274)         enddo
  1275)   
  1276)         ! Flux terms
  1277)         do i = 2, ngcells - 1
  1278)           n = j + (i-1)*ncomp
  1279)           res(n) = res(n) - pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))* &
  1280)                             (total_upd(j,i+1) - total_upd(j,i))
  1281)           res(n) = res(n) + pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))* &
  1282)                             (total_upd(j,i) - total_upd(j,i-1))                      
  1283)         enddo
  1284)          
  1285)               
  1286)         ! Apply boundary conditions
  1287)         ! Inner boundary
  1288)         res(j) = res(j) - pordiff*area(1)/(dm_minus(2) + dm_plus(1))* &
  1289)                           (total_upd(j,2) - total_upd(j,1))
  1290)                                       
  1291)         ! Outer boundary
  1292)         res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) - &
  1293)                                    pordiff*area(ngcells)/dm_plus(ngcells)* &
  1294)                                    (total_primary_node_pert(j) -  &
  1295)                                    total_upd(j,ngcells))
  1296)         res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) + &
  1297)                                    pordiff*area(ngcells-1)/(dm_minus(ngcells) &
  1298)                                    + dm_plus(ngcells-1))*(total_upd(j,ngcells) - &
  1299)                                    total_upd(j,ngcells-1))  
  1300)                                
  1301)       enddo
  1302)                          
  1303)       res = res*1.d3 ! Convert mol/L*m3/s to mol/s                                                    
  1304)                                                                                                                   
  1305) !============================== Forward solve ==================================        
  1306)                         
  1307)       rhs = -res   
  1308)            
  1309)     select case (option%secondary_continuum_solver)
  1310)       case(1) 
  1311)         call bl3dfac(ngcells,ncomp,coeff_right_pert,coeff_diag_pert, &
  1312)                       coeff_left_pert,pivot)  
  1313)         call bl3dsolf(ngcells,ncomp,coeff_right_pert,coeff_diag_pert, &
  1314)                        coeff_left_pert,pivot,ONE_INTEGER,rhs)
  1315)       case(2)
  1316)         call decbt(ncomp,ngcells,ncomp,coeff_diag_pert,coeff_right_pert, &
  1317)                     coeff_left_pert,pivot,ier)
  1318)         if (ier /= 0) then
  1319)           print *,'error in matrix decbt: ier = ',ier
  1320)           stop
  1321)         endif
  1322)         call solbtf(ncomp,ngcells,ncomp,coeff_diag_pert,coeff_right_pert, &
  1323)                      coeff_left_pert,pivot,rhs)
  1324)       case(3)
  1325)         ! Thomas algorithm for tridiagonal system
  1326)         ! Forward elimination
  1327)         if (ncomp /= 1) then
  1328)           option%io_buffer = 'THOMAS algorithm can be used only with '// &
  1329)                              'single component chemistry'
  1330)           call printErrMsg(option)
  1331)         endif
  1332)         do i = 2, ngcells
  1333)           m = coeff_left_pert(ncomp,ncomp,i)/coeff_diag_pert(ncomp,ncomp,i-1)
  1334)           coeff_diag_pert(ncomp,ncomp,i) = coeff_diag_pert(ncomp,ncomp,i) - &
  1335)                                       m*coeff_right_pert(ncomp,ncomp,i-1)
  1336)           rhs(i) = rhs(i) - m*rhs(i-1)
  1337)         enddo        
  1338)         rhs(ngcells) = rhs(ngcells)/coeff_diag(ncomp,ncomp,ngcells)
  1339)       case default
  1340)         option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
  1341)                            'HINDMARSH or KEARST. For single component'// &
  1342)                            'chemistry THOMAS can be used.'
  1343)         call printErrMsg(option)  
  1344)       end select      
  1345)     
  1346)       ! Update the secondary concentrations
  1347)       do i = 1, ncomp
  1348)         if (reaction%use_log_formulation) then
  1349)           ! convert log concentration to concentration
  1350)           rhs(i+(ngcells-1)*ncomp) = dsign(1.d0,rhs(i+(ngcells-1)*ncomp))* &
  1351)             min(dabs(rhs(i+(ngcells-1)*ncomp)),reaction%max_dlnC)
  1352)           conc_current_M_pert(i) = conc_upd(i,ngcells)* &
  1353)                                      exp(rhs(i+(ngcells-1)*ncomp))
  1354)         else
  1355)           conc_current_M_pert(i) = conc_upd(i,ngcells) + &
  1356)                                      rhs(i+(ngcells-1)*ncomp)
  1357)         endif
  1358)       enddo
  1359) 
  1360)       ! Update the secondary continuum totals at the outer matrix node
  1361)       call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(ngcells), &
  1362)                         option)
  1363)       rt_auxvar%pri_molal = conc_current_M_pert ! in mol/kg
  1364)       call RTotal(rt_auxvar,global_auxvar,reaction,option)
  1365)       total_current_M_pert = rt_auxvar%total(:,1)
  1366)              
  1367)       ! Calculate the coupling term
  1368)       res_transport_pert = pordiff/dm_plus(ngcells)*area_fm* &
  1369)                            (total_current_M_pert - total_primary_node_pert)* &
  1370)                            prim_vol*1.d3 ! in mol/s
  1371)   
  1372)       dtotal_prim_num(:,l) = (total_primary_node_pert(:) - &
  1373)                                total_primary_node(:))/pert
  1374)   
  1375)       dPsisec_dCprim_num(:,l) = (total_current_M_pert(:) - &
  1376)                                   total_current_M(:))/pert
  1377)   
  1378)       sec_jac_num(:,l) = (res_transport_pert(:) - res_transport(:))/pert
  1379)     
  1380)     enddo    
  1381) 
  1382)     call RTAuxVarStrip(rt_auxvar)
  1383)     sec_transport_vars%sec_jac = sec_jac_num 
  1384) 
  1385)   endif
  1386)   
  1387) 
  1388) end subroutine SecondaryRTResJacMulti
  1389) 
  1390) ! ************************************************************************** !
  1391) 
  1392) subroutine SecondaryRTUpdateIterate(line_search,P0,dP,P1,dX_changed, &
  1393)                                     X1_changed,realization,ierr)
  1394)   ! 
  1395)   ! Checks update after the update is done
  1396)   ! 
  1397)   ! Author: Satish Karra, LANL
  1398)   ! Date: 02/22/13
  1399)   ! 
  1400) 
  1401)   use Realization_Subsurface_class
  1402)   use Option_module
  1403)   use Grid_module
  1404)   use Reaction_Aux_module
  1405)   use Reactive_Transport_Aux_module
  1406)   use Global_Aux_module
  1407)  
  1408)   implicit none
  1409)   
  1410)   SNESLineSearch :: line_search
  1411)   Vec :: P0
  1412)   Vec :: dP
  1413)   Vec :: P1
  1414)   class(realization_subsurface_type) :: realization
  1415)   ! ignore changed flag for now.
  1416)   PetscBool :: dX_changed
  1417)   PetscBool :: X1_changed
  1418)   
  1419)   type(option_type), pointer :: option
  1420)   type(grid_type), pointer :: grid
  1421)   type(reactive_transport_auxvar_type), pointer :: rt_auxvars(:)
  1422)   type(sec_transport_type), pointer :: rt_sec_transport_vars(:)
  1423)   type(global_auxvar_type), pointer :: global_auxvars(:)
  1424)   type(reaction_type), pointer :: reaction
  1425)   PetscInt :: local_id, ghosted_id
  1426)   PetscReal :: sec_diffusion_coefficient
  1427)   PetscReal :: sec_porosity
  1428)   PetscErrorCode :: ierr
  1429)   PetscReal :: inf_norm_sec
  1430)   PetscReal :: max_inf_norm_sec
  1431)   
  1432)   option => realization%option
  1433)   grid => realization%patch%grid
  1434)   rt_auxvars => realization%patch%aux%RT%auxvars
  1435)   global_auxvars => realization%patch%aux%Global%auxvars
  1436)   reaction => realization%reaction
  1437)   if (option%use_mc) then
  1438)     rt_sec_transport_vars => realization%patch%aux%SC_RT%sec_transport_vars
  1439)   endif  
  1440)   
  1441)   dX_changed = PETSC_FALSE
  1442)   X1_changed = PETSC_FALSE
  1443)   
  1444)   max_inf_norm_sec = 0.d0
  1445)   
  1446)   if (option%use_mc) then
  1447)     do local_id = 1, grid%nlmax
  1448)       ghosted_id = grid%nL2G(local_id)
  1449)       if (realization%patch%imat(ghosted_id) <= 0) cycle
  1450)       sec_diffusion_coefficient = realization%patch% &
  1451)                                   material_property_array(1)%ptr% &
  1452)                                   secondary_continuum_diff_coeff
  1453)       sec_porosity = realization%patch%material_property_array(1)%ptr% &
  1454)                     secondary_continuum_porosity
  1455) 
  1456)       call SecondaryRTAuxVarComputeMulti(&
  1457)                                     rt_sec_transport_vars(local_id), &
  1458)                                     reaction, &
  1459)                                     option)              
  1460)  
  1461)       call SecondaryRTCheckResidual(rt_sec_transport_vars(local_id), &
  1462)                                     rt_auxvars(ghosted_id), &
  1463)                                     global_auxvars(ghosted_id), &
  1464)                                     reaction,sec_diffusion_coefficient, &
  1465)                                     sec_porosity,option,inf_norm_sec)
  1466)                                       
  1467)       max_inf_norm_sec = max(max_inf_norm_sec,inf_norm_sec)                                                                   
  1468)     enddo 
  1469)     call MPI_Allreduce(max_inf_norm_sec,option%infnorm_res_sec,ONE_INTEGER_MPI, &
  1470)                        MPI_DOUBLE_PRECISION, &
  1471)                        MPI_MAX,option%mycomm,ierr)
  1472)   endif
  1473)   
  1474)       
  1475) end subroutine SecondaryRTUpdateIterate
  1476) 
  1477) ! ************************************************************************** !
  1478) 
  1479) subroutine SecondaryRTUpdateEquilState(sec_transport_vars,global_auxvars, &
  1480)                                        reaction,option) 
  1481)   ! 
  1482)   ! Updates the equilibrium secondary continuum
  1483)   ! variables
  1484)   ! at the end of time step
  1485)   ! 
  1486)   ! Author: Satish Karra, LANL; Glenn Hammond (modification)
  1487)   ! Date: 02/22/13; 06/27/13
  1488)   ! 
  1489)                                      
  1490) 
  1491)   use Option_module
  1492)   use Reaction_Aux_module
  1493)   use Reactive_Transport_Aux_module
  1494)   use Reaction_module
  1495)   use Global_Aux_module
  1496)  
  1497)   implicit none
  1498)   
  1499) 
  1500)   type(option_type), pointer :: option
  1501)   type(sec_transport_type) :: sec_transport_vars
  1502)   type(global_auxvar_type) :: global_auxvars
  1503)   type(reaction_type), pointer :: reaction
  1504)   PetscInt :: ngcells,ncomp
  1505)   PetscInt :: i,j
  1506)   
  1507)   ngcells = sec_transport_vars%ncells
  1508)   ncomp = reaction%naqcomp
  1509)                    
  1510)   do j = 1, ncomp
  1511)     do i = 1, ngcells
  1512)       sec_transport_vars%sec_rt_auxvar(i)%pri_molal(j) = sec_transport_vars%&
  1513)         updated_conc(j,i)
  1514)     enddo
  1515)   enddo
  1516)     
  1517)   do i = 1, ngcells
  1518)     call RTotal(sec_transport_vars%sec_rt_auxvar(i),global_auxvars, &
  1519)                 reaction,option)
  1520)   enddo
  1521)   
  1522) end subroutine SecondaryRTUpdateEquilState
  1523) 
  1524) ! ************************************************************************** !
  1525) 
  1526) subroutine SecondaryRTUpdateKineticState(sec_transport_vars,global_auxvars, &
  1527)                                          reaction,porosity,option) 
  1528)   ! 
  1529)   ! Updates the kinetic secondary continuum
  1530)   ! variables at the end of time step
  1531)   ! 
  1532)   ! Author: Satish Karra, LANL; Glenn Hammond (modification)
  1533)   ! Date: 02/22/13; 06/27/13
  1534)   ! 
  1535)                                      
  1536) 
  1537)   use Option_module
  1538)   use Reaction_Aux_module
  1539)   use Reactive_Transport_Aux_module
  1540)   use Reaction_module
  1541)   use Global_Aux_module
  1542)   use Material_Aux_class
  1543)  
  1544)   implicit none
  1545)   
  1546) 
  1547)   type(option_type), pointer :: option
  1548)   type(sec_transport_type) :: sec_transport_vars
  1549)   type(global_auxvar_type) :: global_auxvars
  1550)   type(reaction_type), pointer :: reaction
  1551)   PetscReal :: porosity
  1552)   PetscInt :: ngcells
  1553)   PetscReal :: vol(sec_transport_vars%ncells)
  1554)   PetscReal :: res_react(reaction%naqcomp)
  1555)   PetscReal :: jac_react(reaction%naqcomp,reaction%naqcomp)
  1556)   PetscInt :: i,j
  1557)   class(material_auxvar_type), allocatable :: material_auxvar
  1558)   
  1559)   ngcells = sec_transport_vars%ncells
  1560)   vol = sec_transport_vars%vol     
  1561)                    
  1562)   res_react = 0.d0
  1563)   jac_react = 0.d0 ! These are not used anyway
  1564)   allocate(material_auxvar)
  1565)   call MaterialAuxVarInit(material_auxvar,option)
  1566)   do i = 1, ngcells
  1567)     material_auxvar%porosity = porosity
  1568)     material_auxvar%volume = vol(i)
  1569)     call RReaction(res_react,jac_react,PETSC_FALSE, &
  1570)                    sec_transport_vars%sec_rt_auxvar(i), &
  1571)                    global_auxvars,material_auxvar,reaction,option)
  1572)   enddo
  1573)   call MaterialAuxVarStrip(material_auxvar)
  1574)   deallocate(material_auxvar)
  1575)   
  1576)   if (reaction%mineral%nkinmnrl > 0) then
  1577)     do i = 1, ngcells
  1578)       do j = 1, reaction%mineral%nkinmnrl
  1579)         sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) = &
  1580)           sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) + &
  1581)           sec_transport_vars%sec_rt_auxvar(i)%mnrl_rate(j)* &
  1582)           reaction%mineral%kinmnrl_molar_vol(j)* &
  1583)           option%tran_dt
  1584)           if (sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) < 0.d0) &
  1585)             sec_transport_vars%sec_rt_auxvar(i)%mnrl_volfrac(j) = 0.d0
  1586)       enddo
  1587)     enddo
  1588)   endif
  1589) 
  1590)   
  1591) end subroutine SecondaryRTUpdateKineticState
  1592) 
  1593) ! ************************************************************************** !
  1594) 
  1595) subroutine SecondaryRTCheckResidual(sec_transport_vars,auxvar, &
  1596)                                     global_auxvar, &
  1597)                                     reaction,diffusion_coefficient, &
  1598)                                     porosity,option,inf_norm_sec)
  1599)   ! 
  1600)   ! The residual of the secondary domain are checked
  1601)   ! to ensure convergence
  1602)   ! 
  1603)   ! Author: Satish Karra, LANL
  1604)   ! Date: 1/31/13
  1605)   ! 
  1606)                                     
  1607)   use Option_module 
  1608)   use Global_Aux_module
  1609)   use Block_Solve_module
  1610)   use Block_Tridiag_module
  1611)   use Utility_module
  1612)   use Reaction_module
  1613)   use Reaction_Aux_module
  1614)   use Reactive_Transport_Aux_module
  1615)   use Material_Aux_class
  1616) 
  1617)   implicit none
  1618)   
  1619)   type(sec_transport_type) :: sec_transport_vars
  1620)   type(reactive_transport_auxvar_type) :: auxvar
  1621)   type(reactive_transport_auxvar_type) :: rt_auxvar
  1622)   type(global_auxvar_type) :: global_auxvar
  1623)   type(reaction_type), pointer :: reaction
  1624)   type(option_type) :: option
  1625)   
  1626)   PetscReal :: res(sec_transport_vars%ncells*reaction%naqcomp)
  1627)   PetscReal :: conc_upd(reaction%naqcomp,sec_transport_vars%ncells) 
  1628)   PetscReal :: total_upd(reaction%naqcomp,sec_transport_vars%ncells)
  1629)   PetscReal :: total_prev(reaction%naqcomp,sec_transport_vars%ncells)
  1630)   PetscReal :: total_primary_node(reaction%naqcomp)
  1631)   PetscReal :: area(sec_transport_vars%ncells)
  1632)   PetscReal :: vol(sec_transport_vars%ncells)
  1633)   PetscReal :: dm_plus(sec_transport_vars%ncells)
  1634)   PetscReal :: dm_minus(sec_transport_vars%ncells)
  1635)   PetscReal :: res_react(reaction%naqcomp)
  1636)   PetscReal :: jac_react(reaction%naqcomp,reaction%naqcomp)
  1637)   PetscInt :: i, j, k, n
  1638)   PetscInt :: ngcells, ncomp
  1639)   PetscReal :: area_fm
  1640)   PetscReal :: diffusion_coefficient
  1641)   PetscReal :: porosity
  1642)   PetscReal :: arrhenius_factor
  1643)   PetscReal :: pordt, pordiff
  1644)   PetscReal :: inf_norm_sec
  1645)   class(material_auxvar_type), allocatable :: material_auxvar
  1646) 
  1647)   PetscReal :: total_sorb_upd(reaction%naqcomp,sec_transport_vars%ncells) 
  1648)   PetscReal :: total_sorb_prev(reaction%naqcomp,sec_transport_vars%ncells)
  1649)   
  1650)   ngcells = sec_transport_vars%ncells
  1651)   area = sec_transport_vars%area
  1652)   vol = sec_transport_vars%vol          
  1653)   dm_plus = sec_transport_vars%dm_plus
  1654)   dm_minus = sec_transport_vars%dm_minus
  1655)   area_fm = sec_transport_vars%interfacial_area
  1656)   ncomp = reaction%naqcomp
  1657) 
  1658)   do j = 1, ncomp
  1659)     do i = 1, ngcells
  1660)       total_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total(j,1)
  1661)       if (reaction%neqsorb > 0) then
  1662)         total_sorb_prev(j,i) = sec_transport_vars%sec_rt_auxvar(i)%total_sorb_eq(j)
  1663)       endif
  1664)     enddo
  1665)   enddo
  1666)   conc_upd = sec_transport_vars%updated_conc
  1667)     
  1668)   ! Note that sec_transport_vars%sec_rt_auxvar(i)%pri_molal(j) units are in mol/kg
  1669)   ! Need to convert to mol/L since the units of total. in the Thomas 
  1670)   ! algorithm are in mol/L 
  1671)   
  1672)   res = 0.d0
  1673)   
  1674)   total_primary_node = auxvar%total(:,1)                         ! in mol/L 
  1675)   pordt = porosity/option%tran_dt
  1676)   pordiff = porosity*diffusion_coefficient
  1677) 
  1678)   call RTAuxVarInit(rt_auxvar,reaction,option)
  1679)   do i = 1, ngcells
  1680)     call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i),option)
  1681)     rt_auxvar%pri_molal = conc_upd(:,i)
  1682)     call RTotal(rt_auxvar,global_auxvar,reaction,option)
  1683)     if (reaction%neqsorb > 0) then
  1684)       call SecondaryRTotalSorb(rt_auxvar,global_auxvar,material_auxvar,reaction,option)
  1685)     endif
  1686)     total_upd(:,i) = rt_auxvar%total(:,1)
  1687)     if (reaction%neqsorb > 0) then 
  1688)       total_sorb_upd(:,i) = rt_auxvar%total_sorb_eq(:)
  1689)     endif
  1690)   enddo
  1691)                                     
  1692) !================ Calculate the secondary residual =============================        
  1693) 
  1694)   do j = 1, ncomp
  1695)       
  1696)     ! Accumulation
  1697)     do i = 1, ngcells
  1698)       n = j + (i-1)*ncomp
  1699)       res(n) = pordt*(total_upd(j,i) - total_prev(j,i))*vol(i)    ! in mol/L*m3/s
  1700)       if (reaction%neqsorb > 0) then 
  1701)         res(n) = res(n) + vol(i)/option%tran_dt*(total_sorb_upd(j,i) - total_sorb_prev(j,i))
  1702)       endif 
  1703)     enddo
  1704)   
  1705)     ! Flux terms
  1706)     do i = 2, ngcells - 1
  1707)       n = j + (i-1)*ncomp
  1708)       res(n) = res(n) - pordiff*area(i)/(dm_minus(i+1) + dm_plus(i))* &
  1709)                         (total_upd(j,i+1) - total_upd(j,i))
  1710)       res(n) = res(n) + pordiff*area(i-1)/(dm_minus(i) + dm_plus(i-1))* &
  1711)                         (total_upd(j,i) - total_upd(j,i-1))                      
  1712)     enddo
  1713)          
  1714)               
  1715)     ! Apply boundary conditions
  1716)     ! Inner boundary
  1717)     res(j) = res(j) - pordiff*area(1)/(dm_minus(2) + dm_plus(1))* &
  1718)                       (total_upd(j,2) - total_upd(j,1))
  1719)                                       
  1720)     ! Outer boundary
  1721)     res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) - &
  1722)                                pordiff*area(ngcells)/dm_plus(ngcells)* &
  1723)                                (total_primary_node(j) - total_upd(j,ngcells))
  1724)     res(j+(ngcells-1)*ncomp) = res(j+(ngcells-1)*ncomp) + &
  1725)                                pordiff*area(ngcells-1)/(dm_minus(ngcells) &
  1726)                                + dm_plus(ngcells-1))*(total_upd(j,ngcells) - &
  1727)                                total_upd(j,ngcells-1))  
  1728)                                
  1729)   enddo
  1730)                          
  1731)   res = res*1.d3 ! Convert mol/L*m3/s to mol/s                                             
  1732)                                     
  1733)                                     
  1734) !====================== Add reaction contributions =============================        
  1735)   
  1736)   ! Reaction 
  1737)   allocate(material_auxvar)
  1738)   call MaterialAuxVarInit(material_auxvar,option)
  1739)   do i = 1, ngcells
  1740)     res_react = 0.d0
  1741)     jac_react = 0.d0
  1742)     call RTAuxVarCopy(rt_auxvar,sec_transport_vars%sec_rt_auxvar(i), &
  1743)                       option)
  1744)     rt_auxvar%pri_molal = conc_upd(:,i) ! in mol/kg
  1745)     call RTotal(rt_auxvar,global_auxvar,reaction,option)
  1746)     material_auxvar%porosity = porosity
  1747)     material_auxvar%volume = vol(i)
  1748)     call RReaction(res_react,jac_react,PETSC_FALSE, &
  1749)                    rt_auxvar,global_auxvar,material_auxvar,reaction,option)                     
  1750)     do j = 1, ncomp
  1751)       res(j+(i-1)*ncomp) = res(j+(i-1)*ncomp) + res_react(j) 
  1752)     enddo
  1753)   enddo  
  1754)   call MaterialAuxVarStrip(material_auxvar)         
  1755)   deallocate(material_auxvar)
  1756)   
  1757)  ! Need to decide how to scale the residual with volumes
  1758)   do i = 1, ngcells
  1759)     do j = 1, ncomp
  1760)       res(j+(i-1)*ncomp) = res(j+(i-1)*ncomp)/vol(i)
  1761)     enddo
  1762)   enddo
  1763)     
  1764)   inf_norm_sec = maxval(abs(res))  
  1765)   call RTAuxVarStrip(rt_auxvar)  
  1766)                                                                       
  1767) end subroutine SecondaryRTCheckResidual                                    
  1768) 
  1769) ! ************************************************************************** !
  1770) 
  1771) subroutine SecondaryRTAuxVarComputeMulti(sec_transport_vars,reaction, &
  1772)                                          option)
  1773)   ! 
  1774)   ! Updates the secondary continuum
  1775)   ! concentrations at end of each time step for multicomponent system
  1776)   ! 
  1777)   ! Author: Satish Karra, LANL
  1778)   ! Date: 2/1/13
  1779)   ! 
  1780)                                
  1781)                             
  1782)   use Option_module 
  1783)   use Reaction_Aux_module
  1784)   use Reaction_module
  1785)   use Reactive_Transport_Aux_module
  1786)   use Block_Solve_module
  1787)   use Block_Tridiag_module
  1788)   use Utility_module
  1789)   
  1790) 
  1791)   implicit none
  1792)   
  1793)   type(sec_transport_type) :: sec_transport_vars
  1794)   type(reaction_type), pointer :: reaction
  1795)   type(option_type) :: option
  1796)   PetscReal :: coeff_left(reaction%naqcomp,reaction%naqcomp, &
  1797)                  sec_transport_vars%ncells)
  1798)   PetscReal :: coeff_diag(reaction%naqcomp,reaction%naqcomp, &
  1799)                  sec_transport_vars%ncells)
  1800)   PetscReal :: coeff_right(reaction%naqcomp,reaction%naqcomp, &
  1801)                  sec_transport_vars%ncells)
  1802)   PetscReal :: rhs(sec_transport_vars%ncells*reaction%naqcomp)
  1803)   PetscReal :: conc_upd(reaction%naqcomp,sec_transport_vars%ncells) 
  1804)   PetscInt :: i, j, n
  1805)   PetscInt :: ngcells, ncomp
  1806)   PetscInt :: pivot(reaction%naqcomp,sec_transport_vars%ncells)
  1807)   PetscInt :: indx(reaction%naqcomp)
  1808)   PetscInt :: d
  1809)     
  1810)   ngcells = sec_transport_vars%ncells
  1811)   ncomp = reaction%naqcomp
  1812)   ! Note that sec_transport_vars%sec_conc units are in mol/kg
  1813)   ! Need to convert to mol/L since the units of conc. in the Thomas 
  1814)   ! algorithm are in mol/L 
  1815)   
  1816)   coeff_left = 0.d0
  1817)   coeff_diag = 0.d0
  1818)   coeff_right = 0.d0
  1819)   rhs = 0.d0
  1820) 
  1821)   conc_upd = sec_transport_vars%updated_conc
  1822)            
  1823)   ! Use the stored coefficient matrices from LU decomposition of the
  1824)   ! block triagonal sytem
  1825)   coeff_left = sec_transport_vars%cxm
  1826)   coeff_right = sec_transport_vars%cxp
  1827)   coeff_diag = sec_transport_vars%cdl
  1828)   rhs = sec_transport_vars%r
  1829)     
  1830)   select case (option%secondary_continuum_solver)
  1831)     case(1) 
  1832)       call bl3dsolb(ngcells,ncomp,coeff_right,coeff_diag,coeff_left,pivot, &
  1833)                     ONE_INTEGER,rhs)
  1834)     case(2)
  1835)       call solbtb(ncomp,ngcells,ncomp,coeff_diag,coeff_right,coeff_left, &
  1836)                   pivot,rhs)
  1837)     case(3)
  1838)       do i = ngcells-1, 1, -1
  1839)         rhs(i) = (rhs(i) - coeff_right(ncomp,ncomp,i)*rhs(i+1))/ &
  1840)                              coeff_diag(ncomp,ncomp,i)
  1841)       enddo
  1842)     case default
  1843)       option%io_buffer = 'SECONDARY_CONTINUUM_SOLVER can be only ' // &
  1844)                          'HINDMARSH or KEARST. For single component'// &
  1845)                          'chemistry THOMAS can be used.'
  1846)       call printErrMsg(option)  
  1847)   end select  
  1848)   
  1849)   do j = 1, ncomp
  1850)     do i = 1, ngcells
  1851)       n = j + (i - 1)*ncomp
  1852)       if (reaction%use_log_formulation) then 
  1853)         ! convert log concentration to concentration
  1854)         rhs(n) = dsign(1.d0,rhs(n))*min(dabs(rhs(n)),reaction%max_dlnC) 
  1855)         conc_upd(j,i) = exp(rhs(n))*conc_upd(j,i)
  1856)       else
  1857)         conc_upd(j,i) = rhs(n) + conc_upd(j,i)
  1858)       endif
  1859)       if (conc_upd(j,i) < 0.d0) conc_upd(j,i) = 1.d-8
  1860)     enddo
  1861)   enddo
  1862)   
  1863)   sec_transport_vars%updated_conc = conc_upd
  1864)     
  1865) end subroutine SecondaryRTAuxVarComputeMulti
  1866) 
  1867) ! ************************************************************************** !
  1868) 
  1869) subroutine THCSecHeatAuxVarCompute(sec_heat_vars,global_auxvar, &
  1870)                                    therm_conductivity,dencpr, &
  1871)                                    option)
  1872)   ! 
  1873)   ! Computes secondary auxillary variables for each
  1874)   ! grid cell for heat transfer only
  1875)   ! 
  1876)   ! Author: Satish Karra, LANL
  1877)   ! Date: 06/5/12
  1878)   ! 
  1879) 
  1880)   use Option_module 
  1881)   use Global_Aux_module
  1882)   
  1883)   implicit none
  1884)   
  1885)   type(sec_heat_type) :: sec_heat_vars
  1886)   type(global_auxvar_type) :: global_auxvar
  1887)   type(option_type) :: option
  1888)   PetscReal :: coeff_left(sec_heat_vars%ncells)
  1889)   PetscReal :: coeff_diag(sec_heat_vars%ncells)
  1890)   PetscReal :: coeff_right(sec_heat_vars%ncells)
  1891)   PetscReal :: rhs(sec_heat_vars%ncells)
  1892)   PetscReal :: sec_temp(sec_heat_vars%ncells)
  1893)   PetscReal :: area(sec_heat_vars%ncells)
  1894)   PetscReal :: vol(sec_heat_vars%ncells)
  1895)   PetscReal :: dm_plus(sec_heat_vars%ncells)
  1896)   PetscReal :: dm_minus(sec_heat_vars%ncells)
  1897)   PetscInt :: i, ngcells
  1898)   PetscReal :: area_fm
  1899)   PetscReal :: alpha, therm_conductivity, dencpr
  1900)   PetscReal :: temp_primary_node
  1901)   PetscReal :: m
  1902)   
  1903)   ngcells = sec_heat_vars%ncells
  1904)   area = sec_heat_vars%area
  1905)   vol = sec_heat_vars%vol
  1906)   dm_plus = sec_heat_vars%dm_plus
  1907)   dm_minus = sec_heat_vars%dm_minus
  1908)   area_fm = sec_heat_vars%interfacial_area
  1909)   temp_primary_node = global_auxvar%temp
  1910)   
  1911)   coeff_left = 0.d0
  1912)   coeff_diag = 0.d0
  1913)   coeff_right = 0.d0
  1914)   rhs = 0.d0
  1915)   sec_temp = 0.d0
  1916)   
  1917)   alpha = option%flow_dt*therm_conductivity/dencpr
  1918) 
  1919)   
  1920)   ! Setting the coefficients
  1921)   do i = 2, ngcells-1
  1922)     coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
  1923)     coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
  1924)                     alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
  1925)     coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
  1926)   enddo
  1927)   
  1928)   coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
  1929)   coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
  1930)   
  1931)   coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
  1932)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
  1933)   coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
  1934)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
  1935)                        + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
  1936)                        + 1.d0
  1937) 
  1938)                         
  1939)   rhs = sec_heat_vars%sec_temp  ! secondary continuum values from previous time step
  1940)   rhs(ngcells) = rhs(ngcells) + & 
  1941)                  alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
  1942)                  temp_primary_node
  1943)                 
  1944)   ! Thomas algorithm for tridiagonal system
  1945)   ! Forward elimination
  1946)   do i = 2, ngcells
  1947)     m = coeff_left(i)/coeff_diag(i-1)
  1948)     coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
  1949)     rhs(i) = rhs(i) - m*rhs(i-1)
  1950)   enddo
  1951) 
  1952)   ! Back substitution
  1953)   ! Calculate temperature in the secondary continuum
  1954)   sec_temp(ngcells) = rhs(ngcells)/coeff_diag(ngcells)
  1955)   do i = ngcells-1, 1, -1
  1956)     sec_temp(i) = (rhs(i) - coeff_right(i)*sec_temp(i+1))/coeff_diag(i)
  1957)   enddo
  1958)   
  1959)   sec_heat_vars%sec_temp = sec_temp
  1960)             
  1961) end subroutine THCSecHeatAuxVarCompute
  1962) 
  1963) ! ************************************************************************** !
  1964) 
  1965) subroutine THSecHeatAuxVarCompute(sec_heat_vars,global_auxvar, &
  1966)                                    therm_conductivity,dencpr, &
  1967)                                    option)
  1968)   ! 
  1969)   ! Computes secondary auxillary variables for each
  1970)   ! grid cell for heat transfer only
  1971)   ! 
  1972)   ! Author: Satish Karra, LANL
  1973)   ! Date: 06/5/12
  1974)   ! 
  1975) 
  1976)   use Option_module 
  1977)   use Global_Aux_module
  1978)   
  1979)   implicit none
  1980)   
  1981)   type(sec_heat_type) :: sec_heat_vars
  1982)   type(global_auxvar_type) :: global_auxvar
  1983)   type(option_type) :: option
  1984)   PetscReal :: coeff_left(sec_heat_vars%ncells)
  1985)   PetscReal :: coeff_diag(sec_heat_vars%ncells)
  1986)   PetscReal :: coeff_right(sec_heat_vars%ncells)
  1987)   PetscReal :: rhs(sec_heat_vars%ncells)
  1988)   PetscReal :: sec_temp(sec_heat_vars%ncells)
  1989)   PetscReal :: area(sec_heat_vars%ncells)
  1990)   PetscReal :: vol(sec_heat_vars%ncells)
  1991)   PetscReal :: dm_plus(sec_heat_vars%ncells)
  1992)   PetscReal :: dm_minus(sec_heat_vars%ncells)
  1993)   PetscInt :: i, ngcells
  1994)   PetscReal :: area_fm
  1995)   PetscReal :: alpha, therm_conductivity, dencpr
  1996)   PetscReal :: temp_primary_node
  1997)   PetscReal :: m
  1998)   
  1999)   ngcells = sec_heat_vars%ncells
  2000)   area = sec_heat_vars%area
  2001)   vol = sec_heat_vars%vol
  2002)   dm_plus = sec_heat_vars%dm_plus
  2003)   dm_minus = sec_heat_vars%dm_minus
  2004)   area_fm = sec_heat_vars%interfacial_area
  2005)   temp_primary_node = global_auxvar%temp
  2006)   
  2007)   coeff_left = 0.d0
  2008)   coeff_diag = 0.d0
  2009)   coeff_right = 0.d0
  2010)   rhs = 0.d0
  2011)   sec_temp = 0.d0
  2012)   
  2013)   alpha = option%flow_dt*therm_conductivity/dencpr
  2014) 
  2015)   
  2016)   ! Setting the coefficients
  2017)   do i = 2, ngcells-1
  2018)     coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
  2019)     coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
  2020)                     alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
  2021)     coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
  2022)   enddo
  2023)   
  2024)   coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
  2025)   coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
  2026)   
  2027)   coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
  2028)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
  2029)   coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
  2030)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
  2031)                        + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
  2032)                        + 1.d0
  2033) 
  2034)                         
  2035)   rhs = sec_heat_vars%sec_temp  ! secondary continuum values from previous time step
  2036)   rhs(ngcells) = rhs(ngcells) + & 
  2037)                  alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
  2038)                  temp_primary_node
  2039)                 
  2040)   ! Thomas algorithm for tridiagonal system
  2041)   ! Forward elimination
  2042)   do i = 2, ngcells
  2043)     m = coeff_left(i)/coeff_diag(i-1)
  2044)     coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
  2045)     rhs(i) = rhs(i) - m*rhs(i-1)
  2046)   enddo
  2047) 
  2048)   ! Back substitution
  2049)   ! Calculate temperature in the secondary continuum
  2050)   sec_temp(ngcells) = rhs(ngcells)/coeff_diag(ngcells)
  2051)   do i = ngcells-1, 1, -1
  2052)     sec_temp(i) = (rhs(i) - coeff_right(i)*sec_temp(i+1))/coeff_diag(i)
  2053)   enddo
  2054)   
  2055)   sec_heat_vars%sec_temp = sec_temp
  2056)             
  2057) end subroutine THSecHeatAuxVarCompute
  2058) 
  2059) ! ************************************************************************** !
  2060) 
  2061) subroutine MphaseSecHeatAuxVarCompute(sec_heat_vars,auxvar,global_auxvar, &
  2062)                                    therm_conductivity,dencpr, &
  2063)                                    option)
  2064)   ! 
  2065)   ! Computes secondary auxillary variables in each
  2066)   ! grid cell for heat transfer only
  2067)   ! 
  2068)   ! Author: Satish Karra, LANL
  2069)   ! Date: 06/28/12
  2070)   ! 
  2071) 
  2072)   use Option_module 
  2073)   use Global_Aux_module
  2074)   use Mphase_Aux_module
  2075)   
  2076)   implicit none
  2077)   
  2078)   type(sec_heat_type) :: sec_heat_vars
  2079)   type(mphase_auxvar_elem_type) :: auxvar
  2080)   type(global_auxvar_type) :: global_auxvar
  2081)   type(option_type) :: option
  2082)   PetscReal :: coeff_left(sec_heat_vars%ncells)
  2083)   PetscReal :: coeff_diag(sec_heat_vars%ncells)
  2084)   PetscReal :: coeff_right(sec_heat_vars%ncells)
  2085)   PetscReal :: rhs(sec_heat_vars%ncells)
  2086)   PetscReal :: sec_temp(sec_heat_vars%ncells)
  2087)   PetscReal :: area(sec_heat_vars%ncells)
  2088)   PetscReal :: vol(sec_heat_vars%ncells)
  2089)   PetscReal :: dm_plus(sec_heat_vars%ncells)
  2090)   PetscReal :: dm_minus(sec_heat_vars%ncells)
  2091)   PetscInt :: i, ngcells
  2092)   PetscReal :: area_fm
  2093)   PetscReal :: alpha, therm_conductivity, dencpr
  2094)   PetscReal :: temp_primary_node
  2095)   PetscReal :: m
  2096)   
  2097)   
  2098)   ngcells = sec_heat_vars%ncells
  2099)   area = sec_heat_vars%area
  2100)   vol = sec_heat_vars%vol
  2101)   dm_plus = sec_heat_vars%dm_plus
  2102)   dm_minus = sec_heat_vars%dm_minus
  2103)   area_fm = sec_heat_vars%interfacial_area
  2104)   temp_primary_node = auxvar%temp
  2105) 
  2106)   
  2107)   coeff_left = 0.d0
  2108)   coeff_diag = 0.d0
  2109)   coeff_right = 0.d0
  2110)   rhs = 0.d0
  2111)   sec_temp = 0.d0
  2112)   
  2113)   alpha = option%flow_dt*therm_conductivity/dencpr
  2114) 
  2115)   
  2116)   ! Setting the coefficients
  2117)   do i = 2, ngcells-1
  2118)     coeff_left(i) = -alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i))
  2119)     coeff_diag(i) = alpha*area(i-1)/((dm_minus(i) + dm_plus(i-1))*vol(i)) + &
  2120)                     alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i)) + 1.d0
  2121)     coeff_right(i) = -alpha*area(i)/((dm_minus(i+1) + dm_plus(i))*vol(i))
  2122)   enddo
  2123)   
  2124)   coeff_diag(1) = alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1)) + 1.d0
  2125)   coeff_right(1) = -alpha*area(1)/((dm_minus(2) + dm_plus(1))*vol(1))
  2126)   
  2127)   coeff_left(ngcells) = -alpha*area(ngcells-1)/ &
  2128)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells))
  2129)   coeff_diag(ngcells) = alpha*area(ngcells-1)/ &
  2130)                        ((dm_minus(ngcells) + dm_plus(ngcells-1))*vol(ngcells)) &
  2131)                        + alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells)) &
  2132)                        + 1.d0
  2133)                         
  2134)   rhs = sec_heat_vars%sec_temp  ! secondary continuum values from previous time step
  2135)   rhs(ngcells) = rhs(ngcells) + & 
  2136)                  alpha*area(ngcells)/(dm_plus(ngcells)*vol(ngcells))* &
  2137)                  temp_primary_node
  2138)                 
  2139)   ! Thomas algorithm for tridiagonal system
  2140)   ! Forward elimination
  2141)   do i = 2, ngcells
  2142)     m = coeff_left(i)/coeff_diag(i-1)
  2143)     coeff_diag(i) = coeff_diag(i) - m*coeff_right(i-1)
  2144)     rhs(i) = rhs(i) - m*rhs(i-1)
  2145)   enddo
  2146) 
  2147)   ! Back substitution
  2148)   ! Calculate temperature in the secondary continuum
  2149)   sec_temp(ngcells) = rhs(ngcells)/coeff_diag(ngcells)
  2150)   do i = ngcells-1, 1, -1
  2151)     sec_temp(i) = (rhs(i) - coeff_right(i)*sec_temp(i+1))/coeff_diag(i)
  2152)   enddo
  2153) 
  2154) ! print *,'temp_dcdm= ',(sec_temp(i),i=1,ngcells)
  2155)   
  2156)   sec_heat_vars%sec_temp = sec_temp
  2157) 
  2158) 
  2159) end subroutine MphaseSecHeatAuxVarCompute
  2160) 
  2161) ! ************************************************************************** !
  2162) 
  2163) subroutine SecondaryRTotalSorb(rt_auxvar,global_auxvar,material_auxvar,reaction, &
  2164)                                option)
  2165)   ! 
  2166)   ! Computes the secondary total sorbed component concentrations and
  2167)   ! derivative with respect to free-ion
  2168)   ! 
  2169)   ! Author: Satish Karra, LANL
  2170)   ! Date: 02/20/2014
  2171)   ! 
  2172) 
  2173)   use Option_module
  2174)   use Global_Aux_module
  2175)   use Reaction_Aux_module
  2176)   use Reaction_module
  2177)   use Reactive_Transport_Aux_module
  2178)   use Material_Aux_class
  2179)   
  2180)   implicit none
  2181)   
  2182)   type(reactive_transport_auxvar_type) :: rt_auxvar
  2183)   type(global_auxvar_type) :: global_auxvar
  2184)   class(material_auxvar_type) :: material_auxvar
  2185)   type(reaction_type) :: reaction
  2186)   type(option_type) :: option
  2187)   
  2188)   call RZeroSorb(rt_auxvar)
  2189)   
  2190)   if (reaction%neqkdrxn > 0) then
  2191)     call SecondaryRTotalSorbKD(rt_auxvar,global_auxvar,material_auxvar, &
  2192)                                reaction,option)
  2193)   endif
  2194)   
  2195) end subroutine SecondaryRTotalSorb
  2196) 
  2197) ! ************************************************************************** !
  2198) 
  2199) subroutine SecondaryRTotalSorbKD(rt_auxvar,global_auxvar,material_auxvar,reaction, &
  2200)                         option)
  2201)   ! 
  2202)   ! Computes the total sorbed component concentrations and
  2203)   ! derivative with respect to free-ion for the linear
  2204)   ! K_D model
  2205)   ! 
  2206)   ! Author: Satish Karra, LANL
  2207)   ! Date: 02/20/2014
  2208)   ! 
  2209) 
  2210)   use Option_module
  2211)   use Reaction_Aux_module
  2212)   use Reaction_module
  2213)   use Reactive_Transport_Aux_module
  2214)   use Material_Aux_class
  2215)   use Global_Aux_module
  2216) 
  2217)   implicit none
  2218) 
  2219)   type(reactive_transport_auxvar_type) :: rt_auxvar
  2220)   type(global_auxvar_type) :: global_auxvar
  2221)   class(material_auxvar_type) :: material_auxvar
  2222)   type(reaction_type) :: reaction
  2223)   type(option_type) :: option
  2224)   
  2225)   PetscInt :: irxn
  2226)   PetscInt :: icomp
  2227)   PetscReal :: res
  2228)   PetscReal :: dres_dc
  2229)   PetscReal :: activity
  2230)   PetscReal :: molality
  2231)   PetscReal :: tempreal
  2232)   PetscReal :: one_over_n
  2233)   PetscReal :: activity_one_over_n
  2234) 
  2235)   ! Surface Complexation
  2236)   do irxn = 1, reaction%neqkdrxn
  2237)     icomp = reaction%eqkdspecid(irxn)
  2238)     molality = rt_auxvar%pri_molal(icomp)
  2239)     activity = molality*rt_auxvar%pri_act_coef(icomp) ! Activity coefficient needs?
  2240)     select case(reaction%sec_cont_eqkdtype(irxn))
  2241)       case(SORPTION_LINEAR)
  2242)         ! Csorb = Kd*Caq
  2243)         res = reaction%sec_cont_eqkddistcoef(irxn)*activity
  2244)         dres_dc = res/molality
  2245)       case(SORPTION_LANGMUIR)
  2246)         ! Csorb = K*Caq*b/(1+K*Caq)
  2247)         tempreal = reaction%sec_cont_eqkddistcoef(irxn)*activity
  2248)         res = tempreal*reaction%sec_cont_eqkdlangmuirb(irxn) / (1.d0 + tempreal)
  2249)         dres_dc = res/molality - &
  2250)                   res / (1.d0 + tempreal) * tempreal / molality
  2251)       case(SORPTION_FREUNDLICH)
  2252)         ! Csorb = Kd*Caq**(1/n)
  2253)         one_over_n = 1.d0/reaction%sec_cont_eqkdfreundlichn(irxn)
  2254)         activity_one_over_n = activity**one_over_n
  2255)         res = reaction%sec_cont_eqkddistcoef(irxn)* &
  2256)                 activity**one_over_n
  2257)         dres_dc = res/molality*one_over_n
  2258)       case default
  2259)         res = 0.d0
  2260)         dres_dc = 0.d0
  2261)     end select
  2262)     rt_auxvar%total_sorb_eq(icomp) = rt_auxvar%total_sorb_eq(icomp) + res
  2263)     rt_auxvar%dtotal_sorb_eq(icomp,icomp) = &
  2264)       rt_auxvar%dtotal_sorb_eq(icomp,icomp) + dres_dc 
  2265)   enddo
  2266) 
  2267) end subroutine SecondaryRTotalSorbKD
  2268) 
  2269) 
  2270) end module Secondary_Continuum_module
  2271)             

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