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

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_cell_size_exchange (ircvfrom, isendto, weight, iad_elem, fr_elem, x, v, ms, temp, kinet, nodnx_sms, itab, intbuf_tab, ipari, nin, remote_proc_id, already_send, index_already_send, sort_comm, nodnx_sms_siz, temp_size)

Function/Subroutine Documentation

◆ spmd_cell_size_exchange()

subroutine spmd_cell_size_exchange ( integer, dimension(ninter+1,nspmd+1), intent(in) ircvfrom,
integer, dimension(ninter+1,nspmd+1), intent(in) isendto,
integer, dimension(numnod), intent(inout) weight,
integer, dimension(2,nspmd+1), intent(in) iad_elem,
integer, dimension(sfr_elem), intent(in) fr_elem,
intent(in) x,
intent(in) v,
intent(in) ms,
intent(in) temp,
integer, dimension(numnod), intent(in) kinet,
integer, dimension(nodnx_sms_siz), intent(in) nodnx_sms,
integer, dimension(numnod), intent(in) itab,
type(intbuf_struct_), dimension(ninter), intent(in) intbuf_tab,
integer, dimension(npari,ninter), intent(in) ipari,
integer, intent(in) nin,
integer, intent(in) remote_proc_id,
logical, dimension(nb_cell_x,nb_cell_y,nb_cell_z), intent(inout) already_send,
integer, dimension(nb_cell_x*nb_cell_y*nb_cell_z), intent(inout) index_already_send,
type(sorting_comm_type), dimension(ninter), intent(inout) sort_comm,
integer, intent(in) nodnx_sms_siz,
integer, intent(in) temp_size )

Definition at line 39 of file spmd_cell_size_exchange.F.

42!$COMMENT
43! SPMD_CELL_SIZE_EXCHANGE description :
44! check if the remote processor need some secondary nodes
45! and sent them if necessary
46! remote proc needs seondary nodes if one or several cells were colored by main nodes
47! if yes --> send all the seconcadry nodes of the cell
48! secondary nodes must be sorted according to theirs global IDs (for parith/on purpose)
49! SPMD_CELL_SIZE_EXCHANGE organization :
50! loop over the cells of the remote proc and :
51! * check if 1 or several secondary nodes are in the correct remote proc & send the number of secondary nodes to the remote proc
52! * if yes: - save the ID of the secondary nodes
53! - sort the ID according to the global secondary node ID (parith/on)!
54! - fill the buffer with the data of the secondary nodes (position/velocity...)
55!$ENDCOMMENT
56C-----------------------------------------------
57C M o d u l e s
58C-----------------------------------------------
59 USE intbufdef_mod
60 USE message_mod
61 USE inter_sorting_mod
62 USE tri7box
63C-----------------------------------------------
64C I m p l i c i t T y p e s
65C-----------------------------------------------
66 USE spmd_comm_world_mod, ONLY : spmd_comm_world
67#include "implicit_f.inc"
68C-----------------------------------------------
69C M e s s a g e P a s s i n g
70C-----------------------------------------------
71#include "spmd.inc"
72C-----------------------------------------------
73C C o m m o n B l o c k s
74C-----------------------------------------------
75#include "com01_c.inc"
76#include "com04_c.inc"
77#include "task_c.inc"
78#include "sms_c.inc"
79#include "param_c.inc"
80#include "tabsiz_c.inc"
81C-----------------------------------------------
82C D u m m y A r g u m e n t s
83C-----------------------------------------------
84 INTEGER, INTENT(in) :: NIN
85 INTEGER,INTENT(in) :: REMOTE_PROC_ID
86 INTEGER, INTENT(in) :: NODNX_SMS_SIZ ! size of NODNX_SMS
87 INTEGER, INTENT(in) :: TEMP_SIZE ! size of TEMP
88 INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI
89 INTEGER, DIMENSION(NINTER+1,NSPMD+1), INTENT(in) :: ISENDTO,IRCVFROM
90 INTEGER, DIMENSION(NUMNOD), INTENT(inout) :: WEIGHT
91 INTEGER, DIMENSION(2,NSPMD+1), INTENT(in) :: IAD_ELEM
92 INTEGER, DIMENSION(SFR_ELEM), INTENT(in) :: FR_ELEM
93 my_real, DIMENSION(3,NUMNOD), INTENT(in) :: x,v
94 my_real, DIMENSION(NUMNOD), INTENT(in) :: ms
95 my_real, DIMENSION(TEMP_SIZE), INTENT(in) :: temp
96 INTEGER, DIMENSION(NUMNOD), INTENT(in) :: ITAB
97 INTEGER, DIMENSION(NUMNOD), INTENT(in) :: KINET ! k energy
98 INTEGER, DIMENSION(NODNX_SMS_SIZ), INTENT(in) :: NODNX_SMS ! SMS array
99 TYPE(INTBUF_STRUCT_), DIMENSION(NINTER), INTENT(in) :: INTBUF_TAB
100 LOGICAL, DIMENSION(NB_CELL_X,NB_CELL_Y,NB_CELL_Z), INTENT(inout) :: ALREADY_SEND
101 INTEGER, DIMENSION(NB_CELL_X*NB_CELL_Y*NB_CELL_Z), INTENT(inout) :: INDEX_ALREADY_SEND
102 TYPE(sorting_comm_type), DIMENSION(NINTER), INTENT(inout) :: SORT_COMM ! structure for interface sorting comm
103C-----------------------------------------------
104C L o c a l V a r i a b l e s
105C-----------------------------------------------
106#ifdef MPI
107 INTEGER :: I,J,NOD,L,L2,IJK,KJI
108 INTEGER :: P
109 INTEGER :: SHIFT_
110 INTEGER :: ISIZ,RSIZ
111 INTEGER :: NSN,NMN,IGAP,INTTH,INTFRIC,ITYP,ITIED
112 INTEGER :: IFQ,INACTI
113
114 INTEGER IERROR
115
116 INTEGER :: LOC_PROC
117 INTEGER :: NB
118 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX
119 INTEGER :: ISHIFT,RSHIFT
120
121 INTEGER :: MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4, MSGOFF5
122 INTEGER :: MSGTYP
123
124 INTEGER :: ERROR_SORT
125 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX_2,ITRI
126 INTEGER, DIMENSION(:), ALLOCATABLE :: WORK
127 INTEGER :: CELL_X_ID,CELL_Y_ID,CELL_Z_ID
128 INTEGER :: DISPL
129
130 INTEGER :: NB_INDEX_ALREADY_SEND,VALUE,NB_SAVE
131! --------------------------------------------------------------------
132 DATA msgoff/6021/
133 DATA msgoff2/6022/
134 DATA msgoff3/6023/
135 DATA msgoff4/6024/
136 DATA msgoff5/6025/
137
138 loc_proc = ispmd + 1
139 rsiz = sort_comm(nin)%RSIZ
140 isiz = sort_comm(nin)%ISIZ
141
142 igap = ipari(21,nin)
143 intth = ipari(47,nin)
144 intfric = ipari(72,nin)
145 ityp = ipari(7,nin)
146 itied = ipari(85,nin)
147 nmn = ipari(6,nin)
148 nsn = ipari(5,nin)
149 inacti = ipari(22,nin)
150 ifq =ipari(31,nin)
151 nb_index_already_send= 0
152 ! ---------------------------------
153 IF(ircvfrom(nin,loc_proc)/=0.OR.isendto(nin,loc_proc)/=0) THEN
154 ! ---------------------------------
155 ! only the proc with secondary nodes send theirs data
156 IF(isendto(nin,loc_proc)/=0) THEN ! local nsn >0
157
158 p=sort_comm(nin)%PROC_LIST(remote_proc_id) ! proc ID
159 ! ----------------------------
160 ! skip the frontier nodes with weight = 0
161 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
162 nod = fr_elem(j)
163 weight(nod) = weight(nod)*(-1)
164 ENDDO
165 ! ----------------------------
166
167 sort_comm(nin)%NB(p) = 0
168 nb = 0
169 ALLOCATE(index(2*numnod))
170 ! --------------------------
171 IF(itied/=0.AND.ityp==7) THEN
172 ! itied/=0 --> need to send all nodes
173 DO i=1,nsn
174 nod = intbuf_tab(nin)%NSV(i)
175 IF(weight(nod)==1)THEN
176 IF(candf_si(nin)%P(i)/=0.AND.intbuf_tab(nin)%STFNS(i)>zero)THEN
177 nb = nb + 1
178 index(nb) = i
179 ENDIF
180 ENDIF
181 ENDDO
182 ENDIF
183 ! --------------------------
184 ! loop over the cell of proc REMOTE_PROC_ID
185 displ = sort_comm(nin)%RCV_DISPLS_CELL(remote_proc_id)
186 shift_ = sort_comm(nin)%NB_CELL_PROC(remote_proc_id)
187 ijk = 0
188 DO kji=1,sort_comm(nin)%NB_CELL_PROC(remote_proc_id)
189 ! ----------------------
190 ! get the cell ID
191 ijk = ijk + 1
192 VALUE = sort_comm(nin)%CELL( displ + ijk )
193 cell_z_id = ( VALUE - mod(VALUE,1000000) ) / 1000000
194 VALUE = VALUE - cell_z_id * 1000000
195 cell_y_id = ( VALUE - mod(VALUE,1000) ) / 1000
196 VALUE = VALUE - cell_y_id * 1000
197 cell_x_id = VALUE
198
199 IF(.NOT.already_send(cell_x_id,cell_y_id,cell_z_id)) THEN
200 nb_index_already_send = nb_index_already_send + 1
201 index_already_send(nb_index_already_send) = cell_x_id+cell_y_id*1000+cell_z_id*1000000
202 already_send(cell_x_id,cell_y_id,cell_z_id) = .true.
203
204 ! ----------------------
205 ! loop over the secondary nodes of cell ID (CELL_X_ID,CELL_Y_ID,CELL_Z_ID)
206 i = sort_comm(nin)%VOXEL(cell_x_id,cell_y_id,cell_z_id)
207 DO WHILE(i/=0)
208 nod = intbuf_tab(nin)%NSV(i)
209 IF(weight(nod)==1)THEN
210 IF(intbuf_tab(nin)%STFNS(i)>zero)THEN
211 nb = nb + 1
212 index(nb) = i
213 ENDIF
214 ENDIF
215 i = sort_comm(nin)%NEXT_NOD(i)
216 ENDDO ! WHILE(I/=0)
217 ! ----------------------
218 ENDIF
219 ENDDO
220 ! --------------------------
221 ! flush ALREADY_SEND to FALSE
222 DO i=1,nb_index_already_send
223 VALUE = index_already_send(i)
224 cell_z_id = ( VALUE - mod(VALUE,1000000) ) / 1000000
225 VALUE = VALUE - cell_z_id * 1000000
226 cell_y_id = ( VALUE - mod(VALUE,1000) ) / 1000
227 VALUE = VALUE - cell_y_id * 1000
228 cell_x_id = VALUE
229 already_send(cell_x_id,cell_y_id,cell_z_id) = .false.
230 ENDDO
231 ! --------------------------
232 ! need to sort the secondary nodes
233 nb_save = nb
234 IF(nb_save>1600) THEN
235 ALLOCATE( work(70000) )
236 ALLOCATE( itri(nb_save) )
237 ALLOCATE( index_2(2*nb_save) )
238 DO i=1,nb_save
239 itri(i) = index(i)
240 index_2(i) = i
241 ENDDO
242 CALL my_orders(0,work,itri,index_2,nb_save,1)
243 nb = 1
244 index(nb) = itri(index_2(1))
245 DO i=2,nb_save
246 IF(itri(index_2(i-1))/=itri(index_2(i))) THEN
247 nb = nb + 1
248 index(nb) = itri(index_2(i))
249 ENDIF
250 ENDDO
251 DEALLOCATE( work )
252 DEALLOCATE( itri )
253 DEALLOCATE( index_2 )
254 ELSEIF(nb_save>0) THEN
255 ALLOCATE( index_2(nb_save) )
256 CALL myqsort_int(nb_save, index, index_2, error_sort)
257 index_2(1:nb_save) = index(1:nb_save)
258 nb = 1
259 DO i=2,nb_save
260 IF(index(i)/=index(i-1)) THEN
261 nb = nb + 1
262 index_2(nb) = index(i)
263 ENDIF
264 ENDDO
265 index(1:nb) = index_2(1:nb)
266 DEALLOCATE( index_2 )
267 ENDIF
268
269 ! save the number of secondary nodes
270 sort_comm(nin)%NB(p) = nb
271 ! --------------------------
272
273 ! --------------------------
274 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
275 nod = fr_elem(j)
276 weight(nod) = weight(nod)*(-1)
277 ENDDO
278 ! --------------------------
279
280 ! --------------------------
281 ! send the number of secondary nodes
282 msgtyp = msgoff3
283 sort_comm(nin)%NBSEND_NB=sort_comm(nin)%NBSEND_NB+1
284 sort_comm(nin)%SEND_NB(sort_comm(nin)%NBSEND_NB)=p ! proc with nmn>0
285 CALL mpi_isend(sort_comm(nin)%NB(p),1,mpi_integer,it_spmd(p),msgtyp,
286 . spmd_comm_world,sort_comm(nin)%REQUEST_NB_S(sort_comm(nin)%NBSEND_NB),ierror)
287
288 ! --------------------------
289 ! buffer allocation & buffer initialization
290 IF (nb>0) THEN
291 ALLOCATE( sort_comm(nin)%DATA_PROC(p)%RBUF(rsiz*nb),stat=ierror)
292 ALLOCATE( sort_comm(nin)%DATA_PROC(p)%IBUF(isiz*nb),stat=ierror)
293 IF(ierror/=0) THEN
294 CALL ancmsg(msgid=20,anmode=aninfo)
295 CALL arret(2)
296 ENDIF
297
298 l = 0
299 l2= 0
300
301#include "vectorize.inc"
302 DO j = 1, nb
303 i = index(j)
304 nod = intbuf_tab(nin)%NSV(i)
305 sort_comm(nin)%DATA_PROC(p)%RBUF(l+1) = x(1,nod)
306 sort_comm(nin)%DATA_PROC(p)%RBUF(l+2) = x(2,nod)
307 sort_comm(nin)%DATA_PROC(p)%RBUF(l+3) = x(3,nod)
308 sort_comm(nin)%DATA_PROC(p)%RBUF(l+4) = v(1,nod)
309 sort_comm(nin)%DATA_PROC(p)%RBUF(l+5) = v(2,nod)
310 sort_comm(nin)%DATA_PROC(p)%RBUF(l+6) = v(3,nod)
311 sort_comm(nin)%DATA_PROC(p)%RBUF(l+7) = ms(nod)
312 sort_comm(nin)%DATA_PROC(p)%RBUF(l+8) = intbuf_tab(nin)%STFNS(i)
313 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+1) = i
314 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+2) = itab(nod)
315 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+3) = kinet(nod)
316! save specifics IREM and XREM indexes for INT24 sorting
317 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+4) = 0 !IGAPXREMP
318 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+5) = 0 !I24XREMP
319 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+6) = 0 !I24IREMP
320 l = l + rsiz
321 l2 = l2 + isiz
322 END DO
323
324c shift for real variables (prepare for next setting)
325 rshift = 9
326c shift for integer variables (prepare for next setting)
327 ishift = 7
328
329c specific cases
330c IGAP=1 or IGAP=2
331 IF(igap==1 .OR. igap==2)THEN
332 l = 0
333 igapxremp = rshift
334#include "vectorize.inc"
335 DO j = 1, nb
336 i = index(j)
337 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift)= intbuf_tab(nin)%GAP_S(i)
338 l = l + rsiz
339 ENDDO
340 rshift = rshift + 1
341c IGAP=3
342 ELSEIF(igap==3)THEN
343 l = 0
344 igapxremp = rshift
345#include "vectorize.inc"
346 DO j = 1, nb
347 i = index(j)
348 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift) = intbuf_tab(nin)%GAP_S(i)
349 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift+1)= intbuf_tab(nin)%GAP_SL(i)
350 l = l + rsiz
351 END DO
352 rshift = rshift + 2
353 ENDIF
354
355C thermic
356 IF(intth>0)THEN
357 l = 0
358 l2 = 0
359#include "vectorize.inc"
360 DO j = 1, nb
361 i = index(j)
362 nod = intbuf_tab(nin)%NSV(i)
363 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift) = temp(nod)
364 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift+1) = intbuf_tab(nin)%AREAS(i)
365 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift) = intbuf_tab(nin)%IELEC(i)
366 l = l + rsiz
367 l2 = l2 + isiz
368 END DO
369 rshift = rshift + 2
370 ishift = ishift + 1
371 ENDIF
372C Friction
373 IF(intfric>0)THEN
374 l2 = 0
375#include "vectorize.inc"
376 DO j = 1, nb
377 i = index(j)
378 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift) = intbuf_tab(nin)%IPARTFRICS(i)
379 l2 = l2 + isiz
380 END DO
381 ishift = ishift + 1
382 ENDIF
383C -- IDTMINS==2
384 IF(idtmins==2)THEN
385 l2 = 0
386#include "vectorize.inc"
387 DO j = 1, nb
388 i = index(j)
389 nod = intbuf_tab(nin)%NSV(i)
390 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift) = nodnx_sms(nod)
391 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift+1)= nod
392 l2 = l2 + isiz
393 END DO
394 ishift = ishift + 2
395C -- IDTMINS_INT /= 0
396 ELSEIF(idtmins_int/=0)THEN
397 l2 = 0
398#include "vectorize.inc"
399 DO j = 1, nb
400 i = index(j)
401 nod = intbuf_tab(nin)%NSV(i)
402 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift)= nod
403 l2 = l2 + isiz
404 END DO
405 ishift = ishift + 1
406 ENDIF
407 !save specifics IREM and XREM indexes for INT24 sorting
408 l2 = 0
409#include "vectorize.inc"
410 DO j = 1, nb
411 i = index(j)
412 nod = intbuf_tab(nin)%NSV(i)
413 !save specifics IREM and XREM indexes for INT24 sorting
414 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+4) = igapxremp
415 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+5) = i24xremp
416 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+6) = i24iremp
417 l2 = l2 + isiz
418 END DO
419 ENDIF ! if nb/=0
420 DEALLOCATE(index)
421 ! ------------------------------
422 ENDIF
423 ENDIF ! nsn>0 or nmn > 0
424 ! ---------------------------------
425#endif
426 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
myqsort_int
subroutine myqsort_int(n, a, perm, error)
Definition myqsort_int.F:35
inter_sorting_mod
Definition inter_sorting_mod.F:57
message_mod
Definition message_mod.F:1257
tri7box::candf_si
type(int_pointer), dimension(:), allocatable candf_si
Definition tri7box.F:560
tri7box::i24iremp
integer i24iremp
Definition tri7box.F:423
tri7box::i24xremp
integer i24xremp
Definition tri7box.F:423
tri7box::igapxremp
integer igapxremp
Definition tri7box.F:423
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895
arret
subroutine arret(nn)
Definition arret.F:86