surface_th.F90       coverage:  86.67 %func     64.48 %block


     1) module Surface_TH_module
     2) 
     3)   use Surface_Global_Aux_module
     4)   use Surface_TH_Aux_module
     5)   
     6)   use PFLOTRAN_Constants_module
     7) 
     8)   implicit none
     9)   
    10)   private
    11)   
    12) #include "petsc/finclude/petscsys.h"
    13) 
    14) #include "petsc/finclude/petscvec.h"
    15) #include "petsc/finclude/petscvec.h90"
    16) #include "petsc/finclude/petscmat.h"
    17) #include "petsc/finclude/petscmat.h90"
    18) #include "petsc/finclude/petscsnes.h"
    19) #include "petsc/finclude/petscviewer.h"
    20) #include "petsc/finclude/petsclog.h"
    21) #include "petsc/finclude/petscts.h"
    22) 
    23) ! Cutoff parameters
    24)   PetscReal, parameter :: eps       = 1.D-12
    25)   PetscReal, parameter :: perturbation_tolerance = 1.d-6
    26) 
    27)   public SurfaceTHSetup, &
    28)          SurfaceTHRHSFunction, &
    29)          SurfaceTHIFunction, &
    30)          SurfaceTHComputeMaxDt, &
    31)          SurfaceTHUpdateAuxVars, &
    32)          SurfaceTHUpdateSolution, &
    33)          SurfaceTHUpdateTemperature, &
    34)          SurfaceTHUpdateSurfState, &
    35)          SurfaceTHImplicitAtmForcing, &
    36)          SurfaceTHDestroy
    37) 
    38) contains
    39) 
    40) ! ************************************************************************** !
    41) 
    42) subroutine SurfaceTHSetup(surf_realization)
    43)   ! 
    44)   ! This routine sets up surface_TH_type
    45)   ! 
    46)   ! Author: Gautam Bisht, LBNL
    47)   ! Date: 02/28/13
    48)   ! 
    49) 
    50)   use Realization_Surface_class
    51)   use Patch_module
    52)   use Option_module
    53)   use Grid_module
    54)   use Region_module
    55)   use Coupler_module
    56)   use Connection_module
    57)   use Fluid_module
    58)   use Output_Aux_module
    59)  
    60)   implicit none
    61)   
    62)   class(realization_surface_type) :: surf_realization
    63) 
    64)   type(option_type), pointer :: option
    65)   type(patch_type), pointer :: patch
    66)   type(grid_type), pointer :: grid
    67)   type(coupler_type), pointer :: boundary_condition
    68)   type(Surface_TH_auxvar_type), pointer :: Surf_TH_auxvars(:)
    69)   type(Surface_TH_auxvar_type), pointer :: Surf_TH_auxvars_bc(:)
    70)   type(Surface_TH_auxvar_type), pointer :: Surf_TH_auxvars_ss(:)
    71)   type(fluid_property_type), pointer :: cur_fluid_property
    72)   type(coupler_type), pointer :: initial_condition
    73)   type(output_variable_list_type), pointer :: list
    74)   PetscReal :: area_per_vol
    75) 
    76)   PetscInt :: ghosted_id, iconn, sum_connection
    77)   PetscInt :: i, iphase
    78)   
    79)   option => surf_realization%option
    80)   patch => surf_realization%patch
    81)   grid => patch%grid
    82)     
    83)   patch%surf_aux%SurfaceTH => SurfaceTHAuxCreate(option)
    84) 
    85)   ! allocate auxvar data structures for all grid cells
    86)   allocate(Surf_TH_auxvars(grid%ngmax))
    87)   do ghosted_id = 1, grid%ngmax
    88)     call SurfaceTHAuxVarInit(Surf_TH_auxvars(ghosted_id),option)
    89)   enddo
    90) 
    91)   patch%surf_aux%SurfaceTH%auxvars => Surf_TH_auxvars
    92)   patch%surf_aux%SurfaceTH%num_aux = grid%ngmax
    93) 
    94)   ! count the number of boundary connections and allocate
    95)   ! auxvar data structures for them
    96)   boundary_condition => patch%boundary_condition_list%first
    97) 
    98)   sum_connection = 0    
    99)   do 
   100)     if (.not.associated(boundary_condition)) exit
   101)     sum_connection = sum_connection + &
   102)                      boundary_condition%connection_set%num_connections
   103)     boundary_condition => boundary_condition%next
   104)   enddo
   105) 
   106)   if (sum_connection > 0) then 
   107)     allocate(Surf_TH_auxvars_bc(sum_connection))
   108)     do iconn = 1, sum_connection
   109)       call SurfaceTHAuxVarInit(Surf_TH_auxvars_bc(iconn),option)
   110)     enddo
   111)     patch%surf_aux%SurfaceTH%auxvars_bc => Surf_TH_auxvars_bc
   112)   endif
   113)   patch%surf_aux%SurfaceTH%num_aux_bc = sum_connection
   114) 
   115)   ! Create aux vars for source/sink
   116)   sum_connection = CouplerGetNumConnectionsInList(patch%source_sink_list)
   117)   if (sum_connection > 0) then
   118)     allocate(Surf_TH_auxvars_ss(sum_connection))
   119)     do iconn = 1, sum_connection
   120)       call SurfaceTHAuxVarInit(Surf_TH_auxvars_ss(iconn),option)
   121)     enddo
   122)     patch%surf_aux%SurfaceTH%auxvars_ss => Surf_TH_auxvars_ss
   123)   endif
   124)   patch%surf_aux%SurfaceTH%num_aux_ss = sum_connection
   125) 
   126)   list => surf_realization%output_option%output_snap_variable_list
   127)   call SurfaceTHSetPlotVariables(list)
   128)   list => surf_realization%output_option%output_obs_variable_list
   129)   call SurfaceTHSetPlotVariables(list)
   130) 
   131) end subroutine SurfaceTHSetup
   132) 
   133) ! ************************************************************************** !
   134) 
   135) subroutine SurfaceTHSetPlotVariables(list)
   136)   ! 
   137)   ! This routine adds default variables to be printed to list
   138)   ! 
   139)   ! Author: Gautam Bisht, LBNL
   140)   ! Date: 02/28/13
   141)   ! 
   142)   
   143)   use Realization_Surface_class
   144)   use Output_Aux_module
   145)   use Variables_module
   146)     
   147)   implicit none
   148)   
   149)   type(output_variable_list_type), pointer :: list
   150) 
   151)   character(len=MAXWORDLENGTH) :: name, units
   152)   
   153)   if (associated(list%first)) then
   154)     return
   155)   endif
   156) 
   157)   name = 'H'
   158)   units = 'm'
   159)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   160)                                SURFACE_LIQUID_HEAD)
   161) 
   162)   name = 'Temperature'
   163)   units = 'C'
   164)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   165)                                SURFACE_LIQUID_TEMPERATURE)
   166) 
   167)   name = 'Material ID'
   168)   units = ''
   169)   call OutputVariableAddToList(list,name,OUTPUT_DISCRETE,units, &
   170)                                MATERIAL_ID)
   171)   
   172) end subroutine SurfaceTHSetPlotVariables
   173) 
   174) ! ************************************************************************** !
   175) 
   176) subroutine SurfaceTHRHSFunction(ts,t,xx,ff,surf_realization,ierr)
   177)   ! 
   178)   ! This routine provides the function evaluation for PETSc TSSolve()
   179)   ! Author: Gautam Bisht, LBNL
   180)   ! 
   181) 
   182)   use EOS_Water_module
   183)   use Connection_module
   184)   use Realization_Surface_class
   185)   use Discretization_module
   186)   use Patch_module
   187)   use Grid_module
   188)   use Option_module
   189)   use Coupler_module  
   190)   use Surface_Field_module
   191)   use Debug_module
   192)   use Surface_TH_Aux_module
   193)   use Surface_Global_Aux_module
   194) 
   195)   implicit none
   196)   
   197)   TS :: ts
   198)   PetscReal :: t
   199)   Vec :: xx
   200)   Vec :: ff
   201)   class(realization_surface_type) :: surf_realization
   202)   PetscErrorCode :: ierr
   203) 
   204)   type(grid_type), pointer :: grid
   205)   type(patch_type), pointer :: patch
   206)   type(option_type), pointer :: option
   207)   type(surface_field_type), pointer :: surf_field
   208)   type(coupler_type), pointer :: boundary_condition
   209)   type(coupler_type), pointer :: source_sink
   210)   type(connection_set_list_type), pointer :: connection_set_list
   211)   type(connection_set_type), pointer :: cur_connection_set
   212) 
   213)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars(:)
   214)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars_bc(:)
   215)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars(:)
   216)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_bc(:)
   217)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_ss(:)
   218) 
   219)   PetscInt :: local_id_up, local_id_dn, local_id
   220)   PetscInt :: ghosted_id_up, ghosted_id_dn, ghosted_id
   221)   PetscInt :: iconn
   222)   PetscInt :: sum_connection
   223)   PetscInt :: istart, iend
   224) 
   225)   PetscReal :: dx, dy, dz
   226)   PetscReal :: dist
   227)   PetscReal :: vel
   228)   PetscReal :: slope, slope_dn
   229)   PetscReal :: rho          ! density      [kg/m^3]
   230)   PetscReal :: hw_up, hw_dn ! water height [m]
   231)   PetscReal :: Res(surf_realization%option%nflowdof), v_darcy
   232)   PetscReal :: qsrc, qsrc_flow
   233)   PetscReal :: esrc
   234)   PetscReal :: den
   235)   PetscReal :: dum1
   236) 
   237)   PetscViewer :: viewer
   238)   character(len=MAXSTRINGLENGTH) :: string,string2
   239) 
   240)   PetscReal, pointer :: ff_p(:), mannings_loc_p(:),area_p(:)
   241)   PetscReal, pointer :: xc(:),yc(:),zc(:)
   242) 
   243)   patch => surf_realization%patch
   244)   grid => patch%grid
   245)   option => surf_realization%option
   246)   surf_field => surf_realization%surf_field
   247) 
   248)   surf_auxvars => patch%surf_aux%SurfaceTH%auxvars
   249)   surf_auxvars_bc => patch%surf_aux%SurfaceTH%auxvars_bc
   250)   surf_global_auxvars => patch%surf_aux%SurfaceGlobal%auxvars
   251)   surf_global_auxvars_bc => patch%surf_aux%SurfaceGlobal%auxvars_bc
   252)   surf_global_auxvars_ss => patch%surf_aux%SurfaceGlobal%auxvars_ss
   253) 
   254)   surf_realization%iter_count = surf_realization%iter_count+1
   255)   if (surf_realization%iter_count < 10) then
   256)     write(string2,'("00",i1)') surf_realization%iter_count
   257)   else if (surf_realization%iter_count < 100) then
   258)     write(string2,'("0",i2)') surf_realization%iter_count
   259)   else if (surf_realization%iter_count < 1000) then
   260)     write(string2,'(i3)') surf_realization%iter_count
   261)   else if (surf_realization%iter_count < 10000) then
   262)     write(string2,'(i4)') surf_realization%iter_count
   263)   endif 
   264) 
   265)   ! First, update the solution vector
   266)   call DiscretizationGlobalToLocal(surf_realization%discretization, &
   267)                                    xx,surf_field%flow_xx_loc,NFLOWDOF)
   268) 
   269)   ! Then, update the aux vars
   270)   ! RTM: This includes calculation of the accumulation terms, correct?
   271)   call SurfaceTHUpdateTemperature(surf_realization)
   272)   call SurfaceTHUpdateAuxVars(surf_realization)
   273)   ! override flags since they will soon be out of date  
   274)   patch%surf_aux%SurfaceTH%auxvars_up_to_date = PETSC_FALSE
   275) 
   276)   call VecGetArrayF90(ff,ff_p, ierr);CHKERRQ(ierr)
   277)   call VecGetArrayF90(surf_field%mannings_loc,mannings_loc_p,  &
   278)                       ierr);CHKERRQ(ierr)
   279)   call VecGetArrayF90(surf_field%area,area_p,ierr);CHKERRQ(ierr)
   280) 
   281)   ff_p = 0.d0
   282)   Res  = 0.d0
   283) 
   284)   xc => surf_realization%discretization%grid%x
   285)   yc => surf_realization%discretization%grid%y
   286)   zc => surf_realization%discretization%grid%z
   287) 
   288)   ! Interior Flux Terms -----------------------------------
   289)   connection_set_list => grid%internal_connection_set_list
   290)   cur_connection_set => connection_set_list%first
   291)   sum_connection = 0  
   292)   do 
   293)     if (.not.associated(cur_connection_set)) exit
   294)     do iconn = 1, cur_connection_set%num_connections
   295)       sum_connection = sum_connection + 1
   296) 
   297)       ghosted_id_up = cur_connection_set%id_up(iconn)
   298)       ghosted_id_dn = cur_connection_set%id_dn(iconn)
   299) 
   300)       local_id_up = grid%nG2L(ghosted_id_up)
   301)       local_id_dn = grid%nG2L(ghosted_id_dn)
   302)       
   303)       dx = xc(ghosted_id_dn) - xc(ghosted_id_up)
   304)       dy = yc(ghosted_id_dn) - yc(ghosted_id_up)
   305)       dz = zc(ghosted_id_dn) - zc(ghosted_id_up)
   306)       dist = sqrt(dx*dx + dy*dy + dz*dz)
   307)       slope = dz/dist
   308)       
   309)       call SurfaceTHFlux(surf_auxvars(ghosted_id_up), &
   310)                          surf_global_auxvars(ghosted_id_up), &
   311)                          zc(ghosted_id_up), &
   312)                          mannings_loc_p(ghosted_id_up), &
   313)                          surf_auxvars(ghosted_id_dn), &
   314)                          surf_global_auxvars(ghosted_id_dn), &
   315)                          zc(ghosted_id_dn), &
   316)                          mannings_loc_p(ghosted_id_dn), &
   317)                          dist, cur_connection_set%area(iconn), &
   318)                          option,vel,dum1,Res)
   319) 
   320)       patch%internal_velocities(1,sum_connection) = vel
   321)       patch%internal_flow_fluxes(:,sum_connection) = Res(:)
   322) 
   323)       if (local_id_up>0) then
   324)         iend = local_id_up*option%nflowdof
   325)         istart = iend-option%nflowdof+1
   326)         ff_p(istart:iend) = ff_p(istart:iend) - Res(:)/area_p(local_id_up)
   327)       endif
   328)          
   329)       if (local_id_dn>0) then
   330)         iend = local_id_dn*option%nflowdof
   331)         istart = iend-option%nflowdof+1
   332)         ff_p(istart:iend) = ff_p(istart:iend) + Res(:)/area_p(local_id_dn)
   333)       endif
   334) 
   335)     enddo
   336)     cur_connection_set => cur_connection_set%next
   337)   enddo
   338) 
   339)   ! Boundary Flux Terms -----------------------------------
   340)   boundary_condition => patch%boundary_condition_list%first
   341)   sum_connection = 0    
   342)   do 
   343)     if (.not.associated(boundary_condition)) exit
   344)     
   345)     cur_connection_set => boundary_condition%connection_set
   346)     
   347)     do iconn = 1, cur_connection_set%num_connections
   348)       sum_connection = sum_connection + 1
   349)     
   350)       local_id_dn = cur_connection_set%id_dn(iconn)
   351)       ghosted_id_dn = grid%nL2G(local_id_dn)
   352)   
   353)       dx = xc(ghosted_id_dn) - cur_connection_set%intercp(1,iconn)
   354)       dy = yc(ghosted_id_dn) - cur_connection_set%intercp(2,iconn)
   355)       dz = zc(ghosted_id_dn) - cur_connection_set%intercp(3,iconn)
   356)       dist = sqrt(dx*dx + dy*dy + dz*dz)
   357)       slope_dn = dz/sqrt(dx*dx + dy*dy + dz*dz)
   358) 
   359)       call SurfaceTHBCFlux(boundary_condition%flow_condition%itype, &
   360)                          boundary_condition%flow_aux_real_var(:,iconn), &
   361)                          surf_auxvars_bc(sum_connection), &
   362)                          surf_global_auxvars_bc(sum_connection), &
   363)                          surf_auxvars(ghosted_id_dn), &
   364)                          surf_global_auxvars(ghosted_id_dn), &
   365)                          slope_dn, &
   366)                          mannings_loc_p(ghosted_id_dn), &
   367)                          dist, &
   368)                          cur_connection_set%area(iconn), &
   369)                          option,vel,dum1,Res)
   370) 
   371)       patch%boundary_velocities(1,sum_connection) = vel
   372)       patch%boundary_flow_fluxes(:,sum_connection) = Res(:)
   373)       
   374)       iend = local_id_dn*option%nflowdof
   375)       istart = iend-option%nflowdof+1
   376)       ff_p(istart:iend) = ff_p(istart:iend) + Res(:)/area_p(local_id_dn)
   377)     enddo
   378)     boundary_condition => boundary_condition%next
   379)   enddo
   380) 
   381)   ! Source/sink terms -------------------------------------
   382)   source_sink => patch%source_sink_list%first
   383)   sum_connection = 0
   384)   do
   385)     if (.not.associated(source_sink)) exit
   386)     
   387)     if (source_sink%flow_condition%rate%itype/=HET_VOL_RATE_SS.and. &
   388)        source_sink%flow_condition%rate%itype/=HET_MASS_RATE_SS) &
   389)     qsrc_flow = source_sink%flow_condition%rate%dataset%rarray(1)
   390)       
   391)     if (source_sink%flow_condition%rate%itype == ENERGY_RATE_SS) &
   392)       esrc = source_sink%flow_condition%energy_rate%dataset%rarray(1)
   393) 
   394)     cur_connection_set => source_sink%connection_set
   395)     
   396)     do iconn = 1, cur_connection_set%num_connections
   397)       sum_connection = sum_connection + 1
   398)       local_id = cur_connection_set%id_dn(iconn)
   399)       ghosted_id = grid%nL2G(local_id)
   400)       if (patch%imat(ghosted_id) <= 0) cycle
   401) 
   402)       select case(source_sink%flow_condition%rate%itype)
   403)         case(VOLUMETRIC_RATE_SS)  ! assume local density for now
   404)           ! qsrc = m^3/sec
   405)           qsrc = qsrc_flow*area_p(local_id)
   406)         case(HET_VOL_RATE_SS)
   407)           ! qsrc = m^3/sec
   408)           qsrc = source_sink%flow_aux_real_var(ONE_INTEGER,iconn)*area_p(local_id)
   409)         case default
   410)           option%io_buffer = 'Source/Sink flow condition type not recognized'
   411)           call printErrMsg(option)
   412)       end select
   413)       
   414)       esrc = 0.d0
   415)       select case(source_sink%flow_condition%itype(TH_TEMPERATURE_DOF))
   416)         case (ENERGY_RATE_SS)
   417)           esrc = source_sink%flow_condition%energy_rate%dataset%rarray(1)
   418)         case (HET_ENERGY_RATE_SS)
   419)           esrc = source_sink%flow_aux_real_var(TWO_INTEGER,iconn)
   420)       end select
   421) 
   422)       iend = local_id*option%nflowdof
   423)       istart = iend-option%nflowdof+1
   424) 
   425)       ff_p(istart) = ff_p(istart) + qsrc/area_p(local_id)
   426)       ! RTM: TODO: What should the density term and specific heat capactiy be
   427)       ! in the freezing case?
   428)       ! I think using the weighted average of liquid and ice densities and Cwi 
   429)       ! is correct here, but I should check.
   430)       ff_p(iend) = ff_p(iend) + esrc + &
   431)                     surf_global_auxvars_ss(sum_connection)%den_kg(1)* &
   432)                     (surf_global_auxvars_ss(sum_connection)%temp + 273.15d0)* &
   433)                     surf_auxvars(local_id)%Cwi* &
   434)                     qsrc/area_p(local_id)
   435)     enddo
   436)     source_sink => source_sink%next
   437)   enddo
   438) 
   439)   call VecRestoreArrayF90(ff,ff_p, ierr);CHKERRQ(ierr)
   440)   call VecRestoreArrayF90(surf_field%mannings_loc,mannings_loc_p, &
   441)                           ierr);CHKERRQ(ierr)
   442)   call VecRestoreArrayF90(surf_field%area,area_p,ierr);CHKERRQ(ierr)
   443) 
   444)   if (surf_realization%debug%vecview_solution) then
   445)     string = 'Surf_xx_' // trim(adjustl(string2)) // '.bin'
   446)     call PetscViewerBinaryOpen(surf_realization%option%mycomm,string, &
   447)                               FILE_MODE_WRITE,viewer,ierr);CHKERRQ(ierr)
   448)     call VecView(xx,viewer,ierr);CHKERRQ(ierr)
   449)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   450) 
   451)     string = 'Surf_ff_' // trim(adjustl(string2)) // '.bin'
   452)     call PetscViewerBinaryOpen(surf_realization%option%mycomm,string, &
   453)                               FILE_MODE_WRITE,viewer,ierr);CHKERRQ(ierr)
   454)     call VecView(ff,viewer,ierr);CHKERRQ(ierr)
   455)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   456)   endif
   457) 
   458) end subroutine SurfaceTHRHSFunction
   459) 
   460) ! ************************************************************************** !
   461) 
   462) subroutine SurfaceTHIFunction(ts,t,xx,xxdot,ff,surf_realization,ierr)
   463)   ! 
   464)   ! This routine provides the implicit function evaluation for PETSc TSSolve()
   465)   ! Author: Nathan Collier, ORNL
   466)   ! 
   467) 
   468)   use EOS_Water_module
   469)   use Connection_module
   470)   use Realization_Surface_class
   471)   use Discretization_module
   472)   use Patch_module
   473)   use Grid_module
   474)   use Option_module
   475)   use Coupler_module  
   476)   use Surface_Field_module
   477)   use Debug_module
   478)   use Surface_TH_Aux_module
   479)   use Surface_Global_Aux_module
   480) 
   481)   implicit none
   482)   
   483)   TS :: ts
   484)   PetscReal :: t
   485)   Vec :: xx,xxdot
   486)   Vec :: ff
   487)   class(realization_surface_type) :: surf_realization
   488)   PetscErrorCode :: ierr
   489) 
   490)   ! Our equations are in the form: 
   491)   !    xxdot = RHS(xx)
   492)   ! or in residual form:
   493)   !    ff = xxdot - RHS(xx)
   494) 
   495)   ! First we call RHS function: ff = RHS(xx)
   496)   call SurfaceTHRHSFunction(ts,t,xx,ff,surf_realization,ierr);CHKERRQ(ierr)
   497)   ! negate: RHS(xx) = -RHS(xx)
   498)   call VecScale(ff,-1.d0,ierr);CHKERRQ(ierr)
   499)   ! and finally: ff += xxdot
   500)   call VecAYPX(ff,1.d0,xxdot,ierr);CHKERRQ(ierr)
   501)   
   502) end subroutine SurfaceTHIFunction
   503) 
   504) ! ************************************************************************** !
   505) 
   506) subroutine SurfaceTHComputeMaxDt(surf_realization,max_allowable_dt)
   507)   ! 
   508)   ! This routine maximum allowable 'dt' for explicit time scheme.
   509)   ! Author: Gautam Bisht, LBNL
   510)   ! 
   511) 
   512)   use EOS_Water_module
   513)   use Connection_module
   514)   use Realization_Surface_class
   515)   use Patch_module
   516)   use Grid_module
   517)   use Option_module
   518)   use Coupler_module  
   519)   use Surface_Field_module
   520)   use Debug_module
   521)   use Surface_TH_Aux_module
   522)   use Surface_Global_Aux_module
   523) 
   524)   implicit none
   525)   
   526)   class(realization_surface_type) :: surf_realization
   527)   PetscErrorCode :: ierr
   528) 
   529)   type(grid_type), pointer :: grid
   530)   type(patch_type), pointer :: patch
   531)   type(option_type), pointer :: option
   532)   type(surface_field_type), pointer :: surf_field
   533)   type(coupler_type), pointer :: boundary_condition
   534)   type(connection_set_list_type), pointer :: connection_set_list
   535)   type(connection_set_type), pointer :: cur_connection_set
   536) 
   537)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars(:)
   538)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars_bc(:)
   539)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars(:)
   540)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_bc(:)
   541) 
   542)   PetscInt :: local_id_up, local_id_dn
   543)   PetscInt :: ghosted_id_up, ghosted_id_dn
   544)   PetscInt :: iconn
   545)   PetscInt :: sum_connection
   546) #ifdef SURFACE_TH_DEBUG
   547)   PetscInt :: max_connection,max_iconn
   548) #endif
   549) 
   550)   PetscReal :: dx, dy, dz
   551)   PetscReal :: dist
   552)   PetscReal :: vel
   553)   PetscReal :: slope, slope_dn
   554)   PetscReal :: hw_up, hw_dn ! water height [m]
   555)   PetscReal :: Res(surf_realization%option%nflowdof), v_darcy
   556)   PetscReal :: max_allowable_dt
   557)   PetscReal :: dt
   558) 
   559)   PetscReal, pointer :: mannings_loc_p(:),area_p(:)
   560)   PetscReal, pointer :: xc(:),yc(:),zc(:)
   561) 
   562)   patch => surf_realization%patch
   563)   grid => patch%grid
   564)   option => surf_realization%option
   565)   surf_field => surf_realization%surf_field
   566) 
   567)   surf_auxvars => patch%surf_aux%SurfaceTH%auxvars
   568)   surf_auxvars_bc => patch%surf_aux%SurfaceTH%auxvars_bc
   569)   surf_global_auxvars => patch%surf_aux%SurfaceGlobal%auxvars
   570)   surf_global_auxvars_bc => patch%surf_aux%SurfaceGlobal%auxvars_bc
   571) 
   572)   call VecGetArrayF90(surf_field%mannings_loc,mannings_loc_p,  &
   573)                       ierr);CHKERRQ(ierr)
   574)   call VecGetArrayF90(surf_field%area,area_p,ierr);CHKERRQ(ierr)
   575) 
   576)   Res  = 0.d0
   577)   max_allowable_dt = 1.d10
   578)   vel = 0.d0
   579) 
   580)   xc => surf_realization%discretization%grid%x
   581)   yc => surf_realization%discretization%grid%y
   582)   zc => surf_realization%discretization%grid%z
   583) 
   584)   ! Interior Flux Terms -----------------------------------
   585)   connection_set_list => grid%internal_connection_set_list
   586)   cur_connection_set => connection_set_list%first
   587)   sum_connection = 0  
   588) #ifdef SURFACE_TH_DEBUG
   589)   max_connection = -1
   590)   max_iconn      = -1
   591) #endif
   592)   do 
   593)     if (.not.associated(cur_connection_set)) exit
   594)     do iconn = 1, cur_connection_set%num_connections
   595)       sum_connection = sum_connection + 1
   596) 
   597)       ghosted_id_up = cur_connection_set%id_up(iconn)
   598)       ghosted_id_dn = cur_connection_set%id_dn(iconn)
   599) 
   600)       local_id_up = grid%nG2L(ghosted_id_up)
   601)       local_id_dn = grid%nG2L(ghosted_id_dn)
   602)       
   603)       dx = xc(ghosted_id_dn) - xc(ghosted_id_up)
   604)       dy = yc(ghosted_id_dn) - yc(ghosted_id_up)
   605)       dz = zc(ghosted_id_dn) - zc(ghosted_id_up)
   606)       dist = sqrt(dx*dx + dy*dy + dz*dz)
   607)       slope = dz/dist
   608)       
   609)       call SurfaceTHFlux(surf_auxvars(ghosted_id_up), &
   610)                          surf_global_auxvars(ghosted_id_up), &
   611)                          zc(ghosted_id_up), &
   612)                          mannings_loc_p(ghosted_id_up), &
   613)                          surf_auxvars(ghosted_id_dn), &
   614)                          surf_global_auxvars(ghosted_id_dn), &
   615)                          zc(ghosted_id_dn), &
   616)                          mannings_loc_p(ghosted_id_dn), &
   617)                          dist, cur_connection_set%area(iconn), &
   618)                          option,vel,dt,Res)
   619) 
   620)       patch%internal_velocities(1,sum_connection) = vel
   621)       patch%internal_flow_fluxes(:,sum_connection) = Res(:)
   622) 
   623) #ifdef SURFACE_TH_DEBUG
   624)       if (dt < max_allowable_dt) then
   625)         max_connection = sum_connection
   626)         max_iconn      = iconn
   627)       endif
   628) #endif
   629)       max_allowable_dt = min(max_allowable_dt, dt)
   630) 
   631)     enddo
   632)     cur_connection_set => cur_connection_set%next
   633)   enddo
   634) 
   635) #ifdef SURFACE_TH_DEBUG
   636)   if (max_allowable_dt < 1.d-1) then
   637)     cur_connection_set => connection_set_list%first
   638)     ghosted_id_up = cur_connection_set%id_up(max_iconn)
   639)     ghosted_id_dn = cur_connection_set%id_dn(max_iconn)
   640)     local_id_up = grid%nG2L(ghosted_id_up)
   641)     local_id_dn = grid%nG2L(ghosted_id_dn)
   642)     dx = xc(ghosted_id_dn) - xc(ghosted_id_up)
   643)     dy = yc(ghosted_id_dn) - yc(ghosted_id_up)
   644)     dz = zc(ghosted_id_dn) - zc(ghosted_id_up)
   645)     dist = sqrt(dx*dx + dy*dy + dz*dz)
   646)     slope = dz/dist
   647)     print *,"--------------------------"
   648)     print *,"max_allowable_dt:",max_allowable_dt
   649)     print *,"connection:",max_iconn
   650)     print *,"(dx,dy,dz):",dx,dy,dz
   651)     print *,"dist:      ",dist
   652)     print *,"slope:     ",slope
   653)     print *,"flux:      ",patch%internal_velocities(1,max_connection)
   654)     print *,"dt:        ",dist/abs(patch%internal_velocities(1,max_connection))/3.0d0
   655)     print *,"up info:",ghosted_id_up
   656)     print *,"  istate:",surf_global_auxvars(ghosted_id_up)%istate
   657)     print *,"  head:  ",surf_global_auxvars(ghosted_id_up)%head(1)
   658)     print *,"  zc:    ",zc(ghosted_id_up)
   659)     print *,"  temp:  ",surf_global_auxvars(ghosted_id_up)%temp
   660)     print *,"  is_dry:",surf_global_auxvars(ghosted_id_up)%is_dry
   661)     print *,"dn info:",ghosted_id_dn
   662)     print *,"  istate:",surf_global_auxvars(ghosted_id_dn)%istate
   663)     print *,"  head:  ",surf_global_auxvars(ghosted_id_dn)%head(1)
   664)     print *,"  zc:    ",zc(ghosted_id_dn)
   665)     print *,"  temp:  ",surf_global_auxvars(ghosted_id_dn)%temp
   666)     print *,"  is_dry:",surf_global_auxvars(ghosted_id_dn)%is_dry
   667)   endif  
   668) #endif
   669) 
   670)   ! Boundary Flux Terms -----------------------------------
   671)   boundary_condition => patch%boundary_condition_list%first
   672)   sum_connection = 0    
   673)   do 
   674)     if (.not.associated(boundary_condition)) exit
   675)     
   676)     cur_connection_set => boundary_condition%connection_set
   677) 
   678)     do iconn = 1, cur_connection_set%num_connections
   679)       sum_connection = sum_connection + 1
   680)     
   681)       local_id_dn = cur_connection_set%id_dn(iconn)
   682)       ghosted_id_dn = grid%nL2G(local_id_dn)
   683)   
   684)       dx = xc(ghosted_id_dn) - cur_connection_set%intercp(1,iconn)
   685)       dy = yc(ghosted_id_dn) - cur_connection_set%intercp(2,iconn)
   686)       dz = zc(ghosted_id_dn) - cur_connection_set%intercp(3,iconn)
   687)       dist = sqrt(dx*dx + dy*dy + dz*dz)
   688)       slope_dn = dz/sqrt(dx*dx + dy*dy + dz*dz)
   689) 
   690)       call SurfaceTHBCFlux(boundary_condition%flow_condition%itype, &
   691)                          boundary_condition%flow_aux_real_var(:,iconn), &
   692)                          surf_auxvars_bc(sum_connection), &
   693)                          surf_global_auxvars_bc(sum_connection), &
   694)                          surf_auxvars(ghosted_id_dn), &
   695)                          surf_global_auxvars(ghosted_id_dn), &
   696)                          slope_dn, &
   697)                          mannings_loc_p(ghosted_id_dn), &
   698)                          dist, &
   699)                          cur_connection_set%area(iconn), &
   700)                          option,vel,dt,Res)
   701) 
   702)       patch%boundary_velocities(1,sum_connection) = vel
   703)       patch%boundary_flow_fluxes(:,sum_connection) = Res(:)
   704) 
   705)       max_allowable_dt = min(max_allowable_dt, dt)
   706)     enddo
   707)     boundary_condition => boundary_condition%next
   708)   enddo
   709)   
   710)   call VecRestoreArrayF90(surf_field%mannings_loc,mannings_loc_p, &
   711)                           ierr);CHKERRQ(ierr)
   712)   call VecRestoreArrayF90(surf_field%area,area_p,ierr);CHKERRQ(ierr)
   713)   
   714)   if (max_allowable_dt < 0.d0) then
   715)     write(option%io_buffer, &
   716)           '("surface_th.F90: SurfaceTHComputeMaxDt --> negative max_allowable_dt!",es15.7)') &
   717)           max_allowable_dt
   718)     call printErrMsg(option)     
   719)   endif
   720) 
   721) end subroutine SurfaceTHComputeMaxDt
   722) 
   723) ! ************************************************************************** !
   724) 
   725) subroutine SurfaceTHFlux(surf_auxvar_up, &
   726)                          surf_global_auxvar_up, &
   727)                          zc_up, &
   728)                          mannings_up, &
   729)                          surf_auxvar_dn, &
   730)                          surf_global_auxvar_dn, &
   731)                          zc_dn, &
   732)                          mannings_dn, &
   733)                          dist, &
   734)                          length, &
   735)                          option, &
   736)                          vel, &
   737)                          dt_max, &
   738)                          Res)
   739)   ! 
   740)   ! This routine computes the internal flux term for under
   741)   ! diffusion-wave assumption.
   742)   ! 
   743)   ! Author: Gautam Bisht, LBL
   744)   ! Date: 08/03/12
   745)   ! 
   746) 
   747)   use Surface_TH_Aux_module
   748)   use Surface_Global_Aux_module
   749)   use Option_module
   750)   use PFLOTRAN_Constants_module, only : MIN_SURFACE_WATER_HEIGHT
   751) 
   752)   implicit none
   753) 
   754)   type(option_type) :: option
   755)   type(Surface_TH_auxvar_type) :: surf_auxvar_up
   756)   type(Surface_TH_auxvar_type) :: surf_auxvar_dn
   757)   type(surface_global_auxvar_type) :: surf_global_auxvar_up
   758)   type(surface_global_auxvar_type) :: surf_global_auxvar_dn
   759)   PetscReal :: zc_up, zc_dn
   760)   PetscReal :: mannings_up, mannings_dn
   761) 
   762)   PetscReal :: head_up, head_dn
   763)   PetscReal :: dist, length
   764)   PetscReal :: vel                      ! [m/s]
   765)   PetscReal :: dt_max
   766)   PetscReal :: Res(1:option%nflowdof)   ! [m^3/s]
   767)   
   768)   PetscReal :: hw_half
   769)   PetscReal :: hw_liq_half
   770)   PetscReal :: mannings_half
   771)   PetscReal :: unfrozen_fraction_half
   772)   PetscReal :: dhead
   773)   PetscReal :: den_aveg
   774)   PetscReal :: temp_half
   775)   PetscReal :: dtemp
   776)   PetscReal :: Cw
   777)   PetscReal :: k_therm
   778)   PetscReal :: dt
   779) 
   780)   ! Initialize
   781)   dt_max  = PETSC_MAX_REAL
   782) 
   783)   ! We upwind Manning's coefficient, temperature, and the unfrozen head
   784)   head_up = surf_global_auxvar_up%head(1) + zc_up
   785)   head_dn = surf_global_auxvar_dn%head(1) + zc_dn
   786)   if (head_up > head_dn) then
   787)     mannings_half          = mannings_up
   788)     temp_half              = surf_global_auxvar_up%temp + 273.15d0 ! [K]
   789)     unfrozen_fraction_half = surf_auxvar_up%unfrozen_fraction
   790)     hw_half                = surf_global_auxvar_up%head(1)
   791)   else
   792)     mannings_half          = mannings_dn
   793)     temp_half              = surf_global_auxvar_dn%temp + 273.15d0 ! [K]
   794)     unfrozen_fraction_half = surf_auxvar_dn%unfrozen_fraction
   795)     hw_half                = surf_global_auxvar_dn%head(1)
   796)   endif
   797) 
   798)   ! We clip to avoid problems later evaluating at negative water height
   799)   hw_half     = max(hw_half,MIN_SURFACE_WATER_HEIGHT)
   800)   if (hw_half == MIN_SURFACE_WATER_HEIGHT) then
   801)     temp_half = 0.d0
   802)     hw_half   = 0.d0
   803)   endif
   804) 
   805)   ! Frozen water doesn't contribute to the velocity
   806)   hw_liq_half = unfrozen_fraction_half*hw_half
   807) 
   808)   ! Compute Manning's velocity
   809)   dhead = head_up - head_dn
   810)   vel   = sign(hw_liq_half**(2.d0/3.d0)/mannings_half*abs(dhead/dist)**0.5d0,dhead) ! [m/s]
   811) 
   812)   ! KLUDGE: To address high velocity oscillations of the surface water
   813)   ! height, reduce this value to keep dt from shrinking too much. Add
   814)   ! to options if we decide to keep it.
   815)   vel = sign(min(option%max_manning_velocity,abs(vel)),vel)
   816) 
   817)   ! Load into residual
   818)   Res(TH_PRESSURE_DOF) = vel*hw_liq_half*length ! [m^3/s]
   819)   
   820)   ! Temperature equation
   821)   ! RTM: k_therm is the weighted average of the liquid and ice thermal 
   822)   ! conductivities.  For the density and specific heat capacity in the 
   823)   ! advection term, we want these for liquid water ONLY, as the ice portion 
   824)   ! is immobile and thus should not make up part of the advection term. We 
   825)   ! also multiply the ponded water depth (hw_half) by the unfrozen fraction 
   826)   ! in the advection term but NOT the conduction term.
   827)   ! We do the same in SurfaceTHBCFlux().
   828) 
   829)   ! Average density
   830)   ! Here we only consider the LIQUID fraction.
   831)   den_aveg = (surf_global_auxvar_up%den_kg(1) + &
   832)               surf_global_auxvar_dn%den_kg(1))/2.d0
   833)   ! Temperature difference
   834)   if (surf_global_auxvar_up%is_dry .or. surf_global_auxvar_dn%is_dry) then
   835)     dtemp = 0.d0
   836)   else
   837)     dtemp = surf_global_auxvar_up%temp - surf_global_auxvar_dn%temp
   838)   endif
   839) 
   840)   ! We are not being careful with dry/wet conditions, so if the
   841)   ! temperature change is greater than 100 [C] we will assuming that
   842)   ! it was a wet/dry interface change that was missed.
   843)   if (abs(dtemp) > 100.d0) then
   844)     den_aveg = 0.d0
   845)     dtemp    = 0.d0
   846)   endif
   847) 
   848)   ! Note, Cw and k_therm are same for up and downwind
   849)   Cw = surf_auxvar_up%Cw
   850)   k_therm = surf_auxvar_up%k_therm
   851)   
   852)   ! Unfrozen fraction multiplies hw_half in advection term, but does NOT affect the 
   853)   ! conduction therm.  
   854)   ! RTM: Brookfield et al. 2009 also has dispersion term, which we are not using.
   855)   Res(TH_TEMPERATURE_DOF) = (den_aveg*vel*temp_half*Cw*hw_liq_half + &
   856)                              k_therm*dtemp/dist*hw_half)*length
   857) 
   858)   if (abs(vel)>eps) then
   859)     ! 1) Restriction due to flow equation
   860)     dt     = dist/abs(vel)/3.d0
   861)     dt_max = min(dt_max, dt)
   862)   endif
   863) 
   864)   if (abs(dtemp) > 1.0d-12) then
   865)     ! 2) Restriction due to energy equation
   866)     dt_max = min(dt_max,(dist**2.d0)*Cw*den_aveg/(2.d0*k_therm))
   867)   endif
   868) 
   869) end subroutine SurfaceTHFlux
   870) 
   871) ! ************************************************************************** !
   872) 
   873) subroutine SurfaceTHBCFlux(ibndtype, &
   874)                            auxvars, &
   875)                            surf_auxvar_up, &
   876)                            surf_global_auxvar_up, &
   877)                            surf_auxvar_dn, &
   878)                            surf_global_auxvar_dn, &
   879)                            slope, &
   880)                            mannings, &
   881)                            dist, &
   882)                            length, &
   883)                            option, &
   884)                            vel, &
   885)                            dt_max, &
   886)                            Res)
   887)   ! 
   888)   ! This routine computes flux for boundary cells.
   889)   ! 
   890)   ! Author: Gautam Bisht, LBNL
   891)   ! Date: 03/07/13
   892)   !
   893) 
   894)   use Option_module
   895)   use PFLOTRAN_Constants_module, only : MIN_SURFACE_WATER_HEIGHT
   896) 
   897)   implicit none
   898) 
   899)   type(option_type) :: option
   900)   type(Surface_TH_auxvar_type) :: surf_auxvar_up
   901)   type(surface_global_auxvar_type) :: surf_global_auxvar_up
   902)   type(Surface_TH_auxvar_type) :: surf_auxvar_dn
   903)   type(surface_global_auxvar_type) :: surf_global_auxvar_dn
   904)   PetscReal :: auxvars(:) ! from aux_real_var array
   905)   PetscReal :: slope
   906)   PetscReal :: mannings
   907)   PetscReal :: length
   908)   PetscReal :: flux
   909)   PetscInt :: ibndtype(:)
   910)   PetscReal :: vel
   911)   PetscReal :: dt_max
   912)   PetscReal :: Res(1:option%nflowdof)
   913)   PetscReal :: dist
   914) 
   915)   PetscInt :: pressure_bc_type
   916)   PetscReal :: head,dhead
   917)   PetscReal :: head_liq
   918)   PetscReal :: den
   919)   PetscReal :: temp_half
   920)   PetscReal :: Cw
   921)   PetscReal :: dtemp
   922)   PetscReal :: hw_half
   923)   PetscReal :: k_therm
   924)   PetscReal :: dt
   925) 
   926)   flux = 0.d0
   927)   vel = 0.d0
   928)   hw_half = 0.d0
   929)   dtemp = 0.d0
   930)   Cw = 0.d0
   931)   dt_max = PETSC_MAX_REAL
   932) 
   933)   ! Flow  
   934)   pressure_bc_type = ibndtype(TH_PRESSURE_DOF)
   935)   head = surf_global_auxvar_dn%head(1)
   936)   k_therm = surf_auxvar_dn%k_therm
   937)   
   938)   select case(pressure_bc_type)
   939)     case (ZERO_GRADIENT_BC)
   940)       if (slope<0.d0) then
   941)         vel =  0.d0
   942)         head_liq = 0.d0
   943)       else
   944)         head_liq = surf_auxvar_dn%unfrozen_fraction * head
   945)         vel = -sqrt(dabs(slope))/mannings*(head_liq**(2.d0/3.d0))
   946)         hw_half = head
   947)       endif
   948)       den = surf_global_auxvar_dn%den_kg(1)
   949)       Cw = surf_auxvar_dn%Cw
   950)     case (NEUMANN_BC)
   951)       vel = auxvars(TH_PRESSURE_DOF)
   952)       den = (surf_global_auxvar_up%den_kg(1) + &
   953)              surf_global_auxvar_dn%den_kg(1))/2.d0
   954)     case (SPILLOVER_BC)
   955)       ! if liquid water height is above a user-defined value, then outflow can occur
   956)       head_liq =  surf_auxvar_dn%unfrozen_fraction * head
   957)       dhead    =  max(head_liq-auxvars(1),0.0d0)
   958)       vel      = -dhead**(2.d0/3.d0)/mannings*abs(dhead/dist)**0.5d0
   959)       hw_half  =  head
   960)       Cw       =  surf_auxvar_dn%Cw 
   961)       den      =  surf_global_auxvar_dn%den_kg(1)
   962)     case default
   963)       option%io_buffer = 'Unknown pressure_bc_type for surface flow '
   964)       call printErrMsg(option)
   965)   end select
   966) 
   967)   if (vel>0.d0) then
   968)     temp_half = surf_global_auxvar_up%temp + 273.15d0
   969)   else
   970)     temp_half = surf_global_auxvar_dn%temp + 273.15d0
   971)   endif
   972) 
   973)   if (pressure_bc_type /= ZERO_GRADIENT_BC) then
   974)     select case (ibndtype(TH_TEMPERATURE_DOF))
   975)       case (DIRICHLET_BC)
   976)         dtemp = surf_global_auxvar_up%temp - surf_global_auxvar_dn%temp
   977)       case default
   978)         option%io_buffer = 'Unknown temperature_bc_type for surface flow '
   979)         call printErrMsg(option)
   980)     end select
   981)   endif
   982) 
   983)   flux = head_liq*vel
   984)   Res(TH_PRESSURE_DOF)    = flux*length
   985)   Res(TH_TEMPERATURE_DOF) = den*temp_half*Cw*vel*head_liq*length + &
   986)                             k_therm*dtemp/dist*hw_half*length
   987) 
   988)   ! Timestep restriction due to mass equation
   989)   if (abs(vel)>eps) then
   990)     dt     = dist/abs(vel)/3.d0
   991)     dt_max = min(dt_max, dt)
   992)   endif
   993)   ! Timestep restriction due to energy equation
   994)   if (head_liq > MIN_SURFACE_WATER_HEIGHT) then
   995)     dt_max = min(dt_max,(dist**2.d0)*Cw*den/(2.d0*k_therm))
   996)   endif
   997) 
   998) end subroutine SurfaceTHBCFlux
   999) 
  1000) ! ************************************************************************** !
  1001) 
  1002) subroutine SurfaceTHUpdateAuxVars(surf_realization)
  1003)   ! 
  1004)   ! This routine updates auxiliary variables
  1005)   ! 
  1006)   ! Author: Gautam Bisht, LBNL
  1007)   ! Date: 03/07/13
  1008)   ! 
  1009) 
  1010)   use Realization_Surface_class
  1011)   use Patch_module
  1012)   use Option_module
  1013)   use Surface_Field_module
  1014)   use Grid_module
  1015)   use Coupler_module
  1016)   use Connection_module
  1017)   use Surface_Material_module
  1018)   use PFLOTRAN_Constants_module, only : MIN_SURFACE_WATER_HEIGHT
  1019) 
  1020)   implicit none
  1021) 
  1022)   class(realization_surface_type) :: surf_realization
  1023)   
  1024)   type(option_type), pointer :: option
  1025)   type(patch_type), pointer :: patch
  1026)   type(grid_type), pointer :: grid
  1027)   type(surface_field_type), pointer :: surf_field
  1028)   type(coupler_type), pointer :: boundary_condition
  1029)   type(coupler_type), pointer :: source_sink
  1030)   type(connection_set_type), pointer :: cur_connection_set
  1031)   type(Surface_TH_auxvar_type), pointer :: surf_th_auxvars(:)
  1032)   type(Surface_TH_auxvar_type), pointer :: surf_th_auxvars_bc(:)
  1033)   type(Surface_TH_auxvar_type), pointer :: surf_th_auxvars_ss(:)
  1034)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars(:)
  1035)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_bc(:)
  1036)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_ss(:)
  1037) 
  1038)   PetscInt :: ghosted_id, local_id, istart, iend, sum_connection, idof, iconn
  1039)   PetscInt :: iphasebc, iphase
  1040)   PetscReal, pointer :: xx_loc_p(:), icap_loc_p(:), iphase_loc_p(:)
  1041)   PetscReal, pointer :: perm_xx_loc_p(:), porosity_loc_p(:)
  1042)   PetscReal :: xxbc(surf_realization%option%nflowdof)
  1043)   PetscReal :: xxss(surf_realization%option%nflowdof)
  1044)   PetscReal :: tsrc1
  1045)   PetscErrorCode :: ierr
  1046)   PetscReal :: den,head
  1047) 
  1048)   option => surf_realization%option
  1049)   patch => surf_realization%patch
  1050)   grid => patch%grid
  1051)   surf_field => surf_realization%surf_field
  1052) 
  1053)   surf_th_auxvars => patch%surf_aux%SurfaceTH%auxvars
  1054)   surf_th_auxvars_bc => patch%surf_aux%SurfaceTH%auxvars_bc
  1055)   surf_th_auxvars_ss => patch%surf_aux%SurfaceTH%auxvars_ss
  1056)   surf_global_auxvars => patch%surf_aux%SurfaceGlobal%auxvars
  1057)   surf_global_auxvars_bc => patch%surf_aux%SurfaceGlobal%auxvars_bc
  1058)   surf_global_auxvars_ss => patch%surf_aux%SurfaceGlobal%auxvars_ss
  1059)   
  1060)   call VecGetArrayF90(surf_field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
  1061) 
  1062)   ! Internal aux vars
  1063)   do ghosted_id = 1, grid%ngmax
  1064)     if (grid%nG2L(ghosted_id) < 0) cycle ! bypass ghosted corner cells
  1065) 
  1066)     !geh - Ignore inactive cells with inactive materials
  1067)     if (associated(patch%imat)) then
  1068)       if (patch%imat(ghosted_id) <= 0) cycle
  1069)     endif
  1070)     iend = ghosted_id*option%nflowdof
  1071)     istart = iend-option%nflowdof+1
  1072) 
  1073)     call SurfaceTHAuxVarCompute(xx_loc_p(istart:iend), &
  1074)                                 surf_th_auxvars(ghosted_id), &
  1075)                                 surf_global_auxvars(ghosted_id), &
  1076)                                 option)
  1077)     ! [rho*h*T*Cwi]
  1078)     if (xx_loc_p(istart) >= MIN_SURFACE_WATER_HEIGHT) then
  1079)       xx_loc_p(istart+1) = surf_global_auxvars(ghosted_id)%den_kg(1)* &
  1080)                            xx_loc_p(istart)* &
  1081)                            (surf_global_auxvars(ghosted_id)%temp + 273.15d0)* &
  1082)                            surf_th_auxvars(ghosted_id)%Cwi
  1083)     else
  1084)       xx_loc_p(istart+1) = 0.d0
  1085)     endif
  1086)   enddo
  1087)    
  1088)   ! Boundary aux vars
  1089)   boundary_condition => patch%boundary_condition_list%first
  1090)   sum_connection = 0    
  1091)   do 
  1092)     if (.not.associated(boundary_condition)) exit
  1093)     cur_connection_set => boundary_condition%connection_set
  1094)     do iconn = 1, cur_connection_set%num_connections
  1095)       sum_connection = sum_connection + 1
  1096)       local_id = cur_connection_set%id_dn(iconn)
  1097)       ghosted_id = grid%nL2G(local_id)
  1098)       if (associated(patch%imat)) then
  1099)         if (patch%imat(ghosted_id) <= 0) cycle
  1100)       endif
  1101) 
  1102)       do idof=1,option%nflowdof
  1103)         select case(boundary_condition%flow_condition%itype(idof))
  1104)           case(DIRICHLET_BC,HYDROSTATIC_BC,SEEPAGE_BC,HET_DIRICHLET,NEUMANN_BC)
  1105)             xxbc(idof) = boundary_condition%flow_aux_real_var(idof,iconn)
  1106)           case(ZERO_GRADIENT_BC)
  1107)             xxbc(idof) = xx_loc_p((ghosted_id-1)*option%nflowdof+idof)
  1108)         end select
  1109)       enddo
  1110) 
  1111)       surf_global_auxvars_bc(sum_connection)%temp = xxbc(2)
  1112)       call SurfaceTHAuxVarCompute(xxbc, &
  1113)                                   surf_th_auxvars_bc(sum_connection), &
  1114)                                   surf_global_auxvars_bc(sum_connection), &
  1115)                                   option)
  1116) 
  1117)     enddo
  1118)     boundary_condition => boundary_condition%next
  1119)   enddo
  1120) 
  1121)   ! Source/Sink aux vars
  1122)   ! source/sinks
  1123)   source_sink => patch%source_sink_list%first
  1124)   sum_connection = 0
  1125)   do
  1126)     if (.not.associated(source_sink)) exit
  1127)     cur_connection_set => source_sink%connection_set
  1128)     do iconn = 1, cur_connection_set%num_connections
  1129)       sum_connection = sum_connection + 1
  1130)       local_id = cur_connection_set%id_dn(iconn)
  1131)       ghosted_id = grid%nL2G(local_id)
  1132)       if (patch%imat(ghosted_id) <= 0) cycle
  1133) 
  1134)       iend = ghosted_id*option%nflowdof
  1135)       istart = iend-option%nflowdof+1
  1136) 
  1137)       if (associated(source_sink%flow_condition%temperature)) then
  1138)         if (source_sink%flow_condition%temperature%itype/=HET_DIRICHLET) then
  1139)           tsrc1 = source_sink%flow_condition%temperature%dataset%rarray(1)
  1140)         else
  1141)           tsrc1 = source_sink%flow_aux_real_var(TWO_INTEGER,iconn)
  1142)         endif
  1143)       else
  1144)         tsrc1 = xx_loc_p((ghosted_id-1)*option%nflowdof+1)
  1145)         tsrc1 = surf_global_auxvars(ghosted_id)%temp
  1146)       endif
  1147) 
  1148)       xxss = xx_loc_p(istart:iend)
  1149)       head    = xxss(1)
  1150)       xxss(1) = 1.d0 ! set arbitrary amount of surface water so auxvar will evaluate
  1151)       xxss(2) = tsrc1
  1152) 
  1153)       surf_global_auxvars_ss(sum_connection)%temp = tsrc1
  1154)       call SurfaceTHAuxVarCompute(xxss, &
  1155)                                   surf_th_auxvars_ss(sum_connection), &
  1156)                                   surf_global_auxvars_ss(sum_connection), &
  1157)                                   option)
  1158)       surf_global_auxvars_ss(sum_connection)%head = head ! set head back just in case
  1159) 
  1160)     enddo
  1161)     source_sink => source_sink%next
  1162)   enddo
  1163) 
  1164)   patch%surf_aux%SurfaceTH%auxvars_up_to_date = PETSC_TRUE
  1165) 
  1166)   call VecRestoreArrayF90(surf_field%flow_xx_loc,xx_loc_p, ierr);CHKERRQ(ierr)
  1167) 
  1168) end subroutine SurfaceTHUpdateAuxVars
  1169) 
  1170) ! ************************************************************************** !
  1171) 
  1172) subroutine EnergyToTemperatureBisection(T,TL,TR,h,energy,Cwi,Pr,option)
  1173)   ! 
  1174)   ! Solves the following nonlinear equation using the bisection method
  1175)   !
  1176)   ! R(T) = rho(T) Cwi hw T - energy = 0
  1177)   !
  1178)   ! Author: Nathan Collier, ORNL
  1179)   ! Date: 11/2014
  1180)   ! 
  1181)   use EOS_Water_module
  1182)   use Option_module
  1183) 
  1184)   implicit none
  1185) 
  1186)   PetscReal :: T,TL,TR,h,energy,Cwi,Pr
  1187)   type(option_type), pointer :: option
  1188) 
  1189)   PetscReal :: Tp,rho,rho_t,f,fR,fL,rtol
  1190)   PetscInt :: iter,niter
  1191)   PetscBool :: found
  1192)   PetscErrorCode :: ierr
  1193) 
  1194)   call EOSWaterdensity(TR,Pr,rho,rho_T,ierr)
  1195)   fR = rho*Cwi*h*(TR+273.15d0) - energy
  1196)   call EOSWaterdensity(TL,Pr,rho,rho_T,ierr)
  1197)   fL = rho*Cwi*h*(TL+273.15d0) - energy
  1198) 
  1199)   if (fL*fR > 0.d0) then
  1200)      print *,"[TL,TR] = ",TL,TR
  1201)      print *,"[fL,fR] = ",fL,fR
  1202)      write(option%io_buffer,'("surface_th.F90: EnergyToTemperatureBisection --> root is not bracketed")')
  1203)      call printErrMsg(option)
  1204)   endif
  1205) 
  1206)   T = 0.5d0*(TL+TR)
  1207)   call EOSWaterdensity(T,Pr,rho,rho_T,ierr)
  1208)   f = rho*Cwi*h*(T+273.15d0) - energy
  1209) 
  1210)   found = PETSC_FALSE
  1211)   niter = 200
  1212)   rtol  = 1.d-6
  1213)   do iter = 1,niter
  1214)      Tp = T
  1215)      if (fL*f < 0.d0) then
  1216)         TR = T
  1217)      else 
  1218)         TL = T
  1219)      endif
  1220) 
  1221)      T = 0.5d0*(TL+TR)
  1222) 
  1223)      call EOSWaterdensity(T,Pr,rho,rho_T,ierr)
  1224)      f = rho*Cwi*h*(T+273.15d0) - energy
  1225) 
  1226)      if (abs((T-Tp)/(T+273.15d0)) < rtol) then
  1227)         found = PETSC_TRUE
  1228)         exit
  1229)      endif
  1230)   enddo
  1231) 
  1232)   if (found .eqv. PETSC_FALSE) then
  1233)      print *,"[TL,T,TR] = ",TL,T,TR
  1234)      write(option%io_buffer,'("surface_th.F90: EnergyToTemperatureBisection --> root not found!")')
  1235)      call printErrMsg(option)
  1236)   endif
  1237) 
  1238) end subroutine EnergyToTemperatureBisection
  1239) 
  1240) ! ************************************************************************** !
  1241) 
  1242) subroutine SurfaceTHUpdateTemperature(surf_realization)
  1243)   ! 
  1244)   ! This routine updates the temperature after TSSolve.
  1245)   ! 
  1246)   ! Author: Gautam Bisht, LBNL
  1247)   ! Date: 06/25/13
  1248)   ! 
  1249) 
  1250)   use Realization_Surface_class
  1251)   use Patch_module
  1252)   use Option_module
  1253)   use Surface_Field_module
  1254)   use Grid_module
  1255)   use Coupler_module
  1256)   use Connection_module
  1257)   use Surface_Material_module
  1258)   use EOS_Water_module
  1259)   use PFLOTRAN_Constants_module, only : DUMMY_VALUE,MIN_SURFACE_WATER_HEIGHT
  1260) 
  1261)   implicit none
  1262) 
  1263)   class(realization_surface_type) :: surf_realization
  1264)   type(option_type), pointer :: option
  1265)   type(patch_type), pointer :: patch
  1266)   type(grid_type), pointer :: grid
  1267)   type(surface_field_type), pointer :: surf_field
  1268)   type(coupler_type), pointer :: boundary_condition
  1269)   type(coupler_type), pointer :: source_sink
  1270)   type(connection_set_type), pointer :: cur_connection_set
  1271)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars(:)
  1272)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars_bc(:)
  1273)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars_ss(:)
  1274)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars(:)
  1275)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_bc(:)
  1276)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_ss(:)
  1277) 
  1278)   PetscInt :: ghosted_id, local_id, istart, iend, sum_connection, idof, iconn
  1279)   PetscInt :: iphasebc, iphase
  1280)   PetscReal, pointer :: xx_loc_p(:), icap_loc_p(:), iphase_loc_p(:)
  1281)   PetscReal, pointer :: perm_xx_loc_p(:), porosity_loc_p(:)
  1282)   PetscReal :: xxbc(surf_realization%option%nflowdof)
  1283)   PetscReal :: xxss(surf_realization%option%nflowdof)
  1284)   PetscReal :: temp,TL,TR
  1285)   PetscReal :: den
  1286)   PetscReal :: dum1
  1287)   PetscErrorCode :: ierr
  1288) 
  1289)   option => surf_realization%option
  1290)   patch => surf_realization%patch
  1291)   grid => patch%grid
  1292)   surf_field => surf_realization%surf_field
  1293) 
  1294)   surf_global_auxvars => patch%surf_aux%SurfaceGlobal%auxvars
  1295)   surf_global_auxvars_bc => patch%surf_aux%SurfaceGlobal%auxvars_bc
  1296)   surf_global_auxvars_ss => patch%surf_aux%SurfaceGlobal%auxvars_ss
  1297)   surf_auxvars => patch%surf_aux%SurfaceTH%auxvars
  1298)   surf_auxvars_bc => patch%surf_aux%SurfaceTH%auxvars_bc
  1299) 
  1300)   !
  1301)   ! The unknown for the energy balance in the surface domain is
  1302)   ! energy. Thus we need to compute a temperature, which results in
  1303)   ! finding the root of the following nonlinear equation,
  1304)   !
  1305)   ! Residual(T) = rho(T) Cwi hw T - energy = 0
  1306)   !
  1307) 
  1308)   call VecGetArrayF90(surf_field%flow_xx_loc,xx_loc_p,ierr);CHKERRQ(ierr)
  1309) 
  1310)   do ghosted_id = 1,grid%ngmax
  1311)     istart = (ghosted_id-1)*option%nflowdof+1 ! surface water height dof
  1312)     iend   = istart+1                       ! surface energy dof
  1313)     if (xx_loc_p(istart) < MIN_SURFACE_WATER_HEIGHT) then
  1314)       ! If the cell is dry then we set temperature to a dummy value
  1315)       ! and then zero out the water height and energy.
  1316)       surf_global_auxvars(ghosted_id)%is_dry = PETSC_TRUE
  1317)       temp = DUMMY_VALUE
  1318)       xx_loc_p(istart) = 0.d0 ! no water 
  1319)       xx_loc_p(iend)   = 0.d0 ! no energy
  1320)     else
  1321)       TL = -100.d0
  1322)       TR =  100.d0
  1323)       call EnergyToTemperatureBisection(temp,TL,TR, &
  1324)                                         xx_loc_p(istart), &
  1325)                                         xx_loc_p(iend), &
  1326)                                         surf_auxvars(ghosted_id)%Cwi, &
  1327)                                         option%reference_pressure,option)
  1328)     endif
  1329)     surf_global_auxvars(ghosted_id)%temp = temp
  1330)     call EOSWaterdensity(temp,option%reference_pressure,den,dum1,ierr)
  1331)     surf_global_auxvars(ghosted_id)%den_kg(1) = den
  1332)   enddo
  1333) 
  1334)   call VecRestoreArrayF90(surf_field%flow_xx_loc,xx_loc_p,ierr);CHKERRQ(ierr)
  1335) 
  1336) end subroutine SurfaceTHUpdateTemperature
  1337) 
  1338) ! ************************************************************************** !
  1339) 
  1340) subroutine SurfaceTHUpdateSurfState(surf_realization)
  1341)   ! 
  1342)   ! This routine updates the states for surface-model at the end of
  1343)   ! subsurface-model timestep.
  1344)   ! 
  1345)   ! Author: Gautam Bisht, LBNL
  1346)   ! Date: 06/25/13
  1347)   ! 
  1348) 
  1349)   use Connection_module
  1350)   use Coupler_module
  1351)   use Discretization_module
  1352)   use DM_Kludge_module
  1353)   use Grid_module
  1354)   use Option_module
  1355)   use Patch_module
  1356)   use Realization_Subsurface_class
  1357)   use Realization_Base_class
  1358)   use String_module
  1359)   use Surface_Field_module
  1360)   use Realization_Surface_class
  1361)   use EOS_Water_module
  1362) 
  1363)   implicit none
  1364) 
  1365) #include "petsc/finclude/petscvec.h"
  1366) #include "petsc/finclude/petscvec.h90"
  1367) #include "petsc/finclude/petscmat.h"
  1368) #include "petsc/finclude/petscmat.h90"
  1369) 
  1370)   class(realization_surface_type) :: surf_realization
  1371) 
  1372)   type(coupler_list_type), pointer :: coupler_list
  1373)   type(coupler_type), pointer :: coupler
  1374)   type(connection_set_type), pointer :: cur_connection_set
  1375)   type(dm_ptr_type), pointer :: dm_ptr
  1376)   type(grid_type),pointer :: grid,surf_grid
  1377)   type(option_type), pointer :: option
  1378)   type(patch_type),pointer :: patch,surf_patch
  1379)   type(surface_field_type),pointer :: surf_field
  1380)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars(:)
  1381) 
  1382)   PetscInt :: count
  1383)   PetscInt :: ghosted_id
  1384)   PetscInt :: local_id
  1385)   PetscInt :: ibeg
  1386)   PetscInt :: iend
  1387)   PetscInt :: iconn
  1388)   PetscInt :: sum_connection
  1389) 
  1390)   PetscReal :: den
  1391)   PetscReal :: dum1
  1392)   PetscReal, pointer :: avg_vdarcy_p(:)   ! avg darcy velocity [m/s]
  1393)   PetscReal, pointer :: xx_p(:)           ! head [m]
  1394)   PetscReal, pointer :: surfpress_p(:)
  1395)   PetscReal, pointer :: surftemp_p(:)
  1396)   PetscReal :: Cwi
  1397)   PetscReal :: temp_K
  1398)   PetscErrorCode :: ierr
  1399) 
  1400)   PetscBool :: coupler_found = PETSC_FALSE
  1401) 
  1402)   patch      => surf_realization%patch
  1403)   option     => surf_realization%option
  1404)   surf_field => surf_realization%surf_field
  1405)   surf_grid  => surf_realization%discretization%grid
  1406)   surf_auxvars => patch%surf_aux%SurfaceTH%auxvars
  1407) 
  1408)   call VecGetArrayF90(surf_field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
  1409)   call VecGetArrayF90(surf_field%press_subsurf, surfpress_p,  &
  1410)                       ierr);CHKERRQ(ierr)
  1411)   call VecGetArrayF90(surf_field%temp_subsurf, surftemp_p, ierr);CHKERRQ(ierr)
  1412) 
  1413)   count = 0
  1414)   do ghosted_id = 1,surf_grid%ngmax
  1415) 
  1416)     local_id = surf_grid%nG2L(ghosted_id)
  1417)     if (local_id <= 0) cycle
  1418) 
  1419)     iend = ghosted_id*option%nflowdof
  1420)     ibeg = iend - 1
  1421) 
  1422)     ! Compute density
  1423)     count = count + 1
  1424)     call EOSWaterdensity(surftemp_p(count),option%reference_pressure,den,dum1,ierr)
  1425)     xx_p(ibeg) = (surfpress_p(count)-option%reference_pressure)/ &
  1426)                         (abs(option%gravity(3)))/den
  1427)     if (surfpress_p(count)-option%reference_pressure < 1.0d-8) then
  1428)       xx_p(ibeg) = 0.d0
  1429)       xx_p(iend) = 0.d0
  1430)     else
  1431)       Cwi = surf_auxvars(ghosted_id)%Cwi
  1432)       temp_K = surftemp_p(count) + 273.15d0
  1433)       xx_p(iend) = den*Cwi*temp_K*xx_p(ibeg)
  1434)     endif
  1435) 
  1436)   enddo
  1437)   call VecRestoreArrayF90(surf_field%flow_xx, xx_p, ierr);CHKERRQ(ierr)
  1438)   call VecRestoreArrayF90(surf_field%press_subsurf, surfpress_p,  &
  1439)                           ierr);CHKERRQ(ierr)
  1440)   call VecRestoreArrayF90(surf_field%temp_subsurf, surftemp_p,  &
  1441)                           ierr);CHKERRQ(ierr)
  1442) 
  1443)   call DiscretizationGlobalToLocal(surf_realization%discretization, &
  1444)                                    surf_field%flow_xx, &
  1445)                                    surf_field%flow_xx_loc, &
  1446)                                    NFLOWDOF)
  1447)   call SurfaceTHUpdateAuxVars(surf_realization)
  1448) 
  1449) end subroutine SurfaceTHUpdateSurfState
  1450) 
  1451) ! ************************************************************************** !
  1452) 
  1453) subroutine AtmEnergyToTemperatureBisection(T,TL,TR,shift,RHS,Pr,option)
  1454)   ! 
  1455)   ! Solves the following nonlinear equation using the bisection method
  1456)   !
  1457)   ! R(T) = (rho(T)+shift)*T - RHS = 0
  1458)   !
  1459)   ! Author: Nathan Collier, ORNL
  1460)   ! Date: 11/2014
  1461)   ! 
  1462)   use EOS_Water_module
  1463)   use Option_module
  1464) 
  1465)   implicit none
  1466) 
  1467)   PetscReal :: T,TL,TR,shift,RHS,Pr
  1468)   type(option_type), pointer :: option
  1469) 
  1470)   PetscReal :: Tp,rho,rho_t,f,fR,fL,rtol
  1471)   PetscInt :: iter,niter
  1472)   PetscBool :: found
  1473)   PetscErrorCode :: ierr
  1474) 
  1475)   call EOSWaterdensity(TR,Pr,rho,rho_T,ierr)
  1476)   fR = (rho+shift)*(TR+273.15d0) - RHS
  1477)   call EOSWaterdensity(TL,Pr,rho,rho_T,ierr)
  1478)   fL = (rho+shift)*(TL+273.15d0) - RHS
  1479) 
  1480)   if (fL*fR > 0.d0) then
  1481)      print *,"[TL,TR] = ",TL,TR
  1482)      print *,"[fL,fR] = ",fL,fR
  1483)      write(option%io_buffer,'("surface_th.F90: AtmEnergyToTemperatureBisection --> root is not bracketed")')
  1484)      call printErrMsg(option)
  1485)   endif
  1486) 
  1487)   T = 0.5d0*(TL+TR)
  1488)   call EOSWaterdensity(T,Pr,rho,rho_T,ierr)
  1489)   f = (rho+shift)*(T+273.15d0) - RHS
  1490) 
  1491)   found = PETSC_FALSE
  1492)   niter = 200
  1493)   rtol  = 1.d-6
  1494)   do iter = 1,niter
  1495)      Tp = T
  1496)      if (fL*f < 0.d0) then
  1497)         TR = T
  1498)      else 
  1499)         TL = T
  1500)      endif
  1501) 
  1502)      T = 0.5d0*(TL+TR)
  1503) 
  1504)      call EOSWaterdensity(T,Pr,rho,rho_T,ierr)
  1505)      f = (rho+shift)*(T+273.15d0) - RHS
  1506) 
  1507)      if (abs((T-Tp)/(T+273.15d0)) < rtol) then
  1508)         found = PETSC_TRUE
  1509)         exit
  1510)      endif
  1511)   enddo
  1512) 
  1513)   if (found .eqv. PETSC_FALSE) then
  1514)      print *,"[TL,T,TR] = ",TL,T,TR
  1515)      write(option%io_buffer,'("surface_th.F90: AtmEnergyToTemperatureBisection --> root not found!")')
  1516)      call printErrMsg(option)
  1517)   endif
  1518) 
  1519) end subroutine AtmEnergyToTemperatureBisection
  1520) 
  1521) ! ************************************************************************** !
  1522) 
  1523) subroutine SurfaceTHImplicitAtmForcing(surf_realization)
  1524)   !
  1525)   ! Updates the temperature of surface-water implicitly due to conduction.
  1526)   !
  1527)   ! Author: Gautam Bisht, LBNL
  1528)   ! Date: 04/24/2014
  1529)   !
  1530) 
  1531)   use Realization_Surface_class
  1532)   use Patch_module
  1533)   use Option_module
  1534)   use Surface_Field_module
  1535)   use Grid_module
  1536)   use Coupler_module
  1537)   use Connection_module
  1538)   use Surface_Material_module
  1539)   use EOS_Water_module
  1540)   use String_module
  1541)   use PFLOTRAN_Constants_module, only : MIN_SURFACE_WATER_HEIGHT
  1542)   implicit none
  1543) 
  1544)   class(realization_surface_type) :: surf_realization
  1545)   type(option_type), pointer :: option
  1546)   type(patch_type), pointer :: patch
  1547)   type(grid_type), pointer :: grid
  1548)   type(surface_field_type), pointer :: surf_field
  1549)   type(coupler_type), pointer :: boundary_condition
  1550)   type(coupler_type), pointer :: source_sink
  1551)   type(connection_set_type), pointer :: cur_connection_set
  1552)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars(:)
  1553)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars_bc(:)
  1554)   type(Surface_TH_auxvar_type), pointer :: surf_auxvars_ss(:)
  1555)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars(:)
  1556)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_bc(:)
  1557)   type(surface_global_auxvar_type), pointer :: surf_global_auxvars_ss(:)
  1558) 
  1559)   PetscInt :: ghosted_id, local_id, istart, iend, sum_connection, idof, iconn
  1560)   PetscInt :: iphasebc, iphase
  1561)   PetscReal, pointer :: xx_loc_p(:), xx_p(:)
  1562)   PetscReal, pointer :: perm_xx_loc_p(:), porosity_loc_p(:)
  1563)   PetscReal :: xxbc(surf_realization%option%nflowdof)
  1564)   PetscReal :: xxss(surf_realization%option%nflowdof)
  1565)   PetscReal :: temp,ptemp,rtol
  1566)   PetscInt :: iter
  1567)   PetscInt :: niter
  1568)   PetscReal :: den
  1569)   PetscReal :: dum1
  1570)   PetscReal :: den_iter
  1571)   PetscReal :: den_old
  1572)   PetscReal :: k_therm
  1573)   PetscReal :: Cw
  1574)   PetscReal :: temp_old
  1575)   PetscReal :: head
  1576)   PetscReal :: beta,RHS,TL,TR
  1577)   PetscBool :: found
  1578)   PetscErrorCode :: ierr
  1579) 
  1580)   option => surf_realization%option
  1581)   patch => surf_realization%patch
  1582)   grid => patch%grid
  1583)   surf_field => surf_realization%surf_field
  1584) 
  1585)   surf_global_auxvars => patch%surf_aux%SurfaceGlobal%auxvars
  1586)   surf_global_auxvars_ss => patch%surf_aux%SurfaceGlobal%auxvars_ss
  1587)   surf_auxvars => patch%surf_aux%SurfaceTH%auxvars
  1588)   surf_auxvars_bc => patch%surf_aux%SurfaceTH%auxvars_bc
  1589) 
  1590)   ! niter = max(m)
  1591)   niter = 20
  1592)   rtol  = 1.d-12
  1593)   call VecGetArrayF90(surf_field%flow_xx,xx_p,ierr);CHKERRQ(ierr)
  1594) 
  1595)   ! Update source/sink aux vars
  1596)   source_sink => patch%source_sink_list%first
  1597)   sum_connection = 0
  1598)   do
  1599)     if (.not.associated(source_sink)) exit
  1600) 
  1601)     cur_connection_set => source_sink%connection_set
  1602) 
  1603)     if (StringCompare(source_sink%name,'atm_energy_ss')) then
  1604) 
  1605)       if (source_sink%flow_condition%itype(TH_TEMPERATURE_DOF) == HET_DIRICHLET) then
  1606) 
  1607)         do iconn = 1, cur_connection_set%num_connections
  1608) 
  1609)           sum_connection = sum_connection + 1
  1610) 
  1611)           local_id = cur_connection_set%id_dn(iconn)
  1612)           ghosted_id = grid%nL2G(local_id)
  1613) 
  1614)           head     = surf_global_auxvars(ghosted_id)%head(1)
  1615)           temp_old = surf_global_auxvars(ghosted_id)%temp
  1616)           k_therm  = surf_auxvars(ghosted_id)%k_therm
  1617)           Cw       = surf_auxvars(ghosted_id)%Cw
  1618) 
  1619)           if (head > MIN_SURFACE_WATER_HEIGHT) then
  1620) 
  1621)             call EOSWaterdensity(temp_old,option%reference_pressure,den_old,dum1,ierr)
  1622)             call EOSWaterdensity(temp_old,option%reference_pressure,den_iter,dum1,ierr)
  1623) 
  1624)             TL    = -100.d0
  1625)             TR    =  100.d0
  1626)             beta  = (2.d0*k_therm*option%surf_flow_dt)/(Cw*head**2.d0)
  1627)             RHS   =  den_old*(temp_old+273.15d0)+beta*(surf_global_auxvars_ss(sum_connection)%temp+273.15d0)
  1628)             call AtmEnergyToTemperatureBisection(temp,TL,TR,beta,RHS,option%reference_pressure,option)
  1629) 
  1630)             call EOSWaterdensity(temp,option%reference_pressure,den_iter,dum1,ierr)
  1631)             surf_global_auxvars(ghosted_id)%temp = temp
  1632) 
  1633)             iend = local_id*option%nflowdof
  1634)             istart = iend - option%nflowdof + 1
  1635)             xx_p(iend) = den_iter*Cw*(temp + 273.15d0)*xx_p(istart)
  1636)           endif
  1637) 
  1638)         enddo
  1639) 
  1640)       else
  1641)         sum_connection = sum_connection + cur_connection_set%num_connections
  1642)       endif
  1643) 
  1644)     else
  1645)       sum_connection = sum_connection + cur_connection_set%num_connections
  1646)     endif
  1647) 
  1648)     source_sink => source_sink%next
  1649)   enddo
  1650) 
  1651)   call VecRestoreArrayF90(surf_field%flow_xx,xx_p,ierr);CHKERRQ(ierr)
  1652) 
  1653) end subroutine SurfaceTHImplicitAtmForcing
  1654) 
  1655) ! ************************************************************************** !
  1656) 
  1657) subroutine SurfaceTHUpdateSolution(surf_realization)
  1658)   ! 
  1659)   ! This routine updates solution after a successful time step
  1660)   ! 
  1661)   ! Author: Gautam Bisht, LBNL
  1662)   ! Date: 03/07/13
  1663)   ! 
  1664) 
  1665)   use Realization_Surface_class
  1666)   use Surface_Field_module
  1667) 
  1668)   implicit none
  1669) 
  1670)   class(realization_surface_type) :: surf_realization
  1671) 
  1672)   type(surface_field_type),pointer :: surf_field
  1673)   PetscErrorCode :: ierr
  1674) 
  1675)   surf_field => surf_realization%surf_field
  1676)   call VecCopy(surf_field%flow_xx,surf_field%flow_yy,ierr);CHKERRQ(ierr)
  1677) 
  1678) end subroutine SurfaceTHUpdateSolution
  1679) 
  1680) 
  1681) ! ************************************************************************** !
  1682) 
  1683) subroutine SurfaceTHDestroy(surf_realization)
  1684)   ! 
  1685)   ! Deallocates variables associated with Richard
  1686)   ! 
  1687)   ! Author: ???
  1688)   ! Date: 02/14/08
  1689)   ! 
  1690) 
  1691)   use Realization_Surface_class
  1692) 
  1693)   implicit none
  1694)   
  1695)   class(realization_surface_type) :: surf_realization
  1696)   
  1697)   ! aux vars should be destroyed when surf_realization is destroyed.
  1698)   
  1699) end subroutine SurfaceTHDestroy
  1700) 
  1701) end module Surface_TH_module

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