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,KK,IJK,KJI
108 INTEGER :: P,P_LOC
109 INTEGER :: ADRESS,SHIFT_
110 INTEGER :: ISIZ,RSIZ,IDEB,JDEB
111 INTEGER :: NSN,NMN,IGAP,INTTH,INTFRIC,ITYP,ITIED
112 INTEGER :: IFQ,INACTI
113
114 INTEGER IERROR1,STATUS(MPI_STATUS_SIZE),IERROR
115
116 INTEGER :: LOC_PROC
117 INTEGER :: IX,IY,IZ,NB
118 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX
119 INTEGER :: ISHIFT,RSHIFT
120
121 INTEGER :: MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4, MSGOFF5
122 INTEGER :: MSGTYP,INFO
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 LOGICAL :: NEED_TO_RCV
130
131 INTEGER :: NB_INDEX_ALREADY_SEND,VALUE,NB_SAVE
132! --------------------------------------------------------------------
133 DATA msgoff/6021/
134 DATA msgoff2/6022/
135 DATA msgoff3/6023/
136 DATA msgoff4/6024/
137 DATA msgoff5/6025/
138
139 loc_proc = ispmd + 1
140 rsiz = sort_comm(nin)%RSIZ
141 isiz = sort_comm(nin)%ISIZ
142
143 igap = ipari(21,nin)
144 intth = ipari(47,nin)
145 intfric = ipari(72,nin)
146 ityp = ipari(7,nin)
147 itied = ipari(85,nin)
148 nmn = ipari(6,nin)
149 nsn = ipari(5,nin)
150 inacti = ipari(22,nin)
151 ifq =ipari(31,nin)
152 nb_index_already_send= 0
153 ! ---------------------------------
154 IF(ircvfrom(nin,loc_proc)/=0.OR.isendto(nin,loc_proc)/=0) THEN
155 ! ---------------------------------
156 ! only the proc with secondary nodes send theirs data
157 IF(isendto(nin,loc_proc)/=0) THEN ! local nsn >0
158
159 p=sort_comm(nin)%PROC_LIST(remote_proc_id) ! proc ID
160 ! ----------------------------
161 ! skip the frontier nodes with weight = 0
162 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
163 nod = fr_elem(j)
164 weight(nod) = weight(nod)*(-1)
165 ENDDO
166 ! ----------------------------
167
168 sort_comm(nin)%NB(p) = 0
169 nb = 0
170 ALLOCATE(index(2*numnod))
171 ! --------------------------
172 IF(itied/=0.AND.ityp==7) THEN
173 ! itied/=0 --> need to send all nodes
174 DO i=1,nsn
175 nod = intbuf_tab(nin)%NSV(i)
176 IF(weight(nod)==1)THEN
177 IF(candf_si(nin)%P(i)/=0.AND.intbuf_tab(nin)%STFNS(i)>zero)THEN
178 nb = nb + 1
179 index(nb) = i
180 ENDIF
181 ENDIF
182 ENDDO
183 ENDIF
184 ! --------------------------
185 ! loop over the cell of proc REMOTE_PROC_ID
186 displ = sort_comm(nin)%RCV_DISPLS_CELL(remote_proc_id)
187 shift_ = sort_comm(nin)%NB_CELL_PROC(remote_proc_id)
188 ijk = 0
189 DO kji=1,sort_comm(nin)%NB_CELL_PROC(remote_proc_id)
190 ! ----------------------
191 ! get the cell ID
192 ijk = ijk + 1
193 VALUE = sort_comm(nin)%CELL( displ + ijk )
194 cell_z_id = ( VALUE - mod(VALUE,1000000) ) / 1000000
195 VALUE = VALUE - cell_z_id * 1000000
196 cell_y_id = ( VALUE - mod(VALUE,1000) ) / 1000
197 VALUE = VALUE - cell_y_id * 1000
198 cell_x_id = VALUE
199
200 IF(.NOT.already_send(cell_x_id,cell_y_id,cell_z_id)) THEN
201 nb_index_already_send = nb_index_already_send + 1
202 index_already_send(nb_index_already_send) = cell_x_id+cell_y_id*1000+cell_z_id*1000000
203 already_send(cell_x_id,cell_y_id,cell_z_id) = .true.
204
205 ! ----------------------
206 ! loop over the secondary nodes of cell ID (CELL_X_ID,CELL_Y_ID,CELL_Z_ID)
207 i = sort_comm(nin)%VOXEL(cell_x_id,cell_y_id,cell_z_id)
208 DO WHILE(i/=0)
209 nod = intbuf_tab(nin)%NSV(i)
210 IF(weight(nod)==1)THEN
211 IF(intbuf_tab(nin)%STFNS(i)>zero)THEN
212 nb = nb + 1
213 index(nb) = i
214 ENDIF
215 ENDIF
216 i = sort_comm(nin)%NEXT_NOD(i)
217 ENDDO ! WHILE(I/=0)
218 ! ----------------------
219 ENDIF
220 ENDDO
221 ! --------------------------
222 ! flush ALREADY_SEND to FALSE
223 DO i=1,nb_index_already_send
224 VALUE = index_already_send(i)
225 cell_z_id = ( VALUE - mod(VALUE,1000000) ) / 1000000
226 VALUE = VALUE - cell_z_id * 1000000
227 cell_y_id = ( VALUE - mod(VALUE,1000) ) / 1000
228 VALUE = VALUE - cell_y_id * 1000
229 cell_x_id = VALUE
230 already_send(cell_x_id,cell_y_id,cell_z_id) = .false.
231 ENDDO
232 ! --------------------------
233 ! need to sort the secondary nodes
234 nb_save = nb
235 IF(nb_save>1600) THEN
236 ALLOCATE( work(70000) )
237 ALLOCATE( itri(nb_save) )
238 ALLOCATE( index_2(2*nb_save) )
239 DO i=1,nb_save
240 itri(i) = index(i)
241 index_2(i) = i
242 ENDDO
243 CALL my_orders(0,work,itri,index_2,nb_save,1)
244 nb = 1
245 index(nb) = itri(index_2(1))
246 DO i=2,nb_save
247 IF(itri(index_2(i-1))/=itri(index_2(i))) THEN
248 nb = nb + 1
249 index(nb) = itri(index_2(i))
250 ENDIF
251 ENDDO
252 DEALLOCATE( work )
253 DEALLOCATE( itri )
254 DEALLOCATE( index_2 )
255 ELSEIF(nb_save>0) THEN
256 ALLOCATE( index_2(nb_save) )
257 CALL myqsort_int(nb_save, index, index_2, error_sort)
258 index_2(1:nb_save) = index(1:nb_save)
259 nb = 1
260 DO i=2,nb_save
261 IF(index(i)/=index(i-1)) THEN
262 nb = nb + 1
263 index_2(nb) = index(i)
264 ENDIF
265 ENDDO
266 index(1:nb) = index_2(1:nb)
267 DEALLOCATE( index_2 )
268 ENDIF
269
270 ! save the number of secondary nodes
271 sort_comm(nin)%NB(p) = nb
272 ! --------------------------
273
274 ! --------------------------
275 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
276 nod = fr_elem(j)
277 weight(nod) = weight(nod)*(-1)
278 ENDDO
279 ! --------------------------
280
281 ! --------------------------
282 ! send the number of secondary nodes
283 msgtyp = msgoff3
284 sort_comm(nin)%NBSEND_NB=sort_comm(nin)%NBSEND_NB+1
285 sort_comm(nin)%SEND_NB(sort_comm(nin)%NBSEND_NB)=p ! proc with nmn>0
286 CALL mpi_isend(sort_comm(nin)%NB(p),1,mpi_integer,it_spmd(p),msgtyp,
287 . spmd_comm_world,sort_comm(nin)%REQUEST_NB_S(sort_comm(nin)%NBSEND_NB),ierror)
288
289 ! --------------------------
290 ! buffer allocation & buffer initialization
291 IF (nb>0) THEN
292 ALLOCATE( sort_comm(nin)%DATA_PROC(p)%RBUF(rsiz*nb),stat=ierror)
293 ALLOCATE( sort_comm(nin)%DATA_PROC(p)%IBUF(isiz*nb),stat=ierror)
294 IF(ierror/=0) THEN
295 CALL ancmsg(msgid=20,anmode=aninfo)
296 CALL arret(2)
297 ENDIF
298
299 l = 0
300 l2= 0
301
302#include "vectorize.inc"
303 DO j = 1, nb
304 i = index(j)
305 nod = intbuf_tab(nin)%NSV(i)
306 sort_comm(nin)%DATA_PROC(p)%RBUF(l+1) = x(1,nod)
307 sort_comm(nin)%DATA_PROC(p)%RBUF(l+2) = x(2,nod)
308 sort_comm(nin)%DATA_PROC(p)%RBUF(l+3) = x(3,nod)
309 sort_comm(nin)%DATA_PROC(p)%RBUF(l+4) = v(1,nod)
310 sort_comm(nin)%DATA_PROC(p)%RBUF(l+5) = v(2,nod)
311 sort_comm(nin)%DATA_PROC(p)%RBUF(l+6) = v(3,nod)
312 sort_comm(nin)%DATA_PROC(p)%RBUF(l+7) = ms(nod)
313 sort_comm(nin)%DATA_PROC(p)%RBUF(l+8) = intbuf_tab(nin)%STFNS(i)
314 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+1) = i
315 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+2) = itab(nod)
316 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+3) = kinet(nod)
317! save specifics IREM and XREM indexes for INT24 sorting
318 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+4) = 0 !IGAPXREMP
319 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+5) = 0 !I24XREMP
320 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+6) = 0 !I24IREMP
321 l = l + rsiz
322 l2 = l2 + isiz
323 END DO
324
325c shift for real variables (prepare for next setting)
326 rshift = 9
327c shift for integer variables (prepare for next setting)
328 ishift = 7
329
330c specific cases
331c IGAP=1 or IGAP=2
332 IF(igap==1 .OR. igap==2)THEN
333 l = 0
334 igapxremp = rshift
335#include "vectorize.inc"
336 DO j = 1, nb
337 i = index(j)
338 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift)= intbuf_tab(nin)%GAP_S(i)
339 l = l + rsiz
340 ENDDO
341 rshift = rshift + 1
342c IGAP=3
343 ELSEIF(igap==3)THEN
344 l = 0
345 igapxremp = rshift
346#include "vectorize.inc"
347 DO j = 1, nb
348 i = index(j)
349 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift) = intbuf_tab(nin)%GAP_S(i)
350 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift+1)= intbuf_tab(nin)%GAP_SL(i)
351 l = l + rsiz
352 END DO
353 rshift = rshift + 2
354 ENDIF
355
356C thermic
357 IF(intth>0)THEN
358 l = 0
359 l2 = 0
360#include "vectorize.inc"
361 DO j = 1, nb
362 i = index(j)
363 nod = intbuf_tab(nin)%NSV(i)
364 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift) = temp(nod)
365 sort_comm(nin)%DATA_PROC(p)%RBUF(l+rshift+1) = intbuf_tab(nin)%AREAS(i)
366 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift) = intbuf_tab(nin)%IELEC(i)
367 l = l + rsiz
368 l2 = l2 + isiz
369 END DO
370 rshift = rshift + 2
371 ishift = ishift + 1
372 ENDIF
373C Friction
374 IF(intfric>0)THEN
375 l2 = 0
376#include "vectorize.inc"
377 DO j = 1, nb
378 i = index(j)
379 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift) = intbuf_tab(nin)%IPARTFRICS(i)
380 l2 = l2 + isiz
381 END DO
382 ishift = ishift + 1
383 ENDIF
384C -- IDTMINS==2
385 IF(idtmins==2)THEN
386 l2 = 0
387#include "vectorize.inc"
388 DO j = 1, nb
389 i = index(j)
390 nod = intbuf_tab(nin)%NSV(i)
391 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift) = nodnx_sms(nod)
392 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift+1)= nod
393 l2 = l2 + isiz
394 END DO
395 ishift = ishift + 2
396C -- IDTMINS_INT /= 0
397 ELSEIF(idtmins_int/=0)THEN
398 l2 = 0
399#include "vectorize.inc"
400 DO j = 1, nb
401 i = index(j)
402 nod = intbuf_tab(nin)%NSV(i)
403 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+ishift)= nod
404 l2 = l2 + isiz
405 END DO
406 ishift = ishift + 1
407 ENDIF
408 !save specifics IREM and XREM indexes for INT24 sorting
409 l2 = 0
410#include "vectorize.inc"
411 DO j = 1, nb
412 i = index(j)
413 nod = intbuf_tab(nin)%NSV(i)
414 !save specifics IREM and XREM indexes for INT24 sorting
415 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+4) = igapxremp
416 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+5) = i24xremp
417 sort_comm(nin)%DATA_PROC(p)%IBUF(l2+6) = i24iremp
418 l2 = l2 + isiz
419 END DO
420 ENDIF ! if nb/=0
421 DEALLOCATE(index)
422 ! ------------------------------
423 ENDIF
424 ENDIF ! nsn>0 or nmn > 0
425 ! ---------------------------------
426#endif
427 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:36
inter_sorting_mod
Definition inter_sorting_mod.F:57
message_mod
Definition message_mod.F:1249
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:889
arret
subroutine arret(nn)
Definition arret.F:87