10 include
'fstr_ctrl_util_f.inc'
14 character(len=HECMW_NAME_LEN),
pointer :: s(:)
18 integer(kind=kint),
private :: grp_type
19 integer(kind=kint),
pointer,
private :: n_grp
20 integer(kind=kint),
pointer,
private :: grp_index(:)
21 integer(kind=kint),
pointer,
private :: grp_item(:)
26 private :: set_group_pointers
27 private :: append_single_group
36 integer :: i, n, a, i0,i9, m, x, b
49 if( a < i0 .or. a > i9 )
return
65 if( a >= iachar(
'a') .and. a <= iachar(
'z'))
then
66 s(i:i) = achar(a - 32)
73 character(*) :: s1, s2
75 integer :: i, n, a1, a2
79 if( n /= len_trim(s2))
return
96 character(len=256) :: msg
101 call hecmw_abort( hecmw_comm_get_comm())
112 call hecmw_abort( hecmw_comm_get_comm())
119 subroutine set_group_pointers( hecMESH, grp_type_name )
120 type (hecmwST_local_mesh),
target :: hecMESH
121 character(len=*) :: grp_type_name
123 if( grp_type_name ==
'node_grp' )
then
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
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
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
142 stop
'assert in set_group_pointers'
144 end subroutine set_group_pointers
147 type (hecmwST_local_mesh),
target :: hecMESH
148 character(len=*) :: grp_type_name
150 if( grp_type_name ==
'node_grp' )
then
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
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
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
166 stop
'assert in set_group_pointers'
172 type (hecmwst_local_mesh),
target :: hecmesh
173 integer(kind=kint) :: list(:)
174 integer(kind=kint) :: n, i, j, cache
183 do i=cache, hecmesh%n_node
184 if( hecmesh%global_node_ID(i) == list(j))
then
194 if( hecmesh%global_node_ID(i) == list(j))
then
211 type (hecmwst_local_mesh),
target :: hecmesh
212 integer(kind=kint),
pointer :: list(:)
213 integer(kind=kint) :: n, i, j
220 do i=1, hecmesh%n_elem
221 if( hecmesh%global_elem_ID(i) == list(j))
then
234 function append_single_group( hecMESH, grp_type_name, no_count, no_list )
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
248 call set_group_pointers( hecmesh, grp_type_name )
249 if( grp_type_name ==
'node_grp')
then
251 else if( grp_type_name ==
'elem_grp')
then
255 old_grp_number = n_grp
256 new_grp_number = old_grp_number + no_count
258 old_item_number = grp_index(n_grp)
259 new_item_number = old_item_number + exist_n
265 n_grp = new_grp_number
267 j = old_grp_number + 1
268 k = old_item_number + 1
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
277 grp_index(j) = grp_index(j-1)
281 grp_count = grp_count + 1
283 append_single_group = exist_n
284 end function append_single_group
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
296 call set_group_pointers( hecmesh, grp_type_name )
299 write(*,*)
'### Error: Group already exists: ', name
304 old_grp_number = n_grp
305 new_grp_number = old_grp_number + 1
307 old_item_number = grp_index(n_grp)
308 new_item_number = old_item_number + count
314 n_grp = new_grp_number
315 grp_id = new_grp_number
316 grp_name%s(grp_id) = name
318 grp_item(old_item_number + k) = list(k)
320 grp_index(grp_id) = grp_index(grp_id-1) + count
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 )
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 )
345 allocate( node(nnode) )
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)
355 node(nnode+j) = hecmesh%elem_node_item(j0+snode(j))
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)
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)
381 node(i) = hecmesh%node_group%grp_item(is+i)
383 is= hecmesh%node_group%grp_index(ngrp_id2-1)
385 node(nnode1+i) = hecmesh%node_group%grp_item(is+i)
388 allocate( isect(nnode) )
391 if( node(i) == node(i+1) )
then
393 isect(nisect) = node(i)
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)
412 type (hecmwst_local_mesh),
target :: hecmesh
413 character(len=*) :: grp_type_name
414 character(len=*) :: name
415 integer(kind=kint) :: i
417 call set_group_pointers( hecmesh, grp_type_name )
438 type (hecmwst_local_mesh),
target :: hecmesh
439 character(len=*) :: grp_type_name
440 character(len=*) :: name
441 integer(kind=kint) :: i
443 call set_group_pointers( hecmesh, grp_type_name )
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
474 if( grp_type_name ==
'surf_grp' .and. (.not.
present( member2 )))
then
475 stop
'assert in get_grp_member: not present member2 '
478 call set_group_pointers( hecmesh, grp_type_name )
482 sn = grp_index(i-1) + 1
485 if( grp_type == 3 )
then
487 member1(k) = grp_item(2*j-1)
488 member2(k) = grp_item(2*j)
493 member1(k) = grp_item(j)
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(:)
530 if( type_name ==
'node' )
then
533 global_item => hecmesh%global_node_ID
534 else if( type_name ==
'element' )
then
537 global_item => hecmesh%global_elem_ID
539 stop
'assert in get_local_member_index: unknown type_name'
543 if( no == global_item(i))
then
560 type (hecmwst_local_mesh),
target :: hecmesh
562 character(len=*) :: type_name
563 character(len=*) :: name
564 integer(kind=kint) :: local_id, idx
565 integer(kind=kint) :: n, no, fg
572 if( type_name ==
'node' )
then
574 n = hecmesh%nn_internal
581 stop
'assert in get_sorted_local_member_index: unknown type_name'
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
609 if (left > right)
then
613 center = (left + right) / 2
614 pivot = array(center)
615 if (val < pivot)
then
618 else if (pivot < val)
then
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)
639 do while (array(left) < pivot)
642 do while (pivot < array(right))
645 if (left >= right)
exit
647 array(left) = array(right)
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
665 if (array(i) == array(i - 1 - ndup))
then
667 else if (ndup > 0)
then
668 array(i - ndup) = array(i)
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
688 do id = 1, hecmesh%node_group%n_grp
689 if(
fstr_streqr(hecmesh%node_group%grp_name(id),grp_id_name(i)))
then
694 if( grp_id(i) == -1 )
then
695 write(msg,*)
'### Error: ', header_name,
' : Node group "',&
696 grp_id_name(i),
'" does not exist.'
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
714 do id = 1, hecmesh%elem_group%n_grp
715 if (
fstr_streqr(hecmesh%elem_group%grp_name(id), grp_id_name(i)))
then
720 if( grp_id(i) == -1 )
then
721 write(msg,*)
'### Error: ', header_name,
' : Node group "',&
722 grp_id_name(i),
'" does not exist.'
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(:)
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
747 allocate( no_list( n ))
751 no_count = no_count + 1
752 no_list(no_count) = no
753 grp_id(i) = hecmesh%node_group%n_grp + no_count
756 do id = 1, hecmesh%node_group%n_grp
757 if (
fstr_streqr(hecmesh%node_group%grp_name(id), grp_id_name(i)))
then
762 if( grp_id(i) == -1 )
then
763 write(msg,*)
'### Error: ', header_name,
' : Node group "',grp_id_name(i),
'" does not exist.'
769 if( no_count > 0 )
then
771 exist_n = append_single_group( hecmesh, name, no_count, no_list )
784 deallocate( no_list )
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(:)
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
807 allocate( no_list( n ))
811 no_count = no_count + 1
812 no_list(no_count) = no
813 grp_id(i) = hecmesh%node_group%n_grp + no_count
818 do id = 1, hecmesh%node_group%n_grp
819 if (
fstr_streqr(hecmesh%node_group%grp_name(id), grp_id_name(i)))
then
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
837 if( grp_id(i) == -1 )
then
838 write(msg,*)
'### Error: ', header_name,
' : Node group "',grp_id_name(i),
'" does not exist.'
843 if( no_count > 0 )
then
845 exist_n = append_single_group( hecmesh, name, no_count, no_list )
848 deallocate( no_list )
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
865 allocate( no_list( n ))
869 no_count = no_count + 1
870 no_list(no_count) = no
871 grp_id(i) = hecmesh%elem_group%n_grp + no_count
874 do id = 1, hecmesh%elem_group%n_grp
875 if (
fstr_streqr(hecmesh%elem_group%grp_name(id), grp_id_name(i)))
then
880 if( grp_id(i) == -1 )
then
881 write(msg,*)
'### Error: ', header_name,
' : Element group "',&
882 grp_id_name(i),
'" does not exist.'
888 if( no_count > 0 )
then
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'
895 if( no_list(i)<0 )
then
896 write(*,*) -no_list(i)
897 write(
imsg,*) -no_list(i)
903 deallocate( no_list )
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
920 do id = 1, hecmesh%surf_group%n_grp
921 if (
fstr_streqr(hecmesh%surf_group%grp_name(id), grp_id_name(i)))
then
926 if( grp_id(i) == -1 )
then
927 write(msg,*)
'### Error: ', header_name,
' : Surface group "',grp_id_name(i),
'" does not exist.'
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
949 allocate( no_list( n ))
952 if( fg_surface(i) )
then
954 if(casha < hecmesh%surf_group%n_grp)
then
955 if(
fstr_streqr(hecmesh%surf_group%grp_name(casha), grp_id_name(i)))
then
961 do id = 1, hecmesh%surf_group%n_grp
962 if(
fstr_streqr(hecmesh%surf_group%grp_name(id), grp_id_name(i)))
then
968 if( grp_id(i) == -1 )
then
969 write(msg,*)
'### Error: !DLOAD : Surface group "',&
970 grp_id_name(i),
'" does not exist.'
975 no_count = no_count + 1
976 no_list(no_count) = no
977 grp_id(i) = hecmesh%elem_group%n_grp + no_count
980 if(cashb < hecmesh%surf_group%n_grp)
then
981 if(
fstr_streqr(hecmesh%surf_group%grp_name(cashb), grp_id_name(i)))
then
987 do id = 1, hecmesh%elem_group%n_grp
988 if(
fstr_streqr(hecmesh%elem_group%grp_name(id), grp_id_name(i)))
then
994 if( grp_id(i) == -1 )
then
995 write(msg,*)
'### Error: !DLOAD : Element group "',&
996 grp_id_name(i),
'" does not exist.'
1003 if( no_count > 0 )
then
1005 exist_n = append_single_group( hecmesh, name, no_count, no_list )
1022 deallocate( no_list )
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
1037 if( aname .eq.
' ' )
return
1040 write(msg,*)
'### Error: ', header_name,
' : Amplitude group "',&
1041 aname,
'" does not exist.'
1051 type (hecmwST_local_mesh) :: hecMESH
1052 character(len=HECMW_NAME_LEN)::aname
1053 integer(kind=kint) :: id
1055 integer(kind=kint) :: i
1058 if( aname .eq.
' ' )
return
1060 do i = 1, hecmesh%amp%n_amp
1061 if(
fstr_streqr(hecmesh%amp%amp_name(i), aname))
then
1074 type (hecmwst_local_mesh),
target :: hecmesh
1076 integer(kind=kint) :: n
1077 integer(kind=kint) :: i,j, m
1081 call set_group_pointers( hecmesh, grp_name_array%s(i) )
1083 if(
fstr_streqr(grp_name%s(j), grp_name_array%s(i)))
then
1084 m = m + grp_index(j) - grp_index(j-1)
1096 integer(kind=kint),
pointer :: array(:)
1097 integer(kind=kint) :: old_size, new_size,i
1098 integer(kind=kint),
pointer :: temp(:)
1100 if( old_size >= new_size )
then
1104 if(
associated( array ) )
then
1105 allocate(temp(0:old_size-1))
1110 allocate(array(0:new_size-1))
1117 allocate(array(0:new_size-1))
1124 integer(kind=kint),
pointer :: array(:)
1125 integer(kind=kint) :: old_size, new_size,i
1126 integer(kind=kint),
pointer :: temp(:)
1128 if( old_size >= new_size )
then
1132 if(
associated( array ) )
then
1133 allocate(temp(old_size))
1138 allocate(array(new_size))
1145 allocate(array(new_size))
1152 real(kind=kreal),
pointer :: array(:)
1153 integer(kind=kint) :: old_size, new_size, i
1154 real(kind=kreal),
pointer :: temp(:)
1156 if( old_size >= new_size )
then
1160 if(
associated( array ) )
then
1161 allocate(temp(old_size))
1166 allocate(array(new_size))
1173 allocate(array(new_size))
1181 integer(kind=kint),
pointer :: array(:,:)
1182 integer(kind=kint) :: column, old_size, new_size, i,j
1183 integer(kind=kint),
pointer :: temp(:,:)
1185 if( old_size >= new_size )
then
1189 if(
associated( array ) )
then
1190 allocate(temp(old_size,column))
1193 temp(i,j) = array(i,j)
1197 allocate(array(new_size,column))
1201 array(i,j) = temp(i,j)
1206 allocate(array(new_size, column))
1216 real(kind=kreal),
pointer :: array(:,:)
1217 integer(kind=kint) :: column, old_size, new_size, i,j
1218 real(kind=kreal),
pointer :: temp(:,:)
1220 if( old_size >= new_size )
then
1224 if(
associated( array ) )
then
1225 allocate(temp(old_size,column))
1228 temp(i,j) = array(i,j)
1232 allocate(array(new_size,column))
1236 array(i,j) = temp(i,j)
1241 allocate(array(new_size, column))
1249 integer(kind=kint) :: old_size, new_size, i
1250 character(len=HECMW_NAME_LEN),
pointer :: temp(:)
1252 if( old_size >= new_size )
then
1256 if(
associated( array%s ) )
then
1257 allocate(temp(old_size))
1259 temp(i) = array%s(i)
1262 allocate(array%s(new_size))
1264 array%s(i) = temp(i)
1268 allocate(array%s(new_size))
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(:)
1280 if( old_size < nindex )
then
1284 if( old_size == nindex )
then
1289 allocate(temp(0:old_size-1))
1290 do i=0, old_size-nindex-1
1294 allocate(array(0:old_size-nindex-1))
1296 do i=0, old_size-nindex-1
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(:)
1310 if( old_size < nitem )
then
1314 if( old_size == nitem )
then
1319 allocate(temp(old_size))
1320 do i=1, old_size-nitem
1324 allocate(array(old_size-nitem))
1326 do i=1, old_size-nitem
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(:)
1340 if( old_size < nitem )
then
1344 if( old_size == nitem )
then
1349 allocate(temp(old_size))
1350 do i=1, old_size-nitem
1354 allocate(array(old_size-nitem))
1356 do i=1, old_size-nitem
1366 integer(kind=kint),
pointer :: array(:)
1367 integer(kind=kint) :: n;
1369 if(
associated( array ))
deallocate(array)
1370 allocate( array(n));
1375 real(kind=kreal),
pointer :: array(:)
1376 integer(kind=kint) :: n;
1378 if(
associated( array ))
deallocate(array)
1379 allocate( array(n));
1391 integer(kind=kint) :: ctrl, my_rank, rcode
1392 character(HECMW_FILENAME_LEN) :: vis_filename =
'hecmw_vis.ini'
1396 if(rcode == 0)
return
1398 if(my_rank == 0)
then
1402 inquire(file = vis_filename, exist = is_exit)
1404 if(.not. is_exit)
then
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
1423 open (
ifvs, file = trim(vis_filename), status =
'replace', err = 1000)
1426 if( rcode /= 0 )
exit
1428 if( head ==
'!END')
exit
1429 write(
ifvs,
'(a)') buff
1435 1000
write(msg,*)
'Error: cannot create file:"', trim(vis_filename),
'" for visualization'
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)
This module defined coomon data and basic structures for analysis.
integer(kind=kint), parameter imsg
integer(kind=kint), parameter kfloadtype_surf
integer(kind=kint), parameter ifvs
integer(kind=kint), parameter kfloadtype_node
container of character array pointer, because of gfortran's bug
FSTR INNER CONTROL PARAMETERS (fstrPARAM)