OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_sphvox.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "task_c.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_sphvox (kxsp, spbuf, wsp2sort, bminmal, x)

Function/Subroutine Documentation

◆ spmd_sphvox()

subroutine spmd_sphvox ( integer, dimension(nisp,*) kxsp,
spbuf,
integer, dimension(*) wsp2sort,
bminmal,
x )

Definition at line 40 of file spmd_sphvox.F.

41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE sphbox
45 USE tri7box
46 USE message_mod
47C-----------------------------------------------
48C I m p l i c i t T y p e s
49C-----------------------------------------------
50 USE spmd_comm_world_mod, ONLY : spmd_comm_world
51#include "implicit_f.inc"
52C-----------------------------------------------
53C M e s s a g e P a s s i n g
54C-----------------------------------------------
55#include "spmd.inc"
56C-----------------------------------------------
57C C o m m o n B l o c k s
58C-----------------------------------------------
59#include "com01_c.inc"
60#include "task_c.inc"
61#include "sphcom.inc"
62C-----------------------------------------------
63C D u m m y A r g u m e n t s
64C-----------------------------------------------
65 INTEGER KXSP(NISP,*), WSP2SORT(*)
66 my_real
67 . x(3,*),bminmal(*), spbuf(nspbuf,*)
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71#ifdef MPI
72 INTEGER P, KK, I, J, NOD, N, MSGTYP, LOC_PROC, NBIRECV,
73 . IERROR, IERROR1, L, LEN, IDEB, INDEXI, NB,
74 . NBX, NBY, NBZ,
75 . IX1, IX2, IY1, IY2, IZ1, IZ2, IX, IY, IZ,
76 . REQ_RB(NSPMD), REQ_SB(NSPMD), REQ_SD(NSPMD),
77 . REQ_RD(NSPMD), REQ_SD2(NSPMD), REQ_SC(NSPMD),
78 . REQ_RC(NSPMD),
79 . IRINDEXI(NSPMD), ISINDEXI(NSPMD), NBO(NSPMD),
80 . INDEX(NSP2SORT), STATUS(MPI_STATUS_SIZE),
81 . MSGOFF,MSGOFF2,MSGOFF3,MSGOFF4
82 my_real
83 . bminma(6,nspmd),alpha_marge,
84 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
85 . aaa
86 TYPE(real_pointer), DIMENSION(NSPMD) :: BUF
87 my_real, dimension(:), allocatable :: sbuf,rbuf
88 DATA msgoff/2023/
89 DATA msgoff2/2024/
90 DATA msgoff3/2025/
91 DATA msgoff4/2026/
92
93 INTEGER :: P_LOC
94 INTEGER :: SEND_SIZE_BMINMA
95 INTEGER :: REQUEST_BMINMA
96 INTEGER :: RCV_SIZE_BMINMA,TOTAL_RCV_SIZE_BMINMA
97
98 INTEGER :: SEND_SIZE_CRVOX
99 INTEGER :: REQUEST_CRVOX
100 INTEGER :: RCV_SIZE_CRVOX,TOTAL_RCV_SIZE_CRVOX
101 INTEGER, DIMENSION(0:LRVOXEL,0:LRVOXEL) :: CRVOXEL_LOC
102
103 INTEGER, DIMENSION(:,:), ALLOCATABLE :: INDEX_P
104 INTEGER, DIMENSION(NSPMD) :: NB_P
105 INTEGER :: REQUEST_NBO
106
107 INTEGER, DIMENSION(NSPMD) :: SEND_SIZE_SBUF,DISPLS_SBUF
108 INTEGER :: TOTAL_SEND_SIZE,TOTAL_RCV_SIZE_RBUF
109 INTEGER, DIMENSION(NSPMD) :: RCV_SIZE_RBUF,DISPLS_RBUF
110 INTEGER :: REQUEST_SBUF
111
112
113C-----------------------------------------------
114C S o u r c e L i n e s
115C-----------------------------------------------
116C
117C=======================================================================
118C tag des boites contenant des facettes
119C et creation des candidats
120C=======================================================================
121 ALLOCATE( index_p(nsp2sort,nspmd) )
122 alpha_marge = sqrt(one +spasort)
123 loc_proc = ispmd + 1
124 psphs = 0
125 nbx = lrvoxel
126 nby = lrvoxel
127 nbz = lrvoxel
128
129C
130C
131 bminma(1,loc_proc) = bminmal(1)
132 bminma(2,loc_proc) = bminmal(2)
133 bminma(3,loc_proc) = bminmal(3)
134 bminma(4,loc_proc) = bminmal(4)
135 bminma(5,loc_proc) = bminmal(5)
136 bminma(6,loc_proc) = bminmal(6)
137C
138C envoi voxel + boite min/max
139C
140 send_size_bminma = 6
141 rcv_size_bminma = 6
142 total_rcv_size_bminma = 6*nspmd
143! -------------------------
144! allgather communication with uniform size
145! for real array : send : BMINMAL --> rcv : BMINMAL
146 CALL spmd_iallgather(bminmal,bminma,send_size_bminma,
147 . total_rcv_size_bminma,rcv_size_bminma,
148 . request_bminma,spmd_comm_world)
149! -------------------------
150
151
152 send_size_crvox = (lrvoxel+1)*(lrvoxel+1)
153 rcv_size_crvox = (lrvoxel+1)*(lrvoxel+1)
154 total_rcv_size_crvox = (lrvoxel+1)*(lrvoxel+1)*nspmd
155 crvoxel_loc(0:lrvoxel,0:lrvoxel) = crvoxel(0:lrvoxel,0:lrvoxel,loc_proc)
156
157! -------------------------
158! allgather communication with uniform size
159! for integer array : send : CRVOXEL_LOC --> rcv : CRVOXEL
160 CALL spmd_iallgather_int(crvoxel_loc(0,0),crvoxel(0,0,1),send_size_crvox,
161 . total_rcv_size_crvox,rcv_size_crvox,
162 . request_crvox,spmd_comm_world)
163! -------------------------
164C
165C envoi de XREM
166C
167
168#if _PLMPI
169! -------------------------
170! PLMPI uses MPI-2.x version without non blocking allgather comm
171! -------------------------
172#else
173! -------------------------
174! wait the previous comms : BMINMAL --> BMINMAL
175! CRVOXEL_LOC --> CRVOXEL
176 CALL mpi_wait(request_bminma,status,ierror)
177 CALL mpi_wait(request_crvox,status,ierror)
178! -------------------------
179#endif
180
181
182! -------------------------
183! fill the buffer NBO
184 ideb = 1
185 nb_p(1:nspmd) = 0
186 nbo(1:nspmd) = 0
187 DO p = 1, nspmd
188 if(p==loc_proc) cycle
189 l = ideb
190 nb_p(p) = 0
191 xmaxb = bminma(1,p)
192 ymaxb = bminma(2,p)
193 zmaxb = bminma(3,p)
194 xminb = bminma(4,p)
195 yminb = bminma(5,p)
196 zminb = bminma(6,p)
197
198 DO i=1, nsp2sort
199 n=wsp2sort(i)
200 nod=kxsp(3,n)
201 aaa = spbuf(1,n)* alpha_marge
202 ix1=int(nbx*(x(1,nod)-xminb-aaa)/(xmaxb-xminb))
203 ix2=int(nbx*(x(1,nod)-xminb+aaa)/(xmaxb-xminb))
204 IF(ix1 > nbx) cycle
205 IF(ix2 < 0) cycle
206 iy1=int(nby*(x(2,nod)-yminb-aaa)/(ymaxb-yminb))
207 iy2=int(nby*(x(2,nod)-yminb+aaa)/(ymaxb-yminb))
208 IF(iy1 > nby) cycle
209 IF(iy2 < 0) cycle
210 iz1=int(nbz*(x(3,nod)-zminb-aaa)/(zmaxb-zminb))
211 iz2=int(nbz*(x(3,nod)-zminb+aaa)/(zmaxb-zminb))
212 IF(iz1 > nbz) cycle
213 IF(iz2 < 0) cycle
214
215 ix1=max(0,min(ix1,nbx))
216 ix2=min(nbx,max(ix2,0))
217 iy1=max(0,min(iy1,nby))
218 iy2=min(nby,max(iy2,0))
219 iz1=max(0,min(iz1,nbz))
220 iz2=min(nbz,max(iz2,0))
221
222
223 DO iz = iz1,iz2
224 DO iy = iy1,iy2
225 DO ix = ix1,ix2
226 IF(btest(crvoxel(iy,iz,p),ix)) THEN
227 nb_p(p) = nb_p(p) + 1
228 index_p(nb_p(p),p) = n
229 GOTO 100
230 ENDIF
231 ENDDO
232 ENDDO
233 ENDDO
234
235 100 CONTINUE
236
237 ENDDO
238 nbo(p) = nb_p(p)
239 psphs(p) = nb_p(p)
240 ENDDO
241! -------------------------
242
243 psphr(1:nspmd) = 0
244! -------------------------
245! alltoall communication with uniform size
246! for integer array : send : NBO --> rcv : PSPHR
247 CALL spmd_ialltoall_int(nbo,psphr,nspmd,1,
248 . nspmd,1,request_nbo,spmd_comm_world)
249! -------------------------
250
251C
252 l = 0
253 DO p=1,nspmd
254 l = l + sizspt*nb_p(p)
255 ENDDO
256 ALLOCATE(sbuf(l))
257
258 l = 0
259 DO p = 1, nspmd
260 if(p==loc_proc) cycle
261 IF (nb_p(p)>0) THEN
262 DO j = 1, nb_p(p)
263 n = index_p(j,p)
264 nod = kxsp(3,n)
265 sbuf(l+1) = n
266 sbuf(l+2) = spbuf(1,n)
267 sbuf(l+3) = x(1,nod)
268 sbuf(l+4) = x(2,nod)
269 sbuf(l+5) = x(3,nod)
270 sbuf(l+6) = kxsp(8,n)
271 l = l + sizspt
272 END DO
273 END IF
274 END DO
275
276C
277 ! Total number of particules to send
278 nsphs = 0
279 DO p = 1, nspmd
280 IF(loc_proc /=p) THEN
281 nsphs = nsphs + psphs(p)
282 ENDIF
283 ENDDO
284
285
286 ! Array of local number of particules to send (sorted by proc)
287 IF(ALLOCATED(lsphs))DEALLOCATE(lsphs)
288 ALLOCATE(lsphs(nsphs),stat=ierror)
289
290 IF(ALLOCATED(dks))DEALLOCATE(dks)
291 ALLOCATE(dks(nsphs),stat=ierror1)
292 ierror = ierror1 + ierror
293
294
295 IF(ierror/=0) THEN
296 CALL ancmsg(msgid=20,anmode=aninfo)
297 CALL arret(2)
298 END IF
299 lsphs = 0
300 dks = -one
301 ! Fill LSPHS with local numbers
302 ideb = 0
303 l = 0
304 DO p = 1, nspmd
305 IF(loc_proc /=p) THEN
306#include "novectorize.inc"
307 DO i = 1,psphs(p)
308 ideb = ideb + 1
309 lsphs(ideb) = sbuf(l+1) !BUF(P)%P(L+1)
310 l = l + sizspt
311 ENDDO
312 ENDIF
313 ENDDO
314
315C
316 nsphr = 0
317 l=0
318#if _PLMPI
319! -------------------------
320! PLMPI uses MPI-2.x version without non blocking alltoall comm
321! -------------------------
322#else
323! -------------------------
324! wait the previous comm : NBO --> PSPHR
325 CALL mpi_wait(request_nbo,status,ierror)
326! -------------------------
327#endif
328
329 DO p = 1, nspmd
330! PSPHR(P) = 0
331 IF(loc_proc/=p) THEN
332 IF(psphr(p)>0) THEN
333 l=l+1
334 isindexi(l)=p
335 nsphr = nsphr + psphr(p)
336 END IF
337 END IF
338 END DO
339 nbirecv=l
340C
341! -------------------------
342! compute the displacement, number of element
343! and total number of element (send and rcv)
344 send_size_sbuf(1:nspmd) = 0
345 displs_sbuf(1:nspmd) = 0
346 rcv_size_rbuf(1:nspmd) = 0
347 displs_rbuf(1:nspmd) = 0
348
349 displs_sbuf(1) = 0
350 send_size_sbuf(1) = sizspt*nb_p(1)
351 total_send_size = send_size_sbuf(1)
352 DO p=2,nspmd
353 send_size_sbuf(p) = sizspt*nb_p(p)
354 displs_sbuf(p) = displs_sbuf(p-1) + send_size_sbuf(p-1)
355 total_send_size = total_send_size + send_size_sbuf(p)
356 ENDDO
357
358 rcv_size_rbuf(1) = psphr(1)*sizspt
359 total_rcv_size_rbuf = rcv_size_rbuf(1)
360 displs_rbuf(1) = 0
361 DO p=2,nspmd
362 rcv_size_rbuf(p) = psphr(p)*sizspt
363 displs_rbuf(p) = displs_rbuf(p-1) + rcv_size_rbuf(p-1)
364 total_rcv_size_rbuf = total_rcv_size_rbuf + rcv_size_rbuf(p)
365 ENDDO
366! -------------------------
367
368 ierror = 0
369 IF(ALLOCATED(xsphr))DEALLOCATE(xsphr)
370 ALLOCATE(xsphr(sizspt,nsphr),stat=ierror1)
371 ierror = ierror1 + ierror
372
373 IF(ALLOCATED(dkr))DEALLOCATE(dkr)
374 ALLOCATE(dkr(nsphr),stat=ierror1)
375 ierror = ierror1 + ierror
376
377 IF(ierror/=0) THEN
378 CALL ancmsg(msgid=20,anmode=aninfo)
379 CALL arret(2)
380 END IF
381 xsphr = 0
382 dkr = -one
383
384! -------------------------
385! alltoall communication with non-uniform size
386! for real array : send : SBUF --> rcv : XSPHR
387 CALL spmd_ialltoallv(sbuf,xsphr,send_size_sbuf,total_send_size,displs_sbuf,
388 . total_rcv_size_rbuf,rcv_size_rbuf,displs_rbuf,
389 . request_sbuf,spmd_comm_world,nspmd)
390! -------------------------
391
392#if _PLMPI
393! -------------------------
394! PLMPI uses MPI-2.x version without non blocking alltoall comm
395! -------------------------
396#else
397! -------------------------
398! wait the previous comm : SBUF --> XSPHR
399 CALL mpi_wait(request_sbuf,status,ierror)
400! -------------------------
401#endif
402
403 DEALLOCATE( sbuf )
404 DEALLOCATE( index_p )
405
406#endif
407 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
message_mod
Definition message_mod.F:1249
sphbox::lsphs
integer, dimension(:), allocatable lsphs
Definition sphbox.F:91
sphbox::psphr
integer, dimension(:), allocatable psphr
Definition sphbox.F:89
sphbox::psphs
integer, dimension(:), allocatable psphs
Definition sphbox.F:89
sphbox::sizspt
integer, parameter sizspt
Definition sphbox.F:85
sphbox::nsphr
integer nsphr
Definition sphbox.F:83
sphbox::nsphs
integer nsphs
Definition sphbox.F:83
tri7box::crvoxel
integer, dimension(0:lrvoxel, 0:lrvoxel) crvoxel
Definition tri7box.F:56
tri7box::lrvoxel
integer lrvoxel
Definition tri7box.F:54
spmd_iallgather
subroutine spmd_iallgather(sendbuf, recvbuf, send_size, total_rcv_size, rcv_size, request, comm)
Definition spmd_iallgather.F:31
spmd_iallgather_int
subroutine spmd_iallgather_int(sendbuf, recvbuf, send_size, total_rcv_size, rcv_size, request, comm)
Definition spmd_iallgather_int.F:31
spmd_ialltoall_int
subroutine spmd_ialltoall_int(sendbuf, recvbuf, total_send_size, send_size, total_rcv_size, rcv_size, request, comm)
Definition spmd_ialltoall_int.F:32
spmd_ialltoallv
subroutine spmd_ialltoallv(sendbuf, recvbuf, send_size, total_send_size, sdispls, total_rcv_size, rcv_size, rdispls, request, comm, nb_proc)
Definition spmd_ialltoallv.F:34
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