FrontISTR 5.2.0
Large-scale structural analysis program with finit element method
Loading...
Searching...
No Matches
hecmw_result_f.f90
Go to the documentation of this file.
1!-------------------------------------------------------------------------------
2! Copyright (c) 2019 FrontISTR Commons
3! This software is released under the MIT License, see LICENSE.txt
4!-------------------------------------------------------------------------------
6
8 use hecmw_util
10 implicit none
11
12 public :: hecmwst_result_data
14 public :: hecmw_result_copy_c2f
15 public :: hecmw_result_copy_f2c
16 public :: hecmw_result_init
17 public :: hecmw_result_add
21 public :: hecmw_result_finalize
22 public :: hecmw_result_free
25 private :: put_node_component
26 private :: put_elem_component
27 private :: refine_result
28 private :: get_node_component
29 private :: get_elem_component
30
32 integer(kind=kint) :: ng_component
33 integer(kind=kint) :: nn_component
34 integer(kind=kint) :: ne_component
35 integer(kind=kint),pointer :: ng_dof(:)
36 integer(kind=kint),pointer :: nn_dof(:)
37 integer(kind=kint),pointer :: ne_dof(:)
38 character(len=HECMW_NAME_LEN),pointer :: global_label(:)
39 character(len=HECMW_NAME_LEN),pointer :: node_label(:)
40 character(len=HECMW_NAME_LEN),pointer :: elem_label(:)
41 real(kind=kreal),pointer :: global_val_item(:)
42 real(kind=kreal),pointer :: node_val_item(:)
43 real(kind=kreal),pointer :: elem_val_item(:)
44 end type hecmwst_result_data
45
46 private
47 character(len=HECMW_NAME_LEN) :: sname,vname
48 logical :: mpc_exist
49 integer(kind=kint) :: nelem_wo_mpc = 0
50 integer(kind=kint), allocatable :: eid_wo_mpc(:)
51 integer(kind=kint), allocatable :: elemid_wo_mpc(:)
52
53contains
54
55 !C=============================================================================
56 !C nullify pointer
57 !C=============================================================================
58
60 type( hecmwst_result_data ) :: p
61 nullify( p%ng_dof )
62 nullify( p%nn_dof )
63 nullify( p%ne_dof )
64 nullify( p%global_label )
65 nullify( p%node_label )
66 nullify( p%elem_label )
67 nullify( p%global_val_item )
68 nullify( p%node_val_item )
69 nullify( p%elem_val_item )
70 end subroutine hecmw_nullify_result_data
71
72 !C=============================================================================
73 !C Write result data to file
74 !C=============================================================================
75
76 subroutine hecmw_result_init(hecMESH, i_step, header, comment)
77 type(hecmwst_local_mesh):: hecmesh
78 integer(kind=kint) :: nnode, nelem, i_step, ierr
79 character(len=HECMW_HEADER_LEN) :: header
80 character(len=HECMW_MSG_LEN) :: comment
81
82 integer(kind=kint) :: itype, is, ie, ic_type, icel
83
84 mpc_exist = .false.
85 do itype= 1, hecmesh%n_elem_type
86 ic_type = hecmesh%elem_type_item(itype)
87 if (hecmw_is_etype_patch(ic_type)) mpc_exist = .true.
88 if (hecmw_is_etype_link(ic_type)) mpc_exist = .true.
89 end do
90
91 nnode = hecmesh%n_node
92 nelem = hecmesh%n_elem
93
94 if( mpc_exist ) then
95
96 if( nelem_wo_mpc == 0 ) then
97 allocate(eid_wo_mpc(nelem))
98 allocate(elemid_wo_mpc(nelem))
99 eid_wo_mpc(:) = 0
100 elemid_wo_mpc(:) = 0
101
102 nelem_wo_mpc = 0
103 do itype= 1, hecmesh%n_elem_type
104 is= hecmesh%elem_type_index(itype-1) + 1
105 ie= hecmesh%elem_type_index(itype )
106 ic_type= hecmesh%elem_type_item(itype)
107
108 if (hecmw_is_etype_patch(ic_type)) cycle
109 if (hecmw_is_etype_link(ic_type)) cycle
110
111 do icel= is, ie
112 nelem_wo_mpc = nelem_wo_mpc + 1
113 elemid_wo_mpc(nelem_wo_mpc) = hecmesh%global_elem_ID(icel)
114 eid_wo_mpc(nelem_wo_mpc) = icel
115 end do
116 end do
117 end if
118
119 call hecmw_result_init_if(nnode, nelem_wo_mpc, hecmesh%global_node_ID, elemid_wo_mpc, i_step, header, comment, ierr)
120 else
121 call hecmw_result_init_if(nnode, nelem, hecmesh%global_node_ID, hecmesh%global_elem_ID, i_step, header, comment, ierr)
122 end if
123
124 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
125 end subroutine hecmw_result_init
126
127
128 subroutine hecmw_result_add(dtype, n_dof, label, data)
129 integer(kind=kint) :: dtype, n_dof, ierr
130 character(len=HECMW_NAME_LEN) :: label
131 real(kind=kreal) :: data(:)
132
133 integer(kind=kint) :: i, icel
134 real(kind=kreal), pointer :: data_wo_mpc(:)
135
136 if( dtype == 2 .and. mpc_exist ) then !element output without patch element
137
138 allocate(data_wo_mpc(n_dof*nelem_wo_mpc))
139 data_wo_mpc(:) = 0.d0
140
141 do i= 1, nelem_wo_mpc
142 icel = eid_wo_mpc(i)
143 data_wo_mpc(n_dof*(i-1)+1:n_dof*i) = data(n_dof*(icel-1)+1:n_dof*icel)
144 end do
145
146 call hecmw_result_add_if(dtype, n_dof, label, data_wo_mpc, ierr)
147
148 deallocate(data_wo_mpc)
149
150 else
151 call hecmw_result_add_if(dtype, n_dof, label, data, ierr)
152 end if
153
154 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
155 end subroutine hecmw_result_add
156
157
158 subroutine hecmw_result_write_by_name(name_ID)
159 integer(kind=kint) :: ierr
160 character(len=HECMW_NAME_LEN) :: name_id
161
162 call hecmw_result_write_by_name_if(name_id, ierr)
163 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
164 end subroutine hecmw_result_write_by_name
165
166
168 integer(kind=kint) :: ierr
169
170 call hecmw_result_finalize_if(ierr)
171 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
172 end subroutine hecmw_result_finalize
173
174
175 subroutine hecmw_result_write_st_by_name(name_ID, result_data)
176 integer(kind=kint) :: ierr
177 type(hecmwst_result_data):: result_data
178 character(len=HECMW_NAME_LEN):: name_id
179
181 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
182 call hecmw_result_copy_f2c(result_data, ierr)
183 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
184 call hecmw_result_write_st_by_name_if(name_id, ierr)
185 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
187 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
188 end subroutine hecmw_result_write_st_by_name
189
190
191 subroutine hecmw_result_write_by_addfname(name_ID, addfname)
192 integer(kind=kint) :: ierr
193 character(len=HECMW_NAME_LEN) :: name_id, addfname
194
195 call hecmw_result_write_by_addfname_if(name_id, addfname, ierr)
196 if(ierr /= 0) call hecmw_abort(hecmw_comm_get_comm())
197 end subroutine hecmw_result_write_by_addfname
198
199
200 subroutine hecmw_result_copy_f2c( result_data, ierr )
201 type(hecmwst_result_data), intent(in) :: result_data
202 integer(kind=kint), intent(inout) :: ierr
203
204 call put_global_component( result_data, ierr )
205 if( ierr /= 0 ) return
206 call put_node_component( result_data, ierr )
207 if( ierr /= 0 ) return
208 call put_elem_component( result_data, ierr )
209 if( ierr /= 0 ) return
210 end subroutine hecmw_result_copy_f2c
211
212
213 subroutine put_global_component( result_data, ierr )
214 type(hecmwst_result_data), intent(in) :: result_data
215 integer(kind=kint), intent(inout) :: ierr
216
217 sname = "hecmwST_result_data"
218
219 vname = "ng_component"
220 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%ng_component, ierr )
221 if( ierr /= 0 ) return
222
223 if( result_data%ng_component /= 0 ) then
224 vname = "ng_dof"
225 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%ng_dof, ierr )
226 if( ierr /= 0 ) return
227
228 vname = "global_label"
229 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%global_label, ierr )
230 if( ierr /= 0 ) return
231
232 vname = "global_val_item"
233 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%global_val_item, ierr )
234 if( ierr /= 0 ) return
235 endif
236 end subroutine put_global_component
237
238 subroutine put_node_component( result_data, ierr )
239 type(hecmwst_result_data), intent(in) :: result_data
240 integer(kind=kint), intent(inout) :: ierr
241
242 sname = "hecmwST_result_data"
243
244 vname = "nn_component"
245 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%nn_component, ierr )
246 if( ierr /= 0 ) return
247
248 if( result_data%nn_component /= 0 ) then
249 vname = "nn_dof"
250 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%nn_dof, ierr )
251 if( ierr /= 0 ) return
252
253 vname = "node_label"
254 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%node_label, ierr )
255 if( ierr /= 0 ) return
256
257 vname = "node_val_item"
258 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%node_val_item, ierr )
259 if( ierr /= 0 ) return
260 endif
261 end subroutine put_node_component
262
263 subroutine put_elem_component( result_data, ierr )
264 type(hecmwst_result_data), intent(in) :: result_data
265 integer(kind=kint), intent(inout) :: ierr
266
267 sname = "hecmwST_result_data"
268
269 vname = "ne_component"
270 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%ne_component, ierr )
271 if( ierr /= 0 ) return
272
273 if( result_data%ne_component /= 0 ) then
274 vname = "ne_dof"
275 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%ne_dof, ierr )
276 if( ierr /= 0 ) return
277
278 vname = "elem_label"
279 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%elem_label, ierr )
280 if( ierr /= 0 ) return
281
282 vname = "elem_val_item"
283 call hecmw_result_copy_f2c_set_if( sname, vname, result_data%elem_val_item, ierr )
284 if( ierr /= 0 ) return
285 endif
286 end subroutine put_elem_component
287
288 !C=============================================================================
289 !C Read result data from file
290 !C=============================================================================
291
292 subroutine hecmw_result_checkfile_by_name(name_ID, i_step, ierr)
293 character(len=HECMW_NAME_LEN), intent(in) :: name_id
294 integer(kind=kint), intent(in) :: i_step
295 integer(kind=kint), intent(out) :: ierr
296
297 call hecmw_result_checkfile_by_name_if(name_id, i_step, ierr)
298 end subroutine hecmw_result_checkfile_by_name
299
300
301 subroutine hecmw_result_read_by_name(hecMESH, name_ID, i_step, result)
302 type(hecmwst_local_mesh), intent(in) :: hecmesh
303 character(len=HECMW_NAME_LEN), intent(in) :: name_id
304 integer(kind=kint), intent(in) :: i_step
305 type(hecmwst_result_data), intent(inout) :: result
306 integer(kind=kint) :: n_node, n_elem, ierr
307
308 call hecmw_result_read_by_name_if(name_id, i_step, n_node, n_elem, ierr)
309 if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
310
311 call hecmw_result_copy_c2f(result, n_node, n_elem, ierr)
312 if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
313
315 if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
316
317 call refine_result(hecmesh, n_node, result, ierr)
318 if(ierr /=0) call hecmw_abort(hecmw_comm_get_comm())
319 end subroutine hecmw_result_read_by_name
320
321
322 subroutine refine_result(hecMESH, n_node, result, ierr)
323 type(hecmwst_local_mesh), intent(in) :: hecmesh
324 integer(kind=kint), intent(in) :: n_node
325 type(hecmwst_result_data), intent(inout) :: result
326 integer(kind=kint), intent(out) :: ierr
327 real(kind=kreal), pointer :: tmp_val(:)
328 integer(kind=kint) :: iref, i, j, k, is, ie, js, je, i0
329 integer(kind=kint) :: jj, j0, nn_comp_tot, nn, n_node_ref
330 ierr = 0
331 if(n_node == hecmesh%n_node) return
332 if(n_node > hecmesh%n_node) then
333 write(*,*) 'ERROR: result needs to be coarsened; not implemented yet'
334 ierr = 1
335 return
336 else
337 !write(0,*) 'DEBUG: result needs to be refined'
338 nn_comp_tot = 0
339 do i = 1, result%nn_component
340 nn_comp_tot = nn_comp_tot + result%nn_dof(i)
341 enddo
342 do iref = 1, hecmesh%n_refine
343 is = hecmesh%refine_origin%index(iref-1)
344 ie = hecmesh%refine_origin%index(iref)
345 n_node_ref = ie - is
346 if(n_node >= n_node_ref) cycle
347 !write(0,*) 'DEBUG: start refining result; step=',iref
348 allocate(tmp_val(n_node_ref * nn_comp_tot))
349 tmp_val = 0.d0
350 do i = 1, n_node_ref
351 js = hecmesh%refine_origin%item_index(is+i-1)
352 je = hecmesh%refine_origin%item_index(is+i)
353 nn = je - js
354 i0 = (i-1)*nn_comp_tot
355 do j = js+1, je
356 jj = hecmesh%refine_origin%item_item(j)
357 j0 = (jj-1)*nn_comp_tot
358 do k = 1, nn_comp_tot
359 tmp_val(i0+k) = tmp_val(i0+k) + result%node_val_item(j0+k) / nn
360 enddo
361 enddo
362 enddo
363 deallocate(result%node_val_item)
364 result%node_val_item => tmp_val
365 !write(0,*) 'DEBUG: end refining result; step=',iref
366 enddo
367 !write(0,*) 'DEBUG: refining result done'
368 endif
369 end subroutine refine_result
370
371
372 subroutine hecmw_result_copy_c2f(result, n_node, n_elem, ierr)
373 integer(kind=kint) :: n_node, n_elem, ierr
374 type(hecmwst_result_data) :: result
375
376 call get_global_component(result, n_node, ierr)
377 if(ierr /= 0) return
378 call get_node_component(result, n_node, ierr)
379 if(ierr /= 0) return
380 call get_elem_component(result, n_elem, ierr)
381 if(ierr /= 0) return
382 end subroutine hecmw_result_copy_c2f
383
384
385 subroutine get_global_component(result, n_global, ierr)
386 integer(kind=kint) :: n_global, ierr
387 type(hecmwst_result_data) :: result
388
389 sname = 'hecmwST_result_data'
390
391 vname = 'ng_component'
392 call hecmw_result_copy_c2f_set_if(sname, vname, result%ng_component, ierr)
393 if(ierr /= 0) return
394
395 if(result%ng_component > 0) then
396 vname = 'ng_dof'
397 allocate(result%ng_dof(result%ng_component))
398 call hecmw_result_copy_c2f_set_if(sname, vname, result%ng_dof, ierr)
399 if(ierr /= 0) return
400
401 vname = 'global_label'
402 allocate(result%global_label(result%ng_component))
403 call hecmw_result_copy_c2f_set_if(sname, vname, result%global_label, ierr)
404 if(ierr /= 0) return
405
406 vname = 'global_val_item'
407 allocate(result%global_val_item(sum(result%ng_dof)*n_global))
408 call hecmw_result_copy_c2f_set_if(sname, vname, result%global_val_item, ierr)
409 if(ierr /= 0) return
410 endif
411 end subroutine get_global_component
412
413
414 subroutine get_node_component(result, n_node, ierr)
415 integer(kind=kint) :: n_node, ierr
416 type(hecmwst_result_data) :: result
417
418 sname = 'hecmwST_result_data'
419
420 vname = 'nn_component'
421 call hecmw_result_copy_c2f_set_if(sname, vname, result%nn_component, ierr)
422 if(ierr /= 0) return
423
424 if(result%nn_component > 0) then
425 vname = 'nn_dof'
426 allocate(result%nn_dof(result%nn_component))
427 call hecmw_result_copy_c2f_set_if(sname, vname, result%nn_dof, ierr)
428 if(ierr /= 0) return
429
430 vname = 'node_label'
431 allocate(result%node_label(result%nn_component))
432 call hecmw_result_copy_c2f_set_if(sname, vname, result%node_label, ierr)
433 if(ierr /= 0) return
434
435 vname = 'node_val_item'
436 allocate(result%node_val_item(sum(result%nn_dof)*n_node))
437 call hecmw_result_copy_c2f_set_if(sname, vname, result%node_val_item, ierr)
438 if(ierr /= 0) return
439 endif
440 end subroutine get_node_component
441
442
443 subroutine get_elem_component(result, n_elem, ierr)
444 integer(kind=kint) :: n_elem, ierr
445 type(hecmwst_result_data) :: result
446
447 sname = 'hecmwST_result_data'
448
449 vname = 'ne_component'
450 call hecmw_result_copy_c2f_set_if(sname, vname, result%ne_component, ierr)
451 if(ierr /= 0) return
452
453 if(result%ne_component > 0) then
454 vname = 'ne_dof'
455 allocate(result%ne_dof(result%ne_component))
456 call hecmw_result_copy_c2f_set_if(sname, vname, result%ne_dof, ierr)
457 if(ierr /= 0) return
458
459 vname = 'elem_label'
460 allocate(result%elem_label(result%ne_component))
461 call hecmw_result_copy_c2f_set_if(sname, vname, result%elem_label, ierr)
462 if(ierr /= 0) return
463
464 vname = 'elem_val_item'
465 allocate(result%elem_val_item(sum(result%ne_dof)*n_elem))
466 call hecmw_result_copy_c2f_set_if(sname, vname, result%elem_val_item, ierr)
467 if(ierr /= 0) return
468 endif
469 end subroutine get_elem_component
470
471
472 subroutine hecmw_result_free( result_data )
473 type(hecmwst_result_data), intent(inout) :: result_data
474 integer(kind=kint) :: ierr
475
476 ierr = 0
477
478 if( associated( result_data%ng_dof ) ) then
479 deallocate( result_data%ng_dof, stat=ierr )
480 if( ierr /= 0 ) then
481 print *, "Error: Deallocation error"
483 endif
484 endif
485
486 if( associated( result_data%global_label ) ) then
487 deallocate( result_data%global_label, stat=ierr )
488 if( ierr /= 0 ) then
489 print *, "Error: Deallocation error"
491 endif
492 endif
493
494 if( associated( result_data%global_val_item ) ) then
495 deallocate( result_data%global_val_item, stat=ierr )
496 if( ierr /= 0 ) then
497 print *, "Error: Deallocation error"
499 endif
500 endif
501
502 if( associated( result_data%nn_dof ) ) then
503 deallocate( result_data%nn_dof, stat=ierr )
504 if( ierr /= 0 ) then
505 print *, "Error: Deallocation error"
507 endif
508 endif
509
510 if( associated( result_data%node_label ) ) then
511 deallocate( result_data%node_label, stat=ierr )
512 if( ierr /= 0 ) then
513 print *, "Error: Deallocation error"
515 endif
516 endif
517
518 if( associated( result_data%node_val_item ) ) then
519 deallocate( result_data%node_val_item, stat=ierr )
520 if( ierr /= 0 ) then
521 print *, "Error: Deallocation error"
523 endif
524 endif
525
526 if( associated( result_data%ne_dof ) ) then
527 deallocate( result_data%ne_dof, stat=ierr )
528 if ( ierr /= 0 ) then
529 print *, "Error: Deallocation error"
531 endif
532 endif
533
534 if( associated( result_data%elem_label ) ) then
535 deallocate( result_data%elem_label, stat=ierr )
536 if( ierr /= 0 ) then
537 print *, "Error: Deallocation error"
539 endif
540 endif
541
542 if( associated( result_data%elem_val_item ) ) then
543 deallocate( result_data%elem_val_item, stat=ierr )
544 if( ierr /= 0 ) then
545 print *, "Error: Deallocation error"
547 endif
548 endif
549 end subroutine hecmw_result_free
550
551end module hecmw_result
void hecmw_result_write_by_addfname_if(char *name_ID, char *addfname, int *err, int len1, int len2)
Definition: hecmw_result.c:397
void hecmw_result_init_if(int *n_node, int *n_elem, int *nodeID, int *elemID, int *i_step, char *header, char *comment, int *err, int len)
Definition: hecmw_result.c:247
void hecmw_result_write_by_name_if(char *name_ID, int *err, int len)
Definition: hecmw_result.c:361
void hecmw_result_checkfile_by_name_if(char *name_ID, int *i_step, int *err, int len)
Definition: hecmw_result.c:441
void hecmw_result_finalize_if(int *err)
Definition: hecmw_result.c:287
void hecmw_result_add_if(int *dtype, int *n_dof, char *label, double *ptr, int *err, int len)
Definition: hecmw_result.c:303
void hecmw_result_read_finalize_if(int *err)
void hecmw_result_copy_c2f_set_if(char *struct_name, char *var_name, void *dst, int *err, int len_struct, int len_var)
void hecmw_result_read_by_name_if(char *name_ID, int *i_step, int *n_node, int *n_elem, int *err, int len)
void hecmw_result_write_st_by_name_if(char *name_ID, int *err, int len)
void hecmw_result_copy_f2c_set_if(char *struct_name, char *var_name, void *src, int *err, int slen, int vlen)
void hecmw_result_write_st_init_if(int *err)
void hecmw_result_write_st_finalize_if(int *err)
I/O and Utility.
logical function hecmw_is_etype_patch(etype)
logical function hecmw_is_etype_link(etype)
I/O and Utility.
subroutine, public hecmw_result_init(hecmesh, i_step, header, comment)
subroutine, public hecmw_result_write_by_addfname(name_id, addfname)
subroutine, public hecmw_result_copy_f2c(result_data, ierr)
subroutine, public hecmw_result_add(dtype, n_dof, label, data)
subroutine, public hecmw_result_finalize()
subroutine, public hecmw_result_copy_c2f(result, n_node, n_elem, ierr)
subroutine, public hecmw_result_write_st_by_name(name_id, result_data)
subroutine, public hecmw_result_read_by_name(hecmesh, name_id, i_step, result)
subroutine, public hecmw_result_checkfile_by_name(name_id, i_step, ierr)
subroutine, public hecmw_nullify_result_data(p)
subroutine, public hecmw_result_write_by_name(name_id)
subroutine, public hecmw_result_free(result_data)
I/O and Utility.
Definition: hecmw_util_f.F90:7
integer(kind=kint) function hecmw_comm_get_comm()
integer(kind=4), parameter kreal
subroutine hecmw_abort(comm)