geomechanics_force.F90       coverage:  77.78 %func     79.30 %block


     1) module Geomechanics_Force_module
     2) 
     3)   use Geomechanics_Global_Aux_module
     4)   use PFLOTRAN_Constants_module
     5)   
     6)   implicit none
     7)   
     8)   private
     9)   
    10) #include "petsc/finclude/petscsys.h"
    11) 
    12) #include "petsc/finclude/petscvec.h"
    13) #include "petsc/finclude/petscvec.h90"
    14) #include "petsc/finclude/petscmat.h"
    15) #include "petsc/finclude/petscmat.h90"
    16) !#include "petsc/finclude/petscsnes.h"
    17) #include "petsc/finclude/petscviewer.h"
    18) #include "petsc/finclude/petsclog.h"
    19) #include "petsc/finclude/petscts.h"
    20) 
    21) ! Cutoff parameters
    22)   PetscReal, parameter :: eps       = 1.d-12
    23)   PetscReal, parameter :: perturbation_tolerance = 1.d-6
    24) 
    25)   public :: GeomechForceSetup, &
    26)             GeomechForceUpdateAuxVars, &
    27)             GeomechanicsForceInitialGuess, &
    28)             GeomechForceResidual, &
    29)             GeomechForceJacobian, &
    30)             GeomechUpdateFromSubsurf, &
    31)             GeomechUpdateSubsurfFromGeomech, &
    32)             GeomechCreateGeomechSubsurfVec, &
    33)             GeomechCreateSubsurfStressStrainVec, &
    34)             GeomechUpdateSolution, &
    35)             GeomechStoreInitialPressTemp, &
    36)             GeomechStoreInitialDisp, &
    37)             GeomechStoreInitialPorosity, &
    38)             GeomechUpdateSubsurfPorosity, &
    39)             GeomechForceJacobianLinearPart
    40)  
    41) contains
    42) 
    43) ! ************************************************************************** !
    44) 
    45) subroutine GeomechForceSetup(geomech_realization)
    46)   ! 
    47)   ! Sets up the geomechanics calculations
    48)   ! 
    49)   ! Author: Satish Karra, LANL
    50)   ! Date: 06/17/13
    51)   ! 
    52) 
    53)   use Geomechanics_Realization_class
    54)   use Output_Aux_module
    55) 
    56)   class(realization_geomech_type) :: geomech_realization
    57)   type(output_variable_list_type), pointer :: list
    58) 
    59)   call GeomechForceSetupPatch(geomech_realization)
    60) 
    61)   list => geomech_realization%output_option%output_snap_variable_list
    62)   call GeomechForceSetPlotVariables(list)
    63)   list => geomech_realization%output_option%output_obs_variable_list
    64)   call GeomechForceSetPlotVariables(list)
    65)    
    66) end subroutine GeomechForceSetup
    67) 
    68) ! ************************************************************************** !
    69) 
    70) subroutine GeomechForceSetupPatch(geomech_realization)
    71)   ! 
    72)   ! Sets up the arrays for geomech parameters
    73)   ! 
    74)   ! Author: Satish Karra, LANL
    75)   ! Date: 09/11/13
    76)   ! 
    77) 
    78)   use Geomechanics_Realization_class
    79)   use Geomechanics_Patch_module
    80)   use Option_module
    81)  
    82)   implicit none
    83) 
    84)   class(realization_geomech_type) :: geomech_realization
    85)   type(option_type), pointer :: option
    86)   type(geomech_patch_type), pointer :: patch
    87) 
    88)   PetscInt :: i
    89) 
    90)   option => geomech_realization%option
    91)   patch => geomech_realization%geomech_patch
    92) 
    93)   allocate(patch%geomech_aux%GeomechParam%youngs_modulus &
    94)     (size(geomech_realization%geomech_material_property_array)))
    95)   allocate(patch%geomech_aux%GeomechParam%poissons_ratio &
    96)     (size(geomech_realization%geomech_material_property_array)))
    97)   allocate(patch%geomech_aux%GeomechParam%biot_coef &
    98)     (size(geomech_realization%geomech_material_property_array)))
    99)   allocate(patch%geomech_aux%GeomechParam%thermal_exp_coef &
   100)     (size(geomech_realization%geomech_material_property_array)))
   101)   allocate(patch%geomech_aux%GeomechParam%density &
   102)     (size(geomech_realization%geomech_material_property_array)))
   103) 
   104)   do i = 1, size(geomech_realization%geomech_material_property_array)
   105)     patch%geomech_aux%GeomechParam%youngs_modulus(geomech_realization% &
   106)       geomech_material_property_array(i)%ptr%id) = geomech_realization% &
   107)       geomech_material_property_array(i)%ptr%youngs_modulus
   108)     patch%geomech_aux%GeomechParam%poissons_ratio(geomech_realization% &
   109)       geomech_material_property_array(i)%ptr%id) = geomech_realization% &
   110)       geomech_material_property_array(i)%ptr%poissons_ratio
   111)     patch%geomech_aux%GeomechParam%density(geomech_realization% &
   112)       geomech_material_property_array(i)%ptr%id) = geomech_realization% &
   113)       geomech_material_property_array(i)%ptr%density
   114)     patch%geomech_aux%GeomechParam%biot_coef(geomech_realization% &
   115)       geomech_material_property_array(i)%ptr%id) = geomech_realization% &
   116)       geomech_material_property_array(i)%ptr%biot_coeff
   117)     patch%geomech_aux%GeomechParam%thermal_exp_coef(geomech_realization% &
   118)       geomech_material_property_array(i)%ptr%id) = geomech_realization% &
   119)       geomech_material_property_array(i)%ptr%thermal_exp_coeff
   120)   enddo
   121) 
   122) end subroutine GeomechForceSetupPatch
   123) 
   124) ! ************************************************************************** !
   125) 
   126) subroutine GeomechForceSetPlotVariables(list)
   127)   ! 
   128)   ! Set up of geomechanics plot variables
   129)   ! 
   130)   ! Author: Satish Karra, LANL
   131)   ! Date: 06/17/13
   132)   ! 
   133)   
   134)   use Output_Aux_module
   135)   use Variables_module
   136)     
   137)   implicit none
   138) 
   139)   type(output_variable_list_type), pointer :: list
   140)   type(output_variable_type), pointer :: output_variable
   141) 
   142)   character(len=MAXWORDLENGTH) :: name, units
   143)   
   144)   if (associated(list%first)) then
   145)     return
   146)   endif
   147) 
   148)   name = 'disp_x'
   149)   units = 'm'
   150)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   151)                                GEOMECH_DISP_X)
   152)                                
   153)   name = 'disp_y'
   154)   units = 'm'
   155)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   156)                                GEOMECH_DISP_Y)
   157)                                
   158)   name = 'disp_z'
   159)   units = 'm'
   160)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   161)                                GEOMECH_DISP_Z)
   162) 
   163)   units = ''
   164)   name = 'Material ID'
   165)   output_variable => OutputVariableCreate(name,OUTPUT_DISCRETE, &
   166)                                           units,GEOMECH_MATERIAL_ID)
   167)   output_variable%iformat = 1 ! integer
   168)   call OutputVariableAddToList(list,output_variable)
   169)                              
   170)   name = 'strain_xx'
   171)   units = ''
   172)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   173)                                STRAIN_XX)
   174)                                
   175)   name = 'strain_yy'
   176)   units = ''
   177)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   178)                                STRAIN_YY)
   179)                                
   180)   name = 'strain_zz'
   181)   units = ''
   182)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   183)                                STRAIN_ZZ)
   184)                                
   185)   name = 'strain_xy'
   186)   units = ''
   187)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   188)                                STRAIN_XY)
   189)                                
   190)   name = 'strain_yz'
   191)   units = ''
   192)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   193)                                STRAIN_YZ)
   194)                                
   195)   name = 'strain_zx'
   196)   units = ''
   197)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   198)                                STRAIN_ZX)
   199)                                                                               
   200)   name = 'stress_xx'
   201)   units = ''
   202)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   203)                                STRESS_XX)
   204)                                
   205)   name = 'stress_yy'
   206)   units = ''
   207)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   208)                                STRESS_YY)
   209)                                
   210)   name = 'stress_zz'
   211)   units = ''
   212)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   213)                                STRESS_ZZ)
   214)                                
   215)   name = 'stress_xy'
   216)   units = ''
   217)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   218)                                STRESS_XY)
   219)                                
   220)   name = 'stress_yz'
   221)   units = ''
   222)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   223)                                STRESS_YZ)
   224)                                
   225)   name = 'stress_zx'
   226)   units = ''
   227)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   228)                                STRESS_ZX)
   229)   name = 'rel_disp_x'
   230)   units = 'm'
   231)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   232)                                GEOMECH_REL_DISP_X)
   233)                                
   234)   name = 'rel_disp_y'
   235)   units = 'm'
   236)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   237)                                GEOMECH_REL_DISP_Y)
   238)                                
   239)   name = 'rel_disp_z'
   240)   units = 'm'
   241)   call OutputVariableAddToList(list,name,OUTPUT_GENERIC,units, &
   242)                                GEOMECH_REL_DISP_Z)
   243) 
   244) 
   245) end subroutine GeomechForceSetPlotVariables
   246) 
   247) ! ************************************************************************** !
   248) 
   249) subroutine GeomechanicsForceInitialGuess(geomech_realization)
   250)   ! 
   251)   ! Sets up the inital guess for the solution
   252)   ! The boundary conditions are set here
   253)   ! 
   254)   ! Author: Satish Karra, LANL
   255)   ! Date: 06/19/13
   256)   ! 
   257) 
   258)   use Geomechanics_Realization_class
   259)   use Geomechanics_Field_module
   260)   use Option_module
   261)   use Geomechanics_Grid_Aux_module
   262)   use Geomechanics_Grid_module
   263)   use Geomechanics_Patch_module
   264)   use Geomechanics_Coupler_module
   265)   use Geomechanics_Region_module
   266)   
   267)   implicit none
   268)   
   269)   class(realization_geomech_type) :: geomech_realization
   270)   
   271)   type(option_type), pointer :: option
   272)   type(geomech_field_type), pointer :: field
   273)   type(geomech_patch_type), pointer :: patch
   274)   type(geomech_coupler_type), pointer :: boundary_condition
   275)   type(geomech_grid_type), pointer :: grid
   276)   type(gm_region_type), pointer :: region
   277)   
   278)   PetscInt :: ghosted_id,local_id,total_verts,ivertex
   279)   PetscReal, pointer :: xx_p(:)
   280)   PetscErrorCode :: ierr
   281)   
   282)   option => geomech_realization%option
   283)   field => geomech_realization%geomech_field
   284)   patch => geomech_realization%geomech_patch
   285)   grid => patch%geomech_grid
   286)   
   287)   call GeomechGridVecGetArrayF90(grid,field%disp_xx,xx_p,ierr)
   288)   
   289)   boundary_condition => patch%geomech_boundary_condition_list%first
   290)   total_verts = 0
   291)   do 
   292)     if (.not.associated(boundary_condition)) exit
   293)     region => boundary_condition%region
   294)     do ivertex = 1, region%num_verts
   295)       total_verts = total_verts + 1
   296)       local_id = region%vertex_ids(ivertex)
   297)       ghosted_id = grid%nL2G(local_id)
   298)       if (associated(patch%imat)) then
   299)         if (patch%imat(ghosted_id) <= 0) cycle
   300)       endif    
   301)       
   302)       ! X displacement 
   303)       if (associated(boundary_condition%geomech_condition%displacement_x)) then
   304)         select case(boundary_condition%geomech_condition%displacement_x%itype)
   305)           case(DIRICHLET_BC)
   306)             xx_p(THREE_INTEGER*(local_id-1) + GEOMECH_DISP_X_DOF) = &
   307)             boundary_condition%geomech_aux_real_var(GEOMECH_DISP_X_DOF,ivertex)
   308)           case(ZERO_GRADIENT_BC,NEUMANN_BC)
   309)            ! do nothing
   310)         end select
   311)       endif
   312)       
   313)       ! Y displacement 
   314)       if (associated(boundary_condition%geomech_condition%displacement_y)) then
   315)         select case(boundary_condition%geomech_condition%displacement_y%itype)
   316)           case(DIRICHLET_BC)
   317)             xx_p(THREE_INTEGER*(local_id-1) + GEOMECH_DISP_Y_DOF) = &
   318)             boundary_condition%geomech_aux_real_var(GEOMECH_DISP_Y_DOF,ivertex)
   319)           case(ZERO_GRADIENT_BC,NEUMANN_BC)
   320)            ! do nothing
   321)         end select
   322)       endif
   323)       
   324)       ! Z displacement      
   325)       if (associated(boundary_condition%geomech_condition%displacement_z)) then
   326)         select case(boundary_condition%geomech_condition%displacement_z%itype)
   327)           case(DIRICHLET_BC)
   328)             xx_p(THREE_INTEGER*(local_id-1) + GEOMECH_DISP_Z_DOF) = &
   329)             boundary_condition%geomech_aux_real_var(GEOMECH_DISP_Z_DOF,ivertex)
   330)           case(ZERO_GRADIENT_BC,NEUMANN_BC)
   331)            ! do nothing
   332)         end select
   333)       endif
   334)       
   335)     enddo
   336)     boundary_condition => boundary_condition%next      
   337)   enddo
   338)   
   339)   call GeomechGridVecRestoreArrayF90(grid,field%disp_xx,xx_p,ierr)
   340) 
   341) end subroutine GeomechanicsForceInitialGuess
   342) 
   343) ! ************************************************************************** !
   344) 
   345) subroutine GeomechForceUpdateAuxVars(geomech_realization)
   346)   ! 
   347)   ! Updates the geomechanics variables
   348)   ! 
   349)   ! Author: Satish Karra, LANL
   350)   ! Date: 06/18/13
   351)   ! 
   352) 
   353)   use Geomechanics_Realization_class
   354)   use Geomechanics_Patch_module
   355)   use Option_module
   356)   use Geomechanics_Field_module
   357)   use Geomechanics_Grid_module
   358)   use Geomechanics_Grid_Aux_module
   359)   use Geomechanics_Coupler_module
   360)   use Geomechanics_Material_module
   361)   use Geomechanics_Global_Aux_module
   362)   use Geomechanics_Region_module
   363) 
   364)   implicit none
   365) 
   366)   class(realization_geomech_type) :: geomech_realization
   367)   
   368)   type(option_type), pointer :: option
   369)   type(geomech_patch_type), pointer :: patch
   370)   type(geomech_grid_type), pointer :: grid
   371)   type(geomech_field_type), pointer :: geomech_field
   372)   type(gm_region_type), pointer :: region
   373)   type(geomech_global_auxvar_type), pointer :: geomech_global_aux_vars(:)
   374) 
   375)   PetscInt :: ghosted_id, local_id
   376)   PetscReal, pointer :: xx_loc_p(:), xx_init_loc_p(:)
   377)   PetscErrorCode :: ierr
   378) 
   379)   option => geomech_realization%option
   380)   patch => geomech_realization%geomech_patch
   381)   grid => patch%geomech_grid
   382)   geomech_field => geomech_realization%geomech_field
   383) 
   384)   geomech_global_aux_vars => patch%geomech_aux%GeomechGlobal%aux_vars
   385)   
   386)   call GeomechGridVecGetArrayF90(grid,geomech_field%disp_xx_loc,xx_loc_p,ierr)
   387)   call GeomechGridVecGetArrayF90(grid,geomech_field%disp_xx_init_loc, &
   388)                                  xx_init_loc_p,ierr)
   389) 
   390)   ! Internal aux vars
   391)   do ghosted_id = 1, grid%ngmax_node
   392)     if (grid%nG2L(ghosted_id) < 0) cycle ! bypass ghosted corner cells
   393)     !geh - Ignore inactive cells with inactive materials
   394)     if (associated(patch%imat)) then
   395)       if (patch%imat(ghosted_id) <= 0) cycle
   396)     endif
   397)     geomech_global_aux_vars(ghosted_id)%disp_vector(GEOMECH_DISP_X_DOF) = &
   398)       xx_loc_p(GEOMECH_DISP_X_DOF + (ghosted_id-1)*THREE_INTEGER)
   399)     geomech_global_aux_vars(ghosted_id)%disp_vector(GEOMECH_DISP_Y_DOF) = &
   400)       xx_loc_p(GEOMECH_DISP_Y_DOF + (ghosted_id-1)*THREE_INTEGER)
   401)     geomech_global_aux_vars(ghosted_id)%disp_vector(GEOMECH_DISP_Z_DOF) = &
   402)       xx_loc_p(GEOMECH_DISP_Z_DOF + (ghosted_id-1)*THREE_INTEGER)
   403)  
   404)     geomech_global_aux_vars(ghosted_id)%rel_disp_vector(GEOMECH_DISP_X_DOF) = &
   405)       xx_loc_p(GEOMECH_DISP_X_DOF + (ghosted_id-1)*THREE_INTEGER) - &
   406)       xx_init_loc_p(GEOMECH_DISP_X_DOF + (ghosted_id-1)*THREE_INTEGER)
   407)     geomech_global_aux_vars(ghosted_id)%rel_disp_vector(GEOMECH_DISP_Y_DOF) = &
   408)       xx_loc_p(GEOMECH_DISP_Y_DOF + (ghosted_id-1)*THREE_INTEGER) - &
   409)       xx_init_loc_p(GEOMECH_DISP_Y_DOF + (ghosted_id-1)*THREE_INTEGER)
   410)     geomech_global_aux_vars(ghosted_id)%rel_disp_vector(GEOMECH_DISP_Z_DOF) = &
   411)       xx_loc_p(GEOMECH_DISP_Z_DOF + (ghosted_id-1)*THREE_INTEGER) - &
   412)       xx_init_loc_p(GEOMECH_DISP_Z_DOF + (ghosted_id-1)*THREE_INTEGER)
   413)  enddo
   414)    
   415)   call GeomechGridVecRestoreArrayF90(grid,geomech_field%disp_xx_loc, &
   416)                                      xx_loc_p,ierr)
   417)   call GeomechGridVecRestoreArrayF90(grid,geomech_field%disp_xx_init_loc, &
   418)                                      xx_init_loc_p,ierr)
   419) 
   420) 
   421) end subroutine GeomechForceUpdateAuxVars
   422) 
   423) ! ************************************************************************** !
   424) 
   425) subroutine GeomechForceResidual(snes,xx,r,geomech_realization,ierr)
   426)   ! 
   427)   ! Computes the residual equation
   428)   ! 
   429)   ! Author: Satish Karra
   430)   ! Date: 06/21/13
   431)   ! 
   432) 
   433)   use Geomechanics_Realization_class
   434)   use Geomechanics_Field_module
   435)   use Geomechanics_Discretization_module
   436)   use Option_module
   437) 
   438)   implicit none
   439) 
   440)   SNES :: snes
   441)   Vec :: xx
   442)   Vec :: r
   443)   class(realization_geomech_type) :: geomech_realization
   444)   PetscViewer :: viewer
   445)   PetscErrorCode :: ierr
   446)   
   447)   type(geomech_discretization_type), pointer :: geomech_discretization
   448)   type(geomech_field_type), pointer :: field
   449)   type(option_type), pointer :: option
   450)   
   451)   field => geomech_realization%geomech_field
   452)   geomech_discretization => geomech_realization%geomech_discretization
   453)   option => geomech_realization%option
   454) 
   455)   ! Communication -----------------------------------------
   456)   call GeomechDiscretizationGlobalToLocal(geomech_discretization,xx, &
   457)                                           field%disp_xx_loc,NGEODOF)
   458)   
   459)   call GeomechForceResidualPatch(snes,xx,r,geomech_realization,ierr)
   460) 
   461)   if (geomech_realization%geomech_debug%vecview_residual) then
   462)     call PetscViewerASCIIOpen(geomech_realization%option%mycomm, &
   463)                               'Geomech_residual.out',viewer, &
   464)                               ierr);CHKERRQ(ierr)
   465)     call VecView(r,viewer,ierr);CHKERRQ(ierr)
   466)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   467) 
   468)   endif
   469)   
   470)   if (geomech_realization%geomech_debug%vecview_solution) then
   471)     call PetscViewerASCIIOpen(geomech_realization%option%mycomm, &
   472)                               'Geomech_xx.out', &
   473)                               viewer,ierr);CHKERRQ(ierr)
   474)     call VecView(xx,viewer,ierr);CHKERRQ(ierr)
   475)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   476)   endif
   477) 
   478) end subroutine GeomechForceResidual
   479) 
   480) ! ************************************************************************** !
   481) 
   482) subroutine GeomechForceResidualPatch(snes,xx,r,geomech_realization,ierr)
   483)   ! 
   484)   ! Computes the residual equation on a patch
   485)   ! 
   486)   ! Author: Satish Karra
   487)   ! Date: 06/24/13
   488)   ! 
   489) 
   490)   use Geomechanics_Realization_class
   491)   use Geomechanics_Field_module
   492)   use Geomechanics_Discretization_module
   493)   use Geomechanics_Patch_module
   494)   use Geomechanics_Grid_Aux_module
   495)   use Geomechanics_Grid_module
   496)   use Grid_Unstructured_Cell_module
   497)   use Geomechanics_Region_module
   498)   use Geomechanics_Coupler_module
   499)   use Option_module
   500)   use Geomechanics_Auxiliary_module
   501) 
   502)   implicit none
   503) 
   504)   SNES :: snes
   505)   Vec :: xx
   506)   Vec :: r
   507)   class(realization_geomech_type) :: geomech_realization
   508)   PetscViewer :: viewer
   509)   PetscErrorCode :: ierr
   510)   
   511)   type(geomech_discretization_type), pointer :: geomech_discretization
   512)   type(geomech_patch_type), pointer :: patch
   513)   type(geomech_field_type), pointer :: field
   514)   type(geomech_grid_type), pointer :: grid
   515)   type(geomech_global_auxvar_type), pointer :: geomech_global_aux_vars(:)
   516)   type(option_type), pointer :: option
   517)   type(gm_region_type), pointer :: region
   518)   type(geomech_coupler_type), pointer :: boundary_condition
   519)   type(geomech_parameter_type), pointer :: GeomechParam
   520) 
   521)   PetscInt, allocatable :: elenodes(:)
   522)   PetscReal, allocatable :: local_coordinates(:,:)
   523)   PetscReal, allocatable :: local_disp(:,:)
   524)   PetscReal, allocatable :: local_press(:), local_temp(:)
   525)   PetscInt, allocatable :: petsc_ids(:)
   526)   PetscInt, allocatable :: ids(:)
   527)   PetscReal, allocatable :: res_vec(:)
   528)   PetscReal, pointer :: press(:), temp(:)
   529)   PetscReal, pointer :: press_init(:), temp_init(:)
   530)   PetscReal, allocatable :: beta_vec(:), alpha_vec(:)
   531)   PetscReal, allocatable :: density_vec(:)
   532)   PetscReal, allocatable :: youngs_vec(:), poissons_vec(:)
   533)   PetscInt :: ielem, ivertex 
   534)   PetscInt :: ghosted_id
   535)   PetscInt :: eletype, idof
   536)   PetscInt :: petsc_id, local_id
   537)   PetscReal :: error_H1_global, error_L2_global
   538)   PetscReal :: error_L2, error_H1
   539)   PetscReal, pointer :: imech_loc_p(:)      
   540)   PetscInt :: size_elenodes
   541)                     
   542)   field => geomech_realization%geomech_field
   543)   geomech_discretization => geomech_realization%geomech_discretization
   544)   patch => geomech_realization%geomech_patch
   545)   grid => patch%geomech_grid
   546)   option => geomech_realization%option
   547)   geomech_global_aux_vars => patch%geomech_aux%GeomechGlobal%aux_vars  
   548)   GeomechParam => patch%geomech_aux%GeomechParam 
   549) 
   550)   call GeomechForceUpdateAuxVars(geomech_realization)
   551)   ! Add flag for the update
   552)   
   553)   call VecSet(r,0.d0,ierr);CHKERRQ(ierr)
   554)   
   555) #if 0  
   556)   error_H1_global = 0.d0
   557)   error_L2_global = 0.d0
   558) #endif
   559) 
   560)   ! Get pressure and temperature from subsurface
   561)   call VecGetArrayF90(field%press_loc,press,ierr);CHKERRQ(ierr)
   562)   call VecGetArrayF90(field%temp_loc,temp,ierr);CHKERRQ(ierr)
   563)   call VecGetArrayF90(field%imech_loc,imech_loc_p,ierr);CHKERRQ(ierr)
   564) 
   565)   ! Get initial pressure and temperature 
   566)   call VecGetArrayF90(field%press_init_loc,press_init,ierr);CHKERRQ(ierr)
   567)   call VecGetArrayF90(field%temp_init_loc,temp_init,ierr);CHKERRQ(ierr)
   568)  
   569)   ! Loop over elements on a processor
   570)   do ielem = 1, grid%nlmax_elem
   571)     allocate(elenodes(grid%elem_nodes(0,ielem)))
   572)     allocate(local_coordinates(size(elenodes),THREE_INTEGER))
   573)     allocate(local_disp(size(elenodes),option%ngeomechdof))
   574)     allocate(local_press(size(elenodes)))
   575)     allocate(local_temp(size(elenodes)))
   576)     allocate(petsc_ids(size(elenodes)))
   577)     allocate(ids(size(elenodes)*option%ngeomechdof))
   578)     allocate(res_vec(size(elenodes)*option%ngeomechdof))
   579)     allocate(beta_vec(size(elenodes)))
   580)     allocate(alpha_vec(size(elenodes)))
   581)     allocate(density_vec(size(elenodes)))
   582)     allocate(youngs_vec(size(elenodes)))
   583)     allocate(poissons_vec(size(elenodes)))
   584)     elenodes = grid%elem_nodes(1:grid%elem_nodes(0,ielem),ielem)
   585)     eletype = grid%gauss_node(ielem)%EleType
   586)     do ivertex = 1, grid%elem_nodes(0,ielem)
   587)       ghosted_id = elenodes(ivertex)
   588)       local_coordinates(ivertex,GEOMECH_DISP_X_DOF) = grid%nodes(ghosted_id)%x
   589)       local_coordinates(ivertex,GEOMECH_DISP_Y_DOF) = grid%nodes(ghosted_id)%y
   590)       local_coordinates(ivertex,GEOMECH_DISP_Z_DOF) = grid%nodes(ghosted_id)%z
   591)       petsc_ids(ivertex) = grid%node_ids_ghosted_petsc(ghosted_id)
   592)     enddo
   593)     do ivertex = 1, grid%elem_nodes(0,ielem)
   594)       ghosted_id = elenodes(ivertex)
   595)       do idof = 1, option%ngeomechdof
   596)         local_disp(ivertex,idof) = &
   597)           geomech_global_aux_vars(ghosted_id)%disp_vector(idof)
   598)         ids(idof + (ivertex-1)*option%ngeomechdof) = &
   599)           (petsc_ids(ivertex)-1)*option%ngeomechdof + (idof-1)
   600)       enddo
   601)       local_press(ivertex) = press(ghosted_id) - press_init(ghosted_id)  ! p - p_0
   602)       local_temp(ivertex) = temp(ghosted_id) - temp_init(ghosted_id)     ! T - T_0
   603)       alpha_vec(ivertex) = &
   604)         GeomechParam%thermal_exp_coef(int(imech_loc_p(ghosted_id))) 
   605)       beta_vec(ivertex) = &
   606)         GeomechParam%biot_coef(int(imech_loc_p(ghosted_id))) 
   607)       density_vec(ivertex) = &
   608)         GeomechParam%density(int(imech_loc_p(ghosted_id))) 
   609)       youngs_vec(ivertex) = &
   610)         GeomechParam%youngs_modulus(int(imech_loc_p(ghosted_id))) 
   611)       poissons_vec(ivertex) = &
   612)         GeomechParam%poissons_ratio(int(imech_loc_p(ghosted_id))) 
   613)     enddo
   614)     size_elenodes = size(elenodes)
   615)     call GeomechForceLocalElemResidual(size_elenodes,local_coordinates, &
   616)        local_disp,local_press,local_temp,youngs_vec,poissons_vec, &
   617)        density_vec,beta_vec,alpha_vec,eletype, &
   618)        grid%gauss_node(ielem)%dim,grid%gauss_node(ielem)%r, &
   619)        grid%gauss_node(ielem)%w,res_vec,option)
   620)     call VecSetValues(r,size(ids),ids,res_vec,ADD_VALUES,ierr);CHKERRQ(ierr)
   621) #if 0
   622)     call GeomechForceLocalElemError(size_elenodes,local_coordinates, &
   623)                                     local_disp, &
   624)                                     eletype,grid%gauss_node(ielem)%dim, &
   625)                                     grid%gauss_node(ielem)%r, &
   626)                                     grid%gauss_node(ielem)%w,error_L2, &
   627)                                     error_H1,option)
   628)     error_H1_global = error_H1_global + error_H1
   629)     error_L2_global = error_L2_global + error_L2
   630) #endif
   631)     deallocate(elenodes)
   632)     deallocate(local_coordinates)
   633)     deallocate(local_disp)
   634)     deallocate(petsc_ids)
   635)     deallocate(ids)
   636)     deallocate(res_vec)
   637)     deallocate(local_press)
   638)     deallocate(local_temp)
   639)     deallocate(beta_vec)
   640)     deallocate(alpha_vec)
   641)     deallocate(density_vec)
   642)     deallocate(youngs_vec)
   643)     deallocate(poissons_vec)
   644)   enddo
   645)       
   646)   call VecRestoreArrayF90(field%press_loc,press,ierr);CHKERRQ(ierr)
   647)   call VecRestoreArrayF90(field%temp_loc,temp,ierr);CHKERRQ(ierr)
   648)   call VecRestoreArrayF90(field%imech_loc,imech_loc_p,ierr);CHKERRQ(ierr)
   649)     
   650)   call VecRestoreArrayF90(field%press_init_loc,press_init,ierr);CHKERRQ(ierr)
   651)   call VecRestoreArrayF90(field%temp_init_loc,temp_init,ierr);CHKERRQ(ierr)
   652) 
   653) #if 0
   654)   call MPI_Allreduce(error_H1_global,error_H1_global,ONE_INTEGER_MPI, &
   655)                      MPI_DOUBLE_PRECISION, &
   656)                      MPI_SUM,option%mycomm,ierr)      
   657)   call MPI_Allreduce(error_L2_global,error_L2_global,ONE_INTEGER_MPI, &
   658)                      MPI_DOUBLE_PRECISION, &
   659)                      MPI_SUM,option%mycomm,ierr)   
   660)                      
   661)   if (option%myrank == option%io_rank) then                   
   662)     print *, 'L2 error:', sqrt(error_L2_global)
   663)     print *, 'H1 error:', sqrt(error_H1_global)
   664)   endif
   665) #endif      
   666)       
   667)       
   668)   call VecAssemblyBegin(r,ierr);CHKERRQ(ierr)
   669)   call VecAssemblyEnd(r,ierr);CHKERRQ(ierr)
   670) 
   671)   ! Find the boundary nodes with dirichlet and set the residual at those nodes
   672)   ! to zero, later set the Jacobian to 1
   673) 
   674)   ! displacement boundary conditions
   675)   boundary_condition => patch%geomech_boundary_condition_list%first
   676)   do 
   677)     if (.not.associated(boundary_condition)) exit
   678)     region => boundary_condition%region
   679)     do ivertex = 1, region%num_verts
   680)       local_id = region%vertex_ids(ivertex)
   681)       ghosted_id = grid%nL2G(local_id)
   682)       petsc_id = grid%node_ids_ghosted_petsc(ghosted_id)
   683)       if (associated(patch%imat)) then
   684)         if (patch%imat(ghosted_id) <= 0) cycle
   685)       endif    
   686)       
   687)       ! X displacement 
   688)       if (associated(boundary_condition%geomech_condition%displacement_x)) then
   689)         select case(boundary_condition%geomech_condition%displacement_x%itype)
   690)           case(DIRICHLET_BC)
   691)             call VecSetValue(r,(petsc_id-1)*option%ngeomechdof + &
   692)               GEOMECH_DISP_X_DOF-1,0.d0,INSERT_VALUES,ierr);CHKERRQ(ierr)
   693)           case(ZERO_GRADIENT_BC)
   694)            ! do nothing
   695)           case(NEUMANN_BC)
   696)             option%io_buffer = 'Neumann BC for displacement not available.'
   697)             call printErrMsg(option)
   698)         end select
   699)       endif
   700)       
   701)       ! Y displacement 
   702)       if (associated(boundary_condition%geomech_condition%displacement_y)) then
   703)         select case(boundary_condition%geomech_condition%displacement_y%itype)
   704)           case(DIRICHLET_BC)
   705)             call VecSetValue(r,(petsc_id-1)*option%ngeomechdof + &
   706)               GEOMECH_DISP_Y_DOF-1,0.d0,INSERT_VALUES,ierr);CHKERRQ(ierr)
   707)           case(ZERO_GRADIENT_BC)
   708)            ! do nothing
   709)           case(NEUMANN_BC)
   710)             option%io_buffer = 'Neumann BC for displacement not available.'
   711)             call printErrMsg(option)
   712)         end select
   713)       endif
   714)       
   715)       ! Z displacement      
   716)       if (associated(boundary_condition%geomech_condition%displacement_z)) then
   717)         select case(boundary_condition%geomech_condition%displacement_z%itype)
   718)           case(DIRICHLET_BC)
   719)             call VecSetValue(r,(petsc_id-1)*option%ngeomechdof + &
   720)               GEOMECH_DISP_Z_DOF-1,0.d0,INSERT_VALUES,ierr);CHKERRQ(ierr)
   721)           case(ZERO_GRADIENT_BC)
   722)            ! do nothing
   723)           case(NEUMANN_BC)
   724)             option%io_buffer = 'Neumann BC for displacement not available.'
   725)             call printErrMsg(option)
   726)         end select
   727)       endif
   728)       
   729)     enddo
   730)     boundary_condition => boundary_condition%next      
   731)   enddo
   732) 
   733)   ! Need to assemby here since one cannot mix INSERT_VALUES
   734)   ! and ADD_VALUES
   735)   call VecAssemblyBegin(r,ierr);CHKERRQ(ierr)
   736)   call VecAssemblyEnd(r,ierr);CHKERRQ(ierr)
   737)   
   738)   ! Force boundary conditions
   739)   boundary_condition => patch%geomech_boundary_condition_list%first
   740)   do 
   741)     if (.not.associated(boundary_condition)) exit
   742)     region => boundary_condition%region
   743)     do ivertex = 1, region%num_verts
   744)       local_id = region%vertex_ids(ivertex)
   745)       ghosted_id = grid%nL2G(local_id)
   746)       petsc_id = grid%node_ids_ghosted_petsc(ghosted_id)
   747)       if (associated(patch%imat)) then
   748)         if (patch%imat(ghosted_id) <= 0) cycle
   749)       endif    
   750)        
   751)       ! X force 
   752)       if (associated(boundary_condition%geomech_condition%force_x)) then
   753)         select case(boundary_condition%geomech_condition%force_x%itype)
   754)           case(DIRICHLET_BC)
   755)             call VecSetValue(r,(petsc_id-1)*option%ngeomechdof + &
   756)               GEOMECH_DISP_X_DOF-1, &
   757)               -boundary_condition%geomech_aux_real_var &
   758)               (GEOMECH_DISP_X_DOF,ivertex),ADD_VALUES,ierr);CHKERRQ(ierr)
   759)           case(ZERO_GRADIENT_BC)
   760)            ! do nothing
   761)           case(NEUMANN_BC)
   762)             option%io_buffer = 'Neumann BC for force not available.'
   763)             call printErrMsg(option)
   764)         end select
   765)       endif
   766)       
   767)        ! Y force 
   768)       if (associated(boundary_condition%geomech_condition%force_y)) then
   769)         select case(boundary_condition%geomech_condition%force_y%itype)
   770)           case(DIRICHLET_BC)
   771)             call VecSetValue(r,(petsc_id-1)*option%ngeomechdof + &
   772)               GEOMECH_DISP_Y_DOF-1, &
   773)               -boundary_condition%geomech_aux_real_var &
   774)               (GEOMECH_DISP_Y_DOF,ivertex),ADD_VALUES,ierr);CHKERRQ(ierr)
   775)           case(ZERO_GRADIENT_BC)
   776)            ! do nothing
   777)           case(NEUMANN_BC)
   778)             option%io_buffer = 'Neumann BC for force not available.'
   779)             call printErrMsg(option)
   780) 
   781)         end select
   782)       endif
   783) 
   784)        ! Z force 
   785)       if (associated(boundary_condition%geomech_condition%force_z)) then
   786)         select case(boundary_condition%geomech_condition%force_z%itype)
   787)           case(DIRICHLET_BC)
   788)             call VecSetValue(r,(petsc_id-1)*option%ngeomechdof + &
   789)               GEOMECH_DISP_Z_DOF-1, &
   790)               -boundary_condition%geomech_aux_real_var &
   791)               (GEOMECH_DISP_Z_DOF,ivertex),ADD_VALUES,ierr);CHKERRQ(ierr)
   792)           case(ZERO_GRADIENT_BC)
   793)            ! do nothing
   794)           case(NEUMANN_BC)
   795)             option%io_buffer = 'Neumann BC for force not available.'
   796)             call printErrMsg(option)
   797)         end select
   798)       endif
   799)  
   800)     enddo
   801)     boundary_condition => boundary_condition%next      
   802)   enddo
   803) 
   804)   call VecAssemblyBegin(r,ierr);CHKERRQ(ierr)
   805)   call VecAssemblyEnd(r,ierr);CHKERRQ(ierr)
   806) 
   807) end subroutine GeomechForceResidualPatch
   808) 
   809) ! ************************************************************************** !
   810) 
   811) subroutine GeomechForceLocalElemResidual(size_elenodes,local_coordinates, &
   812)                                          local_disp, &
   813)                                          local_press,local_temp, &
   814)                                          local_youngs,local_poissons, &
   815)                                          local_density,local_beta, &
   816)                                          local_alpha, &
   817)                                          eletype,dim,r,w,res_vec,option)
   818)   ! 
   819)   ! Computes the residual for a local element
   820)   ! 
   821)   ! Author: Satish Karra
   822)   ! Date: 06/24/13
   823)   ! 
   824)                                          
   825)   use Grid_Unstructured_Cell_module
   826)   use Shape_Function_module
   827)   use Option_module
   828)   use Utility_module
   829)   
   830)   type(shapefunction_type) :: shapefunction
   831)   type(option_type) :: option
   832) 
   833)   PetscReal, allocatable :: local_coordinates(:,:)
   834)   PetscReal, allocatable :: B(:,:), Kmat(:,:)
   835)   PetscReal, allocatable :: res_vec(:)
   836)   PetscReal, allocatable :: local_disp(:,:)
   837)   PetscReal, allocatable :: local_press(:)
   838)   PetscReal, allocatable :: local_temp(:)
   839)   PetscReal, allocatable :: local_youngs(:)
   840)   PetscReal, allocatable :: local_poissons(:)
   841)   PetscReal, allocatable :: local_density(:)
   842)   PetscReal, allocatable :: local_beta(:)
   843)   PetscReal, allocatable :: local_alpha(:)
   844)       
   845)   PetscReal, pointer :: r(:,:), w(:)
   846)   PetscInt :: igpt
   847)   PetscInt :: len_w
   848)   PetscInt :: eletype
   849)   PetscReal :: x(THREE_INTEGER), J_map(THREE_INTEGER,THREE_INTEGER)
   850)   PetscReal :: inv_J_map(THREE_INTEGER,THREE_INTEGER)
   851)   PetscReal :: detJ_map
   852)   PetscInt :: i,j,d
   853)   PetscReal :: eye_three(THREE_INTEGER)
   854)   PetscInt :: indx(THREE_INTEGER)
   855)   PetscInt :: dim
   856)   PetscReal :: lambda, mu, beta, alpha
   857)   PetscReal :: density, youngs_mod, poissons_ratio
   858)   PetscInt :: load_type
   859)   PetscReal :: bf(THREE_INTEGER)
   860)   PetscReal :: identity(THREE_INTEGER,THREE_INTEGER)
   861)   PetscReal, allocatable :: N(:,:)
   862)   PetscReal, allocatable :: vecB_transpose(:,:)
   863)   PetscReal, allocatable :: kron_B_eye(:,:)
   864)   PetscReal, allocatable :: kron_B_transpose_eye(:,:)
   865)   PetscReal, allocatable :: Trans(:,:)
   866)   PetscReal, allocatable :: kron_eye_B_transpose(:,:)
   867)   PetscReal, allocatable :: kron_N_eye(:,:)
   868)   PetscReal, allocatable :: vec_local_disp(:,:)
   869)   PetscReal, allocatable :: force(:), res_vec_mat(:,:)
   870)   PetscInt :: size_elenodes
   871)   
   872)   allocate(B(size_elenodes,dim))
   873)   allocate(Kmat(size_elenodes*option%ngeomechdof, &
   874)                 size_elenodes*option%ngeomechdof))  
   875)   allocate(force(size_elenodes*option%ngeomechdof))
   876)   allocate(res_vec_mat(size_elenodes*option%ngeomechdof,1))
   877)   
   878)   res_vec = 0.d0
   879)   res_vec_mat = 0.d0
   880)   Kmat = 0.d0
   881)   force = 0.d0
   882)   len_w = size(w)
   883)   
   884)   identity = 0.d0
   885)   do i = 1, THREE_INTEGER
   886)     do j = 1, THREE_INTEGER
   887)       if (i == j) identity(i,j) = 1.d0
   888)     enddo
   889)   enddo
   890)   
   891)   call Transposer(option%ngeomechdof,size_elenodes,Trans)
   892)  
   893)   do igpt = 1, len_w
   894)     shapefunction%EleType = eletype
   895)     call ShapeFunctionInitialize(shapefunction)
   896)     shapefunction%zeta = r(igpt,:)
   897)     call ShapeFunctionCalculate(shapefunction)
   898)     x = matmul(transpose(local_coordinates),shapefunction%N)
   899)     J_map = matmul(transpose(local_coordinates),shapefunction%DN)
   900)     allocate(N(size(shapefunction%N),ONE_INTEGER))
   901)     call Determinant(J_map,detJ_map)
   902)     if (detJ_map <= 0.d0) then
   903)       option%io_buffer = 'GEOMECHANICS: Determinant of J_map has' // &
   904)                          ' to be positive!' 
   905)       call printErrMsg(option)        
   906)     endif
   907)     ! Find the inverse of J_map
   908)     ! Set identity matrix
   909)     call ludcmp(J_map,THREE_INTEGER,indx,d)
   910)     do i = 1, THREE_INTEGER
   911)       eye_three = 0.d0
   912)       eye_three(i) = 1.d0
   913)       call lubksb(J_map,THREE_INTEGER,indx,eye_three)
   914)       inv_J_map(:,i) = eye_three
   915)     enddo
   916)     B = matmul(shapefunction%DN,inv_J_map)
   917)     youngs_mod = dot_product(shapefunction%N,local_youngs)
   918)     poissons_ratio = dot_product(shapefunction%N,local_poissons)
   919)     alpha = dot_product(shapefunction%N,local_alpha)
   920)     beta = dot_product(shapefunction%N,local_beta)
   921)     density = dot_product(shapefunction%N,local_density) 
   922)     call GeomechGetLambdaMu(lambda,mu,youngs_mod,poissons_ratio)
   923)     call GeomechGetBodyForce(load_type,lambda,mu,x,bf,option) 
   924)     call ConvertMatrixToVector(transpose(B),vecB_transpose)
   925)     Kmat = Kmat + w(igpt)*lambda* &
   926)       matmul(vecB_transpose,transpose(vecB_transpose))*detJ_map
   927)     call Kron(B,identity,kron_B_eye)
   928)     call Kron(transpose(B),identity,kron_B_transpose_eye)
   929)     call Kron(identity,transpose(B),kron_eye_B_transpose)
   930)     N(:,1)= shapefunction%N    
   931)     call Kron(N,identity,kron_N_eye)
   932)     Kmat = Kmat + w(igpt)*mu*matmul(kron_B_eye,kron_B_transpose_eye)*detJ_map
   933)     Kmat = Kmat + w(igpt)*mu* &
   934)       matmul(matmul(kron_B_eye,kron_eye_B_transpose),Trans)*detJ_map
   935)     force = force + w(igpt)*density*matmul(kron_N_eye,bf)*detJ_map
   936)     force = force + w(igpt)*beta*dot_product(N(:,1),local_press)* &
   937)       vecB_transpose(:,1)*detJ_map
   938)     force = force + w(igpt)*alpha*(3*lambda+2*mu)* &
   939)       dot_product(N(:,1),local_temp)*vecB_transpose(:,1)*detJ_map  
   940)     call ShapeFunctionDestroy(shapefunction)
   941)     deallocate(N)
   942)     deallocate(vecB_transpose)
   943)     deallocate(kron_B_eye)
   944)     deallocate(kron_B_transpose_eye)
   945)     deallocate(kron_eye_B_transpose)
   946)     deallocate(kron_N_eye)
   947)   enddo
   948)   
   949)   call ConvertMatrixToVector(transpose(local_disp),vec_local_disp)
   950)   res_vec_mat = matmul(Kmat,vec_local_disp)
   951)   res_vec = res_vec + res_vec_mat(:,1)
   952)   res_vec = res_vec - force
   953) 
   954)   deallocate(B)
   955)   deallocate(force)
   956)   deallocate(Kmat)
   957)   deallocate(res_vec_mat)
   958)   deallocate(vec_local_disp)
   959)   deallocate(Trans)
   960) 
   961) end subroutine GeomechForceLocalElemResidual
   962) 
   963) ! ************************************************************************** !
   964) !
   965) ! GeomechForceLocalElemError: Computes the error for a local element
   966) ! author: Satish Karra
   967) ! date: 07/08/13
   968) !
   969) ! ************************************************************************** !
   970) #if 0
   971) 
   972) ! ************************************************************************** !
   973) 
   974) subroutine GeomechForceLocalElemError(size_elenodes,local_coordinates, &
   975)                                       local_disp, &
   976)                                       eletype,dim,r,w,error_L2,error_H1,option)
   977)                                          
   978)   use Grid_Unstructured_Cell_module
   979)   use Shape_Function_module
   980)   use Option_module
   981)   use Utility_module
   982)   
   983)   type(shapefunction_type) :: shapefunction
   984)   type(option_type) :: option
   985) 
   986)   
   987)   PetscReal, allocatable :: local_coordinates(:,:)
   988)   PetscReal, allocatable :: B(:,:), Kmat(:,:)
   989)   PetscReal, allocatable :: res_vec(:)
   990)   PetscReal, allocatable :: local_disp(:,:)
   991)   PetscReal, pointer :: r(:,:), w(:)
   992)   PetscInt :: igpt
   993)   PetscInt :: len_w
   994)   PetscInt :: eletype
   995)   PetscReal :: x(THREE_INTEGER), J_map(THREE_INTEGER,THREE_INTEGER)
   996)   PetscReal :: u(THREE_INTEGER)
   997)   PetscReal :: inv_J_map(THREE_INTEGER,THREE_INTEGER)
   998)   PetscReal :: detJ_map
   999)   PetscInt :: i,j,d
  1000)   PetscReal :: eye_three(THREE_INTEGER)
  1001)   PetscInt :: indx(THREE_INTEGER)
  1002)   PetscInt :: dim
  1003)   PetscReal :: lambda, mu
  1004)   PetscInt :: load_type
  1005)   PetscReal :: bf(THREE_INTEGER)
  1006)   PetscReal :: identity(THREE_INTEGER,THREE_INTEGER)
  1007)   PetscReal :: den_rock
  1008)   PetscReal :: grad_u(THREE_INTEGER,THREE_INTEGER)
  1009)   PetscReal :: grad_u_exact(THREE_INTEGER,THREE_INTEGER)
  1010)   PetscReal :: u_exact(THREE_INTEGER)
  1011)   PetscReal :: error_H1, error_L2
  1012)   PetscReal :: trace_disp, trace_disp_grad
  1013)   
  1014)   allocate(B(size_elenodes,dim))
  1015)   
  1016)   error_H1 = 0.d0
  1017)   error_L2 = 0.d0
  1018) 
  1019)   len_w = size(w)
  1020)   
  1021)   identity = 0.d0
  1022)   do i = 1, THREE_INTEGER
  1023)     do j = 1, THREE_INTEGER
  1024)       if (i == j) identity(i,j) = 1.d0
  1025)     enddo
  1026)   enddo
  1027)     
  1028)   do igpt = 1, len_w
  1029)     shapefunction%EleType = eletype
  1030)     call ShapeFunctionInitialize(shapefunction)
  1031)     shapefunction%zeta = r(igpt,:)
  1032)     call ShapeFunctionCalculate(shapefunction)
  1033)     x = matmul(transpose(local_coordinates),shapefunction%N)
  1034)     J_map = matmul(transpose(local_coordinates),shapefunction%DN)
  1035)     u = matmul(transpose(local_disp),shapefunction%N)
  1036)     call Determinant(J_map,detJ_map)
  1037)     if (detJ_map <= 0.d0) then
  1038)       option%io_buffer = 'GEOMECHANICS: Determinant of J_map has' // &
  1039)                          ' to be positive!' 
  1040)       call printErrMsg(option)        
  1041)     endif
  1042)     ! Find the inverse of J_map
  1043)     ! Set identity matrix
  1044)     call ludcmp(J_map,THREE_INTEGER,indx,d)
  1045)     do i = 1, THREE_INTEGER
  1046)       eye_three = 0.d0
  1047)       eye_three(i) = 1.d0
  1048)       call lubksb(J_map,THREE_INTEGER,indx,eye_three)
  1049)       inv_J_map(:,i) = eye_three
  1050)     enddo
  1051)     B = matmul(shapefunction%DN,inv_J_map)
  1052)     grad_u = matmul(transpose(local_disp),B)
  1053)     call GeomechGetLambdaMu(lambda,mu,x)
  1054)     load_type = 2 ! Need to change
  1055)     call GeomechGetBodyForce(load_type,lambda,mu,x,bf,option) 
  1056)     call GetAnalytical(load_type,lambda,mu,x,u_exact,grad_u_exact)
  1057)     trace_disp = 0.d0
  1058)     do i = 1,3
  1059)         trace_disp = trace_disp + (u_exact(i) - u(i))**2
  1060)     enddo
  1061)     error_L2 = error_L2 + w(igpt)*trace_disp*detJ_map
  1062)     trace_disp_grad = 0.d0
  1063)     do i = 1,3
  1064)       do j = 1,3
  1065)         trace_disp_grad = trace_disp_grad + (grad_u_exact(i,j) - grad_u(i,j))**2
  1066)       enddo
  1067)     enddo
  1068)     error_H1 = error_H1 + w(igpt)*trace_disp_grad*detJ_map
  1069)     call ShapeFunctionDestroy(shapefunction)
  1070)   enddo
  1071) 
  1072)   deallocate(B)
  1073) 
  1074) end subroutine GeomechForceLocalElemError
  1075) #endif
  1076) 
  1077) ! ************************************************************************** !
  1078) 
  1079) subroutine GetAnalytical(load_type,lambda,mu,coord,u,grad_u)
  1080)   ! 
  1081)   ! GeomechGetBodyForce: Gets the body force at a given position
  1082)   ! of the point
  1083)   ! 
  1084)   ! Author: Satish Karra
  1085)   ! Date: 06/24/13
  1086)   ! 
  1087) 
  1088)   PetscReal :: lambda, mu
  1089)   PetscReal :: coord(THREE_INTEGER)
  1090)   PetscReal :: u(THREE_INTEGER)
  1091)   PetscReal :: grad_u(THREE_INTEGER,THREE_INTEGER)
  1092)   PetscInt :: load_type
  1093)   PetscReal :: x, y, z
  1094)   
  1095)   x = coord(1)
  1096)   y = coord(2)
  1097)   z = coord(3)
  1098)   
  1099)   select case(load_type)
  1100)     case(2)
  1101)       u(1) = 2*y*(x+y+z)
  1102)       u(2) = 4*x-y**2-z**2
  1103)       u(3) = sin(PI*x)*sin(PI*y)*sin(PI*z)
  1104)       grad_u(1,1) = 2*y
  1105)       grad_u(1,2) = 2*x + 4*y + 2*z
  1106)       grad_u(1,3) = 2*y
  1107)       grad_u(2,1) = 4
  1108)       grad_u(2,2) = (-2)*y
  1109)       grad_u(2,3) = (-2)*z
  1110)       grad_u(3,1) = PI*cos(PI*x)*sin(PI*y)*sin(PI*z)
  1111)       grad_u(3,2) = PI*cos(PI*y)*sin(PI*x)*sin(PI*z)
  1112)       grad_u(3,3) = PI*cos(PI*z)*sin(PI*x)*sin(PI*y)
  1113)     case default
  1114)   end select
  1115)   
  1116) end subroutine GetAnalytical
  1117) 
  1118) ! ************************************************************************** !
  1119) 
  1120) subroutine GeomechForceLocalElemJacobian(size_elenodes,local_coordinates, &
  1121)                                          local_disp, &
  1122)                                          local_youngs,local_poissons, &
  1123)                                          eletype,dim,r,w,Kmat,option)
  1124)   ! 
  1125)   ! Computes the Jacobian for a local element
  1126)   ! 
  1127)   ! Author: Satish Karra
  1128)   ! Date: 06/24/13
  1129)   ! 
  1130)                                          
  1131)   use Grid_Unstructured_Cell_module
  1132)   use Shape_Function_module
  1133)   use Option_module
  1134)   use Utility_module
  1135)   
  1136)   type(shapefunction_type) :: shapefunction
  1137)   type(option_type) :: option
  1138) 
  1139)   PetscReal, allocatable :: local_coordinates(:,:)
  1140)   PetscReal, allocatable :: B(:,:), Kmat(:,:)
  1141)   PetscReal, allocatable :: local_disp(:)
  1142)   PetscReal, pointer :: r(:,:), w(:)
  1143)   PetscInt :: igpt
  1144)   PetscInt :: len_w
  1145)   PetscInt :: eletype
  1146)   PetscReal :: x(THREE_INTEGER), J_map(THREE_INTEGER,THREE_INTEGER)
  1147)   PetscReal :: inv_J_map(THREE_INTEGER,THREE_INTEGER)
  1148)   PetscReal :: detJ_map
  1149)   PetscInt :: i,j,d
  1150)   PetscReal :: eye_three(THREE_INTEGER)
  1151)   PetscInt :: indx(THREE_INTEGER)
  1152)   PetscInt :: dim
  1153)   PetscReal :: lambda, mu
  1154)   PetscReal :: youngs_mod, poissons_ratio
  1155)   PetscReal :: identity(THREE_INTEGER,THREE_INTEGER)
  1156)   PetscReal, allocatable :: N(:,:)
  1157)   PetscReal, allocatable :: vecB_transpose(:,:)
  1158)   PetscReal, allocatable :: kron_B_eye(:,:)
  1159)   PetscReal, allocatable :: kron_B_transpose_eye(:,:)
  1160)   PetscReal, allocatable :: Trans(:,:)
  1161)   PetscReal, allocatable :: kron_eye_B_transpose(:,:)
  1162)   PetscReal, allocatable :: kron_N_eye(:,:)
  1163)   PetscReal, allocatable :: local_youngs(:)
  1164)   PetscReal, allocatable :: local_poissons(:)
  1165)   PetscInt :: size_elenodes
  1166) 
  1167)   allocate(B(size_elenodes,dim))
  1168)   
  1169)   Kmat = 0.d0
  1170)   len_w = size(w)
  1171)   
  1172)   identity = 0.d0
  1173)   do i = 1, THREE_INTEGER
  1174)     do j = 1, THREE_INTEGER
  1175)       if (i == j) identity(i,j) = 1.d0
  1176)     enddo
  1177)   enddo
  1178)   
  1179)   call Transposer(option%ngeomechdof,size_elenodes,Trans)
  1180) 
  1181)   do igpt = 1, len_w
  1182)     shapefunction%EleType = eletype
  1183)     call ShapeFunctionInitialize(shapefunction)
  1184)     shapefunction%zeta = r(igpt,:)
  1185)     call ShapeFunctionCalculate(shapefunction)
  1186)     x = matmul(transpose(local_coordinates),shapefunction%N)
  1187)     J_map = matmul(transpose(local_coordinates),shapefunction%DN)
  1188)     allocate(N(size(shapefunction%N),ONE_INTEGER))
  1189)     call Determinant(J_map,detJ_map)
  1190)     if (detJ_map <= 0.d0) then
  1191)       option%io_buffer = 'GEOMECHANICS: Determinant of J_map has' // &
  1192)                          ' to be positive!' 
  1193)       call printErrMsg(option)        
  1194)     endif
  1195)     ! Find the inverse of J_map
  1196)     ! Set identity matrix
  1197)     call ludcmp(J_map,THREE_INTEGER,indx,d)
  1198)     do i = 1, THREE_INTEGER
  1199)       eye_three = 0.d0
  1200)       eye_three(i) = 1.d0
  1201)       call lubksb(J_map,THREE_INTEGER,indx,eye_three)
  1202)       inv_J_map(:,i) = eye_three
  1203)     enddo
  1204)     B = matmul(shapefunction%DN,inv_J_map)
  1205)     youngs_mod = dot_product(shapefunction%N,local_youngs)
  1206)     poissons_ratio = dot_product(shapefunction%N,local_poissons)
  1207)     call GeomechGetLambdaMu(lambda,mu,youngs_mod,poissons_ratio)
  1208)     call ConvertMatrixToVector(transpose(B),vecB_transpose)
  1209)     Kmat = Kmat + w(igpt)*lambda* &
  1210)       matmul(vecB_transpose,transpose(vecB_transpose))*detJ_map
  1211)     call Kron(B,identity,kron_B_eye)
  1212)     call Kron(transpose(B),identity,kron_B_transpose_eye)
  1213)     call Kron(identity,transpose(B),kron_eye_B_transpose)
  1214)     N(:,1)= shapefunction%N    
  1215)     call Kron(N,identity,kron_N_eye)
  1216)     Kmat = Kmat + w(igpt)*mu* &
  1217)       matmul(kron_B_eye,kron_B_transpose_eye)*detJ_map
  1218)     Kmat = Kmat + w(igpt)*mu* &
  1219)       matmul(matmul(kron_B_eye,kron_eye_B_transpose),Trans)*detJ_map
  1220)     call ShapeFunctionDestroy(shapefunction)
  1221)     deallocate(N)
  1222)     deallocate(vecB_transpose)
  1223)     deallocate(kron_B_eye)
  1224)     deallocate(kron_B_transpose_eye)
  1225)     deallocate(kron_eye_B_transpose)
  1226)     deallocate(kron_N_eye)
  1227)   enddo
  1228)     
  1229)   deallocate(B)
  1230)   deallocate(Trans)
  1231) 
  1232) end subroutine GeomechForceLocalElemJacobian
  1233) 
  1234) ! ************************************************************************** !
  1235) 
  1236) subroutine GeomechGetLambdaMu(lambda,mu,E,nu)
  1237)   ! 
  1238)   ! Gets the material properties given the position
  1239)   ! of the point
  1240)   ! 
  1241)   ! Author: Satish Karra
  1242)   ! Date: 06/24/13
  1243)   ! 
  1244) 
  1245)   PetscReal :: lambda, mu
  1246)   PetscReal :: E, nu
  1247)   PetscReal :: coord(THREE_INTEGER)
  1248)  
  1249)   lambda = E*nu/(1.d0+nu)/(1.d0-2.d0*nu)
  1250)   mu = E/2.d0/(1.d0+nu)
  1251) 
  1252) 
  1253) end subroutine GeomechGetLambdaMu
  1254) 
  1255) ! ************************************************************************** !
  1256) 
  1257) subroutine GeomechGetBodyForce(load_type,lambda,mu,coord,bf,option)
  1258)   ! 
  1259)   ! Gets the body force at a given position
  1260)   ! of the point
  1261)   ! 
  1262)   ! Author: Satish Karra
  1263)   ! Date: 06/24/13
  1264)   ! 
  1265) 
  1266)   use Option_module
  1267) 
  1268)   type(option_type) :: option
  1269) 
  1270)   PetscInt :: load_type
  1271)   PetscReal :: lambda, mu, den_rock
  1272)   PetscReal :: coord(THREE_INTEGER)
  1273)   PetscReal :: bf(THREE_INTEGER)
  1274)   PetscReal :: x, y, z
  1275)  
  1276)   bf = 0.d0
  1277)   
  1278)   x = coord(1)
  1279)   y = coord(2)
  1280)   z = coord(3)
  1281)     
  1282)   ! This subroutine needs major changes. For given position, it needs to give 
  1283)   ! out lambda, mu, also need to add density of rock
  1284)   
  1285)   
  1286)   select case(load_type)
  1287)     case default
  1288)       bf(GEOMECH_DISP_X_DOF) = option%geomech_gravity(X_DIRECTION)
  1289)       bf(GEOMECH_DISP_Y_DOF) = option%geomech_gravity(Y_DIRECTION)
  1290)       bf(GEOMECH_DISP_Z_DOF) = option%geomech_gravity(Z_DIRECTION)
  1291)   end select
  1292)   
  1293) end subroutine GeomechGetBodyForce
  1294) 
  1295) ! ************************************************************************** !
  1296) 
  1297) subroutine GeomechForceJacobian(snes,xx,A,B,geomech_realization,ierr)
  1298)   ! 
  1299)   ! Computes the Jacobian
  1300)   ! 
  1301)   ! Author: Satish Karra
  1302)   ! Date: 06/21/13
  1303)   ! 
  1304) 
  1305)   use Geomechanics_Realization_class
  1306)   use Geomechanics_Patch_module
  1307)   use Geomechanics_Grid_module
  1308)   use Geomechanics_Grid_Aux_module
  1309)   use Option_module
  1310) 
  1311)   implicit none
  1312) 
  1313)   SNES :: snes
  1314)   Vec :: xx
  1315)   Mat :: A, B
  1316)   class(realization_geomech_type) :: geomech_realization
  1317)   PetscErrorCode :: ierr
  1318)   
  1319)   Mat :: J
  1320)   MatType :: mat_type
  1321)   PetscViewer :: viewer
  1322)   type(geomech_grid_type),  pointer :: grid
  1323)   type(option_type), pointer :: option
  1324)   PetscReal :: norm
  1325)   
  1326)   option => geomech_realization%option
  1327) 
  1328)   call MatGetType(A,mat_type,ierr);CHKERRQ(ierr)
  1329)   if (mat_type == MATMFFD) then
  1330)     J = B
  1331)     call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  1332)     call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  1333)   else
  1334)     J = A
  1335)   endif
  1336) 
  1337)   call GeomechForceJacobianPatch(snes,xx,J,J,geomech_realization,ierr)
  1338) 
  1339)   if (geomech_realization%geomech_debug%matview_Jacobian) then
  1340)     call PetscViewerASCIIOpen(geomech_realization%option%mycomm, &
  1341)                               'Geomech_jacobian.out', &
  1342)                               viewer,ierr);CHKERRQ(ierr)
  1343)    
  1344)     call MatView(J,viewer,ierr);CHKERRQ(ierr)
  1345)     call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  1346)   endif
  1347)   if (geomech_realization%geomech_debug%norm_Jacobian) then
  1348)     option => geomech_realization%option
  1349)     call MatNorm(J,NORM_1,norm,ierr);CHKERRQ(ierr)
  1350)     write(option%io_buffer,'("1 norm: ",es11.4)') norm
  1351)     call printMsg(option) 
  1352)     call MatNorm(J,NORM_FROBENIUS,norm,ierr);CHKERRQ(ierr)
  1353)     write(option%io_buffer,'("2 norm: ",es11.4)') norm
  1354)     call printMsg(option) 
  1355)     call MatNorm(J,NORM_INFINITY,norm,ierr);CHKERRQ(ierr)
  1356)     write(option%io_buffer,'("inf norm: ",es11.4)') norm
  1357)     call printMsg(option) 
  1358)   endif
  1359) 
  1360) end subroutine GeomechForceJacobian
  1361) 
  1362) ! ************************************************************************** !
  1363) 
  1364) subroutine GeomechForceJacobianPatch(snes,xx,A,B,geomech_realization,ierr)
  1365)   ! 
  1366)   ! Computes the nonlinear part of the Jacobian on a patch
  1367)   ! 
  1368)   ! Author: Satish Karra
  1369)   ! Date: 06/21/13
  1370)   ! Modified: 07/12/16
  1371)        
  1372)   use Geomechanics_Realization_class
  1373)       
  1374)   implicit none
  1375) 
  1376)   SNES, intent(in) :: snes
  1377)   Vec, intent(in) :: xx
  1378)   Mat, intent(inout) :: A
  1379)   Mat, intent(out) :: B
  1380)   PetscViewer :: viewer
  1381) 
  1382)   PetscErrorCode :: ierr
  1383)    
  1384)   class(realization_geomech_type) :: geomech_realization
  1385)   
  1386)   ! Do nothing here since Jacobian is always linear and is computed
  1387)   ! once at the setup of geomechanics realization
  1388) 
  1389) end subroutine GeomechForceJacobianPatch  
  1390) 
  1391) ! ************************************************************************** !
  1392) 
  1393) subroutine GeomechForceJacobianLinearPart(A,geomech_realization)
  1394)   ! 
  1395)   ! Computes the Linear part of the Jacobian on a patch
  1396)   ! 
  1397)   ! Author: Satish Karra
  1398)   ! Date: 06/21/13
  1399)   ! Modified: 07/12/16
  1400)   ! 
  1401)        
  1402)   use Geomechanics_Realization_class
  1403)   use Geomechanics_Patch_module
  1404)   use Geomechanics_Grid_module
  1405)   use Geomechanics_Grid_Aux_module
  1406)   use Geomechanics_Coupler_module
  1407)   use Geomechanics_Field_module
  1408)   use Geomechanics_Debug_module
  1409)   use Geomechanics_Discretization_module
  1410)   use Option_module
  1411)   use Grid_Unstructured_Cell_module
  1412)   use Geomechanics_Region_module
  1413)   use Geomechanics_Auxiliary_module
  1414)       
  1415)   implicit none
  1416) 
  1417)   Mat :: A
  1418)   PetscViewer :: viewer
  1419) 
  1420)   PetscErrorCode :: ierr
  1421)    
  1422)   class(realization_geomech_type) :: geomech_realization
  1423)   type(geomech_discretization_type), pointer :: geomech_discretization
  1424)   type(geomech_patch_type), pointer :: patch
  1425)   type(geomech_field_type), pointer :: field
  1426)   type(geomech_grid_type), pointer :: grid
  1427)   type(geomech_global_auxvar_type), pointer :: geomech_global_aux_vars(:)
  1428)   type(option_type), pointer :: option
  1429)   type(gm_region_type), pointer :: region
  1430)   type(geomech_coupler_type), pointer :: boundary_condition
  1431)   type(geomech_parameter_type), pointer :: GeomechParam
  1432) 
  1433)   PetscInt, allocatable :: elenodes(:)
  1434)   PetscReal, allocatable :: local_coordinates(:,:)
  1435)   PetscReal, allocatable :: local_disp(:)
  1436)   PetscInt, allocatable :: ghosted_ids(:)
  1437)   PetscReal, allocatable :: Jac_full(:,:)
  1438)   PetscReal, allocatable :: Jac_sub_mat(:,:)
  1439)   PetscInt, allocatable :: rows(:)
  1440)   PetscReal, allocatable :: youngs_vec(:), poissons_vec(:)
  1441)   PetscInt :: ielem,ivertex 
  1442)   PetscInt :: ghosted_id
  1443)   PetscInt :: eletype, idof
  1444)   PetscInt :: local_id, petsc_id
  1445)   PetscInt :: ghosted_id1, ghosted_id2
  1446)   PetscInt :: petsc_id1, petsc_id2
  1447)   PetscInt :: id1, id2, i, j, vertex_count, count
  1448)   PetscReal, pointer :: imech_loc_p(:)
  1449)   PetscInt :: size_elenodes
  1450)         
  1451)   field => geomech_realization%geomech_field
  1452)   geomech_discretization => geomech_realization%geomech_discretization
  1453)   patch => geomech_realization%geomech_patch
  1454)   grid => patch%geomech_grid
  1455)   option => geomech_realization%option
  1456)   geomech_global_aux_vars => patch%geomech_aux%GeomechGlobal%aux_vars  
  1457)   GeomechParam => patch%geomech_aux%GeomechParam 
  1458) 
  1459)   call MatZeroEntries(A,ierr);CHKERRQ(ierr)
  1460)   call VecGetArrayF90(field%imech_loc,imech_loc_p,ierr);CHKERRQ(ierr)
  1461) 
  1462)   ! Loop over elements on a processor
  1463)   do ielem = 1, grid%nlmax_elem
  1464)     allocate(elenodes(grid%elem_nodes(0,ielem)))
  1465)     allocate(local_coordinates(size(elenodes),THREE_INTEGER))
  1466)     allocate(local_disp(size(elenodes)*option%ngeomechdof))
  1467)     allocate(ghosted_ids(size(elenodes)))
  1468)     allocate(Jac_full(size(elenodes)*option%ngeomechdof, &
  1469)                       size(elenodes)*option%ngeomechdof))
  1470)     allocate(Jac_sub_mat(option%ngeomechdof,option%ngeomechdof))
  1471)     allocate(youngs_vec(size(elenodes)))
  1472)     allocate(poissons_vec(size(elenodes)))
  1473)     elenodes = grid%elem_nodes(1:grid%elem_nodes(0,ielem),ielem)
  1474)     eletype = grid%gauss_node(ielem)%EleType
  1475)     do ivertex = 1, grid%elem_nodes(0,ielem)
  1476)       ghosted_id = elenodes(ivertex)
  1477)       local_coordinates(ivertex,GEOMECH_DISP_X_DOF) = grid%nodes(ghosted_id)%x
  1478)       local_coordinates(ivertex,GEOMECH_DISP_Y_DOF) = grid%nodes(ghosted_id)%y
  1479)       local_coordinates(ivertex,GEOMECH_DISP_Z_DOF) = grid%nodes(ghosted_id)%z
  1480)       ghosted_ids(ivertex) = ghosted_id
  1481)     enddo
  1482)     do ivertex = 1, grid%elem_nodes(0,ielem)
  1483)       ghosted_id = elenodes(ivertex)
  1484)       do idof = 1, option%ngeomechdof
  1485)         local_disp(idof + (ivertex-1)*option%ngeomechdof) = &
  1486)           geomech_global_aux_vars(ghosted_id)%disp_vector(idof)
  1487)       enddo
  1488)       youngs_vec(ivertex) = &
  1489)         GeomechParam%youngs_modulus(int(imech_loc_p(ghosted_id))) 
  1490)       poissons_vec(ivertex) = &
  1491)         GeomechParam%poissons_ratio(int(imech_loc_p(ghosted_id))) 
  1492)     enddo
  1493)     size_elenodes = size(elenodes)
  1494)     call GeomechForceLocalElemJacobian(size_elenodes,local_coordinates, &
  1495)        local_disp,youngs_vec,poissons_vec,eletype, &
  1496)        grid%gauss_node(ielem)%dim,grid%gauss_node(ielem)%r, &
  1497)        grid%gauss_node(ielem)%w,Jac_full,option)
  1498)     do id1 = 1, size(ghosted_ids)
  1499)       ghosted_id1 = ghosted_ids(id1)
  1500)       petsc_id1 = grid%node_ids_ghosted_petsc(ghosted_id1)
  1501)       do id2 = 1, size(ghosted_ids)
  1502)         ghosted_id2 = ghosted_ids(id2)
  1503)         petsc_id2 = grid%node_ids_ghosted_petsc(ghosted_id2)
  1504)         Jac_sub_mat = 0.d0
  1505)         Jac_sub_mat =  &
  1506)           Jac_full(option%ngeomechdof*(id1-1)+GEOMECH_DISP_X_DOF: &
  1507)                    option%ngeomechdof*(id1-1)+GEOMECH_DISP_Z_DOF, &
  1508)                    option%ngeomechdof*(id2-1)+GEOMECH_DISP_X_DOF: &
  1509)                    option%ngeomechdof*(id2-1)+GEOMECH_DISP_Z_DOF) 
  1510)           
  1511)         call MatSetValuesBlocked(A,1,petsc_id1-1,1,petsc_id2-1, &
  1512)                                  Jac_sub_mat,ADD_VALUES,ierr);CHKERRQ(ierr)
  1513)       enddo
  1514)     enddo
  1515)    
  1516)     deallocate(elenodes)
  1517)     deallocate(local_coordinates)
  1518)     deallocate(local_disp)
  1519)     deallocate(ghosted_ids)
  1520)     deallocate(Jac_full)
  1521)     deallocate(Jac_sub_mat)
  1522)     deallocate(youngs_vec)
  1523)     deallocate(poissons_vec)
  1524)   enddo
  1525)   
  1526)   call VecRestoreArrayF90(field%imech_loc,imech_loc_p,ierr);CHKERRQ(ierr)
  1527)   
  1528)   call MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  1529)   call MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY,ierr);CHKERRQ(ierr)
  1530)   
  1531)   ! Find the boundary nodes with dirichlet and set the residual at those nodes
  1532)   ! to zero, later set the Jacobian to 1
  1533)   
  1534)   ! Find the number of boundary vertices
  1535)   vertex_count = 0
  1536)   boundary_condition => patch%geomech_boundary_condition_list%first
  1537)   do 
  1538)     if (.not.associated(boundary_condition)) exit
  1539)     region => boundary_condition%region
  1540)     vertex_count = vertex_count + region%num_verts
  1541)     boundary_condition => boundary_condition%next      
  1542)   enddo
  1543)   
  1544)   allocate(rows(vertex_count*option%ngeomechdof))
  1545)   count = 0
  1546)  
  1547)   boundary_condition => patch%geomech_boundary_condition_list%first
  1548)   do 
  1549)     if (.not.associated(boundary_condition)) exit
  1550)     region => boundary_condition%region
  1551)     do ivertex = 1, region%num_verts
  1552)       local_id = region%vertex_ids(ivertex)
  1553)       ghosted_id = grid%nL2G(local_id)
  1554)       petsc_id = grid%node_ids_ghosted_petsc(ghosted_id)
  1555)       if (associated(patch%imat)) then
  1556)         if (patch%imat(ghosted_id) <= 0) cycle
  1557)       endif    
  1558)       
  1559)       ! X displacement 
  1560)       if (associated(boundary_condition%geomech_condition%displacement_x)) then
  1561)         select case(boundary_condition%geomech_condition%displacement_x%itype)
  1562)           case(DIRICHLET_BC)
  1563)             count = count + 1
  1564)             rows(count) = (ghosted_id-1)*option%ngeomechdof + &
  1565)               GEOMECH_DISP_X_DOF-1
  1566)           case(ZERO_GRADIENT_BC,NEUMANN_BC)
  1567)            ! do nothing
  1568)         end select
  1569)       endif
  1570)       
  1571)       ! Y displacement 
  1572)       if (associated(boundary_condition%geomech_condition%displacement_y)) then
  1573)         select case(boundary_condition%geomech_condition%displacement_y%itype)
  1574)           case(DIRICHLET_BC)
  1575)             count = count + 1
  1576)             rows(count) = (ghosted_id-1)*option%ngeomechdof + &
  1577)               GEOMECH_DISP_Y_DOF-1
  1578)           case(ZERO_GRADIENT_BC,NEUMANN_BC)
  1579)            ! do nothing
  1580)         end select
  1581)       endif
  1582)       
  1583)       ! Z displacement      
  1584)       if (associated(boundary_condition%geomech_condition%displacement_z)) then
  1585)         select case(boundary_condition%geomech_condition%displacement_z%itype)
  1586)           case(DIRICHLET_BC)
  1587)             count = count + 1
  1588)             rows(count) = (ghosted_id-1)*option%ngeomechdof + &
  1589)               GEOMECH_DISP_Z_DOF-1
  1590)           case(ZERO_GRADIENT_BC,NEUMANN_BC)
  1591)            ! do nothing
  1592)         end select
  1593)       endif
  1594)       
  1595)     enddo
  1596)     boundary_condition => boundary_condition%next      
  1597)   enddo
  1598)     
  1599)   call MatZeroRowsLocal(A,count,rows,1.d0, &
  1600)                         PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, &
  1601)                         ierr);CHKERRQ(ierr)
  1602)   call MatSetOption(A,MAT_NEW_NONZERO_LOCATIONS,PETSC_FALSE, &
  1603)                     ierr);CHKERRQ(ierr)
  1604)   call MatStoreValues(A,ierr);CHKERRQ(ierr) ! Store the linear part of Jacobian
  1605)                     
  1606)   deallocate(rows)
  1607) 
  1608) end subroutine GeomechForceJacobianLinearPart  
  1609) 
  1610) ! ************************************************************************** !
  1611) 
  1612) subroutine GeomechUpdateFromSubsurf(realization,geomech_realization)
  1613)   ! 
  1614)   ! The pressure/temperature from subsurface are
  1615)   ! mapped to geomech
  1616)   ! 
  1617)   ! Author: Satish Karra, LANL
  1618)   ! Date: 09/10/13
  1619)   ! 
  1620) 
  1621)   use Realization_Subsurface_class
  1622)   use Grid_module
  1623)   use Field_module
  1624)   use Geomechanics_Realization_class
  1625)   use Geomechanics_Grid_module
  1626)   use Geomechanics_Grid_Aux_module
  1627)   use Geomechanics_Field_module
  1628)   use Geomechanics_Discretization_module
  1629)   use Option_module
  1630)   
  1631)   implicit none
  1632)   
  1633)   class(realization_subsurface_type) :: realization
  1634)   class(realization_geomech_type) :: geomech_realization
  1635)   type(grid_type), pointer :: grid
  1636)   type(geomech_grid_type), pointer :: geomech_grid
  1637)   type(option_type), pointer :: option
  1638)   type(field_type), pointer :: field
  1639)   type(geomech_field_type), pointer :: geomech_field
  1640)   type(gmdm_ptr_type), pointer :: dm_ptr
  1641) 
  1642)   PetscErrorCode :: ierr
  1643)   PetscReal, pointer :: vec_p(:), xx_loc_p(:)
  1644)   PetscInt :: local_id, ghosted_id
  1645) 
  1646)   option        => realization%option
  1647)   grid          => realization%discretization%grid
  1648)   field         => realization%field
  1649)   geomech_grid  => geomech_realization%geomech_discretization%grid
  1650)   geomech_field => geomech_realization%geomech_field
  1651) 
  1652)   ! use the subsurface output option parameters for geomechanics as well
  1653)   geomech_realization%output_option%tunit = realization%output_option%tunit
  1654)   geomech_realization%output_option%tconv = realization%output_option%tconv
  1655)   
  1656)   dm_ptr => GeomechDiscretizationGetDMPtrFromIndex(geomech_realization% &
  1657)                                                    geomech_discretization, &
  1658)                                                    ONEDOF)
  1659) 
  1660) 
  1661)   ! pressure
  1662)   call VecGetArrayF90(field%flow_xx_loc,xx_loc_p,ierr);CHKERRQ(ierr)
  1663)   call GeomechGridVecGetArrayF90(geomech_grid, &
  1664)                                  geomech_field%subsurf_vec_1dof,vec_p,ierr)
  1665)   do local_id = 1, grid%nlmax
  1666)     ghosted_id = grid%nL2G(local_id)
  1667)     vec_p(local_id) = xx_loc_p(option%nflowdof*(ghosted_id-1)+1) 
  1668)   enddo
  1669)   call GeomechGridVecRestoreArrayF90(geomech_grid, &
  1670)                                      geomech_field%subsurf_vec_1dof,vec_p,ierr)
  1671)   call VecRestoreArrayF90(field%flow_xx_loc,xx_loc_p,ierr);CHKERRQ(ierr)
  1672)   
  1673)   ! Scatter the data
  1674)   call VecScatterBegin(dm_ptr%gmdm%scatter_subsurf_to_geomech_ndof, &
  1675)                        geomech_field%subsurf_vec_1dof, &
  1676)                        geomech_field%press, &
  1677)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1678)   call VecScatterEnd(dm_ptr%gmdm%scatter_subsurf_to_geomech_ndof, &
  1679)                      geomech_field%subsurf_vec_1dof, &
  1680)                      geomech_field%press, &
  1681)                      INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1682)                      
  1683)   ! temperature
  1684)   if (option%nflowdof > 1) then
  1685)     call VecGetArrayF90(field%flow_xx_loc,xx_loc_p,ierr);CHKERRQ(ierr)
  1686)     call GeomechGridVecGetArrayF90(geomech_grid, &
  1687)                                    geomech_field%subsurf_vec_1dof,vec_p,ierr)
  1688)     do local_id = 1, grid%nlmax
  1689)       ghosted_id = grid%nL2G(local_id)
  1690)       vec_p(local_id) = xx_loc_p(option%nflowdof*(ghosted_id-1)+2) 
  1691)     enddo
  1692)     call GeomechGridVecRestoreArrayF90(geomech_grid, &
  1693)                                        geomech_field%subsurf_vec_1dof, &
  1694)                                        vec_p,ierr)
  1695)     call VecRestoreArrayF90(field%flow_xx_loc,xx_loc_p,ierr);CHKERRQ(ierr)
  1696)   
  1697)     ! Scatter the data
  1698)     call VecScatterBegin(dm_ptr%gmdm%scatter_subsurf_to_geomech_ndof, &
  1699)                          geomech_field%subsurf_vec_1dof, &
  1700)                          geomech_field%temp, &
  1701)                          INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1702)     call VecScatterEnd(dm_ptr%gmdm%scatter_subsurf_to_geomech_ndof, &
  1703)                        geomech_field%subsurf_vec_1dof, &
  1704)                        geomech_field%temp, &
  1705)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1706)   endif                       
  1707)  
  1708)   call GeomechDiscretizationGlobalToLocal(&
  1709)                                 geomech_realization%geomech_discretization, &
  1710)                                 geomech_field%press, & 
  1711)                                 geomech_field%press_loc,ONEDOF)
  1712)   
  1713)   if (option%nflowdof > 1) &
  1714)     call GeomechDiscretizationGlobalToLocal(&
  1715)                                 geomech_realization%geomech_discretization, &
  1716)                                 geomech_field%temp, &
  1717)                                 geomech_field%temp_loc,ONEDOF)
  1718) 
  1719) end subroutine GeomechUpdateFromSubsurf
  1720) 
  1721) ! ************************************************************************** !
  1722) 
  1723) subroutine GeomechUpdateSubsurfFromGeomech(realization,geomech_realization)
  1724)   ! 
  1725)   ! The stresses and strains from geomech
  1726)   ! are mapped to subsurf.
  1727)   ! 
  1728)   ! Author: Satish Karra, LANL
  1729)   ! Date: 10/10/13
  1730)   ! 
  1731) 
  1732)   use Realization_Subsurface_class
  1733)   use Discretization_module
  1734)   use Grid_module
  1735)   use Field_module
  1736)   use Geomechanics_Realization_class
  1737)   use Geomechanics_Grid_module
  1738)   use Geomechanics_Grid_Aux_module
  1739)   use Geomechanics_Field_module
  1740)   use Geomechanics_Discretization_module
  1741)   use Option_module
  1742)   
  1743)   implicit none
  1744)   
  1745)   class(realization_subsurface_type) :: realization
  1746)   class(realization_geomech_type) :: geomech_realization
  1747)   type(grid_type), pointer :: grid
  1748)   type(geomech_grid_type), pointer :: geomech_grid
  1749)   type(option_type), pointer :: option
  1750)   type(field_type), pointer :: field
  1751)   type(geomech_field_type), pointer :: geomech_field
  1752)   type(gmdm_ptr_type), pointer :: dm_ptr
  1753) 
  1754)   PetscErrorCode :: ierr
  1755) 
  1756)   option        => realization%option
  1757)   grid          => realization%discretization%grid
  1758)   field         => realization%field
  1759)   geomech_grid  => geomech_realization%geomech_discretization%grid
  1760)   geomech_field => geomech_realization%geomech_field
  1761)   
  1762)   dm_ptr => GeomechDiscretizationGetDMPtrFromIndex(geomech_realization% &
  1763)                                                    geomech_discretization, &
  1764)                                                    ONEDOF)
  1765)   
  1766)   ! Scatter the strains
  1767)   call VecScatterBegin(dm_ptr%gmdm%scatter_geomech_to_subsurf_ndof, &
  1768)                        geomech_field%strain, &
  1769)                        geomech_field%strain_subsurf, &
  1770)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1771)   call VecScatterEnd(dm_ptr%gmdm%scatter_geomech_to_subsurf_ndof, &
  1772)                        geomech_field%strain, &
  1773)                        geomech_field%strain_subsurf, &
  1774)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1775)                        
  1776)   ! Scatter the stresses
  1777)   call VecScatterBegin(dm_ptr%gmdm%scatter_geomech_to_subsurf_ndof, &
  1778)                        geomech_field%stress, &
  1779)                        geomech_field%stress_subsurf, &
  1780)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1781)   call VecScatterEnd(dm_ptr%gmdm%scatter_geomech_to_subsurf_ndof, &
  1782)                        geomech_field%stress, &
  1783)                        geomech_field%stress_subsurf, &
  1784)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1785)                        
  1786)   ! Scatter from global to local vectors
  1787)   call DiscretizationGlobalToLocal(realization%discretization, &
  1788)                                    geomech_field%strain_subsurf, &
  1789)                                    geomech_field%strain_subsurf_loc, &
  1790)                                    NGEODOF)
  1791)   call DiscretizationGlobalToLocal(realization%discretization, &
  1792)                                    geomech_field%stress_subsurf, &
  1793)                                    geomech_field%stress_subsurf_loc, &
  1794)                                    NGEODOF)
  1795)  
  1796) end subroutine GeomechUpdateSubsurfFromGeomech
  1797) 
  1798) ! ************************************************************************** !
  1799) 
  1800) subroutine GeomechCreateGeomechSubsurfVec(realization,geomech_realization)
  1801)   ! 
  1802)   ! Creates the MPI vector that stores the
  1803)   ! variables from subsurface
  1804)   ! 
  1805)   ! Author: Satish Karra, LANL
  1806)   ! Date: 09/10/13
  1807)   ! 
  1808) 
  1809)   use Grid_module
  1810)   use Geomechanics_Discretization_module
  1811)   use Geomechanics_Realization_class
  1812)   use Geomechanics_Grid_Aux_module
  1813)   use Geomechanics_Grid_module
  1814)   use Geomechanics_Field_module
  1815)   use String_module
  1816)   use Realization_Subsurface_class
  1817)   use Option_module
  1818) 
  1819)   implicit none
  1820)   
  1821) #include "petsc/finclude/petscvec.h"
  1822) #include "petsc/finclude/petscvec.h90"
  1823) #include "petsc/finclude/petscmat.h"
  1824) #include "petsc/finclude/petscmat.h90"
  1825) 
  1826)   class(realization_subsurface_type) :: realization
  1827)   class(realization_geomech_type) :: geomech_realization
  1828) 
  1829)   type(grid_type), pointer :: grid
  1830)   type(geomech_grid_type), pointer :: geomech_grid
  1831)   type(option_type), pointer :: option
  1832)   type(geomech_field_type), pointer :: geomech_field
  1833)   
  1834)   PetscErrorCode :: ierr
  1835)   
  1836)   option     => realization%option
  1837)   grid       => realization%discretization%grid
  1838)   geomech_field => geomech_realization%geomech_field
  1839)   
  1840)   call VecCreate(option%mycomm,geomech_field%subsurf_vec_1dof, &
  1841)                  ierr);CHKERRQ(ierr)
  1842)   call VecSetSizes(geomech_field%subsurf_vec_1dof, &
  1843)                    grid%nlmax,PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1844)   call VecSetFromOptions(geomech_field%subsurf_vec_1dof,ierr);CHKERRQ(ierr)
  1845)   
  1846) end subroutine GeomechCreateGeomechSubsurfVec
  1847) 
  1848) ! ************************************************************************** !
  1849) 
  1850) subroutine GeomechCreateSubsurfStressStrainVec(realization,geomech_realization)
  1851)   ! 
  1852)   ! Creates the subsurface stress and strain
  1853)   ! MPI vectors to store information from geomechanics
  1854)   ! 
  1855)   ! Author: Satish Karra, LANL
  1856)   ! Date: 10/10/13
  1857)   ! 
  1858) 
  1859)   use Grid_module
  1860)   use Geomechanics_Discretization_module
  1861)   use Geomechanics_Realization_class
  1862)   use Geomechanics_Grid_Aux_module
  1863)   use Geomechanics_Grid_module
  1864)   use Geomechanics_Field_module
  1865)   use String_module
  1866)   use Realization_Subsurface_class
  1867)   use Option_module
  1868) 
  1869)   implicit none
  1870)   
  1871) #include "petsc/finclude/petscvec.h"
  1872) #include "petsc/finclude/petscvec.h90"
  1873) #include "petsc/finclude/petscmat.h"
  1874) #include "petsc/finclude/petscmat.h90"
  1875) 
  1876)   class(realization_subsurface_type) :: realization
  1877)   class(realization_geomech_type) :: geomech_realization
  1878) 
  1879)   type(grid_type), pointer :: grid
  1880)   type(geomech_grid_type), pointer :: geomech_grid
  1881)   type(option_type), pointer :: option
  1882)   type(geomech_field_type), pointer :: geomech_field
  1883)   
  1884)   PetscErrorCode :: ierr
  1885)   
  1886)   option     => realization%option
  1887)   grid       => realization%discretization%grid
  1888)   geomech_field => geomech_realization%geomech_field
  1889)   
  1890)   ! strain
  1891)   call VecCreate(option%mycomm,geomech_field%strain_subsurf, &
  1892)                  ierr);CHKERRQ(ierr)
  1893)   call VecSetSizes(geomech_field%strain_subsurf, &
  1894)                    grid%nlmax*SIX_INTEGER,PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1895)   call VecSetBlockSize(geomech_field%strain_subsurf,SIX_INTEGER, &
  1896)                        ierr);CHKERRQ(ierr)
  1897)   call VecSetFromOptions(geomech_field%strain_subsurf,ierr);CHKERRQ(ierr)
  1898)   
  1899)   ! stress
  1900)   call VecCreate(option%mycomm,geomech_field%stress_subsurf, &
  1901)                  ierr);CHKERRQ(ierr)
  1902)   call VecSetSizes(geomech_field%stress_subsurf, &
  1903)                    grid%nlmax*SIX_INTEGER,PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1904)   call VecSetBlockSize(geomech_field%stress_subsurf,SIX_INTEGER, &
  1905)                        ierr);CHKERRQ(ierr)
  1906)   call VecSetFromOptions(geomech_field%stress_subsurf,ierr);CHKERRQ(ierr)
  1907)   
  1908)   ! strain_loc
  1909)   call VecCreate(PETSC_COMM_SELF,geomech_field%strain_subsurf_loc, &
  1910)                  ierr);CHKERRQ(ierr)
  1911)   call VecSetSizes(geomech_field%strain_subsurf_loc, &
  1912)                    grid%ngmax*SIX_INTEGER,PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1913)   call VecSetBlockSize(geomech_field%strain_subsurf_loc,SIX_INTEGER, &
  1914)                        ierr);CHKERRQ(ierr)
  1915)   call VecSetFromOptions(geomech_field%strain_subsurf_loc,ierr);CHKERRQ(ierr)
  1916)   
  1917)   ! stress_loc 
  1918)   call VecCreate(PETSC_COMM_SELF,geomech_field%stress_subsurf_loc, &
  1919)                  ierr);CHKERRQ(ierr)
  1920)   call VecSetSizes(geomech_field%stress_subsurf_loc, &
  1921)                    grid%ngmax*SIX_INTEGER,PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1922)   call VecSetBlockSize(geomech_field%stress_subsurf_loc,SIX_INTEGER, &
  1923)                        ierr);CHKERRQ(ierr)
  1924)   call VecSetFromOptions(geomech_field%stress_subsurf_loc,ierr);CHKERRQ(ierr)
  1925)   
  1926) end subroutine GeomechCreateSubsurfStressStrainVec
  1927) 
  1928) ! ************************************************************************** !
  1929) 
  1930) subroutine GeomechForceStressStrain(geomech_realization)
  1931)   ! 
  1932)   ! Computes the stress strain on a patch
  1933)   ! 
  1934)   ! Author: Satish Karra
  1935)   ! Date: 09/17/13
  1936)   ! 
  1937) 
  1938)   use Geomechanics_Realization_class
  1939)   use Geomechanics_Field_module
  1940)   use Geomechanics_Discretization_module
  1941)   use Geomechanics_Patch_module
  1942)   use Geomechanics_Grid_Aux_module
  1943)   use Geomechanics_Grid_module
  1944)   use Grid_Unstructured_Cell_module
  1945)   use Geomechanics_Region_module
  1946)   use Geomechanics_Coupler_module
  1947)   use Option_module
  1948)   use Geomechanics_Auxiliary_module
  1949) 
  1950)   implicit none
  1951) 
  1952)   class(realization_geomech_type) :: geomech_realization
  1953)   type(geomech_discretization_type), pointer :: geomech_discretization
  1954)   type(geomech_patch_type), pointer :: patch
  1955)   type(geomech_field_type), pointer :: field
  1956)   type(geomech_grid_type), pointer :: grid
  1957)   type(geomech_global_auxvar_type), pointer :: geomech_global_aux_vars(:)
  1958)   type(option_type), pointer :: option
  1959)   type(gm_region_type), pointer :: region
  1960)   type(geomech_coupler_type), pointer :: boundary_condition
  1961)   type(geomech_parameter_type), pointer :: GeomechParam
  1962) 
  1963)   PetscInt, allocatable :: elenodes(:)
  1964)   PetscReal, allocatable :: local_coordinates(:,:)
  1965)   PetscReal, allocatable :: local_disp(:,:)
  1966)   PetscInt, allocatable :: petsc_ids(:)
  1967)   PetscInt, allocatable :: ids(:)
  1968)   PetscReal, allocatable :: youngs_vec(:), poissons_vec(:)
  1969)   PetscReal, allocatable :: strain(:,:), stress(:,:)
  1970)   PetscInt, allocatable :: count(:)
  1971)   PetscInt :: ielem, ivertex 
  1972)   PetscInt :: ghosted_id
  1973)   PetscInt :: eletype, idof
  1974)   PetscInt :: petsc_id, local_id
  1975)   PetscInt :: size_elenodes
  1976)   PetscReal, pointer :: imech_loc_p(:)  
  1977)   PetscReal, pointer :: strain_loc_p(:)
  1978)   PetscReal, pointer :: stress_loc_p(:)
  1979)   PetscReal, pointer :: strain_p(:), stress_p(:)
  1980)   PetscReal, pointer :: no_elems_p(:)
  1981)   
  1982)   PetscErrorCode :: ierr
  1983)                   
  1984)   field => geomech_realization%geomech_field
  1985)   geomech_discretization => geomech_realization%geomech_discretization
  1986)   patch => geomech_realization%geomech_patch
  1987)   grid => patch%geomech_grid
  1988)   option => geomech_realization%option
  1989)   geomech_global_aux_vars => patch%geomech_aux%GeomechGlobal%aux_vars  
  1990)   GeomechParam => patch%geomech_aux%GeomechParam 
  1991) 
  1992)   call VecSet(field%strain,0.d0,ierr);CHKERRQ(ierr)
  1993)   call VecSet(field%stress,0.d0,ierr);CHKERRQ(ierr)
  1994) 
  1995)   call VecGetArrayF90(field%imech_loc,imech_loc_p,ierr);CHKERRQ(ierr)
  1996)   call VecGetArrayF90(field%strain_loc,strain_loc_p,ierr);CHKERRQ(ierr)
  1997)   call VecGetArrayF90(field%stress_loc,stress_loc_p,ierr);CHKERRQ(ierr)
  1998)   
  1999)   strain_loc_p = 0.d0
  2000)   stress_loc_p = 0.d0
  2001)   
  2002)    ! Loop over elements on a processor
  2003)   do ielem = 1, grid%nlmax_elem
  2004)     allocate(elenodes(grid%elem_nodes(0,ielem)))
  2005)     allocate(local_coordinates(size(elenodes),THREE_INTEGER))
  2006)     allocate(local_disp(size(elenodes),option%ngeomechdof))
  2007)     allocate(petsc_ids(size(elenodes)))
  2008)     allocate(ids(size(elenodes)*option%ngeomechdof))
  2009)     allocate(youngs_vec(size(elenodes)))
  2010)     allocate(poissons_vec(size(elenodes)))
  2011)     allocate(strain(size(elenodes),SIX_INTEGER))
  2012)     allocate(stress(size(elenodes),SIX_INTEGER))
  2013)     elenodes = grid%elem_nodes(1:grid%elem_nodes(0,ielem),ielem)
  2014)     eletype = grid%gauss_node(ielem)%EleType
  2015)     do ivertex = 1, grid%elem_nodes(0,ielem)
  2016)       ghosted_id = elenodes(ivertex)
  2017)       local_coordinates(ivertex,GEOMECH_DISP_X_DOF) = grid%nodes(ghosted_id)%x
  2018)       local_coordinates(ivertex,GEOMECH_DISP_Y_DOF) = grid%nodes(ghosted_id)%y
  2019)       local_coordinates(ivertex,GEOMECH_DISP_Z_DOF) = grid%nodes(ghosted_id)%z
  2020)       petsc_ids(ivertex) = grid%node_ids_ghosted_petsc(ghosted_id)
  2021)     enddo
  2022)     do ivertex = 1, grid%elem_nodes(0,ielem)
  2023)       ghosted_id = elenodes(ivertex)
  2024)       do idof = 1, option%ngeomechdof
  2025)         local_disp(ivertex,idof) = &
  2026)           geomech_global_aux_vars(ghosted_id)%disp_vector(idof)
  2027)         ids(idof + (ivertex-1)*option%ngeomechdof) = &
  2028)           (petsc_ids(ivertex)-1)*option%ngeomechdof + (idof-1)
  2029)       enddo
  2030)       youngs_vec(ivertex) = &
  2031)         GeomechParam%youngs_modulus(int(imech_loc_p(ghosted_id))) 
  2032)       poissons_vec(ivertex) = &
  2033)         GeomechParam%poissons_ratio(int(imech_loc_p(ghosted_id))) 
  2034)     enddo
  2035)     size_elenodes = size(elenodes)
  2036)     call GeomechForceLocalElemStressStrain(size_elenodes,local_coordinates, &
  2037)        local_disp,youngs_vec,poissons_vec, &
  2038)        eletype,grid%gauss_node(ielem)%dim,strain,stress,option)
  2039)  
  2040)     do ivertex = 1, grid%elem_nodes(0,ielem)
  2041)       ghosted_id = elenodes(ivertex)
  2042)       do idof = 1, SIX_INTEGER
  2043)         strain_loc_p(idof + (ghosted_id-1)*SIX_INTEGER) = &
  2044)           strain_loc_p(idof + (ghosted_id-1)*SIX_INTEGER) + &
  2045)           strain(ivertex,idof)
  2046)         stress_loc_p(idof + (ghosted_id-1)*SIX_INTEGER) = &
  2047)           stress_loc_p(idof + (ghosted_id-1)*SIX_INTEGER) + & 
  2048)           stress(ivertex,idof)
  2049)       enddo
  2050)     enddo
  2051)    
  2052)     deallocate(elenodes)
  2053)     deallocate(local_coordinates)
  2054)     deallocate(local_disp)
  2055)     deallocate(petsc_ids)
  2056)     deallocate(ids)
  2057)     deallocate(youngs_vec)
  2058)     deallocate(poissons_vec)
  2059)     deallocate(strain)
  2060)     deallocate(stress)
  2061)   enddo
  2062) 
  2063)   call VecRestoreArrayF90(field%imech_loc,imech_loc_p,ierr);CHKERRQ(ierr)
  2064)   call VecRestoreArrayF90(field%strain_loc,strain_loc_p,ierr);CHKERRQ(ierr)
  2065)   call VecRestoreArrayF90(field%stress_loc,stress_loc_p,ierr);CHKERRQ(ierr)
  2066)   
  2067)   call GeomechDiscretizationLocalToGlobalAdd(geomech_discretization, &
  2068)                                              field%strain_loc,field%strain, &
  2069)                                              SIX_INTEGER)
  2070)   call GeomechDiscretizationLocalToGlobalAdd(geomech_discretization, &
  2071)                                              field%stress_loc,field%stress, &
  2072)                                              SIX_INTEGER)
  2073)                                              
  2074) ! Now take the average at each node for elements sharing the node
  2075)   call VecGetArrayF90(grid%no_elems_sharing_node,no_elems_p, &
  2076)                       ierr);CHKERRQ(ierr)
  2077)   call VecGetArrayF90(field%strain,strain_p,ierr);CHKERRQ(ierr)
  2078)   call VecGetArrayF90(field%stress,stress_p,ierr);CHKERRQ(ierr)
  2079)   do local_id = 1, grid%nlmax_node
  2080)     do idof = 1, SIX_INTEGER
  2081)       strain_p(idof + (local_id-1)*SIX_INTEGER) = &
  2082)         strain_p(idof + (local_id-1)*SIX_INTEGER)/int(no_elems_p(local_id))
  2083)       stress_p(idof + (local_id-1)*SIX_INTEGER) = &
  2084)         stress_p(idof + (local_id-1)*SIX_INTEGER)/int(no_elems_p(local_id))
  2085)     enddo
  2086)   enddo
  2087)   call VecRestoreArrayF90(field%stress,stress_p,ierr);CHKERRQ(ierr)
  2088)   call VecRestoreArrayF90(field%strain,strain_p,ierr);CHKERRQ(ierr)
  2089)   call VecRestoreArrayF90(grid%no_elems_sharing_node,no_elems_p, &
  2090)                           ierr);CHKERRQ(ierr)
  2091) 
  2092) ! Now scatter back to local domains
  2093)   call GeomechDiscretizationGlobalToLocal(geomech_discretization, &
  2094)                                           field%strain,field%strain_loc, &
  2095)                                           SIX_INTEGER)
  2096)   call GeomechDiscretizationGlobalToLocal(geomech_discretization, &
  2097)                                           field%stress,field%stress_loc, &
  2098)                                           SIX_INTEGER)
  2099)                                           
  2100)   call VecGetArrayF90(field%strain_loc,strain_loc_p,ierr);CHKERRQ(ierr)
  2101)   call VecGetArrayF90(field%stress_loc,stress_loc_p,ierr);CHKERRQ(ierr)
  2102) ! Copy them to global_aux_vars
  2103)   do ghosted_id = 1, grid%ngmax_node  
  2104)     do idof = 1, SIX_INTEGER
  2105)       geomech_global_aux_vars(ghosted_id)%strain(idof) = &
  2106)         strain_loc_p(idof + (ghosted_id-1)*SIX_INTEGER)
  2107)       geomech_global_aux_vars(ghosted_id)%stress(idof) = &
  2108)         stress_loc_p(idof + (ghosted_id-1)*SIX_INTEGER)
  2109)     enddo
  2110)   enddo
  2111)   call VecRestoreArrayF90(field%strain_loc,strain_loc_p,ierr);CHKERRQ(ierr)
  2112)   call VecRestoreArrayF90(field%stress_loc,stress_loc_p,ierr);CHKERRQ(ierr)
  2113) 
  2114) end subroutine GeomechForceStressStrain
  2115) 
  2116) ! ************************************************************************** !
  2117) 
  2118) subroutine GeomechForceLocalElemStressStrain(size_elenodes,local_coordinates, &
  2119)                                              local_disp, &
  2120)                                              local_youngs,local_poissons, &
  2121)                                              eletype,dim,strain,stress,option)
  2122)   ! 
  2123)   ! Computes the stress-strain for a local
  2124)   ! element
  2125)   ! 
  2126)   ! Author: Satish Karra
  2127)   ! Date: 09/17/13
  2128)   ! 
  2129)                                          
  2130)   use Grid_Unstructured_Cell_module
  2131)   use Shape_Function_module
  2132)   use Option_module
  2133)   use Utility_module
  2134)   
  2135)   type(shapefunction_type) :: shapefunction
  2136)   type(option_type) :: option
  2137) 
  2138)   PetscReal, allocatable :: local_coordinates(:,:)
  2139)   PetscReal, allocatable :: B(:,:), Kmat(:,:)
  2140)   PetscReal, allocatable :: res_vec(:)
  2141)   PetscReal, allocatable :: local_disp(:,:)
  2142)   PetscReal, allocatable :: local_youngs(:)
  2143)   PetscReal, allocatable :: local_poissons(:)
  2144)   PetscReal, allocatable :: strain(:,:)
  2145)   PetscReal, allocatable :: stress(:,:) 
  2146)   PetscReal :: strain_local(NINE_INTEGER,ONE_INTEGER)
  2147)   PetscReal :: stress_local(NINE_INTEGER,ONE_INTEGER) 
  2148)     
  2149)   PetscReal, pointer :: r(:,:), w(:)
  2150)   PetscInt :: ivertex
  2151)   PetscInt :: eletype
  2152)   PetscReal :: identity(THREE_INTEGER,THREE_INTEGER) 
  2153)   PetscInt :: indx(THREE_INTEGER)
  2154)   PetscInt :: dim
  2155)   PetscInt :: i, j, d
  2156)   PetscReal :: lambda, mu
  2157)   PetscReal :: youngs_mod, poissons_ratio
  2158)   PetscReal, allocatable :: kron_B_eye(:,:)
  2159)   PetscReal, allocatable :: kron_B_transpose_eye(:,:)
  2160)   PetscReal, allocatable :: Trans(:,:)
  2161)   PetscReal, allocatable :: kron_eye_B_transpose(:,:)
  2162)   PetscReal, allocatable :: vec_local_disp(:,:)
  2163)   PetscInt :: size_elenodes
  2164)   PetscReal :: J_map(THREE_INTEGER,THREE_INTEGER)
  2165)   PetscReal :: inv_J_map(THREE_INTEGER,THREE_INTEGER)
  2166)   PetscReal :: eye_three(THREE_INTEGER)
  2167)   PetscReal :: eye_vec(NINE_INTEGER,ONE_INTEGER) 
  2168)   
  2169)   allocate(B(size_elenodes,dim))
  2170)   
  2171)   call Transposer(option%ngeomechdof,size_elenodes,Trans)
  2172)   strain = 0.d0
  2173)   stress = 0.d0 
  2174) 
  2175)   call ConvertMatrixToVector(transpose(local_disp),vec_local_disp)
  2176) 
  2177)   identity = 0.d0
  2178)   do i = 1, THREE_INTEGER
  2179)     do j = 1, THREE_INTEGER
  2180)       if (i == j) identity(i,j) = 1.d0
  2181)     enddo
  2182)   enddo
  2183) 
  2184)   eye_vec = 0.d0
  2185)   eye_vec(1,1) = 1.d0
  2186)   eye_vec(5,1) = 1.d0
  2187)   eye_vec(9,1) = 1.d0
  2188)  
  2189)   do ivertex = 1, size_elenodes
  2190)     strain_local = 0.d0
  2191)     stress_local = 0.d0 
  2192)     shapefunction%EleType = eletype
  2193)     call ShapeFunctionInitialize(shapefunction)
  2194)     shapefunction%zeta = shapefunction%coord(ivertex,:)
  2195)     call ShapeFunctionCalculate(shapefunction)
  2196)     J_map = matmul(transpose(local_coordinates),shapefunction%DN)
  2197)     call ludcmp(J_map,THREE_INTEGER,indx,d)
  2198)     do i = 1, THREE_INTEGER
  2199)       eye_three = 0.d0
  2200)       eye_three(i) = 1.d0
  2201)       call lubksb(J_map,THREE_INTEGER,indx,eye_three)
  2202)       inv_J_map(:,i) = eye_three
  2203)     enddo
  2204)     B = matmul(shapefunction%DN,inv_J_map)
  2205)     youngs_mod = dot_product(shapefunction%N,local_youngs)
  2206)     poissons_ratio = dot_product(shapefunction%N,local_poissons)
  2207)     call GeomechGetLambdaMu(lambda,mu,youngs_mod,poissons_ratio)
  2208)     call Kron(B,identity,kron_B_eye)
  2209)     call Kron(transpose(B),identity,kron_B_transpose_eye)
  2210)     call Kron(identity,transpose(B),kron_eye_B_transpose)
  2211)     strain_local =  0.5*matmul((kron_B_transpose_eye + &
  2212)       matmul(kron_eye_B_transpose,Trans)),vec_local_disp)
  2213)     stress_local = lambda*(strain_local(1,1)+ &
  2214)                    strain_local(5,1)+strain_local(9,1))*eye_vec + &
  2215)                    2*mu*strain_local 
  2216)     call ShapeFunctionDestroy(shapefunction)
  2217)     deallocate(kron_B_eye)
  2218)     deallocate(kron_B_transpose_eye)
  2219)     deallocate(kron_eye_B_transpose)
  2220)     strain(ivertex,1) = strain_local(1,1)
  2221)     strain(ivertex,2) = strain_local(5,1)
  2222)     strain(ivertex,3) = strain_local(9,1)
  2223)     strain(ivertex,4) = strain_local(2,1)
  2224)     strain(ivertex,5) = strain_local(6,1)
  2225)     strain(ivertex,6) = strain_local(3,1)
  2226)     stress(ivertex,1) = stress_local(1,1)
  2227)     stress(ivertex,2) = stress_local(5,1)
  2228)     stress(ivertex,3) = stress_local(9,1)
  2229)     stress(ivertex,4) = stress_local(2,1)
  2230)     stress(ivertex,5) = stress_local(6,1)
  2231)     stress(ivertex,6) = stress_local(3,1)
  2232)   enddo
  2233)   
  2234)   deallocate(B)
  2235)   deallocate(vec_local_disp)
  2236)   deallocate(Trans)
  2237) 
  2238) end subroutine GeomechForceLocalElemStressStrain 
  2239) 
  2240) ! ************************************************************************** !
  2241) 
  2242) subroutine GeomechUpdateSolution(geomech_realization)
  2243)   ! 
  2244)   ! Updates data in module after a successful time
  2245)   ! step
  2246)   ! 
  2247)   ! Author: Satish Karra, LANL
  2248)   ! Date: 09/17/13
  2249)   ! 
  2250) 
  2251)   use Geomechanics_Realization_class
  2252)   use Geomechanics_Field_module
  2253)   
  2254)   implicit none 
  2255)   
  2256)   class(realization_geomech_type) :: geomech_realization
  2257)   type(geomech_field_type), pointer :: field
  2258)   
  2259)   PetscErrorCode :: ierr 
  2260)   PetscViewer :: viewer
  2261)   
  2262)   field => geomech_realization%geomech_field
  2263) 
  2264)   call GeomechUpdateSolutionPatch(geomech_realization)
  2265) 
  2266) end subroutine GeomechUpdateSolution
  2267) 
  2268) ! ************************************************************************** !
  2269) 
  2270) subroutine GeomechUpdateSolutionPatch(geomech_realization)
  2271)   ! 
  2272)   ! updates data in module after a successful time
  2273)   ! step
  2274)   ! 
  2275)   ! Author: satish karra, lanl
  2276)   ! Date: 09/17/13
  2277)   ! 
  2278) 
  2279)   use Geomechanics_Realization_class
  2280)     
  2281)   implicit none 
  2282)   
  2283)   class(realization_geomech_type) :: geomech_realization
  2284) 
  2285)   call GeomechForceStressStrain(geomech_realization)
  2286) 
  2287) end subroutine GeomechUpdateSolutionPatch
  2288) 
  2289) ! ************************************************************************** !
  2290) 
  2291) subroutine GeomechStoreInitialPressTemp(geomech_realization)
  2292)   ! 
  2293)   ! Stores initial pressure and temperature from
  2294)   ! subsurface
  2295)   ! 
  2296)   ! Author: Satish Karra, LANL
  2297)   ! Date: 09/24/13
  2298)   ! 
  2299) 
  2300)   use Geomechanics_Realization_class
  2301)     
  2302)   implicit none 
  2303)   
  2304)   class(realization_geomech_type) :: geomech_realization
  2305) 
  2306)   PetscErrorCode :: ierr
  2307) 
  2308)   call VecCopy(geomech_realization%geomech_field%press_loc, & 
  2309)                geomech_realization%geomech_field%press_init_loc, &
  2310)                ierr);CHKERRQ(ierr)
  2311)  
  2312)   call VecCopy(geomech_realization%geomech_field%temp_loc, & 
  2313)                geomech_realization%geomech_field%temp_init_loc, &
  2314)                ierr);CHKERRQ(ierr)
  2315)    
  2316) end subroutine GeomechStoreInitialPressTemp
  2317) 
  2318) ! ************************************************************************** !
  2319) 
  2320) subroutine GeomechStoreInitialPorosity(realization,geomech_realization)
  2321)   ! 
  2322)   ! Stores initial porosity from
  2323)   ! subsurface
  2324)   ! 
  2325)   ! Author: Satish Karra, LANL
  2326)   ! Date: 10/22/13
  2327)   ! 
  2328) 
  2329)   use Geomechanics_Realization_class
  2330)   use Realization_Subsurface_class
  2331)   use Discretization_module
  2332)     
  2333)   implicit none 
  2334)   
  2335)   class(realization_geomech_type) :: geomech_realization
  2336)   class(realization_subsurface_type) :: realization
  2337)   type(discretization_type) :: discretization
  2338) 
  2339)   PetscErrorCode :: ierr
  2340) 
  2341)   call DiscretizationDuplicateVector(discretization, &
  2342)                                      realization%field%work_loc, &
  2343)                                      geomech_realization%geomech_field% &
  2344)                                      porosity_init_loc)
  2345)    
  2346) end subroutine GeomechStoreInitialPorosity
  2347) 
  2348) ! ************************************************************************** !
  2349) 
  2350) subroutine GeomechStoreInitialDisp(geomech_realization)
  2351)   ! 
  2352)   ! Stores initial displacement for calculating
  2353)   ! relative displacements
  2354)   ! 
  2355)   ! Author: Satish Karra, LANL
  2356)   ! Date: 09/30/13
  2357)   ! 
  2358) 
  2359)   use Geomechanics_Realization_class
  2360)     
  2361)   implicit none 
  2362)   
  2363)   class(realization_geomech_type) :: geomech_realization
  2364) 
  2365)   PetscErrorCode :: ierr
  2366) 
  2367)   call VecCopy(geomech_realization%geomech_field%disp_xx_loc, & 
  2368)                geomech_realization%geomech_field%disp_xx_init_loc, &
  2369)                ierr);CHKERRQ(ierr)
  2370)    
  2371) end subroutine GeomechStoreInitialDisp
  2372) 
  2373) ! ************************************************************************** !
  2374) 
  2375) subroutine GeomechUpdateSubsurfPorosity(realization,geomech_realization)
  2376)   ! 
  2377)   ! Updates the porosity in the subsurface based
  2378)   ! on the deformation in geomechanics
  2379)   ! 
  2380)   ! Author: Satish Karra, LANL
  2381)   ! Date: 10/08/13
  2382)   ! 
  2383) 
  2384)   use Realization_Subsurface_class
  2385)   use Option_module
  2386)   use Patch_module
  2387)   use Field_module
  2388)   use Grid_module
  2389)   use Discretization_module
  2390)   use Geomechanics_Field_module
  2391)   use Material_Aux_class
  2392)   use Material_module
  2393)   use Variables_module, only : POROSITY
  2394)   use Geomechanics_Realization_class
  2395) 
  2396)   implicit none
  2397)   
  2398)   class(realization_subsurface_type) :: realization
  2399)   class(realization_geomech_type) :: geomech_realization
  2400)   type(field_type), pointer :: field
  2401)   type(option_type), pointer :: option
  2402)   type(patch_type), pointer :: patch
  2403)   type(geomech_field_type), pointer :: geomech_field
  2404)   type(grid_type), pointer :: grid
  2405)   class(material_auxvar_type), pointer :: material_auxvars(:)
  2406) 
  2407)   PetscReal :: trace_epsilon
  2408)   PetscReal, pointer :: por0_loc_p(:), strain_loc_p(:)
  2409)   PetscInt :: ghosted_id
  2410)   PetscErrorCode :: ierr
  2411) 
  2412)   option => realization%option
  2413)   field => realization%field
  2414)   patch => realization%patch
  2415)   grid => patch%grid
  2416)   geomech_field => geomech_realization%geomech_field
  2417)   material_auxvars => realization%patch%aux%Material%auxvars
  2418) 
  2419)   if (.not.associated(patch%imat)) then
  2420)     option%io_buffer = 'Materials IDs not present in run.  Material ' // &
  2421)       ' properties cannot be updated without material ids'
  2422)     call printErrMsg(option)
  2423)   endif
  2424)   
  2425)   call VecGetArrayF90(geomech_field%porosity_init_loc,por0_loc_p, &
  2426)                       ierr);CHKERRQ(ierr)
  2427)   call VecGetArrayF90(geomech_field%strain_subsurf_loc,strain_loc_p, &
  2428)                       ierr);CHKERRQ(ierr)
  2429)   
  2430)   do ghosted_id = 1, grid%ngmax
  2431)     trace_epsilon = strain_loc_p((ghosted_id-1)*SIX_INTEGER+ONE_INTEGER) + &
  2432)                     strain_loc_p((ghosted_id-1)*SIX_INTEGER+TWO_INTEGER) + &
  2433)                     strain_loc_p((ghosted_id-1)*SIX_INTEGER+THREE_INTEGER)
  2434)     material_auxvars(ghosted_id)%porosity = por0_loc_p(ghosted_id)/ &
  2435)       (1.d0 + (1.d0 - por0_loc_p(ghosted_id))*trace_epsilon)
  2436)   enddo
  2437)   
  2438)   call VecRestoreArrayF90(geomech_field%porosity_init_loc,por0_loc_p, &
  2439)                           ierr);CHKERRQ(ierr)
  2440)   call VecRestoreArrayF90(geomech_field%strain_subsurf_loc,strain_loc_p, &
  2441)                           ierr);CHKERRQ(ierr)
  2442) 
  2443)   call MaterialGetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2444)                                POROSITY,ZERO_INTEGER)
  2445)   call DiscretizationLocalToLocal(realization%discretization,field%work_loc, &
  2446)                                   field%work_loc,ONEDOF)
  2447)   call MaterialSetAuxVarVecLoc(patch%aux%Material,field%work_loc, &
  2448)                                POROSITY,ZERO_INTEGER)
  2449) 
  2450) end subroutine GeomechUpdateSubsurfPorosity
  2451) 
  2452) end module Geomechanics_Force_module

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