FrontISTR 5.2.0
Large-scale structural analysis program with finit element method
Loading...
Searching...
No Matches
hecmw_dist_copy_f2c_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!-------------------------------------------------------------------------------
11
13 use hecmw_util
14 implicit none
15
16 private
17 character(len=100) :: sname,vname
18
19 public :: hecmw_dist_copy_f2c
20
21contains
22
23 subroutine hecmw_dist_copy_f2c(mesh, ierr)
24 integer(kind=kint) :: ierr
25 type(hecmwst_local_mesh) :: mesh
26
27 call put_flags(mesh, ierr)
28 if(ierr /= 0) return
29
30 call put_etc(mesh, ierr)
31 if(ierr /= 0) return
32
33 call put_node(mesh, ierr)
34 if(ierr /= 0) return
35
36 call put_elem(mesh, ierr)
37 if(ierr /= 0) return
38
39 call put_comm(mesh, ierr)
40 if(ierr /= 0) return
41
42 call put_adapt(mesh, ierr)
43 if(ierr /= 0) return
44
45 call put_refine(mesh, ierr)
46 if(ierr /= 0) return
47
48 call put_sect(mesh%section, ierr)
49 if(ierr /= 0) return
50
51 call put_mat(mesh%material, ierr)
52 if(ierr /= 0) return
53
54 call put_mpc(mesh%mpc, ierr)
55 if(ierr /= 0) return
56
57 call put_amp(mesh%amp, ierr)
58 if(ierr /= 0) return
59
60 call put_ngrp(mesh%node_group, ierr)
61 if(ierr /= 0) return
62
63 call put_egrp(mesh%elem_group, ierr)
64 if(ierr /= 0) return
65
66 call put_sgrp(mesh%surf_group, ierr)
67 if(ierr /= 0) return
68
69 call put_contact_pair(mesh%contact_pair, ierr)
70 if(ierr /= 0) return
71 end subroutine hecmw_dist_copy_f2c
72
73
74 subroutine put_flags(mesh, ierr)
75 integer(kind=kint) :: ierr
76 type(hecmwst_local_mesh) :: mesh
77
78 sname = 'hecmwST_local_mesh'
79
80 vname = 'hecmw_flag_adapt'
81 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_flag_adapt, ierr)
82 if(ierr /= 0) return
83
84 vname = 'hecmw_flag_initcon'
85 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_flag_initcon, ierr)
86 if(ierr /= 0) return
87
88 vname = 'hecmw_flag_parttype'
89 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_flag_parttype, ierr)
90 if(ierr /= 0) return
91
92 vname = 'hecmw_flag_partdepth'
93 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_flag_partdepth, ierr)
94 if(ierr /= 0) return
95
96 vname = 'hecmw_flag_version'
97 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_flag_version, ierr)
98 if(ierr /= 0) return
99
100 vname = 'hecmw_flag_partcontact'
101 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_flag_partcontact, ierr)
102 if(ierr /= 0) return
103 end subroutine put_flags
104
105
106 subroutine put_etc(mesh, ierr)
107 integer(kind=kint) :: ierr
108 type(hecmwst_local_mesh) :: mesh
109
110 sname = 'hecmwST_local_mesh'
111
112 vname = 'gridfile'
113 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%gridfile, ierr)
114 if(ierr /= 0) return
115
116 vname = 'hecmw_n_file'
117 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%hecmw_n_file, ierr)
118 if(ierr /= 0) return
119
120 if(mesh%hecmw_n_file > 0) then
121 vname = 'files'
122 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%files, ierr)
123 if(ierr /= 0) return
124 endif
125
126 vname = 'header'
127 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%header, ierr)
128 if(ierr /= 0) return
129
130 vname = 'zero_temp'
131 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%zero_temp, ierr)
132 if(ierr /= 0) return
133 end subroutine put_etc
134
135
136 subroutine put_node(mesh, ierr)
137 integer(kind=kint) :: ierr
138 type(hecmwst_local_mesh) :: mesh
139
140 sname = 'hecmwST_local_mesh'
141 vname = 'n_node'
142 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_node, ierr)
143 if(ierr /= 0) return
144
145 vname = 'n_node_gross'
146 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_node_gross, ierr)
147 if(ierr /= 0) return
148
149 vname = 'nn_middle'
150 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%nn_middle, ierr)
151 if(ierr /= 0) return
152
153 vname = 'nn_internal'
154 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%nn_internal, ierr)
155 if(ierr /= 0) return
156
157 if((mesh%hecmw_flag_parttype == 0 .OR. mesh%hecmw_flag_parttype == 2) .AND. mesh%nn_internal > 0) then
158 vname = 'node_internal_list'
159 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_internal_list, ierr)
160 if(ierr /= 0) return
161 endif
162
163 if(mesh%n_node_gross > 0) then
164 vname = 'node_ID'
165 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_ID, ierr)
166 if(ierr /= 0) return
167
168 vname = 'global_node_ID'
169 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%global_node_ID, ierr)
170 if(ierr /= 0) return
171
172 vname = 'node'
173 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node, ierr)
174 if(ierr /= 0) return
175 endif
176
177 vname = 'n_dof'
178 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_dof, ierr)
179 if(ierr /= 0) return
180
181 vname = 'n_dof_grp'
182 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_dof_grp, ierr)
183 if(ierr /= 0) return
184
185 vname = 'n_dof_tot'
186 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_dof_tot, ierr)
187 if(ierr /= 0) return
188
189 if(mesh%n_dof_grp > 0) then
190 vname = 'node_dof_index'
191 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_dof_index, ierr)
192 if(ierr /= 0) return
193
194 vname = 'node_dof_item'
195 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_dof_item, ierr)
196 if(ierr /= 0) return
197 endif
198
199 if(mesh%n_node_gross > 0) then
200 vname = 'node_val_index'
201 if(associated(mesh%node_val_index)) then
202 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_val_index, ierr)
203 if(ierr /= 0) return
204 endif
205
206 vname = 'node_val_item'
207 if(associated(mesh%node_val_item)) then
208 if(mesh%node_val_index(mesh%n_node_gross) > 0) then
209 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_val_item, ierr)
210 if(ierr /= 0) return
211 endif
212 endif
213
214 vname = 'node_init_val_index'
215 if(associated(mesh%node_init_val_index)) then
216 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_init_val_index, ierr)
217 if(ierr /= 0) return
218 endif
219
220 vname = 'node_init_val_item'
221 if(associated(mesh%node_init_val_item)) then
222 if(mesh%node_init_val_index(mesh%n_node_gross) > 0) then
223 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_init_val_item, ierr)
224 if(ierr /= 0) return
225 endif
226 endif
227 endif
228 end subroutine put_node
229
230
231 subroutine put_elem(mesh, ierr)
232 integer(kind=kint) :: ierr
233 type(hecmwst_local_mesh) :: mesh
234
235 sname = 'hecmwST_local_mesh'
236
237 vname = 'n_elem'
238 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_elem, ierr)
239 if(ierr /= 0) return
240
241 vname = 'n_elem_gross'
242 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_elem_gross, ierr)
243 if(ierr /= 0) return
244
245 vname = 'ne_internal'
246 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%ne_internal, ierr)
247 if(ierr /= 0) return
248
249 if((mesh%hecmw_flag_parttype == 0 .OR. mesh%hecmw_flag_parttype == 1) .AND. mesh%ne_internal > 0) then
250 vname = 'elem_internal_list'
251 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_internal_list, ierr)
252 if(ierr /= 0) return
253 endif
254
255 if(mesh%n_elem_gross > 0) then
256 vname = 'elem_ID'
257 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_ID, ierr)
258 if(ierr /= 0) return
259
260 vname = 'global_elem_ID'
261 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%global_elem_ID, ierr)
262 if(ierr /= 0) return
263
264 vname = 'elem_type'
265 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_type, ierr)
266 if(ierr /= 0) return
267 endif
268
269 vname = 'n_elem_type'
270 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_elem_type, ierr)
271 if(ierr /= 0) return
272
273 if(mesh%n_elem_type > 0) then
274 vname = 'elem_type_index'
275 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_type_index, ierr)
276 if(ierr /= 0) return
277
278 vname = 'elem_type_item'
279 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_type_item, ierr)
280 if(ierr /= 0) return
281 endif
282
283 if(mesh%n_elem_gross > 0) then
284 vname = 'elem_node_index'
285 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_node_index, ierr)
286 if(ierr /= 0) return
287
288 vname = 'elem_node_item'
289 if(mesh%elem_node_index(mesh%n_elem_gross) > 0) then
290 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_node_item, ierr)
291 if(ierr /= 0) return
292 endif
293
294 vname = 'section_ID'
295 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%section_ID, ierr)
296 if(ierr /= 0) return
297 endif
298
299 if(mesh%n_elem_gross > 0) then
300 vname = 'elem_mat_ID_index'
301 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_mat_ID_index, ierr)
302 if(ierr /= 0) return
303
304 if(mesh%elem_mat_ID_index(mesh%n_elem_gross) > 0) then
305 vname = 'elem_mat_ID_item'
306 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_mat_ID_item, ierr)
307 if(ierr /= 0) return
308 endif
309 endif
310
311 vname = 'n_elem_mat_ID'
312 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_elem_mat_ID, ierr)
313 if(ierr /= 0) return
314
315 if(mesh%n_elem_gross > 0) then
316 vname = 'elem_mat_int_index'
317 if(associated(mesh%elem_mat_int_index)) then
318 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_mat_int_index, ierr)
319 if(ierr /= 0) return
320 endif
321
322 vname = 'elem_mat_int_val'
323 if(associated(mesh%elem_mat_int_val)) then
324 if(mesh%elem_mat_int_index(mesh%n_elem_gross) > 0) then
325 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_mat_int_val, ierr)
326 if(ierr /= 0) return
327 endif
328 endif
329 endif
330
331 if(mesh%n_elem_gross > 0) then
332 vname = 'elem_val_index'
333 if(associated(mesh%elem_val_index)) then
334 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_val_index, ierr)
335 if(ierr /= 0) return
336 endif
337
338 vname = 'elem_val_item'
339 if(associated(mesh%elem_val_item)) then
340 if(mesh%elem_val_index(mesh%n_elem_gross) > 0) then
341 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_val_item, ierr)
342 if(ierr /= 0) return
343 endif
344 endif
345 endif
346 end subroutine put_elem
347
348
349 subroutine put_comm(mesh, ierr)
350 integer(kind=kint) :: ierr
351 type(hecmwst_local_mesh) :: mesh
352
353
354 sname = 'hecmwST_local_mesh'
355
356 vname = 'zero'
357 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%zero, ierr)
358 if(ierr /= 0) return
359
360 vname = 'HECMW_COMM'
361 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%MPI_COMM, ierr)
362 if(ierr /= 0) return
363
364 vname = 'PETOT'
365 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%PETOT, ierr)
366 if(ierr /= 0) return
367
368 vname = 'PEsmpTOT'
369 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%PEsmpTOT, ierr)
370 if(ierr /= 0) return
371
372 vname = 'my_rank'
373 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%my_rank, ierr)
374 if(ierr /= 0) return
375
376 vname = 'errnof'
377 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%errnof, ierr)
378 if(ierr /= 0) return
379
380 vname = 'n_subdomain'
381 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_subdomain, ierr)
382 if(ierr /= 0) return
383
384 vname = 'n_neighbor_pe'
385 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_neighbor_pe, ierr)
386 if(ierr /= 0) return
387
388 if(mesh%n_neighbor_pe > 0) then
389 vname = 'neighbor_pe'
390 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%neighbor_pe, ierr)
391 if(ierr /= 0) return
392
393 vname = 'import_index'
394 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%import_index, ierr)
395 if(ierr /= 0) return
396
397 if(mesh%import_index(mesh%n_neighbor_pe) > 0) then
398 vname = 'import_item'
399 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%import_item, ierr)
400 if(ierr /= 0) return
401 endif
402
403 vname = 'export_index'
404 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%export_index, ierr)
405 if(ierr /= 0) return
406
407 if(mesh%export_index(mesh%n_neighbor_pe) > 0) then
408 vname = 'export_item'
409 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%export_item, ierr)
410 if(ierr /= 0) return
411 endif
412
413 vname = 'shared_index'
414 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%shared_index, ierr)
415 if(ierr /= 0) return
416
417 if(mesh%shared_index(mesh%n_neighbor_pe) > 0) then
418 vname = 'shared_item'
419 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%shared_item, ierr)
420 if(ierr /= 0) return
421 endif
422 endif
423 end subroutine put_comm
424
425
426 subroutine put_adapt(mesh, ierr)
427 integer(kind=kint) :: ierr
428 type(hecmwst_local_mesh) :: mesh
429
430 if(mesh%hecmw_flag_adapt == 0) return;
431
432 sname = 'hecmwST_local_mesh'
433
434 vname = 'coarse_grid_level'
435 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%coarse_grid_level, ierr)
436 if(ierr /= 0) return
437
438 vname = 'n_adapt'
439 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_adapt, ierr)
440 if(ierr /= 0) return
441
442 if(mesh%n_node_gross > 0) then
443 vname = 'when_i_was_refined_node'
444 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%when_i_was_refined_node, ierr)
445 if(ierr /= 0) return
446 endif
447
448 if(mesh%n_elem_gross > 0) then
449 vname = 'when_i_was_refined_elem'
450 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%when_i_was_refined_elem, ierr)
451 if(ierr /= 0) return
452
453 vname = 'adapt_parent_type'
454 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%adapt_parent_type, ierr)
455 if(ierr /= 0) return
456
457 vname = 'adapt_type'
458 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%adapt_type, ierr)
459 if(ierr /= 0) return
460
461 vname = 'adapt_level'
462 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%adapt_level, ierr)
463 if(ierr /= 0) return
464
465 vname = 'adapt_parent'
466 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%adapt_parent, ierr)
467 if(ierr /= 0) return
468
469 vname = 'adapt_children_index'
470 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%adapt_children_index, ierr)
471 if(ierr /= 0) return
472
473 vname = 'adapt_children_item'
474 if(mesh%adapt_children_index(mesh%n_elem_gross) > 0) then
475 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%adapt_children_item, ierr)
476 if(ierr /= 0) return
477 endif
478 endif
479 end subroutine put_adapt
480
481
482 subroutine put_refine(mesh, ierr)
483 integer(kind=kint) :: ierr
484 type(hecmwst_local_mesh) :: mesh
485
486 sname = 'hecmwST_local_mesh'
487
488 vname = 'n_refine'
489 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_refine, ierr)
490 if(ierr /= 0) return
491
492 if(mesh%n_refine == 0) return;
493
494 if(mesh%n_node_gross > 0) then
495 vname = 'node_old2new'
496 if(associated(mesh%node_old2new)) then
497 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_old2new, ierr)
498 if(ierr /= 0) return
499 endif
500
501 vname = 'node_new2old'
502 if(associated(mesh%node_new2old)) then
503 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%node_new2old, ierr)
504 if(ierr /= 0) return
505 endif
506 endif
507
508 if(mesh%n_elem_gross > 0) then
509 vname = 'elem_old2new'
510 if(associated(mesh%elem_old2new)) then
511 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_old2new, ierr)
512 if(ierr /= 0) return
513 endif
514
515 vname = 'elem_new2old'
516 if(associated(mesh%elem_new2old)) then
517 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%elem_new2old, ierr)
518 if(ierr /= 0) return
519 endif
520 endif
521
522 if(mesh%n_refine > 0) then
523 vname = 'n_node_refine_hist'
524 if(associated(mesh%n_node_refine_hist)) then
525 call hecmw_dist_copy_f2c_set_if(sname, vname, mesh%n_node_refine_hist, ierr)
526 if(ierr /= 0) return
527 endif
528 endif
529 end subroutine put_refine
530
531
532 subroutine put_sect(sect, ierr)
533 integer(kind=kint) :: ierr
534 type(hecmwst_section) :: sect
535
536 sname = 'hecmwST_section'
537
538 vname = 'n_sect'
539 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%n_sect, ierr)
540 if(ierr /= 0) return
541
542 if(sect%n_sect > 0) then
543 vname = 'sect_type'
544 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_type, ierr)
545 if(ierr /= 0) return
546
547 vname = 'sect_opt'
548 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_opt, ierr)
549 if(ierr /= 0) return
550
551 vname = 'sect_mat_ID_index'
552 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_mat_ID_index, ierr)
553 if(ierr /= 0) return
554
555 if(sect%sect_mat_ID_index(sect%n_sect) > 0) then
556 vname = 'sect_mat_ID_item'
557 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_mat_ID_item, ierr)
558 if(ierr /= 0) return
559 endif
560
561 vname = 'sect_I_index'
562 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_I_index, ierr)
563 if(ierr /= 0) return
564
565 if(sect%sect_I_index(sect%n_sect) > 0) then
566 vname = 'sect_I_item'
567 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_I_item, ierr)
568 if(ierr /= 0) return
569 endif
570
571 vname = 'sect_R_index'
572 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_R_index, ierr)
573 if(ierr /= 0) return
574
575 if(sect%sect_R_index(sect%n_sect) > 0) then
576 vname = 'sect_R_item'
577 call hecmw_dist_copy_f2c_set_if(sname, vname, sect%sect_R_item, ierr)
578 if(ierr /= 0) return
579 endif
580 endif
581 end subroutine put_sect
582
583
584 subroutine put_mat(mat, ierr)
585 integer(kind=kint) :: ierr
586 type(hecmwst_material),target :: mat
587 character(len=HECMW_NAME_LEN),pointer :: name_p
588
589 sname = 'hecmwST_material'
590
591 vname = 'n_mat'
592 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%n_mat, ierr)
593 if(ierr /= 0) return
594
595 vname = 'n_mat_item'
596 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%n_mat_item, ierr)
597 if(ierr /= 0) return
598
599 vname = 'n_mat_subitem'
600 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%n_mat_subitem, ierr)
601 if(ierr /= 0) return
602
603 vname = 'n_mat_table'
604 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%n_mat_table, ierr)
605 if(ierr /= 0) return
606
607 if(mat%n_mat > 0) then
608 vname = 'mat_name'
609 name_p => mat%mat_name(1)
610 call hecmw_dist_copy_f2c_set_if(sname, vname, name_p, ierr)
611 if(ierr /= 0) return
612 endif
613
614 if(mat%n_mat > 0) then
615 vname = 'mat_item_index'
616 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%mat_item_index, ierr)
617 if(ierr /= 0) return
618 endif
619
620 if(mat%n_mat_item > 0) then
621 vname = 'mat_subitem_index'
622 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%mat_subitem_index, ierr)
623 if(ierr /= 0) return
624 endif
625
626 if(mat%n_mat_subitem > 0) then
627 vname = 'mat_table_index'
628 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%mat_table_index, ierr)
629 if(ierr /= 0) return
630 endif
631
632 if(mat%n_mat_table > 0) then
633 vname = 'mat_val'
634 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%mat_val, ierr)
635 if(ierr /= 0) return
636
637 vname = 'mat_temp'
638 call hecmw_dist_copy_f2c_set_if(sname, vname, mat%mat_temp, ierr)
639 if(ierr /= 0) return
640 endif
641 end subroutine put_mat
642
643
644 subroutine put_mpc(mpc, ierr)
645 integer(kind=kint) :: ierr
646 type(hecmwst_mpc) :: mpc
647
648 sname = 'hecmwST_mpc'
649
650 vname = 'n_mpc'
651 call hecmw_dist_copy_f2c_set_if(sname, vname, mpc%n_mpc, ierr)
652 if(ierr /= 0) return
653
654 if(mpc%n_mpc > 0) then
655 vname = 'mpc_index'
656 call hecmw_dist_copy_f2c_set_if(sname, vname, mpc%mpc_index, ierr)
657 if(ierr /= 0) return
658
659 if(mpc%mpc_index(mpc%n_mpc) > 0) then
660 vname = 'mpc_item'
661 call hecmw_dist_copy_f2c_set_if(sname, vname, mpc%mpc_item, ierr)
662 if(ierr /= 0) return
663
664 vname = 'mpc_dof'
665 call hecmw_dist_copy_f2c_set_if(sname, vname, mpc%mpc_dof, ierr)
666 if(ierr /= 0) return
667
668 vname = 'mpc_val'
669 call hecmw_dist_copy_f2c_set_if(sname, vname, mpc%mpc_val, ierr)
670 if(ierr /= 0) return
671
672 vname = 'mpc_const'
673 call hecmw_dist_copy_f2c_set_if(sname, vname, mpc%mpc_const, ierr)
674 if(ierr /= 0) return
675 endif
676 endif
677 end subroutine put_mpc
678
679
680 subroutine put_amp(amp, ierr)
681 integer(kind=kint) :: ierr
682 type(hecmwst_amplitude) :: amp
683 character(len=HECMW_NAME_LEN),pointer :: name_p
684
685 sname = 'hecmwST_amplitude'
686
687 vname = 'n_amp'
688 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%n_amp, ierr)
689 if(ierr /= 0) return
690
691 if(amp%n_amp > 0) then
692 vname = 'amp_name'
693 name_p => amp%amp_name(1)
694 call hecmw_dist_copy_f2c_set_if(sname, vname, name_p, ierr)
695 if(ierr /= 0) return
696
697 vname = 'amp_type_definition'
698 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%amp_type_definition, ierr)
699 if(ierr /= 0) return
700
701 vname = 'amp_type_time'
702 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%amp_type_time, ierr)
703 if(ierr /= 0) return
704
705 vname = 'amp_type_value'
706 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%amp_type_value, ierr)
707 if(ierr /= 0) return
708
709 vname = 'amp_index'
710 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%amp_index, ierr)
711 if(ierr /= 0) return
712
713 if(amp%amp_index(amp%n_amp) > 0) then
714 vname = 'amp_val'
715 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%amp_val, ierr)
716 if(ierr /= 0) return
717
718 vname = 'amp_table'
719 call hecmw_dist_copy_f2c_set_if(sname, vname, amp%amp_table, ierr)
720 if(ierr /= 0) return
721 endif
722 endif
723 end subroutine put_amp
724
725
726 subroutine put_ngrp(grp, ierr)
727 integer(kind=kint) :: ierr
728 type(hecmwst_node_grp) :: grp
729 character(len=HECMW_NAME_LEN),pointer :: name_p
730
731 sname = 'hecmwST_node_grp'
732
733 vname = 'n_grp'
734 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%n_grp, ierr)
735 if(ierr /= 0) return
736
737 if(grp%n_grp > 0) then
738 vname = 'grp_name'
739 name_p => grp%grp_name(1)
740 call hecmw_dist_copy_f2c_set_if(sname, vname, name_p, ierr)
741 if(ierr /= 0) return
742
743 vname = 'grp_index'
744 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%grp_index, ierr)
745 if(ierr /= 0) return
746
747 vname = 'grp_item'
748 if(grp%grp_index(grp%n_grp) > 0) then
749 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%grp_item, ierr)
750 if(ierr /= 0) return
751 endif
752 endif
753
754 vname = 'n_bc'
755 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%n_bc, ierr)
756 if(ierr /= 0) return
757
758 if(grp%n_bc > 0) then
759 vname = 'bc_grp_ID'
760 if(associated(grp%bc_grp_ID)) then
761 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_ID, ierr)
762 if(ierr /= 0) return
763 endif
764
765 vname = 'bc_grp_type'
766 if(associated(grp%bc_grp_type)) then
767 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_type, ierr)
768 if(ierr /= 0) return
769 endif
770
771 vname = 'bc_grp_index'
772 if(associated(grp%bc_grp_index)) then
773 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_index, ierr)
774 if(ierr /= 0) return
775 endif
776
777 vname = 'bc_grp_dof'
778 if(associated(grp%bc_grp_dof)) then
779 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_dof, ierr)
780 if(ierr /= 0) return
781 endif
782
783 vname = 'bc_grp_val'
784 if(associated(grp%bc_grp_val)) then
785 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_val, ierr)
786 if(ierr /= 0) return
787 endif
788 endif
789 end subroutine put_ngrp
790
791
792 subroutine put_egrp(grp, ierr)
793 integer(kind=kint) :: ierr
794 type(hecmwst_elem_grp) :: grp
795 character(len=HECMW_NAME_LEN),pointer :: name_p
796
797 sname = 'hecmwST_elem_grp'
798
799 vname = 'n_grp'
800 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%n_grp, ierr)
801 if(ierr /= 0) return
802
803 if(grp%n_grp > 0) then
804 vname = 'grp_name'
805 name_p => grp%grp_name(1)
806 call hecmw_dist_copy_f2c_set_if(sname, vname, name_p, ierr)
807 if(ierr /= 0) return
808
809 vname = 'grp_index'
810 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%grp_index, ierr)
811 if(ierr /= 0) return
812
813 vname = 'grp_item'
814 if(grp%grp_index(grp%n_grp) > 0) then
815 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%grp_item, ierr)
816 if(ierr /= 0) return
817 endif
818 endif
819
820 vname = 'n_bc'
821 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%n_bc, ierr)
822 if(ierr /= 0) return
823
824 if(grp%n_bc > 0) then
825 vname = 'bc_grp_ID'
826 if(associated(grp%bc_grp_ID)) then
827 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_ID, ierr)
828 if(ierr /= 0) return
829 endif
830
831 vname = 'bc_grp_type'
832 if(associated(grp%bc_grp_type)) then
833 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_type, ierr)
834 if(ierr /= 0) return
835 endif
836
837 vname = 'bc_grp_index'
838 if(associated(grp%bc_grp_index)) then
839 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_index, ierr)
840 if(ierr /= 0) return
841 endif
842
843 vname = 'bc_grp_val'
844 if(associated(grp%bc_grp_val)) then
845 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_val, ierr)
846 if(ierr /= 0) return
847 endif
848 endif
849 end subroutine put_egrp
850
851
852 subroutine put_sgrp(grp, ierr)
853 integer(kind=kint) :: ierr
854 type(hecmwst_surf_grp) :: grp
855 character(len=HECMW_NAME_LEN),pointer :: name_p
856
857 sname = 'hecmwST_surf_grp'
858
859 vname = 'n_grp'
860 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%n_grp, ierr)
861 if(ierr /= 0) return
862
863 if(grp%n_grp > 0) then
864 vname = 'grp_name'
865 name_p => grp%grp_name(1)
866 call hecmw_dist_copy_f2c_set_if(sname, vname, name_p, ierr)
867 if(ierr /= 0) return
868
869 vname = 'grp_index'
870 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%grp_index, ierr)
871 if(ierr /= 0) return
872
873 vname = 'grp_item'
874 if(grp%grp_index(grp%n_grp) > 0) then
875 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%grp_item, ierr)
876 if(ierr /= 0) return
877 endif
878 endif
879
880 vname = 'n_bc'
881 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%n_bc, ierr)
882 if(ierr /= 0) return
883
884 if(grp%n_bc > 0) then
885 vname = 'bc_grp_ID'
886 if(associated(grp%bc_grp_ID)) then
887 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_ID, ierr)
888 if(ierr /= 0) return
889 endif
890
891 vname = 'bc_grp_type'
892 if(associated(grp%bc_grp_type)) then
893 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_type, ierr)
894 if(ierr /= 0) return
895 endif
896
897 vname = 'bc_grp_index'
898 if(associated(grp%bc_grp_index)) then
899 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_index, ierr)
900 if(ierr /= 0) return
901 endif
902
903 vname = 'bc_grp_val'
904 if(associated(grp%bc_grp_val)) then
905 call hecmw_dist_copy_f2c_set_if(sname, vname, grp%bc_grp_val, ierr)
906 if(ierr /= 0) return
907 endif
908 endif
909 end subroutine put_sgrp
910
911
912 subroutine put_contact_pair(cpair, ierr)
913 integer(kind=kint) :: ierr
914 type(hecmwst_contact_pair) :: cpair
915 character(len=HECMW_NAME_LEN),pointer :: name_p
916
917 sname = 'hecmwST_contact_pair'
918
919 vname = 'n_pair'
920 call hecmw_dist_copy_f2c_set_if(sname, vname, cpair%n_pair, ierr)
921 if(ierr /= 0) return
922
923 if(cpair%n_pair > 0) then
924 vname = 'name'
925 name_p => cpair%name(1)
926 call hecmw_dist_copy_f2c_set_if(sname, vname, name_p, ierr)
927 if(ierr /= 0) return
928
929 vname = 'type'
930 call hecmw_dist_copy_f2c_set_if(sname, vname, cpair%type, ierr)
931 if(ierr /= 0) return
932
933 vname = 'slave_grp_id'
934 call hecmw_dist_copy_f2c_set_if(sname, vname, cpair%slave_grp_id, ierr)
935 if(ierr /= 0) return
936
937 vname = 'slave_orisgrp_id'
938 call hecmw_dist_copy_f2c_set_if(sname, vname, cpair%slave_orisgrp_id, ierr)
939 if(ierr /= 0) return
940
941 vname = 'master_grp_id'
942 call hecmw_dist_copy_f2c_set_if(sname, vname, cpair%master_grp_id, ierr)
943 if(ierr /= 0) return
944 endif
945 end subroutine put_contact_pair
946
947end module hecmw_dist_copy_f2c_f
948
void hecmw_dist_copy_f2c_set_if(char *struct_name, char *var_name, void *src, int *err, int slen, int vlen)
I/O and Utility memo) Intel 9 compiler generates codes to wast stack memory when an array of string i...
subroutine, public hecmw_dist_copy_f2c(mesh, ierr)
I/O and Utility.
Definition: hecmw_util_f.F90:7