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,
357 . STATUS(MPI_STATUS_SIZE),NB(6),OFFSET1
358 DATA MSGOFF/5004/
359C-----------------------------------------------
360C
361C --- gathering information on the processors: number of elements to send, double nodes, 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, 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 of the element numbering----
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 P, IERROR, MSGOFF, LOC_PROC, MSGTYP,
723 . STATUS(MPI_STATUS_SIZE),BUFSIZ,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, P, N, L, IERROR, MSGOFF,
796 . LOC_PROC, MSGTYP, BUFSIZ,
797 . dbl,
798 . status(mpi_status_size), itag(numnod)
799 DATA msgoff/5009/
800C-----------------------------------------------
801C
802 loc_proc = ispmd+1
803 IF(loc_proc==1) THEN
804 l = dd_r2r(1)+dbn(iex,1)
805 DO p = 2, nspmd
806 IF((dd_r2r(p)+dbn(iex,p))>0)THEN
807 bufsiz = dd_r2r(p)+dbn(iex,p)
808 msgtyp = msgoff
809 CALL mpi_send(
810 s bufr(l+1),bufsiz,real,it_spmd(p),msgtyp,
811 g spmd_comm_world,ierror)
812 l = l + dd_r2r(p)+dbn(iex,p)
813 END IF
814 END DO
815 ELSEIF(nng>0)THEN
816 bufsiz = nng
817 msgtyp = msgoff
818 CALL mpi_recv(
819 s bufr,bufsiz,real,it_spmd(1),msgtyp,
820 g spmd_comm_world,status,ierror)
821 END IF
822 DO i = 1, numnod
823 itag(i) = 0
824 END DO
825 l = 0
826 dbl = dd_r2r(loc_proc)
827
828 DO i = 1, nng
829 n=grnod(i)
830 IF(weight(n)==1)THEN
831 l = l + 1
832 m(n) = bufr(l)
833 ELSE
834 dbl = dbl + 1
835 m(n) = bufr(dbl)
836 ENDIF
837 END DO
838C
839#endif
840 RETURN
841 END
842C
843!||====================================================================
844!|| spmd_r2r_rset4 ../engine/source/mpi/r2r/spmd_r2r.F
845!||--- called by ------------------------------------------------------
846!|| get_mass_spmd ../engine/source/coupling/rad2rad/r2r_init.F
847!||--- calls -----------------------------------------------------
848!||--- uses -----------------------------------------------------
849!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
850!||====================================================================
851 SUBROUTINE spmd_r2r_rset4(
852 1 M ,NNG ,GRNOD, DD_R2R, WEIGHT,
853 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF )
854C-----------------------------------------------
855C I m p l i c i t T y p e s
856C-----------------------------------------------
857 USE spmd_comm_world_mod, ONLY : spmd_comm_world
858#include "implicit_f.inc"
859C-----C-----------------------------------------------------------------
860C M e s s a g e P a s s i n g
861C-----------------------------------------------
862#include "spmd.inc"
863C-----------------------------------------------
864C C o m m o n B l o c k s
865C-----------------------------------------------
866#include "com01_c.inc"
867#include "com04_c.inc"
868#include "task_c.inc"
869C-----------------------------------------------
870C D u m m y A r g u m e n t s
871C-----------------------------------------------
872 INTEGER NNG,LRBUF,
873 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
874 my_real
875 . BUFR(*), M(*)
876C-----------------------------------------------
877C L o c a l V a r i a b l e s
878C-----------------------------------------------
879#ifdef MPI
880 INTEGER I, P, N, L, IERROR, MSGOFF,
881 . LOC_PROC, MSGTYP, BUFSIZ,
882 .
883 . STATUS(MPI_STATUS_SIZE), ITAG(NUMNOD)
884 DATA msgoff/5010/
885C-----------------------------------------------
886C
887 loc_proc = ispmd+1
888 IF(loc_proc==1) THEN
889 l = dd_r2r(1)
890 DO p = 2, nspmd
891 IF((dd_r2r(p))>0)THEN
892 bufsiz = dd_r2r(p)
893 msgtyp = msgoff
894 CALL mpi_send(
895 s bufr(l+1),bufsiz,real,it_spmd(p),msgtyp,
896 g spmd_comm_world,ierror)
897 l = l + dd_r2r(p)
898 END IF
899 END DO
900 ELSEIF(dd_r2r(loc_proc)>0)THEN
901 bufsiz = dd_r2r(loc_proc)
902 msgtyp = msgoff
903 CALL mpi_recv(
904 s bufr,bufsiz,real,it_spmd(1),msgtyp,
905 g spmd_comm_world,status,ierror)
906 END IF
907 DO i = 1, numnod
908 itag(i) = 0
909 END DO
910 l = 0
911 DO i = 1, nng
912 n=grnod(i)
913 IF(weight(n)==1)THEN
914 l = l + 1
915 m(n) = bufr(l)
916 itag(n) = 1
917 END IF
918 END DO
919
920C
921#endif
922 RETURN
923 END
924C
925!||====================================================================
926!|| spmd_r2r_rset3 ../engine/source/mpi/r2r/spmd_r2r.f
927!||--- called by ------------------------------------------------------
928!|| get_displ_spmd ../engine/source/coupling/rad2rad/r2r_getdata.F
929!|| get_force_spmd ../engine/source/coupling/rad2rad/r2r_getdata.F
930!||--- calls -----------------------------------------------------
931!||--- uses -----------------------------------------------------
932!|| rad2r_mod ../engine/share/modules/rad2r.F
933!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
934!||====================================================================
935 SUBROUTINE spmd_r2r_rset3(
936 1 A ,NNG ,GRNOD, DD_R2R, WEIGHT,
937 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF,IEX )
938C-----------------------------------------------
939C M o d u l e s
940C-----------------------------------------------
941 USE rad2r_mod
942C-----------------------------------------------
943C I m p l i c i t T y p e s
944C-----------------------------------------------
945 USE spmd_comm_world_mod, ONLY : spmd_comm_world
946#include "implicit_f.inc"
947C-----C-----------------------------------------
948C M e s s a g e P a s s i n g
949C-----------------------------------------------
950#include "spmd.inc"
951C-----------------------------------------------
952C C o m m o n B l o c k s
953C-----------------------------------------------
954#include "com01_c.inc"
955#include "com04_c.inc"
956#include "task_c.inc"
957C-----------------------------------------------
958C D u m m y A r g u m e n t s
959C-----------------------------------------------
960 INTEGER NNG,LRBUF,IEX,
961 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
962 my_real
963 . BUFR(3,*), A(3,*)
964C-----------------------------------------------
965C L o c a l V a r i a b l e s
966C-----------------------------------------------
967#ifdef MPI
968 INTEGER I, P, N, L, IERROR, MSGOFF, DBL,
969 . LOC_PROC, MSGTYP, BUFSIZ,
970 .
971 . STATUS(MPI_STATUS_SIZE), ITAG(NUMNOD)
972 DATA MSGOFF/5011/
973C-----------------------------------------------
974C
975 loc_proc = ispmd+1
976 IF(loc_proc==1) THEN
977 l = dd_r2r(1)+dbn(iex,1)
978 DO p = 2, nspmd
979 IF((dd_r2r(p)+dbn(iex,p))>0)THEN
980 bufsiz = (dd_r2r(p)+dbn(iex,p))*3
981 msgtyp = msgoff
982 CALL mpi_send(
983 s bufr(1,l+1),bufsiz,real,it_spmd(p),msgtyp,
984 g spmd_comm_world,ierror)
985 l = l + dd_r2r(p)+dbn(iex,p)
986 END IF
987 END DO
988 ELSEIF(nng>0)THEN
989 bufsiz = nng*3
990 msgtyp = msgoff
991 CALL mpi_recv(
992 s bufr,bufsiz,real,it_spmd(1),msgtyp,
993 g spmd_comm_world,status,ierror)
994 END IF
995 DO i = 1, numnod
996 itag(i) = 0
997 END DO
998
999 l = 0
1000 dbl = dd_r2r(loc_proc)
1001
1002 DO i = 1, nng
1003 n=grnod(i)
1004 IF(weight(n)==1)THEN
1005 l = l + 1
1006 a(1,n) = bufr(1,l)
1007 a(2,n) = bufr(2,l)
1008 a(3,n) = bufr(3,l)
1009 ELSE
1010 dbl = dbl + 1
1011 a(1,n) = bufr(1,dbl)
1012 a(2,n) = bufr(2,dbl)
1013 a(3,n) = bufr(3,dbl)
1014 ENDIF
1015 END DO
1016C
1017#endif
1018 RETURN
1019 END
1020C
1021!||====================================================================
1022!|| spmd_r2r_rset3b ../engine/source/mpi/r2r/spmd_r2r.F
1023!||--- called by ------------------------------------------------------
1024!|| get_force_spmd ../engine/source/coupling/rad2rad/r2r_getdata.F
1025!||--- calls -----------------------------------------------------
1026!||--- uses -----------------------------------------------------
1027!|| rad2r_mod ../engine/share/modules/rad2r.F
1028!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1029!||====================================================================
1030 SUBROUTINE spmd_r2r_rset3b(
1031 1 A ,NNG ,GRNOD, DD_R2R,WEIGHT,
1032 2 BUFR ,IAD_ELEM,FR_ELEM, LRBUF ,MS ,
1033 3 V ,WF ,WF2, IEX )
1034C-----------------------------------------------
1035C M o d u l e s
1036C-----------------------------------------------
1037 USE rad2r_mod
1038C-----------------------------------------------
1039C I m p l i c i t T y p e s
1040C-----------------------------------------------
1041 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1042#include "implicit_f.inc"
1043C-----C-----------------------------------------
1044C M e s s a g e P a s s i n g
1045C-----------------------------------------------
1046#include "spmd.inc"
1047C-----------------------------------------------
1048C C o m m o n B l o c k s
1049C-----------------------------------------------
1050#include "com01_c.inc"
1051#include "com04_c.inc"
1052#include "task_c.inc"
1053C-----------------------------------------------
1054C D u m m y A r g u m e n t s
1055C-----------------------------------------------
1056 INTEGER NNG,LRBUF,IEX,
1057 . GRNOD(*),DD_R2R(*),WEIGHT(*),IAD_ELEM(2,*),FR_ELEM(*)
1058 my_real
1059 . bufr(3,*), a(3,*), ms(*), v(3,*), wf, wf2
1060C-----------------------------------------------
1061C L o c a l V a r i a b l e s
1062C-----------------------------------------------
1063#ifdef MPI
1064 INTEGER I, P, N, L, IERROR, MSGOFF, MSGOFF2, DBL,
1065 . LOC_PROC, MSGTYP, BUFSIZ,
1066 .
1067 . STATUS(MPI_STATUS_SIZE)
1068 my_real
1069 . DF1, DF2, DF3, WFB
1070 DATA MSGOFF/5012/
1071 DATA MSGOFF2/5013/
1072C-----------------------------------------------
1073C
1074 wf=0
1075 wf2=0
1076
1077 loc_proc = ispmd+1
1078 IF(loc_proc==1) THEN
1079 l = dd_r2r(1)+dbn(iex,1)
1080 DO p = 2, nspmd
1081 IF((dd_r2r(p)+dbn(iex,p))>0)THEN
1082 bufsiz = (dd_r2r(p)+dbn(iex,p))*3
1083 msgtyp = msgoff
1084 CALL mpi_send(
1085 s bufr(1,l+1),bufsiz,real,it_spmd(p),msgtyp,
1086 g spmd_comm_world,ierror)
1087 l = l + dd_r2r(p)+dbn(iex,p)
1088 END IF
1089 END DO
1090 ELSEIF(nng>0)THEN
1091 bufsiz = nng*3
1092 msgtyp = msgoff
1093 CALL mpi_recv(
1094 s bufr,bufsiz,real,it_spmd(1),msgtyp,
1095 g spmd_comm_world,status,ierror)
1096 END IF
1097
1098 l = 0
1099 dbl = dd_r2r(loc_proc)
1100
1101 DO i = 1, nng
1102 n=grnod(i)
1103 IF(weight(n)==1)THEN
1104 l = l + 1
1105 df1 = ms(n)*bufr(1,l)-a(1,n)
1106 df2 = ms(n)*bufr(2,l)-a(2,n)
1107 df3 = ms(n)*bufr(3,l)-a(3,n)
1108 a(1,n) = ms(n)*bufr(1,l)
1109 a(2,n) = ms(n)*bufr(2,l)
1110 a(3,n) = ms(n)*bufr(3,l)
1111C local computation of work
1112 wf = wf + (df1*v(1,n)+df2*v(2,n)+df3*v(3,n))/two
1113 wf2= wf2+ (df1*a(1,n)+df2*a(2,n)+df3*a(3,n))/(two*ms(n))
1114 ELSE
1115 dbl = dbl + 1
1116 df1 = ms(n)*bufr(1,dbl)-a(1,n)
1117 df2 = ms(n)*bufr(2,dbl)-a(2,n)
1118 df3 = ms(n)*bufr(3,dbl)-a(3,n)
1119 a(1,n) = ms(n)*bufr(1,dbl)
1120 a(2,n) = ms(n)*bufr(2,dbl)
1121 a(3,n) = ms(n)*bufr(3,dbl)
1122 ENDIF
1123 END DO
1124
1125C summation over the processors of wf
1126 IF(loc_proc==1) THEN
1127 DO p = 2, nspmd
1128 msgtyp = msgoff
1129 CALL mpi_recv(
1130 s wfb,1,real,it_spmd(p),msgtyp,
1131 g spmd_comm_world,status,ierror)
1132 wf = wf+wfb
1133 END DO
1134 ELSE
1135 msgtyp = msgoff
1136 CALL mpi_send(
1137 s wf,1,real,it_spmd(1),msgtyp,
1138 g spmd_comm_world,ierror)
1139 END IF
1140
1141C summation over the processors of wf2
1142
1143 IF(loc_proc==1) THEN
1144 DO p = 2, nspmd
1145 msgtyp = msgoff
1146 CALL mpi_recv(
1147 s wfb,1,real,it_spmd(p),msgtyp,
1148 g spmd_comm_world,status,ierror)
1149 wf2 = wf2+wfb
1150 END DO
1151 ELSE
1152 msgtyp = msgoff
1153 CALL mpi_send(
1154 s wf2,1,real,it_spmd(1),msgtyp,
1155 g spmd_comm_world,ierror)
1156 END IF
1157
1158#endif
1159 RETURN
1160 END
1161!||====================================================================
1162!|| spmd_exch_r2r ../engine/source/mpi/r2r/spmd_r2r.F
1163!||--- called by ------------------------------------------------------
1164!|| r2r_exchange ../engine/source/coupling/rad2rad/r2r_exchange.F
1165!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
1166!||--- calls -----------------------------------------------------
1167!||--- uses -----------------------------------------------------
1168!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1169!||====================================================================
1170 SUBROUTINE spmd_exch_r2r(
1171 1 A ,AR ,STIFN,STIFR ,MS ,
1172 2 IAD_ELEM ,FR_ELEM, SIZE,
1173 3 LENR ,DD_R2R,DD_R2R_ELEM,FLAG)
1174C--------------------------------------
1175C-----------------------------------------------
1176C I m p l i c i t T y p e s
1177C-----------------------------------------------
1178 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1179#include "implicit_f.inc"
1180C-----------------------------------------------------------------
1181C M e s s a g e P a s s i n g
1182C-----------------------------------------------
1183#include "spmd.inc"
1184C-----------------------------------------------
1185C C o m m o n B l o c k s
1186C-----------------------------------------------
1187#include "com01_c.inc"
1188#include "task_c.inc"
1189#include "tabsiz_c.inc"
1190C-----------------------------------------------
1191C D u m m y A r g u m e n t s
1192C-----------------------------------------------
1193 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR,
1194 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),FLAG
1195 my_real
1196 . A(3,*),AR(3,*),STIFN(*),STIFR(*),MS(*)
1197C-----------------------------------------------
1198C L o c a l V a r i a b l e s
1199C-----------------------------------------------
1200#ifdef MPI
1201 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1202 . SIZ,J,L,NB_NOD,
1203 . STATUS(MPI_STATUS_SIZE),
1204 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1205 . REQ_R(NSPMD),REQ_S(NSPMD),OFFSET,MSGOFF
1206 my_real
1207 . RBUF(SIZE*LENR ),
1208 . SBUF(SIZE*LENR )
1209 DATA MSGOFF/5014/
1210C-----------------------------------------------
1211C S o u r c e L i n e s
1212C-----------------------------------------------
1213 loc_proc = ispmd + 1
1214 l = 1
1215 iad_recv(1) = 1
1216
1217 DO i=1,nspmd
1218 siz = size*(dd_r2r(i+1,2)-dd_r2r(i,2))
1219 IF(siz/=0)THEN
1220 msgtyp = msgoff
1221 CALL mpi_irecv(
1222 s rbuf(l),siz,real,it_spmd(i),msgtyp,
1223 g spmd_comm_world,req_r(i),ierror)
1224 l = l + siz
1225 ENDIF
1226 iad_recv(i+1) = l
1227 END DO
1228 l = 1
1229 iad_send(1) = 1
1230C
1231 DO i=1,nspmd
1232C preparation envoi partie fixe (elem) a proc I
1233 IF(iroddl/=0) THEN
1234#include "vectorize.inc"
1235 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1236 nod = dd_r2r_elem(j)
1237 IF (flag==2) THEN
1238 sbuf(l ) = a(1,nod)
1239 sbuf(l+1) = a(2,nod)
1240 sbuf(l+2) = a(3,nod)
1241 sbuf(l+3) = ar(1,nod)
1242 sbuf(l+4) = ar(2,nod)
1243 sbuf(l+5) = ar(3,nod)
1244 ELSE
1245 sbuf(l ) = stifn(nod)
1246 sbuf(l+1) = stifr(nod)
1247 ENDIF
1248 l = l + SIZE
1249 END DO
1250 ELSE
1251#include "vectorize.inc"
1252 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1253 nod = dd_r2r_elem(j)
1254 IF (flag==2) THEN
1255 sbuf(l ) = a(1,nod)
1256 sbuf(l+1) = a(2,nod)
1257 sbuf(l+2) = a(3,nod)
1258 ELSE
1259 sbuf(l ) = stifn(nod)
1260 ENDIF
1261 l = l + SIZE
1262 END DO
1263 ENDIF
1264C
1265 iad_send(i+1) = l
1266 ENDDO
1267C
1268C echange messages
1269C
1270 DO i=1,nspmd
1271C--------------------------------------------------------------------
1272C envoi a N+I mod P
1273C test if msg requires to send to complete by test interface
1274 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1275 msgtyp = msgoff
1276 siz = iad_send(i+1)-iad_send(i)
1277 l = iad_send(i)
1278 CALL mpi_isend(
1279 s sbuf(l),siz,real,it_spmd(i),msgtyp,
1280 g spmd_comm_world,req_s(i),ierror)
1281 ENDIF
1282C--------------------------------------------------------------------
1283 ENDDO
1284C
1285C decompactage
1286C
1287 offset = dd_r2r(nspmd+1,1)-1
1288 DO i = 1, nspmd
1289C test if msg requires to send to complete by test interface
1290 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1291 IF(nb_nod>0)THEN
1292 CALL mpi_wait(req_r(i),status,ierror)
1293 l = iad_recv(i)
1294
1295 IF(iroddl/=0) THEN
1296#include "vectorize.inc"
1297 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1298 nod = dd_r2r_elem(offset+j)
1299 IF (flag==2) THEN
1300 a(1,nod) = rbuf(l)
1301 a(2,nod) = rbuf(l+1)
1302 a(3,nod) = rbuf(l+2)
1303 ar(1,nod)= rbuf(l+3)
1304 ar(2,nod)= rbuf(l+4)
1305 ar(3,nod)= rbuf(l+5)
1306 ELSE
1307 stifn(nod)= rbuf(l)
1308 stifr(nod)= rbuf(l+1)
1309 ENDIF
1310 l = l + SIZE
1311 END DO
1312 ELSE
1313#include "vectorize.inc"
1314 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1315 nod = dd_r2r_elem(offset+j)
1316 IF (flag==2) THEN
1317 a(1,nod) = rbuf(l)
1318 a(2,nod) = rbuf(l+1)
1319 a(3,nod) = rbuf(l+2)
1320 ELSE
1321 stifn(nod)= rbuf(l)
1322 ENDIF
1323 l = l + SIZE
1324 END DO
1325 ENDIF
1326C ---
1327 ENDIF
1328C
1329 END DO
1330C
1331C wait terminaison isend
1332C
1333 DO i = 1, nspmd
1334 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1335 CALL mpi_wait(req_s(i),status,ierror)
1336 ENDIF
1337 ENDDO
1338C
1339
1340#endif
1341 RETURN
1342 END
1343!||====================================================================
1344!|| spmd_exch_r2r_2 ../engine/source/mpi/r2r/spmd_r2r.F
1345!||--- called by ------------------------------------------------------
1346!|| r2r_getdata ../engine/source/coupling/rad2rad/r2r_getdata.F
1347!||--- calls -----------------------------------------------------
1348!||--- uses -----------------------------------------------------
1349!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1350!||====================================================================
1351 SUBROUTINE spmd_exch_r2r_2(
1352 1 A ,AR, V, VR ,MS , IN,
1353 2 IAD_ELEM ,FR_ELEM, SIZE, WF, WF2,
1354 3 LENR ,DD_R2R,DD_R2R_ELEM,WEIGHT,FLAG)
1355C--------------------------------------
1356C-----------------------------------------------
1357C I m p l i c i t T y p e s
1358C-----------------------------------------------
1359 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1360#include "implicit_f.inc"
1361C-----------------------------------------------------------------
1362C M e s s a g e P a s s i n g
1363C-----------------------------------------------
1364#include "spmd.inc"
1365C-----------------------------------------------
1366C C o m m o n B l o c k s
1367C-----------------------------------------------
1368#include "com01_c.inc"
1369#include "task_c.inc"
1370#include "tabsiz_c.inc"
1371C-----------------------------------------------
1372C D u m m y A r g u m e n t s
1373C-----------------------------------------------
1374 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR,
1375 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),FLAG,
1376 . WEIGHT(*)
1377 my_real
1378 . A(3,*),AR(3,*), V(3,*),VR(3,*),MS(*),IN(*),
1379 . WF,WF2
1380C-----------------------------------------------
1381C L o c a l V a r i a b l e s
1382C-----------------------------------------------
1383#ifdef MPI
1384 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1385 . SIZ,J,L,NB_NOD,
1386 . STATUS(MPI_STATUS_SIZE),
1387 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1388 . REQ_R(NSPMD),REQ_S(NSPMD),OFFSET,MSGOFF
1389 my_real
1390 . RBUF(SIZE*LENR ),
1391 . SBUF(SIZE*LENR ),DF1,DF2,DF3,DF4,DF5,DF6
1392 DATA MSGOFF/5015/
1393C-----------------------------------------------
1394C S o u r c e L i n e s
1395C-----------------------------------------------
1396 LOC_PROC = ispmd + 1
1397 l = 1
1398 iad_recv(1) = 1
1399
1400 DO i=1,nspmd
1401 siz = size*(dd_r2r(i+1,2)-dd_r2r(i,2))
1402 IF(siz/=0)THEN
1403 msgtyp = msgoff
1404 CALL mpi_irecv(
1405 s rbuf(l),siz,real,it_spmd(i),msgtyp,
1406 g spmd_comm_world,req_r(i),ierror)
1407 l = l + siz
1408 ENDIF
1409 iad_recv(i+1) = l
1410 END DO
1411 l = 1
1412 iad_send(1) = 1
1413C
1414 DO i=1,nspmd
1415C preparation envoi partie fixe (elem) a proc I
1416 IF(iroddl/=0) THEN
1417#include "vectorize.inc"
1418 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1419 nod = dd_r2r_elem(j)
1420 sbuf(l ) = a(1,nod)
1421 sbuf(l+1) = a(2,nod)
1422 sbuf(l+2) = a(3,nod)
1423 sbuf(l+3) = ar(1,nod)
1424 sbuf(l+4) = ar(2,nod)
1425 sbuf(l+5) = ar(3,nod)
1426 IF (flag==1) THEN
1427 sbuf(l+6) = ms(nod)
1428 sbuf(l+7) = in(nod)
1429 ENDIF
1430 l = l + SIZE
1431 END DO
1432 ELSE
1433#include "vectorize.inc"
1434 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1435 nod = dd_r2r_elem(j)
1436 sbuf(l ) = a(1,nod)
1437 sbuf(l+1) = a(2,nod)
1438 sbuf(l+2) = a(3,nod)
1439 IF (flag==1) THEN
1440 sbuf(l+3) = ms(nod)
1441 ENDIF
1442 l = l + SIZE
1443 END DO
1444 ENDIF
1445C
1446 iad_send(i+1) = l
1447 ENDDO
1448C
1449C echange messages
1450C
1451 DO i=1,nspmd
1452C--------------------------------------------------------------------
1453C envoi a N+I mod P
1454C test if msg requires to send to complete by test interface
1455 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1456 msgtyp = msgoff
1457 siz = iad_send(i+1)-iad_send(i)
1458 l = iad_send(i)
1459 CALL mpi_isend(
1460 s sbuf(l),siz,real,it_spmd(i),msgtyp,
1461 g spmd_comm_world,req_s(i),ierror)
1462 ENDIF
1463C--------------------------------------------------------------------
1464 ENDDO
1465C
1466C decompactage
1467C
1468 offset = dd_r2r(nspmd+1,1)-1
1469 DO i = 1, nspmd
1470C test if msg requires to send to complete by test interface
1471 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1472 IF(nb_nod>0)THEN
1473 CALL mpi_wait(req_r(i),status,ierror)
1474 l = iad_recv(i)
1475
1476 IF(iroddl/=0) THEN
1477#include "vectorize.inc"
1478 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1479 nod = dd_r2r_elem(offset+j)
1480 IF(weight(nod)==1)THEN
1481 df1 = rbuf(l)-a(1,nod)
1482 df2 = rbuf(l+1)-a(2,nod)
1483 df3 = rbuf(l+2)-a(3,nod)
1484 df4 = rbuf(l+3)-ar(1,nod)
1485 df5 = rbuf(l+4)-ar(2,nod)
1486 df6 = rbuf(l+5)-ar(3,nod)
1487 ENDIF
1488 a(1,nod) = rbuf(l)
1489 a(2,nod) = rbuf(l+1)
1490 a(3,nod) = rbuf(l+2)
1491 ar(1,nod)= rbuf(l+3)
1492 ar(2,nod)= rbuf(l+4)
1493 ar(3,nod)= rbuf(l+5)
1494 IF (flag==1) THEN
1495 ms(nod)= rbuf(l+6)
1496 in(nod)= rbuf(l+7)
1497 ENDIF
1498 l = l + SIZE
1499C local computation of work
1500 IF(weight(nod)==1)THEN
1501 wf = wf + (df1*v(1,nod)+df2*v(2,nod)+
1502 . df3*v(3,nod))/two
1503 wf2= wf2+ (df1*a(1,nod)+df2*a(2,nod)+
1504 . df3*a(3,nod))/(two*ms(nod))
1505 wf = wf + (df4*vr(1,nod)+df5*vr(2,nod)+
1506 . df6*vr(3,nod))/two
1507 wf2= wf2+ (df4*ar(1,nod)+df5*ar(2,nod)+
1508 . df6*ar(3,nod))/(two*in(nod))
1509 ENDIF
1510 END DO
1511 ELSE
1512#include "vectorize.inc"
1513 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1514 nod = dd_r2r_elem(offset+j)
1515 IF(weight(nod)==1)THEN
1516 df1 = rbuf(l)-a(1,nod)
1517 df2 = rbuf(l+1)-a(2,nod)
1518 df3 = rbuf(l+2)-a(3,nod)
1519 ENDIF
1520 a(1,nod) = rbuf(l)
1521 a(2,nod) = rbuf(l+1)
1522 a(3,nod) = rbuf(l+2)
1523 IF (flag==1) THEN
1524 ms(nod)= rbuf(l+3)
1525 ENDIF
1526 l = l + SIZE
1527C local computation of work
1528 IF(weight(nod)==1)THEN
1529 wf = wf + (df1*v(1,nod)+df2*v(2,nod)+
1530 . df3*v(3,nod))/two
1531 wf2= wf2+ (df1*a(1,nod)+df2*a(2,nod)+
1532 . df3*a(3,nod))/(two*ms(nod))
1533 ENDIF
1534 END DO
1535 ENDIF
1536C ---
1537 ENDIF
1538C
1539 END DO
1540C
1541C wait terminaison isend
1542C
1543 DO i = 1, nspmd
1544 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1545 CALL mpi_wait(req_s(i),status,ierror)
1546 ENDIF
1547 ENDDO
1548C
1549
1550#endif
1551 RETURN
1552 END
1553!||====================================================================
1554!|| spmd_exch_r2r_rby ../engine/source/mpi/r2r/spmd_r2r.F
1555!||--- called by ------------------------------------------------------
1556!|| r2r_init ../engine/source/coupling/rad2rad/r2r_init.F
1557!||--- calls -----------------------------------------------------
1558!||--- uses -----------------------------------------------------
1559!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1560!||====================================================================
1561 SUBROUTINE spmd_exch_r2r_rby(
1562 1 NPBY , RBY ,IAD_ELEM ,FR_ELEM, SIZE,
1563 2 LENR ,DD_R2R,DD_R2R_ELEM ,X)
1564C--------------------------------------
1565C-----------------------------------------------
1566C I m p l i c i t T y p e s
1567C-----------------------------------------------
1568 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1569#include "implicit_f.inc"
1570#include "param_c.inc"
1571C-----------------------------------------------------------------
1572C M e s s a g e P a s s i n g
1573C-----------------------------------------------
1574#include "spmd.inc"
1575C-----------------------------------------------
1576C C o m m o n B l o c k s
1577C-----------------------------------------------
1578#include "com01_c.inc"
1579#include "com04_c.inc"
1580#include "task_c.inc"
1581#include "tabsiz_c.inc"
1582C-----------------------------------------------
1583C D u m m y A r g u m e n t s
1584C-----------------------------------------------
1585 INTEGER IAD_ELEM(2,*),FR_ELEM(*), SIZE, LENR,
1586 . dd_r2r(nspmd+1,sdd_r2r),dd_r2r_elem(*),
1587 . npby(nnpby,*)
1588 my_real
1589 . rby(nrby,*)
1590 DOUBLE PRECISION X(3,*)
1591C-----------------------------------------------
1592C L o c a l V a r i a b l e s
1593C-----------------------------------------------
1594#ifdef MPI
1595 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1596 . SIZ,J,K,L,NB_NOD,
1597 . STATUS(MPI_STATUS_SIZE),
1598 . IAD_SEND(NSPMD+1),IAD_RECV(NSPMD+1),
1599 . REQ_R(NSPMD),REQ_S(NSPMD),OFFSET,IDRBY,MSGOFF
1600 DOUBLE PRECISION
1601 . RBUF(SIZE*LENR ),SBUF(SIZE*LENR )
1602 DATA MSGOFF/5016/
1603C-----------------------------------------------
1604C S o u r c e L i n e s
1605C-----------------------------------------------
1606 LOC_PROC = ispmd + 1
1607 l = 1
1608 iad_recv(1) = 1
1609
1610 DO i=1,nspmd
1611 siz = size*(dd_r2r(i+1,2)-dd_r2r(i,2))
1612 IF(siz/=0)THEN
1613 msgtyp = msgoff
1614 CALL mpi_irecv(
1615 s rbuf(l),siz,mpi_double_precision,it_spmd(i),
1616 g msgtyp,spmd_comm_world,req_r(i),ierror)
1617 l = l + siz
1618 ENDIF
1619 iad_recv(i+1) = l
1620 END DO
1621 l = 1
1622 iad_send(1) = 1
1623C
1624 DO i=1,nspmd
1625C preparation envoi partie fixe (elem) a proc I
1626
1627#include "vectorize.inc"
1628 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1629 idrby = 0
1630 nod = dd_r2r_elem(j)
1631 DO k=1,nrbody
1632 IF (npby(1,k)==nod) idrby = k
1633 END DO
1634 IF (idrby>0) THEN
1635 DO k=1,25
1636 sbuf(l+k-1) = rby(k,idrby)
1637 END DO
1638 sbuf(l+26-1) = x(1,nod)
1639 sbuf(l+27-1) = x(2,nod)
1640 sbuf(l+28-1) = x(3,nod)
1641 ELSE
1642 DO k=1,25
1643 sbuf(l+k-1) = 0
1644 END DO
1645 ENDIF
1646 l = l + SIZE
1647 END DO
1648C
1649 iad_send(i+1) = l
1650 ENDDO
1651C
1652C echange messages
1653C
1654 DO i=1,nspmd
1655C--------------------------------------------------------------------
1656C envoi a N+I mod P
1657C test if msg requires to send to complete by test interface
1658 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1659 msgtyp = msgoff
1660 siz = iad_send(i+1)-iad_send(i)
1661 l = iad_send(i)
1662 CALL mpi_isend(
1663 s sbuf(l),siz,mpi_double_precision,it_spmd(i),
1664 g msgtyp,spmd_comm_world,req_s(i),ierror)
1665 ENDIF
1666C--------------------------------------------------------------------
1667 ENDDO
1668C
1669C decompactage
1670C
1671 offset = dd_r2r(nspmd+1,1)-1
1672 DO i = 1, nspmd
1673C test if msg requires to send to complete by test interface
1674 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1675 IF(nb_nod>0)THEN
1676 CALL mpi_wait(req_r(i),status,ierror)
1677 l = iad_recv(i)
1678
1679#include "vectorize.inc"
1680 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1681 idrby = 0
1682 nod = dd_r2r_elem(offset+j)
1683 DO k=1,nrbody
1684 IF (npby(1,k)==nod) idrby = k
1685 END DO
1686 IF (idrby>0) THEN
1687 DO k=1,25
1688 rby(k,idrby) = rbuf(l+k-1)
1689 END DO
1690 x(1,nod) = rbuf(l+26-1)
1691 x(2,nod) = rbuf(l+27-1)
1692 x(3,nod) = rbuf(l+28-1)
1693 ENDIF
1694 l = l + SIZE
1695 END DO
1696C ---
1697 ENDIF
1698C
1699 END DO
1700C
1701C wait terminaison isend
1702C
1703 DO i = 1, nspmd
1704 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1705 CALL mpi_wait(req_s(i),status,ierror)
1706 ENDIF
1707 ENDDO
1708C
1709
1710#endif
1711 RETURN
1712 END
1713!||====================================================================
1714!|| spmd_exch_work ../engine/source/mpi/r2r/spmd_r2r.F
1715!||--- called by ------------------------------------------------------
1716!|| r2r_getdata ../engine/source/coupling/rad2rad/r2r_getdata.F
1717!||--- calls -----------------------------------------------------
1718!||--- uses -----------------------------------------------------
1719!|| rad2r_mod ../engine/share/modules/rad2r.F
1720!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1721!||====================================================================
1722 SUBROUTINE spmd_exch_work(WF, WF2)
1723C-----------------------------------------------
1724C M o d u l e s
1725C-----------------------------------------------
1726 USE rad2r_mod
1727C-----------------------------------------------
1728C I m p l i c i t T y p e s
1729C-----------------------------------------------
1730 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1731#include "implicit_f.inc"
1732C-----C-----------------------------------------
1733C M e s s a g e P a s s i n g
1734C-----------------------------------------------
1735#include "spmd.inc"
1736C-----------------------------------------------
1737C C o m m o n B l o c k s
1738C-----------------------------------------------
1739#include "com01_c.inc"
1740#include "task_c.inc"
1741C-----------------------------------------------
1742C D u m m y A r g u m e n t s
1743C-----------------------------------------------
1744 my_real
1745 . wf, wf2
1746C-----------------------------------------------
1747C L o c a l V a r i a b l e s
1748C-----------------------------------------------
1749#ifdef MPI
1750 INTEGER P, IERROR, MSGOFF,LOC_PROC,
1751 . msgtyp,status(mpi_status_size)
1752 my_real
1753 . wfb
1754 DATA msgoff/5017/
1755C-----------------------------------------------
1756C
1757 loc_proc = ispmd+1
1758
1759C summation over the processors of wf
1760 IF(loc_proc==1) THEN
1761 DO p = 2, nspmd
1762 msgtyp = msgoff
1763 CALL mpi_recv(
1764 s wfb,1,real,it_spmd(p),msgtyp,
1765 g spmd_comm_world,status,ierror)
1766 wf = wf+wfb
1767 END DO
1768 ELSE
1769 msgtyp = msgoff
1770 CALL mpi_send(
1771 s wf,1,real,it_spmd(1),msgtyp,
1772 g spmd_comm_world,ierror)
1773 END IF
1774
1775C summation over the processors of wf2
1776
1777 IF(loc_proc==1) THEN
1778 DO p = 2, nspmd
1779 msgtyp = msgoff
1780 CALL mpi_recv(
1781 s wfb,1,real,it_spmd(p),msgtyp,
1782 g spmd_comm_world,status,ierror)
1783 wf2 = wf2+wfb
1784 END DO
1785 ELSE
1786 msgtyp = msgoff
1787 CALL mpi_send(
1788 s wf2,1,real,it_spmd(1),msgtyp,
1789 g spmd_comm_world,ierror)
1790 END IF
1791
1792#endif
1793 RETURN
1794 END
1795C
1796!||====================================================================
1797!|| spmd_r2r_tagel ../engine/source/mpi/r2r/spmd_r2r.F
1798!||--- called by ------------------------------------------------------
1799!|| tagoff3n ../engine/source/interfaces/interf/chkstfn3.F
1800!||--- calls -----------------------------------------------------
1801!||--- uses -----------------------------------------------------
1802!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1803!||====================================================================
1804 SUBROUTINE spmd_r2r_tagel(TAGELG,TAGEL,LEN)
1805C-----------------------------------------------
1806C I m p l i c i t T y p e s
1807C-----------------------------------------------
1808 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1809#include "implicit_f.inc"
1810C-----C-----------------------------------------------------------------
1811C M e s s a g e P a s s i n g
1812C-----------------------------------------------
1813#include "spmd.inc"
1814C-----------------------------------------------
1815C C o m m o n B l o c k s
1816C-----------------------------------------------
1817#include "com01_c.inc"
1818#include "task_c.inc"
1819C-----------------------------------------------
1820C D u m m y A r g u m e n t s
1821C-----------------------------------------------
1822 INTEGER TAGELG(*),TAGEL(*),LEN(*)
1823C-----------------------------------------------
1824C L o c a l V a r i a b l e s
1825C-----------------------------------------------
1826#ifdef MPI
1827 INTEGER I, P, L, IERROR, MSGOFF, LOC_PROC, MSGTYP,
1828 . STATUS(MPI_STATUS_SIZE)
1829 DATA msgoff/5018/
1830C-----------------------------------------------
1831C
1832 loc_proc = ispmd+1
1833 l = 0
1834C
1835 IF(loc_proc==1) THEN
1836 DO i=1,len(loc_proc)
1837 tagelg(i)=tagel(i)
1838 l = l+1
1839 ENDDO
1840 DO p = 2, nspmd
1841 IF(len(p)>0)THEN
1842 msgtyp = msgoff
1843 CALL mpi_recv(
1844 s tagelg(l+1),len(p),mpi_integer,it_spmd(p),msgtyp,
1845 g spmd_comm_world,status,ierror)
1846 l = l + len(p)
1847 END IF
1848 END DO
1849 ELSEIF(len(loc_proc)>0)THEN
1850 msgtyp = msgoff
1851 CALL mpi_send(
1852 s tagel,len(loc_proc),mpi_integer,it_spmd(1),msgtyp,
1853 g spmd_comm_world,ierror)
1854 END IF
1855C
1856#endif
1857 RETURN
1858 END
1859C
1860!||====================================================================
1861!|| spmd_exch_r2r_itag ../engine/source/mpi/r2r/spmd_r2r.F
1862!||--- called by ------------------------------------------------------
1863!|| tagoff3n ../engine/source/interfaces/interf/chkstfn3.F
1864!||--- calls -----------------------------------------------------
1865!||--- uses -----------------------------------------------------
1866!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1867!||====================================================================
1868 SUBROUTINE spmd_exch_r2r_itag(
1869 1 ITAG,IAD_ELEM ,FR_ELEM,DD_R2R,DD_R2R_ELEM,LENR)
1870C--------------------------------------
1871C-----------------------------------------------
1872C I m p l i c i t T y p e s
1873C-----------------------------------------------
1874 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1875#include "implicit_f.inc"
1876C-----------------------------------------------------------------
1877C M e s s a g e P a s s i n g
1878C-----------------------------------------------
1879#include "spmd.inc"
1880C-----------------------------------------------
1881C C o m m o n B l o c k s
1882C-----------------------------------------------
1883#include "com01_c.inc"
1884#include "com04_c.inc"
1885#include "task_c.inc"
1886#include "tabsiz_c.inc"
1887C-----------------------------------------------
1888C D u m m y A r g u m e n t s
1889C-----------------------------------------------
1890 INTEGER IAD_ELEM(2,*),FR_ELEM(*),
1891 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),
1892 . ITAG(*),LENR
1893C-----------------------------------------------
1894C L o c a l V a r i a b l e s
1895C-----------------------------------------------
1896#ifdef MPI
1897 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
1898 . SIZ,J,L,NB_NOD,
1899 . STATUS(MPI_STATUS_SIZE),
1900 . iad_send(nspmd+1),iad_recv(nspmd+1),
1901 . req_r(nspmd),req_s(nspmd),offset,
1902 . sbuf(2*lenr),rbuf(2*lenr), msgoff
1903 DATA msgoff/5019/
1904C-----------------------------------------------
1905C S o u r c e L i n e s
1906C-----------------------------------------------
1907 loc_proc = ispmd + 1
1908 l = 1
1909 iad_recv(1) = 1
1910
1911 DO i=1,nspmd
1912 siz = 2*(dd_r2r(i+1,2)-dd_r2r(i,2))
1913 IF(siz/=0)THEN
1914 msgtyp = msgoff
1915 CALL mpi_irecv(
1916 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
1917 g spmd_comm_world,req_r(i),ierror)
1918 l = l + siz
1919 ENDIF
1920 iad_recv(i+1) = l
1921 END DO
1922C
1923 l = 1
1924 iad_send(1) = 1
1925C
1926 DO i=1,nspmd
1927#include "vectorize.inc"
1928 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
1929 nod = dd_r2r_elem(j)
1930 sbuf(l) = itag(nod)
1931 sbuf(l+1) = itag(numnod+nod)
1932 l = l + 2
1933 END DO
1934 iad_send(i+1) = l
1935 ENDDO
1936C
1937C echange messages
1938C
1939 DO i=1,nspmd
1940C--------------------------------------------------------------------
1941C envoi a N+I mod P
1942C test if msg requires to send to complete by test interface
1943 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1944 msgtyp = msgoff
1945 siz = iad_send(i+1)-iad_send(i)
1946 l = iad_send(i)
1947 CALL mpi_isend(
1948 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
1949 g spmd_comm_world,req_s(i),ierror)
1950 ENDIF
1951C--------------------------------------------------------------------
1952 ENDDO
1953C
1954C decompactage
1955C
1956 offset = dd_r2r(nspmd+1,1)-1
1957 DO i = 1, nspmd
1958C test if msg requires to send to complete by test interface
1959 nb_nod = dd_r2r(i+1,2)-dd_r2r(i,2)
1960 IF(nb_nod>0)THEN
1961 CALL mpi_wait(req_r(i),status,ierror)
1962 l = iad_recv(i)
1963#include "vectorize.inc"
1964 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
1965 nod = dd_r2r_elem(offset+j)
1966 itag(nod) = rbuf(l)
1967 itag(numnod+nod) = rbuf(l+1)
1968 l = l + 2
1969 END DO
1970C ---
1971 ENDIF
1972C
1973 END DO
1974C
1975C wait terminaison isend
1976C
1977 DO i = 1, nspmd
1978 IF(dd_r2r(i+1,1)-dd_r2r(i,1)>0)THEN
1979 CALL mpi_wait(req_s(i),status,ierror)
1980 ENDIF
1981 ENDDO
1982C
1983
1984#endif
1985 RETURN
1986 END
1987C
1988!||====================================================================
1989!|| spmd_exch_r2r_sph ../engine/source/mpi/r2r/spmd_r2r.F
1990!||--- called by ------------------------------------------------------
1991!|| resol ../engine/source/engine/resol.F
1992!||--- calls -----------------------------------------------------
1993!||--- uses -----------------------------------------------------
1994!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1995!||====================================================================
1996 SUBROUTINE spmd_exch_r2r_sph(A,IAD_ELEM,FR_ELEM,DD_R2R,DD_R2R_ELEM,LENR)
1997C-----------------------------------------------
1998C I m p l i c i t T y p e s
1999C-----------------------------------------------
2000 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2001#include "implicit_f.inc"
2002C-----------------------------------------------------------------
2003C M e s s a g e P a s s i n g
2004C-----------------------------------------------
2005#include "spmd.inc"
2006C-----------------------------------------------
2007C C o m m o n B l o c k s
2008C-----------------------------------------------
2009#include "com01_c.inc"
2010#include "task_c.inc"
2011#include "tabsiz_c.inc"
2012C-----------------------------------------------
2013C D u m m y A r g u m e n t s
2014C-----------------------------------------------
2015 INTEGER IAD_ELEM(2,*),FR_ELEM(*),
2016 . DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),LENR
2017 my_real
2018 . A(3,*)
2019C-----------------------------------------------
2020C L o c a l V a r i a b l e s
2021C-----------------------------------------------
2022#ifdef MPI
2023 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
2024 . SIZ,J,L,NB_NOD,
2025 . STATUS(MPI_STATUS_SIZE),
2026 . iad_send(nspmd+1),iad_recv(nspmd+1),
2027 . req_r(nspmd),req_s(nspmd),offset
2028 my_real
2029 . rbuf(3*lenr ),sbuf(3*lenr )
2030C-----------------------------------------------
2031C S o u r c e L i n e s
2032C-----------------------------------------------
2033 loc_proc = ispmd + 1
2034 l = 1
2035 iad_recv(1) = 1
2036 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2037
2038 DO i=1,nspmd
2039 siz = 3*(dd_r2r(i+1,1)-dd_r2r(i,1))
2040 IF(siz/=0)THEN
2041 msgtyp = 10000 + nspmd*(i-1) + loc_proc
2042 CALL mpi_irecv(
2043 s rbuf(l),siz,real,it_spmd(i),msgtyp,
2044 g spmd_comm_world,req_r(i),ierror)
2045 l = l + siz
2046 ENDIF
2047 iad_recv(i+1) = l
2048 END DO
2049 l = 1
2050 iad_send(1) = 1
2051C
2052 offset = dd_r2r(nspmd+1,1)-1
2053 DO i=1,nspmd
2054C preparation envoi partie fixe (elem) a proc I
2055#include "vectorize.inc"
2056 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
2057 nod = dd_r2r_elem(offset+j)
2058 sbuf(l ) = a(1,nod)
2059 sbuf(l+1) = a(2,nod)
2060 sbuf(l+2) = a(3,nod)
2061 l = l + 3
2062 END DO
2063C
2064 iad_send(i+1) = l
2065 ENDDO
2066C
2067C echange messages
2068C
2069 DO i=1,nspmd
2070C--------------------------------------------------------------------
2071C envoi a N+I mod P
2072 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2073 msgtyp = 10000 + nspmd*(loc_proc-1) + i
2074 siz = iad_send(i+1)-iad_send(i)
2075 l = iad_send(i)
2076 CALL mpi_isend(
2077 s sbuf(l),siz,real,it_spmd(i),msgtyp,
2078 g spmd_comm_world,req_s(i),ierror)
2079 ENDIF
2080C--------------------------------------------------------------------
2081 ENDDO
2082C
2083C decompactage
2084C
2085 DO i = 1, nspmd
2086 nb_nod = dd_r2r(i+1,1)-dd_r2r(i,1)
2087 IF(nb_nod>0)THEN
2088 CALL mpi_wait(req_r(i),status,ierror)
2089 l = iad_recv(i)
2090#include "vectorize.inc"
2091 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
2092 nod = dd_r2r_elem(j)
2093 a(1,nod) = rbuf(l)
2094 a(2,nod) = rbuf(l+1)
2095 a(3,nod) = rbuf(l+2)
2096 l = l + 3
2097 END DO
2098C ---
2099 ENDIF
2100C
2101 END DO
2102C
2103C wait terminaison isend
2104C
2105 DO i = 1, nspmd
2106 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2107 CALL mpi_wait(req_s(i),status,ierror)
2108 ENDIF
2109 ENDDO
2110C
2111
2112#endif
2113 RETURN
2114 END
2115!||====================================================================
2116!|| spmd_exch_r2r_sphoff ../engine/source/mpi/r2r/spmd_r2r.F
2117!||--- called by ------------------------------------------------------
2118!|| resol ../engine/source/engine/resol.F
2119!||--- calls -----------------------------------------------------
2120!||--- uses -----------------------------------------------------
2121!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2122!||====================================================================
2123 SUBROUTINE spmd_exch_r2r_sphoff(OFF_SPH_R2R,IAD_ELEM,
2124 1 FR_ELEM,DD_R2R,DD_R2R_ELEM,LENR)
2125C-----------------------------------------------
2126C I m p l i c i t T y p e s
2127C-----------------------------------------------
2128 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2129#include "implicit_f.inc"
2130C-----------------------------------------------------------------
2131C M e s s a g e P a s s i n g
2132C-----------------------------------------------
2133#include "spmd.inc"
2134C-----------------------------------------------
2135C C o m m o n B l o c k s
2136C-----------------------------------------------
2137#include "com01_c.inc"
2138#include "task_c.inc"
2139#include "tabsiz_c.inc"
2140C-----------------------------------------------
2141C D u m m y A r g u m e n t s
2142C-----------------------------------------------
2143 INTEGER OFF_SPH_R2R(*),IAD_ELEM(2,*),
2144 . FR_ELEM(*),DD_R2R(NSPMD+1,SDD_R2R),DD_R2R_ELEM(*),LENR
2145C-----------------------------------------------
2146C L o c a l V a r i a b l e s
2147C-----------------------------------------------
2148#ifdef MPI
2149 INTEGER MSGTYP,I,NOD,LOC_PROC,IERROR,
2150 . siz,j,l,nb_nod,
2151 . status(mpi_status_size),
2152 . iad_send(nspmd+1),iad_recv(nspmd+1),
2153 . req_r(nspmd),req_s(nspmd),offset,
2154 . rbuf(lenr ),sbuf(lenr )
2155C-----------------------------------------------
2156C S o u r c e L i n e s
2157C-----------------------------------------------
2158 loc_proc = ispmd + 1
2159 l = 1
2160 iad_recv(1) = 1
2161
2162 DO i=1,nspmd
2163 siz = dd_r2r(i+1,1)-dd_r2r(i,1)
2164 IF(siz/=0)THEN
2165 msgtyp = 10000 + nspmd*(i-1) + loc_proc
2166 CALL mpi_irecv(
2167 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2168 g spmd_comm_world,req_r(i),ierror)
2169 l = l + siz
2170 ENDIF
2171 iad_recv(i+1) = l
2172 END DO
2173 l = 1
2174 iad_send(1) = 1
2175C
2176 offset = dd_r2r(nspmd+1,1)-1
2177 DO i=1,nspmd
2178C preparation envoi partie fixe (elem) a proc I
2179#include "vectorize.inc"
2180 DO j=dd_r2r(i,2),dd_r2r(i+1,2)-1
2181 nod = dd_r2r_elem(offset+j)
2182 sbuf(l) = off_sph_r2r(nod)
2183 l = l + 1
2184 END DO
2185C
2186 iad_send(i+1) = l
2187 ENDDO
2188C
2189C echange messages
2190C
2191 DO i=1,nspmd
2192C--------------------------------------------------------------------
2193C envoi a N+I mod P
2194 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2195 msgtyp = 10000 + nspmd*(loc_proc-1) + i
2196 siz = iad_send(i+1)-iad_send(i)
2197 l = iad_send(i)
2198 CALL mpi_isend(
2199 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2200 g spmd_comm_world,req_s(i),ierror)
2201 ENDIF
2202C--------------------------------------------------------------------
2203 ENDDO
2204C
2205C decompactage
2206C
2207 DO i = 1, nspmd
2208 nb_nod = dd_r2r(i+1,1)-dd_r2r(i,1)
2209 IF(nb_nod>0)THEN
2210 CALL mpi_wait(req_r(i),status,ierror)
2211 l = iad_recv(i)
2212#include "vectorize.inc"
2213 DO j=dd_r2r(i,1),dd_r2r(i+1,1)-1
2214 nod = dd_r2r_elem(j)
2215 off_sph_r2r(nod) = rbuf(l)
2216 l = l + 1
2217 END DO
2218C ---
2219 ENDIF
2220C
2221 END DO
2222C
2223C wait terminaison isend
2224C
2225 DO i = 1, nspmd
2226 IF(dd_r2r(i+1,2)-dd_r2r(i,2)>0)THEN
2227 CALL mpi_wait(req_s(i),status,ierror)
2228 ENDIF
2229 ENDDO
2230C
2231
2232#endif
2233 RETURN
2234 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_data_spmd
subroutine send_data_spmd(idp, nng, grnod, a, ar, stx, str, v, vr, ms, in, dx, dd_r2r, nglob, weight, typ, flag_rot, flag_rby, rby, iex)
Definition r2r_exchange.F:295
r2r_exchange
subroutine r2r_exchange(iexlnk, igrnod, dx, v, vr, a, ar, ms, in, stx, str, r2r_on, dd_r2r, weight, iad_elem, fr_elem, rby, xdp, x, dd_r2r_elem, sdd_r2r_elem, off_sph_r2r, numsph_glo_r2r, nloc_dmg)
Definition r2r_exchange.F:52
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:1174
spmd_r2r_rset4
subroutine spmd_r2r_rset4(m, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf)
Definition spmd_r2r.F:854
spmd_exch_work
subroutine spmd_exch_work(wf, wf2)
Definition spmd_r2r.F:1723
spmd_exch_r2r_itag
subroutine spmd_exch_r2r_itag(itag, iad_elem, fr_elem, dd_r2r, dd_r2r_elem, lenr)
Definition spmd_r2r.F:1870
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:2125
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:1034
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:1805
spmd_r2r_rset3
subroutine spmd_r2r_rset3(a, nng, grnod, dd_r2r, weight, bufr, iad_elem, fr_elem, lrbuf, iex)
Definition spmd_r2r.F:938
spmd_exch_r2r_sph
subroutine spmd_exch_r2r_sph(a, iad_elem, fr_elem, dd_r2r, dd_r2r_elem, lenr)
Definition spmd_r2r.F:1997
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:1355
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:1564
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