realization_surface.F90       coverage:  85.00 %func     67.87 %block


     1) module Realization_Surface_class
     2) 
     3)   use Realization_Base_class
     4)   
     5)   use Condition_module
     6)   use Debug_module
     7)   use Discretization_module
     8)   use Input_Aux_module
     9)   use Option_module
    10)   use Patch_module
    11)   use Region_module
    12)   use Surface_Field_module
    13)   use Surface_Material_module
    14)   use Dataset_Base_class
    15)   use Reaction_Aux_module
    16)   use Output_Aux_module
    17)   
    18)   use PFLOTRAN_Constants_module
    19) 
    20)   implicit none
    21)   
    22) private
    23) 
    24) 
    25) #include "petsc/finclude/petscsys.h"
    26) 
    27)   PetscReal, parameter :: eps       = 1.D-8
    28) 
    29)   type, public, extends(realization_base_type) :: realization_surface_type
    30) 
    31)     type(surface_field_type), pointer :: surf_field
    32)     type(region_list_type), pointer :: surf_regions
    33)     type(condition_list_type),pointer :: surf_flow_conditions
    34)     type(tran_condition_list_type),pointer :: surf_transport_conditions
    35)     type(surface_material_property_type), pointer :: surf_material_properties
    36)     type(surface_material_property_ptr_type), pointer :: surf_material_property_array(:)
    37)     type(reaction_type), pointer :: surf_reaction
    38)     character(len=MAXSTRINGLENGTH) :: surf_filename
    39)     character(len=MAXSTRINGLENGTH) :: subsurf_filename
    40) 
    41)     class(dataset_base_type), pointer :: datasets
    42)     
    43)     PetscReal :: dt_max
    44)     PetscReal :: dt_init
    45)     PetscReal :: dt_coupling
    46)     
    47)     PetscInt :: iter_count
    48)     PetscBool :: first_time
    49) 
    50)   end type realization_surface_type
    51) 
    52)   !         123456789+123456789+123456789+1
    53)   public :: RealizSurfCreate, &
    54)             RealizSurfDestroy, &
    55)             RealizSurfStrip, &
    56)             RealizSurfAddWaypointsToList, &
    57)             RealizSurfCreateDiscretization, &
    58)             RealizSurfAddCoupler, &
    59)             RealizSurfAddStrata, &
    60)             RealizSurfLocalizeRegions, &
    61)             RealizSurfPassFieldPtrToPatches, &
    62)             RealizSurfProcessCouplers, &
    63)             RealizSurfLocalToLocalWithArray, &
    64)             RealizSurfProcessConditions, &
    65)             RealizSurfProcessFlowConditions, &
    66)             RealizSurfMapSurfSubsurfGrids, &
    67)             RealizSurfInitAllCouplerAuxVars, &
    68)             RealizSurfAllCouplerAuxVars, &
    69)             RealizSurfProcessMatProp, &
    70)             RealizSurfUpdate, &
    71) !            RealizSurfCreateSurfSubsurfVec, &
    72) !            RealizSurfUpdateSubsurfBC, &
    73) !            RealizSurfUpdateSurfBC, &
    74) !            RealizSurfSurf2SubsurfFlux, &
    75)             RealizSurfGetVariable
    76) 
    77)   !TODO(intel)
    78) !  public :: SurfaceRealizationGetVariable     
    79)   
    80) !  interface SurfaceRealizationGetVariable
    81) !    module procedure :: RealizationGetVariable ! from Realization_Base_class
    82) !  end interface
    83)   
    84) contains
    85) 
    86) ! ************************************************************************** !
    87) 
    88) function RealizSurfCreate(option)
    89)   ! 
    90)   ! This routine allocates and initializes a new SurfaceRealization object
    91)   ! 
    92)   ! Author: Gautam Bisht, ORNL
    93)   ! Date: 02/16/12
    94)   ! 
    95) 
    96)   implicit none
    97) 
    98)   type(option_type), pointer :: option
    99)   class(realization_surface_type),pointer :: RealizSurfCreate
   100)   class(realization_surface_type),pointer :: surf_realization
   101)   
   102)   allocate(surf_realization)
   103)   call RealizationBaseInit(surf_realization,option)
   104)   surf_realization%option => option
   105)   nullify(surf_realization%input)
   106) 
   107)   surf_realization%surf_field => SurfaceFieldCreate()
   108)   !geh: debug, output_option, patch_list already allocated in 
   109)   !     RealizationBaseInit()
   110)   !geh: surf_realization%debug => DebugCreate()
   111)   !geh: surf_realization%output_option => OutputOptionCreate()
   112)   !geh: surf_realization%patch_list => PatchCreateList()
   113) 
   114)   nullify(surf_realization%surf_material_properties)
   115)   nullify(surf_realization%surf_material_property_array)
   116) 
   117)   allocate(surf_realization%surf_regions)
   118)   call RegionInitList(surf_realization%surf_regions)
   119)   
   120)   allocate(surf_realization%surf_flow_conditions)
   121)   call FlowConditionInitList(surf_realization%surf_flow_conditions)
   122)   allocate(surf_realization%surf_transport_conditions)
   123)   call TranConditionInitList(surf_realization%surf_transport_conditions)
   124)   
   125)   nullify(surf_realization%surf_reaction)
   126)   nullify(surf_realization%datasets)
   127) 
   128)   surf_realization%iter_count = 0
   129)   surf_realization%dt_init = 1.d0
   130)   surf_realization%dt_max = 1.d0
   131)   surf_realization%dt_coupling = 0.d0
   132)   
   133)   surf_realization%first_time = PETSC_TRUE
   134)   RealizSurfCreate => surf_realization
   135) 
   136) end function RealizSurfCreate
   137) 
   138) ! ************************************************************************** !
   139) 
   140) subroutine RealizSurfAddCoupler(surf_realization,coupler)
   141)   ! 
   142)   ! This routine adds a copy of a coupler to a list
   143)   ! 
   144)   ! Author: Gautam Bisht, ORNL
   145)   ! Date: 02/10/12
   146)   ! 
   147) 
   148)   use Coupler_module
   149) 
   150)   implicit none
   151)   
   152)   class(realization_surface_type) :: surf_realization
   153)   type(coupler_type), pointer :: coupler
   154)   
   155)   type(patch_type), pointer :: cur_patch
   156)   type(coupler_type), pointer :: new_coupler
   157)   
   158)   cur_patch => surf_realization%patch_list%first
   159)   do
   160)     if (.not.associated(cur_patch)) exit
   161)     ! only add to flow list for now, since they will be split out later
   162)     new_coupler => CouplerCreate(coupler)
   163)     select case(coupler%itype)
   164)       case(BOUNDARY_COUPLER_TYPE)
   165)         call CouplerAddToList(new_coupler,cur_patch%boundary_condition_list)
   166)       case(INITIAL_COUPLER_TYPE)
   167)         call CouplerAddToList(new_coupler,cur_patch%initial_condition_list)
   168)       case(SRC_SINK_COUPLER_TYPE)
   169)         call CouplerAddToList(new_coupler,cur_patch%source_sink_list)
   170)     end select
   171)     nullify(new_coupler)
   172)     cur_patch => cur_patch%next
   173)   enddo
   174) 
   175)   call CouplerDestroy(coupler)
   176)  
   177) end subroutine RealizSurfAddCoupler
   178) 
   179) ! ************************************************************************** !
   180) 
   181) subroutine RealizSurfProcessCouplers(surf_realization)
   182)   ! 
   183)   ! This routine sets connectivity and pointers for couplers related to
   184)   ! surface flow.
   185)   ! 
   186)   ! Author: Gautam Bisht, ORNL
   187)   ! Date: 02/17/12
   188)   ! 
   189) 
   190)   use Option_module
   191) 
   192)   implicit none
   193)   
   194)   class(realization_surface_type) :: surf_realization
   195)   type(patch_type), pointer :: cur_patch
   196)   
   197)   cur_patch => surf_realization%patch_list%first
   198)   do
   199)     if (.not.associated(cur_patch)) exit
   200)     call PatchProcessCouplers(cur_patch,surf_realization%surf_flow_conditions, &
   201)                               surf_realization%surf_transport_conditions, &
   202)                               surf_realization%option)
   203)     cur_patch => cur_patch%next
   204)   enddo
   205) 
   206) end subroutine RealizSurfProcessCouplers
   207) 
   208) ! ************************************************************************** !
   209) 
   210) subroutine RealizSurfProcessMatProp(surf_realization)
   211)   ! 
   212)   ! This routine sets up linkeage between surface material properties
   213)   ! 
   214)   ! Author: Gautam Bisht, ORNL
   215)   ! Date: 02/17/12
   216)   ! 
   217) 
   218)   use String_module
   219)   
   220)   implicit none
   221)   
   222)   class(realization_surface_type) :: surf_realization
   223)   
   224)   PetscBool :: found
   225)   PetscInt :: i
   226)   type(option_type), pointer :: option
   227)   character(len=MAXSTRINGLENGTH) :: string
   228) 
   229)   type(patch_type), pointer :: cur_patch
   230)   
   231)   option => surf_realization%option
   232)   
   233)   ! organize lists
   234)   call SurfaceMaterialPropConvertListToArray( &
   235)                                 surf_realization%surf_material_properties, &
   236)                                 surf_realization%surf_material_property_array, &
   237)                                 option)
   238) 
   239)   ! set up mirrored pointer arrays within patches to saturation functions
   240)   ! and material properties
   241)   cur_patch => surf_realization%patch_list%first
   242)   do
   243)     if (.not.associated(cur_patch)) exit
   244)     cur_patch%surf_material_properties => surf_realization%surf_material_properties
   245)     call SurfaceMaterialPropConvertListToArray( &
   246)                                     cur_patch%surf_material_properties, &
   247)                                     cur_patch%surf_material_property_array, &
   248)                                     option)
   249)     ! create mapping of internal to external material id
   250)     call SurfaceMaterialCreateIntToExtMapping(cur_patch%surf_material_property_array, &
   251)                                               cur_patch%imat_internal_to_external)
   252) 
   253)     cur_patch => cur_patch%next
   254)   enddo
   255)   
   256) end subroutine RealizSurfProcessMatProp
   257) 
   258) ! ************************************************************************** !
   259) 
   260) subroutine RealizSurfLocalizeRegions(surf_realization)
   261)   ! 
   262)   ! This routine localizes surface regions within each patch
   263)   ! (similar to RealizationLocalizeRegions)
   264)   ! 
   265)   ! Author: Gautam Bisht, ORNL
   266)   ! Date: 02/17/12
   267)   ! 
   268) 
   269)   use Option_module
   270)   use String_module
   271)   use Grid_module
   272) 
   273)   implicit none
   274)   
   275)   class(realization_surface_type) :: surf_realization
   276)   
   277)   type(patch_type), pointer :: cur_patch
   278)   type (region_type), pointer :: cur_region
   279)   type(option_type), pointer :: option
   280)   type(region_type), pointer :: patch_region
   281) 
   282)   option => surf_realization%option
   283) 
   284)   ! localize the regions on each patch
   285)   cur_patch => surf_realization%patch_list%first
   286)   do
   287)     if (.not.associated(cur_patch)) exit
   288)     call PatchLocalizeRegions(cur_patch,surf_realization%surf_regions, &
   289)                               surf_realization%option)
   290)     cur_patch => cur_patch%next
   291)   enddo
   292)  
   293) end subroutine RealizSurfLocalizeRegions
   294) 
   295) ! ************************************************************************** !
   296) 
   297) subroutine RealizSurfAddStrata(surf_realization,strata)
   298)   ! 
   299)   ! This routine adds a copy of a strata to a list
   300)   ! 
   301)   ! Author: Gautam Bisht, ORNL
   302)   ! Date: 02/17/12
   303)   ! 
   304) 
   305)   use Strata_module
   306) 
   307)   implicit none
   308)   
   309)   class(realization_surface_type) :: surf_realization
   310)   type(strata_type), pointer :: strata
   311)   
   312)   type(patch_type), pointer :: cur_patch
   313)   type(strata_type), pointer :: new_strata
   314)   
   315)   cur_patch => surf_realization%patch_list%first
   316)   do
   317)     if (.not.associated(cur_patch)) exit
   318)     new_strata => StrataCreate(strata)
   319)     call StrataAddToList(new_strata,cur_patch%strata_list)
   320)     nullify(new_strata)
   321)     cur_patch => cur_patch%next
   322)   enddo
   323)   
   324)   call StrataDestroy(strata)
   325)  
   326) end subroutine RealizSurfAddStrata
   327) 
   328) ! ************************************************************************** !
   329) 
   330) subroutine RealizSurfCreateDiscretization(surf_realization)
   331)   ! 
   332)   ! This routine creates grid
   333)   ! 
   334)   ! Author: Gautam Bisht, ORNL
   335)   ! Date: 02/17/12
   336)   ! 
   337) 
   338)   use Grid_module
   339)   use Grid_Unstructured_Aux_module, only : UGridMapIndices
   340)   use Grid_Unstructured_module, only     : UGridEnsureRightHandRule
   341)   use Coupler_module
   342)   use Discretization_module
   343)   use Grid_Unstructured_Cell_module
   344)   use DM_Kludge_module
   345)   
   346)   implicit none
   347) 
   348)   class(realization_surface_type) :: surf_realization
   349)   type(discretization_type), pointer :: discretization
   350)   type(grid_type), pointer :: grid
   351)   type(surface_field_type), pointer :: surf_field
   352)   type(option_type), pointer :: option
   353)   type(dm_ptr_type), pointer :: dm_ptr
   354) 
   355)   PetscErrorCode :: ierr
   356) 
   357)   option => surf_realization%option
   358)   surf_field => surf_realization%surf_field
   359)   discretization => surf_realization%discretization
   360) 
   361)   call DiscretizationCreateDMs(discretization, option%nsurfflowdof, &
   362)                                ZERO_INTEGER, ZERO_INTEGER, &
   363)                                ZERO_INTEGER, ZERO_INTEGER, &
   364)                                option)
   365) 
   366)   ! n degree of freedom, global
   367)   call DiscretizationCreateVector(discretization,NFLOWDOF,surf_field%flow_xx, &
   368)                                   GLOBAL,option)
   369)   call VecSet(surf_field%flow_xx,0.d0,ierr);CHKERRQ(ierr)
   370) 
   371)   call DiscretizationDuplicateVector(discretization,surf_field%flow_xx, &
   372)                                      surf_field%flow_yy)
   373)   call DiscretizationDuplicateVector(discretization,surf_field%flow_xx, &
   374)                                      surf_field%flow_dxx)
   375)   call DiscretizationDuplicateVector(discretization,surf_field%flow_xx, &
   376)                                      surf_field%flow_r)
   377)   call DiscretizationDuplicateVector(discretization,surf_field%flow_xx, &
   378)                                      surf_field%flow_accum)
   379)   call DiscretizationDuplicateVector(discretization,surf_field%flow_xx, &
   380)                                      surf_field%work)
   381) 
   382)   ! 1 degree of freedom, global
   383)   call DiscretizationCreateVector(discretization,ONEDOF,surf_field%mannings0, &
   384)                                   GLOBAL,option)
   385)   call VecSet(surf_field%mannings0,0.d0,ierr);CHKERRQ(ierr)
   386) 
   387)    call DiscretizationDuplicateVector(discretization,surf_field%mannings0, &
   388)                                      surf_field%area)
   389)   call DiscretizationDuplicateVector(discretization,surf_field%mannings0, &
   390)                                      surf_field%press_subsurf)
   391)   call DiscretizationDuplicateVector(discretization,surf_field%mannings0, &
   392)                                      surf_field%temp_subsurf)
   393)   ! n degrees of freedom, local
   394)   call DiscretizationCreateVector(discretization,NFLOWDOF,surf_field%flow_xx_loc, &
   395)                                   LOCAL,option)
   396)   call VecSet(surf_field%flow_xx_loc,0.d0,ierr);CHKERRQ(ierr)
   397)   call DiscretizationDuplicateVector(discretization,surf_field%flow_xx_loc, &
   398)                                      surf_field%work_loc)
   399) 
   400)   ! 1-dof degrees of freedom, local
   401)   call DiscretizationCreateVector(discretization,ONEDOF,surf_field%mannings_loc, &
   402)                                   LOCAL,option)
   403)   call VecSet(surf_field%mannings_loc,0.d0,ierr);CHKERRQ(ierr)
   404) 
   405)   grid => discretization%grid
   406) 
   407)   ! set up nG2L, NL2G, etc.
   408)   call UGridMapIndices(grid%unstructured_grid,discretization%dm_1dof%ugdm, &
   409)                         grid%nG2L,grid%nL2G,grid%nG2A,option)
   410)   call GridComputeCoordinates(grid,discretization%origin_global,option, &
   411)                               discretization%dm_1dof%ugdm) 
   412)   call UGridEnsureRightHandRule(grid%unstructured_grid,grid%x, &
   413)                                 grid%y,grid%z,grid%nG2A,grid%nL2G,option)
   414) 
   415)   ! set up internal connectivity, distance, etc.
   416)   call GridComputeInternalConnect(grid,option,discretization%dm_1dof%ugdm) 
   417)   call GridComputeAreas(grid,surf_field%area,option)
   418) 
   419)   ! Allocate vectors to hold flowrate quantities
   420)   if (surf_realization%output_option%print_hdf5_mass_flowrate.or. &
   421)      surf_realization%output_option%print_hdf5_energy_flowrate.or. &
   422)      surf_realization%output_option%print_hdf5_aveg_mass_flowrate.or. &
   423)      surf_realization%output_option%print_hdf5_aveg_energy_flowrate) then
   424) 
   425)     call VecCreateMPI(option%mycomm, &
   426)          (option%nflowdof*MAX_FACE_PER_CELL_SURF+1)*surf_realization%patch%grid%nlmax, &
   427)           PETSC_DETERMINE,surf_field%flowrate_inst,ierr);CHKERRQ(ierr)
   428)     call VecSet(surf_field%flowrate_inst,0.d0,ierr);CHKERRQ(ierr)
   429) 
   430)     ! If average flowrate has to be saved, create a vector for it
   431)     if (surf_realization%output_option%print_hdf5_aveg_mass_flowrate.or. &
   432)        surf_realization%output_option%print_hdf5_aveg_energy_flowrate) then
   433)       call VecCreateMPI(option%mycomm, &
   434)           (option%nflowdof*MAX_FACE_PER_CELL_SURF+1)*surf_realization%patch%grid%nlmax, &
   435)           PETSC_DETERMINE,surf_field%flowrate_aveg,ierr);CHKERRQ(ierr)
   436)     call VecSet(surf_field%flowrate_aveg,0.d0,ierr);CHKERRQ(ierr)
   437)     endif
   438)   endif
   439) 
   440) end subroutine RealizSurfCreateDiscretization
   441) 
   442) ! ************************************************************************** !
   443) 
   444) subroutine RealizSurfPassFieldPtrToPatches(surf_realization)
   445)   ! 
   446)   ! This routine
   447)   ! 
   448)   ! Author: Gautam Bisht, ORNL
   449)   ! Date: 02/19/12
   450)   ! 
   451) 
   452)   use Option_module
   453) 
   454)   implicit none
   455)   
   456)   class(realization_surface_type) :: surf_realization
   457) 
   458)   type(patch_type), pointer :: cur_patch
   459) 
   460)   cur_patch => surf_realization%patch_list%first
   461)   do
   462)     if (.not.associated(cur_patch)) exit
   463)     cur_patch%surf_field => surf_realization%surf_field
   464)     cur_patch => cur_patch%next
   465)   enddo
   466)   
   467) end subroutine RealizSurfPassFieldPtrToPatches
   468) 
   469) ! ************************************************************************** !
   470) 
   471) subroutine RealizSurfProcessConditions(surf_realization)
   472)   ! 
   473)   ! This routine
   474)   ! 
   475)   ! Author: Gautam Bisht, ORNL
   476)   ! Date: 02/19/12
   477)   ! 
   478) 
   479)   implicit none
   480)   
   481)   class(realization_surface_type) :: surf_realization
   482)   
   483)   if (surf_realization%option%nflowdof > 0) then
   484)     call RealizSurfProcessFlowConditions(surf_realization)
   485)   endif
   486)   if (surf_realization%option%ntrandof > 0) then
   487)     !call SurfaceRealProcessTranConditions(surf_realization)
   488)   endif
   489)  
   490) end subroutine RealizSurfProcessConditions
   491) 
   492) ! ************************************************************************** !
   493) 
   494) subroutine RealizSurfLocalToLocalWithArray(surf_realization,array_id)
   495)   ! 
   496)   ! This routine takes an F90 array that is ghosted and updates the ghosted
   497)   ! values (similar to RealLocalToLocalWithArray)
   498)   ! 
   499)   ! Author: Gautam Bisht, ORNL
   500)   ! Date: 02/13/12
   501)   ! 
   502) 
   503)   use Grid_module
   504)   use Surface_Field_module
   505) 
   506)   implicit none
   507) 
   508)   class(realization_surface_type) :: surf_realization
   509)   PetscInt :: array_id
   510)   
   511)   type(patch_type), pointer :: cur_patch
   512)   type(grid_type), pointer :: grid
   513)   type(surface_field_type), pointer :: surf_field
   514) 
   515)   surf_field => surf_realization%surf_field
   516) 
   517)   cur_patch => surf_realization%patch_list%first
   518)   do
   519)     if (.not.associated(cur_patch)) exit
   520)     grid => cur_patch%grid
   521)     select case(array_id)
   522)       case(MATERIAL_ID_ARRAY)
   523)         call GridCopyIntegerArrayToVec(grid, cur_patch%imat,surf_field%work_loc, &
   524)                                         grid%ngmax)
   525)     end select
   526)     cur_patch => cur_patch%next
   527)   enddo
   528)   call DiscretizationLocalToLocal(surf_realization%discretization, &
   529)                                   surf_field%work_loc, &
   530)                                   surf_field%work_loc,ONEDOF)
   531)   cur_patch => surf_realization%patch_list%first
   532)   do
   533)     if (.not.associated(cur_patch)) exit
   534)     grid => cur_patch%grid
   535) 
   536)     select case(array_id)
   537)       case(MATERIAL_ID_ARRAY)
   538)         call GridCopyVecToIntegerArray(grid, cur_patch%imat,surf_field%work_loc, &
   539)                                         grid%ngmax)
   540)     end select
   541)     cur_patch => cur_patch%next
   542)   enddo
   543) 
   544) end subroutine RealizSurfLocalToLocalWithArray
   545) 
   546) ! ************************************************************************** !
   547) 
   548) subroutine RealizSurfProcessFlowConditions(surf_realization)
   549)   ! 
   550)   ! This routine sets linkage of flow conditions to dataset
   551)   ! 
   552)   ! Author: Gautam Bisht, ORNL
   553)   ! Date: 02/20/12
   554)   ! 
   555) 
   556)   use Dataset_Base_class
   557)   use Dataset_module
   558) 
   559)   implicit none
   560) 
   561)   class(realization_surface_type) :: surf_realization
   562)   
   563)   type(flow_condition_type), pointer :: cur_surf_flow_condition
   564)   type(flow_sub_condition_type), pointer :: cur_surf_flow_sub_condition
   565)   type(option_type), pointer :: option
   566)   character(len=MAXSTRINGLENGTH) :: string
   567)   character(len=MAXWORDLENGTH) :: dataset_name
   568)   class(dataset_base_type), pointer :: dataset
   569)   PetscInt :: i
   570)   
   571)   option => surf_realization%option
   572)   
   573)   ! loop over flow conditions looking for linkage to datasets
   574)   cur_surf_flow_condition => surf_realization%surf_flow_conditions%first
   575)   do
   576)     if (.not.associated(cur_surf_flow_condition)) exit
   577)     string = 'flow_condition ' // trim(cur_surf_flow_condition%name)
   578)     ! find datum dataset
   579)     call DatasetFindInList(surf_realization%datasets, &
   580)                            cur_surf_flow_condition%datum, &
   581)                            cur_surf_flow_condition%default_time_storage, &
   582)                            string,option)
   583)     select case(option%iflowmode)
   584)       case(RICHARDS_MODE,TH_MODE)
   585)         do i = 1, size(cur_surf_flow_condition%sub_condition_ptr)
   586)            ! find dataset
   587)           call DatasetFindInList(surf_realization%datasets, &
   588)                  cur_surf_flow_condition%sub_condition_ptr(i)%ptr%dataset, &
   589)                  cur_surf_flow_condition%default_time_storage, &
   590)                  string,option)
   591)           ! find gradient dataset
   592)           call DatasetFindInList(surf_realization%datasets, &
   593)                  cur_surf_flow_condition%sub_condition_ptr(i)%ptr%gradient, &
   594)                  cur_surf_flow_condition%default_time_storage, &
   595)                  string,option)
   596)         enddo
   597)       case default
   598)         option%io_buffer='RealizSurfProcessFlowConditions not implemented in this mode'
   599)         call printErrMsg(option)
   600)     end select
   601)     cur_surf_flow_condition => cur_surf_flow_condition%next
   602)   enddo
   603) 
   604) end subroutine RealizSurfProcessFlowConditions
   605) 
   606) ! ************************************************************************** !
   607) 
   608) subroutine RealizSurfInitAllCouplerAuxVars(surf_realization)
   609)   ! 
   610)   ! This routine initializez coupler auxillary variables within list
   611)   ! 
   612)   ! Author: Gautam Bisht, ORNL
   613)   ! Date: 02/21/12
   614)   ! 
   615) 
   616)   use Option_module
   617) 
   618)   implicit none
   619)   
   620)   class(realization_surface_type) :: surf_realization
   621)   
   622)   type(patch_type), pointer :: cur_patch
   623) 
   624)   call FlowConditionUpdate(surf_realization%surf_flow_conditions, &
   625)                            surf_realization%option, &
   626)                            surf_realization%option%time)
   627) 
   628)   cur_patch => surf_realization%patch_list%first
   629)   do
   630)     if (.not.associated(cur_patch)) exit
   631)     call PatchInitAllCouplerAuxVars(cur_patch, &
   632)                                     surf_realization%option)
   633)     cur_patch => cur_patch%next
   634)   enddo
   635) 
   636) end subroutine RealizSurfInitAllCouplerAuxVars
   637) 
   638) ! ************************************************************************** !
   639) 
   640) subroutine RealizSurfAllCouplerAuxVars(surf_realization,force_update_flag)
   641)   ! 
   642)   ! This routine updates auxiliary variables associated with couplers in the
   643)   ! list.
   644)   ! 
   645)   ! Author: Gautam Bisht, LBNL
   646)   ! Date: 04/18/13
   647)   ! 
   648) 
   649)   use Option_module
   650) 
   651)   implicit none
   652) 
   653)   class(realization_surface_type) :: surf_realization
   654)   PetscBool :: force_update_flag
   655) 
   656)   call PatchUpdateAllCouplerAuxVars(surf_realization%patch,force_update_flag, &
   657)                                     surf_realization%option)
   658) 
   659) end subroutine RealizSurfAllCouplerAuxVars
   660) 
   661) ! ************************************************************************** !
   662) 
   663) subroutine RealizSurfMapSurfSubsurfGrids(realization,surf_realization)
   664)   ! 
   665)   ! This routine creates vector scatter contexts between surface and subsurface
   666)   ! grids.
   667)   ! Algorithm:
   668)   ! - It uses a similar logic of Matrix-Vector multiplication used in
   669)   ! UGridMapSideSet() subroutine. The algorithm here is extended to use
   670)   ! Matrix-Matrix mulitplication
   671)   ! 
   672)   ! Author: Gautam Bisht, ORNL
   673)   ! Date: 01/17/12
   674)   ! 
   675) 
   676)   use Grid_module
   677)   use String_module
   678)   use Grid_Unstructured_module
   679)   use Grid_Unstructured_Aux_module
   680)   use Grid_Unstructured_Cell_module
   681)   use Realization_Subsurface_class
   682)   use Option_module
   683)   use Patch_module
   684)   use Region_module
   685) 
   686)   implicit none
   687)   
   688) #include "petsc/finclude/petscvec.h"
   689) #include "petsc/finclude/petscvec.h90"
   690) #include "petsc/finclude/petscmat.h"
   691) #include "petsc/finclude/petscmat.h90"
   692) 
   693)   class(realization_subsurface_type), pointer :: realization
   694)   class(realization_surface_type), pointer :: surf_realization
   695) 
   696)   type(option_type), pointer :: option
   697)   type(grid_unstructured_type),pointer :: subsurf_grid
   698)   type(grid_unstructured_type),pointer :: surf_grid
   699)   type(patch_type), pointer :: cur_patch 
   700)   type(region_type), pointer :: cur_region, top_region
   701)   type(region_type), pointer :: patch_region
   702) 
   703)   Mat :: Mat_vert_to_face_subsurf
   704)   Mat :: Mat_vert_to_face_subsurf_transp
   705)   Mat :: Mat_vert_to_face_surf
   706)   Mat :: Mat_vert_to_face_surf_transp
   707)   Mat :: prod
   708)   Vec :: subsurf_petsc_ids, surf_petsc_ids
   709) 
   710)   PetscViewer :: viewer
   711) 
   712) 
   713)   character(len=MAXSTRINGLENGTH) :: string
   714)   PetscInt,pointer ::int_array(:)
   715)   PetscInt :: offset
   716)   PetscInt :: int_array4(4)
   717)   PetscInt :: int_array4_0(4,1)
   718)   PetscInt :: nvertices
   719)   PetscInt :: iface
   720)   PetscInt :: local_id, ii, jj
   721)   PetscInt :: cell_type
   722)   PetscInt :: ivertex, vertex_id_local
   723)   PetscReal :: real_array4(4)
   724)   PetscReal, pointer :: vec_ptr(:)
   725) 
   726)   PetscErrorCode :: ierr
   727)   PetscBool :: found
   728)   
   729)   found = PETSC_FALSE
   730)   
   731)   if (.not.associated(realization)) return
   732)   
   733)   option => realization%option
   734)   subsurf_grid => realization%discretization%grid%unstructured_grid
   735)   surf_grid    => surf_realization%discretization%grid%unstructured_grid
   736) 
   737)   ! localize the regions on each patch
   738)   cur_patch => realization%patch_list%first
   739)   do
   740)     if (.not.associated(cur_patch)) exit
   741)     cur_region => cur_patch%region_list%first
   742)       do
   743)         if (.not.associated(cur_region)) exit
   744)         if (StringCompare(cur_region%name,'top')) then
   745)           found = PETSC_TRUE
   746)           top_region => cur_region
   747)           exit
   748)         endif
   749)         cur_region => cur_region%next
   750)       enddo
   751)     cur_patch => cur_patch%next
   752)   enddo
   753) 
   754)   if (found.eqv.PETSC_FALSE) then
   755)     option%io_buffer = 'When running with -DSURFACE_FLOW need to specify ' // &
   756)       ' in the inputfile explicitly region: top '
   757)     call printErrMsg(option)
   758)   endif
   759) 
   760)   call MatCreateAIJ(option%mycomm, &
   761)                        top_region%num_cells, &
   762)                        PETSC_DECIDE, &
   763)                        PETSC_DETERMINE, &
   764)                        subsurf_grid%num_vertices_global, &
   765)                        4, &
   766)                        PETSC_NULL_INTEGER, &
   767)                        4, &
   768)                        PETSC_NULL_INTEGER, &
   769)                        Mat_vert_to_face_subsurf, &
   770)                        ierr);CHKERRQ(ierr)
   771) 
   772)    call MatCreateAIJ(option%mycomm, &
   773)                      PETSC_DECIDE, &
   774)                      top_region%num_cells, &
   775)                      subsurf_grid%num_vertices_global, &
   776)                      PETSC_DETERMINE, &
   777)                      12, &
   778)                      PETSC_NULL_INTEGER, &
   779)                      12, &
   780)                      PETSC_NULL_INTEGER, &
   781)                      Mat_vert_to_face_subsurf_transp, &
   782)                      ierr);CHKERRQ(ierr)
   783) 
   784)   call VecCreateMPI(option%mycomm,top_region%num_cells,PETSC_DETERMINE, &
   785)                     subsurf_petsc_ids,ierr);CHKERRQ(ierr)
   786)   call MatZeroEntries(Mat_vert_to_face_subsurf,ierr);CHKERRQ(ierr)
   787)   real_array4 = 1.d0
   788) 
   789)   call VecGetArrayF90(subsurf_petsc_ids,vec_ptr,ierr);CHKERRQ(ierr)
   790) 
   791)   offset=0
   792)   call MPI_Exscan(top_region%num_cells,offset, &
   793)                   ONE_INTEGER_MPI,MPIU_INTEGER,MPI_SUM,option%mycomm,ierr)
   794) 
   795)   do ii = 1, top_region%num_cells
   796)     local_id = top_region%cell_ids(ii)
   797)     vec_ptr(ii) = subsurf_grid%cell_ids_petsc(local_id)
   798)     iface    = top_region%faces(ii)
   799)     cell_type = subsurf_grid%cell_type(local_id)
   800)     !nfaces = UCellGetNFaces(cell_type,option)
   801) 
   802)     call UCellGetNFaceVertsandVerts(option,cell_type,iface,nvertices, &
   803)                                     int_array4)
   804)     ! For this matrix:
   805)     !   irow = local face id
   806)     !   icol = natural (global) vertex id
   807)     do ivertex = 1, nvertices
   808)       vertex_id_local = &
   809)         subsurf_grid%cell_vertices(int_array4(ivertex),local_id)
   810)       int_array4_0(ivertex,1) = &
   811)         subsurf_grid%vertex_ids_natural(vertex_id_local)-1
   812)     enddo
   813)     call MatSetValues(Mat_vert_to_face_subsurf, &
   814)                       1,ii-1+offset, &
   815)                       nvertices,int_array4_0, &
   816)                       real_array4, &
   817)                       INSERT_VALUES,ierr);CHKERRQ(ierr)
   818)     call MatSetValues(Mat_vert_to_face_subsurf_transp, &
   819)                       nvertices,int_array4_0, &
   820)                       1,ii-1+offset, &
   821)                       real_array4, &
   822)                       INSERT_VALUES,ierr);CHKERRQ(ierr)
   823)   enddo
   824) 
   825)   call VecRestoreArrayF90(subsurf_petsc_ids,vec_ptr,ierr);CHKERRQ(ierr)
   826) 
   827)   call MatAssemblyBegin(Mat_vert_to_face_subsurf,MAT_FINAL_ASSEMBLY, &
   828)                         ierr);CHKERRQ(ierr)
   829)   call MatAssemblyEnd(Mat_vert_to_face_subsurf,MAT_FINAL_ASSEMBLY, &
   830)                       ierr);CHKERRQ(ierr)
   831)   call MatAssemblyBegin(Mat_vert_to_face_subsurf_transp,MAT_FINAL_ASSEMBLY, &
   832)                         ierr);CHKERRQ(ierr)
   833)   call MatAssemblyEnd(Mat_vert_to_face_subsurf_transp,MAT_FINAL_ASSEMBLY, &
   834)                       ierr);CHKERRQ(ierr)
   835) 
   836) #if UGRID_DEBUG
   837)   string = 'Mat_vert_to_face_subsurf.out'
   838)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   839)   call MatView(Mat_vert_to_face_subsurf,viewer,ierr);CHKERRQ(ierr)
   840)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   841) #endif  
   842) 
   843)   !call MatTranspose(Mat_vert_to_face_subsurf,MAT_INITIAL_MATRIX, &
   844)   !                  Mat_vert_to_face_subsurf_transp,ierr)
   845) 
   846) #if UGRID_DEBUG
   847)   string = 'Mat_vert_to_face_subsurf_transp.out'
   848)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   849)   call MatView(Mat_vert_to_face_subsurf_transp,viewer,ierr);CHKERRQ(ierr)
   850)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   851) 
   852)   string = 'subsurf_petsc_ids.out'
   853)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   854)   call VecView(subsurf_petsc_ids,viewer,ierr);CHKERRQ(ierr)
   855)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   856) #endif
   857) 
   858)   call MatCreateAIJ(option%mycomm, &
   859)                        surf_grid%nlmax, &
   860)                        PETSC_DECIDE, &
   861)                        PETSC_DETERMINE, &
   862)                        subsurf_grid%num_vertices_global, &
   863)                        4, &
   864)                        PETSC_NULL_INTEGER, &
   865)                        4, &
   866)                        PETSC_NULL_INTEGER, &
   867)                        Mat_vert_to_face_surf, &
   868)                        ierr);CHKERRQ(ierr)
   869) 
   870)   call MatCreateAIJ(option%mycomm, &
   871)                     PETSC_DECIDE, &
   872)                     surf_grid%nlmax, &
   873)                     subsurf_grid%num_vertices_global, &
   874)                     PETSC_DETERMINE, &
   875)                     12, &
   876)                     PETSC_NULL_INTEGER, &
   877)                     12, &
   878)                     PETSC_NULL_INTEGER, &
   879)                     Mat_vert_to_face_surf_transp, &
   880)                     ierr);CHKERRQ(ierr)
   881) 
   882)   call VecCreateMPI(option%mycomm,surf_grid%nlmax,PETSC_DETERMINE, &
   883)                     surf_petsc_ids,ierr);CHKERRQ(ierr)
   884)   offset=0
   885)   call MPI_Exscan(surf_grid%nlmax,offset, &
   886)                   ONE_INTEGER_MPI,MPIU_INTEGER,MPI_SUM,option%mycomm,ierr)
   887) 
   888)   call VecGetArrayF90(surf_petsc_ids,vec_ptr,ierr);CHKERRQ(ierr)
   889) 
   890)   do local_id = 1, surf_grid%nlmax
   891)     cell_type = surf_grid%cell_type(local_id)
   892)     vec_ptr(local_id) = surf_grid%cell_ids_petsc(local_id)
   893)     
   894)     int_array4_0 = 0
   895)     nvertices = surf_grid%cell_vertices(0,local_id)
   896)     do ivertex = 1, nvertices
   897)       vertex_id_local = surf_grid%cell_vertices(ivertex,local_id)
   898)       int_array4_0(ivertex,1) = &
   899)         surf_grid%vertex_ids_natural(vertex_id_local)-1
   900)     enddo    
   901)    call MatSetValues(Mat_vert_to_face_surf,1,local_id-1+offset, &
   902)                      nvertices,int_array4_0,real_array4, &
   903)                      INSERT_VALUES,ierr);CHKERRQ(ierr)
   904)    call MatSetValues(Mat_vert_to_face_surf_transp, &
   905)                      nvertices,int_array4_0, &
   906)                      1,local_id-1+offset, &
   907)                      real_array4, &
   908)                      INSERT_VALUES,ierr);CHKERRQ(ierr)
   909)   enddo
   910) 
   911)   call VecRestoreArrayF90(surf_petsc_ids,vec_ptr,ierr);CHKERRQ(ierr)
   912) 
   913)   call MatAssemblyBegin(Mat_vert_to_face_surf,MAT_FINAL_ASSEMBLY, &
   914)                         ierr);CHKERRQ(ierr)
   915)   call MatAssemblyEnd(Mat_vert_to_face_surf,MAT_FINAL_ASSEMBLY, &
   916)                       ierr);CHKERRQ(ierr)
   917) 
   918)   call MatAssemblyBegin(Mat_vert_to_face_surf_transp,MAT_FINAL_ASSEMBLY, &
   919)                         ierr);CHKERRQ(ierr)
   920)   call MatAssemblyEnd(Mat_vert_to_face_surf_transp,MAT_FINAL_ASSEMBLY, &
   921)                       ierr);CHKERRQ(ierr)
   922) 
   923) #if UGRID_DEBUG
   924)   string = 'Mat_vert_to_face_surf.out'
   925)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   926)   call MatView(Mat_vert_to_face_surf,viewer,ierr);CHKERRQ(ierr)
   927)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   928) 
   929)   string = 'surf_petsc_ids.out'
   930)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   931)   call VecView(surf_petsc_ids,viewer,ierr);CHKERRQ(ierr)
   932)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   933) #endif  
   934) 
   935)   !call MatTranspose(Mat_vert_to_face_surf,MAT_INITIAL_MATRIX, &
   936)   !                  Mat_vert_to_face_surf_transp,ierr)
   937) 
   938) #if UGRID_DEBUG
   939)   string = 'Mat_vert_to_face_surf_transp.out'
   940)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   941)   call MatView(Mat_vert_to_face_surf_transp,viewer,ierr);CHKERRQ(ierr)
   942)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   943) #endif  
   944)   
   945)   call MatMatMult(Mat_vert_to_face_subsurf,Mat_vert_to_face_surf_transp, &
   946)                   MAT_INITIAL_MATRIX,PETSC_DEFAULT_REAL,prod, &
   947)                   ierr);CHKERRQ(ierr)
   948) 
   949) #if UGRID_DEBUG
   950)   string = 'prod.out'
   951)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   952)   call MatView(prod,viewer,ierr);CHKERRQ(ierr)
   953)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   954) #endif  
   955) 
   956)   call RealizSurfMapSurfSubsurfGrid(realization, surf_realization, prod, TWO_DIM_GRID, &
   957)                                      surf_petsc_ids)
   958)   call MatDestroy(prod,ierr);CHKERRQ(ierr)
   959) 
   960)   call MatMatMult(Mat_vert_to_face_surf,Mat_vert_to_face_subsurf_transp, &
   961)                   MAT_INITIAL_MATRIX,PETSC_DEFAULT_REAL,prod, &
   962)                   ierr);CHKERRQ(ierr)
   963) 
   964) #if UGRID_DEBUG
   965)   string = 'prod_2.out'
   966)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
   967)   call MatView(prod,viewer,ierr);CHKERRQ(ierr)
   968)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
   969) #endif  
   970)   call RealizSurfMapSurfSubsurfGrid(realization, surf_realization, prod, THREE_DIM_GRID, &
   971)                                         subsurf_petsc_ids)
   972) 
   973)   call MatDestroy(prod,ierr);CHKERRQ(ierr)
   974) 
   975)   call MatDestroy(Mat_vert_to_face_subsurf,ierr);CHKERRQ(ierr)
   976)   call MatDestroy(Mat_vert_to_face_subsurf_transp,ierr);CHKERRQ(ierr)
   977)   call MatDestroy(Mat_vert_to_face_surf,ierr);CHKERRQ(ierr)
   978)   call MatDestroy(Mat_vert_to_face_surf_transp,ierr);CHKERRQ(ierr)
   979) 
   980)   call VecDestroy(subsurf_petsc_ids,ierr);CHKERRQ(ierr)
   981)   call VecDestroy(surf_petsc_ids,ierr);CHKERRQ(ierr)
   982)   
   983) end subroutine RealizSurfMapSurfSubsurfGrids
   984) 
   985) ! ************************************************************************** !
   986) 
   987) subroutine RealizSurfMapSurfSubsurfGrid( &
   988)               realization, &       !<
   989)               surf_realization, &  !<
   990)               prod_mat, &          !< Mat-Mat-Mult matrix
   991)               source_grid_flag, &  !< To identify a surface or subsurface grid
   992)               source_petsc_ids &   !< MPI-Vector containing cell ids in PETSc order
   993)               )
   994)   ! 
   995)   ! This subroutine creates a single vector scatter context
   996)   ! Algorithm:
   997)   ! 
   998)   ! Author: Gautam Bisht, ORNL
   999)   ! Date: 01/18/12
  1000)   ! 
  1001) 
  1002)   use Grid_module
  1003)   use String_module
  1004)   use Grid_Unstructured_module
  1005)   use Grid_Unstructured_Cell_module
  1006)   use Realization_Subsurface_class
  1007)   use Option_module
  1008)   use Field_module
  1009)   use Surface_Field_module
  1010)   use Grid_Unstructured_module
  1011)   use Discretization_module
  1012)   use Grid_Unstructured_Aux_module
  1013)   use DM_Kludge_module
  1014) 
  1015)   implicit none
  1016)   
  1017) #include "petsc/finclude/petscvec.h"
  1018) #include "petsc/finclude/petscvec.h90"
  1019) #include "petsc/finclude/petscmat.h"
  1020) #include "petsc/finclude/petscmat.h90"
  1021) 
  1022)   class(realization_subsurface_type), pointer :: realization
  1023)   class(realization_surface_type), pointer :: surf_realization
  1024)   Mat :: prod_mat
  1025)   PetscInt :: source_grid_flag
  1026)   Vec :: source_petsc_ids
  1027) 
  1028)   Mat :: prod_loc_mat
  1029)   Vec :: source_loc_vec
  1030)   Vec :: corr_dest_ids_vec
  1031)   Vec :: corr_dest_ids_vec_ndof
  1032)   Vec :: source_petsc_ids_ndof
  1033)   IS :: is_tmp1, is_tmp2
  1034)   IS :: is_tmp3, is_tmp4
  1035)   PetscInt,pointer :: corr_v2_ids(:)
  1036)   VecScatter :: scatter
  1037)   VecScatter :: scatter_ndof
  1038) 
  1039)   PetscViewer :: viewer
  1040) 
  1041)   type(option_type), pointer :: option
  1042)   type(field_type), pointer :: field
  1043)   type(surface_field_type), pointer :: surf_field
  1044) 
  1045)   type(dm_ptr_type), pointer :: dm_ptr
  1046)   character(len=MAXSTRINGLENGTH) :: string
  1047)   PetscInt,pointer ::int_array(:)
  1048)   PetscInt :: offset
  1049)   PetscInt :: int_array4(4)
  1050)   PetscInt :: int_array4_0(4,1)
  1051)   PetscReal :: real_array4(4)
  1052)   PetscInt :: ii, jj
  1053)   PetscReal, pointer :: vec_ptr(:)
  1054)   PetscInt :: ivertex, cell_id, vertex_id_local
  1055)   PetscReal :: max_value
  1056) 
  1057)   PetscInt, pointer :: ia_p(:), ja_p(:)
  1058)   PetscInt :: nrow,rstart,rend,icol(1)
  1059)   PetscInt :: index
  1060)   PetscInt :: vertex_id
  1061)   PetscOffset :: iia,jja,iicol
  1062)   PetscBool :: done
  1063)   PetscScalar, pointer :: aa_v(:)
  1064)   PetscInt :: row, col
  1065) 
  1066)   PetscErrorCode :: ierr
  1067)   PetscBool :: found
  1068)   PetscInt :: nlocal
  1069) 
  1070)   option     => realization%option
  1071)   field      => realization%field
  1072)   surf_field => surf_realization%surf_field
  1073)   
  1074)   if (option%mycommsize > 1) then
  1075)     ! From the MPI-Matrix get the local-matrix
  1076)     call MatMPIAIJGetLocalMat(prod_mat,MAT_INITIAL_MATRIX,prod_loc_mat, &
  1077)                               ierr);CHKERRQ(ierr)
  1078)     ! Get i and j indices of the local-matrix
  1079)     call MatGetRowIJF90(prod_loc_mat, ONE_INTEGER, PETSC_FALSE, PETSC_FALSE, &
  1080)                         nrow, ia_p, ja_p, done, ierr);CHKERRQ(ierr)
  1081)     ! Get values stored in the local-matrix
  1082)     call MatSeqAIJGetArrayF90(prod_loc_mat,aa_v,ierr);CHKERRQ(ierr)
  1083)   else
  1084)     ! Get i and j indices of the local-matrix
  1085)     call MatGetRowIJF90(prod_mat, ONE_INTEGER, PETSC_FALSE, PETSC_FALSE, &
  1086)                         nrow, ia_p, ja_p, done, ierr);CHKERRQ(ierr)
  1087)     ! Get values stored in the local-matrix
  1088)     call MatSeqAIJGetArrayF90(prod_mat,aa_v,ierr);CHKERRQ(ierr)
  1089)   endif
  1090) 
  1091)   ! For each row of the local-matrix, find the column with the largest value
  1092)   allocate(corr_v2_ids(nrow))
  1093)   row = 1
  1094)   col = 0
  1095)   do ii = 1, nrow
  1096)     max_value = 0.d0
  1097)     do jj = ia_p(ii), ia_p(ii + 1) - 1
  1098)       if (aa_v(jj) > max_value) then
  1099)         corr_v2_ids(ii) = ja_p(jj)
  1100)         max_value = aa_v(jj)
  1101)       endif
  1102)     enddo
  1103)     if (max_value<3) then
  1104)       option%io_buffer = 'Atleast three vertices need to form a face'
  1105)       call printErrMsg(option)
  1106)     endif
  1107)   enddo
  1108) 
  1109)   offset = 0
  1110)   call MPI_Exscan(nrow,offset,ONE_INTEGER_MPI, &
  1111)                   MPIU_INTEGER,MPI_SUM,option%mycomm,ierr)
  1112)   allocate(int_array(nrow))
  1113)   do ii = 1, nrow
  1114)     int_array(ii) = (ii-1)+offset
  1115)   enddo
  1116)   call ISCreateGeneral(option%mycomm,nrow, &
  1117)                        int_array,PETSC_COPY_VALUES,is_tmp1,ierr);CHKERRQ(ierr)
  1118)   call ISCreateBlock(option%mycomm,option%nflowdof,nrow, &
  1119)                      int_array,PETSC_COPY_VALUES,is_tmp3,ierr);CHKERRQ(ierr)
  1120) 
  1121)   do ii = 1, nrow
  1122)     int_array(ii) = corr_v2_ids(ii)-1
  1123)   enddo
  1124)   call ISCreateGeneral(option%mycomm,nrow, &
  1125)                        int_array,PETSC_COPY_VALUES,is_tmp2,ierr);CHKERRQ(ierr)
  1126)   call ISCreateBlock(option%mycomm,option%nflowdof,nrow, &
  1127)                      int_array,PETSC_COPY_VALUES,is_tmp4,ierr);CHKERRQ(ierr)
  1128)   deallocate(int_array)
  1129)   
  1130)   call VecCreateMPI(option%mycomm,nrow,PETSC_DETERMINE, &
  1131)                     corr_dest_ids_vec,ierr);CHKERRQ(ierr)
  1132)   call VecScatterCreate(source_petsc_ids,is_tmp2,corr_dest_ids_vec,is_tmp1, &
  1133)                         scatter,ierr);CHKERRQ(ierr)
  1134)   call ISDestroy(is_tmp1,ierr);CHKERRQ(ierr)
  1135)   call ISDestroy(is_tmp2,ierr);CHKERRQ(ierr)
  1136)   
  1137)   call VecScatterBegin(scatter,source_petsc_ids,corr_dest_ids_vec, &
  1138)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1139)   call VecScatterEnd(scatter,source_petsc_ids,corr_dest_ids_vec, &
  1140)                        INSERT_VALUES,SCATTER_FORWARD,ierr);CHKERRQ(ierr)
  1141)   select case(source_grid_flag)
  1142)     case(TWO_DIM_GRID)
  1143)       dm_ptr => DiscretizationGetDMPtrFromIndex(surf_realization%discretization,ONEDOF)
  1144)       call VecScatterCopy(scatter,dm_ptr%ugdm%scatter_bet_grids, &
  1145)                           ierr);CHKERRQ(ierr)
  1146)       call VecScatterCopy(scatter,dm_ptr%ugdm%scatter_bet_grids_1dof, &
  1147)                           ierr);CHKERRQ(ierr)
  1148)     case(THREE_DIM_GRID)
  1149)       dm_ptr => DiscretizationGetDMPtrFromIndex(realization%discretization,ONEDOF)
  1150)       call VecScatterCopy(scatter,dm_ptr%ugdm%scatter_bet_grids, &
  1151)                           ierr);CHKERRQ(ierr)
  1152)       call VecScatterCopy(scatter,dm_ptr%ugdm%scatter_bet_grids_1dof, &
  1153)                           ierr);CHKERRQ(ierr)
  1154)   end select
  1155)   call VecScatterDestroy(scatter,ierr);CHKERRQ(ierr)
  1156) 
  1157) #if UGRID_DEBUG
  1158)   if (source_grid_flag==TWO_DIM_GRID) write(string,*) 'surf'
  1159)   if (source_grid_flag==THREE_DIM_GRID) write(string,*) 'subsurf'
  1160)   string = adjustl(string)
  1161)   string = 'corr_dest_ids_vec_' // trim(string) // '.out'
  1162)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
  1163)   call VecView(corr_dest_ids_vec,viewer,ierr);CHKERRQ(ierr)
  1164)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  1165) #endif
  1166) 
  1167)   call VecDestroy(corr_dest_ids_vec,ierr);CHKERRQ(ierr)
  1168)   if (option%mycommsize>1) then
  1169)     call MatSeqAIJRestoreArrayF90(prod_loc_mat,aa_v,ierr);CHKERRQ(ierr)
  1170)     call MatDestroy(prod_loc_mat,ierr);CHKERRQ(ierr)
  1171)   else
  1172)     call MatSeqAIJRestoreArrayF90(prod_mat,aa_v,ierr);CHKERRQ(ierr)
  1173)   endif
  1174) 
  1175) #if UGRID_DEBUG
  1176)   if (source_grid_flag==TWO_DIM_GRID) write(string,*) 'surf'
  1177)   if (source_grid_flag==THREE_DIM_GRID) write(string,*) 'subsurf'
  1178)   string = adjustl(string)
  1179)   string = 'scatter_bet_grids_' // trim(string) // '.out'
  1180)   call PetscViewerASCIIOpen(option%mycomm,string,viewer,ierr);CHKERRQ(ierr)
  1181)   call VecScatterView(dm_ptr%ugdm%scatter_bet_grids,viewer,ierr);CHKERRQ(ierr)
  1182)   call PetscViewerDestroy(viewer,ierr);CHKERRQ(ierr)
  1183) #endif
  1184) 
  1185)   ! Create stridded vectors
  1186)   call VecCreate(option%mycomm,corr_dest_ids_vec_ndof,ierr);CHKERRQ(ierr)
  1187)   call VecSetSizes(corr_dest_ids_vec_ndof,nrow*option%nflowdof, &
  1188)                   PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1189)   call VecSetBlockSize(corr_dest_ids_vec_ndof,option%nflowdof, &
  1190)                        ierr);CHKERRQ(ierr)
  1191)   call VecSetFromOptions(corr_dest_ids_vec_ndof,ierr);CHKERRQ(ierr)
  1192) 
  1193)   call VecGetLocalSize(source_petsc_ids,nlocal,ierr);CHKERRQ(ierr)
  1194)   call VecCreate(option%mycomm,source_petsc_ids_ndof,ierr);CHKERRQ(ierr)
  1195)   call VecSetSizes(source_petsc_ids_ndof,nlocal*option%nflowdof, &
  1196)                   PETSC_DECIDE,ierr);CHKERRQ(ierr)
  1197)   call VecSetBlockSize(source_petsc_ids_ndof,option%nflowdof, &
  1198)                        ierr);CHKERRQ(ierr)
  1199)   call VecSetFromOptions(source_petsc_ids_ndof,ierr);CHKERRQ(ierr)
  1200) 
  1201)   ! Create stridded vectors-scatter context
  1202)   call VecScatterCreate(source_petsc_ids_ndof,is_tmp4, &
  1203)                         corr_dest_ids_vec_ndof,is_tmp3, &
  1204)                         scatter_ndof,ierr);CHKERRQ(ierr)
  1205) 
  1206)   ! Save the stridded vectors-scatter context
  1207)   select case(source_grid_flag)
  1208)     case(TWO_DIM_GRID)
  1209)       dm_ptr => DiscretizationGetDMPtrFromIndex(surf_realization%discretization,NFLOWDOF)
  1210)     case(THREE_DIM_GRID)
  1211)       dm_ptr => DiscretizationGetDMPtrFromIndex(realization%discretization,NFLOWDOF)
  1212)   end select
  1213)   call VecScatterCopy(scatter_ndof,dm_ptr%ugdm%scatter_bet_grids_ndof, &
  1214)                       ierr);CHKERRQ(ierr)
  1215) 
  1216)   ! Cleanup
  1217)   call VecScatterDestroy(scatter_ndof,ierr);CHKERRQ(ierr)
  1218)   call VecDestroy(source_petsc_ids_ndof,ierr);CHKERRQ(ierr)
  1219)   call VecDestroy(corr_dest_ids_vec_ndof,ierr);CHKERRQ(ierr)
  1220) 
  1221) end subroutine RealizSurfMapSurfSubsurfGrid
  1222) 
  1223) ! ************************************************************************** !
  1224) 
  1225) subroutine RealizSurfDestroy(surf_realization)
  1226)   ! 
  1227)   ! This routine destroys RealizSurf object
  1228)   ! 
  1229)   ! Author: Gautam Bisht, ORNL
  1230)   ! Date: 02/16/12
  1231)   ! 
  1232) 
  1233)   implicit none
  1234)   
  1235)   class(realization_surface_type), pointer :: surf_realization
  1236)   
  1237)   if (.not.associated(surf_realization)) return
  1238)   
  1239)   !geh: deallocate everything in base
  1240)   call RealizationBaseStrip(surf_realization)
  1241)   
  1242)   call SurfaceFieldDestroy(surf_realization%surf_field)
  1243) 
  1244)   call OutputOptionDestroy(surf_realization%output_option)
  1245)   
  1246)   call RegionDestroyList(surf_realization%surf_regions)
  1247)   
  1248)   call FlowConditionDestroyList(surf_realization%surf_flow_conditions)
  1249) 
  1250)   call TranConditionDestroyList(surf_realization%surf_transport_conditions)
  1251)   
  1252)   call PatchDestroyList(surf_realization%patch_list)
  1253)   
  1254)   if (associated(surf_realization%debug)) deallocate(surf_realization%debug)
  1255)   nullify(surf_realization%debug)
  1256)   
  1257)   if (associated(surf_realization%surf_material_property_array)) &
  1258)     deallocate(surf_realization%surf_material_property_array)
  1259)   nullify(surf_realization%surf_material_property_array)
  1260)   call SurfaceMaterialPropertyDestroy(surf_realization%surf_material_properties)
  1261)   
  1262)   call DiscretizationDestroy(surf_realization%discretization)
  1263) 
  1264)   if (associated(surf_realization)) deallocate(surf_realization)
  1265)   nullify(surf_realization)
  1266) 
  1267) end subroutine RealizSurfDestroy
  1268) 
  1269) 
  1270) ! ************************************************************************** !
  1271) 
  1272) subroutine RealizSurfStrip(surf_realization)
  1273)   ! 
  1274)   ! This routine destroys RealizSurf object
  1275)   ! 
  1276)   ! Author: Gautam Bisht, ORNL
  1277)   ! Date: 02/16/12
  1278)   ! 
  1279) 
  1280)   implicit none
  1281)   
  1282)   class(realization_surface_type), pointer :: surf_realization
  1283)   
  1284)   if (.not.associated(surf_realization)) return
  1285)   
  1286)   !geh: deallocate everything in base
  1287)   call RealizationBaseStrip(surf_realization)
  1288)   
  1289)   call SurfaceFieldDestroy(surf_realization%surf_field)
  1290) 
  1291)   call OutputOptionDestroy(surf_realization%output_option)
  1292)   
  1293)   call RegionDestroyList(surf_realization%surf_regions)
  1294)   
  1295)   call FlowConditionDestroyList(surf_realization%surf_flow_conditions)
  1296) 
  1297)   call TranConditionDestroyList(surf_realization%surf_transport_conditions)
  1298)   
  1299)   call PatchDestroyList(surf_realization%patch_list)
  1300)   
  1301)   if (associated(surf_realization%debug)) deallocate(surf_realization%debug)
  1302)   nullify(surf_realization%debug)
  1303)   
  1304)   if (associated(surf_realization%surf_material_property_array)) &
  1305)     deallocate(surf_realization%surf_material_property_array)
  1306)   nullify(surf_realization%surf_material_property_array)
  1307)   call SurfaceMaterialPropertyDestroy(surf_realization%surf_material_properties)
  1308)   
  1309)   call DiscretizationDestroy(surf_realization%discretization)
  1310) 
  1311)   call ReactionDestroy(surf_realization%reaction,surf_realization%option)
  1312) 
  1313) end subroutine RealizSurfStrip
  1314) 
  1315) ! ************************************************************************** !
  1316) 
  1317) subroutine RealizSurfUpdate(surf_realization)
  1318)   ! 
  1319)   ! This routine updates parameters in realization (eg. conditions, bcs, srcs)
  1320)   ! 
  1321)   ! Author: Gautam Bisht, ORNL
  1322)   ! Date: 05/22/12
  1323)   ! 
  1324) 
  1325)   implicit none
  1326)   
  1327)   class(realization_surface_type) :: surf_realization
  1328) 
  1329)   PetscBool :: force_update_flag = PETSC_FALSE
  1330) 
  1331)   ! must update conditions first
  1332)   call FlowConditionUpdate(surf_realization%surf_flow_conditions, &
  1333)                            surf_realization%option, &
  1334)                            surf_realization%option%time)
  1335) 
  1336)   call RealizSurfAllCouplerAuxVars(surf_realization,force_update_flag)
  1337) 
  1338) end subroutine RealizSurfUpdate
  1339) 
  1340) ! ************************************************************************** !
  1341) 
  1342) subroutine RealizSurfGetVariable(surf_realization,vec,ivar,isubvar,isubvar1)
  1343)   ! 
  1344)   ! This routine extracts variables indexed by ivar and isubvar from surface
  1345)   ! realization.
  1346)   ! 
  1347)   ! Author: Gautam Bisht, ORNL
  1348)   ! Date: 05/22/12
  1349)   ! 
  1350) 
  1351)   use Option_module
  1352)   use Surface_Field_module
  1353) 
  1354)   implicit none
  1355) 
  1356)   class(realization_surface_type) :: surf_realization
  1357)   Vec :: vec
  1358)   PetscInt :: ivar
  1359)   PetscInt :: isubvar
  1360)   PetscInt, optional :: isubvar1
  1361) 
  1362)   call PatchGetVariable(surf_realization%patch, &
  1363)                        surf_realization%surf_field, &
  1364)                        !surf_realization%reaction, &
  1365)                        surf_realization%option, &
  1366)                        surf_realization%output_option, &
  1367)                        vec,ivar,isubvar,isubvar1)
  1368) 
  1369) end subroutine RealizSurfGetVariable
  1370) 
  1371) ! ************************************************************************** !
  1372) 
  1373) subroutine RealizSurfAddWaypointsToList(surf_realization,waypoint_list)
  1374)   ! 
  1375)   ! This routine creates waypoints assocated with source/sink, boundary
  1376)   ! condition, etc. and adds to a list
  1377)   ! 
  1378)   ! Author: Gautam Bisht, LBNL
  1379)   ! Date: 03/15/13
  1380)   ! 
  1381) 
  1382)   use Option_module
  1383)   use Waypoint_module
  1384)   use Time_Storage_module  
  1385) 
  1386)   implicit none
  1387)   
  1388)   class(realization_surface_type) :: surf_realization
  1389)   type(waypoint_list_type) :: waypoint_list
  1390) 
  1391)   type(flow_condition_type), pointer :: cur_flow_condition
  1392)   type(flow_sub_condition_type), pointer :: sub_condition
  1393)   type(waypoint_type), pointer :: waypoint, cur_waypoint
  1394)   type(option_type), pointer :: option
  1395)   PetscInt :: itime, isub_condition
  1396)   PetscReal :: temp_real, final_time
  1397)   PetscReal, pointer :: times(:)
  1398) 
  1399)   option => surf_realization%option
  1400)   nullify(times)
  1401)   
  1402)   ! set flag for final output
  1403)   cur_waypoint => waypoint_list%first
  1404)   do
  1405)     if (.not.associated(cur_waypoint)) exit
  1406)     if (cur_waypoint%final) then
  1407)       cur_waypoint%print_snap_output = &
  1408)         surf_realization%output_option%print_final_snap
  1409)       exit
  1410)     endif
  1411)     cur_waypoint => cur_waypoint%next
  1412)   enddo
  1413)   ! use final time in conditional below
  1414)   if (associated(cur_waypoint)) then
  1415)     final_time = cur_waypoint%time
  1416)   else
  1417)     option%io_buffer = 'Final time not found in RealizSurfAddWaypointsToList'
  1418)     call printErrMsg(option)
  1419)   endif
  1420) 
  1421)   ! add update of flow conditions
  1422)   cur_flow_condition => surf_realization%surf_flow_conditions%first
  1423)   do
  1424)     if (.not.associated(cur_flow_condition)) exit
  1425)     if (cur_flow_condition%sync_time_with_update) then
  1426)       do isub_condition = 1, cur_flow_condition%num_sub_conditions
  1427)         sub_condition => cur_flow_condition%sub_condition_ptr(isub_condition)%ptr
  1428)         !TODO(geh): check if this updated more than simply the flow_dataset (i.e. datum and gradient)
  1429)         !geh: followup - no, datum/gradient are not considered.  Should they be considered?
  1430)         call TimeStorageGetTimes(sub_condition%dataset%time_storage, option, &
  1431)                                 final_time, times)        
  1432)         if (associated(times)) then
  1433)           if (size(times) > 1000) then
  1434)             option%io_buffer = 'For flow condition "' // &
  1435)               trim(cur_flow_condition%name) // &
  1436)               '" dataset "' // trim(sub_condition%name) // &
  1437)               '", the number of times is excessive for synchronization ' // &
  1438)               'with waypoints.'
  1439)             call printErrMsg(option)
  1440)           endif
  1441)           do itime = 1, size(times)
  1442)             waypoint => WaypointCreate()
  1443)             waypoint%time = times(itime)
  1444)             waypoint%update_conditions = PETSC_TRUE
  1445)             call WaypointInsertInList(waypoint,waypoint_list)
  1446)           enddo
  1447)           deallocate(times)
  1448)           nullify(times)
  1449)         endif
  1450)       enddo
  1451)     endif
  1452)     cur_flow_condition => cur_flow_condition%next
  1453)   enddo
  1454)      
  1455) end subroutine RealizSurfAddWaypointsToList
  1456) 
  1457) end module Realization_Surface_class

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