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