OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_exch_i24.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!|| spmd_exch_i24 ../engine/source/mpi/interfaces/spmd_exch_i24.F
26!||--- called by ------------------------------------------------------
27!|| resol ../engine/source/engine/resol.F
28!||--- calls -----------------------------------------------------
29!|| ancmsg ../engine/source/output/message/message.F
30!|| arret ../engine/source/system/arret.F
31!||--- uses -----------------------------------------------------
32!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
33!|| message_mod ../engine/share/message_module/message_mod.F
34!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
35!|| tri7box ../engine/share/modules/tri7box.F
36!||====================================================================
37 SUBROUTINE spmd_exch_i24(IPARI ,INTBUF_TAB ,ITAB,
38 * IAD_ELEM ,FR_ELEM,INTLIST,NBINTC,
39 * IAD_I24 ,FR_I24 ,SFR_I24,I24MAXNSNE,FLAG,
40 * INT24E2EUSE )
41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE tri7box
45 USE message_mod
46 USE intbufdef_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
54#include "spmd.inc"
55C-----------------------------------------------
56C C o m m o n B l o c k s
57C-----------------------------------------------
58#include "param_c.inc"
59#include "com04_c.inc"
60#include "task_c.inc"
61#include "com01_c.inc"
62#include "spmd_c.inc"
63#include "impl1_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER IPARI(NPARI,*),IAD_ELEM(2,*),FR_ELEM(*),
68 * ITAB(*),INTLIST(*),NBINTC,FLAG,I24MAXNSNE,INT24E2EUSE
69 INTEGER
70 * iad_i24(nbintc+1,*), sfr_i24,fr_i24(*)
71C
72 TYPE(intbuf_struct_) INTBUF_TAB(*)
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76#ifdef MPI
77 INTEGER STATUS(MPI_STATUS_SIZE),
78 * REQ_SI(PARASIZ),REQ_S(PARASIZ),
79 * REQ_S2(PARASIZ),REQ_R(PARASIZ),REQ_R2(PARASIZ)
80 INTEGER P,LENSD,LENRV,IADS(PARASIZ+1),IADR(PARASIZ+1),IERROR,
81 * SIZ,LOC_PROC,MSGTYP,IDEB(NINTER),IDB,
82 * MSGOFF,MSGOFF2,MSGOFF3,MSGOFF4,MSGOFF5
83 INTEGER I, L, NB, NN, K, N, NOD, LEN, ALEN, ND, NIN, NTY,
84 * NSN,SN,NSI,IEDG4,
85 * SURF,SURFR,I_STOK,MS,NSNR,
86 * ni,ilen,rlen,li,lr,igsti
87
88 my_real
89 * send_pmax(ninter),time_s,time_sr
90 my_real ,
91 * DIMENSION(:), ALLOCATABLE :: bbufs, bbufr,rrecbuf
92 my_real ,
93 * DIMENSION(:,:), ALLOCATABLE :: rsendbuf
94
95
96 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISENDBUF
97 INTEGER, DIMENSION(:), ALLOCATABLE :: IRECBUF
98
99 INTEGER, DIMENSION(:), ALLOCATABLE :: ISCAND
100 DATA msgoff/156/
101 DATA msgoff2/157/
102 DATA msgoff3/158/
103 DATA msgoff4/159/
104 DATA msgoff5/160/
105C-----------------------------------------------
106 SAVE iads,iadr,bbufs,bbufr,req_s,req_s2,
107 * req_si,req_r,req_r2,
108 * rrecbuf,irecbuf,rsendbuf,isendbuf,
109 * ilen,rlen,len,lensd,lenrv
110C-----------------------------------------------
111 alen=10
112 loc_proc = ispmd+1
113 send_pmax(1:ninter)=0
114C--------------------------------------------------------
115C For Part 3
116 ilen = 4
117 rlen = 8
118C--------------------------------------------------------
119 IF(nspmd == 1)RETURN
120
121C ----------------------------------
122C Iflag = 1 part 1 - Send
123C ----------------------------------
124 IF(flag==1)THEN
125
126C----------------------------------------------------------------------------------------------------
127C IRTLM & TIME_S are put to ZERO when the local second nodes are not candidates
128C----------------------------------------------------------------------------------------------------
129 ALLOCATE(iscand(numnod+i24maxnsne))
130 iscand(1:numnod+i24maxnsne)=0
131 DO ni=1,nbintc
132 nin = intlist(ni)
133 nty = ipari( 7,nin)
134 nsn = ipari( 5,nin)
135 nsnr = ipari( 24,nin)
136 iedg4 = ipari(59,nin)
137 IF(nty==24)THEN
138 i_stok = intbuf_tab(nin)%I_STOK(1)
139 DO i=1,i_stok
140 n = intbuf_tab(nin)%CAND_N(i)
141 IF(n<=nsn)THEN
142 sn = intbuf_tab(nin)%NSV(n)
143 iscand(sn)=1
144 ms = intbuf_tab(nin)%CAND_E(i)
145 ENDIF
146 ENDDO
147 DO i=1,nsn
148 n = intbuf_tab(nin)%NSV(i)
149 IF (iscand(n)==0)THEN
150 intbuf_tab(nin)%TIME_S(i) = zero
151 intbuf_tab(nin)%IRTLM(2*(i-1)+1) = 0
152 iscand(n)=0
153 ENDIF
154 ENDDO
155 IF(iedg4 >0)THEN
156 DO i=1,nsnr
157 IF(isedge_fi(nin)%P(i)==-1)THEN
158 irtlm_fi(nin)%P(1,i)=0
159 time_sfi(nin)%P(i)=zero
160 ENDIF
161 ENDDO
162 ENDIF
163 ENDIF
164 ENDDO
165
166C--------------------------------------------------------
167
168C Comm on the Type 24 interface
169C First part, we bring back to the proc that has the secondary nodes the values of IRTLM_FI + TIME_SFI & treatments
170C Second part, we process them on the proc that has the secondary nodes the values
171C 3rd part we refer to the remotes of the globalized values on the
172
173C--------------------------------------------------------
174C First part, we bring back to the proc that has the secondary nodes the values of IRTLM_FI + TIME_SFI
175C--------------------------------------------------------
176
177 loc_proc = ispmd+1
178 iads(1:nspmd+1) = 0
179 iadr(1:nspmd+1) = 0
180 lensd = 0
181 lenrv = 0
182
183 alen=10
184
185
186C counting buffer sizes for reception and sending
187 DO p=1,nspmd
188 iadr(p)=lenrv+1
189 DO ni=1,nbintc
190 nin = intlist(ni)
191 nty=ipari(7,nin)
192 IF(nty==24)THEN
193 lensd = lensd + nsnfi(nin)%P(p)*alen
194 lenrv = lenrv + nsnsi(nin)%P(p)*alen
195 ENDIF
196 ENDDO
197 ENDDO
198 iadr(nspmd+1)=lenrv+1
199
200C preparation of send
201 IF(lensd>0)THEN
202 ALLOCATE(bbufs(lensd),stat=ierror)
203 IF(ierror/=0) THEN
204 CALL ancmsg(msgid=20,anmode=aninfo)
205 CALL arret(2)
206 ENDIF
207 ENDIF
208
209C ---------------------------------------------
210C preparation of receive
211 IF(lenrv>0)THEN
212 ALLOCATE(bbufr(lenrv),stat=ierror)
213 IF(ierror/=0) THEN
214 CALL ancmsg(msgid=20,anmode=aninfo)
215 CALL arret(2)
216 ENDIF
217 ENDIF
218
219 DO p=1, nspmd
220 siz=iadr(p+1)-iadr(p)
221 IF (siz > 0) THEN
222 msgtyp = msgoff2
223 CALL mpi_irecv( bbufr(iadr(p)),siz,real,it_spmd(p),msgtyp,
224 * spmd_comm_world,req_r(p),ierror )
225 ENDIF
226 ENDDO
227
228C ---------------------------------------------
229C Send
230 l=1
231 ideb=0
232 DO p=1, nspmd
233 iads(p)=l
234 IF (p/= loc_proc) THEN
235 DO ni=1,nbintc
236 nin = intlist(ni)
237 nty =ipari(7,nin)
238 IF(nty==24) THEN
239 nb = nsnfi(nin)%P(p)
240 DO nn=1,nb
241 bbufs(l)= irtlm_fi(nin)%P(1,nn+ideb(nin))
242 bbufs(l+1)=irtlm_fi(nin)%P(2,nn+ideb(nin))
243 bbufs(l+2)=time_sfi(nin)%P(nn+ideb(nin))
244 bbufs(l+3)=secnd_frfi(nin)%P(1,nn+ideb(nin))
245 bbufs(l+4)=secnd_frfi(nin)%P(2,nn+ideb(nin))
246 bbufs(l+5)=secnd_frfi(nin)%P(3,nn+ideb(nin))
247 bbufs(l+6)=pene_oldfi(nin)%P(1,nn+ideb(nin))
248 bbufs(l+7)=stif_oldfi(nin)%P(1,nn+ideb(nin))
249 bbufs(l+8)=pene_oldfi(nin)%P(3,nn+ideb(nin))
250 bbufs(l+9)=pene_oldfi(nin)%P(5,nn+ideb(nin))
251 l=l+10
252 ENDDO
253 ideb(nin)=ideb(nin)+nb
254 ENDIF
255 ENDDO ! DO NIN=1,NINTER
256 siz = l-iads(p)
257 IF(siz>0)THEN
258 msgtyp = msgoff2
259 CALL mpi_isend(
260 . bbufs(iads(p)),siz,real ,it_spmd(p),msgtyp,
261 . spmd_comm_world,req_si(p),ierror )
262 ENDIF
263 ENDIF ! ENDIF P/= LOC_PROC
264 ENDDO ! DO P=1, NSPMD
265
266
267 RETURN
268 ENDIF
269
270C----------------------------------
271C IFLAG=2 partie2 - Recieve
272C ----------------------------------
273 IF(flag==2)THEN
274
275C Recieve
276 l=0
277 ideb = 0
278
279 DO p=1, nspmd
280 l=0
281 siz=iadr(p+1)-iadr(p)
282 IF (siz > 0) THEN
283 msgtyp = msgoff2
284
285C WAIT
286 CALL mpi_wait(req_r(p),status,ierror)
287
288 DO ni=1,nbintc
289 nin = intlist(ni)
290 nty =ipari(7,nin)
291
292 IF(nty==24)THEN
293
294 nb = nsnsi(nin)%P(p)
295 IF (nb > 0)THEN
296C
297 DO k=1,nb
298 nd = nsvsi(nin)%P(ideb(nin)+k)
299
300C Merge IRTLM & TIME_S
301 sn = intbuf_tab(nin)%NSV(nd)
302 time_s = intbuf_tab(nin)%TIME_S(nd)
303 surf = intbuf_tab(nin)%IRTLM(2*(nd-1)+1)
304 surfr = bbufr(iadr(p)+l)
305 time_sr = bbufr(iadr(p)+l+2)
306
307 IF (bbufr(iadr(p)+l)==0
308 * .AND.bbufr(iadr(p)+l+2)==zero) THEN
309C If IRTLM (1, == 0 and time_s (SNR) == 0. Then he is not chosen candidate
310
311 ELSEIF (intbuf_tab(nin)%IRTLM(2*(nd-1)+1) == 0
312 * .AND. intbuf_tab(nin)%TIME_S(nd) ==zero)THEN
313C Si candidat local n'est pas retenu, on copie simplement
314 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) = bbufr(iadr(p)+l)
315 intbuf_tab(nin)%IRTLM(2*(nd-1)+2) = bbufr(iadr(p)+l+1)
316 intbuf_tab(nin)%TIME_S(nd) = bbufr(iadr(p)+l+2)
317
318 ELSEIF (time_s==-ep20 .AND. surf == 0)THEN
319 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) = 0
320 intbuf_tab(nin)%IRTLM(2*(nd-1)+2) = 0
321 intbuf_tab(nin)%TIME_S(nd) = -ep20
322
323 ELSEIF (time_sr==-ep20 .AND. surfr == 0)THEN
324 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) = 0
325 intbuf_tab(nin)%IRTLM(2*(nd-1)+2) = 0
326 intbuf_tab(nin)%TIME_S(nd) = -ep20
327 ELSEIF (time_s==-ep20 .AND. surf == 0)THEN
328C nothing to do
329 ELSEIF( surfr > 0 .AND. time_sr==-ep20 .AND.
330 * surf > 0 .AND. time_s==-ep20 )THEN
331C Case both SURFR values are positive & TIME_S is Equal to EP20
332C We choose the highest value
333 IF (surfr > surf)THEN
334 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) = bbufr(iadr(p)+l)
335 intbuf_tab(nin)%IRTLM(2*(nd-1)+2) = bbufr(iadr(p)+l+1)
336 intbuf_tab(nin)%TIME_S(nd) = bbufr(iadr(p)+l+2)
337 ENDIF
338 ELSEIF(surfr > 0 .AND. time_sr==-ep20)THEN
339 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) = bbufr(iadr(p)+l)
340 intbuf_tab(nin)%IRTLM(2*(nd-1)+2) = bbufr(iadr(p)+l+1)
341 intbuf_tab(nin)%TIME_S(nd) = -ep20
342
343 ELSEIF(surf > 0 .AND. time_s==-ep20)THEN
344C nothing to do
345 ELSEIF(surfr < 0)THEN
346 IF (time_sr == time_s) THEN
347 IF (abs(surfr) > abs(surf))THEN
348 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) = bbufr(iadr(p)+l)
349 intbuf_tab(nin)%IRTLM(2*(nd-1)+2)=
350 * bbufr(iadr(p)+l+1)
351 intbuf_tab(nin)%TIME_S(nd) = bbufr(iadr(p)+l+2)
352 ENDIF
353 ELSEIF (time_s <= time_sr ) THEN
354 intbuf_tab(nin)%IRTLM(2*(nd-1)+1) =
355 * bbufr(iadr(p)+l)
356 intbuf_tab(nin)%IRTLM(2*(nd-1)+2)= int(bbufr(iadr(p)+l+1))
357 intbuf_tab(nin)%TIME_S(nd) = bbufr(iadr(p)+l+2)
358 ENDIF
359 ENDIF
360C Merge SECND_FR
361
362 IF(abs(bbufr(iadr(p)+l+3)) >
363 * abs(intbuf_tab(nin)%SECND_FR(6*(nd-1)+1)))
364 * intbuf_tab(nin)%SECND_FR(6*(nd-1)+1) = bbufr(iadr(p)+l+3)
365C
366 IF(abs(bbufr(iadr(p)+l+4)) >
367 * abs(intbuf_tab(nin)%SECND_FR(6*(nd-1)+2)))
368 * intbuf_tab(nin)%SECND_FR(6*(nd-1)+2) = bbufr(iadr(p)+l+4)
369C
370 IF(abs(bbufr(iadr(p)+l+5)) >
371 * abs(intbuf_tab(nin)%SECND_FR(6*(nd-1)+3)))
372 * intbuf_tab(nin)%SECND_FR(6*(nd-1)+3) = bbufr(iadr(p)+l+5)
373
374C case equal abs but opposite sign
375 IF(bbufr(iadr(p)+l+3)==-intbuf_tab(nin)%SECND_FR(6*(nd-1)+1) )
376 * intbuf_tab(nin)%SECND_FR(6*(nd-1)+1) = abs(bbufr(iadr(p)+l+3))
377C
378 IF(bbufr(iadr(p)+l+4)==-intbuf_tab(nin)%SECND_FR(6*(nd-1)+2) )
379 * intbuf_tab(nin)%SECND_FR(6*(nd-1)+2) = abs(bbufr(iadr(p)+l+4))
380C
381 IF(bbufr(iadr(p)+l+5)==-intbuf_tab(nin)%SECND_FR(6*(nd-1)+3) )
382 * intbuf_tab(nin)%SECND_FR(6*(nd-1)+3) = abs(bbufr(iadr(p)+l+5))
383C
384
385C Merge PENE_OLD
386cc IF(INTBUF_TAB(NIN)%PENE_OLD(2*(ND-1)+1)/=0 .OR.
387cc * BBUFR(IADR(P)+L+6)/=0)THEN
388
389 intbuf_tab(nin)%PENE_OLD(5*(nd-1)+1)=max(intbuf_tab(nin)%PENE_OLD(5*(nd-1)+1),
390 * bbufr(iadr(p)+l+6) )
391 intbuf_tab(nin)%PENE_OLD(5*(nd-1)+3)=
392 * max(intbuf_tab(nin)%PENE_OLD(5*(nd-1)+3),
393 * bbufr(iadr(p)+l+8) )
394cc IF(TT==ZERO)THEN !due to Inacti=6
395 intbuf_tab(nin)%PENE_OLD(5*(nd-1)+5)=
396 * max(intbuf_tab(nin)%PENE_OLD(5*(nd-1)+5),
397 * bbufr(iadr(p)+l+9) )
398cc ENDIF
399cctobemoved IF(INTBUF_TAB(NIN)%IRTLM(2*(ND-1)+1) ==0)
400cctobemoved * INTBUF_TAB(NIN)%PENE_OLD(5*(ND-1)+5)=ZERO
401
402
403 intbuf_tab(nin)%STIF_OLD(2*(nd-1)+1)=max(intbuf_tab(nin)%STIF_OLD(2*(nd-1)+1),
404 * bbufr(iadr(p)+l+7) )
405cc ENDIF
406 l=l+10
407 ENDDO
408 ENDIF
409 ENDIF ! ity==24
410 ideb(nin)=ideb(nin)+nb
411 ENDDO
412 ENDIF ! IF (NB > 0)
413 l=l+siz
414 ENDDO ! DO P=1, NSPMD
415
416C end of send
417 DO p = 1, nspmd
418 IF (p==nspmd)THEN
419 siz=lensd-iads(p)
420 ELSE
421 siz=iads(p+1)-iads(p)
422 ENDIF
423 IF(siz>0) THEN
424 CALL mpi_wait(req_si(p),status,ierror)
425 ENDIF
426 ENDDO
427
428 IF (ALLOCATED(bbufs)) DEALLOCATE(bbufs)
429 IF (ALLOCATED(bbufr)) DEALLOCATE(bbufr)
430
431C -------------------
432C T24 E2E Merge ISPT2
433C -------------------
434C ISPT2 : Tag Array for secnd nodes (not fictive nodes)
435C Set to 1 when
436C 1/ Secnd node is part of an Edge
437C 2/ This Edge is impacting, eg fictive node has IRTLM not NULL
438C
439C Note for Parallelism - at this Stage Remote nodes & nodes on Marter processor are merged.
440C Fictive nodes (& secnd surface IRTS) are only affected to 1 SPMD Domain. They can only be
441C either Local or remote (not neighbour in term of SPMD domain).
442C One can start to merge here and spread the info to the neighboug domains.
443 IF(int24e2euse == 1)THEN
444 DO ni=1,nbintc
445 nin = intlist(ni)
446 nty = ipari(7,nin)
447 iedg4 = ipari(59,nin)
448 IF(nty==24 .AND. iedg4 > 0)THEN
449 nsn = ipari(5,nin)
450 DO sn=1,nsn
451C Basic case : Secnd node is not part of an Edge
452 intbuf_tab(nin)%ISPT2(sn)=0
453 nsi = intbuf_tab(nin)%ISEGPT(sn)
454 nd=intbuf_tab(nin)%NSV(sn)
455 IF(nsi > 0)THEN
456 IF(intbuf_tab(nin)%IRTLM(2*(nsi-1)+1) /= 0)THEN
457 intbuf_tab(nin)%ISPT2(sn) = 0
458 ELSE
459 intbuf_tab(nin)%ISPT2(sn) = 1
460 ENDIF
461 ELSEIF(nsi<0)THEN
462 intbuf_tab(nin)%ISPT2(sn) = 1
463 ENDIF
464 ENDDO
465 ENDIF
466 ENDDO
467 ENDIF
468C-----------------------------------------------------------
469C Second part - exchanges on the secondary boundary nodes
470C for all interface type 24.
471C-----------------------------------------------------------
472 len=3
473 iads(1:nspmd+1)=0
474
475 DO i=1,nspmd
476 iads(i)=iad_i24(1,i)
477 ENDDO
478 iads(nspmd+1)=sfr_i24+1
479C preparation of send
480 ilen=4
481 rlen=8
482 ALLOCATE(isendbuf(4,sfr_i24))
483 ALLOCATE(irecbuf(ilen*sfr_i24))
484 ALLOCATE(rsendbuf(8,sfr_i24))
485 ALLOCATE(rrecbuf(rlen*sfr_i24))
486
487C implementation of the IRECIEVE
488 DO p=1,nspmd
489 siz = iads(p+1)-iads(p)
490 IF(siz/=0)THEN
491 li = (iads(p)-1)*ilen+1
492 lr = (iads(p)-1)*rlen+1
493 msgtyp = msgoff3
494 len = siz*4
495 CALL mpi_irecv(
496 s irecbuf(li),len,mpi_integer,it_spmd(p),msgtyp,
497 g spmd_comm_world,req_r(p),ierror)
498
499 msgtyp = msgoff4
500 len = siz*8
501 CALL mpi_irecv(
502 s rrecbuf(lr),len,real,it_spmd(p),msgtyp,
503 g spmd_comm_world,req_r2(p),ierror)
504
505 ENDIF
506 ENDDO
507
508 nb = 1
509 DO p = 1, nspmd
510 DO ni=1,nbintc
511 nin=intlist(ni)
512 nty = ipari(7,nin)
513 nsn = ipari(5,nin)
514 iedg4 = ipari(59,nin)
515 IF(nty==24) THEN
516
517 DO i=iad_i24(ni,p),iad_i24(ni+1,p)-1
518
519 nd = fr_i24(i)
520 sn = intbuf_tab(nin)%NSV(nd)
521
522 isendbuf(1,nb)=itab(sn)
523 isendbuf(2,nb)=intbuf_tab(nin)%IRTLM(2*(nd-1)+1)
524 isendbuf(3,nb)=intbuf_tab(nin)%IRTLM(2*(nd-1)+2)
525 IF(iedg4 > 0) THEN
526 isendbuf(4,nb)= intbuf_tab(nin)%ISPT2(nd)
527 ELSE
528 isendbuf(4,nb)=0
529 ENDIF
530 rsendbuf(1,nb) = intbuf_tab(nin)%TIME_S(nd)
531 rsendbuf(2,nb) = intbuf_tab(nin)%SECND_FR(6*(nd-1)+1)
532 rsendbuf(3,nb) = intbuf_tab(nin)%SECND_FR(6*(nd-1)+2)
533 rsendbuf(4,nb) = intbuf_tab(nin)%SECND_FR(6*(nd-1)+3)
534 rsendbuf(5,nb) = intbuf_tab(nin)%PENE_OLD(5*(nd-1)+1)
535 rsendbuf(6,nb) = intbuf_tab(nin)%PENE_OLD(5*(nd-1)+3)
536 rsendbuf(8,nb) = intbuf_tab(nin)%PENE_OLD(5*(nd-1)+5)
537 rsendbuf(7,nb) = intbuf_tab(nin)%STIF_OLD(2*(nd-1)+1)
538 nb=nb+1
539 ENDDO
540 ENDIF
541 ENDDO ! DO NI=1,NBINTC
542 ENDDO ! DO P=1,NSPMD
543
544C--------------------------------------------------------------------
545C echange messages
546C
547 DO p=1,nspmd
548 siz = iads(p+1) - iads(p)
549 IF (siz >0)THEN
550 msgtyp = msgoff3
551 l = iads(p)
552 CALL mpi_isend(
553 s isendbuf(1,l),siz*4,mpi_integer,it_spmd(p),msgtyp,
554 g spmd_comm_world,req_s(p),ierror)
555
556 msgtyp = msgoff4
557 CALL mpi_isend(
558 s rsendbuf(1,l),siz*8,real,it_spmd(p),msgtyp,
559 g spmd_comm_world,req_s2(p),ierror)
560 ENDIF ! IF (SIZ >0)
561 ENDDO ! DO P=1,NSPMD
562C--------------------------------------------------------------------
563 i24com3 = 1
564
565 RETURN
566 ENDIF
567
568C ----------------------------------
569C IFLAG=3 partie3 - Recieve
570C ----------------------------------
571 IF(flag==3)THEN
572
573 IF(i24com3==0)RETURN
574
575C Reception
576 DO p=1,nspmd
577 siz = iads(p+1)-iads(p)
578 IF(siz/=0)THEN
579 idb = iads(p)
580 CALL mpi_wait(req_r(p),status,ierror)
581
582 CALL mpi_wait(req_r2(p),status,ierror)
583
584C Treatments
585
586 DO ni=1,nbintc
587 nin = intlist(ni)
588
589 nty = ipari(7,nin)
590 nsn = ipari(5,nin)
591 iedg4 = ipari(59,nin)
592 IF (nty == 24)THEN
593
594 DO k=iad_i24(ni,p),iad_i24(ni+1,p)-1
595 sn = fr_i24(k)
596 time_s = intbuf_tab(nin)%TIME_S(sn)
597 surf = intbuf_tab(nin)%IRTLM(2*(sn-1)+1)
598 surfr = irecbuf(2+(idb-1)*ilen)
599 time_sr = rrecbuf(1+(idb-1)*rlen)
600 IF (time_sr==0 .AND. surfr==0)THEN
601C Nothing
602
603 ELSEIF (time_s==0 .AND.surf==0)THEN
604C We impose the value of the candidate node
605 intbuf_tab(nin)%TIME_S(sn) = time_sr
606 intbuf_tab(nin)%IRTLM(2*(sn-1)+1) = irecbuf(2+(idb-1)*ilen)
607 intbuf_tab(nin)%IRTLM(2*(sn-1)+2) = irecbuf(3+(idb-1)*ilen)
608
609C now the update comes from a candidate
610
611 ELSEIF( time_s == -ep20 .AND. surf == 0)THEN
612C Nothing
613
614 ELSEIF( surfr == 0 .AND. time_sr == -ep20)THEN
615 intbuf_tab(nin)%TIME_S(sn) = -ep20
616 intbuf_tab(nin)%IRTLM(2*(sn-1)+1) = irecbuf(2+(idb-1)*ilen)
617 intbuf_tab(nin)%IRTLM(2*(sn-1)+2) = irecbuf(3+(idb-1)*ilen)
618
619 ELSEIF( surfr > 0 .AND. time_sr==-ep20 .AND.
620 * surf > 0 .AND. time_s==-ep20)THEN
621C Case both SURFR values are positive & TIME_S is Equal to EP20
622C We choose the highest value
623 IF (surfr > surf)THEN
624 intbuf_tab(nin)%IRTLM(2*(sn-1)+1) = irecbuf(2+(idb-1)*ilen)
625 intbuf_tab(nin)%IRTLM(2*(sn-1)+2) =
626 * irecbuf(3+(idb-1)*ilen)
627 intbuf_tab(nin)%TIME_S(sn) = -ep20
628 intbuf_tab(nin)%PENE_OLD(5*(sn-1)+1)=rrecbuf(5+(idb-1)*rlen)
629 intbuf_tab(nin)%STIF_OLD(2*(sn-1)+1)=rrecbuf(7+(idb-1)*rlen)
630 ENDIF
631
632 ELSEIF( surf > 0 .AND. time_s == -ep20)THEN
633c nothing to do
634
635 ELSEIF( surfr > 0 .AND. time_sr == -ep20)THEN
636 intbuf_tab(nin)%TIME_S(sn) = -ep20
637 intbuf_tab(nin)%IRTLM(2*(sn-1)+1) = irecbuf(2+(idb-1)*ilen)
638 intbuf_tab(nin)%IRTLM(2*(sn-1)+2) = irecbuf(3+(idb-1)*ilen)
639
640 ELSEIF( surfr < 0 )THEN
641 IF (time_sr == time_s) THEN
642 IF (abs(surfr) > abs(surf))THEN
643 intbuf_tab(nin)%TIME_S(sn) = time_sr
644 intbuf_tab(nin)%IRTLM(2*(sn-1)+1) =
645 * irecbuf(2+(idb-1)*ilen)
646 intbuf_tab(nin)%IRTLM(2*(sn-1)+2) =
647 * irecbuf(3+(idb-1)*ilen)
648 ENDIF
649 ELSEIF (time_s <= time_sr ) THEN
650 intbuf_tab(nin)%TIME_S(sn) = time_sr
651 intbuf_tab(nin)%IRTLM(2*(sn-1)+1) =
652 * irecbuf(2+(idb-1)*ilen)
653 intbuf_tab(nin)%IRTLM(2*(sn-1)+2) =
654 * irecbuf(3+(idb-1)*ilen)
655 ENDIF
656 ENDIF
657
658C Max for SECND_FR
659 IF (abs(rrecbuf(2+(idb-1)*rlen)) >
660 * (abs(intbuf_tab(nin)%SECND_FR(6*(sn-1)+1)) ) )
661 * intbuf_tab(nin)%SECND_FR(6*(sn-1)+1) = rrecbuf(2+(idb-1)*rlen)
662
663 IF (abs(rrecbuf(3+(idb-1)*rlen)) >
664 * abs(intbuf_tab(nin)%SECND_FR(6*(sn-1)+2)) )
665 * intbuf_tab(nin)%SECND_FR(6*(sn-1)+2) = rrecbuf(3+(idb-1)*rlen)
666
667 IF (abs(rrecbuf(4+(idb-1)*rlen)) >
668 * abs(intbuf_tab(nin)%SECND_FR(6*(sn-1)+3)) )
669 * intbuf_tab(nin)%SECND_FR(6*(sn-1)+3) = rrecbuf(4+(idb-1)*rlen)
670
671C Case equal abs but opposite sign
672 IF (rrecbuf(2+(idb-1)*rlen)==-intbuf_tab(nin)%SECND_FR(6*(sn-1)+1) )
673 * intbuf_tab(nin)%SECND_FR(6*(sn-1)+1)=
674 * abs(rrecbuf(2+(idb-1)*rlen))
675
676 IF (rrecbuf(3+(idb-1)*rlen)==-intbuf_tab(nin)%SECND_FR(6*(sn-1)+2) )
677 * intbuf_tab(nin)%SECND_FR(6*(sn-1)+2)=
678 * abs(rrecbuf(3+(idb-1)*rlen))
679
680 IF (rrecbuf(4+(idb-1)*rlen)==-intbuf_tab(nin)%SECND_FR(6*(sn-1)+3) )
681 * intbuf_tab(nin)%SECND_FR(6*(sn-1)+3)=
682 * abs(rrecbuf(4+(idb-1)*rlen))
683
684C Merge PENE_OLD
685 intbuf_tab(nin)%PENE_OLD(5*(sn-1)+1)=max(intbuf_tab(nin)%PENE_OLD(5*(sn-1)+1),
686 * rrecbuf(5+(idb-1)*rlen) )
687 intbuf_tab(nin)%PENE_OLD(5*(sn-1)+3)=max(intbuf_tab(nin)%PENE_OLD(5*(sn-1)+3),
688 * rrecbuf(6+(idb-1)*rlen) )
689
690cc IF(TT==DT2)THEN !due to Inacti=6
691 intbuf_tab(nin)%PENE_OLD(5*(sn-1)+5)=max(intbuf_tab(nin)%PENE_OLD(5*(sn-1)+5),
692 * rrecbuf(8+(idb-1)*rlen) )
693cc ENDIF
694
695cctobemoved IF(INTBUF_TAB(NIN)%IRTLM(2*(SN-1)+1)==0)
696cctobemoved * INTBUF_TAB(NIN)%PENE_OLD(5*(SN-1)+5)=ZERO
697
698 intbuf_tab(nin)%STIF_OLD(2*(sn-1)+1)=max(intbuf_tab(nin)%STIF_OLD(2*(sn-1)+1),
699 * rrecbuf(7+(idb-1)*rlen) )
700
701C T24 E2E Merge ISPT2
702 IF(iedg4 > 0)THEN
703 nd=intbuf_tab(nin)%NSV(sn)
704 intbuf_tab(nin)%ISPT2(sn) = max( intbuf_tab(nin)%ISPT2(sn), irecbuf(4+(idb-1)*ilen))
705 ENDIF
706 idb=idb+1
707 ENDDO ! K=,IAD_I24(NI,P),IAD_I24(NI+1,P)-1
708 ENDIF ! IF (NTY == 24)THEN
709 ENDDO ! DO NI=1,NBINTC
710 ENDIF !IF(SIZ/=0)THEN
711 ENDDO ! DO P=1,NSPMD
712
713C Fin send
714 DO p=1,nspmd
715 siz = iads(p+1)-iads(p)
716 IF(siz/=0)THEN
717 CALL mpi_wait(req_s(p),status,ierror)
718 CALL mpi_wait(req_s2(p),status,ierror)
719 ENDIF
720 ENDDO
721
722C Treat PENE_OLD(5
723
724 DO ni=1,nbintc
725 nin = intlist(ni)
726 nty = ipari( 7,nin)
727 nsn = ipari( 5,nin)
728 nsnr = ipari( 24,nin)
729 iedg4 = ipari(59,nin)
730 IF(nty==24)THEN
731 DO sn=1,nsn
732 IF(intbuf_tab(nin)%IRTLM(2*(sn-1)+1)==0)
733 * intbuf_tab(nin)%PENE_OLD(5*(sn-1)+5)=zero
734 ENDDO
735 ENDIF
736 ENDDO
737
738 IF(ALLOCATED(isendbuf))DEALLOCATE(isendbuf)
739 IF(ALLOCATED(irecbuf))DEALLOCATE(irecbuf)
740 IF(ALLOCATED(rsendbuf))DEALLOCATE(rsendbuf)
741 IF(ALLOCATED(rrecbuf))DEALLOCATE(rrecbuf)
742
743C ------------------------------------------------------------------
744C Third part we send back the globalized values to the remote procs
745C ------------------------------------------------------------------
746 len=6
747 loc_proc = ispmd+1
748 iads = 0
749 iadr = 0
750 lensd = 0
751 lenrv = 0
752
753 alen=11
754C counting buffer sizes for reception and sending
755 DO p=1,nspmd
756 iadr(p)=lenrv+1
757 DO nin=1,ninter
758 nty=ipari(7,nin)
759 IF(nty==24) THEN
760 lensd = lensd + nsnsi(nin)%P(p)*alen
761 lenrv = lenrv + nsnfi(nin)%P(p)*alen
762 ENDIF
763 ENDDO
764 ENDDO
765 iadr(nspmd+1)=lenrv+1
766
767 IF(lensd>0)THEN
768 ALLOCATE(bbufs(lensd),stat=ierror)
769 IF(ierror/=0) THEN
770 CALL ancmsg(msgid=20,anmode=aninfo)
771 CALL arret(2)
772 ENDIF
773 ENDIF
774
775C preparation of receive
776 IF(lenrv>0)THEN
777 ALLOCATE(bbufr(lenrv),stat=ierror)
778 IF(ierror/=0) THEN
779 CALL ancmsg(msgid=20,anmode=aninfo)
780 CALL arret(2)
781 ENDIF
782 ENDIF
783
784
785 DO p=1, nspmd
786 siz=iadr(p+1)-iadr(p)
787 IF (siz > 0) THEN
788 msgtyp = msgoff5
789 CALL mpi_irecv( bbufr(iadr(p)),siz,real,it_spmd(p),msgtyp,
790 * spmd_comm_world,req_r(p),ierror )
791 ENDIF
792 ENDDO
793
794C Send
795 l=1
796 ideb = 0
797 DO p=1, nspmd
798 iads(p)=l
799 IF (p/= loc_proc) THEN
800 DO ni=1,nbintc
801 nin = intlist(ni)
802 nty =ipari(7,nin)
803 IF(nty==24)THEN
804 iedg4 = ipari(59,nin)
805 nb = nsnsi(nin)%P(p)
806C preparation of send
807 DO nn=1,nb
808 nd = nsvsi(nin)%P(ideb(nin)+nn)
809 nod=intbuf_tab(nin)%NSV(nd)
810 bbufs(l )=intbuf_tab(nin)%IRTLM(2*(nd-1)+1)
811 bbufs(l+1)=intbuf_tab(nin)%IRTLM(2*(nd-1)+2)
812 bbufs(l+2)=intbuf_tab(nin)%TIME_S(nd)
813 bbufs(l+3)=intbuf_tab(nin)%SECND_FR(6*(nd-1)+1)
814 bbufs(l+4)=intbuf_tab(nin)%SECND_FR(6*(nd-1)+2)
815 bbufs(l+5)=intbuf_tab(nin)%SECND_FR(6*(nd-1)+3)
816 bbufs(l+6)=intbuf_tab(nin)%PENE_OLD(5*(nd-1)+1)
817 bbufs(l+7)=intbuf_tab(nin)%PENE_OLD(5*(nd-1)+3)
818 bbufs(l+9)=intbuf_tab(nin)%PENE_OLD(5*(nd-1)+5)
819 bbufs(l+8)=intbuf_tab(nin)%STIF_OLD(2*(nd-1)+1)
820 IF(iedg4 > 0)THEN
821 bbufs(l+10)=intbuf_tab(nin)%ISPT2(nd)
822 ELSE
823 bbufs(l+10)=0
824 ENDIF
825 l = l + 11
826 ENDDO
827 ENDIF
828 ideb(nin)=ideb(nin)+nb
829 ENDDO
830
831 siz = l-iads(p)
832 IF(siz>0)THEN
833 msgtyp = msgoff5
834C Send
835 CALL mpi_isend(
836 . bbufs(iads(p)),siz,real ,it_spmd(p),msgtyp,
837 . spmd_comm_world,req_si(p),ierror )
838 ENDIF
839 ENDIF
840 ENDDO
841 iads(nspmd+1)=l
842C Third part of Comm routine has been done
843 i24com3 = 0
844
845C Fourth part of Comm routine has been done
846 i24com4 = 1
847 RETURN
848 ENDIF
849
850C ----------------------------------
851C IFLAG=4 partie4 - Recieve
852C ----------------------------------
853 IF(flag==4)THEN
854 IF(i24com4==0)RETURN
855
856C Recieve
857 l=0
858 ideb = 0
859
860 DO p=1, nspmd
861 l=0
862 siz=iadr(p+1)-iadr(p)
863 IF (siz > 0) THEN
864
865 CALL mpi_wait(req_r(p),status,ierror)
866 DO ni=1,nbintc
867 nin=intlist(ni)
868 nty = ipari(7,nin)
869 igsti = ipari(34,nin)
870
871 IF(nty==24) THEN
872 iedg4 = ipari(59,nin)
873 nb = nsnfi(nin)%P(p)
874
875 IF (nb > 0)THEN
876 IF(impl_s>0.AND.igsti==6)THEN
877C--------------keep STIF_OLDFI(NIN)%P(1,
878 DO k=1,nb
879 irtlm_fi(nin)%P(1,ideb(nin)+k)=bbufr(iadr(p)+l)
880 irtlm_fi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+1)
881 time_sfi(nin)%P(ideb(nin)+k)=bbufr(iadr(p)+l+2)
882C Same initialization than in i24optcd :
883C copy SECND_FRFI(1,2,3) into SECND_FRFI(4,5,6) & Flush SECND_FRFI to zero
884 secnd_frfi(nin)%P(1,ideb(nin)+k)=zero
885 secnd_frfi(nin)%P(2,ideb(nin)+k)=zero
886 secnd_frfi(nin)%P(3,ideb(nin)+k)=zero
887 secnd_frfi(nin)%P(4,ideb(nin)+k)=bbufr(iadr(p)+l+3)
888 secnd_frfi(nin)%P(5,ideb(nin)+k)=bbufr(iadr(p)+l+4)
889 secnd_frfi(nin)%P(6,ideb(nin)+k)=bbufr(iadr(p)+l+5)
890 pene_oldfi(nin)%P(1,ideb(nin)+k)=zero
891 pene_oldfi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+6)
892 pene_oldfi(nin)%P(3,ideb(nin)+k)=bbufr(iadr(p)+l+7)
893 pene_oldfi(nin)%P(5,ideb(nin)+k)=bbufr(iadr(p)+l+9)
894 stif_oldfi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+8)
895 IF(iedg4 > 0)THEN
896 ispt2_fi(nin)%P(ideb(nin)+k)=bbufr(iadr(p)+l+10)
897 ENDIF
898 l=l+11
899 ENDDO
900 ELSE
901 DO k=1,nb
902 irtlm_fi(nin)%P(1,ideb(nin)+k)=bbufr(iadr(p)+l)
903 irtlm_fi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+1)
904 time_sfi(nin)%P(ideb(nin)+k)=bbufr(iadr(p)+l+2)
905C Same initialization than in i24optcd :
906C copy SECND_FRFI(1,2,3) into SECND_FRFI(4,5,6) & Flush SECND_FRFI to zero
907 secnd_frfi(nin)%P(1,ideb(nin)+k)=zero
908 secnd_frfi(nin)%P(2,ideb(nin)+k)=zero
909 secnd_frfi(nin)%P(3,ideb(nin)+k)=zero
910 secnd_frfi(nin)%P(4,ideb(nin)+k)=bbufr(iadr(p)+l+3)
911 secnd_frfi(nin)%P(5,ideb(nin)+k)=bbufr(iadr(p)+l+4)
912 secnd_frfi(nin)%P(6,ideb(nin)+k)=bbufr(iadr(p)+l+5)
913 pene_oldfi(nin)%P(1,ideb(nin)+k)=zero
914 pene_oldfi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+6)
915 pene_oldfi(nin)%P(3,ideb(nin)+k)=bbufr(iadr(p)+l+7)
916 pene_oldfi(nin)%P(5,ideb(nin)+k)=bbufr(iadr(p)+l+9)
917 stif_oldfi(nin)%P(1,ideb(nin)+k)=zero
918 stif_oldfi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+8)
919 IF(iedg4 > 0)THEN
920 ispt2_fi(nin)%P(ideb(nin)+k)=bbufr(iadr(p)+l+10)
921 ENDIF
922 l=l+11
923 ENDDO
924 END if!(IMPL_S>0.AND.IGSTI==6)THEN
925 ENDIF
926 ENDIF
927 ideb(nin)=ideb(nin)+nb
928 ENDDO
929 ENDIF
930 ENDDO
931
932C end of send
933 DO p = 1, nspmd
934 IF (p==nspmd)THEN
935 siz=lensd-iads(p)
936 ELSE
937 siz=iads(p+1)-iads(p)
938 ENDIF
939 IF(siz>0) THEN
940 CALL mpi_wait(req_si(p),status,ierror)
941 ENDIF
942 ENDDO
943
944
945 IF (ALLOCATED(bbufs)) DEALLOCATE(bbufs)
946 IF (ALLOCATED(bbufr)) DEALLOCATE(bbufr)
947
948C Fourth part of Comm routine has been done
949 i24com4=0
950 ENDIF ! fi iflag=4
951#endif
952 RETURN
953 END
my_real
#define my_real
Definition cppsort.cpp:32
if
if(complex_arithmetic) id
max
#define max(a, b)
Definition macros.h:21
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_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
message_mod
Definition message_mod.F:1257
tri7box::ispt2_fi
type(int_pointer), dimension(:), allocatable ispt2_fi
Definition tri7box.F:538
tri7box::stif_oldfi
type(real_pointer2), dimension(:), allocatable stif_oldfi
Definition tri7box.F:545
tri7box::secnd_frfi
type(real_pointer2), dimension(:), allocatable secnd_frfi
Definition tri7box.F:543
tri7box::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
tri7box::nsvsi
type(int_pointer), dimension(:), allocatable nsvsi
Definition tri7box.F:485
tri7box::nsnsi
type(int_pointer), dimension(:), allocatable nsnsi
Definition tri7box.F:491
tri7box::isedge_fi
type(int_pointer), dimension(:), allocatable isedge_fi
Definition tri7box.F:540
tri7box::pene_oldfi
type(real_pointer2), dimension(:), allocatable pene_oldfi
Definition tri7box.F:544
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
spmd_exch_i24
subroutine spmd_exch_i24(ipari, intbuf_tab, itab, iad_elem, fr_elem, intlist, nbintc, iad_i24, fr_i24, sfr_i24, i24maxnsne, flag, int24e2euse)
Definition spmd_exch_i24.F:41
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