25 private :: put_node_component
26 private :: put_elem_component
27 private :: refine_result
28 private :: get_node_component
29 private :: get_elem_component
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(:)
47 character(len=HECMW_NAME_LEN) :: sname,vname
49 integer(kind=kint) :: nelem_wo_mpc = 0
50 integer(kind=kint),
allocatable :: eid_wo_mpc(:)
51 integer(kind=kint),
allocatable :: elemid_wo_mpc(:)
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 )
78 integer(kind=kint) :: nnode, nelem, i_step, ierr
79 character(len=HECMW_HEADER_LEN) :: header
80 character(len=HECMW_MSG_LEN) :: comment
82 integer(kind=kint) :: itype, is, ie, ic_type, icel
85 do itype= 1, hecmesh%n_elem_type
86 ic_type = hecmesh%elem_type_item(itype)
91 nnode = hecmesh%n_node
92 nelem = hecmesh%n_elem
96 if( nelem_wo_mpc == 0 )
then
97 allocate(eid_wo_mpc(nelem))
98 allocate(elemid_wo_mpc(nelem))
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)
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
119 call hecmw_result_init_if(nnode, nelem_wo_mpc, hecmesh%global_node_ID, elemid_wo_mpc, i_step, header, comment, ierr)
121 call hecmw_result_init_if(nnode, nelem, hecmesh%global_node_ID, hecmesh%global_elem_ID, i_step, header, comment, ierr)
129 integer(kind=kint) :: dtype, n_dof, ierr
130 character(len=HECMW_NAME_LEN) :: label
131 real(kind=
kreal) ::
data(:)
133 integer(kind=kint) :: i, icel
134 real(kind=
kreal),
pointer :: data_wo_mpc(:)
136 if( dtype == 2 .and. mpc_exist )
then
138 allocate(data_wo_mpc(n_dof*nelem_wo_mpc))
139 data_wo_mpc(:) = 0.d0
141 do i= 1, nelem_wo_mpc
143 data_wo_mpc(n_dof*(i-1)+1:n_dof*i) =
data(n_dof*(icel-1)+1:n_dof*icel)
148 deallocate(data_wo_mpc)
159 integer(kind=kint) :: ierr
160 character(len=HECMW_NAME_LEN) :: name_id
168 integer(kind=kint) :: ierr
176 integer(kind=kint) :: ierr
178 character(len=HECMW_NAME_LEN):: name_id
192 integer(kind=kint) :: ierr
193 character(len=HECMW_NAME_LEN) :: name_id, addfname
202 integer(kind=kint),
intent(inout) :: ierr
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
213 subroutine put_global_component( result_data, ierr )
215 integer(kind=kint),
intent(inout) :: ierr
217 sname =
"hecmwST_result_data"
219 vname =
"ng_component"
221 if( ierr /= 0 )
return
223 if( result_data%ng_component /= 0 )
then
226 if( ierr /= 0 )
return
228 vname =
"global_label"
230 if( ierr /= 0 )
return
232 vname =
"global_val_item"
234 if( ierr /= 0 )
return
236 end subroutine put_global_component
238 subroutine put_node_component( result_data, ierr )
240 integer(kind=kint),
intent(inout) :: ierr
242 sname =
"hecmwST_result_data"
244 vname =
"nn_component"
246 if( ierr /= 0 )
return
248 if( result_data%nn_component /= 0 )
then
251 if( ierr /= 0 )
return
255 if( ierr /= 0 )
return
257 vname =
"node_val_item"
259 if( ierr /= 0 )
return
261 end subroutine put_node_component
263 subroutine put_elem_component( result_data, ierr )
265 integer(kind=kint),
intent(inout) :: ierr
267 sname =
"hecmwST_result_data"
269 vname =
"ne_component"
271 if( ierr /= 0 )
return
273 if( result_data%ne_component /= 0 )
then
276 if( ierr /= 0 )
return
280 if( ierr /= 0 )
return
282 vname =
"elem_val_item"
284 if( ierr /= 0 )
return
286 end subroutine put_elem_component
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
303 character(len=HECMW_NAME_LEN),
intent(in) :: name_id
304 integer(kind=kint),
intent(in) :: i_step
306 integer(kind=kint) :: n_node, n_elem, ierr
317 call refine_result(hecmesh, n_node, result, ierr)
322 subroutine refine_result(hecMESH, n_node, result, ierr)
324 integer(kind=kint),
intent(in) :: n_node
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
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'
339 do i = 1, result%nn_component
340 nn_comp_tot = nn_comp_tot + result%nn_dof(i)
342 do iref = 1, hecmesh%n_refine
343 is = hecmesh%refine_origin%index(iref-1)
344 ie = hecmesh%refine_origin%index(iref)
346 if(n_node >= n_node_ref) cycle
348 allocate(tmp_val(n_node_ref * nn_comp_tot))
351 js = hecmesh%refine_origin%item_index(is+i-1)
352 je = hecmesh%refine_origin%item_index(is+i)
354 i0 = (i-1)*nn_comp_tot
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
363 deallocate(result%node_val_item)
364 result%node_val_item => tmp_val
369 end subroutine refine_result
373 integer(kind=kint) :: n_node, n_elem, ierr
376 call get_global_component(result, n_node, ierr)
378 call get_node_component(result, n_node, ierr)
380 call get_elem_component(result, n_elem, ierr)
385 subroutine get_global_component(result, n_global, ierr)
386 integer(kind=kint) :: n_global, ierr
389 sname =
'hecmwST_result_data'
391 vname =
'ng_component'
395 if(result%ng_component > 0)
then
397 allocate(result%ng_dof(result%ng_component))
401 vname =
'global_label'
402 allocate(result%global_label(result%ng_component))
406 vname =
'global_val_item'
407 allocate(result%global_val_item(sum(result%ng_dof)*n_global))
411 end subroutine get_global_component
414 subroutine get_node_component(result, n_node, ierr)
415 integer(kind=kint) :: n_node, ierr
418 sname =
'hecmwST_result_data'
420 vname =
'nn_component'
424 if(result%nn_component > 0)
then
426 allocate(result%nn_dof(result%nn_component))
431 allocate(result%node_label(result%nn_component))
435 vname =
'node_val_item'
436 allocate(result%node_val_item(sum(result%nn_dof)*n_node))
440 end subroutine get_node_component
443 subroutine get_elem_component(result, n_elem, ierr)
444 integer(kind=kint) :: n_elem, ierr
447 sname =
'hecmwST_result_data'
449 vname =
'ne_component'
453 if(result%ne_component > 0)
then
455 allocate(result%ne_dof(result%ne_component))
460 allocate(result%elem_label(result%ne_component))
464 vname =
'elem_val_item'
465 allocate(result%elem_val_item(sum(result%ne_dof)*n_elem))
469 end subroutine get_elem_component
474 integer(kind=kint) :: ierr
478 if(
associated( result_data%ng_dof ) )
then
479 deallocate( result_data%ng_dof, stat=ierr )
481 print *,
"Error: Deallocation error"
486 if(
associated( result_data%global_label ) )
then
487 deallocate( result_data%global_label, stat=ierr )
489 print *,
"Error: Deallocation error"
494 if(
associated( result_data%global_val_item ) )
then
495 deallocate( result_data%global_val_item, stat=ierr )
497 print *,
"Error: Deallocation error"
502 if(
associated( result_data%nn_dof ) )
then
503 deallocate( result_data%nn_dof, stat=ierr )
505 print *,
"Error: Deallocation error"
510 if(
associated( result_data%node_label ) )
then
511 deallocate( result_data%node_label, stat=ierr )
513 print *,
"Error: Deallocation error"
518 if(
associated( result_data%node_val_item ) )
then
519 deallocate( result_data%node_val_item, stat=ierr )
521 print *,
"Error: Deallocation error"
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"
534 if(
associated( result_data%elem_label ) )
then
535 deallocate( result_data%elem_label, stat=ierr )
537 print *,
"Error: Deallocation error"
542 if(
associated( result_data%elem_val_item ) )
then
543 deallocate( result_data%elem_val_item, stat=ierr )
545 print *,
"Error: Deallocation error"
void hecmw_result_write_by_addfname_if(char *name_ID, char *addfname, int *err, int len1, int len2)
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)
void hecmw_result_write_by_name_if(char *name_ID, int *err, int len)
void hecmw_result_checkfile_by_name_if(char *name_ID, int *i_step, int *err, int len)
void hecmw_result_finalize_if(int *err)
void hecmw_result_add_if(int *dtype, int *n_dof, char *label, double *ptr, int *err, int len)
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)
logical function hecmw_is_etype_patch(etype)
logical function hecmw_is_etype_link(etype)
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)
integer(kind=kint) function hecmw_comm_get_comm()
integer(kind=4), parameter kreal
subroutine hecmw_abort(comm)