OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
init_nodal_state.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| init_nodal_state ../engine/source/interfaces/interf/init_nodal_state.F
25!||--- called by ------------------------------------------------------
26!|| resol ../engine/source/engine/resol.F
27!||--- calls -----------------------------------------------------
28!|| count_nb_elem_edge ../engine/source/interfaces/interf/count_nb_elem_edge.F
29!|| count_remote_nb_elem_edge ../engine/source/interfaces/interf/count_remote_nb_elem_edge.F
30!|| myqsort_int ../common_source/tools/sort/myqsort_int.F
31!||--- uses -----------------------------------------------------
32!|| array_mod ../common_source/modules/array_mod.F
33!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.f90
34!|| nodal_arrays_mod ../common_source/modules/nodal_arrays.F90
35!|| shooting_node_mod ../engine/share/modules/shooting_node_mod.f
36!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
37!||====================================================================
38 SUBROUTINE init_nodal_state( IPARI,SHOOT_STRUCT,INTBUF_TAB,IAD_ELEM,FR_ELEM,
39 . ITAB,NODES,GEO,ADDCNEL,CNEL,
40 . IXS,IXC,IXT,IXP,IXR,IXTG,
41 . SIZE_ADDCNEL,SIZE_CNEL,
42 . numelsg,numelqg,numelcg,numeltrg,numelpg,
43 . numelrg,numeltgg,ixs10 )
44!$COMMENT
45! INIT_NODAL_STATE description
46! initialization of structures for the new shooting node algo
47! this algo is available only for /INTER/TYPE7 & 11 & 10 & 22
48! INIT_NODAL_STATE organization
49! for each secondary node, save :
50! - the number of processor where the node is defined
51! - the list of processor where the node is defined
52! - the number of interface where the node is defined
53! - the list of interface where the node is defined
54!
55! for each main node, save :
56! - the number of processor where the node is defined
57! - the list of processor where the node is defined
58! - the number of surface where the node is defined
59! - the list of surface where the node is defined
60!$ENDCOMMENT
61 USE nodal_arrays_mod
62 USE intbufdef_mod
63 USE shooting_node_mod
64 USE array_mod
65C-----------------------------------------------
66C I m p l i c i t T y p e s
67C-----------------------------------------------
68 USE spmd_comm_world_mod, ONLY : spmd_comm_world
69#include "implicit_f.inc"
70C-----------------------------------------------------------------
71C M e s s a g e P a s s i n g
72C-----------------------------------------------
73#include "spmd.inc"
74C-----------------------------------------------
75C C o m m o n B l o c k s
76C-----------------------------------------------
77#include "task_c.inc"
78#include "com04_c.inc"
79#include "param_c.inc"
80#include "tabsiz_c.inc"
81#include "com01_c.inc"
82C-----------------------------------------------
83C D u m m y A r g u m e n t s
84C-----------------------------------------------
85 INTEGER, INTENT(in) :: SIZE_ADDCNEL,SIZE_CNEL !< array size : cnel & addcnel
86 integer, intent(in) :: numelsg !< global number of solid
87 integer, intent(in) :: numelqg !< global number of quad
88 integer, intent(in) :: numelcg !< global number of shell
89 integer, intent(in) :: numeltrg !< global number of truss
90 integer, intent(in) :: numelpg !< global number of beam
91 integer, intent(in) :: numelrg !< global number of spring
92 integer, intent(in) :: numeltgg !< global number of shell3n
93 INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI
94 INTEGER, DIMENSION(2,NSPMD+1), INTENT(in) :: IAD_ELEM !< adress for frontier node
95 INTEGER, DIMENSION(SFR_ELEM), INTENT(in) :: FR_ELEM !< frontier node id
96 TYPE(shooting_node_type), INTENT(inout) :: SHOOT_STRUCT !< structure for shooting node algo
97 TYPE(intbuf_struct_), DIMENSION(NINTER), INTENT(inout) :: INTBUF_TAB !< interface data
98 INTEGER, DIMENSION(NUMNOD), INTENT(in) :: ITAB !< array to convert local id to global id
99 type(nodal_arrays_), INTENT(INOUT) :: NODES !< nodal data
100 my_real, DIMENSION(NPROPG,NUMGEO), INTENT(in) :: geo !< property data
101 INTEGER, DIMENSION(0:SIZE_ADDCNEL), INTENT(in) :: ADDCNEL !< address for the CNEL array
102 INTEGER, DIMENSION(0:SIZE_CNEL), INTENT(in) :: CNEL !< connectivity node --> element
103 INTEGER, DIMENSION(NIXS,NUMELS),TARGET, INTENT(in) :: IXS !< solid array
104 INTEGER, DIMENSION(NIXC,NUMELC),TARGET, INTENT(in) :: IXC !< shell array
105 INTEGER, DIMENSION(NIXT,NUMELT),TARGET, INTENT(in) :: IXT !< truss array
106 INTEGER, DIMENSION(NIXP,NUMELP),TARGET, INTENT(in) :: IXP !< beam array
107 INTEGER, DIMENSION(NIXR,NUMELR),TARGET, INTENT(in) :: IXR !< spring array
108 INTEGER, DIMENSION(NIXTG,NUMELTG),TARGET, INTENT(in) :: IXTG !<triangle array
109 INTEGER, DIMENSION(6,NUMELS10), INTENT(in) :: IXS10!< tetra10 data
110C-----------------------------------------------
111C L o c a l V a r i a b l e s
112C-----------------------------------------------
113 LOGICAL :: TYPE_INTER
114 INTEGER :: NIN,ITY,NSN,NMN,NRTM,NRTS,IDEL,IDELKEEP,NRTMG
115 INTEGER :: I,J
116 INTEGER :: NODE_ID,SHIFT,SHIFT_INTER,NEXT_INTER
117 INTEGER :: TMP_,MY_ERROR,NB_PROC,NB_NODE_SURF,NB_SURF,NB_REAL_NODE
118 INTEGER :: NB_EDGE,NB_EDGE_2
119 INTEGER :: N1,N2,N3,N4
120 INTEGER :: MAX_NB_NODE_PER_SURFACE ! max number of nodes per surface
121 INTEGER :: CHUNK ! chunk size : 1-> interface id, 2-> surface id, 3:6-> node id (for type11, 5&6 values are equal to 0)
122 INTEGER, DIMENSION(4) :: LIST_NODE_ID ! node id of surface
123 INTEGER, DIMENSION(4) :: GLOBAL_NODE_ID ! node id of surface
124 INTEGER, DIMENSION(:), ALLOCATABLE :: WORK_ARRAY,WORK_ARRAY_2,WORK_ARRAY_3
125 INTEGER, DIMENSION(:), ALLOCATABLE :: SORT_ARRAY,PERM
126
127 TYPE(array_type), DIMENSION(:), ALLOCATABLE :: BUFFER_SECOND,BUFFER_MAIN
128 TYPE(array_type), DIMENSION(:), ALLOCATABLE :: R_BUFFER_SECOND,R_BUFFER_MAIN
129#ifdef MPI
130 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: STATU
131 INTEGER :: MSGTYP,MSGOFF1,IERROR
132 DATA msgoff1/13013/
133 INTEGER, DIMENSION(NSPMD) :: REQUEST_S,REQUEST_R
134 INTEGER, DIMENSION(NSPMD) :: REQUEST_S2,REQUEST_R2
135 INTEGER, DIMENSION(NSPMD) :: REQUEST_S3,REQUEST_R3
136#endif
137 INTEGER :: SIZ,OLD_SIZE
138 INTEGER :: PROC_ID
139 INTEGER :: NB_PROC_1,NB_PROC_2,NB_RESULT_INTERSECT,SHIFT_INTER2
140 INTEGER, DIMENSION(:), ALLOCATABLE :: INTERSECT_1,INTERSECT_2,RESULT_INTERSECT
141 INTEGER, DIMENSION(2,NSPMD) :: S_BUFFER_2_INT,R_BUFFER_2_INT
142 INTEGER, DIMENSION(NSPMD) :: SIZE_BUFFER_MAIN,SIZE_BUFFER_SECOND
143 INTEGER, DIMENSION(NSPMD) :: R_SIZE_BUFFER_MAIN,R_SIZE_BUFFER_SECOND
144
145C-----------------------------------------------
146 ! --------------------------------
147 ! Upper & lower bound, only used by the erosion of solid element + /TYPE25
148 ! to get the kind of element (solid,shell or shell3n)
149 ! --------------------------------
150 ! solid
151 shoot_struct%offset_elem%sol_low_bound = 0
152 shoot_struct%offset_elem%sol_up_bound = numelsg
153 ! quad
154 shoot_struct%offset_elem%quad_low_bound = shoot_struct%offset_elem%sol_up_bound + 1
155 shoot_struct%offset_elem%quad_up_bound = shoot_struct%offset_elem%sol_up_bound + numelqg
156 ! shell
157 shoot_struct%offset_elem%shell_low_bound = shoot_struct%offset_elem%quad_up_bound + 1
158 shoot_struct%offset_elem%shell_up_bound = shoot_struct%offset_elem%quad_up_bound + numelcg
159 ! truss
160 shoot_struct%offset_elem%truss_low_bound = shoot_struct%offset_elem%shell_up_bound + 1
161 shoot_struct%offset_elem%truss_up_bound = shoot_struct%offset_elem%shell_up_bound + numeltrg
162 ! beam
163 shoot_struct%offset_elem%beam_low_bound = shoot_struct%offset_elem%truss_up_bound + 1
164 shoot_struct%offset_elem%beam_up_bound = shoot_struct%offset_elem%truss_up_bound + numelpg
165 ! spring
166 shoot_struct%offset_elem%spring_low_bound = shoot_struct%offset_elem%truss_up_bound + 1
167 shoot_struct%offset_elem%spring_up_bound = shoot_struct%offset_elem%truss_up_bound + numelrg
168 ! shell3n
169 shoot_struct%offset_elem%shell3n_low_bound = shoot_struct%offset_elem%spring_up_bound + 1
170 shoot_struct%offset_elem%shell3n_up_bound = shoot_struct%offset_elem%spring_up_bound + numeltgg
171 ! --------------------------------
172
173
174 ALLOCATE( buffer_second(nspmd) )
175 ALLOCATE( buffer_main(nspmd) )
176 ALLOCATE( r_buffer_second(nspmd) )
177 ALLOCATE( r_buffer_main(nspmd) )
178
179 buffer_second(1:nspmd)%SIZE_INT_ARRAY_1D = 0
180 buffer_main(1:nspmd)%SIZE_INT_ARRAY_1D = 0
181 r_buffer_second(1:nspmd)%SIZE_INT_ARRAY_1D = 0
182 r_buffer_main(1:nspmd)%SIZE_INT_ARRAY_1D = 0
183
184 ! --------------------------------
185 ! SECONDARY NODES
186 ! --------------------------------
187
188 ! SHIFT_S_NODE(i) = index to INTER_SEC_NODE/SEC_NODE_ID for node_id = i
189 ! SHIFT_S_NODE(i+1) - SHIFT_S_NODE(i) = number of interface per node
190 IF(ALLOCATED(shoot_struct%SHIFT_S_NODE) )DEALLOCATE( shoot_struct%SHIFT_S_NODE )
191 ALLOCATE( shoot_struct%SHIFT_S_NODE(numnod+1) )
192 shoot_struct%SHIFT_S_NODE(1:numnod+1) = 0
193 DO nin=1,ninter
194 ity = ipari(7,nin) ! interface id
195 nsn = ipari(5,nin) ! number of secondary nodes
196 idel = ipari(17,nin)! idel option
197 idelkeep = ipari(61,nin)
198 IF((ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.ity==25).AND.idel>=1.AND.idelkeep/=1) THEN
199 ! loop over the S nodes
200 DO i=1,nsn
201 node_id = intbuf_tab(nin)%NSV(i)
202 ! need to check the node_id value: for type24 + e2e NODE_ID can be greater than NUMNOD
203 IF(node_id<=numnod) shoot_struct%SHIFT_S_NODE(node_id+1) = shoot_struct%SHIFT_S_NODE(node_id+1) + 1
204 ENDDO
205 ENDIF
206 ENDDO
207
208 shoot_struct%SIZE_SEC_NODE = 0
209 DO i=1,numnod
210 shoot_struct%SHIFT_S_NODE(i+1) = shoot_struct%SHIFT_S_NODE(i+1) + shoot_struct%SHIFT_S_NODE(i)
211 ENDDO
212 ! size of %INTER_SEC_NODE & %SEC_NODE_ID
213 shoot_struct%SIZE_SEC_NODE = shoot_struct%SHIFT_S_NODE(numnod+1)
214
215 ! allocation
216 IF(ALLOCATED(shoot_struct%INTER_SEC_NODE) )DEALLOCATE( shoot_struct%INTER_SEC_NODE )
217 ALLOCATE( shoot_struct%INTER_SEC_NODE(shoot_struct%SIZE_SEC_NODE) )
218 IF(ALLOCATED(shoot_struct%SEC_NODE_ID) )DEALLOCATE( shoot_struct%SEC_NODE_ID )
219 ALLOCATE( shoot_struct%SEC_NODE_ID(shoot_struct%SIZE_SEC_NODE) )
220
221
222 ALLOCATE( work_array(numnod) )
223 work_array(1:numnod) = 0
224 DO nin=1,ninter
225 ity = ipari(7,nin)
226 nsn = ipari(5,nin)
227 idel = ipari(17,nin)! idel option
228 idelkeep = ipari(61,nin)
229 IF((ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.ity==25).AND.idel>=1.AND.idelkeep/=1) THEN
230 DO i=1,nsn
231 node_id = intbuf_tab(nin)%NSV(i) ! node id
232 IF(node_id<=numnod) THEN
233 work_array(node_id) = work_array(node_id) + 1
234 shift = work_array(node_id) + shoot_struct%SHIFT_S_NODE(node_id) ! index for %inter_sec_node
235 shoot_struct%INTER_SEC_NODE( shift ) = nin ! save the interface
236 shoot_struct%SEC_NODE_ID( shift ) = i ! save the NSV id
237 ENDIF
238 ENDDO
239 ENDIF
240 ENDDO
241
242 DEALLOCATE( work_array )
243 ! --------------------------------
244
245
246 ! --------------------------------
247 ! MAIN NODES
248 ! --------------------------------
249 IF(ALLOCATED(shoot_struct%SHIFT_M_NODE_PROC) ) DEALLOCATE( shoot_struct%SHIFT_M_NODE_PROC )
250 ALLOCATE( shoot_struct%SHIFT_M_NODE_PROC(numnod+1) )
251 shoot_struct%SHIFT_M_NODE_PROC(2:numnod+1) = 1
252 shoot_struct%SHIFT_M_NODE_PROC(1) = 0
253 ! ---------------------
254 ! compute the nodal index (main node)
255 ! shift(i) gives the index of the i node
256 ! shift(i+1)-shift(i) gives the number of surface of the i node
257 DO i=1,nspmd
258 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
259 node_id = fr_elem(j)
260 shoot_struct%SHIFT_M_NODE_PROC(node_id+1) = shoot_struct%SHIFT_M_NODE_PROC(node_id+1) + 1
261 ENDDO
262 ENDDO
263 DO i=1,numnod
264 shoot_struct%SHIFT_M_NODE_PROC(i+1) = shoot_struct%SHIFT_M_NODE_PROC(i+1) + shoot_struct%SHIFT_M_NODE_PROC(i)
265 ENDDO
266 ! save the size
267 shoot_struct%SIZE_M_NODE_PROC = shoot_struct%SHIFT_M_NODE_PROC(numnod+1)
268 ! ---------------------
269
270 ! ---------------------
271 ! compute the list of processor for each node
272 IF(ALLOCATED(shoot_struct%M_NODE_PROC) )DEALLOCATE( shoot_struct%M_NODE_PROC )
273 ALLOCATE( shoot_struct%M_NODE_PROC( shoot_struct%SIZE_M_NODE_PROC ) )
274 shoot_struct%M_NODE_PROC(1:shoot_struct%SIZE_M_NODE_PROC) = -1
275 ALLOCATE( work_array(numnod) )
276 work_array(1:numnod) = 0
277
278 ! loop over the nodes to save the proc ID
279 DO i=1,numnod
280 work_array(i) = work_array(i) + 1
281 shift = work_array(i) + shoot_struct%SHIFT_M_NODE_PROC(i) ! index for M_NODE_PROC
282 shoot_struct%M_NODE_PROC( shift ) = ispmd+1
283 ENDDO
284 ! loop over the frontier nodes to save the proc ID
285 DO i=1,nspmd
286 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
287 node_id = fr_elem(j)
288 work_array(node_id) = work_array(node_id) + 1
289 shift = work_array(node_id) + shoot_struct%SHIFT_M_NODE_PROC(node_id) ! index for M_NODE_PROC
290 shoot_struct%M_NODE_PROC( shift ) = i ! save the processor ID
291 ENDDO
292 ENDDO
293 ! sort the list of processor and compute the max number of processor
294 shoot_struct%MAX_PROC_NB = 0
295 DO i=1,numnod
296 shift = shoot_struct%SHIFT_M_NODE_PROC(i) ! index for M_NODE_PROC
297 nb_proc = shoot_struct%SHIFT_M_NODE_PROC(i+1) - shoot_struct%SHIFT_M_NODE_PROC(i)
298 shoot_struct%MAX_PROC_NB = max(shoot_struct%MAX_PROC_NB,nb_proc)
299 IF(nb_proc>2) THEN
300 ALLOCATE( sort_array(nb_proc),perm(nb_proc) )
301 sort_array(1:nb_proc) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc )
302 CALL myqsort_int(nb_proc, sort_array, perm, my_error)
303 shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc ) = sort_array(1:nb_proc)
304 DEALLOCATE( sort_array,perm )
305 ELSEIF(nb_proc==2) THEN
306 IF(shoot_struct%M_NODE_PROC(shift+1)>shoot_struct%M_NODE_PROC(shift+2)) THEN
307 tmp_ = shoot_struct%M_NODE_PROC(shift+2)
308 shoot_struct%M_NODE_PROC(shift+2) = shoot_struct%M_NODE_PROC(shift+1)
309 shoot_struct%M_NODE_PROC(shift+1) = tmp_
310 ENDIF
311 ENDIF
312 ENDDO
313 ! ---------------------
314
315 ! ---------------------
316 ! compute the index for the surface/edge array
317 IF(ALLOCATED(shoot_struct%SHIFT_M_NODE_SURF) )DEALLOCATE( shoot_struct%SHIFT_M_NODE_SURF )
318 ALLOCATE( shoot_struct%SHIFT_M_NODE_SURF(numnod+1) )
319 shoot_struct%SHIFT_M_NODE_SURF(1:numnod+1) = 0
320 IF(ALLOCATED(shoot_struct%SHIFT_M_NODE_EDGE) )DEALLOCATE( shoot_struct%SHIFT_M_NODE_EDGE )
321 ALLOCATE( shoot_struct%SHIFT_M_NODE_EDGE(numnod+1) )
322 shoot_struct%SHIFT_M_NODE_EDGE(1:numnod+1) = 0
323 IF(ALLOCATED(shoot_struct%SHIFT_S_NODE_EDGE) )DEALLOCATE( shoot_struct%SHIFT_S_NODE_EDGE )
324 ALLOCATE( shoot_struct%SHIFT_S_NODE_EDGE(numnod+1) )
325 shoot_struct%SHIFT_S_NODE_EDGE(1:numnod+1) = 0
326
327 DO nin=1,ninter
328 ity = ipari(7,nin) ! interface id
329 nmn = ipari(6,nin) ! number of main nodes
330 nrtm = ipari(4,nin) ! number of main surfaces/edges
331 nrts = ipari(3,nin) ! number of secondary edges
332 idel = ipari(17,nin)! idel option
333 ! -----------------------------
334 IF((ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.ity==25).AND.idel>=1) THEN
335 ! loop over the M surface
336 DO i=1,nrtm
337 n1 = intbuf_tab(nin)%IRECTM((i-1)*4+1)
338 n2 = intbuf_tab(nin)%IRECTM((i-1)*4+2)
339 n3 = intbuf_tab(nin)%IRECTM((i-1)*4+3)
340 n4 = intbuf_tab(nin)%IRECTM((i-1)*4+4)
341 shoot_struct%SHIFT_M_NODE_SURF(n1+1) = shoot_struct%SHIFT_M_NODE_SURF(n1+1) + 1
342 shoot_struct%SHIFT_M_NODE_SURF(n2+1) = shoot_struct%SHIFT_M_NODE_SURF(n2+1) + 1
343 shoot_struct%SHIFT_M_NODE_SURF(n3+1) = shoot_struct%SHIFT_M_NODE_SURF(n3+1) + 1
344 IF(n3/=n4) shoot_struct%SHIFT_M_NODE_SURF(n4+1) = shoot_struct%SHIFT_M_NODE_SURF(n4+1) + 1
345 ENDDO
346 ! -----------------------------
347
348 ELSEIF(ity == 11) THEN
349 ! loop over the M edge
350 IF(idel>=1) THEN
351 DO i=1,nrtm
352 n1 = intbuf_tab(nin)%IRECTM((i-1)*2+1)
353 n2 = intbuf_tab(nin)%IRECTM((i-1)*2+2)
354 shoot_struct%SHIFT_M_NODE_EDGE(n1+1) = shoot_struct%SHIFT_M_NODE_EDGE(n1+1) + 1
355 shoot_struct%SHIFT_M_NODE_EDGE(n2+1) = shoot_struct%SHIFT_M_NODE_EDGE(n2+1) + 1
356 ENDDO
357 ENDIF
358 ! loop over the S edge
359 IF(idel>=1) THEN
360 DO i=1,nrts
361 n1 = intbuf_tab(nin)%IRECTS((i-1)*2+1)
362 n2 = intbuf_tab(nin)%IRECTS((i-1)*2+2)
363 shoot_struct%SHIFT_S_NODE_EDGE(n1+1) = shoot_struct%SHIFT_S_NODE_EDGE(n1+1) + 1
364 shoot_struct%SHIFT_S_NODE_EDGE(n2+1) = shoot_struct%SHIFT_S_NODE_EDGE(n2+1) + 1
365 ENDDO
366 ENDIF
367 ENDIF
368 ! -----------------------------
369 ENDDO
370
371 DO i=1,numnod
372 shoot_struct%SHIFT_M_NODE_SURF(i+1) = shoot_struct%SHIFT_M_NODE_SURF(i+1) + shoot_struct%SHIFT_M_NODE_SURF(i)
373 shoot_struct%SHIFT_M_NODE_EDGE(i+1) = shoot_struct%SHIFT_M_NODE_EDGE(i+1) + shoot_struct%SHIFT_M_NODE_EDGE(i)
374 shoot_struct%SHIFT_S_NODE_EDGE(i+1) = shoot_struct%SHIFT_S_NODE_EDGE(i+1) + shoot_struct%SHIFT_S_NODE_EDGE(i)
375 ENDDO
376 shoot_struct%SIZE_M_NODE_SURF = shoot_struct%SHIFT_M_NODE_SURF(numnod+1)
377 IF(ALLOCATED(shoot_struct%M_NODE_SURF) )DEALLOCATE( shoot_struct%M_NODE_SURF )
378 ALLOCATE( shoot_struct%M_NODE_SURF( shoot_struct%SIZE_M_NODE_SURF) )
379 IF(ALLOCATED(shoot_struct%M_NODE_EDGE) )DEALLOCATE( shoot_struct%M_NODE_EDGE )
380 shoot_struct%SIZE_M_NODE_EDGE = shoot_struct%SHIFT_M_NODE_EDGE(numnod+1)
381 ALLOCATE( shoot_struct%M_NODE_EDGE( shoot_struct%SIZE_M_NODE_EDGE) )
382 shoot_struct%SIZE_S_NODE_EDGE = shoot_struct%SHIFT_S_NODE_EDGE(numnod+1)
383 IF(ALLOCATED(shoot_struct%S_NODE_EDGE) )DEALLOCATE( shoot_struct%S_NODE_EDGE )
384 ALLOCATE( shoot_struct%S_NODE_EDGE( shoot_struct%SIZE_S_NODE_EDGE) )
385 ! ---------------------
386 ! compute the max number of surface/edge
387 shoot_struct%MAX_SURF_NB = 0
388 shoot_struct%MAX_EDGE_NB = 0
389 DO i=1,numnod
390 nb_surf = shoot_struct%SHIFT_M_NODE_SURF(i+1) - shoot_struct%SHIFT_M_NODE_SURF(i)
391 shoot_struct%MAX_SURF_NB = max(shoot_struct%MAX_SURF_NB,nb_surf)
392
393 nb_edge = shoot_struct%SHIFT_M_NODE_EDGE(i+1) - shoot_struct%SHIFT_M_NODE_EDGE(i)
394 nb_edge_2 = shoot_struct%SHIFT_S_NODE_EDGE(i+1) - shoot_struct%SHIFT_S_NODE_EDGE(i)
395 nb_edge = max(nb_edge,nb_edge_2)
396 shoot_struct%MAX_EDGE_NB = max(shoot_struct%MAX_EDGE_NB,nb_edge)
397 ENDDO
398 ! ---------------------
399 ! save the surface/edge ID for each node
400 work_array(1:numnod) = 0
401 ALLOCATE( work_array_2(numnod) )
402 work_array_2(1:numnod) = 0
403 ALLOCATE( work_array_3(numnod) )
404 work_array_3(1:numnod) = 0
405 IF(ALLOCATED(shoot_struct%SHIFT_INTERFACE) )DEALLOCATE( shoot_struct%SHIFT_INTERFACE )
406 IF(ALLOCATED(shoot_struct%SHIFT_INTERFACE2) )DEALLOCATE( shoot_struct%SHIFT_INTERFACE2 )
407 ALLOCATE( shoot_struct%SHIFT_INTERFACE(ninter+1,2) )
408 ALLOCATE( shoot_struct%SHIFT_INTERFACE2(ninter) )
409 next_inter = 0
410 shift_inter = 1
411 shift_inter2 = 0
412 DO nin=1,ninter
413 ity = ipari(7,nin) ! interface id
414 nmn = ipari(6,nin) ! number of main nodes
415 nrtm = ipari(4,nin) ! number of main surfaces/edges
416 nrts = ipari(3,nin) ! number of secondary edges
417 idel = ipari(17,nin)! idel option
418 nrtmg = ipari(74,nin) ! global number of main surfaces
419 ! ---------------------------
420 IF((ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.ity==25).AND.idel>=1) THEN
421 ! loop over the M surface
422 DO i=1,nrtm
423 n3 = intbuf_tab(nin)%IRECTM((i-1)*4+3)
424 n4 = intbuf_tab(nin)%IRECTM((i-1)*4+4)
425 nb_node_surf = 4
426 IF(n3==n4) nb_node_surf = 3
427 DO j=1,nb_node_surf
428 node_id = intbuf_tab(nin)%IRECTM((i-1)*4+j)
429 work_array(node_id) = work_array(node_id) + 1
430 shift = work_array(node_id) + shoot_struct%SHIFT_M_NODE_SURF(node_id) ! index for M_NODE_SURF
431 shoot_struct%M_NODE_SURF( shift ) = shift_inter - 1 + i ! save the surface ID
432 ENDDO
433 ENDDO
434
435 ELSEIF(ity==11) THEN
436 ! loop over the M edge
437 IF(idel>=1) THEN
438 DO i=1,nrtm
439 DO j=1,2
440 node_id = intbuf_tab(nin)%IRECTM((i-1)*2+j)
441 work_array_2(node_id) = work_array_2(node_id) + 1
442 shift = work_array_2(node_id) + shoot_struct%SHIFT_M_NODE_EDGE(node_id) ! index for M_NODE_EDGE
443 shoot_struct%M_NODE_EDGE( shift ) = shift_inter - 1 + i ! save the edge ID
444 ENDDO
445 ENDDO
446 ENDIF
447 ! loop over the S edge
448 IF(idel>=1) THEN
449 DO i=1,nrts
450 DO j=1,2
451 node_id = intbuf_tab(nin)%IRECTS((i-1)*2+j)
452 work_array_3(node_id) = work_array_3(node_id) + 1
453 shift = work_array_3(node_id) + shoot_struct%SHIFT_S_NODE_EDGE(node_id) ! index for S_NODE_EDGE
454 shoot_struct%S_NODE_EDGE( shift ) = shift_inter - 1 + i ! save the edge ID
455 ENDDO
456 ENDDO
457 ENDIF
458 ENDIF
459 ! ---------------------------
460 IF(nrtm+nrts>0) THEN
461 next_inter = next_inter + 1
462 shoot_struct%SHIFT_INTERFACE(next_inter,1) = shift_inter
463 shoot_struct%SHIFT_INTERFACE(next_inter,2) = nin
464 ENDIF
465 IF(nrtmg>0.AND.(ity==25.AND.ipari(100,nin)/=0)) THEN
466 shoot_struct%SHIFT_INTERFACE2(nin) = shift_inter2
467 shift_inter2 = shift_inter2 + nrtmg
468 ENDIF
469
470 shift_inter = shift_inter + nrtm + nrts
471 ENDDO
472 shoot_struct%SHIFT_INTERFACE(next_inter+1,1) = shift_inter + 1
473 shoot_struct%SHIFT_INTERFACE(ninter+1,1) = shift_inter + 1
474 shoot_struct%SHIFT_INTERFACE(ninter+1,2) = next_inter
475
476
477 DEALLOCATE( work_array )
478
479 ALLOCATE( intersect_1(nspmd) )
480 ALLOCATE( intersect_2(nspmd) )
481 ALLOCATE( result_intersect(nspmd) )
482
483 size_buffer_main(1:nspmd) = 0
484 size_buffer_second(1:nspmd) = 0
485 max_nb_node_per_surface = 4 ! up to 4 nodes per surface
486 chunk = 2 + max_nb_node_per_surface ! up to 4 nodes per surface + surface id + interface id
487 DO nin=1,ninter
488 ity = ipari(7,nin) ! interface id
489 nmn = ipari(6,nin) ! number of main nodes
490 nrtm = ipari(4,nin) ! number of main surfaces/edges
491 nrts = ipari(3,nin) ! number of secondary edges
492 idel = ipari(17,nin)! idel option
493 type_inter = (ity==7.OR.ity==10.OR.ity==11.OR.ity==22.OR.ity==24) ! interface 7/10/11/22/24/25 with idel=1
494 type_inter = (type_inter.OR.(ity==25.AND.ipari(100,nin)==0)) ! interface 7/10/11/22/24/25 with idel=1
495 type_inter = (type_inter.AND.(idel==1)) ! interface 7/10/11/22/24/25 with idel=1
496 ! ----------------------------------------
497 IF((type_inter.AND.(idel==1)).OR.(ity==25.AND.ipari(100,nin)/=0)) THEN
498 IF(.NOT.ALLOCATED(shoot_struct%INTER)) ALLOCATE(shoot_struct%INTER(ninter))
499 if(.NOT.ALLOCATED(shoot_struct%INTER(nin)%REMOTE_ELM_M)) THEN
500 ALLOCATE( shoot_struct%INTER(nin)%REMOTE_ELM_M(nrtm) )
501 ENDIF
502 shoot_struct%INTER(nin)%REMOTE_ELM_M(1:nrtm) = 0
503
504 IF(.NOT.ALLOCATED(shoot_struct%INTER(nin)%REMOTE_ELM_S)) THEN
505 ALLOCATE( shoot_struct%INTER(nin)%REMOTE_ELM_S(nrts) )
506 ENDIF
507 shoot_struct%INTER(nin)%REMOTE_ELM_S(1:nrts) = 0
508 IF(ity==25.AND.ipari(100,nin)/=0) THEN
509 IF(.NOT.ALLOCATED(shoot_struct%INTER)) ALLOCATE(shoot_struct%INTER(ninter))
510 ALLOCATE( shoot_struct%INTER(nin)%NB_ELM_M(nrtm) )
511 shoot_struct%INTER(nin)%NB_ELM_M(1:nrtm) = 0
512 ENDIF
513 ENDIF
514 ! ----------------------------------------
515
516 ! ----------------------------------------
517 IF( (type_inter.OR.(ity==25.AND.ipari(100,nin)/=0)).AND.nspmd>1 ) THEN
518 DO i=1,nspmd
519 IF(.NOT.ALLOCATED(buffer_second(i)%INT_ARRAY_1D)) THEN
520 buffer_second(i)%SIZE_INT_ARRAY_1D = numnod/4+1
521 CALL alloc_1d_array(buffer_second(i))
522 ENDIF
523! if(allocated(BUFFER_MAIN(I)%INT_ARRAY_1D)) deallocate( BUFFER_MAIN(I)%INT_ARRAY_1D )
524 IF(.NOT.ALLOCATED(buffer_main(i)%INT_ARRAY_1D)) THEN
525 buffer_main(i)%SIZE_INT_ARRAY_1D = numnod/4+1
526 CALL alloc_1d_array(buffer_main(i))
527 ENDIF
528 ENDDO
529 nb_node_surf = 4
530 IF(ity==11) nb_node_surf = 2
531 ! ------------------------------------
532 ! loop over the M edge
533 DO i=1,nrtm
534 list_node_id(1) = intbuf_tab(nin)%IRECTM((i-1)*nb_node_surf+1) ! node id N1
535 list_node_id(2) = intbuf_tab(nin)%IRECTM((i-1)*nb_node_surf+2) ! node id N2
536 list_node_id(3) = 0 ! fake node id for interface typ11
537 list_node_id(4) = 0 ! fake node id for interface typ11
538 global_node_id(1) = itab(list_node_id(1)) ! global node id N1
539 global_node_id(2) = itab(list_node_id(2)) ! global node id N2
540 global_node_id(3) = 0 ! fake node id for interface typ11
541 global_node_id(4) = 0 ! fake node id for interface typ11
542
543 nb_real_node = 2 ! number of node per surface (4 for interface type 7 / 2 for interface type 11)
544 IF(ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.ity==25) THEN
545 list_node_id(3) = intbuf_tab(nin)%IRECTM((i-1)*nb_node_surf+3) ! node id N3
546 list_node_id(4) = intbuf_tab(nin)%IRECTM((i-1)*nb_node_surf+4) ! node id N4
547 global_node_id(3) = itab(list_node_id(3)) ! global node id N3
548 global_node_id(4) = itab(list_node_id(4)) ! global node id n4
549 nb_real_node = 4 ! number of node per surface (4 for interface type 7 / 2 for interface type 11)
550 IF(list_node_id(3)==list_node_id(4)) nb_real_node = 3 ! N3 and N4 equal : the surface is defined as a triangle -> only 3 nodes
551 ENDIF
552
553 nb_proc_1 = shoot_struct%SHIFT_M_NODE_PROC(list_node_id(1)+1)
554 . - shoot_struct%SHIFT_M_NODE_PROC(list_node_id(1)) ! get the number of processor of the node
555 nb_proc_2 = shoot_struct%SHIFT_M_NODE_PROC(list_node_id(2)+1)
556 . - shoot_struct%SHIFT_M_NODE_PROC(list_node_id(2)) ! get the number of processor of the node
557 nb_result_intersect = 0
558
559 ! initialize the data for N1
560 shift = shoot_struct%SHIFT_M_NODE_PROC(list_node_id(1))
561 intersect_1(1:nb_proc_1) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc_1 )
562 ! -------------------------
563 ! intersection of node list to find the common processors
564 DO j = 1,nb_real_node-1
565 IF(nb_proc_1>1.AND.nb_proc_2>1) THEN
566 ! initialize the data for N(J+1)
567 shift = shoot_struct%SHIFT_M_NODE_PROC(list_node_id(j+1))
568 nb_proc_2 = shoot_struct%SHIFT_M_NODE_PROC(list_node_id(j+1)+1)
569 . - shoot_struct%SHIFT_M_NODE_PROC(list_node_id(j+1)) ! get the number of processor of the node
570 intersect_2(1:nb_proc_2) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc_2 )
571
572 CALL intersect_2_sorted_sets( intersect_1,nb_proc_1,
573 . intersect_2,nb_proc_2,
574 . result_intersect,nb_result_intersect )
575 ! save the intesected list for the next intersection
576 nb_proc_1 = nb_result_intersect
577 intersect_1(1:nb_result_intersect) = result_intersect(1:nb_result_intersect)
578 ELSE
579 nb_result_intersect = 0
580 nb_proc_1 = 0
581 nb_proc_2 = 0
582 ENDIF
583 ENDDO
584 ! -------------------------
585 IF(nb_result_intersect>1) THEN
586 ! ---------------------
587 ! intersection of node list to find the
588 DO j=1,nb_result_intersect
589 proc_id = result_intersect(j)
590 IF(proc_id/=ispmd+1) THEN
591 IF(size_buffer_main(proc_id)+chunk>buffer_main(proc_id)%SIZE_INT_ARRAY_1D) THEN
592 old_size = buffer_main(proc_id)%SIZE_INT_ARRAY_1D
593 ALLOCATE( work_array(old_size) )
594 work_array(1:old_size) =
595 . buffer_main(proc_id)%INT_ARRAY_1D(1:old_size)
596 CALL dealloc_1d_array(buffer_main(proc_id))
597 buffer_main(proc_id)%SIZE_INT_ARRAY_1D = chunk * (old_size + chunk)
598 CALL alloc_1d_array(buffer_main(proc_id))
599 buffer_main(proc_id)%INT_ARRAY_1D(1:old_size) = work_array(1:old_size)
600 DEALLOCATE( work_array )
601 ENDIF
602 ! 1 : interface id
603 size_buffer_main(proc_id) = size_buffer_main(proc_id) + 1
604 buffer_main(proc_id)%INT_ARRAY_1D( size_buffer_main(proc_id) ) = nin
605 ! 2 : local surface id
606 size_buffer_main(proc_id) = size_buffer_main(proc_id) + 1
607 buffer_main(proc_id)%INT_ARRAY_1D( size_buffer_main(proc_id) ) = i
608 ! 3 : global node id N1
609 size_buffer_main(proc_id) = size_buffer_main(proc_id) + 1
610 buffer_main(proc_id)%INT_ARRAY_1D( size_buffer_main(proc_id) ) = global_node_id(1)
611 ! 4 : global node id N2
612 size_buffer_main(proc_id) = size_buffer_main(proc_id) + 1
613 buffer_main(proc_id)%INT_ARRAY_1D( size_buffer_main(proc_id) ) = global_node_id(2)
614 ! 5 : fake node id for interface type11 / global node id N3 for interface type7
615 size_buffer_main(proc_id) = size_buffer_main(proc_id) + 1
616 buffer_main(proc_id)%INT_ARRAY_1D( size_buffer_main(proc_id) ) = global_node_id(3)
617 ! 6 : fake node id for interface type11 / global node id N3 for interface type7
618 size_buffer_main(proc_id) = size_buffer_main(proc_id) + 1
619 buffer_main(proc_id)%INT_ARRAY_1D( size_buffer_main(proc_id) ) = global_node_id(4)
620 ENDIF
621 ENDDO
622 ! ---------------------
623 ENDIF
624 ENDDO
625 ! ------------------------------------
626 IF(ity==11) THEN
627 ! ---------------------
628 ! loop over the secondary nodes
629 DO i=1,nrts
630 n1 = intbuf_tab(nin)%IRECTS((i-1)*2+1)
631 n2 = intbuf_tab(nin)%IRECTS((i-1)*2+2)
632 nb_proc_1 = shoot_struct%SHIFT_M_NODE_PROC(n1+1) - shoot_struct%SHIFT_M_NODE_PROC(n1) ! get the number of processor of the node
633 nb_proc_2 = shoot_struct%SHIFT_M_NODE_PROC(n2+1) - shoot_struct%SHIFT_M_NODE_PROC(n2) ! get the number of processor of the node
634 IF(nb_proc_1>1.AND.nb_proc_2>1) THEN
635 shift = shoot_struct%SHIFT_M_NODE_PROC(n1)
636 intersect_1(1:nb_proc_1) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc_1 )
637 shift = shoot_struct%SHIFT_M_NODE_PROC(n2)
638 intersect_2(1:nb_proc_2) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc_2 )
639
640 nb_result_intersect = 0
641 CALL intersect_2_sorted_sets( intersect_1,nb_proc_1,
642 . intersect_2,nb_proc_2,
643 . result_intersect,nb_result_intersect )
644
645 IF(nb_result_intersect>1) THEN
646 DO j=1,nb_result_intersect
647 proc_id = result_intersect(j)
648 IF(proc_id/=ispmd+1) THEN
649 IF(size_buffer_second(proc_id)+chunk>buffer_second(proc_id)%SIZE_INT_ARRAY_1D) THEN
650 old_size = buffer_second(proc_id)%SIZE_INT_ARRAY_1D
651 ALLOCATE( work_array(old_size) )
652 work_array(1:old_size) =
653 . buffer_second(proc_id)%INT_ARRAY_1D(1:old_size)
654 CALL dealloc_1d_array(buffer_second(proc_id))
655 buffer_second(proc_id)%SIZE_INT_ARRAY_1D =
656 . chunk * (buffer_second(proc_id)%SIZE_INT_ARRAY_1D + chunk)
657 CALL alloc_1d_array(buffer_second(proc_id))
658 buffer_second(proc_id)%INT_ARRAY_1D(1:old_size) = work_array(1:old_size)
659 DEALLOCATE( work_array )
660 ENDIF
661 ! 1 : interface id
662 size_buffer_second(proc_id) = size_buffer_second(proc_id) + 1
663 buffer_second(proc_id)%INT_ARRAY_1D( size_buffer_second(proc_id) ) = nin
664 ! 2 : local surface id
665 size_buffer_second(proc_id) = size_buffer_second(proc_id) + 1
666 buffer_second(proc_id)%INT_ARRAY_1D( size_buffer_second(proc_id) ) = i
667 ! 3 : global node id N1
668 size_buffer_second(proc_id) = size_buffer_second(proc_id) + 1
669 buffer_second(proc_id)%INT_ARRAY_1D( size_buffer_second(proc_id) ) = itab(n1)
670 ! 4 : global node id N2
671 size_buffer_second(proc_id) = size_buffer_second(proc_id) + 1
672 buffer_second(proc_id)%INT_ARRAY_1D( size_buffer_second(proc_id) ) = itab(n2)
673 ! 5 : fake node id
674 size_buffer_second(proc_id) = size_buffer_second(proc_id) + 1
675 buffer_second(proc_id)%INT_ARRAY_1D( size_buffer_second(proc_id) ) = 0
676 ! 6 : fake node id
677 size_buffer_second(proc_id) = size_buffer_second(proc_id) + 1
678 buffer_second(proc_id)%INT_ARRAY_1D( size_buffer_second(proc_id) ) = 0
679 ENDIF
680 ENDDO
681 ENDIF
682 ENDIF ! proc 1 & proc 2 > 1
683 ENDDO ! loop over the secondary nodes
684 ! ---------------------
685 ENDIF ! type 11 : secondary nodes
686 ! ------------------------------------
687 ENDIF ! type 11 or 7 + idel = 1 + nspmd > 1
688 ! ----------------------------------------
689
690 ! ----------------------------------------
691 IF(ity==25.AND.ipari(100,nin)/=0) THEN
692 DO i=1,nrtm
693 ! check if the current segment is an internal segment
694 IF(intbuf_tab(nin)%STFM(i)<zero) THEN
695 shoot_struct%INTER(nin)%NB_ELM_M(i) = shoot_struct%INTER(nin)%NB_ELM_M(i) + 1
696 IF(intbuf_tab(nin)%IELEM_M(2*(i-1)+2)/=0) THEN
697 shoot_struct%INTER(nin)%NB_ELM_M(i) = shoot_struct%INTER(nin)%NB_ELM_M(i) + 1
698 ENDIF
699 ENDIF
700 ENDDO
701 ENDIF ! type 25 with solid erosion
702 ! ----------------------------------------
703 ENDDO
704 ! ---------------------------
705 IF(nspmd>1) THEN
706#ifdef MPI
707 msgtyp = msgoff1
708 DO i=1,nspmd
709 r_size_buffer_main(i) = 0
710 r_size_buffer_second(i) = 0
711 siz = iad_elem(1,i+1)-iad_elem(1,i)
712 IF(i/=ispmd+1.AND.siz>0) THEN
713 s_buffer_2_int(1,i) = size_buffer_main(i)
714 s_buffer_2_int(2,i) = size_buffer_second(i)
715 CALL mpi_isend(s_buffer_2_int(1,i),2,mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_s(i),ierror)
716 ENDIF
717 IF(i/=ispmd+1.AND.siz>0) THEN
718 CALL mpi_irecv(r_buffer_2_int(1,i),2,mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_r(i),ierror)
719
720 ENDIF
721 ENDDO
722
723 DO i=1,nspmd
724 siz = iad_elem(1,i+1)-iad_elem(1,i)
725 IF(i/=ispmd+1.AND.siz>0) THEN
726 CALL mpi_wait(request_s(i),statu,ierror)
727 CALL mpi_wait(request_r(i),statu,ierror)
728 r_size_buffer_main(i) = r_buffer_2_int(1,i)
729 r_size_buffer_second(i) = r_buffer_2_int(2,i)
730 ENDIF
731 ENDDO
732 DO i=1,nspmd
733 IF(r_size_buffer_main(i)>0) THEN
734 r_buffer_main(i)%SIZE_INT_ARRAY_1D = r_size_buffer_main(i)
735 CALL alloc_1d_array(r_buffer_main(i))
736 CALL mpi_irecv( r_buffer_main(i)%INT_ARRAY_1D,r_buffer_main(i)%SIZE_INT_ARRAY_1D,
737 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_r2(i),ierror )
738 ENDIF
739 IF(r_size_buffer_second(i)>0) THEN
740 r_buffer_second(i)%SIZE_INT_ARRAY_1D = r_size_buffer_second(i)
741 CALL alloc_1d_array(r_buffer_second(i))
742 CALL mpi_irecv( r_buffer_second(i)%INT_ARRAY_1D,r_buffer_second(i)%SIZE_INT_ARRAY_1D,
743 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_r3(i),ierror )
744 ENDIF
745 IF(size_buffer_main(i)>0) THEN
746 CALL mpi_isend( buffer_main(i)%INT_ARRAY_1D,size_buffer_main(i),
747 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_s2(i),ierror )
748 ENDIF
749 IF(size_buffer_second(i)>0) THEN
750 CALL mpi_isend( buffer_second(i)%INT_ARRAY_1D,size_buffer_second(i),
751 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_s3(i),ierror )
752 ENDIF
753 ENDDO
754 DO i=1,nspmd
755 siz = iad_elem(1,i+1)-iad_elem(1,i)
756 IF(size_buffer_main(i)>0) CALL mpi_wait(request_s2(i),statu,ierror)
757 IF(r_size_buffer_main(i)>0) CALL mpi_wait(request_r2(i),statu,ierror)
758 IF(size_buffer_second(i)>0) CALL mpi_wait(request_s3(i),statu,ierror)
759 IF(r_size_buffer_second(i)>0) CALL mpi_wait(request_r3(i),statu,ierror)
760 ENDDO
761 DO i=1,nspmd
762 IF(r_buffer_main(i)%SIZE_INT_ARRAY_1D>0) THEN
763 CALL count_remote_nb_elem_edge( r_buffer_main(i)%SIZE_INT_ARRAY_1D,r_buffer_main(i)%INT_ARRAY_1D,
764 . geo,ixs,ixc,ixt,ixp,ixr,ixtg,addcnel,nodes,cnel,chunk,ixs10)
765 CALL mpi_isend( r_buffer_main(i)%INT_ARRAY_1D,r_buffer_main(i)%SIZE_INT_ARRAY_1D,
766 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_s2(i),ierror )
767
768 ENDIF
769 IF(r_buffer_second(i)%SIZE_INT_ARRAY_1D>0) THEN
770 CALL count_remote_nb_elem_edge( r_buffer_second(i)%SIZE_INT_ARRAY_1D,r_buffer_second(i)%INT_ARRAY_1D,
771 . geo,ixs,ixc,ixt,ixp,ixr,ixtg,addcnel,nodes,cnel,chunk,ixs10 )
772 CALL mpi_isend( r_buffer_second(i)%INT_ARRAY_1D,r_buffer_second(i)%SIZE_INT_ARRAY_1D,
773 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_s3(i),ierror)
774 ENDIF
775 IF(size_buffer_main(i)>0) THEN
776 CALL mpi_irecv( buffer_main(i)%INT_ARRAY_1D,size_buffer_main(i),
777 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_r2(i),ierror )
778 ENDIF
779 IF(size_buffer_second(i)>0) THEN
780 CALL mpi_irecv( buffer_second(i)%INT_ARRAY_1D,size_buffer_second(i),
781 . mpi_integer,it_spmd(i),msgtyp,spmd_comm_world,request_r3(i),ierror )
782 ENDIF
783 ENDDO
784 DO i=1,nspmd
785 siz = iad_elem(1,i+1)-iad_elem(1,i)
786 IF(r_buffer_main(i)%SIZE_INT_ARRAY_1D>0) THEN
787 CALL mpi_wait(request_s2(i),statu,ierror)
788 CALL dealloc_1d_array(r_buffer_main(i))
789 ENDIF
790 IF(size_buffer_main(i)>0) THEN
791 CALL mpi_wait(request_r2(i),statu,ierror)
792 CALL count_nb_elem_edge( 1,size_buffer_main(i),buffer_main(i)%INT_ARRAY_1D,shoot_struct,chunk)
793 CALL dealloc_1d_array(buffer_main(i))
794 ENDIF
795 IF(r_buffer_second(i)%SIZE_INT_ARRAY_1D>0) THEN
796 CALL mpi_wait(request_s3(i),statu,ierror)
797 CALL dealloc_1d_array(r_buffer_second(i))
798 ENDIF
799 IF(size_buffer_second(i)>0) THEN
800 CALL mpi_wait(request_r3(i),statu,ierror)
801 CALL count_nb_elem_edge( 2,size_buffer_second(i),buffer_second(i)%INT_ARRAY_1D,shoot_struct,chunk)
802 CALL dealloc_1d_array(buffer_second(i))
803 ENDIF
804 ENDDO
805#endif
806 ENDIF
807 ! ---------------------------
808
809 DEALLOCATE( work_array_2 )
810 DEALLOCATE( work_array_3 )
811
812 DEALLOCATE( intersect_1 )
813 DEALLOCATE( intersect_2 )
814 DEALLOCATE( result_intersect )
815
816 DEALLOCATE( buffer_second )
817 DEALLOCATE( buffer_main )
818 DEALLOCATE( r_buffer_second )
819 DEALLOCATE( r_buffer_main )
820 ! --------------------------------
821 ! WORKING ARRAY
822 ! --------------------------------
823 IF(.NOT.ALLOCATED(shoot_struct%GLOBAL_NB_ELEM_OFF)) THEN
824 ALLOCATE( shoot_struct%GLOBAL_NB_ELEM_OFF(nthread) ) ! number of deactivated element for each thread
825 ENDIF
826
827 ! ---------------------------
828 ! Only for interface type 24 & 25
829 shoot_struct%NUMBER_REMOTE_SURF = 0 ! number of deactivated potential remote surface for interface type 24 & 25
830 shoot_struct%SIZE_REMOTE_SURF = 0 ! size of array of REMOTE_SURF (list of potential remote deactivated surfaces)
831 IF(ALLOCATED(shoot_struct%REMOTE_SURF)) DEALLOCATE( shoot_struct%REMOTE_SURF )
832 ALLOCATE( shoot_struct%REMOTE_SURF( shoot_struct%SIZE_REMOTE_SURF ) ) ! list of potential remote deactivated surfaces
833 ! ---------------------------
834
835 ! ---------------------------
836 ! Only for interface type 25
837 shoot_struct%NUMBER_NEW_SURF = 0 ! number of new active segment/surface for interface type 25
838 shoot_struct%SIZE_NEW_SURF = 0 ! size of array of NEW_SURF
839 IF(ALLOCATED(shoot_struct%NEW_SURF)) DEALLOCATE( shoot_struct%NEW_SURF )
840 ALLOCATE( shoot_struct%NEW_SURF( shoot_struct%SIZE_NEW_SURF ) ) ! list of new active segment/surface
841 ! ---------------------------
842
843 RETURN
844 END SUBROUTINE init_nodal_state
count_nb_elem_edge
subroutine count_nb_elem_edge(mode, size_buffer, buffer, shoot_struct, chunk)
Definition count_nb_elem_edge.F:31
count_remote_nb_elem_edge
subroutine count_remote_nb_elem_edge(size_buffer, buffer, geo, ixs, ixc, ixt, ixp, ixr, ixtg, addcnel, nodes, cnel, chunk, ixs10)
Definition count_remote_nb_elem_edge.F:33
my_real
#define my_real
Definition cppsort.cpp:32
the
end diagonal values have been computed in the(sparse) matrix id.SOL
init_nodal_state
subroutine init_nodal_state(ipari, shoot_struct, intbuf_tab, iad_elem, fr_elem, itab, nodes, geo, addcnel, cnel, ixs, ixc, ixt, ixp, ixr, ixtg, size_addcnel, size_cnel, numelsg, numelqg, numelcg, numeltrg, numelpg, numelrg, numeltgg, ixs10)
Definition init_nodal_state.F:44
array_mod::alloc_1d_array
Definition array_mod.F:95
array_mod::dealloc_1d_array
Definition array_mod.F:99
max
#define max(a, b)
Definition macros.h:21
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
id
initmumps id
Definition multiplerhs_example.m:4
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
myqsort_int
subroutine myqsort_int(n, a, perm, error)
Definition myqsort_int.F:36
array_mod
Definition array_mod.F:51
shooting_node_mod
Definition shooting_node_mod.F:46
array_mod::array_type
Definition array_mod.F:61
shooting_node_mod::shooting_node_type
Definition shooting_node_mod.F:83