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

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_sphgat (kxsp, ixsp, wsp2sort, ireduce, lgauge)

Function/Subroutine Documentation

◆ spmd_sphgat()

subroutine spmd_sphgat ( integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) wsp2sort,
integer ireduce,
integer, dimension(3,*) lgauge )

Definition at line 37 of file spmd_sphgat.F.

38C-----------------------------------------------
39C M o d u l e s
40C-----------------------------------------------
41 USE sphbox
42 USE message_mod
43C-----------------------------------------------
44C I m p l i c i t T y p e s
45C-----------------------------------------------
46 USE spmd_comm_world_mod, ONLY : spmd_comm_world
47#include "implicit_f.inc"
48C-----------------------------------------------
49C M e s s a g e P a s s i n g
50C-----------------------------------------------
51#include "spmd.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "com04_c.inc"
57#include "task_c.inc"
58#include "sphcom.inc"
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER KXSP(NISP,*),IXSP(KVOISPH,*),
63 . WSP2SORT(*), IREDUCE, LGAUGE(3,*)
64C-----------------------------------------------
65C L o c a l V a r i a b l e s
66C-----------------------------------------------
67#ifdef MPI
68 INTEGER P, I, NN, N, NN0, NSP, IDEB, INITV, IG,
69 . MSGTYP, LOC_PROC, NBIRECV,
70 . IERROR, IERROR1, LEN, NVOIS1, NVOIS2,
71 . REQ_SD(NSPMD), REQ_SD2(NSPMD),
72 . INDEX(NSPHR), STATUS(MPI_STATUS_SIZE),
73 . MSGOFF,MSGOFF2
74 my_real
75 . xsphtmp(sizspt,nsphr), sbufcom(2,nspmd),bufcom(2,nspmd)
76
77 INTEGER :: REQUEST_SBUF
78
79 INTEGER :: REQUEST_INDEX
80 INTEGER, DIMENSION(NSPMD) :: DISPLS_INDEX,DISPLS_LSPHS
81 INTEGER, DIMENSION(NSPMD) :: SEND_SIZE_INDEX,RCV_SIZE_LSPHS
82 INTEGER ::TOTAL_SEND_SIZE_INDEX,TOTAL_RCV_SIZE_LSPHS
83 DATA msgoff/2004/
84 DATA msgoff2/2005/
85C-----------------------------------------------
86C S o u r c e L i n e s
87C-----------------------------------------------
88 loc_proc = ispmd+1
89
90C Compactage des structures
91C
92 ideb = 0
93 nn = 0
94 DO p = 1, nspmd
95 IF(p/=loc_proc)THEN
96 sbufcom(1,p) = ireduce
97 nsp = psphr(p)
98 nn0 = nn
99 DO i = 1, nsp
100 IF(xsphr(1,i+ideb)<zero)THEN
101 nn = nn + 1
102 index(i+ideb) = nn
103 xsphtmp(1,nn) = -xsphr(1,i+ideb)
104 xsphtmp(2,nn) = xsphr(2,i+ideb)
105 xsphtmp(3,nn) = xsphr(3,i+ideb)
106 xsphtmp(4,nn) = xsphr(4,i+ideb)
107 xsphtmp(5,nn) = xsphr(5,i+ideb)
108 xsphtmp(6,nn) = xsphr(6,i+ideb)
109 END IF
110 END DO
111 ideb = ideb + nsp
112 psphr(p) = nn-nn0
113 msgtyp = msgoff
114 sbufcom(2,p) = psphr(p)
115 ELSE
116 sbufcom(1:2,p) = zero
117 END IF
118 END DO
119
120! -------------------------
121! alltoall communication with uniform size
122! for real array : send : SBUFCOM --> rcv : BUFCOM
123 CALL spmd_ialltoall(sbufcom,bufcom,2*nspmd,2,
124 . 2*nspmd,2,request_sbuf,spmd_comm_world)
125! -------------------------
126
127
128 nsphr = nn
129C
130 ierror = 0
131 IF(ALLOCATED(xsphr))DEALLOCATE(xsphr)
132C reallocation avec nouveau NSPHR sur la taille totale
133 ALLOCATE(xsphr(sizspc,nsphr),stat=ierror1)
134 ierror = ierror + ierror1
135 IF(ALLOCATED(wacompr))DEALLOCATE(wacompr)
136C reallocation WACOMPR en prevision echange spforcp et splissv
137 ALLOCATE(wacompr(sizspw,nsphr),stat=ierror1)
138 ierror = ierror + ierror1
139C reallocation des tags cellule active a recevoir
140 IF(ALLOCATED(isphr))DEALLOCATE(isphr)
141
142 ALLOCATE(isphr(nsphr),stat=ierror1)
143 ierror = ierror + ierror1
144 IF(nspcond>0) THEN
145C reallocation du tableau gerant les particules symetrisees
146 IF(ALLOCATED(ispsymr))DEALLOCATE(ispsymr)
147 ALLOCATE(ispsymr(nspcond,nsphr),stat=ierror1)
148 ierror = ierror + ierror1
149 END IF
150 IF(ierror/=0) THEN
151 CALL ancmsg(msgid=20,anmode=aninfo)
152 CALL arret(2)
153 END IF
154 xsphr = 0
155
156C recopie + init
157 IF(nspcond>0)THEN
158C si condition de symetrie alors pas d'optimisation sur particules active
159C car particule symetrique de particule inactive eventuellement active
160 initv = 1
161 ELSE
162 initv = 0
163 END IF
164 DO i = 1, nsphr
165 xsphr(1,i) = xsphtmp(1,i)
166 xsphr(2,i) = xsphtmp(2,i)
167 xsphr(3,i) = xsphtmp(3,i)
168 xsphr(4,i) = xsphtmp(4,i)
169 xsphr(5,i) = xsphtmp(5,i)
170 xsphr(6,i) = xsphtmp(6,i)
171 isphr(i) = initv
172 END DO
173C
174C Renumerotation + selection particules actives
175C
176 DO i=1, nsp2sort
177 n=wsp2sort(i)
178 nvois1 = kxsp(4,n)
179 nvois2 = kxsp(5,n)
180 DO nn = 1, nvois1
181 IF(ixsp(nn,n)<zero) THEN
182C renumerotation
183 ixsp(nn,n) = -index(-ixsp(nn,n))
184C flag differenciant les cellules actives des autres
185 isphr(-ixsp(nn,n)) = 1
186 END IF
187 END DO
188 DO nn = nvois1+1,nvois2
189 IF(ixsp(nn,n)<zero) THEN
190C renumerotation
191 ixsp(nn,n) = -index(-ixsp(nn,n))
192 END IF
193 END DO
194 END DO
195C
196C Gauges : Renumerotation + selection particules actives
197C
198 DO ig=1, nbgauge
199 IF(lgauge(1,ig) > -(numels+1))cycle
200 n=numsph+ig
201 nvois1 = kxsp(4,n)
202 nvois2 = kxsp(5,n)
203 DO nn = 1, nvois1
204 IF(ixsp(nn,n)<zero) THEN
205C renumerotation
206 ixsp(nn,n) = -index(-ixsp(nn,n))
207C flag differenciant les cellules actives des autres
208 isphr(-ixsp(nn,n)) = 1
209 END IF
210 END DO
211 DO nn = nvois1+1,nvois2
212 IF(ixsp(nn,n)<zero) THEN
213C renumerotation
214 ixsp(nn,n) = -index(-ixsp(nn,n))
215 END IF
216 END DO
217 END DO
218C
219C Renvoi frontiere
220C
221 ideb = 0
222 DO p = 1, nspmd
223 nsp = psphr(p)
224 IF(loc_proc/=p.AND.nsp>0)THEN
225 DO i = 1, nsp
226 index(ideb+i) = nint(xsphr(1,i+ideb))
227 END DO
228 msgtyp = msgoff2
229 ideb = ideb + nsp
230 END IF
231 END DO
232C
233C Reception
234C
235
236#if _PLMPI
237! -------------------------
238! PLMPI uses MPI-2.x version without non blocking alltoallv comm
239! -------------------------
240#else
241! -------------------------
242! wait the previous comm : SBUFCOM/RBUFCOM
243 CALL mpi_wait(request_sbuf,status,ierror)
244! -------------------------
245#endif
246
247 nsphs = 0
248 DO p = 1, nspmd
249 IF(p/=loc_proc)THEN
250 msgtyp = msgoff
251 ireduce = max(ireduce,nint(bufcom(1,p)))
252 psphs(p) = nint(bufcom(2,p))
253 nsphs = nsphs + psphs(p)
254 END IF
255 END DO
256C reallocation liste cellule a envoyer
257 IF(ALLOCATED(lsphs))DEALLOCATE(lsphs)
258 ALLOCATE(lsphs(nsphs),stat=ierror)
259C reallocation des tags cellule active a envoyer
260 IF(ALLOCATED(isphs))DEALLOCATE(isphs)
261 ALLOCATE(isphs(nsphs),stat=ierror1)
262 ierror = ierror + ierror1
263 IF(ierror/=0) THEN
264 CALL ancmsg(msgid=20,anmode=aninfo)
265 CALL arret(2)
266 END IF
267 ideb = 1
268 DO p = 1, nspmd
269 IF(p/=loc_proc.AND.psphs(p)>0)THEN
270 msgtyp = msgoff2
271 ideb = ideb + psphs(p)
272 END IF
273 END DO
274
275! -------------------------
276! compute the displacement, number of element
277! and total number of element (send and rcv)
278 displs_index(1:nspmd) = 0
279 displs_lsphs(1:nspmd) = 0
280 send_size_index(1:nspmd) = 0
281 rcv_size_lsphs(1:nspmd) = 0
282 total_send_size_index = 0
283 total_rcv_size_lsphs = 0
284
285
286 displs_index(1) = 0
287 displs_lsphs(1) = 0
288 DO p=1,nspmd
289 IF(p/=loc_proc) THEN
290 send_size_index(p) = psphr(p)
291 rcv_size_lsphs(p) = psphs(p)
292 ENDIF
293 total_send_size_index = total_send_size_index + send_size_index(p)
294 total_rcv_size_lsphs = total_rcv_size_lsphs + rcv_size_lsphs(p)
295 ENDDO
296 DO p=2,nspmd
297 displs_index(p) = displs_index(p-1) + send_size_index(p-1)
298 displs_lsphs(p) = displs_lsphs(p-1) + rcv_size_lsphs(p-1)
299 ENDDO
300! -------------------------
301
302
303! -------------------------
304! alltoall communication with non-uniform size
305! for integer array : send : INDEX --> rcv : LSPHS
306 CALL spmd_ialltoallv_int(index,lsphs,
307 . send_size_index,total_send_size_index,displs_index,
308 . total_rcv_size_lsphs,rcv_size_lsphs,displs_lsphs,
309 . request_index,spmd_comm_world,nspmd)
310! -------------------------
311
312#if _PLMPI
313! -------------------------
314! PLMPI uses MPI-2.x version without non blocking alltoallv comm
315! -------------------------
316#else
317! -------------------------
318! wait the previous comm
319 CALL mpi_wait(request_index,status,ierror)
320! -------------------------
321#endif
322C
323#endif
324 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
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::isphs
integer, dimension(:), allocatable isphs
Definition sphbox.F:87
sphbox::lsphs
integer, dimension(:), allocatable lsphs
Definition sphbox.F:91
sphbox::isphr
integer, dimension(:), allocatable isphr
Definition sphbox.F:87
sphbox::psphr
integer, dimension(:), allocatable psphr
Definition sphbox.F:89
sphbox::sizspc
integer, parameter sizspc
Definition sphbox.F:85
sphbox::psphs
integer, dimension(:), allocatable psphs
Definition sphbox.F:89
sphbox::sizspt
integer, parameter sizspt
Definition sphbox.F:85
sphbox::sizspw
integer, parameter sizspw
Definition sphbox.F:85
sphbox::ispsymr
integer, dimension(:,:), allocatable ispsymr
Definition sphbox.F:93
sphbox::nsphr
integer nsphr
Definition sphbox.F:83
sphbox::nsphs
integer nsphs
Definition sphbox.F:83
spmd_ialltoall
subroutine spmd_ialltoall(sendbuf, recvbuf, total_send_size, send_size, total_rcv_size, rcv_size, request, comm)
Definition spmd_ialltoall.F:32
spmd_ialltoallv_int
subroutine spmd_ialltoallv_int(sendbuf, recvbuf, send_size, total_send_size, sdispls, total_rcv_size, rcv_size, rdispls, request, comm, nb_proc)
Definition spmd_ialltoallv_int.F:35
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