OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
init_nodal_state.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "task_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "tabsiz_c.inc"
#include "com01_c.inc"

Go to the source code of this file.

Functions/Subroutines

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)

Function/Subroutine Documentation

◆ init_nodal_state()

subroutine init_nodal_state ( integer, dimension(npari,ninter), intent(in) ipari,
type(shooting_node_type), intent(inout) shoot_struct,
type(intbuf_struct_), dimension(ninter), intent(inout) intbuf_tab,
integer, dimension(2,nspmd+1), intent(in) iad_elem,
integer, dimension(sfr_elem), intent(in) fr_elem,
integer, dimension(numnod), intent(in) itab,
type(nodal_arrays_), intent(inout) nodes,
intent(in) geo,
integer, dimension(0:size_addcnel), intent(in) addcnel,
integer, dimension(0:size_cnel), intent(in) cnel,
integer, dimension(nixs,numels), intent(in), target ixs,
integer, dimension(nixc,numelc), intent(in), target ixc,
integer, dimension(nixt,numelt), intent(in), target ixt,
integer, dimension(nixp,numelp), intent(in), target ixp,
integer, dimension(nixr,numelr), intent(in), target ixr,
integer, dimension(nixtg,numeltg), intent(in), target ixtg,
integer, intent(in) size_addcnel,
integer, intent(in) size_cnel,
integer, intent(in) numelsg,
integer, intent(in) numelqg,
integer, intent(in) numelcg,
integer, intent(in) numeltrg,
integer, intent(in) numelpg,
integer, intent(in) numelrg,
integer, intent(in) numeltgg,
integer, dimension(6,numels10), intent(in) ixs10 )
Parameters
[in]size_cnelarray size : cnel & addcnel
[in]numelsgglobal number of solid
[in]numelqgglobal number of quad
[in]numelcgglobal number of shell
[in]numeltrgglobal number of truss
[in]numelpgglobal number of beam
[in]numelrgglobal number of spring
[in]numeltggglobal number of shell3n
[in]iad_elemadress for frontier node
[in]fr_elemfrontier node id
[in,out]shoot_structstructure for shooting node algo
[in,out]intbuf_tabinterface data
[in]itabarray to convert local id to global id
[in,out]nodesnodal data
[in]addcneladdress for the CNEL array
[in]cnelconnectivity node --> element
[in]ixssolid array
[in]ixcshell array
[in]ixttruss array
[in]ixpbeam array
[in]ixrspring array
[in]ixtgtriangle array
[in]ixs10tetra10 data

Definition at line 43 of file init_nodal_state.F.

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