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