OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_exch_i25.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_i25 ../engine/source/mpi/interfaces/spmd_exch_i25.F
27!||--- called by ------------------------------------------------------
28!|| resol ../engine/source/engine/resol.F
29!||--- calls -----------------------------------------------------
30!|| ancmsg ../engine/source/output/message/message.F
31!|| arret ../engine/source/system/arret.F
32!||--- uses -----------------------------------------------------
33!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
34!|| message_mod ../engine/share/message_module/message_mod.F
35!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.f90
36!|| tri7box ../engine/share/modules/tri7box.F
37!||====================================================================
38 SUBROUTINE spmd_exch_i25(IPARI ,INTBUF_TAB ,ITAB,
39 * IAD_ELEM ,FR_ELEM,INTLIST,NBINTC,
40 * IAD_I25 ,FR_I25 ,SFR_I25,FLAG)
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 "assert.inc"
59#include "param_c.inc"
60#include "com04_c.inc"
61#include "task_c.inc"
62#include "com01_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER IPARI(NPARI,*),IAD_ELEM(2,*),FR_ELEM(*),
67 * ITAB(*),INTLIST(*),NBINTC,FLAG
68 integer
69 * iad_i25(nbintc+1,nspmd), sfr_i25,fr_i25(sfr_i25)
70C
71 TYPE(intbuf_struct_) INTBUF_TAB(*)
72C-----------------------------------------------
73C L o c a l V a r i a b l e s
74C-----------------------------------------------
75#ifdef MPI
76 INTEGER STATUS(MPI_STATUS_SIZE)
77 INTEGER P,LENSD,LENRV,IERROR,
78 * siz,loc_proc,msgtyp,ideb(ninter),idb,proc,
79 * msgoff,msgoff2,msgoff3,msgoff4,msgoff5
80 INTEGER I,J,L,NB,NL,NN,K,N,NOD,MODE,LEN,ALEN,ND,FLG,NIN,NTY,
81 * NSN,SN,SSIZ,NBI,
82 * surf,surfr,subtriar,kleave,kleave_r,proc_r,i_stok,it,ct,ms,
83 * ni,ilen,rlen,li,lr
84
85 my_real
86 * time_s_1, time_s_2, time_sr_1, time_sr_2
87 my_real ,
88 * DIMENSION(:), ALLOCATABLE :: bbufs, bbufr,rrecbuf
89 my_real ,
90 * DIMENSION(:,:), ALLOCATABLE :: rsendbuf
91
92
93 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ISENDBUF
94 INTEGER, DIMENSION(:), ALLOCATABLE :: IRECBUF
95 INTEGER, DIMENSION(:), ALLOCATABLE :: SNIDX
96 INTEGER, DIMENSION(:), ALLOCATABLE :: ITRI,INDTRI,ISCANDR
97 INTEGER, DIMENSION(:), ALLOCATABLE:: REQ_SI,REQ_RI,REQ_S,IADS
98 INTEGER, DIMENSION(:), ALLOCATABLE:: REQ_S2,REQ_R,REQ_R2,IADR
99
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 loc_proc = ispmd+1
112C ----------------------------------
113C IFLAG=1 partie1 - Send
114C ----------------------------------
115 IF(flag==1)THEN
116C WRITE(6,*) __FILE__,__LINE__ ; CALL FLUSH(6)
117 assert(.NOT.(ALLOCATED(req_si)))
118 assert(.NOT.(ALLOCATED(req_ri)))
119 assert(.NOT.(ALLOCATED(req_s)))
120 assert(.NOT.(ALLOCATED(req_s2)))
121 assert(.NOT.(ALLOCATED(req_r)))
122 assert(.NOT.(ALLOCATED(req_r2)))
123 assert(.NOT.(ALLOCATED(iadr)))
124 assert(.NOT.(ALLOCATED(iads)))
125
126 ALLOCATE(req_si(nspmd))
127 ALLOCATE(req_ri(nspmd))
128 ALLOCATE(req_s(nspmd))
129 ALLOCATE(req_s2(nspmd))
130 ALLOCATE(req_r(nspmd))
131 ALLOCATE(req_r2(nspmd))
132 ALLOCATE(iadr(nspmd+1))
133 ALLOCATE(iads(nspmd+1))
134
135C--------------------------------------------------------
136
137C Comm sur l'interface type 25
138C 1ere partie, on ramene sur le proc qui a les noeuds slv les valeurs de IRTLM_FI + TIME_SFI & traitements
139C 2eme partie on les traite sur le proc qui a les neouds slv les valeurs
140C 3eme partie on renvoie sur les procs remotes les valeurs globalisees
141
142C--------------------------------------------------------
143C 1ere partie, on ramene sur le proc qui a les neouds slv les valeurs de IRTLM_FI + TIME_SFI
144C--------------------------------------------------------
145
146 loc_proc = ispmd+1
147 iads(1:nspmd+1) = 0
148 iadr(1:nspmd+1) = 0
149 lensd = 0
150 lenrv = 0
151
152 alen=6
153
154
155C Comptage des tailles de buffer Reception et envoi
156 DO p=1,nspmd
157 iadr(p)=lenrv+1
158 DO ni=1,nbintc
159 nin = intlist(ni)
160 nty=ipari(7,nin)
161 IF(nty==25)THEN
162 lensd = lensd + nsnfi(nin)%P(p)*alen
163 lenrv = lenrv + nsnsi(nin)%P(p)*alen
164 ENDIF
165 ENDDO
166 ENDDO
167 iadr(nspmd+1)=lenrv+1
168
169C Preparation du send
170 IF(lensd>0)THEN
171 ALLOCATE(bbufs(lensd),stat=ierror)
172 IF(ierror/=0) THEN
173 CALL ancmsg(msgid=20,anmode=aninfo)
174 CALL arret(2)
175 ENDIF
176 ENDIF
177
178C ---------------------------------------------
179C Preparation du recieve
180 IF(lenrv>0)THEN
181 ALLOCATE(bbufr(lenrv),stat=ierror)
182 IF(ierror/=0) THEN
183 CALL ancmsg(msgid=20,anmode=aninfo)
184 CALL arret(2)
185 ENDIF
186 ENDIF
187
188 DO p=1, nspmd
189 siz=iadr(p+1)-iadr(p)
190 IF (siz > 0) THEN
191 msgtyp = msgoff2
192 CALL mpi_irecv( bbufr(iadr(p)),siz,real,it_spmd(p),msgtyp,
193 * spmd_comm_world,req_r(p),ierror )
194 ENDIF
195 ENDDO
196
197C ---------------------------------------------
198C Send
199 l=1
200 ideb=0
201 DO p=1, nspmd
202 iads(p)=l
203 IF (p/= loc_proc) THEN
204 DO ni=1,nbintc
205 nin = intlist(ni)
206 nty =ipari(7,nin)
207 IF(nty==25) THEN
208 nb = nsnfi(nin)%P(p)
209 DO nn=1,nb
210 bbufs(l) =irtlm_fi(nin)%P(1,nn+ideb(nin))
211 bbufs(l+1) =irtlm_fi(nin)%P(2,nn+ideb(nin))
212 bbufs(l+2) =irtlm_fi(nin)%P(3,nn+ideb(nin))
213 bbufs(l+3) =irtlm_fi(nin)%P(4,nn+ideb(nin))
214 bbufs(l+4) =time_sfi(nin)%P(2*(nn+ideb(nin)-1)+1)
215 bbufs(l+5) =time_sfi(nin)%P(2*(nn+ideb(nin)-1)+2)
216 l=l+alen
217 ENDDO
218 ideb(nin)=ideb(nin)+nb
219 ENDIF
220 ENDDO ! DO NIN=1,NINTER
221 siz = l-iads(p)
222 IF(siz>0)THEN
223 msgtyp = msgoff2
224 CALL mpi_isend(
225 . bbufs(iads(p)),siz,real ,it_spmd(p),msgtyp,
226 . spmd_comm_world,req_si(p),ierror )
227 ENDIF
228 ENDIF ! ENDIF P/= LOC_PROC
229 ENDDO ! DO P=1, NSPMD
230
231
232 RETURN
233 ENDIF
234
235C----------------------------------
236C IFLAG=2 partie2 - Recieve
237C ----------------------------------
238 IF(flag==2)THEN
239
240 alen=6
241
242C Recieve
243 l=0
244 ideb = 0
245
246 DO p=1, nspmd
247 l=0
248 siz=iadr(p+1)-iadr(p)
249 IF (siz > 0) THEN
250 msgtyp = msgoff2
251
252C WAIT
253 CALL mpi_wait(req_r(p),status,ierror)
254
255 DO ni=1,nbintc
256 nin = intlist(ni)
257 nty =ipari(7,nin)
258
259 IF(nty==25)THEN
260
261 nb = nsnsi(nin)%P(p)
262 IF (nb > 0)THEN
263C
264 DO k=1,nb
265 nd = nsvsi(nin)%P(ideb(nin)+k)
266
267C Merge IRTLM & TIME_S
268 sn = intbuf_tab(nin)%NSV(nd)
269 time_s_1 = intbuf_tab(nin)%TIME_S(2*(nd-1)+1)
270 time_s_2 = intbuf_tab(nin)%TIME_S(2*(nd-1)+2)
271 surf = intbuf_tab(nin)%IRTLM(4*(nd-1)+1)
272 kleave = intbuf_tab(nin)%IRTLM(4*(nd-1)+3)
273 surfr = nint(bbufr(iadr(p)+l))
274 subtriar = nint(bbufr(iadr(p)+l+1))
275 kleave_r = nint(bbufr(iadr(p)+l+2))
276 proc_r = nint(bbufr(iadr(p)+l+3))
277 time_sr_1 = bbufr(iadr(p)+l+4)
278 time_sr_2 = bbufr(iadr(p)+l+5)
279
280 IF(kleave == -1)THEN
281
282 ELSEIF(kleave_r == -1)THEN
283C
284C IRTLM has been reset after main segment deletion (Idel)
285 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = 0
286 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = 0
287 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = -1
288 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
289
290 ELSEIF (surf > 0)THEN
291
292 IF(time_s_1 == ep20)THEN
293
294 IF(surfr > 0 .AND. time_sr_1 /= ep20)THEN
295
296c IF( TIME_SR_2 == EP20 .OR.
297c . (TIME_SR_2 /= EP20 .AND. TIME_S_2 == TIME_SR_2 .AND. SURFR > SURF))THEN
298c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+1) = SURFR
299c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+2) = SUBTRIAR
300c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+3) = KLEAVE_R
301c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+4) = PROC_R
302c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1
303c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+2) = TIME_SR_2
304c ELSEIF(ABS(TIME_S_2) > ABS(TIME_SR_2))THEN
305 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
306 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
307 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
308 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
309 intbuf_tab(nin)%TIME_S(2*(nd-1)+1) = time_sr_1
310 intbuf_tab(nin)%TIME_S(2*(nd-1)+2) = time_sr_2
311c END IF
312
313c inutile
314c elseif(SURFR > 0 .AND. TIME_SR_1 == EP20 .AND. KLEAVE_R > 0)THEN
315c
316c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+1) = SURFR
317c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+2) = SUBTRIAR
318c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+3) = KLEAVE_R
319c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+4) = PROC_R
320c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1
321c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+2) = TIME_SR_2
322c
323 END IF
324
325 ELSE ! TIME_S_1 /= EP20
326
327 IF(surfr > 0 .AND. time_sr_1 /= ep20 .AND. time_sr_2 /= ep20)THEN
328
329 IF(time_s_2 == time_sr_2)THEN
330 IF(surfr > surf)THEN
331 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
332 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
333 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
334 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
335C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1 == TIME_S_1
336C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+2) = TIME_SR_2 == TIME_S_2
337 END IF
338 ELSEIF(time_s_2 > time_sr_2)THEN
339 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
340 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
341 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
342 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
343C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1 == TIME_S_1
344 intbuf_tab(nin)%TIME_S(2*(nd-1)+2) = time_sr_2
345 END IF
346
347 END IF
348 END IF
349 ELSE ! SURF <= 0
350 IF(surfr < 0)THEN
351 IF(time_s_1 == time_sr_1)THEN
352 IF(-surfr > -surf)THEN
353 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
354 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
355 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
356 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
357C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1 == TIME_S_1
358 END IF
359 ELSEIF(time_sr_1 > time_s_1)THEN
360 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
361 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
362 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
363 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
364 intbuf_tab(nin)%TIME_S(2*(nd-1)+1) = time_sr_1
365 END IF
366 END IF
367 END IF
368C
369 l=l+alen
370c if(itab(sn)==29376)print *,'recoit nsnsi apr',loc_proc,p,INTBUF_TAB(NIN)%IRTLM(4*ND-3:4*ND)
371
372 ENDDO
373 ENDIF
374 ideb(nin)=ideb(nin)+nb
375 ENDIF ! ity==25
376 ENDDO
377 ENDIF ! IF (NB > 0)
378 l=l+siz
379 ENDDO ! DO P=1, NSPMD
380
381C Fin du send
382 DO p = 1, nspmd
383 IF (p==nspmd)THEN
384 siz=lensd-iads(p)
385 ELSE
386 siz=iads(p+1)-iads(p)
387 ENDIF
388 IF(siz>0) THEN
389 CALL mpi_wait(req_si(p),status,ierror)
390 ENDIF
391 ENDDO
392
393 IF (ALLOCATED(bbufs)) DEALLOCATE(bbufs)
394 IF (ALLOCATED(bbufr)) DEALLOCATE(bbufr)
395C-----------------------------------------------------------
396C 2eme partie - echanges sur les noeuds seconds frontieres
397C pour toutes les interface type 25.
398C-----------------------------------------------------------
399 iads(1:nspmd+1)=0
400
401 DO i=1,nspmd
402 assert(iad_i25(1,i) >= 0)
403 iads(i)=iad_i25(1,i)
404 ENDDO
405 iads(nspmd+1)=sfr_i25+1
406
407c print *,'iads',ispmd+1,iads(1),iads(2),iads(3)
408C Preparation du send
409 ilen=5
410 rlen=2
411 assert(sfr_i25 >= 0)
412 ALLOCATE(isendbuf(ilen,sfr_i25))
413 ALLOCATE(irecbuf(ilen*sfr_i25))
414 ALLOCATE(rsendbuf(rlen,sfr_i25))
415 ALLOCATE(rrecbuf(rlen*sfr_i25))
416
417C mise en place du irecieve
418 DO p=1,nspmd
419 siz = iads(p+1)-iads(p)
420 assert(siz >= 0)
421 IF(siz/=0)THEN
422 li = (iads(p)-1)*ilen+1
423 lr = (iads(p)-1)*rlen+1
424 msgtyp = msgoff3
425 len = siz*ilen
426c print *,'recept attend entier',ispmd+1,p,len
427 CALL mpi_irecv(
428 s irecbuf(li),len,mpi_integer,it_spmd(p),msgtyp,
429 g spmd_comm_world,req_r(p),ierror)
430
431 msgtyp = msgoff4
432 len = siz*rlen
433c print *,'recept attend reel',ispmd+1,p,len
434 CALL mpi_irecv(
435 s rrecbuf(lr),len,real,it_spmd(p),msgtyp,
436 g spmd_comm_world,req_r2(p),ierror)
437
438 ENDIF
439 ENDDO
440
441 nb = 1
442 DO p = 1, nspmd
443 DO ni=1,nbintc
444 nin=intlist(ni)
445 nty = ipari(7,nin)
446 nsn = ipari(5,nin)
447 IF(nty==25) THEN
448
449 DO i=iad_i25(ni,p),iad_i25(ni+1,p)-1
450
451 nd = fr_i25(i)
452 assert(nd > 0)
453 assert(nd <= nsn)
454 sn = intbuf_tab(nin)%NSV(nd)
455
456 isendbuf(1,nb) = itab(sn)
457 isendbuf(2,nb) = intbuf_tab(nin)%IRTLM(4*(nd-1)+1)
458 isendbuf(3,nb) = intbuf_tab(nin)%IRTLM(4*(nd-1)+2)
459 isendbuf(4,nb) = intbuf_tab(nin)%IRTLM(4*(nd-1)+3)
460 isendbuf(5,nb) = intbuf_tab(nin)%IRTLM(4*(nd-1)+4)
461 rsendbuf(1,nb) = intbuf_tab(nin)%TIME_S(2*(nd-1)+1)
462 rsendbuf(2,nb) = intbuf_tab(nin)%TIME_S(2*(nd-1)+2)
463 nb=nb+1
464 ENDDO
465 ENDIF
466 ENDDO ! DO NI=1,NBINTC
467 ENDDO ! DO P=1,NSPMD
468
469C--------------------------------------------------------------------
470C echange messages
471C
472 DO p=1,nspmd
473 siz = iads(p+1) - iads(p)
474 IF (siz >0)THEN
475 msgtyp = msgoff3
476 l = iads(p)
477 CALL mpi_isend(
478 s isendbuf(1,l),siz*ilen,mpi_integer,it_spmd(p),msgtyp,
479 g spmd_comm_world,req_s(p),ierror)
480c print *,'envoi entier',ispmd+1,p,siz*2
481
482 msgtyp = msgoff4
483 CALL mpi_isend(
484 s rsendbuf(1,l),siz*rlen,real,it_spmd(p),msgtyp,
485 g spmd_comm_world,req_s2(p),ierror)
486c print *,'envoi reel',ispmd+1,p,siz*8
487 ENDIF ! IF (SIZ >0)
488 ENDDO ! DO P=1,NSPMD
489C--------------------------------------------------------------------
490
491 RETURN
492 ENDIF
493
494C ----------------------------------
495C IFLAG=3 partie3 - Recieve
496C ----------------------------------
497 IF(flag==3)THEN
498
499 ilen = 5
500 rlen = 2
501C Reception
502 DO p=1,nspmd
503 siz = iads(p+1)-iads(p)
504 IF(siz/=0)THEN
505 idb = iads(p)
506 CALL mpi_wait(req_r(p),status,ierror)
507c print *,'recept recu entiers',ispmd+1,p
508
509 CALL mpi_wait(req_r2(p),status,ierror)
510c print *,'recept recu reels',ispmd+1,p
511
512C Traitements
513
514 DO ni=1,nbintc
515 nin = intlist(ni)
516
517 nty = ipari(7,nin)
518 nsn = ipari(5,nin)
519 IF (nty == 25)THEN
520
521 DO k=iad_i25(ni,p),iad_i25(ni+1,p)-1
522 nd = fr_i25(k)
523 sn = intbuf_tab(nin)%NSV(nd)
524
525 time_s_1 = intbuf_tab(nin)%TIME_S(2*(nd-1)+1)
526 time_s_2 = intbuf_tab(nin)%TIME_S(2*(nd-1)+2)
527 surf = intbuf_tab(nin)%IRTLM(4*(nd-1)+1)
528 kleave = intbuf_tab(nin)%IRTLM(4*(nd-1)+3)
529 surfr = irecbuf((idb-1)*ilen+2)
530 subtriar = irecbuf((idb-1)*ilen+3)
531 kleave_r = irecbuf((idb-1)*ilen+4)
532 proc_r = irecbuf((idb-1)*ilen+5)
533 time_sr_1 = rrecbuf((idb-1)*rlen+1)
534 time_sr_2 = rrecbuf((idb-1)*rlen+2)
535c if(itab(sn)==29376)print *,'recoit avant',loc_proc,p,INTBUF_TAB(NIN)%IRTLM(4*ND-3:4*ND)
536
537 IF(kleave == -1)THEN
538
539 ELSEIF(kleave_r == -1)THEN
540C
541C IRTLM has been reset after main segment deletion (Idel)
542 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = 0
543 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = 0
544 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = -1
545 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
546
547 ELSEIF (surf > 0)THEN
548
549 IF(time_s_1 == ep20)THEN
550
551 IF(surfr > 0 .AND. time_sr_1 /= ep20)THEN
552
553c IF( TIME_SR_2 == EP20 .OR.
554c . (TIME_SR_2 /= EP20 .AND. TIME_S_2 == TIME_SR_2 .AND. SURFR > SURF))THEN
555c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+1) = SURFR
556c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+2) = SUBTRIAR
557c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+3) = KLEAVE_R
558c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+4) = PROC_R
559c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1
560c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+2) = TIME_SR_2
561c ELSEIF(ABS(TIME_S_2) > ABS(TIME_SR_2))THEN
562 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
563 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
564 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
565 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
566 intbuf_tab(nin)%TIME_S(2*(nd-1)+1) = time_sr_1
567 intbuf_tab(nin)%TIME_S(2*(nd-1)+2) = time_sr_2
568c END IF
569
570
571c inutile
572c elseif(SURFR > 0 .AND. TIME_SR_1 == EP20 .AND. KLEAVE_R > 0)THEN
573cC
574cC le nd est ressorti du contact ou il etait precedemment sur le proc remote
575cC ------------------
576c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+1) = SURFR
577c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+2) = SUBTRIAR
578c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+3) = KLEAVE_R
579c INTBUF_TAB(NIN)%IRTLM(4*(ND-1)+4) = PROC_R
580c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1
581c INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+2) = TIME_SR_2
582c
583 END IF
584
585 ELSE ! TIME_S_1 /= EP20
586
587 IF(surfr > 0 .AND. time_sr_1 /= ep20 .AND. time_sr_2 /= ep20)THEN
588
589 IF(time_s_2 == time_sr_2)THEN
590 IF(surfr > surf)THEN
591 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
592 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
593 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
594 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
595C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1 == TIME_S_1
596C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+2) = TIME_SR_2 == TIME_S_2
597 END IF
598 ELSEIF(abs(time_s_2) > abs(time_sr_2))THEN
599 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
600 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
601 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
602 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
603C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1 == TIME_S_1
604 intbuf_tab(nin)%TIME_S(2*(nd-1)+2) = time_sr_2
605 END IF
606 END IF
607
608 END IF
609
610 ELSE ! SURF <= 0
611
612 IF(surfr < 0)THEN
613 IF(time_s_1 == time_sr_1)THEN
614 IF(-surfr > -surf)THEN
615 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
616 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
617 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
618 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
619C INTBUF_TAB(NIN)%TIME_S(2*(ND-1)+1) = TIME_SR_1 == TIME_S_1
620 END IF
621 ELSEIF(time_sr_1 > time_s_1)THEN
622 intbuf_tab(nin)%IRTLM(4*(nd-1)+1) = surfr
623 intbuf_tab(nin)%IRTLM(4*(nd-1)+2) = subtriar
624 intbuf_tab(nin)%IRTLM(4*(nd-1)+3) = kleave_r
625 intbuf_tab(nin)%IRTLM(4*(nd-1)+4) = proc_r
626 intbuf_tab(nin)%TIME_S(2*(nd-1)+1) = time_sr_1
627 END IF
628 END IF
629
630 END IF
631C
632c if(itab(sn)==29376)print *,'recoit apres',loc_proc,p,INTBUF_TAB(NIN)%IRTLM(4*ND-3:4*ND)
633
634 idb=idb+1
635 ENDDO ! K=,IAD_I25(NI,P),IAD_I25(NI+1,P)-1
636 ENDIF ! IF (NTY == 25)THEN
637 ENDDO ! DO NI=1,NBINTC
638 ENDIF ! IF(SIZ/=0)THEN
639 ENDDO ! DO P=1,NSPMD
640
641C Fin send
642 DO p=1,nspmd
643 siz = iads(p+1)-iads(p)
644 IF(siz/=0)THEN
645 CALL mpi_wait(req_s(p),status,ierror)
646 CALL mpi_wait(req_s2(p),status,ierror)
647 ENDIF
648 ENDDO
649
650 IF(ALLOCATED(isendbuf))DEALLOCATE(isendbuf)
651 IF(ALLOCATED(irecbuf))DEALLOCATE(irecbuf)
652 IF(ALLOCATED(rsendbuf))DEALLOCATE(rsendbuf)
653 IF(ALLOCATED(rrecbuf))DEALLOCATE(rrecbuf)
654
655C ------------------------------------------------------------------
656C 3e partie on renvoie les valeurs globalisees sur les procs remote
657C ------------------------------------------------------------------
658 loc_proc = ispmd+1
659 iads = 0
660 iadr = 0
661 lensd = 0
662 lenrv = 0
663
664 alen=6
665C Comptage des tailles de buffer Receeption et envoi
666 DO p=1,nspmd
667 iadr(p)=lenrv+1
668 DO ni=1,nbintc
669 nin = intlist(ni)
670 nty=ipari(7,nin)
671 IF(nty==25) THEN
672 lensd = lensd + nsnsi(nin)%P(p)*alen
673 lenrv = lenrv + nsnfi(nin)%P(p)*alen
674 ENDIF
675 ENDDO
676 ENDDO
677 iadr(nspmd+1)=lenrv+1
678
679 IF(lensd>0)THEN
680 ALLOCATE(bbufs(lensd),stat=ierror)
681 IF(ierror/=0) THEN
682 CALL ancmsg(msgid=20,anmode=aninfo)
683 CALL arret(2)
684 ENDIF
685 ENDIF
686
687C Preparation du recieve
688 IF(lenrv>0)THEN
689 ALLOCATE(bbufr(lenrv),stat=ierror)
690 IF(ierror/=0) THEN
691 CALL ancmsg(msgid=20,anmode=aninfo)
692 CALL arret(2)
693 ENDIF
694 ENDIF
695
696
697 DO p=1, nspmd
698 siz=iadr(p+1)-iadr(p)
699 IF (siz > 0) THEN
700 msgtyp = msgoff5
701 CALL mpi_irecv( bbufr(iadr(p)),siz,real,it_spmd(p),msgtyp,
702 * spmd_comm_world,req_r(p),ierror )
703 ENDIF
704 ENDDO
705
706C Send
707 l=1
708 ideb = 0
709 DO p=1, nspmd
710 iads(p)=l
711 IF (p/= loc_proc) THEN
712 DO ni=1,nbintc
713 nin = intlist(ni)
714 nty =ipari(7,nin)
715 IF(nty==25)THEN
716 nb = nsnsi(nin)%P(p)
717C Preparation du send
718 DO nn=1,nb
719 nd = nsvsi(nin)%P(ideb(nin)+nn)
720 nod=intbuf_tab(nin)%NSV(nd)
721c if(itab(sn)==29376)print *,'broadcast nsnsi',loc_proc,p,INTBUF_TAB(NIN)%IRTLM(4*ND-3:4*ND)
722 bbufs(l )=intbuf_tab(nin)%IRTLM(4*(nd-1)+1)
723 bbufs(l+1)=intbuf_tab(nin)%IRTLM(4*(nd-1)+2)
724 bbufs(l+2)=intbuf_tab(nin)%IRTLM(4*(nd-1)+3)
725 bbufs(l+3)=intbuf_tab(nin)%IRTLM(4*(nd-1)+4)
726 bbufs(l+4)=intbuf_tab(nin)%TIME_S(2*(nd-1)+1)
727 bbufs(l+5)=intbuf_tab(nin)%TIME_S(2*(nd-1)+2)
728 l = l + alen
729 ENDDO
730 ideb(nin)=ideb(nin)+nb
731 ENDIF
732 ENDDO
733
734 siz = l-iads(p)
735 IF(siz>0)THEN
736 msgtyp = msgoff5
737C Send
738 CALL mpi_isend(
739 . bbufs(iads(p)),siz,real ,it_spmd(p),msgtyp,
740 . spmd_comm_world,req_si(p),ierror )
741 ENDIF
742 ENDIF
743 ENDDO
744 iads(nspmd+1)=l
745
746 RETURN
747 ENDIF
748
749C ----------------------------------
750C IFLAG=4 partie4 - Recieve
751C ----------------------------------
752 IF(flag==4)THEN
753
754 alen=6
755C Recieve
756 l=0
757 ideb = 0
758
759 DO p=1, nspmd
760 l=0
761 siz=iadr(p+1)-iadr(p)
762 IF (siz > 0) THEN
763
764 CALL mpi_wait(req_r(p),status,ierror)
765 DO ni=1,nbintc
766 nin=intlist(ni)
767 nty =ipari(7,nin)
768
769 IF(nty==25) THEN
770 nb = nsnfi(nin)%P(p)
771
772 IF (nb > 0)THEN
773 DO k=1,nb
774c if(itafi(nin)%p(ideb(nin)+k)==29376)print *,'recoit nsnfi',loc_proc,p,
775c . BBUFR(IADR(P)+L:IADR(P)+L+3)
776 irtlm_fi(nin)%P(1,ideb(nin)+k)=bbufr(iadr(p)+l)
777 irtlm_fi(nin)%P(2,ideb(nin)+k)=bbufr(iadr(p)+l+1)
778 irtlm_fi(nin)%P(3,ideb(nin)+k)=bbufr(iadr(p)+l+2)
779 irtlm_fi(nin)%P(4,ideb(nin)+k)=bbufr(iadr(p)+l+3)
780 time_sfi(nin)%P(2*(ideb(nin)+k-1)+1) =bbufr(iadr(p)+l+4)
781 time_sfi(nin)%P(2*(ideb(nin)+k-1)+2) =bbufr(iadr(p)+l+5)
782 l=l+alen
783 ENDDO
784 ENDIF
785 ideb(nin)=ideb(nin)+nb
786 ENDIF
787 ENDDO
788 ENDIF
789 ENDDO
790
791C Fin du send
792 DO p = 1, nspmd
793 IF (p==nspmd)THEN
794 siz=lensd-iads(p)
795 ELSE
796 siz=iads(p+1)-iads(p)
797 ENDIF
798 IF(siz>0) THEN
799 CALL mpi_wait(req_si(p),status,ierror)
800 ENDIF
801 ENDDO
802
803
804C WRITE(6,*) __FILE__,__LINE__
805 IF(ALLOCATED(bbufs)) DEALLOCATE(bbufs)
806 IF(ALLOCATED(bbufr)) DEALLOCATE(bbufr)
807 IF(ALLOCATED( req_si )) DEALLOCATE(req_si)
808 IF(ALLOCATED( req_ri )) DEALLOCATE(req_ri)
809 IF(ALLOCATED( req_s )) DEALLOCATE(req_s)
810 IF(ALLOCATED( req_s2 )) DEALLOCATE(req_s2)
811 IF(ALLOCATED( req_r )) DEALLOCATE(req_r)
812 IF(ALLOCATED( req_r2 )) DEALLOCATE(req_r2)
813 IF(ALLOCATED( iadr )) DEALLOCATE(iadr)
814 IF(ALLOCATED( iads )) DEALLOCATE(iads)
815
816 ENDIF ! fi iflag=4
817#endif
818 RETURN
819 END
my_real
#define my_real
Definition cppsort.cpp:32
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::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::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
spmd_exch_i25
subroutine spmd_exch_i25(ipari, intbuf_tab, itab, iad_elem, fr_elem, intlist, nbintc, iad_i25, fr_i25, sfr_i25, flag)
Definition spmd_exch_i25.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