OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_exch_smst2.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23
24
25!||====================================================================
26!|| spmd_exch_smst2 ../engine/source/mpi/ams/spmd_exch_smst2.F
27!||--- called by ------------------------------------------------------
28!|| sms_ini_int ../engine/source/ams/sms_init.F
29!||--- calls -----------------------------------------------------
30!|| ancmsg ../engine/source/output/message/message.F
31!|| arret ../engine/source/system/arret.F
32!|| spmd_check_tag ../engine/source/mpi/ams/spmd_check_tag.F
33!||--- uses -----------------------------------------------------
34!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
35!|| message_mod ../engine/share/message_module/message_mod.F
36!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
37!|| tri7box ../engine/share/modules/tri7box.F
38!||====================================================================
39 SUBROUTINE spmd_exch_smst2(IPARI,TAG,INTLIST,NBINTC,INTBUF_TAB)
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE tri7box
44 USE message_mod
45 USE intbufdef_mod
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49 USE spmd_comm_world_mod, ONLY : spmd_comm_world
50#include "implicit_f.inc"
51C-----------------------------------------------
52C M e s s a g e P a s s i n g
53#include "spmd.inc"
54C-----------------------------------------------
55C C o m m o n B l o c k s
56C-----------------------------------------------
57#include "param_c.inc"
58#include "com04_c.inc"
59#include "task_c.inc"
60#include "com01_c.inc"
61C-----------------------------------------------
62C D u m m y A r g u m e n t s
63C-----------------------------------------------
64 INTEGER, INTENT(IN) :: NBINTC
65 INTEGER, DIMENSION(NPARI,*), INTENT(IN) :: IPARI
66 INTEGER, DIMENSION(NUMNOD), INTENT(IN) :: TAG(NUMNOD)
67 INTEGER, DIMENSION(*), INTENT(IN) :: INTLIST(*)
68 TYPE(intbuf_struct_),DIMENSION(NINTER) :: INTBUF_TAB
69! ********************************************************
70! * variable * type * size * intent * feature
71! *------------*--------*---------*----------*-------------
72! * NBINTC * integ. * 1 * in * number of interf. (/=2)
73! * INTLIST * integ. * NBINTC * in * kind of interface (/=2)
74! * IPARI * integ. * NPARI,: * in * size of TAG
75! * TAG * integ. * NUMNOD * in * tag array
76! * INTBUF_TAB * struct.* * inout * interface pointer
77C-----------------------------------------------
78C L o c a l V a r i a b l e s
79C-----------------------------------------------
80#ifdef mpi
81 INTEGER STATUS(MPI_STATUS_SIZE),
82 * REQ_SI(PARASIZ),REQ_RI(PARASIZ),REQ_S(PARASIZ),
83 * REQ_S2(PARASIZ),REQ_R(PARASIZ),REQ_R2(PARASIZ)
84 INTEGER P,LENSD,LENRV,IADS(PARASIZ+1),IADR(PARASIZ+1),IERROR,
85 * SIZ,LOC_PROC,MSGTYP,IDEBS(NINTER),IDEBR(NINTER),IDB,PROC,
86 * MSGOFF,MSGOFF2,LENSD_0,LENRV_0
87 INTEGER IADINT(NINTER,NSPMD)
88
89 INTEGER I,J,L,NB,NL,NN,K,N,LEN,ND,FLG,NIN,NTY,
90 * NSN,SN,SSIZ,
91 * IT,LEN_NSNSI,NSNR,NI,NP,ALEN,NOD,NOD1,NOD2,
92 * SIZE_LOC, I_STOK,INACTI,IFQ,ITIED,NRTS
93! Exchanged arrays for sent buffer
94 INTEGER, DIMENSION(:), ALLOCATABLE :: TAB_SEND,TAB_LOC
95 INTEGER, DIMENSION(:), ALLOCATABLE :: IBUFS, IBUFR
96
97 TYPE(int_pointer), DIMENSION(:), ALLOCATABLE :: TAG_LOC,TAB_NSVSI
98C REAL
99 DATA msgoff/240/
100 DATA msgoff2/241/
101! -----------------------------------------------
102! at tt = 0 and with AMS, one must eliminate cand_a/e for
103! type 2 interface and ilev/+25 or 26
104! ( if NTY==2 .AND. ILEV/=25 .and. ILEV /= 26 )
105!
106! NSNSI and NSVSI are unknown at tt = 0
107! --> one must build NSNSI and NSVSI one each process/domain
108! using NSNFI and NSVFI arrays located on the others domain
109!
110! 1st comm : building of NSNSI array (for ispmd domain) with NSNFI array (located on p domain, p/=ispmd)
111! 2nd comm : building of NSVSI array (for ispmd domain) with NSVFI array (located on p domain, p/=ispmd) !
112! 3rd comm : comm of tag array (each ispmd domain sends NSNSI values of tag arrays to p domain)
113! check the value of tag : if tag = -1, cand_a/e are deleted
114! -----------------------------------------------
115 IF(nspmd == 1)RETURN
116
117 ierror = 0
118 IF(nspmd>1) THEN
119 ! -----------------------
120 ! FIRST COMM.
121 ! building of NSNSI
122 ! tab_loc : sent buffer (=NSNFI)
123 ! tab_send : recv. buffer (-->NSNSI)
124 IF(ninter>0) THEN
125 ALLOCATE(tab_send(ninter*nspmd), stat=ierror)
126 IF(ierror/=0) THEN
127 CALL ancmsg(msgid=20,anmode=aninfo)
128 CALL arret(2)
129 ENDIF
130 ALLOCATE(tab_loc(ninter*nspmd), stat=ierror)
131 IF(ierror/=0) THEN
132 CALL ancmsg(msgid=20,anmode=aninfo)
133 CALL arret(2)
134 ENDIF
135 tab_loc(1:ninter*nspmd) = 0
136 ENDIF ! ninter/=0
137!
138 loc_proc = ispmd+1
139 iads(1:nspmd+1) = 0
140 iadr(1:nspmd+1) = 0
141 lensd_0 = 0
142 lenrv_0 = 0
143
144 alen = 1
145 DO p=1,nspmd
146 iads(p)=lensd_0+1
147 DO ni=1,nbintc
148 nin = intlist(ni)
149 nty=ipari(7,nin)
150 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
151 lensd_0 = lensd_0 + nsnfi(nin)%P(p)*alen
152 tab_loc(nin+ninter*(p-1)) = tab_loc(nin+ninter*(p-1)) + nsnfi(nin)%P(p)
153 ENDIF
154 ENDDO
155 ENDDO
156 iads(nspmd+1)=lensd_0+1
157
158 ! AlltoAll comm in order to know the sent buffer size
159 CALL mpi_alltoall(tab_loc(1),ninter,mpi_integer,
160 . tab_send(1),ninter,mpi_integer,
161 . spmd_comm_world,ierror)
162
163 ! -----------------------
164 ! SECOND COMM.
165 ! building of NSVSI
166 ! IBUFS : sent buffer (=NSVFI)
167 ! IBUFR : recv. buffer (-->NSVSI)
168 ! TAB_NSVSI : NSVSI array
169 DO p=1,nspmd
170 iadr(p) = lenrv_0 + 1
171 DO ni=1,nbintc
172 nin = intlist(ni)
173 nty=ipari(7,nin)
174 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
175 lenrv_0 = lenrv_0 + tab_send(nin+ninter*(p-1))*alen
176 ENDIF
177 ENDDO
178 ENDDO
179 iadr(nspmd+1) = lenrv_0 + 1
180
181 ! Sent buffer allocation
182 IF(lensd_0>0) THEN
183 ALLOCATE(ibufs(lensd_0),stat=ierror)
184 IF(ierror/=0) THEN
185 CALL ancmsg(msgid=20,anmode=aninfo)
186 CALL arret(2)
187 ENDIF
188 ENDIF
189
190 ! Received buffer allocation
191 IF(lenrv_0>0) THEN
192 ALLOCATE(ibufr(lenrv_0),stat=ierror)
193 IF(ierror/=0) THEN
194 CALL ancmsg(msgid=20,anmode=aninfo)
195 CALL arret(2)
196 ENDIF
197 ALLOCATE(tab_nsvsi(ninter),stat=ierror)
198 IF(ierror/=0) THEN
199 CALL ancmsg(msgid=20,anmode=aninfo)
200 CALL arret(2)
201 ENDIF
202
203 DO ni=1,nbintc
204 nin = intlist(ni)
205 nty = ipari(7,nin)
206 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
207 nsnr = ipari(24,nin)
208 lenrv_0 = 0
209 DO p=1,nspmd
210 lenrv_0 = lenrv_0 + tab_send(nin+ninter*(p-1))
211 ENDDO
212 ALLOCATE(tab_nsvsi(nin)%P(lenrv_0), stat=ierror)
213 IF(ierror/=0) THEN
214 CALL ancmsg(msgid=20,anmode=aninfo)
215 CALL arret(2)
216 ENDIF
217 tab_nsvsi(nin)%P(1:lenrv_0) = 0
218 ENDIF
219 ENDDO
220 ENDIF
221 ! -----------------
222 ! Received MPI comm
223 DO p=1, nspmd
224 siz=iadr(p+1)-iadr(p)
225 IF (siz > 0) THEN
226 msgtyp = msgoff
227 CALL mpi_irecv( ibufr(iadr(p)),siz,mpi_integer,it_spmd(p),msgtyp,
228 . spmd_comm_world,req_r(p),ierror )
229 ENDIF
230 ENDDO
231 ! -----------------
232 ! Sent MPI comm
233 l=1
234 idebs=0
235 DO p=1, nspmd
236 iads(p)=l
237 IF (p/= loc_proc) THEN
238 DO ni=1,nbintc
239 nin = intlist(ni)
240 nty = ipari(7,nin)
241 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11) THEN
242 nb = nsnfi(nin)%P(p) ! size = nsnfi
243 IF(nb>0) THEN
244 DO nn=1,nb
245 ibufs(l) = nsvfi(nin)%P(idebs(nin)+nn)
246 l=l+alen
247 ENDDO
248 idebs(nin)=idebs(nin)+nb
249 ENDIF
250 ENDIF
251 ENDDO ! DO NIN=1,NINTER
252 siz = l-iads(p)
253 IF(siz>0)THEN
254 msgtyp = msgoff
255 CALL mpi_isend( ibufs(iads(p)),siz,mpi_integer,it_spmd(p),msgtyp,
256 . spmd_comm_world,req_si(p),ierror )
257 ENDIF
258 ENDIF ! ENDIF P/= LOC_PROC
259 ENDDO ! DO P=1, NSPMD
260 ! -----------------
261 ! Receive
262 l=0
263 idebr = 0
264
265 DO p=1, nspmd
266 l=0
267 siz=iadr(p+1)-iadr(p)
268 IF (siz > 0) THEN
269 msgtyp = msgoff
270 ! MPI WAIT
271 CALL mpi_wait(req_r(p),status,ierror)
272 DO ni=1,nbintc
273 nin = intlist(ni)
274 nty = ipari(7,nin)
275 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
276 nb = tab_send(nin+ninter*(p-1)) ! nsnfi becomes nsnsi on local proc
277 IF (nb > 0)THEN
278 DO k=1,nb
279 tab_nsvsi(nin)%P(idebr(nin)+k) = ibufr(iadr(p)+l) ! nsvfi becomes nsvsi on local proc
280 l=l+alen
281 ENDDO
282 idebr(nin)=idebr(nin)+nb
283 ENDIF
284 ENDIF ! ity==7
285 ENDDO
286 ENDIF ! IF (NB > 0)
287! L=L+SIZ
288 ENDDO ! DO P=1, NSPMD
289
290 ! -----------------
291 ! Fin du send
292 DO p = 1, nspmd
293 IF (p==nspmd)THEN
294 siz=lensd_0-iads(p)
295 ELSE
296 siz=iads(p+1)-iads(p)
297 ENDIF
298 IF(siz>0) THEN
299 CALL mpi_wait(req_si(p),status,ierror)
300 ENDIF
301 ENDDO
302 ! -----------------
303 ! -----------------------
304 ! THIRD COMM.
305 ! building of tag array
306 ! IBUFS : sent buffer
307 ! IBUFR : recv. buffer
308 ! TAG_LOC is used as tag array
309 ! example for nspmd = 5, TAG_LOC(nin)%P
310 ! nin |------*---*-----*-------------*-----|
311 ! P1 * P2* P3 * P4 * P5
312 IF(ALLOCATED(ibufs)) DEALLOCATE(ibufs)
313 IF(ALLOCATED(ibufr)) DEALLOCATE(ibufr)
314 lensd = 0
315 lenrv = 0
316 alen = 1
317 iads(:) = 0
318 iadr(:) = 0
319 DO p=1,nspmd
320 iads(p)=lensd+1
321 iadr(p)=lenrv+1
322 DO ni=1,nbintc
323 nin = intlist(ni)
324 nty=ipari(7,nin)
325 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
326 lensd = lensd + tab_send(nin+ninter*(p-1))*alen
327 lenrv = lenrv + nsnfi(nin)%P(p)*alen
328 ENDIF
329 ENDDO
330 ENDDO
331 iads(nspmd+1)=lensd+1
332 iadr(nspmd+1)=lenrv+1
333 ! -----------------
334 ! Sent buffer allocation
335 IF(lensd>0) THEN
336 ALLOCATE(ibufs(lensd),stat=ierror)
337 IF(ierror/=0) THEN
338 CALL ancmsg(msgid=20,anmode=aninfo)
339 CALL arret(2)
340 ENDIF
341 ENDIF
342 ! -----------------
343 ! Received buffer allocation
344 IF(lenrv>0) THEN
345 ALLOCATE(ibufr(lenrv),stat=ierror)
346 IF(ierror/=0) THEN
347 CALL ancmsg(msgid=20,anmode=aninfo)
348 CALL arret(2)
349 ENDIF
350 ENDIF
351 ! -----------------
352 ! Received MPI comm
353 DO p=1, nspmd
354 siz=iadr(p+1)-iadr(p)
355 IF (siz > 0) THEN
356 msgtyp = msgoff2
357 CALL mpi_irecv( ibufr(iadr(p)),siz,mpi_integer,it_spmd(p),msgtyp,
358 . spmd_comm_world,req_r(p),ierror )
359 ENDIF
360 ENDDO
361 ! -----------------
362 ! Sent MPI comm
363 l=1
364 idebs = 0
365 DO p=1, nspmd
366 iads(p)=l
367 IF (p/= loc_proc) THEN
368 DO ni=1,nbintc
369 nin = intlist(ni)
370 nty = ipari(7,nin)
371 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25) THEN
372 nb = tab_send(nin+ninter*(p-1)) ! size = nsnsi
373 IF(nb>0) THEN
374 DO nn=1,nb
375 nd = tab_nsvsi(nin)%P(idebs(nin)+nn) ! = nsvsi
376 nod = intbuf_tab(nin)%NSV(nd)
377 ibufs(l)= tag(nod)
378 l=l+alen
379 ENDDO
380 idebs(nin)=idebs(nin)+nb
381 ENDIF
382 ELSEIF (nty == 11)THEN
383 nb = tab_send(nin+ninter*(p-1)) ! size = nsnsi
384 IF(nb>0) THEN
385 DO nn=1,nb
386 nd = tab_nsvsi(nin)%P(idebs(nin)+nn) ! = nsvsi
387 nod1 = intbuf_tab(nin)%IRECTS(2*(nd-1)+1)
388 nod2 = intbuf_tab(nin)%IRECTS(2*(nd-1)+2)
389 IF(tag(nod1)==1 .OR.tag(nod2)==1)THEN
390 ibufs(l)= 1
391 ELSE
392 ibufs(l)= 0
393 ENDIF
394 l = l+alen
395 ENDDO
396 idebs(nin)=idebs(nin)+nb
397 ENDIF
398 ENDIF
399 ENDDO ! DO NIN=1,NINTER
400 siz = l-iads(p)
401 IF(siz>0)THEN
402 msgtyp = msgoff2
403 CALL mpi_isend( ibufs(iads(p)),siz,mpi_integer,it_spmd(p),msgtyp,
404 . spmd_comm_world,req_si(p),ierror )
405 ENDIF
406 ENDIF ! ENDIF P/= LOC_PROC
407 ENDDO ! DO P=1, NSPMD
408
409 ! -----------------
410 ! Recv. MPI comm
411 ALLOCATE( tag_loc(ninter) )
412 DO ni=1,nbintc
413 nin = intlist(ni)
414 nty = ipari(7,nin)
415 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
416 nsnr = ipari(24,nin)
417 ALLOCATE(tag_loc(nin)%P(nsnr), stat=ierror)
418 IF(ierror/=0) THEN
419 CALL ancmsg(msgid=20,anmode=aninfo)
420 CALL arret(2)
421 ENDIF
422 tag_loc(nin)%P(1:nsnr) = 0
423 ENDIF
424 ENDDO
425 ! -----------------
426 ! building of tag array (TAG_LOC) as a structure
427 l=0
428 idebr(:) = 0
429 DO p=1, nspmd
430 l=0
431 siz=iadr(p+1)-iadr(p)
432 IF (siz > 0) THEN
433 msgtyp = msgoff2
434 ! MPI WAIT
435 CALL mpi_wait(req_r(p),status,ierror)
436
437 DO ni=1,nbintc
438 nin = intlist(ni)
439 nty = ipari(7,nin)
440 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11)THEN
441 nb = nsnfi(nin)%P(p) ! size = nsnfi
442 IF (nb > 0)THEN
443 DO k=1,nb
444 nd = idebr(nin)+k
445 tag_loc(nin)%P(nd) = - ibufr(iadr(p)+l)
446 l=l+alen
447 ENDDO
448 idebr(nin) = idebr(nin) + nb
449 ENDIF
450 ENDIF ! ity==7
451 ENDDO
452 ENDIF ! IF (NB > 0)
453 ENDDO ! DO P=1, NSPMD
454 ! -----------------
455 ! Fin du send
456 DO p = 1, nspmd
457 IF (p==nspmd)THEN
458 siz=lensd-iads(p)
459 ELSE
460 siz=iads(p+1)-iads(p)
461 ENDIF
462 IF(siz>0) THEN
463 CALL mpi_wait(req_si(p),status,ierror)
464 ENDIF
465 ENDDO
466 ! -----------------------
467 ! Check the value of tag and elimination of cand_a/e if tag = -1
468 DO ni=1,nbintc
469 nin = intlist(ni)
470 nty = ipari(7,nin)
471 nsn = ipari(5,nin)
472 nsnr = ipari(24,nin)
473 i_stok = intbuf_tab(nin)%I_STOK(1)
474 inacti = ipari(22,nin)
475 ifq = ipari(31,nin)
476 itied = ipari(85,nin)
477 nrts = ipari(3,nin)
478 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==24.OR.nty==25.OR.nty==11) THEN
479 CALL spmd_check_tag(nin,i_stok,intbuf_tab(nin),tag_loc(nin)%P,
480 . nsnr,nsn,nty,inacti,ifq,itied,nrts)
481 ENDIF
482 intbuf_tab(nin)%I_STOK(1) = i_stok
483 ENDDO
484
485 IF(ALLOCATED(ibufs)) DEALLOCATE(ibufs)
486 IF(ALLOCATED(ibufr)) DEALLOCATE(ibufr)
487 IF(ALLOCATED(tab_nsvsi)) DEALLOCATE(tab_nsvsi)
488 IF(ALLOCATED(tab_loc)) DEALLOCATE(tab_loc)
489 IF(ALLOCATED(tab_send)) DEALLOCATE(tab_send)
490 DEALLOCATE( tag_loc )
491 ! -----------------------
492 ENDIF ! NSPMD > 1
493#endif
494 RETURN
495 END SUBROUTINE
496
497
498
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_alltoall
subroutine mpi_alltoall(sendbuf, sendcnt, sendtype, recvbuf, recvcnt, recvtype, comm, ierr)
Definition mpi.f:161
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
message_mod
Definition message_mod.F:1249
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
spmd_check_tag
subroutine spmd_check_tag(nin, i_stok, intbuf_tab, tag, nsnr, nsn, nty, inacti, ifq, itied, nrts)
Definition spmd_check_tag.F:38
spmd_exch_smst2
subroutine spmd_exch_smst2(ipari, tag, intlist, nbintc, intbuf_tab)
Definition spmd_exch_smst2.F:40
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