FrontISTR 5.2.0
Large-scale structural analysis program with finit element method
Loading...
Searching...
No Matches
fstr_setup_util.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 m_fstr
9 use hecmw
10 include 'fstr_ctrl_util_f.inc'
11
14 character(len=HECMW_NAME_LEN), pointer :: s(:)
15 end type fstr_str_arr
16
18 integer(kind=kint),private :: grp_type ! 1:node_grp, 2:elem_grp, 3:surf_grp
19 integer(kind=kint),pointer,private :: n_grp
20 integer(kind=kint),pointer,private :: grp_index(:)
21 integer(kind=kint),pointer,private :: grp_item(:)
22 type(fstr_str_arr),private :: grp_name
23 ! character(len=HECMW_NAME_LEN),pointer,private :: grp_name(:)
24
25 ! private subroutines ------------
26 private :: set_group_pointers
27 private :: append_single_group
28
29contains
30 !------------------------------------------------------------------------------
31
32 function fstr_str2index( s, x )
33 implicit none
34 logical fstr_str2index
35 character(*) :: s
36 integer :: i, n, a, i0,i9, m, x, b
37 logical :: fg
38
39 fstr_str2index = .false.
40 i0 = iachar('0')
41 i9 = iachar('9')
42 n = len_trim(s)
43 x = 0
44 b = 1
45 fg = .true.
46 do i=n,1,-1
47 fg = .false.
48 a = iachar(s(i:i))
49 if( a < i0 .or. a > i9 ) return
50 m = a-i0
51 x = x + b * m
52 b = b*10
53 end do
54 fstr_str2index = .true.
55 end function fstr_str2index
56
57 subroutine fstr_strupr( s )
58 implicit none
59 character(*) :: s
60 integer :: i, n, a
61
62 n = len_trim(s)
63 do i = 1, n
64 a = iachar(s(i:i))
65 if( a >= iachar('a') .and. a <= iachar('z')) then
66 s(i:i) = achar(a - 32)
67 end if
68 end do
69 end subroutine fstr_strupr
70
71 function fstr_streqr( s1, s2 )
72 implicit none
73 character(*) :: s1, s2
74 logical :: fstr_streqr
75 integer :: i, n, a1, a2
76
77 fstr_streqr = .false.
78 n = len_trim(s1)
79 if( n /= len_trim(s2)) return
80 call fstr_strupr(s1)
81 call fstr_strupr(s2)
82 do i = 1, n
83 a1 = iachar(s1(i:i))
84 a2 = iachar(s2(i:i))
85 if( a1 /= a2 ) then
86 return
87 end if
88 end do
89 fstr_streqr = .true.
90 end function fstr_streqr
91
92 !------------------------------------------------------------------------------
93
95 implicit none
96 character(len=256) :: msg
97
98 call fstr_ctrl_get_err_msg( msg, 256 )
99 write(*,*) msg
100 write(imsg,*) msg
101 call hecmw_abort( hecmw_comm_get_comm())
102 end subroutine fstr_ctrl_err_stop
103
104 !------------------------------------------------------------------------------
105
106 subroutine fstr_setup_util_err_stop( msg )
107 implicit none
108 character(*) :: msg
109
110 write(*,*) msg
111 write(imsg,*) msg
112 call hecmw_abort( hecmw_comm_get_comm())
113 end subroutine fstr_setup_util_err_stop
114
115 !------------------------------------------------------------------------------
116
117 ! grp_type_name : 'node_grp', 'elem_grp' or 'surf_grp'
118
119 subroutine set_group_pointers( hecMESH, grp_type_name )
120 type (hecmwST_local_mesh),target :: hecMESH
121 character(len=*) :: grp_type_name
122
123 if( grp_type_name == 'node_grp' ) then
124 grp_type = 1
125 n_grp => hecmesh%node_group%n_grp
126 grp_name%s => hecmesh%node_group%grp_name
127 grp_index => hecmesh%node_group%grp_index
128 grp_item => hecmesh%node_group%grp_item
129 else if( grp_type_name == 'elem_grp' ) then
130 grp_type = 2
131 n_grp => hecmesh%elem_group%n_grp
132 grp_name%s => hecmesh%elem_group%grp_name
133 grp_index => hecmesh%elem_group%grp_index
134 grp_item => hecmesh%elem_group%grp_item
135 else if( grp_type_name == 'surf_grp' ) then
136 grp_type = 3
137 n_grp => hecmesh%surf_group%n_grp
138 grp_name%s => hecmesh%surf_group%grp_name
139 grp_index => hecmesh%surf_group%grp_index
140 grp_item => hecmesh%surf_group%grp_item
141 else
142 stop 'assert in set_group_pointers'
143 end if
144 end subroutine set_group_pointers
145
146 subroutine backset_group_pointers( hecMESH, grp_type_name )
147 type (hecmwST_local_mesh),target :: hecMESH
148 character(len=*) :: grp_type_name
149
150 if( grp_type_name == 'node_grp' ) then
151 grp_type = 1
152 hecmesh%node_group%grp_name => grp_name%s
153 hecmesh%node_group%grp_index => grp_index
154 hecmesh%node_group%grp_item => grp_item
155 else if( grp_type_name == 'elem_grp' ) then
156 grp_type = 2
157 hecmesh%elem_group%grp_name => grp_name%s
158 hecmesh%elem_group%grp_index => grp_index
159 hecmesh%elem_group%grp_item => grp_item
160 else if( grp_type_name == 'surf_grp' ) then
161 grp_type = 3
162 hecmesh%surf_group%grp_name => grp_name%s
163 hecmesh%surf_group%grp_index => grp_index
164 hecmesh%surf_group%grp_item => grp_item
165 else
166 stop 'assert in set_group_pointers'
167 end if
168 end subroutine backset_group_pointers
169
170 function node_global_to_local( hecMESH, list, n )
171 implicit none
172 type (hecmwst_local_mesh), target :: hecmesh
173 integer(kind=kint) :: list(:)
174 integer(kind=kint) :: n, i, j, cache
175 logical:: fg
176 integer(kind=kint):: node_global_to_local
177
179 cache = 1
180 aa:do j=1, n
181 fg = .false.
182
183 do i=cache, hecmesh%n_node
184 if( hecmesh%global_node_ID(i) == list(j)) then
185 list(j) = i
186 cache = i+1
187 fg = .true.
189 cycle aa
190 endif
191 enddo
192
193 do i=1, cache
194 if( hecmesh%global_node_ID(i) == list(j)) then
195 list(j) = i
196 cache = i+1
197 fg = .true.
199 cycle aa
200 endif
201 enddo
202
203 if( .not. fg ) then
204 list(j) = -list(j) ! not exist node
205 endif
206 enddo aa
207 end function node_global_to_local
208
209 function elem_global_to_local( hecMESH, list, n )
210 implicit none
211 type (hecmwst_local_mesh), target :: hecmesh
212 integer(kind=kint), pointer :: list(:)
213 integer(kind=kint) :: n, i, j
214 logical :: fg
215 integer(kind=kint) :: elem_global_to_local
216
218 do j=1, n
219 fg = .false.
220 do i=1, hecmesh%n_elem
221 if( hecmesh%global_elem_ID(i) == list(j)) then
222 list(j) = i
223 fg = .true.
225 exit
226 endif
227 end do
228 if( .not. fg ) then
229 list(j) = -list(j)
230 endif
231 end do
232 end function elem_global_to_local
233
234 function append_single_group( hecMESH, grp_type_name, no_count, no_list )
235 implicit none
236 type (hecmwst_local_mesh), target :: hecmesh
237 character(len=*) :: grp_type_name
238 integer(kind=kint) :: no_count
239 integer(kind=kint),pointer :: no_list(:)
240 integer(kind=kint):: append_single_group
241 integer(kind=kint) :: old_grp_number, new_grp_number
242 integer(kind=kint) :: old_item_number, new_item_number
243 integer(kind=kint) :: i,j,k, exist_n
244 integer(kind=kint), save :: grp_count = 1
245 character(50) :: grp_name_s
246
247 exist_n = 0
248 call set_group_pointers( hecmesh, grp_type_name )
249 if( grp_type_name == 'node_grp') then
250 exist_n = node_global_to_local( hecmesh, no_list, no_count )
251 else if( grp_type_name == 'elem_grp') then
252 exist_n = elem_global_to_local( hecmesh, no_list, no_count )
253 endif
254
255 old_grp_number = n_grp
256 new_grp_number = old_grp_number + no_count
257
258 old_item_number = grp_index(n_grp)
259 new_item_number = old_item_number + exist_n
260
261 call fstr_expand_name_array( grp_name, old_grp_number, new_grp_number )
262 call fstr_expand_index_array( grp_index, old_grp_number + 1, new_grp_number+1)
263 call fstr_expand_integer_array( grp_item, old_item_number, new_item_number )
264
265 n_grp = new_grp_number
266
267 j = old_grp_number + 1
268 k = old_item_number + 1
269 do i = 1, no_count
270 write( grp_name_s, '(a,i0,a,i0)') 'FSTR_', grp_count, '_', i
271 grp_name%s(j) = grp_name_s
272 if( no_list(i) >= 0) then
273 grp_item(k) = no_list(i)
274 grp_index(j) = grp_index(j-1)+1
275 k = k + 1
276 else
277 grp_index(j) = grp_index(j-1)
278 endif
279 j = j + 1
280 end do
281 grp_count = grp_count + 1
282 call backset_group_pointers( hecmesh, grp_type_name )
283 append_single_group = exist_n
284 end function append_single_group
285
286 subroutine append_new_group(hecMESH, grp_type_name, name, count, list, grp_id)
287 implicit none
288 type(hecmwst_local_mesh), pointer :: hecMESH
289 character(len=*), intent(in) :: grp_type_name
290 character(len=HECMW_NAME_LEN), intent(in) :: name
291 integer(kind=kint), intent(in) :: count
292 integer(kind=kint), intent(in) :: list(:)
293 integer(kind=kint), intent(out) :: grp_id
294 integer(kind=kint) :: id, old_grp_number, new_grp_number, old_item_number, new_item_number, k
295
296 call set_group_pointers( hecmesh, grp_type_name )
297 do id = 1, n_grp
298 if( fstr_streqr(grp_name%s(id), name) ) then
299 write(*,*) '### Error: Group already exists: ', name
300 stop
301 endif
302 enddo
303
304 old_grp_number = n_grp
305 new_grp_number = old_grp_number + 1
306
307 old_item_number = grp_index(n_grp)
308 new_item_number = old_item_number + count
309
310 call fstr_expand_name_array( grp_name, old_grp_number, new_grp_number )
311 call fstr_expand_index_array( grp_index, old_grp_number + 1, new_grp_number + 1)
312 call fstr_expand_integer_array( grp_item, old_item_number, new_item_number )
313
314 n_grp = new_grp_number
315 grp_id = new_grp_number
316 grp_name%s(grp_id) = name
317 do k = 1, count
318 grp_item(old_item_number + k) = list(k)
319 enddo
320 grp_index(grp_id) = grp_index(grp_id-1) + count
321 call backset_group_pointers( hecmesh, grp_type_name )
322 end subroutine append_new_group
323
324 subroutine append_node_grp_from_surf_grp( hecMESH, sgrp_id, ngrp_id )
325 implicit none
326 type(hecmwst_local_mesh), pointer :: hecMESH
327 integer(kind=kint), intent(in) :: sgrp_id
328 integer(kind=kint), intent(out) :: ngrp_id
329 integer(kind=kint) :: is, ie, nnode, i, ic, isurf, ic_type, stype, nn, j0, j, new_nnode
330 integer(kind=kint) :: snode(20)
331 integer(kind=kint), allocatable :: node(:)
332 character(len=HECMW_NAME_LEN) :: grp_name
333 is= hecmesh%surf_group%grp_index(sgrp_id-1) + 1
334 ie= hecmesh%surf_group%grp_index(sgrp_id )
335 ! count num of nodes on surface incl duplication
336 nnode = 0
337 do i=is,ie
338 ic = hecmesh%surf_group%grp_item(2*i-1)
339 isurf = hecmesh%surf_group%grp_item(2*i)
340 ic_type = hecmesh%elem_type(ic)
341 call getsubface( ic_type, isurf, stype, snode )
342 nnode = nnode + getnumberofnodes( stype )
343 enddo
344 ! extract nodes on surface incl duplication
345 allocate( node(nnode) )
346 nnode = 0
347 do i=is,ie
348 ic = hecmesh%surf_group%grp_item(2*i-1)
349 isurf = hecmesh%surf_group%grp_item(2*i)
350 ic_type = hecmesh%elem_type(ic)
351 call getsubface( ic_type, isurf, stype, snode )
352 nn = getnumberofnodes( stype )
353 j0 = hecmesh%elem_node_index(ic-1)
354 do j=1,nn
355 node(nnode+j) = hecmesh%elem_node_item(j0+snode(j))
356 enddo
357 nnode = nnode + nn
358 enddo
359 ! sort and uniq node list
360 call qsort_int_array(node, 1, nnode)
361 call uniq_int_array(node, nnode, new_nnode)
362 ! append node group
363 write( grp_name, '(a,a)') 'FSTR_S2N_',trim(hecmesh%surf_group%grp_name(sgrp_id))
364 call append_new_group(hecmesh, 'node_grp', grp_name, new_nnode, node, ngrp_id)
365 deallocate(node)
366 end subroutine append_node_grp_from_surf_grp
367
368 subroutine append_intersection_node_grp( hecMESH, ngrp_id1, ngrp_id2 )
369 implicit none
370 type(hecmwst_local_mesh), pointer :: hecMESH
371 integer(kind=kint), intent(in) :: ngrp_id1, ngrp_id2
372 integer(kind=kint) :: nnode1, nnode2, nnode, is, i, nisect, ngrp_id
373 integer(kind=kint), allocatable :: node(:), isect(:)
374 character(len=HECMW_NAME_LEN) :: grp_name
375 nnode1 = hecmesh%node_group%grp_index(ngrp_id1) - hecmesh%node_group%grp_index(ngrp_id1-1)
376 nnode2 = hecmesh%node_group%grp_index(ngrp_id2) - hecmesh%node_group%grp_index(ngrp_id2-1)
377 nnode = nnode1 + nnode2
378 allocate( node(nnode) )
379 is= hecmesh%node_group%grp_index(ngrp_id1-1)
380 do i=1,nnode1
381 node(i) = hecmesh%node_group%grp_item(is+i)
382 enddo
383 is= hecmesh%node_group%grp_index(ngrp_id2-1)
384 do i=1,nnode2
385 node(nnode1+i) = hecmesh%node_group%grp_item(is+i)
386 enddo
387 call qsort_int_array(node, 1, nnode)
388 allocate( isect(nnode) )
389 nisect = 0
390 do i=1,nnode-1
391 if( node(i) == node(i+1) ) then
392 nisect = nisect + 1
393 isect(nisect) = node(i)
394 endif
395 enddo
396 write( grp_name, '(a,a,a,a)') &
397 'FSTR_ISCT_',trim(hecmesh%node_group%grp_name(ngrp_id1)),'_AND_',trim(hecmesh%node_group%grp_name(ngrp_id2))
398 call append_new_group(hecmesh, 'node_grp', grp_name, nisect, isect, ngrp_id)
399 deallocate(node)
400 deallocate(isect)
401 end subroutine append_intersection_node_grp
402
403 !------------------------------------------------------------------------------
404 ! JP-0
405 ! grp_type_name : 'node_grp', 'elem_grp' or 'surf_grp'
406 ! name : group name
407 ! return : number of member in specified group
408
409 function get_grp_member_n( hecMESH, grp_type_name, name )
410 implicit none
411 integer(kind=kint) :: get_grp_member_n
412 type (hecmwst_local_mesh),target :: hecmesh
413 character(len=*) :: grp_type_name
414 character(len=*) :: name
415 integer(kind=kint) :: i
416
417 call set_group_pointers( hecmesh, grp_type_name )
418
419 do i = 1, n_grp
420 if( fstr_streqr(grp_name%s(i),name)) then
421 get_grp_member_n = grp_index(i) - grp_index(i-1)
422 return
423 end if
424 end do
426 return
427 end function get_grp_member_n
428
429 !------------------------------------------------------------------------------
430 ! JP-1
431 ! grp_type_name : 'node_grp', 'elem_grp' or 'surf_grp'
432 ! name : group name
433 ! return : number of member in specified group
434
435 function get_grp_id( hecMESH, grp_type_name, name )
436 implicit none
437 integer(kind=kint) :: get_grp_id
438 type (hecmwst_local_mesh),target :: hecmesh
439 character(len=*) :: grp_type_name
440 character(len=*) :: name
441 integer(kind=kint) :: i
442
443 call set_group_pointers( hecmesh, grp_type_name )
444
445 do i = 1, n_grp
446 if( fstr_streqr(grp_name%s(i), name)) then
447 get_grp_id = i
448 return
449 end if
450 end do
451 get_grp_id = 0
452 return
453 end function get_grp_id
454
455 !------------------------------------------------------------------------------
456 ! JP-2
457 ! grp_type_name : 'node_grp', 'elem_grp' or 'surf_grp'
458 ! name : group name
459 ! member1 : id list for node or element
460 ! member2 : id list for surface ( only 'surf_grp' specified )
461 ! return : number of member in specified group
462
463 function get_grp_member( hecMESH, grp_type_name, name, member1, member2 )
464 implicit none
465 integer(kind=kint) :: get_grp_member
466 type (hecmwst_local_mesh),target :: hecmesh
467 character(len=*) :: grp_type_name
468 character(len=*) :: name
469 integer(kind=kint),pointer :: member1(:)
470 integer(kind=kint),pointer, optional :: member2(:)
471 integer(kind=kint) :: i, j, k, sn, en
472
473 get_grp_member = -1
474 if( grp_type_name == 'surf_grp' .and. (.not. present( member2 ))) then
475 stop 'assert in get_grp_member: not present member2 '
476 end if
477
478 call set_group_pointers( hecmesh, grp_type_name )
479
480 do i = 1, n_grp
481 if( fstr_streqr(grp_name%s(i), name)) then
482 sn = grp_index(i-1) + 1
483 en = grp_index(i)
484 k = 1
485 if( grp_type == 3 ) then ! == surf_grp
486 do j = sn, en
487 member1(k) = grp_item(2*j-1)
488 member2(k) = grp_item(2*j)
489 k = k + 1
490 end do
491 else
492 do j = sn, en
493 member1(k) = grp_item(j)
494 k = k + 1
495 end do
496 end if
497 get_grp_member = en - sn + 1
498 return
499 end if
500 end do
502 return
503 end function get_grp_member
504
505 !------------------------------------------------------------------------------
506 ! JP-3
507 ! JP-4
508 ! type_name : 'node', 'element'
509 ! name : group name
510 ! local_id : local id (set only when return value > 0)
511 ! return : -1 if name is not a number
512 ! 0 if name is a number and a node with ID=name is not in myrank
513 ! >0 if name is a number and a node with ID=name is in myrank
514
515 function get_local_member_index( hecMESH, type_name, name, local_id )
516 implicit none
517 integer(kind=kint) :: get_local_member_index
518 type (hecmwst_local_mesh),target :: hecmesh
519 character(len=*) :: type_name
520 character(len=*) :: name
521 integer(kind=kint) :: local_id
522 integer(kind=kint) :: i, n, no, fg
523 integer(kind=kint),pointer :: global_item(:)
524
525 if( .not. fstr_str2index(name, no) ) then
527 return
528 end if
529
530 if( type_name == 'node' ) then
531 fg = 1
532 n = hecmesh%n_node
533 global_item => hecmesh%global_node_ID
534 else if( type_name == 'element' ) then
535 fg = 2
536 n = hecmesh%n_elem
537 global_item => hecmesh%global_elem_ID
538 else
539 stop 'assert in get_local_member_index: unknown type_name'
540 end if
541
542 do i = 1, n
543 if( no == global_item(i)) then
544 local_id = i
545 get_local_member_index = local_id
546 return
547 end if
548 end do
549 local_id = 0
551 return
552 end function get_local_member_index
553
554 !-----------------------------------------------------------------------------!
555 !
556
557 function get_sorted_local_member_index( hecMESH, hecPARAM, type_name, name, local_id )
558 implicit none
559 integer(kind=kint) :: get_sorted_local_member_index
560 type (hecmwst_local_mesh),target :: hecmesh
561 type(fstr_param), target :: hecparam
562 character(len=*) :: type_name
563 character(len=*) :: name
564 integer(kind=kint) :: local_id, idx
565 integer(kind=kint) :: n, no, fg
566
567 if( .not. fstr_str2index(name, no) ) then
569 return
570 end if
571
572 if( type_name == 'node' ) then
573 fg = 1
574 n = hecmesh%nn_internal
575 ! item => hecMESH%global_node_ID
576 ! else if( type_name == 'element' ) then
577 ! fg = 2
578 ! n = hecMESH%n_elem
579 ! item => hecMESH%global_elem_ID
580 else
581 stop 'assert in get_sorted_local_member_index: unknown type_name'
582 end if
583
584 call bsearch_int_array(hecparam%global_local_ID(1,:), 1, n, no, idx)
585 if(idx > 0)then
586 get_sorted_local_member_index = hecparam%global_local_ID(2,idx)
588 return
589 endif
590
592 return
594 !-----------------------------------------------------------------------------!
595
596 !-----------------------------------------------------------------------------!
597 !~/FrontISTR/hecmw1/src/solver/matrix/hecmw_matrix_reorder.f90
598
599 subroutine bsearch_int_array(array, istart, iend, val, idx)
600 implicit none
601 integer(kind=kint), intent(in) :: array(:)
602 integer(kind=kint), intent(in) :: istart, iend
603 integer(kind=kint), intent(in) :: val
604 integer(kind=kint), intent(out) :: idx
605 integer(kind=kint) :: center, left, right, pivot
606 left = istart
607 right = iend
608 do
609 if (left > right) then
610 idx = -1
611 exit
612 end if
613 center = (left + right) / 2
614 pivot = array(center)
615 if (val < pivot) then
616 right = center - 1
617 cycle
618 else if (pivot < val) then
619 left = center + 1
620 cycle
621 else ! if (pivot == val) then
622 idx = center
623 exit
624 end if
625 end do
626 end subroutine bsearch_int_array
627
628 recursive subroutine qsort_int_array(array, istart, iend)
629 implicit none
630 integer(kind=kint), intent(inout) :: array(:)
631 integer(kind=kint), intent(in) :: istart, iend
632 integer(kind=kint) :: pivot, center, left, right, tmp
633 if (istart >= iend) return
634 center = (istart + iend) / 2
635 pivot = array(center)
636 left = istart
637 right = iend
638 do
639 do while (array(left) < pivot)
640 left = left + 1
641 end do
642 do while (pivot < array(right))
643 right = right - 1
644 end do
645 if (left >= right) exit
646 tmp = array(left)
647 array(left) = array(right)
648 array(right) = tmp
649 left = left + 1
650 right = right - 1
651 end do
652 if (istart < left-1) call qsort_int_array(array, istart, left-1)
653 if (right+1 < iend) call qsort_int_array(array, right+1, iend)
654 return
655 end subroutine qsort_int_array
656
657 subroutine uniq_int_array(array, len, newlen)
658 implicit none
659 integer(kind=kint), intent(inout) :: array(:)
660 integer(kind=kint), intent(in) :: len
661 integer(kind=kint), intent(out) :: newlen
662 integer(kind=kint) :: i, ndup
663 ndup = 0
664 do i=2,len
665 if (array(i) == array(i - 1 - ndup)) then
666 ndup = ndup + 1
667 else if (ndup > 0) then
668 array(i - ndup) = array(i)
669 endif
670 end do
671 newlen = len - ndup
672 end subroutine uniq_int_array
673
674 !-----------------------------------------------------------------------------!
675
676 subroutine node_grp_name_to_id( hecMESH, header_name, n, grp_id_name, grp_ID )
677 implicit none
678 type (hecmwST_local_mesh) :: hecMESH
679 character(len=*) :: header_name
680 character(HECMW_NAME_LEN) :: grp_id_name(:)
681 integer(kind=kint),pointer :: grp_ID(:)
682 integer(kind=kint) :: n
683 integer(kind=kint) :: i, id
684 character(len=256) :: msg
685
686 do i = 1, n
687 grp_id(i) = -1
688 do id = 1, hecmesh%node_group%n_grp
689 if( fstr_streqr(hecmesh%node_group%grp_name(id),grp_id_name(i))) then
690 grp_id(i) = id
691 exit
692 end if
693 end do
694 if( grp_id(i) == -1 ) then
695 write(msg,*) '### Error: ', header_name,' : Node group "',&
696 grp_id_name(i),'" does not exist.'
698 end if
699 end do
700 end subroutine node_grp_name_to_id
701
702 subroutine elem_grp_name_to_id( hecMESH, header_name, n, grp_id_name, grp_ID )
703 implicit none
704 type (hecmwST_local_mesh) :: hecMESH
705 character(len=*) :: header_name
706 character(HECMW_NAME_LEN) :: grp_id_name(:)
707 integer(kind=kint) :: grp_ID(:)
708 integer(kind=kint) :: n
709 integer(kind=kint) :: i, id
710 character(len=256) :: msg
711
712 do i = 1, n
713 grp_id(i) = -1
714 do id = 1, hecmesh%elem_group%n_grp
715 if (fstr_streqr(hecmesh%elem_group%grp_name(id), grp_id_name(i))) then
716 grp_id(i) = id
717 exit
718 end if
719 end do
720 if( grp_id(i) == -1 ) then
721 write(msg,*) '### Error: ', header_name,' : Node group "',&
722 grp_id_name(i),'" does not exist.'
724 end if
725 end do
726 end subroutine elem_grp_name_to_id
727
728 !------------------------------------------------------------------------------
729 ! JP-5
730 ! JP-6
731 !
732
733 subroutine node_grp_name_to_id_ex( hecMESH, header_name, n, grp_id_name, grp_ID )
734 implicit none
735 type (hecmwST_local_mesh),target :: hecMESH
736 character(len=*) :: header_name
737 integer(kind=kint) :: n
738 character(len=HECMW_NAME_LEN) :: grp_id_name(:)
739 integer(kind=kint) :: grp_ID(:)
740
741 integer(kind=kint) :: i, id
742 integer(kind=kint) :: no, no_count, exist_n
743 integer(kind=kint),pointer :: no_list(:)
744 character(HECMW_NAME_LEN) :: name
745 character(len=256) :: msg
746
747 allocate( no_list( n ))
748 no_count = 0
749 do i = 1, n
750 if( fstr_str2index( grp_id_name(i), no )) then
751 no_count = no_count + 1
752 no_list(no_count) = no
753 grp_id(i) = hecmesh%node_group%n_grp + no_count
754 else
755 grp_id(i) = -1
756 do id = 1, hecmesh%node_group%n_grp
757 if (fstr_streqr(hecmesh%node_group%grp_name(id), grp_id_name(i))) then
758 grp_id(i) = id
759 exit
760 end if
761 end do
762 if( grp_id(i) == -1 ) then
763 write(msg,*) '### Error: ', header_name,' : Node group "',grp_id_name(i),'" does not exist.'
765 end if
766 end if
767 end do
768
769 if( no_count > 0 ) then
770 name = 'node_grp'
771 exist_n = append_single_group( hecmesh, name, no_count, no_list )
772 ! if( exist_n < no_count ) then
773 ! write(*,*) '### Warning: ', header_name, ': following nodes are not exist'
774 ! write(imsg,*) '### Warning: ', header_name, ': following nodes are not exist'
775 ! do i=1, no_count
776 ! if( no_list(i)<0 ) then
777 ! write(*,*) -no_list(i)
778 ! write(imsg,*) -no_list(i)
779 ! end if
780 ! end do
781 ! end if
782 end if
783
784 deallocate( no_list )
785 end subroutine node_grp_name_to_id_ex
786
787 !------------------------------------------------------------------------------
788
789 !Find node/surf group from name or nodeid
790
791 subroutine nodesurf_grp_name_to_id_ex(hecMESH, header_name, n, grp_id_name, grp_ID, grp_TYPE)
792 use m_fstr
793 implicit none
794 type (hecmwST_local_mesh),target :: hecMESH
795 character(len=*) :: header_name
796 integer(kind=kint) :: n
797 character(len=HECMW_NAME_LEN) :: grp_id_name(:)
798 integer(kind=kint) :: grp_ID(:)
799 integer(kind=kint) :: grp_TYPE(:)
800
801 integer(kind=kint) :: i, id
802 integer(kind=kint) :: no, no_count, exist_n
803 integer(kind=kint),pointer :: no_list(:)
804 character(HECMW_NAME_LEN) :: name
805 character(len=256) :: msg
806
807 allocate( no_list( n ))
808 no_count = 0
809 do i = 1, n
810 if( fstr_str2index( grp_id_name(i), no )) then
811 no_count = no_count + 1
812 no_list(no_count) = no
813 grp_id(i) = hecmesh%node_group%n_grp + no_count
814 grp_type(i) = kfloadtype_node
815 else
816 !Find node group
817 grp_id(i) = -1
818 do id = 1, hecmesh%node_group%n_grp
819 if (fstr_streqr(hecmesh%node_group%grp_name(id), grp_id_name(i))) then
820 grp_id(i) = id
821 grp_type(i) = kfloadtype_node
822 exit
823 end if
824 end do
825 !Find surf group
826 if (grp_id(i) == -1) then
827 do id = 1, hecmesh%surf_group%n_grp
828 if (fstr_streqr(hecmesh%surf_group%grp_name(id), grp_id_name(i))) then
829 grp_id(i) = id
830 grp_type(i) = kfloadtype_surf
831 exit
832 end if
833 end do
834 end if
835
836 !not fouund => exit
837 if( grp_id(i) == -1 ) then
838 write(msg,*) '### Error: ', header_name,' : Node group "',grp_id_name(i),'" does not exist.'
840 end if
841 end if
842 end do
843 if( no_count > 0 ) then
844 name = 'node_grp'
845 exist_n = append_single_group( hecmesh, name, no_count, no_list )
846 end if
847
848 deallocate( no_list )
849
850 end subroutine nodesurf_grp_name_to_id_ex
851
852 subroutine elem_grp_name_to_id_ex( hecMESH, header_name, n, grp_id_name, grp_ID )
853 implicit none
854 type (hecmwST_local_mesh),target :: hecMESH
855 character(len=*) :: header_name
856 integer(kind=kint) :: n
857 character(HECMW_NAME_LEN) :: grp_id_name(:)
858 integer(kind=kint) :: grp_ID(:)
859 integer(kind=kint) :: i, id
860 integer(kind=kint) :: no, no_count, exist_n
861 integer(kind=kint),pointer :: no_list(:)
862 character(HECMW_NAME_LEN) :: name
863 character(len=256) :: msg
864
865 allocate( no_list( n ))
866 no_count = 0
867 do i = 1, n
868 if( fstr_str2index( grp_id_name(i), no )) then
869 no_count = no_count + 1
870 no_list(no_count) = no
871 grp_id(i) = hecmesh%elem_group%n_grp + no_count
872 else
873 grp_id(i) = -1
874 do id = 1, hecmesh%elem_group%n_grp
875 if (fstr_streqr(hecmesh%elem_group%grp_name(id), grp_id_name(i))) then
876 grp_id(i) = id
877 exit
878 end if
879 end do
880 if( grp_id(i) == -1 ) then
881 write(msg,*) '### Error: ', header_name,' : Element group "',&
882 grp_id_name(i),'" does not exist.'
884 end if
885 end if
886 end do
887
888 if( no_count > 0 ) then
889 name = 'elem_grp'
890 exist_n = append_single_group( hecmesh, name, no_count, no_list )
891 if( exist_n < no_count ) then
892 write(*,*) '### Warning: ', header_name, ': following elements are not exist'
893 write(imsg,*) '### Warning: ', header_name, ': following elements are not exist'
894 do i=1, no_count
895 if( no_list(i)<0 ) then
896 write(*,*) -no_list(i)
897 write(imsg,*) -no_list(i)
898 end if
899 end do
900 end if
901 end if
902
903 deallocate( no_list )
904 end subroutine elem_grp_name_to_id_ex
905
906 !------------------------------------------------------------------------------
907
908 subroutine surf_grp_name_to_id_ex( hecMESH, header_name, n, grp_id_name, grp_ID )
909 implicit none
910 type (hecmwST_local_mesh),target :: hecMESH
911 character(len=*) :: header_name
912 integer(kind=kint) :: n
913 character(len=HECMW_NAME_LEN) :: grp_id_name(:)
914 integer(kind=kint) :: grp_ID(:)
915 integer(kind=kint) :: i, id
916 character(len=256) :: msg
917
918 do i = 1, n
919 grp_id(i) = -1
920 do id = 1, hecmesh%surf_group%n_grp
921 if (fstr_streqr(hecmesh%surf_group%grp_name(id), grp_id_name(i))) then
922 grp_id(i) = id
923 exit
924 end if
925 end do
926 if( grp_id(i) == -1 ) then
927 write(msg,*) '### Error: ', header_name,' : Surface group "',grp_id_name(i),'" does not exist.'
929 end if
930 end do
931 end subroutine surf_grp_name_to_id_ex
932
933 !------------------------------------------------------------------------------
934
935 subroutine dload_grp_name_to_id_ex( hecMESH, n, grp_id_name, fg_surface, grp_ID )
936 implicit none
937 type (hecmwST_local_mesh),target :: hecMESH
938 integer(kind=kint) :: n
939 integer(kind=kint),save :: casha = 1, cashb = 1
940 character(HECMW_NAME_LEN) :: grp_id_name(:)
941 logical :: fg_surface(:)
942 integer(kind=kint) :: grp_ID(:)
943 integer(kind=kint) :: i, id
944 integer(kind=kint) :: no, no_count, exist_n
945 integer(kind=kint),pointer :: no_list(:)
946 character(HECMW_NAME_LEN) :: name
947 character(len=256) :: msg
948
949 allocate( no_list( n ))
950 no_count = 0
951 do i = 1, n
952 if( fg_surface(i) ) then
953 grp_id(i) = -1
954 if(casha < hecmesh%surf_group%n_grp)then
955 if(fstr_streqr(hecmesh%surf_group%grp_name(casha), grp_id_name(i))) then
956 grp_id(i) = casha
957 casha = casha + 1
958 cycle
959 end if
960 endif
961 do id = 1, hecmesh%surf_group%n_grp
962 if(fstr_streqr(hecmesh%surf_group%grp_name(id), grp_id_name(i))) then
963 grp_id(i) = id
964 casha = id + 1
965 exit
966 end if
967 end do
968 if( grp_id(i) == -1 ) then
969 write(msg,*) '### Error: !DLOAD : Surface group "',&
970 grp_id_name(i),'" does not exist.'
972 end if
973 else
974 if( fstr_str2index( grp_id_name(i), no )) then
975 no_count = no_count + 1
976 no_list(no_count) = no
977 grp_id(i) = hecmesh%elem_group%n_grp + no_count
978 else
979 grp_id(i) = -1
980 if(cashb < hecmesh%surf_group%n_grp)then
981 if(fstr_streqr(hecmesh%surf_group%grp_name(cashb), grp_id_name(i))) then
982 grp_id(i) = cashb
983 cashb = cashb + 1
984 cycle
985 end if
986 endif
987 do id = 1, hecmesh%elem_group%n_grp
988 if(fstr_streqr(hecmesh%elem_group%grp_name(id), grp_id_name(i))) then
989 grp_id(i) = id
990 cashb = cashb + 1
991 exit
992 end if
993 end do
994 if( grp_id(i) == -1 ) then
995 write(msg,*) '### Error: !DLOAD : Element group "',&
996 grp_id_name(i),'" does not exist.'
998 end if
999 end if
1000 end if
1001 end do
1002
1003 if( no_count > 0 ) then
1004 name = 'elem_grp'
1005 exist_n = append_single_group( hecmesh, name, no_count, no_list )
1006 ! if( exist_n < no_count ) then
1007 ! write(*,*) '### Warning: !DLOAD : following elements are not exist'
1008 ! if( hecMESH%my_rank == 0 ) then
1009 ! write(imsg,*) '### Warning: !DLOAD : following elements are not exist'
1010 ! end if
1011 ! do i=1, no_count
1012 ! if( no_list(i)<0 ) then
1013 ! write(*,*) -no_list(i)
1014 ! if( hecMESH%my_rank == 0 ) then
1015 ! write(imsg,*) -no_list(i)
1016 ! endif
1017 ! end if
1018 ! end do
1019 ! end if
1020 end if
1021
1022 deallocate( no_list )
1023 end subroutine dload_grp_name_to_id_ex
1024
1025 !------------------------------------------------------------------------------
1026 ! JP-7
1027
1028 subroutine amp_name_to_id( hecMESH, header_name, aname, id )
1029 implicit none
1030 type (hecmwST_local_mesh) :: hecMESH
1031 character(len=*) :: header_name
1032 character(len=HECMW_NAME_LEN)::aname
1033 integer(kind=kint) :: id
1034 character(len=256) :: msg
1035
1036 id = 0
1037 if( aname .eq. ' ' ) return
1038 call get_amp_id( hecmesh, aname, id )
1039 if( id == 0 ) then
1040 write(msg,*) '### Error: ', header_name,' : Amplitude group "',&
1041 aname,'" does not exist.'
1042 call fstr_setup_util_err_stop(msg)
1043 end if
1044 end subroutine amp_name_to_id
1045
1046
1047 !GET AMPLITUDE INDEX
1048
1049 subroutine get_amp_id( hecMESH, aname, id )
1050 implicit none
1051 type (hecmwST_local_mesh) :: hecMESH
1052 character(len=HECMW_NAME_LEN)::aname
1053 integer(kind=kint) :: id
1054
1055 integer(kind=kint) :: i
1056
1057 id = 0
1058 if( aname .eq. ' ' ) return
1059
1060 do i = 1, hecmesh%amp%n_amp
1061 if( fstr_streqr(hecmesh%amp%amp_name(i), aname)) then
1062 id = i
1063 return
1064 end if
1065 end do
1066 end subroutine get_amp_id
1067
1068 !------------------------------------------------------------------------------
1069 ! JP-8
1070
1071 function get_node_grp_member_n( hecMESH, grp_name_array, n )
1072 implicit none
1073 integer(kind=kint) :: get_node_grp_member_n
1074 type (hecmwst_local_mesh), target :: hecmesh
1075 type(fstr_str_arr) :: grp_name_array
1076 integer(kind=kint) :: n
1077 integer(kind=kint) :: i,j, m
1078
1079 m = 0;
1080 do i = 1, n
1081 call set_group_pointers( hecmesh, grp_name_array%s(i) )
1082 do j = 1, n_grp
1083 if( fstr_streqr(grp_name%s(j), grp_name_array%s(i))) then
1084 m = m + grp_index(j) - grp_index(j-1)
1085 end if
1086 end do
1087 end do
1089 return
1090 end function get_node_grp_member_n
1091
1092 !------------------------------------------------------------------------------
1093
1094 subroutine fstr_expand_index_array( array, old_size, new_size )
1095 implicit none
1096 integer(kind=kint), pointer :: array(:)
1097 integer(kind=kint) :: old_size, new_size,i
1098 integer(kind=kint), pointer :: temp(:)
1099
1100 if( old_size >= new_size ) then
1101 return
1102 end if
1103
1104 if( associated( array ) ) then
1105 allocate(temp(0:old_size-1))
1106 do i=0, old_size-1
1107 temp(i) = array(i)
1108 end do
1109 deallocate(array)
1110 allocate(array(0:new_size-1))
1111 array = 0
1112 do i=0, old_size-1
1113 array(i) = temp(i)
1114 end do
1115 deallocate(temp)
1116 else
1117 allocate(array(0:new_size-1))
1118 array = 0
1119 end if
1120 end subroutine fstr_expand_index_array
1121
1122 subroutine fstr_expand_integer_array( array, old_size, new_size )
1123 implicit none
1124 integer(kind=kint), pointer :: array(:)
1125 integer(kind=kint) :: old_size, new_size,i
1126 integer(kind=kint), pointer :: temp(:)
1127
1128 if( old_size >= new_size ) then
1129 return
1130 end if
1131
1132 if( associated( array ) ) then
1133 allocate(temp(old_size))
1134 do i=1, old_size
1135 temp(i) = array(i)
1136 end do
1137 deallocate(array)
1138 allocate(array(new_size))
1139 array = 0
1140 do i=1, old_size
1141 array(i) = temp(i)
1142 end do
1143 deallocate(temp)
1144 else
1145 allocate(array(new_size))
1146 array = 0
1147 end if
1148 end subroutine fstr_expand_integer_array
1149
1150 subroutine fstr_expand_real_array( array, old_size, new_size )
1151 implicit none
1152 real(kind=kreal), pointer :: array(:)
1153 integer(kind=kint) :: old_size, new_size, i
1154 real(kind=kreal), pointer :: temp(:)
1155
1156 if( old_size >= new_size ) then
1157 return
1158 end if
1159
1160 if( associated( array ) ) then
1161 allocate(temp(old_size))
1162 do i=1, old_size
1163 temp(i) = array(i)
1164 end do
1165 deallocate(array)
1166 allocate(array(new_size))
1167 array = 0
1168 do i=1, old_size
1169 array(i) = temp(i)
1170 end do
1171 deallocate(temp)
1172 else
1173 allocate(array(new_size))
1174 array = 0
1175 end if
1176 end subroutine fstr_expand_real_array
1177
1178 ! array( old_size, column ) -> array( new_size, column )
1179 subroutine fstr_expand_integer_array2( array, column, old_size, new_size )
1180 implicit none
1181 integer(kind=kint), pointer :: array(:,:)
1182 integer(kind=kint) :: column, old_size, new_size, i,j
1183 integer(kind=kint), pointer :: temp(:,:)
1184
1185 if( old_size >= new_size ) then
1186 return
1187 end if
1188
1189 if( associated( array ) ) then
1190 allocate(temp(old_size,column))
1191 do i=1, old_size
1192 do j=1,column
1193 temp(i,j) = array(i,j)
1194 end do
1195 end do
1196 deallocate(array)
1197 allocate(array(new_size,column))
1198 array = 0
1199 do i=1, old_size
1200 do j=1,column
1201 array(i,j) = temp(i,j)
1202 end do
1203 end do
1204 deallocate(temp)
1205 else
1206 allocate(array(new_size, column))
1207 array = 0
1208 end if
1209 end subroutine fstr_expand_integer_array2
1210
1211
1212 ! array( old_size, column ) -> array( new_size, column )
1213
1214 subroutine fstr_expand_real_array2( array, column, old_size, new_size )
1215 implicit none
1216 real(kind=kreal), pointer :: array(:,:)
1217 integer(kind=kint) :: column, old_size, new_size, i,j
1218 real(kind=kreal), pointer :: temp(:,:)
1219
1220 if( old_size >= new_size ) then
1221 return
1222 end if
1223
1224 if( associated( array ) ) then
1225 allocate(temp(old_size,column))
1226 do i=1, old_size
1227 do j=1,column
1228 temp(i,j) = array(i,j)
1229 end do
1230 end do
1231 deallocate(array)
1232 allocate(array(new_size,column))
1233 array = 0
1234 do i=1, old_size
1235 do j=1,column
1236 array(i,j) = temp(i,j)
1237 end do
1238 end do
1239 deallocate(temp)
1240 else
1241 allocate(array(new_size, column))
1242 array = 0
1243 end if
1244 end subroutine fstr_expand_real_array2
1245
1246 subroutine fstr_expand_name_array( array, old_size, new_size )
1247 implicit none
1248 type(fstr_str_arr) :: array
1249 integer(kind=kint) :: old_size, new_size, i
1250 character(len=HECMW_NAME_LEN), pointer :: temp(:)
1251
1252 if( old_size >= new_size ) then
1253 return
1254 end if
1255
1256 if( associated( array%s ) ) then
1257 allocate(temp(old_size))
1258 do i=1, old_size
1259 temp(i) = array%s(i)
1260 end do
1261 deallocate(array%s)
1262 allocate(array%s(new_size))
1263 do i=1, old_size
1264 array%s(i) = temp(i)
1265 end do
1266 deallocate(temp)
1267 else
1268 allocate(array%s(new_size))
1269 end if
1270 end subroutine fstr_expand_name_array
1271
1272 subroutine fstr_delete_index_array( array, old_size, nindex )
1273 implicit none
1274 integer(kind=kint), pointer :: array(:)
1275 integer(kind=kint), intent(in) :: old_size
1276 integer(kind=kint), intent(in) :: nindex
1277 integer(kind=kint) :: i
1278 integer(kind=kint), pointer :: temp(:)
1279
1280 if( old_size < nindex ) then
1281 return
1282 end if
1283
1284 if( old_size == nindex ) then
1285 deallocate( array )
1286 return
1287 endif
1288
1289 allocate(temp(0:old_size-1))
1290 do i=0, old_size-nindex-1
1291 temp(i) = array(i)
1292 end do
1293 deallocate(array)
1294 allocate(array(0:old_size-nindex-1))
1295 array = 0
1296 do i=0, old_size-nindex-1
1297 array(i) = temp(i)
1298 end do
1299 deallocate(temp)
1300 end subroutine fstr_delete_index_array
1301
1302 subroutine fstr_delete_integer_array( array, old_size, nitem )
1303 implicit none
1304 integer(kind=kint), pointer :: array(:)
1305 integer(kind=kint), intent(in) :: old_size
1306 integer(kind=kint), intent(in) :: nitem
1307 integer(kind=kint) :: i
1308 integer(kind=kint), pointer :: temp(:)
1309
1310 if( old_size < nitem ) then
1311 return
1312 end if
1313
1314 if( old_size == nitem ) then
1315 deallocate( array )
1316 return
1317 endif
1318
1319 allocate(temp(old_size))
1320 do i=1, old_size-nitem
1321 temp(i) = array(i)
1322 end do
1323 deallocate(array)
1324 allocate(array(old_size-nitem))
1325 array = 0
1326 do i=1, old_size-nitem
1327 array(i) = temp(i)
1328 end do
1329 deallocate(temp)
1330 end subroutine fstr_delete_integer_array
1331
1332 subroutine fstr_delete_real_array( array, old_size, nitem )
1333 implicit none
1334 real(kind=kreal), pointer :: array(:)
1335 integer(kind=kint), intent(in) :: old_size
1336 integer(kind=kint), intent(in) :: nitem
1337 integer(kind=kint) :: i
1338 real(kind=kreal), pointer :: temp(:)
1339
1340 if( old_size < nitem ) then
1341 return
1342 end if
1343
1344 if( old_size == nitem ) then
1345 deallocate( array )
1346 return
1347 endif
1348
1349 allocate(temp(old_size))
1350 do i=1, old_size-nitem
1351 temp(i) = array(i)
1352 end do
1353 deallocate(array)
1354 allocate(array(old_size-nitem))
1355 array = 0
1356 do i=1, old_size-nitem
1357 array(i) = temp(i)
1358 end do
1359 deallocate(temp)
1360 end subroutine fstr_delete_real_array
1361
1362 !-----------------------------------------------------------------------------!
1363
1364 subroutine reallocate_integer( array, n )
1365 implicit none
1366 integer(kind=kint),pointer :: array(:)
1367 integer(kind=kint) :: n;
1368
1369 if( associated( array )) deallocate(array)
1370 allocate( array(n));
1371 end subroutine reallocate_integer
1372
1373 subroutine reallocate_real( array, n )
1374 implicit none
1375 real(kind=kreal),pointer :: array(:)
1376 integer(kind=kint) :: n;
1377
1378 if( associated( array )) deallocate(array)
1379 allocate( array(n));
1380 end subroutine reallocate_real
1381
1382 !-----------------------------------------------------------------------------!
1383 ! FSTR_SETUP_VISUALIZE !
1384 ! 1) Seeking header to 'WRITE' !
1385 ! 2) If parameter 'VISUAL' exists, then 'hecmw_vis.ini' is opend. !
1386 ! 3) All following lines under the header are writen to the opend file !
1387 !-----------------------------------------------------------------------------!
1388
1389 subroutine fstr_setup_visualize( ctrl, my_rank )
1390 implicit none
1391 integer(kind=kint) :: ctrl, my_rank, rcode
1392 character(HECMW_FILENAME_LEN) :: vis_filename = 'hecmw_vis.ini'
1393 logical :: is_exit
1394
1395 rcode = fstr_ctrl_seek_header( ctrl, '!VISUAL ' )
1396 if(rcode == 0) return
1397
1398 if(my_rank == 0)then
1399 call fstr_setup_visualize_main( ctrl, vis_filename )
1400 endif
1401
1402 inquire(file = vis_filename, exist = is_exit)
1403
1404 if(.not. is_exit)then
1405 call fstr_setup_visualize_main( ctrl, vis_filename )
1406 endif
1407 end subroutine fstr_setup_visualize
1408
1409 subroutine fstr_setup_visualize_main( ctrl, vis_filename )
1410 implicit none
1411 integer(kind=kint) :: ctrl
1412 integer(kind=kint) :: rcode
1413 integer(kind=kint) :: i, start_n, end_n
1414 character(HECMW_FILENAME_LEN) :: vis_filename
1415 integer(kind=kint), parameter :: buffsize = 127
1416 character( buffsize ) :: buff
1417 character( buffsize ) :: head
1418 character( buffsize ) :: msg
1419
1420 start_n = fstr_ctrl_get_c_h_pos( ctrl )
1421 end_n = fstr_ctrl_get_rec_number( ctrl )
1422
1423 open ( ifvs, file = trim(vis_filename), status = 'replace', err = 1000)
1424 do i=start_n, end_n
1425 rcode = fstr_ctrl_get_line( ctrl, i, buff, buffsize )
1426 if( rcode /= 0 ) exit
1427 read( buff, *) head
1428 if( head == '!END') exit
1429 write( ifvs, '(a)') buff
1430 end do
1431 close( ifvs );
1432
1433 return
1434
1435 1000 write(msg,*) 'Error: cannot create file:"', trim(vis_filename), '" for visualization'
1436 call fstr_setup_util_err_stop(msg)
1437 end subroutine fstr_setup_visualize_main
1438
1439 !******************************************************************************
1440
1441end module fstr_setup_util
int fstr_ctrl_get_rec_number(int *ctrl)
void fstr_ctrl_get_err_msg(char *f_buff, int *len)
int fstr_ctrl_get_line(int *ctrl, int *rec_no, char *buff, int *buff_size)
int fstr_ctrl_seek_header(int *ctrl, const char *header_name)
int fstr_ctrl_get_c_h_pos(int *ctrl)
This module contains auxiliary functions in calculation setup.
subroutine append_new_group(hecmesh, grp_type_name, name, count, list, grp_id)
subroutine dload_grp_name_to_id_ex(hecmesh, n, grp_id_name, fg_surface, grp_id)
subroutine elem_grp_name_to_id(hecmesh, header_name, n, grp_id_name, grp_id)
subroutine node_grp_name_to_id_ex(hecmesh, header_name, n, grp_id_name, grp_id)
integer(kind=kint) function get_local_member_index(hecmesh, type_name, name, local_id)
subroutine fstr_ctrl_err_stop
subroutine nodesurf_grp_name_to_id_ex(hecmesh, header_name, n, grp_id_name, grp_id, grp_type)
subroutine fstr_setup_visualize_main(ctrl, vis_filename)
subroutine fstr_setup_visualize(ctrl, my_rank)
subroutine fstr_delete_real_array(array, old_size, nitem)
subroutine append_node_grp_from_surf_grp(hecmesh, sgrp_id, ngrp_id)
subroutine node_grp_name_to_id(hecmesh, header_name, n, grp_id_name, grp_id)
subroutine fstr_expand_real_array2(array, column, old_size, new_size)
integer(kind=kint) function get_grp_id(hecmesh, grp_type_name, name)
subroutine elem_grp_name_to_id_ex(hecmesh, header_name, n, grp_id_name, grp_id)
integer(kind=kint) function get_node_grp_member_n(hecmesh, grp_name_array, n)
subroutine append_intersection_node_grp(hecmesh, ngrp_id1, ngrp_id2)
subroutine fstr_expand_integer_array(array, old_size, new_size)
integer(kind=kint) function get_grp_member(hecmesh, grp_type_name, name, member1, member2)
subroutine get_amp_id(hecmesh, aname, id)
subroutine fstr_expand_index_array(array, old_size, new_size)
logical function fstr_str2index(s, x)
subroutine fstr_expand_real_array(array, old_size, new_size)
subroutine fstr_delete_integer_array(array, old_size, nitem)
subroutine amp_name_to_id(hecmesh, header_name, aname, id)
integer(kind=kint) function node_global_to_local(hecmesh, list, n)
subroutine fstr_setup_util_err_stop(msg)
subroutine backset_group_pointers(hecmesh, grp_type_name)
subroutine fstr_expand_name_array(array, old_size, new_size)
subroutine uniq_int_array(array, len, newlen)
integer(kind=kint) function elem_global_to_local(hecmesh, list, n)
subroutine fstr_strupr(s)
integer(kind=kint) function get_sorted_local_member_index(hecmesh, hecparam, type_name, name, local_id)
subroutine reallocate_real(array, n)
subroutine reallocate_integer(array, n)
subroutine bsearch_int_array(array, istart, iend, val, idx)
subroutine fstr_expand_integer_array2(array, column, old_size, new_size)
recursive subroutine qsort_int_array(array, istart, iend)
subroutine fstr_delete_index_array(array, old_size, nindex)
integer(kind=kint) function get_grp_member_n(hecmesh, grp_type_name, name)
logical function fstr_streqr(s1, s2)
subroutine surf_grp_name_to_id_ex(hecmesh, header_name, n, grp_id_name, grp_id)
Definition: hecmw.f90:6
This module defined coomon data and basic structures for analysis.
Definition: m_fstr.f90:15
integer(kind=kint), parameter imsg
Definition: m_fstr.f90:94
integer(kind=kint), parameter kfloadtype_surf
Definition: m_fstr.f90:74
integer(kind=kint), parameter kfloadtype_node
Definition: m_fstr.f90:73
container of character array pointer, because of gfortran's bug
FSTR INNER CONTROL PARAMETERS (fstrPARAM)
Definition: m_fstr.f90:138