surface_material.F90       coverage:  70.00 %func     48.81 %block


     1) module Surface_Material_module
     2) 
     3)   use PFLOTRAN_Constants_module
     4) 
     5)   implicit none
     6)   
     7)   private
     8)   
     9) #include "petsc/finclude/petscsys.h"
    10) 
    11)   type, public :: surface_material_property_type
    12)     
    13)     character(len=MAXWORDLENGTH) :: name
    14)     PetscInt :: external_id
    15)     PetscInt :: internal_id
    16)     PetscReal :: mannings
    17)     
    18)     type(surface_material_property_type), pointer :: next
    19)   end type surface_material_property_type
    20)   
    21)   type, public :: surface_material_property_ptr_type
    22)     type(surface_material_property_type), pointer :: ptr
    23)   end type surface_material_property_ptr_type
    24) 
    25)   public :: SurfaceMaterialPropertyCreate, &
    26)             SurfaceMaterialPropertyDestroy, &
    27)             SurfaceMaterialPropertyAddToList, &
    28)             SurfaceMaterialPropertyRead, &
    29)             SurfaceMaterialPropConvertListToArray, &
    30)             SurfaceMaterialPropGetPtrFromArray, &
    31)             SurfaceMaterialGetMaxExternalID, &
    32)             SurfaceMaterialCreateIntToExtMapping, &
    33)             SurfaceMaterialCreateExtToIntMapping, &
    34)             SurfaceMaterialApplyMapping
    35) 
    36)   contains
    37) 
    38) ! ************************************************************************** !
    39) 
    40) function SurfaceMaterialPropertyCreate()
    41)   ! 
    42)   ! This routine creates a surface material property
    43)   ! 
    44)   ! Author: Gautam Bisht, ORNL
    45)   ! Date: 02/09/12
    46)   ! 
    47) 
    48)   implicit none
    49)   
    50)   type(surface_material_property_type), pointer :: SurfaceMaterialPropertyCreate
    51)   type(surface_material_property_type), pointer :: surf_material_property
    52)   
    53)   allocate(surf_material_property)
    54) 
    55)   surf_material_property%name        = ''
    56)   surf_material_property%internal_id = 0
    57)   surf_material_property%external_id = 0
    58)   surf_material_property%mannings    = 0.d0
    59)   
    60)   nullify(surf_material_property%next)
    61)   
    62)   SurfaceMaterialPropertyCreate => surf_material_property
    63) 
    64) end function SurfaceMaterialPropertyCreate
    65) 
    66) ! ************************************************************************** !
    67) 
    68) subroutine SurfaceMaterialPropertyRead(surf_material_property,input,option)
    69)   ! 
    70)   ! This routine reads in contents of a surface material property
    71)   ! 
    72)   ! Author: Gautam Bisht, ORNL
    73)   ! Date: 02/09/12
    74)   ! 
    75) 
    76)   use Option_module
    77)   use Input_Aux_module
    78)   use String_module
    79)   
    80)   implicit none
    81)   
    82)   type(surface_material_property_type) :: surf_material_property
    83)   type(input_type), pointer :: input
    84)   type(option_type) :: option
    85)   
    86)   character(len=MAXWORDLENGTH) :: keyword, word
    87)   character(len=MAXSTRINGLENGTH) :: string
    88) 
    89)   do
    90)     call InputReadPflotranString(input,option)
    91)     
    92)     if (InputCheckExit(input,option)) exit
    93)   
    94)     call InputReadWord(input,option,keyword,PETSC_TRUE)
    95)     call InputErrorMsg(input,option,'keyword','SURFACE_MATERIAL_PROPERTY')
    96)     call StringToUpper(keyword)
    97)     
    98)     select case(trim(keyword))
    99)       case('ID')
   100)         call InputReadInt(input,option,surf_material_property%external_id)
   101)         call InputErrorMsg(input,option,'id','SURFACE_MATERIAL_PROPERTY')
   102)       case('MANNINGS')
   103)         call InputReadDouble(input,option,surf_material_property%mannings)
   104)         call InputErrorMsg(input,option,'MANNINGS','SURFACE_MATERIAL_PROPERTY')
   105)       case default
   106)         call InputKeywordUnrecognized(keyword,'SURFACE_MATERIAL_PROPERTY',option)
   107)       end select
   108)   enddo
   109)   
   110) end subroutine SurfaceMaterialPropertyRead
   111) 
   112) ! ************************************************************************** !
   113) 
   114) subroutine SurfaceMaterialPropertyAddToList(surf_material_property,list)
   115)   ! 
   116)   ! This routine adds a surface material property to a linked list
   117)   ! 
   118)   ! Author: Gautam Bisht, ORNL
   119)   ! Date: 02/09/12
   120)   ! 
   121) 
   122)   implicit none
   123)   
   124)   type(surface_material_property_type), pointer :: surf_material_property
   125)   type(surface_material_property_type), pointer :: list
   126)   type(surface_material_property_type), pointer :: cur_surf_material_property
   127)   
   128)   if (associated(list)) then
   129)     cur_surf_material_property => list
   130)     ! loop to end of list
   131)     do
   132)       if (.not.associated(cur_surf_material_property%next)) exit
   133)       cur_surf_material_property => cur_surf_material_property%next
   134)     enddo
   135)     cur_surf_material_property%next => surf_material_property
   136)     surf_material_property%internal_id = cur_surf_material_property%internal_id + 1
   137)   else
   138)     list => surf_material_property
   139)     surf_material_property%internal_id = 1
   140)   endif
   141)   
   142) end subroutine SurfaceMaterialPropertyAddToList
   143) 
   144) ! ************************************************************************** !
   145) 
   146) recursive subroutine SurfaceMaterialPropertyDestroy(surf_material_property)
   147)   ! 
   148)   ! This routine destroys a surface material property
   149)   ! 
   150)   ! Author: Gautam Bisht, ORNL
   151)   ! Date: 02/09/12
   152)   ! 
   153) 
   154)   implicit none
   155)   
   156)   type(surface_material_property_type), pointer :: surf_material_property
   157)   
   158)   if (.not.associated(surf_material_property)) return
   159)   
   160)   call SurfaceMaterialPropertyDestroy(surf_material_property%next)
   161)   
   162)   deallocate(surf_material_property)
   163)   nullify(surf_material_property)
   164)   
   165) end subroutine SurfaceMaterialPropertyDestroy
   166) 
   167) ! ************************************************************************** !
   168) 
   169) subroutine SurfaceMaterialPropConvertListToArray(list,array,option)
   170)   ! 
   171)   ! This routine creates an array of pointers to the surface_material_properties
   172)   ! in the list (similar to subroutine MaterialPropConvertListToArray)
   173)   ! 
   174)   ! Author: Gautam Bisht, ORNL
   175)   ! Date: 02/11/12
   176)   ! 
   177) 
   178)   use Option_module
   179)   use String_module
   180) 
   181)   implicit none
   182) 
   183)   type(surface_material_property_type), pointer :: list
   184)   type(surface_material_property_ptr_type), pointer :: array(:)
   185)   type(option_type) :: option
   186) 
   187)   type(surface_material_property_type), pointer :: cur_material_property
   188)   type(surface_material_property_type), pointer :: prev_material_property
   189)   type(surface_material_property_type), pointer :: next_material_property
   190)   PetscInt :: i, j, length1,length2, max_internal_id, max_external_id
   191)   PetscInt, allocatable :: id_count(:)
   192)   PetscBool :: error_flag
   193)   character(len=MAXSTRINGLENGTH) :: string
   194) 
   195)   ! check to ensure that max internal id is equal to the number of
   196)   ! material properties and that internal ids are contiguous
   197)   max_internal_id = 0
   198)   max_external_id = 0
   199)   cur_material_property => list
   200)   do
   201)     if (.not.associated(cur_material_property)) exit
   202)     max_internal_id = max_internal_id + 1
   203)     max_external_id = max(max_external_id,cur_material_property%external_id)
   204)     if (max_internal_id /= cur_material_property%internal_id) then
   205)       write(string,*) cur_material_property%external_id
   206)       option%io_buffer = 'Non-contiguous internal material id for ' // &
   207)         'material named "' // trim(cur_material_property%name) // &
   208)         '" with external id "' // trim(adjustl(string)) // '" '
   209)       write(string,*) cur_material_property%internal_id
   210)       option%io_buffer = trim(option%io_buffer) // &
   211)         'and internal id "' // trim(adjustl(string)) // '".'
   212)       call printErrMsg(option)
   213)     endif
   214)     cur_material_property => cur_material_property%next
   215)   enddo
   216) 
   217)   allocate(array(max_internal_id))
   218)   do i = 1, max_internal_id
   219)     nullify(array(i)%ptr)
   220)   enddo
   221) 
   222)   ! use id_count to ensure that an id is not duplicated
   223)   allocate(id_count(max_external_id))
   224)   id_count = 0
   225) 
   226)   cur_material_property => list
   227)   do
   228)     if (.not.associated(cur_material_property)) exit
   229)     id_count(cur_material_property%external_id) = &
   230)       id_count(cur_material_property%external_id) + 1
   231)     array(cur_material_property%internal_id)%ptr => cur_material_property
   232)     cur_material_property => cur_material_property%next
   233)   enddo
   234) 
   235)   ! check to ensure that an id is not duplicated
   236)   error_flag = PETSC_FALSE
   237)   do i = 1, max_external_id
   238)     if (id_count(i) > 1) then
   239)       write(string,*) i
   240)       option%io_buffer = 'Material ID ' // trim(adjustl(string)) // &
   241)         ' is duplicated in input file.'
   242)       call printMsg(option)
   243)       error_flag = PETSC_TRUE
   244)     endif
   245)   enddo
   246) 
   247)   deallocate(id_count)
   248) 
   249)   if (error_flag) then
   250)     option%io_buffer = 'Duplicate Material IDs.'
   251)     call printErrMsg(option)
   252)   endif
   253) 
   254)   ! ensure unique material names
   255)   error_flag = PETSC_FALSE
   256)   do i = 1, size(array)
   257)     if (associated(array(i)%ptr)) then
   258)       length1 = len_trim(array(i)%ptr%name)
   259)       do j = 1, i-1
   260)         if (associated(array(j)%ptr)) then
   261)           length2 = len_trim(array(j)%ptr%name)
   262)           if (length1 /= length2) cycle
   263)           if (StringCompare(array(i)%ptr%name,array(j)%ptr%name,length1)) then
   264)             option%io_buffer = 'Material name "' // &
   265)               trim(adjustl(array(i)%ptr%name)) // &
   266)               '" is duplicated in input file.'
   267)             call printMsg(option)
   268)             error_flag = PETSC_TRUE
   269)           endif
   270)         endif
   271)       enddo
   272)     endif
   273)   enddo
   274) 
   275)   if (error_flag) then
   276)     option%io_buffer = 'Duplicate Material names.'
   277)     call printErrMsg(option)
   278)   endif
   279) 
   280) end subroutine SurfaceMaterialPropConvertListToArray
   281) 
   282) ! ************************************************************************** !
   283) 
   284) function SurfaceMaterialPropGetPtrFromArray(surf_material_property_name, &
   285)                                             surf_material_property_array)
   286)   ! 
   287)   ! This routine returns a pointer to the surface material property matching
   288)   ! surface_material_propertry_name (similar to subroutine
   289)   ! MaterialPropGetPtrFromArray)
   290)   ! 
   291)   ! Author: Gautam Bisht, ORNL
   292)   ! Date: 02/11/12
   293)   ! 
   294) 
   295)   use String_module
   296) 
   297)   implicit none
   298) 
   299)   type(surface_material_property_type), pointer :: SurfaceMaterialPropGetPtrFromArray
   300)   type(surface_material_property_ptr_type), pointer :: surf_material_property_array(:)
   301)   character(len=MAXWORDLENGTH) :: surf_material_property_name
   302)   PetscInt :: length
   303)   PetscInt :: isurf_material_property
   304) 
   305)   nullify(SurfaceMaterialPropGetPtrFromArray)
   306) 
   307)   do isurf_material_property = 1, size(surf_material_property_array)
   308)     length = len_trim(surf_material_property_name)
   309)     if (.not.associated(surf_material_property_array(isurf_material_property)%ptr)) cycle
   310)     if (length == &
   311)         len_trim(surf_material_property_array(isurf_material_property)%ptr%name) .and. &
   312)         StringCompare(surf_material_property_array(isurf_material_property)%ptr%name, &
   313)                         surf_material_property_name,length)) then
   314)       SurfaceMaterialPropGetPtrFromArray => &
   315)         surf_material_property_array(isurf_material_property)%ptr
   316)       return
   317)     endif
   318)   enddo
   319) 
   320) end function SurfaceMaterialPropGetPtrFromArray
   321) 
   322) ! ************************************************************************** !
   323) 
   324) function SurfaceMaterialGetMaxExternalID(surf_material_property_array)
   325)   !
   326)   ! Maps internal material ids to external for I/O, etc. [copy of
   327)   ! MaterialGetMaxExternalID()]
   328)   !
   329)   ! Author: Gautam Bisht
   330)   ! Date: 08/05/14
   331)   !
   332)   implicit none
   333) 
   334)   type(surface_material_property_ptr_type) :: surf_material_property_array(:)
   335) 
   336)   PetscInt :: SurfaceMaterialGetMaxExternalID
   337) 
   338)   PetscInt :: i
   339) 
   340)   SurfaceMaterialGetMaxExternalID = UNINITIALIZED_INTEGER
   341)   do i = 1, size(surf_material_property_array)
   342)     SurfaceMaterialGetMaxExternalID = max(SurfaceMaterialGetMaxExternalID, &
   343)                                          (surf_material_property_array(i)%ptr%external_id))
   344)   enddo
   345) 
   346) end function SurfaceMaterialGetMaxExternalID
   347) 
   348) ! ************************************************************************** !
   349) 
   350) subroutine SurfaceMaterialCreateIntToExtMapping(surf_material_property_array,mapping)
   351)   !
   352)   ! Maps internal material ids to external for I/O, etc. [copy of
   353)   ! MaterialCreateIntToExtMapping()]
   354)   !
   355)   ! Author: Gautam Bisht.
   356)   ! Date: 08/08/14
   357)   !
   358)   implicit none
   359) 
   360)   type(surface_material_property_ptr_type) :: surf_material_property_array(:)
   361)   PetscInt, pointer :: mapping(:)
   362) 
   363)   PetscInt :: i
   364) 
   365)   allocate(mapping(size(surf_material_property_array)))
   366)   mapping = UNINITIALIZED_INTEGER
   367) 
   368)   do i = 1, size(surf_material_property_array)
   369)     mapping(surf_material_property_array(i)%ptr%internal_id) = &
   370)       surf_material_property_array(i)%ptr%external_id
   371)   enddo
   372) 
   373) end subroutine SurfaceMaterialCreateIntToExtMapping
   374) 
   375) ! ************************************************************************** !
   376) 
   377) subroutine SurfaceMaterialCreateExtToIntMapping(surf_material_property_array,mapping)
   378)   !
   379)   ! Maps external material ids to internal for setup. This array should be
   380)   ! temporary and never stored for the duration of the simulation.
   381)   ! [copy of MaterialCreateExtToIntMapping()]
   382)   !
   383)   ! Author: Gautam Bisht
   384)   ! Date: 08/08/14
   385)   !
   386)   implicit none
   387) 
   388)   type(surface_material_property_ptr_type) :: surf_material_property_array(:)
   389)   PetscInt, pointer :: mapping(:)
   390) 
   391)   PetscInt :: i
   392) 
   393)   allocate(mapping(SurfaceMaterialGetMaxExternalID(surf_material_property_array)))
   394)   mapping = -888
   395) 
   396)   do i = 1, size(surf_material_property_array)
   397)     mapping(surf_material_property_array(i)%ptr%external_id) = &
   398)       surf_material_property_array(i)%ptr%internal_id
   399)   enddo
   400) 
   401) end subroutine SurfaceMaterialCreateExtToIntMapping
   402) 
   403) ! ************************************************************************** !
   404) 
   405) subroutine SurfaceMaterialApplyMapping(mapping,array)
   406)   !
   407)   ! Maps internal material ids to external for I/O, etc. [copy of
   408)   ! MaterialApplyMapping()]
   409)   !
   410)   ! Author: Gautam Bisht
   411)   ! Date: 08/08/14
   412)   !
   413)   implicit none
   414) 
   415)   PetscInt :: mapping(:)
   416)   PetscInt :: array(:)
   417) 
   418)   PetscInt :: i
   419)   PetscInt :: mapping_size
   420)   PetscInt :: mapped_id
   421) 
   422)   mapping_size = size(mapping)
   423)   do i = 1, size(array)
   424)     if (array(i) <= mapping_size) then
   425)       mapped_id = mapping(array(i))
   426)     else
   427)       mapped_id = -888 ! indicates corresponding mapped value does not exist.
   428)     endif
   429)     if (mapped_id == -888) then ! negate material id to indicate not found
   430)       mapped_id = -1*array(i)
   431)     endif
   432)     array(i) = mapped_id
   433)   enddo
   434) 
   435) end subroutine SurfaceMaterialApplyMapping
   436) 
   437) end module Surface_Material_module

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