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