FrontISTR  5.2.0
Large-scale structural analysis program with finit element method
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
9  use hecmw_etype
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 
53 contains
54 
55  !C=============================================================================
56  !C nullify pointer
57  !C=============================================================================
58 
59  subroutine hecmw_nullify_result_data( P )
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 
551 end 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_checkfile_by_name(name_ID, i_step, ierr)
subroutine, public hecmw_result_write_by_addfname(name_ID, addfname)
subroutine, public hecmw_result_read_by_name(hecMESH, name_ID, i_step, result)
subroutine, public hecmw_result_copy_f2c(result_data, ierr)
subroutine, public hecmw_nullify_result_data(P)
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_init(hecMESH, i_step, header, comment)
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)