OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_r2r.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!|| spmd_r2r_rget3 ../engine/source/mpi/r2r/spmd_r2r.F
25!||--- called by ------------------------------------------------------
26!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.F
27!|| send_data_spmd ../engine/source/coupling/rad2rad/r2r_exchange.F
28!||--- calls -----------------------------------------------------
29!||--- uses -----------------------------------------------------
30!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
31!||====================================================================
32 SUBROUTINE spmd_r2r_rget3(
33 1 X ,NNG ,GRNOD, DD_R2R, WEIGHT, BUFR)
34C-----------------------------------------------
35C I m p l i c i t T y p e s
36C-----------------------------------------------
37 USE spmd_comm_world_mod, ONLY : spmd_comm_world
38#include "implicit_f.inc"
39C-----C-----------------------------------------------------------------
40C M e s s a g e P a s s i n g
41C-----------------------------------------------
42#include "spmd.inc"
43C-----------------------------------------------
44C C o m m o n B l o c k s
45C-----------------------------------------------
46#include "com01_c.inc"
47#include "task_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 INTEGER NNG, GRNOD(*), DD_R2R(*), WEIGHT(*)
52 my_real
53 . bufr(3,*), x(3,*)
54C-----------------------------------------------
55C L o c a l V a r i a b l e s
56C-----------------------------------------------
57#ifdef MPI
58 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
59 . status(mpi_status_size)
60 DATA msgoff/5000/
61C-----------------------------------------------
62C
63 loc_proc = ispmd+1
64 l = 0
65 DO i = 1, nng
66 n=grnod(i)
67 IF(weight(n)==1)THEN
68 l = l + 1
69 bufr(1,l) = x(1,n)
70 bufr(2,l) = x(2,n)
71 bufr(3,l) = x(3,n)
72 END IF
73 END DO
74 IF(loc_proc==1) THEN
75 DO p = 2, nspmd
76 IF(dd_r2r(p)>0)THEN
77 bufsiz = 3*dd_r2r(p)
78 msgtyp = msgoff
79 CALL mpi_recv(
80 s bufr(1,l+1),bufsiz,real,it_spmd(p),msgtyp,
81 g spmd_comm_world,status,ierror)
82 l = l + dd_r2r(p)
83 END IF
84 END DO
85 ELSEIF(l>0)THEN
86 msgtyp = msgoff
87 CALL mpi_send(
88 s bufr,l*3,real,it_spmd(1),msgtyp,
89 g spmd_comm_world,ierror)
90 END IF
91C
92#endif
93 RETURN
94 END
95C
96!||====================================================================
97!|| spmd_r2r_rget3_dp ../engine/source/mpi/r2r/spmd_r2r.F
98!||--- called by ------------------------------------------------------
99!|| send_data_spmd ../engine/source/coupling/rad2rad/r2r_exchange.F
100!||--- calls -----------------------------------------------------
101!||--- uses -----------------------------------------------------
102!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
103!||====================================================================
104 SUBROUTINE spmd_r2r_rget3_dp(
105 1 X ,NNG ,GRNOD, DD_R2R, WEIGHT, BUFR)
106C-----------------------------------------------
107C I m p l i c i t T y p e s
108C-----------------------------------------------
109 USE spmd_comm_world_mod, ONLY : spmd_comm_world
110#include "implicit_f.inc"
111C-----C-----------------------------------------------------------------
112C M e s s a g e P a s s i n g
113C-----------------------------------------------
114#include "spmd.inc"
115C-----------------------------------------------
116C C o m m o n B l o c k s
117C-----------------------------------------------
118#include "com01_c.inc"
119#include "task_c.inc"
120C-----------------------------------------------
121C D u m m y A r g u m e n t s
122C-----------------------------------------------
123 INTEGER NNG, GRNOD(*), DD_R2R(*), WEIGHT(*)
124 DOUBLE PRECISION
125 . bufr(3,*), x(3,*)
126C-----------------------------------------------
127C L o c a l V a r i a b l e s
128C-----------------------------------------------
129#ifdef MPI
130 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
131 . STATUS(MPI_STATUS_SIZE)
132 DATA msgoff/5001/
133C-----------------------------------------------
134C
135 loc_proc = ispmd+1
136 l = 0
137 DO i = 1, nng
138 n=grnod(i)
139 IF(weight(n)==1)THEN
140 l = l + 1
141 bufr(1,l) = x(1,n)
142 bufr(2,l) = x(2,n)
143 bufr(3,l) = x(3,n)
144 END IF
145 END DO
146 IF(loc_proc==1) THEN
147 DO p = 2, nspmd
148 IF(dd_r2r(p)>0)THEN
149 bufsiz = 3*dd_r2r(p)
150 msgtyp = msgoff
151 CALL mpi_recv(
152 s bufr(1,l+1),bufsiz,mpi_double_precision,it_spmd(p),
153 g msgtyp,spmd_comm_world,status,ierror)
154 l = l + dd_r2r(p)
155 END IF
156 END DO
157 ELSEIF(l>0)THEN
158 msgtyp = msgoff
159 CALL mpi_send(
160 s bufr,l*3,mpi_double_precision,it_spmd(1),msgtyp,
161 g spmd_comm_world,ierror)
162 END IF
163C
164#endif
165 RETURN
166 END
167C
168!||====================================================================
169!|| spmd_r2r_rget ../engine/source/mpi/r2r/spmd_r2r.F
170!||--- called by ------------------------------------------------------
171!|| send_data_spmd ../engine/source/coupling/rad2rad/r2r_exchange.F
172!|| send_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.f
173!|| send_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
174!||--- calls -----------------------------------------------------
175!||--- uses -----------------------------------------------------
176!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
177!||====================================================================
178 SUBROUTINE spmd_r2r_rget(
179 1 M ,NNG ,GRNOD, DD_R2R, WEIGHT, BUFR)
180C-----------------------------------------------
181C I m p l i c i t T y p e s
182C-----------------------------------------------
183 USE spmd_comm_world_mod, ONLY : spmd_comm_world
184#include "implicit_f.inc"
185C-----C-----------------------------------------------------------------
186C M e s s a g e P a s s i n g
187C-----------------------------------------------
188#include "spmd.inc"
189C-----------------------------------------------
190C C o m m o n B l o c k s
191C-----------------------------------------------
192#include "com01_c.inc"
193#include "task_c.inc"
194C-----------------------------------------------
195C D u m m y A r g u m e n t s
196C-----------------------------------------------
197 INTEGER NNG, GRNOD(*), DD_R2R(*), WEIGHT(*)
198 my_real
199 . BUFR(*), M(*)
200C-----------------------------------------------
201C L o c a l V a r i a b l e s
202C-----------------------------------------------
203#ifdef MPI
204 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
205 . STATUS(MPI_STATUS_SIZE)
206 DATA MSGOFF/5002/
207C-----------------------------------------------
208C
209 loc_proc = ispmd+1
210 l = 0
211 DO i = 1, nng
212 n=grnod(i)
213 IF(weight(n)==1)THEN
214 l = l + 1
215 bufr(l) = m(n)
216 END IF
217 END DO
218 IF(loc_proc==1) THEN
219 DO p = 2, nspmd
220 IF(dd_r2r(p)>0)THEN
221 bufsiz = dd_r2r(p)
222 msgtyp = msgoff
223 CALL mpi_recv(
224 s bufr(l+1),bufsiz,real,it_spmd(p),msgtyp,
225 g spmd_comm_world,status,ierror)
226 l = l + dd_r2r(p)
227 END IF
228 END DO
229 ELSEIF(l>0)THEN
230 msgtyp = msgoff
231 CALL mpi_send(
232 s bufr,l,real,it_spmd(1),msgtyp,
233 g spmd_comm_world,ierror)
234 END IF
235C
236#endif
237 RETURN
238 END
239C
240!||====================================================================
241!|| spmd_r2r_rby ../engine/source/mpi/r2r/spmd_r2r.F
242!||--- called by ------------------------------------------------------
243!|| send_data_spmd ../engine/source/coupling/rad2rad/r2r_exchange.F
244!||--- calls -----------------------------------------------------
245!||--- uses -----------------------------------------------------
246!|| rad2r_mod ../engine/share/modules/rad2r.F
247!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
248!||====================================================================
249 SUBROUTINE spmd_r2r_rby(
250 1 RBY ,NNG ,GRNOD, DD_R2R, WEIGHT, IEX, BUFR)
251C----6----------------------------------------------------------------
252C M o d u l e s
253C-----------------------------------------------
254 USE rad2r_mod
255C-----------------------------------------------
256C I m p l i c i t T y p e s
257C-----------------------------------------------
258 USE spmd_comm_world_mod, ONLY : spmd_comm_world
259#include "implicit_f.inc"
260C-----C----------------------------------------------------------------
261C M e s s a g e P a s s i n g
262C-----------------------------------------------
263#include "spmd.inc"
264C-----------------------------------------------
265C C o m m o n B l o c k s
266C-----------------------------------------------
267#include "com01_c.inc"
268#include "param_c.inc"
269#include "task_c.inc"
270C-----------------------------------------------
271C D u m m y A r g u m e n t s
272C-----------------------------------------------
273 INTEGER NNG, GRNOD(*), DD_R2R(*), WEIGHT(*), IEX
274 my_real
275 . BUFR(9,*), RBY(NRBY,*)
276C-----------------------------------------------
277C L o c a l V a r i a b l e s
278C-----------------------------------------------
279#ifdef MPI
280 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
281 . STATUS(MPI_STATUS_SIZE),NOD
282 DATA MSGOFF/5003/
283C-----------------------------------------------
284C
285 loc_proc = ispmd+1
286 l = 0
287 DO i = 1, nng
288 nod=grnod(i)
289 IF(weight(nod)==1)THEN
290 n=tag_rby(add_rby(iex)+i)
291 l = l + 1
292 DO p = 1, 9
293 bufr(p,l) = rby(16+p,n)
294 END DO
295 END IF
296 END DO
297 IF(loc_proc==1) THEN
298 DO p = 2, nspmd
299 IF(dd_r2r(p)>0)THEN
300 bufsiz = 9*dd_r2r(p)
301 msgtyp = msgoff
302 CALL mpi_recv(
303 s bufr(1,l+1),bufsiz,real,it_spmd(p),msgtyp,
304 g spmd_comm_world,status,ierror)
305 l = l + dd_r2r(p)
306 END IF
307 END DO
308 ELSEIF(l>0)THEN
309 msgtyp = msgoff
310 CALL mpi_send(
311 s bufr,l*9,real,it_spmd(1),msgtyp,
312 g spmd_comm_world,ierror)
313 END IF
314C
315#endif
316 RETURN
317 END
318C
319!||====================================================================
320!|| spmd_r2r_idef ../engine/source/mpi/r2r/spmd_r2r.F
321!||--- called by ------------------------------------------------------
322!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.F
323!||--- calls -----------------------------------------------------
324!||--- uses -----------------------------------------------------
325!|| rad2r_mod ../engine/share/modules/rad2r.F
326!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
327!||====================================================================
328 SUBROUTINE spmd_r2r_idef(NNG,GRNOD,WEIGHT,IEX,TLEL,TLELN,TCNEL,TCNELDB)
329C-----------------------------------------------
330C M o d u l e s
331C-----------------------------------------------
332 USE rad2r_mod
333C-----------------------------------------------
334C I m p l i c i t T y p e s
335C-----------------------------------------------
336 USE spmd_comm_world_mod, ONLY : spmd_comm_world
337#include "implicit_f.inc"
338C-----C-----------------------------------------------------------------
339C M e s s a g e P a s s i n g
340C-----------------------------------------------
341#include "spmd.inc"
342C-----------------------------------------------
343C C o m m o n B l o c k s
344C-----------------------------------------------
345#include "com01_c.inc"
346#include "com04_c.inc"
347#include "task_c.inc"
348C-----------------------------------------------
349C D u m m y A r g u m e n t s
350C-----------------------------------------------
351 INTEGER NNG, GRNOD(*), WEIGHT(*),IEX,TLEL,TLELN,TCNEL,TCNELDB
352C-----------------------------------------------
353C L o c a l V a r i a b l e s
354C-----------------------------------------------
355#ifdef MPI
356 INTEGER I, P, N, L(6), IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
357 . STATUS(MPI_STATUS_SIZE),NB(6),OFFSET1
358 DATA MSGOFF/5004/
359C-----------------------------------------------
360C
361C --- Recolte des infos sur les procs : nb d'elements a envoyer, noeuds doubles, etc ...
362C
363 loc_proc = ispmd+1
364 l(1) = 0
365 l(2) = 0
366 l(3) = 0
367 l(4) = 0
368 l(5) = 0
369 l(6) = 0
370
371 DO i = 1, nng
372 n=grnod(i)
373 IF(weight(n)==0)THEN
374 l(1) = l(1) + 1
375 END IF
376 END DO
377 l(2) = tlel
378 l(3) = numels+numelq+numelc+numelt+numelp+numelr+numeltg
379 l(4) = tleln
380 l(5) = tcnel
381 l(6) = tcneldb
382
383 IF(loc_proc==1) THEN
384 dbn(iex,1)=l(1)
385 dbno(iex)=l(1)
386 nbel(iex,1) = l(2)
387 nbelt_r2r(iex) = l(2)
388 nbeltn_r2r(iex) = l(4)
389 offset(1)=0
390 offset1 = l(3)
391 tbcnel(iex,1) = l(5)
392 tcnelt(iex) = l(5)
393 tbcneldb(iex,1) = l(6)
394 tcneltdb(iex) = l(6)
395
396 DO p = 2, nspmd
397 msgtyp = msgoff
398 CALL mpi_recv(
399 s nb,6,mpi_integer,it_spmd(p),msgtyp,
400 g spmd_comm_world,status,ierror)
401
402 dbn(iex,p) = nb(1)
403 nbel(iex,p) = nb(2)
404 nbeln(iex,p) = nb(4)
405 dbno(iex) = dbno(iex) + dbn(iex,p)
406 nbelt_r2r(iex) = nbelt_r2r(iex) + nbel(iex,p)
407 nbeltn_r2r(iex) = nbeltn_r2r(iex) + nbeln(iex,p)
408 offset(p)= offset1
409 offset1 = offset1 + nb(3)
410 tbcnel(iex,p) = nb(5)
411 tcnelt(iex) = tcnelt(iex) + nb(5)
412 tbcneldb(iex,p) = nb(6)
413 tcneltdb(iex) = tcneltdb(iex)+nb(6)
414 END DO
415 ELSE
416 msgtyp = msgoff
417 CALL mpi_send(
418 s l,6,mpi_integer,it_spmd(1),msgtyp,
419 g spmd_comm_world,ierror)
420 END IF
421C
422#endif
423 RETURN
424 END
425!||====================================================================
426!|| spmd_r2r_iget ../engine/source/mpi/r2r/spmd_r2r.F
427!||--- called by ------------------------------------------------------
428!|| get_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
429!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.F
430!|| send_mass_rby_spmd ../engine/source/coupling/rad2rad/r2r_init.F
431!||--- calls -----------------------------------------------------
432!||--- uses -----------------------------------------------------
433!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
434!||====================================================================
435 SUBROUTINE spmd_r2r_iget(
436 1 ITAB ,NNG ,GRNOD, DD_R2R, WEIGHT, IBUF,FLAG)
437C-----------------------------------------------
438C I m p l i c i t T y p e s
439C-----------------------------------------------
440 USE spmd_comm_world_mod, ONLY : spmd_comm_world
441#include "implicit_f.inc"
442C-----C-----------------------------------------------------------------
443C M e s s a g e P a s s i n g
444C-----------------------------------------------
445#include "spmd.inc"
446C-----------------------------------------------
447C C o m m o n B l o c k s
448C-----------------------------------------------
449#include "com01_c.inc"
450#include "task_c.inc"
451C-----------------------------------------------
452C D u m m y A r g u m e n t s
453C-----------------------------------------------
454 INTEGER NNG,GRNOD(*),DD_R2R(*),WEIGHT(*),IBUF(*),ITAB(*),FLAG
455C-----------------------------------------------
456C L o c a l V a r i a b l e s
457C-----------------------------------------------
458#ifdef MPI
459 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
460 . STATUS(MPI_STATUS_SIZE)
461 DATA MSGOFF/5005/
462C-----------------------------------------------
463C
464 loc_proc = ispmd+1
465 l = 0
466
467 DO i = 1, nng
468 n=grnod(i)
469 IF(weight(n)==1)THEN
470 l = l + 1
471 IF (flag==1) THEN
472 ibuf(l) = itab(n)
473 ELSE
474 ibuf(l) = itab(i)
475 ENDIF
476 END IF
477 END DO
478
479 IF(loc_proc==1) THEN
480 DO p = 2, nspmd
481 IF(dd_r2r(p)>0)THEN
482 bufsiz = dd_r2r(p)
483 msgtyp = msgoff
484 CALL mpi_recv(
485 s ibuf(l+1),bufsiz,mpi_integer,it_spmd(p),msgtyp,
486 g spmd_comm_world,status,ierror)
487 l = l + dd_r2r(p)
488 END IF
489 END DO
490 ELSEIF(l>0)THEN
491 msgtyp = msgoff
492 CALL mpi_send(
493 s ibuf,l,mpi_integer,it_spmd(1),msgtyp,
494 g spmd_comm_world,ierror)
495 END IF
496C
497#endif
498 RETURN
499 END
500C
501!||====================================================================
502!|| spmd_r2r_iget2 ../engine/source/mpi/r2r/spmd_r2r.F
503!||--- called by ------------------------------------------------------
504!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.F
505!||--- calls -----------------------------------------------------
506!||--- uses -----------------------------------------------------
507!|| rad2r_mod ../engine/share/modules/rad2r.F
508!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
509!||====================================================================
510 SUBROUTINE spmd_r2r_iget2(
511 1 ITAB ,NNG ,IEX, IBUF, FLAG)
512C-----------------------------------------------
513C M o d u l e s
514C-----------------------------------------------
515 USE rad2r_mod
516C-----------------------------------------------
517C I m p l i c i t T y p e s
518C-----------------------------------------------
519 USE spmd_comm_world_mod, ONLY : spmd_comm_world
520#include "implicit_f.inc"
521C-----C-----------------------------------------
522C M e s s a g e P a s s i n g
523C-----------------------------------------------
524#include "spmd.inc"
525C-----------------------------------------------
526C C o m m o n B l o c k s
527C-----------------------------------------------
528#include "com01_c.inc"
529#include "task_c.inc"
530C-----------------------------------------------
531C D u m m y A r g u m e n t s
532C-----------------------------------------------
533 INTEGER NNG, IEX,IBUF(*),ITAB(*),FLAG
534C-----------------------------------------------
535C L o c a l V a r i a b l e s
536C-----------------------------------------------
537#ifdef MPI
538 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
539 . status(mpi_status_size)
540 DATA msgoff/5006/
541C-----------------------------------------------
542C
543 loc_proc = ispmd+1
544 l = 0
545
546 IF(loc_proc==1) THEN
547 DO i = 1, nng
548 ibuf(i) = itab(i)
549 l = l+1
550 END DO
551
552 DO p = 2, nspmd
553
554 IF (flag<2) THEN
555 bufsiz = nbel(iex,p)
556 ELSEIF (flag==2) THEN
557 bufsiz = nbeln(iex,p)
558 ELSEIF (flag==3) THEN
559 bufsiz = tbcnel(iex,p)
560 ELSEIF (flag==4) THEN
561 bufsiz = tbcneldb(iex,p)
562 ENDIF
563
564 IF(bufsiz>0)THEN
565
566 msgtyp = msgoff
567 CALL mpi_recv(
568 s ibuf(l+1),bufsiz,mpi_integer,it_spmd(p),msgtyp,
569 g spmd_comm_world,status,ierror)
570
571C--------------OFFSET de la numerotation des elements----
572 IF ((flag==1).OR.(flag>2)) THEN
573 DO i=1,bufsiz
574 ibuf(l+i)=ibuf(l+i)+offset(p)
575 END DO
576 ENDIF
577C--------------------------------------------------------
578
579 IF (flag<2) THEN
580 l = l + nbel(iex,p)
581 ELSEIF (flag==2) THEN
582 l = l + nbeln(iex,p)
583 ELSEIF (flag==3) THEN
584 l = l + tbcnel(iex,p)
585 ELSEIF (flag==4) THEN
586 l = l + tbcneldb(iex,p)
587 ENDIF
588
589 END IF
590 END DO
591 ELSEIF(nng>0)THEN
592 msgtyp = msgoff
593 CALL mpi_send(
594 s itab,nng,mpi_integer,it_spmd(1),msgtyp,
595 g spmd_comm_world,ierror)
596 END IF
597C
598C
599#endif
600 RETURN
601 END
602C
603!||====================================================================
604!|| spmd_r2r_iget4 ../engine/source/mpi/r2r/spmd_r2r.F
605!||--- called by ------------------------------------------------------
606!|| init_link_spmd ../engine/source/coupling/rad2rad/r2r_init.F
607!||--- calls -----------------------------------------------------
608!||--- uses -----------------------------------------------------
609!|| rad2r_mod ../engine/share/modules/rad2r.F
610!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
611!||====================================================================
612 SUBROUTINE spmd_r2r_iget4(
613 1 ITAB,NNG,GRNOD,DD_R2R,WEIGHT,IBUF,IEX,DBNBUF,
614 2 DDBUF,FLAG)
615C-----------------------------------------------
616C M o d u l e s
617C-----------------------------------------------
618 USE rad2r_mod
619C-----------------------------------------------
620C I m p l i c i t T y p e s
621C-----------------------------------------------
622 USE spmd_comm_world_mod, ONLY : spmd_comm_world
623#include "implicit_f.inc"
624C-----C------------------------------------------
625C M e s s a g e P a s s i n g
626C-----------------------------------------------
627#include "spmd.inc"
628C-----------------------------------------------
629C C o m m o n B l o c k s
630C-----------------------------------------------
631#include "com01_c.inc"
632#include "task_c.inc"
633C-----------------------------------------------
634C D u m m y A r g u m e n t s
635C-----------------------------------------------
636 INTEGER NNG,GRNOD(*),DD_R2R(*),WEIGHT(*),IBUF(*),ITAB(*),
637 . IEX,FLAG,DBNBUF(*),DDBUF(*)
638C-----------------------------------------------
639C L o c a l V a r i a b l e s
640C-----------------------------------------------
641#ifdef MPI
642 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
643 . STATUS(MPI_STATUS_SIZE)
644 DATA msgoff/5007/
645C-----------------------------------------------
646C
647 loc_proc = ispmd+1
648 l = 0
649 DO i = 1, nng
650 n=grnod(i)
651 IF(weight(n)==0)THEN
652 l = l + 1
653 IF (flag==1) THEN
654 ibuf(l) = itab(n)
655 ELSE
656 ibuf(l) = itab(i)
657 ENDIF
658 END IF
659 END DO
660
661 IF(loc_proc==1) THEN
662 dbnbuf(1)=dbn(iex,1)
663 ddbuf(1)=dd_r2r(1)
664 DO p = 2, nspmd
665 dbnbuf(p)=dbn(iex,p)
666 ddbuf(p)=dd_r2r(p)
667
668 IF(dbn(iex,p)>0)THEN
669 bufsiz = dbn(iex,p)
670 msgtyp = msgoff
671 CALL mpi_recv(
672 s ibuf(l+1),bufsiz,mpi_integer,it_spmd(p),msgtyp,
673 g spmd_comm_world,status,ierror)
674
675 l = l + dbn(iex,p)
676
677 END IF
678 END DO
679 ELSEIF(l>0)THEN
680 msgtyp = msgoff
681 CALL mpi_send(
682 s ibuf,l,mpi_integer,it_spmd(1),msgtyp,
683 g spmd_comm_world,ierror)
684 END IF
685C
686#endif
687 RETURN
688 END
689
690!||====================================================================
691!|| spmd_r2r_sync ../engine/source/mpi/r2r/spmd_r2r.f
692!||--- called by ------------------------------------------------------
693!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
694!||--- calls -----------------------------------------------------
695!|| get_name_c ../engine/source/coupling/rad2rad/rad2rad_c.c
696!||--- uses -----------------------------------------------------
697!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
698!||====================================================================
699 SUBROUTINE spmd_r2r_sync(ADDR)
700C-----------------------------------------------
701C I m p l i c i t T y p e s
702C-----------------------------------------------
703 USE spmd_comm_world_mod, ONLY : spmd_comm_world
704#include "implicit_f.inc"
705C-----C-----------------------------------------------------------------
706C M e s s a g e P a s s i n g
707C-----------------------------------------------
708#include "spmd.inc"
709C-----------------------------------------------
710C C o m m o n B l o c k s
711C-----------------------------------------------
712#include "com01_c.inc"
713#include "task_c.inc"
714C-----------------------------------------------
715C D u m m y A r g u m e n t s
716C-----------------------------------------------
717 CHARACTER*35 ADDR
718C-----------------------------------------------
719C L o c a l V a r i a b l e s
720C-----------------------------------------------
721#ifdef MPI
722 INTEGER I, P, N, IERROR, MSGOFF,LOC_PROC, MSGTYP,
723 . STATUS(MPI_STATUS_SIZE),BUFSIZ,BUFA,TOTO
724 DATA MSGOFF/5008/
725C-----------------------------------------------
726C
727 loc_proc = ispmd+1
728 bufsiz=35
729 IF(nspmd>1) THEN
730 IF(loc_proc==1) THEN
731 CALL get_name_c(addr)
732 addr=trim(addr)
733 toto=len_trim(addr)
734 DO p = 2, nspmd
735 msgtyp = msgoff
736 CALL mpi_send(
737 s addr,bufsiz,mpi_character,it_spmd(p),msgtyp,
738 g spmd_comm_world,ierror)
739 END DO
740 ELSE
741 msgtyp = msgoff
742 CALL mpi_recv(
743 s addr,bufsiz,mpi_character,it_spmd(1),msgtyp,
744 g spmd_comm_world,status,ierror)
745 END IF
746 ENDIF
747C
748C
749#endif
750 RETURN
751 END
752C
753!||====================================================================
754!|| spmd_r2r_rset ../engine/source/mpi/r2r/spmd_r2r.F
755!||--- called by ------------------------------------------------------
756!|| get_stiff_spmd ../engine/source/coupling/rad2rad/r2r_exchange.F
757!||--- calls -----------------------------------------------------
758!||--- uses -----------------------------------------------------
759!|| rad2r_mod ../engine/share/modules/rad2r.F
760!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
761!||====================================================================
762 SUBROUTINE spmd_r2r_rset(
763 1 M ,NNG ,GRNOD, DD_R2R, WEIGHT,
764 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF,IEX )
765C-----------------------------------------------
766C M o d u l e s
767C-----------------------------------------------
768 USE rad2r_mod
769C-----------------------------------------------
770C I m p l i c i t T y p e s
771C-----------------------------------------------
772 USE spmd_comm_world_mod, ONLY : spmd_comm_world
773#include "implicit_f.inc"
774C-----C-----------------------------------------
775C M e s s a g e P a s s i n g
776C-----------------------------------------------
777#include "spmd.inc"
778C-----------------------------------------------
779C C o m m o n B l o c k s
780C-----------------------------------------------
781#include "com01_c.inc"
782#include "com04_c.inc"
783#include "task_c.inc"
784C-----------------------------------------------
785C D u m m y A r g u m e n t s
786C-----------------------------------------------
787 INTEGER NNG,LRBUF,IEX,
788 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
789 my_real
790 . BUFR(*), M(*)
791C-----------------------------------------------
792C L o c a l V a r i a b l e s
793C-----------------------------------------------
794#ifdef MPI
795 INTEGER I, J, P, N, L, IERROR, MSGOFF, ISHIFT,
796 . LOC_PROC, MSGTYP, BUFSIZ, SIZ, INB, NB_NOD, NOD, LSEND,
797 . req_r(nspmd), req_s(nspmd),iad_send(nspmd+1),dbl,
798 . iad_recv(nspmd+1), status(mpi_status_size), itag(numnod)
799 my_real
800 . rbuf(lrbuf)
801 DATA msgoff/5009/
802C-----------------------------------------------
803C
804 loc_proc = ispmd+1
805 IF(loc_proc==1) THEN
806 l = dd_r2r(1)+dbn(iex,1)
807 DO p = 2, nspmd
808 IF((dd_r2r(p)+dbn(iex,p))>0)THEN
809 bufsiz = dd_r2r(p)+dbn(iex,p)
810 msgtyp = msgoff
811 CALL mpi_send(
812 s bufr(l+1),bufsiz,real,it_spmd(p),msgtyp,
813 g spmd_comm_world,ierror)
814 l = l + dd_r2r(p)+dbn(iex,p)
815 END IF
816 END DO
817 ELSEIF(nng>0)THEN
818 bufsiz = nng
819 msgtyp = msgoff
820 CALL mpi_recv(
821 s bufr,bufsiz,real,it_spmd(1),msgtyp,
822 g spmd_comm_world,status,ierror)
823 END IF
824 DO i = 1, numnod
825 itag(i) = 0
826 END DO
827 l = 0
828 dbl = dd_r2r(loc_proc)
829
830 DO i = 1, nng
831 n=grnod(i)
832 IF(weight(n)==1)THEN
833 l = l + 1
834 m(n) = bufr(l)
835 ELSE
836 dbl = dbl + 1
837 m(n) = bufr(dbl)
838 ENDIF
839 END DO
840C
841#endif
842 RETURN
843 END
844C
845!||====================================================================
846!|| spmd_r2r_rset4 ../engine/source/mpi/r2r/spmd_r2r.F
847!||--- called by ------------------------------------------------------
848!|| get_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
849!||--- calls -----------------------------------------------------
850!||--- uses -----------------------------------------------------
851!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
852!||====================================================================
853 SUBROUTINE spmd_r2r_rset4(
854 1 M ,NNG ,GRNOD, DD_R2R, WEIGHT,
855 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF )
856C-----------------------------------------------
857C I m p l i c i t T y p e s
858C-----------------------------------------------
859 USE spmd_comm_world_mod, ONLY : spmd_comm_world
860#include "implicit_f.inc"
861C-----C-----------------------------------------------------------------
862C M e s s a g e P a s s i n g
863C-----------------------------------------------
864#include "spmd.inc"
865C-----------------------------------------------
866C C o m m o n B l o c k s
867C-----------------------------------------------
868#include "com01_c.inc"
869#include "com04_c.inc"
870#include "task_c.inc"
871C-----------------------------------------------
872C D u m m y A r g u m e n t s
873C-----------------------------------------------
874 INTEGER NNG,LRBUF,
875 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
876 my_real
877 . BUFR(*), M(*)
878C-----------------------------------------------
879C L o c a l V a r i a b l e s
880C-----------------------------------------------
881#ifdef MPI
882 INTEGER I, J, P, N, L, IERROR, MSGOFF, ISHIFT,
883 . LOC_PROC, MSGTYP, BUFSIZ, SIZ, INB, NB_NOD, NOD, LSEND,
884 . REQ_R(NSPMD), REQ_S(NSPMD),IAD_SEND(NSPMD+1),
885 . IAD_RECV(NSPMD+1), STATUS(MPI_STATUS_SIZE), ITAG(NUMNOD)
886 my_real
887 . rbuf(lrbuf)
888 DATA msgoff/5010/
889C-----------------------------------------------
890C
891 loc_proc = ispmd+1
892 IF(loc_proc==1) THEN
893 l = dd_r2r(1)
894 DO p = 2, nspmd
895 IF((dd_r2r(p))>0)THEN
896 bufsiz = dd_r2r(p)
897 msgtyp = msgoff
898 CALL mpi_send(
899 s bufr(l+1),bufsiz,real,it_spmd(p),msgtyp,
900 g spmd_comm_world,ierror)
901 l = l + dd_r2r(p)
902 END IF
903 END DO
904 ELSEIF(dd_r2r(loc_proc)>0)THEN
905 bufsiz = dd_r2r(loc_proc)
906 msgtyp = msgoff
907 CALL mpi_recv(
908 s bufr,bufsiz,real,it_spmd(1),msgtyp,
909 g spmd_comm_world,status,ierror)
910 END IF
911 DO i = 1, numnod
912 itag(i) = 0
913 END DO
914 l = 0
915 DO i = 1, nng
916 n=grnod(i)
917 IF(weight(n)==1)THEN
918 l = l + 1
919 m(n) = bufr(l)
920 itag(n) = 1
921 END IF
922 END DO
923
924C
925#endif
926 RETURN
927 END
928C
929!||====================================================================
930!|| spmd_r2r_rset3 ../engine/source/mpi/r2r/spmd_r2r.F
931!||--- called by ------------------------------------------------------
932!|| get_displ_spmd ../engine/source/coupling/rad2rad/r2r_getdata.F
933!|| get_force_spmd ../engine/source/coupling/rad2rad/r2r_getdata.F
934!||--- calls -----------------------------------------------------
935!||--- uses -----------------------------------------------------
936!|| rad2r_mod ../engine/share/modules/rad2r.f
937!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
938!||====================================================================
939 SUBROUTINE spmd_r2r_rset3(
940 1 A ,NNG ,GRNOD, DD_R2R, WEIGHT,
941 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF,IEX )
942C-----------------------------------------------
943C M o d u l e s
944C-----------------------------------------------
945 USE rad2r_mod
946C-----------------------------------------------
947C I m p l i c i t T y p e s
948C-----------------------------------------------
949 USE spmd_comm_world_mod, ONLY : spmd_comm_world
950#include "implicit_f.inc"
951C-----C-----------------------------------------
952C M e s s a g e P a s s i n g
953C-----------------------------------------------
954#include "spmd.inc"
955C-----------------------------------------------
956C C o m m o n B l o c k s
957C-----------------------------------------------
958#include "com01_c.inc"
959#include "com04_c.inc"
960#include "task_c.inc"
961C-----------------------------------------------
962C D u m m y A r g u m e n t s
963C-----------------------------------------------
964 INTEGER NNG,LRBUF,IEX,
965 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
966 my_real
967 . BUFR(3,*), A(3,*)
968C-----------------------------------------------
969C L o c a l V a r i a b l e s
970C-----------------------------------------------
971#ifdef MPI
972 INTEGER I, J, P, N, L, IERROR, MSGOFF, ISHIFT,DBL,
973 . LOC_PROC, MSGTYP, BUFSIZ, SIZ, INB, NB_NOD, NOD, LSEND,
974 . REQ_R(NSPMD), REQ_S(NSPMD),IAD_SEND(NSPMD+1),
975 . IAD_RECV(NSPMD+1), STATUS(MPI_STATUS_SIZE), ITAG(NUMNOD)
976 my_real
977 . RBUF(LRBUF)
978 DATA msgoff/5011/
979C-----------------------------------------------
980C
981 loc_proc = ispmd+1
982 IF(loc_proc==1) THEN
983 l = dd_r2r(1)+dbn(iex,1)
984 DO p = 2, nspmd
985 IF((dd_r2r(p)+dbn(iex,p))>0)THEN
986 bufsiz = (dd_r2r(p)+dbn(iex,p))*3
987 msgtyp = msgoff
988 CALL mpi_send(
989 s bufr(1,l+1),bufsiz,real,it_spmd(p),msgtyp,
990 g spmd_comm_world,ierror)
991 l = l + dd_r2r(p)+dbn(iex,p)
992 END IF
993 END DO
994 ELSEIF(nng>0)THEN
995 bufsiz = nng*3
996 msgtyp = msgoff
997 CALL mpi_recv(
998 s bufr,bufsiz,real,it_spmd(1),msgtyp,
999 g spmd_comm_world,status,ierror)
1000 END IF
1001 DO i = 1, numnod
1002 itag(i) = 0
1003 END DO
1004
1005 l = 0
1006 dbl = dd_r2r(loc_proc)
1007
1008 DO i = 1, nng
1009 n=grnod(i)
1010 IF(weight(n)==1)THEN
1011 l = l + 1
1012 a(1,n) = bufr(1,l)
1013 a(2,n) = bufr(2,l)
1014 a(3,n) = bufr(3,l)
1015 ELSE
1016 dbl = dbl + 1
1017 a(1,n) = bufr(1,dbl)
1018 a(2,n) = bufr(2,dbl)
1019 a(3,n) = bufr(3,dbl)
1020 ENDIF
1021 END DO
1022C
1023#endif
1024 RETURN
1025 END
1026C
1027!||====================================================================
1028!|| spmd_r2r_rset3b ../engine/source/mpi/r2r/spmd_r2r.F
1029!||--- called by ------------------------------------------------------
1030!|| get_force_spmd ../engine/source/coupling/rad2rad/r2r_getdata.F
1031!||--- calls -----------------------------------------------------
1032!||--- uses -----------------------------------------------------
1033!|| rad2r_mod ../engine/share/modules/rad2r.F
1034!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.f90
1035!||====================================================================
1036 SUBROUTINE spmd_r2r_rset3b(
1037 1 A ,NNG ,GRNOD, DD_R2R,WEIGHT,
1038 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF ,MS ,
1039 3 V ,WF ,WF2, IEX )
1040C-----------------------------------------------
1041C M o d u l e s
1042C-----------------------------------------------
1043 USE rad2r_mod
1044C-----------------------------------------------
1045C I m p l i c i t T y p e s
1046C-----------------------------------------------
1047 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1048#include "implicit_f.inc"
1049C-----C-----------------------------------------
1050C M e s s a g e P a s s i n g
1051C-----------------------------------------------
1052#include "spmd.inc"
1053C-----------------------------------------------
1054C C o m m o n B l o c k s
1055C-----------------------------------------------
1056#include "com01_c.inc"
1057#include "com04_c.inc"
1058#include "task_c.inc"
1059C-----------------------------------------------
1060C D u m m y A r g u m e n t s
1061C-----------------------------------------------
1062 INTEGER NNG,LRBUF,IEX,
1063 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
1064 my_real
1065 . bufr(3,*), a(3,*), ms(*), v(3,*), wf, wf2
1066C-----------------------------------------------
1067C L o c a l V a r i a b l e s
1068C-----------------------------------------------
1069#ifdef mpi
1070 INTEGER I, J, P, N, L, IERROR, MSGOFF, MSGOFF2, ISHIFT,DBL,
1071 . LOC_PROC, MSGTYP, BUFSIZ, SIZ, INB, NB_NOD, NOD, LSEND,
1072 . REQ_R(NSPMD), REQ_S(NSPMD),IAD_SEND(NSPMD+1),
1073 . IAD_RECV(NSPMD+1), STATUS(MPI_STATUS_SIZE), ITAG(NUMNOD)
1074 my_real
1075 . DF1, DF2, DF3, RBUF(LRBUF), WFB
1076 DATA MSGOFF/5012/
1077 DATA MSGOFF2/5013/
1078C-----------------------------------------------
1079C
1080 wf=0
1081 wf2=0
1082
1083 loc_proc = ispmd+1
1084 IF(loc_proc==1) THEN
1085 l = dd_r2r(1)+dbn(iex,1)
1086 DO p = 2, nspmd
1087 IF((dd_r2r(p)+dbn(iex,p))>0)THEN
1088 bufsiz = (dd_r2r(p)+dbn(iex,p))*3
1089 msgtyp = msgoff
1090 CALL mpi_send(
1091 s bufr(1,l+1),bufsiz,real,it_spmd(p),msgtyp,
1092 g spmd_comm_world,ierror)
1093 l = l + dd_r2r(p)+dbn(iex,p)
1094 END IF
1095 END DO
1096 ELSEIF(nng>0)THEN
1097 bufsiz = nng*3
1098 msgtyp = msgoff
1099 CALL mpi_recv(
1100 s bufr,bufsiz,real,it_spmd(1),msgtyp,
1101 g spmd_comm_world,status,ierror)
1102 END IF
1103
1104 l = 0
1105 dbl = dd_r2r(loc_proc)
1106
1107 DO i = 1, nng
1108 n=grnod(i)
1109 IF(weight(n)==1)THEN
1110 l = l + 1
1111 df1 = ms(n)*bufr(1,l)-a(1,n)
1112 df2 = ms(n)*bufr(2,l)-a(2,n)
1113 df3 = ms(n)*bufr(3,l)-a(3,n)
1114 a(1,n) = ms(n)*bufr(1,l)
1115 a(2,n) = ms(n)*bufr(2,l)
1116 a(3,n) = ms(n)*bufr(3,l)
1117C calcul du travail localement
1118 wf = wf + (df1*v(1,n)+df2*v(2,n)+df3*v(3,n))/two
1119 wf2= wf2+ (df1*a(1,n)+df2*a(2,n)+df3*a(3,n))/(two*ms(n))
1120 ELSE
1121 dbl = dbl + 1
1122 df1 = ms(n)*bufr(1,dbl)-a(1,n)
1123 df2 = ms(n)*bufr(2,dbl)-a(2,n)
1124 df3 = ms(n)*bufr(3,dbl)-a(3,n)
1125 a(1,n) = ms(n)*bufr(1,dbl)
1126 a(2,n) = ms(n)*bufr(2,dbl)
1127 a(3,n) = ms(n)*bufr(3,dbl)
1128 ENDIF
1129 END DO
1130
1131C Sommation sur les procs de WF
1132 IF(loc_proc==1) THEN
1133 DO p = 2, nspmd
1134 msgtyp = msgoff
1135 CALL mpi_recv(
1136 s wfb,1,real,it_spmd(p),msgtyp,
1137 g spmd_comm_world,status,ierror)
1138 wf = wf+wfb
1139 END DO
1140 ELSE
1141 msgtyp = msgoff
1142 CALL mpi_send(
1143 s wf,1,real,it_spmd(1),msgtyp,
1144 g spmd_comm_world,ierror)
1145 END IF
1146
1147C Sommation sur les procs de WF2
1148
1149 IF(loc_proc==1) THEN
1150 DO p = 2, nspmd
1151 msgtyp = msgoff
1152 CALL mpi_recv(
1153 s wfb,1,real,it_spmd(p),msgtyp,
1154 g spmd_comm_world,status,ierror)
1155 wf2 = wf2+wfb
1156 END DO
1157 ELSE
1158 msgtyp = msgoff
1159 CALL mpi_send(
1160 s wf2,1,real,it_spmd(1),msgtyp,
1161 g spmd_comm_world,ierror)
1162 END IF
1163
1164#endif
1165 RETURN
1166 END
1167!||====================================================================
1168!|| spmd_exch_r2r ../engine/source/mpi/r2r/spmd_r2r.F
1169!||--- called by ------------------------------------------------------
1170!|| r2r_exchange ../engine/source/coupling/rad2rad/r2r_exchange.F
1171!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
1172!||--- calls -----------------------------------------------------
1173!||--- uses -----------------------------------------------------
1174!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1175!||====================================================================
1176 SUBROUTINE spmd_exch_r2r(
1177 1 A ,AR ,STIFN,STIFR ,MS ,
1178 2 IAD_ELEM ,FR_ELEM, SIZE,
1179 3 LENR ,DD_R2R,DD_R2R_ELEM,FLAG)
1180C--------------------------------------
1181C-----------------------------------------------
1182C I m p l i c i t T y p e s
1183C-----------------------------------------------
1184 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1185#include "implicit_f.inc"
1186C-----------------------------------------------------------------
1187C M e s s a g e P a s s i n g
1188C-----------------------------------------------
1189#include "spmd.inc"
1190C-----------------------------------------------
1191C C o m m o n B l o c k s
1192C-----------------------------------------------
1193#include "com01_c.inc"
1194#include "task_c.inc"
1195#include "tabsiz_c.inc"
1196C-----------------------------------------------
1197C D u m m y A r g u m e n t s
1198C-----------------------------------------------
1199 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR,
1200 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),FLAG
1201 my_real
1202 . A(3,*),AR(3,*),STIFN(*),STIFR(*),MS(*)
1203C-----------------------------------------------
1204C L o c a l V a r i a b l e s
1205C-----------------------------------------------
1206#ifdef MPI
1207 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1208 . SIZ,J,K,L,NB_NOD,
1209 . STATUS(MPI_STATUS_SIZE),
1210 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1211 . REQ_R(NSPMD),REQ_S(NSPMD),OFFSET,MSGOFF
1212 my_real
1213 . RBUF(SIZE*LENR ),
1214 . SBUF(SIZE*LENR )
1215 DATA MSGOFF/5014/
1216C-----------------------------------------------
1217C S o u r c e L i n e s
1218C-----------------------------------------------
1219 loc_proc = ispmd + 1
1220 l = 1
1221 iad_recv(1) = 1
1222
1223 DO i=1,nspmd
1224 siz = size*(dd_r2r(i+1,2)-dd_r2r(i,2))
1225 IF(siz/=0)THEN
1226 msgtyp = msgoff
1227 CALL mpi_irecv(
1228 s rbuf(l),siz,real,it_spmd(i),msgtyp,
1229 g spmd_comm_world,req_r(i),ierror)
1230 l = l + siz
1231 ENDIF
1232 iad_recv(i+1) = l
1233 END DO
1234 l = 1
1235 iad_send(1) = 1
1236C
1237 DO i=1,nspmd
1238C preparation envoi partie fixe (elem) a proc I
1239 IF(iroddl/=0) THEN
1240#include "vectorize.inc"
1241 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1242 nod = dd_r2r_elem(j)
1243 IF (flag==2) THEN
1244 sbuf(l ) = a(1,nod)
1245 sbuf(l+1) = a(2,nod)
1246 sbuf(l+2) = a(3,nod)
1247 sbuf(l+3) = ar(1,nod)
1248 sbuf(l+4) = ar(2,nod)
1249 sbuf(l+5) = ar(3,nod)
1250 ELSE
1251 sbuf(l ) = stifn(nod)
1252 sbuf(l+1) = stifr(nod)
1253 ENDIF
1254 l = l + SIZE
1255 END DO
1256 ELSE
1257#include "vectorize.inc"
1258 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1259 nod = dd_r2r_elem(j)
1260 IF (flag==2) THEN
1261 sbuf(l ) = a(1,nod)
1262 sbuf(l+1) = a(2,nod)
1263 sbuf(l+2) = a(3,nod)
1264 ELSE
1265 sbuf(l ) = stifn(nod)
1266 ENDIF
1267 l = l + SIZE
1268 END DO
1269 ENDIF
1270C
1271 iad_send(i+1) = l
1272 ENDDO
1273C
1274C echange messages
1275C
1276 DO i=1,nspmd
1277C--------------------------------------------------------------------
1278C envoi a N+I mod P
1279C test si msg necessaire a envoyer a completer par test interface
1280 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1281 msgtyp = msgoff
1282 siz = iad_send(i+1)-iad_send(i)
1283 l = iad_send(i)
1284 CALL mpi_isend(
1285 s sbuf(l),siz,real,it_spmd(i),msgtyp,
1286 g spmd_comm_world,req_s(i),ierror)
1287 ENDIF
1288C--------------------------------------------------------------------
1289 ENDDO
1290C
1291C decompactage
1292C
1293 offset = dd_r2r(nspmd+1,1)-1
1294 DO i = 1, nspmd
1295C test si msg necessaire a envoyer a completer par test interface
1296 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1297 IF(nb_nod>0)THEN
1298 CALL mpi_wait(req_r(i),status,ierror)
1299 l = iad_recv(i)
1300
1301 IF(iroddl/=0) THEN
1302#include "vectorize.inc"
1303 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1304 nod = dd_r2r_elem(offset+j)
1305 IF (flag==2) THEN
1306 a(1,nod) = rbuf(l)
1307 a(2,nod) = rbuf(l+1)
1308 a(3,nod) = rbuf(l+2)
1309 ar(1,nod)= rbuf(l+3)
1310 ar(2,nod)= rbuf(l+4)
1311 ar(3,nod)= rbuf(l+5)
1312 ELSE
1313 stifn(nod)= rbuf(l)
1314 stifr(nod)= rbuf(l+1)
1315 ENDIF
1316 l = l + SIZE
1317 END DO
1318 ELSE
1319#include "vectorize.inc"
1320 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1321 nod = dd_r2r_elem(offset+j)
1322 IF (flag==2) THEN
1323 a(1,nod) = rbuf(l)
1324 a(2,nod) = rbuf(l+1)
1325 a(3,nod) = rbuf(l+2)
1326 ELSE
1327 stifn(nod)= rbuf(l)
1328 ENDIF
1329 l = l + SIZE
1330 END DO
1331 ENDIF
1332C ---
1333 ENDIF
1334C
1335 END DO
1336C
1337C wait terminaison isend
1338C
1339 DO i = 1, nspmd
1340 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1341 CALL mpi_wait(req_s(i),status,ierror)
1342 ENDIF
1343 ENDDO
1344C
1345
1346#endif
1347 RETURN
1348 END
1349!||====================================================================
1350!|| spmd_exch_r2r_2 ../engine/source/mpi/r2r/spmd_r2r.F
1351!||--- called by ------------------------------------------------------
1352!|| r2r_getdata ../engine/source/coupling/rad2rad/r2r_getdata.F
1353!||--- calls -----------------------------------------------------
1354!||--- uses -----------------------------------------------------
1355!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1356!||====================================================================
1357 SUBROUTINE spmd_exch_r2r_2(
1358 1 A ,AR, V, VR ,MS , IN,
1359 2 IAD_ELEM ,FR_ELEM, SIZE, WF, WF2,
1360 3 LENR ,DD_R2R,DD_R2R_ELEM,WEIGHT,FLAG)
1361C--------------------------------------
1362C-----------------------------------------------
1363C I m p l i c i t T y p e s
1364C-----------------------------------------------
1365 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1366#include "implicit_f.inc"
1367C-----------------------------------------------------------------
1368C M e s s a g e P a s s i n g
1369C-----------------------------------------------
1370#include "spmd.inc"
1371C-----------------------------------------------
1372C C o m m o n B l o c k s
1373C-----------------------------------------------
1374#include "com01_c.inc"
1375#include "task_c.inc"
1376#include "tabsiz_c.inc"
1377C-----------------------------------------------
1378C D u m m y A r g u m e n t s
1379C-----------------------------------------------
1380 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR,
1381 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),FLAG,
1382 . WEIGHT(*)
1383 my_real
1384 . A(3,*),AR(3,*), V(3,*),VR(3,*),MS(*),IN(*),
1385 . WF,WF2
1386C-----------------------------------------------
1387C L o c a l V a r i a b l e s
1388C-----------------------------------------------
1389#ifdef MPI
1390 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1391 . SIZ,J,K,L,NB_NOD,
1392 . STATUS(MPI_STATUS_SIZE),
1393 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1394 . REQ_R(NSPMD),REQ_S(NSPMD),OFFSET,MSGOFF
1395 my_real
1396 . RBUF(SIZE*LENR ),
1397 . SBUF(SIZE*LENR ),DF1,DF2,DF3,DF4,DF5,DF6
1398 DATA MSGOFF/5015/
1399C-----------------------------------------------
1400C S o u r c e L i n e s
1401C-----------------------------------------------
1402 LOC_PROC = ispmd + 1
1403 l = 1
1404 iad_recv(1) = 1
1405
1406 DO i=1,nspmd
1407 siz = size*(dd_r2r(i+1,2)-dd_r2r(i,2))
1408 IF(siz/=0)THEN
1409 msgtyp = msgoff
1410 CALL mpi_irecv(
1411 s rbuf(l),siz,real,it_spmd(i),msgtyp,
1412 g spmd_comm_world,req_r(i),ierror)
1413 l = l + siz
1414 ENDIF
1415 iad_recv(i+1) = l
1416 END DO
1417 l = 1
1418 iad_send(1) = 1
1419C
1420 DO i=1,nspmd
1421C preparation envoi partie fixe (elem) a proc I
1422 IF(iroddl/=0) THEN
1423#include "vectorize.inc"
1424 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1425 nod = dd_r2r_elem(j)
1426 sbuf(l ) = a(1,nod)
1427 sbuf(l+1) = a(2,nod)
1428 sbuf(l+2) = a(3,nod)
1429 sbuf(l+3) = ar(1,nod)
1430 sbuf(l+4) = ar(2,nod)
1431 sbuf(l+5) = ar(3,nod)
1432 IF (flag==1) THEN
1433 sbuf(l+6) = ms(nod)
1434 sbuf(l+7) = in(nod)
1435 ENDIF
1436 l = l + SIZE
1437 END DO
1438 ELSE
1439#include "vectorize.inc"
1440 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1441 nod = dd_r2r_elem(j)
1442 sbuf(l ) = a(1,nod)
1443 sbuf(l+1) = a(2,nod)
1444 sbuf(l+2) = a(3,nod)
1445 IF (flag==1) THEN
1446 sbuf(l+3) = ms(nod)
1447 ENDIF
1448 l = l + SIZE
1449 END DO
1450 ENDIF
1451C
1452 iad_send(i+1) = l
1453 ENDDO
1454C
1455C echange messages
1456C
1457 DO i=1,nspmd
1458C--------------------------------------------------------------------
1459C envoi a N+I mod P
1460C test si msg necessaire a envoyer a completer par test interface
1461 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1462 msgtyp = msgoff
1463 siz = iad_send(i+1)-iad_send(i)
1464 l = iad_send(i)
1465 CALL mpi_isend(
1466 s sbuf(l),siz,real,it_spmd(i),msgtyp,
1467 g spmd_comm_world,req_s(i),ierror)
1468 ENDIF
1469C--------------------------------------------------------------------
1470 ENDDO
1471C
1472C decompactage
1473C
1474 offset = dd_r2r(nspmd+1,1)-1
1475 DO i = 1, nspmd
1476C test si msg necessaire a envoyer a completer par test interface
1477 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1478 IF(nb_nod>0)THEN
1479 CALL mpi_wait(req_r(i),status,ierror)
1480 l = iad_recv(i)
1481
1482 IF(iroddl/=0) THEN
1483#include "vectorize.inc"
1484 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1485 nod = dd_r2r_elem(offset+j)
1486 IF(weight(nod)==1)THEN
1487 df1 = rbuf(l)-a(1,nod)
1488 df2 = rbuf(l+1)-a(2,nod)
1489 df3 = rbuf(l+2)-a(3,nod)
1490 df4 = rbuf(l+3)-ar(1,nod)
1491 df5 = rbuf(l+4)-ar(2,nod)
1492 df6 = rbuf(l+5)-ar(3,nod)
1493 ENDIF
1494 a(1,nod) = rbuf(l)
1495 a(2,nod) = rbuf(l+1)
1496 a(3,nod) = rbuf(l+2)
1497 ar(1,nod)= rbuf(l+3)
1498 ar(2,nod)= rbuf(l+4)
1499 ar(3,nod)= rbuf(l+5)
1500 IF (flag==1) THEN
1501 ms(nod)= rbuf(l+6)
1502 in(nod)= rbuf(l+7)
1503 ENDIF
1504 l = l + SIZE
1505C calcul du travail localement
1506 IF(weight(nod)==1)THEN
1507 wf = wf + (df1*v(1,nod)+df2*v(2,nod)+
1508 . df3*v(3,nod))/two
1509 wf2= wf2+ (df1*a(1,nod)+df2*a(2,nod)+
1510 . df3*a(3,nod))/(two*ms(nod))
1511 wf = wf + (df4*vr(1,nod)+df5*vr(2,nod)+
1512 . df6*vr(3,nod))/two
1513 wf2= wf2+ (df4*ar(1,nod)+df5*ar(2,nod)+
1514 . df6*ar(3,nod))/(two*in(nod))
1515 ENDIF
1516 END DO
1517 ELSE
1518#include "vectorize.inc"
1519 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1520 nod = dd_r2r_elem(offset+j)
1521 IF(weight(nod)==1)THEN
1522 df1 = rbuf(l)-a(1,nod)
1523 df2 = rbuf(l+1)-a(2,nod)
1524 df3 = rbuf(l+2)-a(3,nod)
1525 ENDIF
1526 a(1,nod) = rbuf(l)
1527 a(2,nod) = rbuf(l+1)
1528 a(3,nod) = rbuf(l+2)
1529 IF (flag==1) THEN
1530 ms(nod)= rbuf(l+3)
1531 ENDIF
1532 l = l + SIZE
1533C calcul du travail localement
1534 IF(weight(nod)==1)THEN
1535 wf = wf + (df1*v(1,nod)+df2*v(2,nod)+
1536 . df3*v(3,nod))/two
1537 wf2= wf2+ (df1*a(1,nod)+df2*a(2,nod)+
1538 . df3*a(3,nod))/(two*ms(nod))
1539 ENDIF
1540 END DO
1541 ENDIF
1542C ---
1543 ENDIF
1544C
1545 END DO
1546C
1547C wait terminaison isend
1548C
1549 DO i = 1, nspmd
1550 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1551 CALL mpi_wait(req_s(i),status,ierror)
1552 ENDIF
1553 ENDDO
1554C
1555
1556#endif
1557 RETURN
1558 END
1559!||====================================================================
1560!|| spmd_exch_r2r_rby ../engine/source/mpi/r2r/spmd_r2r.F
1561!||--- called by ------------------------------------------------------
1562!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
1563!||--- calls -----------------------------------------------------
1564!||--- uses -----------------------------------------------------
1565!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1566!||====================================================================
1567 SUBROUTINE spmd_exch_r2r_rby(
1568 1 NPBY , RBY ,IAD_ELEM ,FR_ELEM, SIZE,
1569 2 LENR ,DD_R2R,DD_R2R_ELEM ,X)
1570C--------------------------------------
1571C-----------------------------------------------
1572C I m p l i c i t T y p e s
1573C-----------------------------------------------
1574 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1575#include "implicit_f.inc"
1576#include "param_c.inc"
1577C-----------------------------------------------------------------
1578C M e s s a g e P a s s i n g
1579C-----------------------------------------------
1580#include "spmd.inc"
1581C-----------------------------------------------
1582C C o m m o n B l o c k s
1583C-----------------------------------------------
1584#include "com01_c.inc"
1585#include "com04_c.inc"
1586#include "task_c.inc"
1587#include "tabsiz_c.inc"
1588C-----------------------------------------------
1589C D u m m y A r g u m e n t s
1590C-----------------------------------------------
1591 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR,
1592 . dd_r2r(nspmd+1,sdd_r2r),dd_r2r_elem(*),
1593 . npby(nnpby,*)
1594 my_real
1595 . rby(nrby,*)
1596 DOUBLE PRECISION X(3,*)
1597C-----------------------------------------------
1598C L o c a l V a r i a b l e s
1599C-----------------------------------------------
1600#ifdef MPI
1601 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1602 . SIZ,J,K,L,NB_NOD,
1603 . STATUS(MPI_STATUS_SIZE),
1604 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1605 . REQ_R(NSPMD),REQ_S(NSPMD),OFFSET,IDRBY,MSGOFF
1606 DOUBLE PRECISION
1607 . RBUF(SIZE*LENR ),SBUF(SIZE*LENR )
1608 DATA MSGOFF/5016/
1609C-----------------------------------------------
1610C S o u r c e L i n e s
1611C-----------------------------------------------
1612 LOC_PROC = ispmd + 1
1613 l = 1
1614 iad_recv(1) = 1
1615
1616 DO i=1,nspmd
1617 siz = size*(dd_r2r(i+1,2)-dd_r2r(i,2))
1618 IF(siz/=0)THEN
1619 msgtyp = msgoff
1620 CALL mpi_irecv(
1621 s rbuf(l),siz,mpi_double_precision,it_spmd(i),
1622 g msgtyp,spmd_comm_world,req_r(i),ierror)
1623 l = l + siz
1624 ENDIF
1625 iad_recv(i+1) = l
1626 END DO
1627 l = 1
1628 iad_send(1) = 1
1629C
1630 DO i=1,nspmd
1631C preparation envoi partie fixe (elem) a proc I
1632
1633#include "vectorize.inc"
1634 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1635 idrby = 0
1636 nod = dd_r2r_elem(j)
1637 DO k=1,nrbody
1638 IF (npby(1,k)==nod) idrby = k
1639 END DO
1640 IF (idrby>0) THEN
1641 DO k=1,25
1642 sbuf(l+k-1) = rby(k,idrby)
1643 END DO
1644 sbuf(l+26-1) = x(1,nod)
1645 sbuf(l+27-1) = x(2,nod)
1646 sbuf(l+28-1) = x(3,nod)
1647 ELSE
1648 DO k=1,25
1649 sbuf(l+k-1) = 0
1650 END DO
1651 ENDIF
1652 l = l + SIZE
1653 END DO
1654C
1655 iad_send(i+1) = l
1656 ENDDO
1657C
1658C echange messages
1659C
1660 DO i=1,nspmd
1661C--------------------------------------------------------------------
1662C envoi a N+I mod P
1663C test si msg necessaire a envoyer a completer par test interface
1664 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1665 msgtyp = msgoff
1666 siz = iad_send(i+1)-iad_send(i)
1667 l = iad_send(i)
1668 CALL mpi_isend(
1669 s sbuf(l),siz,mpi_double_precision,it_spmd(i),
1670 g msgtyp,spmd_comm_world,req_s(i),ierror)
1671 ENDIF
1672C--------------------------------------------------------------------
1673 ENDDO
1674C
1675C decompactage
1676C
1677 offset = dd_r2r(nspmd+1,1)-1
1678 DO i = 1, nspmd
1679C test si msg necessaire a envoyer a completer par test interface
1680 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1681 IF(nb_nod>0)THEN
1682 CALL mpi_wait(req_r(i),status,ierror)
1683 l = iad_recv(i)
1684
1685#include "vectorize.inc"
1686 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1687 idrby = 0
1688 nod = dd_r2r_elem(offset+j)
1689 DO k=1,nrbody
1690 IF (npby(1,k)==nod) idrby = k
1691 END DO
1692 IF (idrby>0) THEN
1693 DO k=1,25
1694 rby(k,idrby) = rbuf(l+k-1)
1695 END DO
1696 x(1,nod) = rbuf(l+26-1)
1697 x(2,nod) = rbuf(l+27-1)
1698 x(3,nod) = rbuf(l+28-1)
1699 ENDIF
1700 l = l + SIZE
1701 END DO
1702C ---
1703 ENDIF
1704C
1705 END DO
1706C
1707C wait terminaison isend
1708C
1709 DO i = 1, nspmd
1710 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1711 CALL mpi_wait(req_s(i),status,ierror)
1712 ENDIF
1713 ENDDO
1714C
1715
1716#endif
1717 RETURN
1718 END
1719!||====================================================================
1720!|| spmd_exch_work ../engine/source/mpi/r2r/spmd_r2r.F
1721!||--- called by ------------------------------------------------------
1722!|| r2r_getdata ../engine/source/coupling/rad2rad/r2r_getdata.F
1723!||--- calls -----------------------------------------------------
1724!||--- uses -----------------------------------------------------
1725!|| rad2r_mod ../engine/share/modules/rad2r.F
1726!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1727!||====================================================================
1728 SUBROUTINE spmd_exch_work(WF, WF2)
1729C-----------------------------------------------
1730C M o d u l e s
1731C-----------------------------------------------
1732 USE rad2r_mod
1733C-----------------------------------------------
1734C I m p l i c i t T y p e s
1735C-----------------------------------------------
1736 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1737#include "implicit_f.inc"
1738C-----C-----------------------------------------
1739C M e s s a g e P a s s i n g
1740C-----------------------------------------------
1741#include "spmd.inc"
1742C-----------------------------------------------
1743C C o m m o n B l o c k s
1744C-----------------------------------------------
1745#include "com01_c.inc"
1746#include "task_c.inc"
1747C-----------------------------------------------
1748C D u m m y A r g u m e n t s
1749C-----------------------------------------------
1750 my_real
1751 . wf, wf2
1752C-----------------------------------------------
1753C L o c a l V a r i a b l e s
1754C-----------------------------------------------
1755#ifdef MPI
1756 INTEGER P, IERROR, MSGOFF,LOC_PROC,
1757 . msgtyp,status(mpi_status_size)
1758 my_real
1759 . wfb
1760 DATA msgoff/5017/
1761C-----------------------------------------------
1762C
1763 loc_proc = ispmd+1
1764
1765C Sommation sur les procs de WF
1766 IF(loc_proc==1) THEN
1767 DO p = 2, nspmd
1768 msgtyp = msgoff
1769 CALL mpi_recv(
1770 s wfb,1,real,it_spmd(p),msgtyp,
1771 g spmd_comm_world,status,ierror)
1772 wf = wf+wfb
1773 END DO
1774 ELSE
1775 msgtyp = msgoff
1776 CALL mpi_send(
1777 s wf,1,real,it_spmd(1),msgtyp,
1778 g spmd_comm_world,ierror)
1779 END IF
1780
1781C Sommation sur les procs de WF2
1782
1783 IF(loc_proc==1) THEN
1784 DO p = 2, nspmd
1785 msgtyp = msgoff
1786 CALL mpi_recv(
1787 s wfb,1,real,it_spmd(p),msgtyp,
1788 g spmd_comm_world,status,ierror)
1789 wf2 = wf2+wfb
1790 END DO
1791 ELSE
1792 msgtyp = msgoff
1793 CALL mpi_send(
1794 s wf2,1,real,it_spmd(1),msgtyp,
1795 g spmd_comm_world,ierror)
1796 END IF
1797
1798#endif
1799 RETURN
1800 END
1801C
1802!||====================================================================
1803!|| spmd_r2r_tagel ../engine/source/mpi/r2r/spmd_r2r.F
1804!||--- called by ------------------------------------------------------
1805!|| tagoff3n ../engine/source/interfaces/interf/chkstfn3.F
1806!||--- calls -----------------------------------------------------
1807!||--- uses -----------------------------------------------------
1808!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1809!||====================================================================
1810 SUBROUTINE spmd_r2r_tagel(TAGELG,TAGEL,LEN)
1811C-----------------------------------------------
1812C I m p l i c i t T y p e s
1813C-----------------------------------------------
1814 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1815#include "implicit_f.inc"
1816C-----C-----------------------------------------------------------------
1817C M e s s a g e P a s s i n g
1818C-----------------------------------------------
1819#include "spmd.inc"
1820C-----------------------------------------------
1821C C o m m o n B l o c k s
1822C-----------------------------------------------
1823#include "com01_c.inc"
1824#include "task_c.inc"
1825C-----------------------------------------------
1826C D u m m y A r g u m e n t s
1827C-----------------------------------------------
1828 INTEGER TAGELG(*),TAGEL(*),LEN(*)
1829C-----------------------------------------------
1830C L o c a l V a r i a b l e s
1831C-----------------------------------------------
1832#ifdef MPI
1833 INTEGER I, P, N, L, IERROR, MSGOFF,LOC_PROC, MSGTYP, BUFSIZ,
1834 . STATUS(MPI_STATUS_SIZE)
1835 DATA msgoff/5018/
1836C-----------------------------------------------
1837C
1838 loc_proc = ispmd+1
1839 l = 0
1840C
1841 IF(loc_proc==1) THEN
1842 DO i=1,len(loc_proc)
1843 tagelg(i)=tagel(i)
1844 l = l+1
1845 ENDDO
1846 DO p = 2, nspmd
1847 IF(len(p)>0)THEN
1848 msgtyp = msgoff
1849 CALL mpi_recv(
1850 s tagelg(l+1),len(p),mpi_integer,it_spmd(p),msgtyp,
1851 g spmd_comm_world,status,ierror)
1852 l = l + len(p)
1853 END IF
1854 END DO
1855 ELSEIF(len(loc_proc)>0)THEN
1856 msgtyp = msgoff
1857 CALL mpi_send(
1858 s tagel,len(loc_proc),mpi_integer,it_spmd(1),msgtyp,
1859 g spmd_comm_world,ierror)
1860 END IF
1861C
1862#endif
1863 RETURN
1864 END
1865C
1866!||====================================================================
1867!|| spmd_exch_r2r_itag ../engine/source/mpi/r2r/spmd_r2r.F
1868!||--- called by ------------------------------------------------------
1869!|| tagoff3n ../engine/source/interfaces/interf/chkstfn3.F
1870!||--- calls -----------------------------------------------------
1871!||--- uses -----------------------------------------------------
1872!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1873!||====================================================================
1874 SUBROUTINE spmd_exch_r2r_itag(
1875 1 ITAG,IAD_ELEM ,FR_ELEM,DD_R2R,DD_R2R_ELEM,LENR)
1876C--------------------------------------
1877C-----------------------------------------------
1878C I m p l i c i t T y p e s
1879C-----------------------------------------------
1880 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1881#include "implicit_f.inc"
1882C-----------------------------------------------------------------
1883C M e s s a g e P a s s i n g
1884C-----------------------------------------------
1885#include "spmd.inc"
1886C-----------------------------------------------
1887C C o m m o n B l o c k s
1888C-----------------------------------------------
1889#include "com01_c.inc"
1890#include "com04_c.inc"
1891#include "task_c.inc"
1892#include "tabsiz_c.inc"
1893C-----------------------------------------------
1894C D u m m y A r g u m e n t s
1895C-----------------------------------------------
1896 INTEGER IAD_ELEM(2,*),FR_ELEM(*),
1897 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),FLAG,
1898 . ITAG(*),LENR
1899C-----------------------------------------------
1900C L o c a l V a r i a b l e s
1901C-----------------------------------------------
1902#ifdef MPI
1903 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1904 . SIZ,J,K,L,NB_NOD,
1905 . STATUS(MPI_STATUS_SIZE),
1906 . iad_send(nspmd+1),iad_recv(nspmd+1),
1907 . req_r(nspmd),req_s(nspmd),offset,
1908 . sbuf(2*lenr),rbuf(2*lenr), msgoff
1909 DATA msgoff/5019/
1910C-----------------------------------------------
1911C S o u r c e L i n e s
1912C-----------------------------------------------
1913 loc_proc = ispmd + 1
1914 l = 1
1915 iad_recv(1) = 1
1916
1917 DO i=1,nspmd
1918 siz = 2*(dd_r2r(i+1,2)-dd_r2r(i,2))
1919 IF(siz/=0)THEN
1920 msgtyp = msgoff
1921 CALL mpi_irecv(
1922 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
1923 g spmd_comm_world,req_r(i),ierror)
1924 l = l + siz
1925 ENDIF
1926 iad_recv(i+1) = l
1927 END DO
1928C
1929 l = 1
1930 iad_send(1) = 1
1931C
1932 DO i=1,nspmd
1933#include "vectorize.inc"
1934 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1935 nod = dd_r2r_elem(j)
1936 sbuf(l) = itag(nod)
1937 sbuf(l+1) = itag(numnod+nod)
1938 l = l + 2
1939 END DO
1940 iad_send(i+1) = l
1941 ENDDO
1942C
1943C echange messages
1944C
1945 DO i=1,nspmd
1946C--------------------------------------------------------------------
1947C envoi a N+I mod P
1948C test si msg necessaire a envoyer a completer par test interface
1949 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1950 msgtyp = msgoff
1951 siz = iad_send(i+1)-iad_send(i)
1952 l = iad_send(i)
1953 CALL mpi_isend(
1954 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
1955 g spmd_comm_world,req_s(i),ierror)
1956 ENDIF
1957C--------------------------------------------------------------------
1958 ENDDO
1959C
1960C decompactage
1961C
1962 offset = dd_r2r(nspmd+1,1)-1
1963 DO i = 1, nspmd
1964C test si msg necessaire a envoyer a completer par test interface
1965 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1966 IF(nb_nod>0)THEN
1967 CALL mpi_wait(req_r(i),status,ierror)
1968 l = iad_recv(i)
1969#include "vectorize.inc"
1970 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1971 nod = dd_r2r_elem(offset+j)
1972 itag(nod) = rbuf(l)
1973 itag(numnod+nod) = rbuf(l+1)
1974 l = l + 2
1975 END DO
1976C ---
1977 ENDIF
1978C
1979 END DO
1980C
1981C wait terminaison isend
1982C
1983 DO i = 1, nspmd
1984 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1985 CALL mpi_wait(req_s(i),status,ierror)
1986 ENDIF
1987 ENDDO
1988C
1989
1990#endif
1991 RETURN
1992 END
1993C
1994!||====================================================================
1995!|| spmd_exch_r2r_sph ../engine/source/mpi/r2r/spmd_r2r.F
1996!||--- called by ------------------------------------------------------
1997!|| resol ../engine/source/engine/resol.F
1998!||--- calls -----------------------------------------------------
1999!||--- uses -----------------------------------------------------
2000!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2001!||====================================================================
2002 SUBROUTINE spmd_exch_r2r_sph(A,IAD_ELEM,FR_ELEM,DD_R2R,DD_R2R_ELEM,LENR)
2003C-----------------------------------------------
2004C I m p l i c i t T y p e s
2005C-----------------------------------------------
2006 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2007#include "implicit_f.inc"
2008C-----------------------------------------------------------------
2009C M e s s a g e P a s s i n g
2010C-----------------------------------------------
2011#include "spmd.inc"
2012C-----------------------------------------------
2013C C o m m o n B l o c k s
2014C-----------------------------------------------
2015#include "com01_c.inc"
2016#include "task_c.inc"
2017#include "tabsiz_c.inc"
2018C-----------------------------------------------
2019C D u m m y A r g u m e n t s
2020C-----------------------------------------------
2021 INTEGER IAD_ELEM(2,*),FR_ELEM(*),
2022 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),LENR
2023 my_real
2024 . A(3,*)
2025C-----------------------------------------------
2026C L o c a l V a r i a b l e s
2027C-----------------------------------------------
2028#ifdef MPI
2029 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
2030 . SIZ,J,K,L,NB_NOD,
2031 . STATUS(MPI_STATUS_SIZE),
2032 . iad_send(nspmd+1),iad_recv(nspmd+1),
2033 . req_r(nspmd),req_s(nspmd),offset
2034 my_real
2035 . rbuf(3*lenr ),sbuf(3*lenr )
2036C-----------------------------------------------
2037C S o u r c e L i n e s
2038C-----------------------------------------------
2039 loc_proc = ispmd + 1
2040 l = 1
2041 iad_recv(1) = 1
2042 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2043
2044 DO i=1,nspmd
2045 siz = 3*(dd_r2r(i+1,1)-dd_r2r(i,1))
2046 IF(siz/=0)THEN
2047 msgtyp = 10000 + nspmd*(i-1) + loc_proc
2048 CALL mpi_irecv(
2049 s rbuf(l),siz,real,it_spmd(i),msgtyp,
2050 g spmd_comm_world,req_r(i),ierror)
2051 l = l + siz
2052 ENDIF
2053 iad_recv(i+1) = l
2054 END DO
2055 l = 1
2056 iad_send(1) = 1
2057C
2058 offset = dd_r2r(nspmd+1,1)-1
2059 DO i=1,nspmd
2060C preparation envoi partie fixe (elem) a proc I
2061#include "vectorize.inc"
2062 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
2063 nod = dd_r2r_elem(offset+j)
2064 sbuf(l ) = a(1,nod)
2065 sbuf(l+1) = a(2,nod)
2066 sbuf(l+2) = a(3,nod)
2067 l = l + 3
2068 END DO
2069C
2070 iad_send(i+1) = l
2071 ENDDO
2072C
2073C echange messages
2074C
2075 DO i=1,nspmd
2076C--------------------------------------------------------------------
2077C envoi a N+I mod P
2078 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2079 msgtyp = 10000 + nspmd*(loc_proc-1) + i
2080 siz = iad_send(i+1)-iad_send(i)
2081 l = iad_send(i)
2082 CALL mpi_isend(
2083 s sbuf(l),siz,real,it_spmd(i),msgtyp,
2084 g spmd_comm_world,req_s(i),ierror)
2085 ENDIF
2086C--------------------------------------------------------------------
2087 ENDDO
2088C
2089C decompactage
2090C
2091 DO i = 1, nspmd
2092 nb_nod = dd_r2r(i+1,1)-dd_r2r(i,1)
2093 IF(nb_nod>0)THEN
2094 CALL mpi_wait(req_r(i),status,ierror)
2095 l = iad_recv(i)
2096#include "vectorize.inc"
2097 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
2098 nod = dd_r2r_elem(j)
2099 a(1,nod) = rbuf(l)
2100 a(2,nod) = rbuf(l+1)
2101 a(3,nod) = rbuf(l+2)
2102 l = l + 3
2103 END DO
2104C ---
2105 ENDIF
2106C
2107 END DO
2108C
2109C wait terminaison isend
2110C
2111 DO i = 1, nspmd
2112 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2113 CALL mpi_wait(req_s(i),status,ierror)
2114 ENDIF
2115 ENDDO
2116C
2117
2118#endif
2119 RETURN
2120 END
2121!||====================================================================
2122!|| spmd_exch_r2r_sphoff ../engine/source/mpi/r2r/spmd_r2r.F
2123!||--- called by ------------------------------------------------------
2124!|| resol ../engine/source/engine/resol.F
2125!||--- calls -----------------------------------------------------
2126!||--- uses -----------------------------------------------------
2127!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2128!||====================================================================
2129 SUBROUTINE spmd_exch_r2r_sphoff(OFF_SPH_R2R,IAD_ELEM,
2130 1 FR_ELEM,DD_R2R,DD_R2R_ELEM,LENR)
2131C-----------------------------------------------
2132C I m p l i c i t T y p e s
2133C-----------------------------------------------
2134 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2135#include "implicit_f.inc"
2136C-----------------------------------------------------------------
2137C M e s s a g e P a s s i n g
2138C-----------------------------------------------
2139#include "spmd.inc"
2140C-----------------------------------------------
2141C C o m m o n B l o c k s
2142C-----------------------------------------------
2143#include "com01_c.inc"
2144#include "task_c.inc"
2145#include "tabsiz_c.inc"
2146C-----------------------------------------------
2147C D u m m y A r g u m e n t s
2148C-----------------------------------------------
2149 INTEGER OFF_SPH_R2R(*),IAD_ELEM(2,*),
2150 . FR_ELEM(*),DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),LENR
2151C-----------------------------------------------
2152C L o c a l V a r i a b l e s
2153C-----------------------------------------------
2154#ifdef MPI
2155 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
2156 . siz,j,k,l,nb_nod,
2157 . status(mpi_status_size),
2158 . iad_send(nspmd+1),iad_recv(nspmd+1),
2159 . req_r(nspmd),req_s(nspmd),offset,
2160 . rbuf(lenr ),sbuf(lenr )
2161C-----------------------------------------------
2162C S o u r c e L i n e s
2163C-----------------------------------------------
2164 loc_proc = ispmd + 1
2165 l = 1
2166 iad_recv(1) = 1
2167
2168 DO i=1,nspmd
2169 siz = dd_r2r(i+1,1)-dd_r2r(i,1)
2170 IF(siz/=0)THEN
2171 msgtyp = 10000 + nspmd*(i-1) + loc_proc
2172 CALL mpi_irecv(
2173 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2174 g spmd_comm_world,req_r(i),ierror)
2175 l = l + siz
2176 ENDIF
2177 iad_recv(i+1) = l
2178 END DO
2179 l = 1
2180 iad_send(1) = 1
2181C
2182 offset = dd_r2r(nspmd+1,1)-1
2183 DO i=1,nspmd
2184C preparation envoi partie fixe (elem) a proc I
2185#include "vectorize.inc"
2186 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
2187 nod = dd_r2r_elem(offset+j)
2188 sbuf(l) = off_sph_r2r(nod)
2189 l = l + 1
2190 END DO
2191C
2192 iad_send(i+1) = l
2193 ENDDO
2194C
2195C echange messages
2196C
2197 DO i=1,nspmd
2198C--------------------------------------------------------------------
2199C envoi a N+I mod P
2200 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2201 msgtyp = 10000 + nspmd*(loc_proc-1) + i
2202 siz = iad_send(i+1)-iad_send(i)
2203 l = iad_send(i)
2204 CALL mpi_isend(
2205 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2206 g spmd_comm_world,req_s(i),ierror)
2207 ENDIF
2208C--------------------------------------------------------------------
2209 ENDDO
2210C
2211C decompactage
2212C
2213 DO i = 1, nspmd
2214 nb_nod = dd_r2r(i+1,1)-dd_r2r(i,1)
2215 IF(nb_nod>0)THEN
2216 CALL mpi_wait(req_r(i),status,ierror)
2217 l = iad_recv(i)
2218#include "vectorize.inc"
2219 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
2220 nod = dd_r2r_elem(j)
2221 off_sph_r2r(nod) = rbuf(l)
2222 l = l + 1
2223 END DO
2224C ---
2225 ENDIF
2226C
2227 END DO
2228C
2229C wait terminaison isend
2230C
2231 DO i = 1, nspmd
2232 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2233 CALL mpi_wait(req_s(i),status,ierror)
2234 ENDIF
2235 ENDDO
2236C
2237
2238#endif
2239 RETURN
2240 END
my_real
#define my_real
Definition cppsort.cpp:32
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
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_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
rad2r_mod
Definition rad2r.F:46
rad2r_mod::dbn
integer, dimension(:,:), allocatable dbn
Definition rad2r.F:58
rad2r_mod::tcnelt
integer, dimension(:), allocatable tcnelt
Definition rad2r.F:53
rad2r_mod::tcneltdb
integer, dimension(:), allocatable tcneltdb
Definition rad2r.F:53
rad2r_mod::offset
integer, dimension(:), allocatable offset
Definition rad2r.F:53
rad2r_mod::tbcnel
integer, dimension(:,:), allocatable tbcnel
Definition rad2r.F:58
rad2r_mod::tag_rby
integer, dimension(:), allocatable tag_rby
Definition rad2r.F:53
rad2r_mod::nbeln
integer, dimension(:,:), allocatable nbeln
Definition rad2r.F:58
rad2r_mod::nbeltn_r2r
integer, dimension(:), allocatable nbeltn_r2r
Definition rad2r.F:53
rad2r_mod::nbel
integer, dimension(:,:), allocatable nbel
Definition rad2r.F:58
rad2r_mod::add_rby
integer, dimension(:), allocatable add_rby
Definition rad2r.F:53
rad2r_mod::nbelt_r2r
integer, dimension(:), allocatable nbelt_r2r
Definition rad2r.F:53
rad2r_mod::tbcneldb
integer, dimension(:,:), allocatable tbcneldb
Definition rad2r.F:58
rad2r_mod::dbno
integer, dimension(:), allocatable dbno
Definition rad2r.F:53
send_mass_rby_spmd
subroutine send_mass_rby_spmd(idp, nng, grnod, ms, in, dd_r2r, nglob, weight, flag_rot, npby, rby, addr)
Definition r2r_init.F:804
r2r_init
subroutine r2r_init(iexlnk, itab, igrnod, x, ms, in, dd_r2r, weight, iad_elem, fr_elem, addcnel, cnel, ixc, iparg, icodt, icodr, ibfv, dx, rby, npby, xdp, stifn, stifr, dd_r2r_elem, sdd_r2r_elem, weight_md, ilenxv, numsph_glo_r2r, flg_sphinout_r2r, ipari, nloc_dmg)
Definition r2r_init.F:70
get_name_c
void get_name_c(char *name)
Definition rad2rad_c.c:2607
spmd_r2r_rset
subroutine spmd_r2r_rset(m, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf, iex)
Definition spmd_r2r.F:765
spmd_r2r_iget4
subroutine spmd_r2r_iget4(itab, nng, grnod, dd_r2r, weight, ibuf, iex, dbnbuf, ddbuf, flag)
Definition spmd_r2r.F:615
spmd_r2r_rget3
subroutine spmd_r2r_rget3(x, nng, grnod, dd_r2r, weight, bufr)
Definition spmd_r2r.F:34
spmd_r2r_rby
subroutine spmd_r2r_rby(rby, nng, grnod, dd_r2r, weight, iex, bufr)
Definition spmd_r2r.F:251
spmd_exch_r2r
subroutine spmd_exch_r2r(a, ar, stifn, stifr, ms, iad_elem, fr_elem, size, lenr, dd_r2r, dd_r2r_elem, flag)
Definition spmd_r2r.F:1180
spmd_r2r_rset4
subroutine spmd_r2r_rset4(m, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf)
Definition spmd_r2r.F:856
spmd_exch_work
subroutine spmd_exch_work(wf, wf2)
Definition spmd_r2r.F:1729
spmd_exch_r2r_itag
subroutine spmd_exch_r2r_itag(itag, iad_elem, fr_elem, dd_r2r, dd_r2r_elem, lenr)
Definition spmd_r2r.F:1876
spmd_r2r_iget2
subroutine spmd_r2r_iget2(itab, nng, iex, ibuf, flag)
Definition spmd_r2r.F:512
spmd_exch_r2r_sphoff
subroutine spmd_exch_r2r_sphoff(off_sph_r2r, iad_elem, fr_elem, dd_r2r, dd_r2r_elem, lenr)
Definition spmd_r2r.F:2131
spmd_r2r_rget
subroutine spmd_r2r_rget(m, nng, grnod, dd_r2r, weight, bufr)
Definition spmd_r2r.F:180
spmd_r2r_rset3b
subroutine spmd_r2r_rset3b(a, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf, ms, v, wf, wf2, iex)
Definition spmd_r2r.F:1040
spmd_r2r_iget
subroutine spmd_r2r_iget(itab, nng, grnod, dd_r2r, weight, ibuf, flag)
Definition spmd_r2r.F:437
spmd_r2r_tagel
subroutine spmd_r2r_tagel(tagelg, tagel, len)
Definition spmd_r2r.F:1811
spmd_r2r_rset3
subroutine spmd_r2r_rset3(a, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf, iex)
Definition spmd_r2r.F:942
spmd_exch_r2r_sph
subroutine spmd_exch_r2r_sph(a, iad_elem, fr_elem, dd_r2r, dd_r2r_elem, lenr)
Definition spmd_r2r.F:2003
spmd_exch_r2r_2
subroutine spmd_exch_r2r_2(a, ar, v, vr, ms, in, iad_elem, fr_elem, size, wf, wf2, lenr, dd_r2r, dd_r2r_elem, weight, flag)
Definition spmd_r2r.F:1361
spmd_r2r_sync
subroutine spmd_r2r_sync(addr)
Definition spmd_r2r.F:700
spmd_exch_r2r_rby
subroutine spmd_exch_r2r_rby(npby, rby, iad_elem, fr_elem, size, lenr, dd_r2r, dd_r2r_elem, x)
Definition spmd_r2r.F:1570
spmd_r2r_rget3_dp
subroutine spmd_r2r_rget3_dp(x, nng, grnod, dd_r2r, weight, bufr)
Definition spmd_r2r.F:106
spmd_r2r_idef
subroutine spmd_r2r_idef(nng, grnod, weight, iex, tlel, tleln, tcnel, tcneldb)
Definition spmd_r2r.F:329