FrontISTR  5.2.0
Large-scale structural analysis program with finit element method
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 
29 contains
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 
94  subroutine fstr_ctrl_err_stop
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
425  get_grp_member_n = 0
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
501  get_grp_member = 0
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
593  end function get_sorted_local_member_index
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.'
697  call fstr_setup_util_err_stop(msg)
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.'
723  call fstr_setup_util_err_stop(msg)
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.'
764  call fstr_setup_util_err_stop(msg)
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.'
839  call fstr_setup_util_err_stop(msg)
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.'
883  call fstr_setup_util_err_stop(msg)
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.'
928  call fstr_setup_util_err_stop(msg)
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.'
971  call fstr_setup_util_err_stop(msg)
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.'
997  call fstr_setup_util_err_stop(msg)
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 
1441 end 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.
integer(kind=kint) function get_grp_member_n(hecMESH, grp_type_name, name)
integer(kind=kint) function get_node_grp_member_n(hecMESH, grp_name_array, n)
subroutine fstr_ctrl_err_stop
subroutine node_grp_name_to_id_ex(hecMESH, header_name, n, grp_id_name, grp_ID)
subroutine surf_grp_name_to_id_ex(hecMESH, header_name, n, grp_id_name, grp_ID)
subroutine dload_grp_name_to_id_ex(hecMESH, n, grp_id_name, fg_surface, grp_ID)
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 backset_group_pointers(hecMESH, grp_type_name)
subroutine fstr_setup_visualize(ctrl, my_rank)
subroutine fstr_delete_real_array(array, old_size, nitem)
integer(kind=kint) function get_local_member_index(hecMESH, type_name, name, local_id)
subroutine fstr_expand_real_array2(array, column, old_size, new_size)
integer(kind=kint) function get_grp_member(hecMESH, grp_type_name, name, member1, member2)
subroutine fstr_expand_integer_array(array, old_size, new_size)
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 append_new_group(hecMESH, grp_type_name, name, count, list, grp_id)
subroutine amp_name_to_id(hecMESH, header_name, aname, id)
subroutine append_node_grp_from_surf_grp(hecMESH, sgrp_id, ngrp_id)
subroutine fstr_setup_util_err_stop(msg)
subroutine fstr_expand_name_array(array, old_size, new_size)
subroutine uniq_int_array(array, len, newlen)
integer(kind=kint) function node_global_to_local(hecMESH, list, n)
subroutine elem_grp_name_to_id_ex(hecMESH, header_name, n, grp_id_name, grp_ID)
integer(kind=kint) function elem_global_to_local(hecMESH, list, n)
subroutine fstr_strupr(s)
subroutine reallocate_real(array, n)
subroutine elem_grp_name_to_id(hecMESH, header_name, n, grp_id_name, grp_ID)
subroutine append_intersection_node_grp(hecMESH, ngrp_id1, ngrp_id2)
subroutine reallocate_integer(array, n)
subroutine bsearch_int_array(array, istart, iend, val, idx)
integer(kind=kint) function get_grp_id(hecMESH, grp_type_name, name)
integer(kind=kint) function get_sorted_local_member_index(hecMESH, hecPARAM, type_name, name, local_id)
subroutine fstr_expand_integer_array2(array, column, old_size, new_size)
recursive subroutine qsort_int_array(array, istart, iend)
subroutine get_amp_id(hecMESH, aname, id)
subroutine fstr_delete_index_array(array, old_size, nindex)
subroutine node_grp_name_to_id(hecMESH, header_name, n, grp_id_name, grp_ID)
logical function fstr_streqr(s1, s2)
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 ifvs
Definition: m_fstr.f90:96
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