OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_lag.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#if defined(MPI)
24!||====================================================================
25!|| spmd_get_mult ../engine/source/mpi/lag_multipliers/spmd_lag.f
26!||--- called by ------------------------------------------------------
27!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
28!||--- uses -----------------------------------------------------
29!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.f90
30!||====================================================================
31 SUBROUTINE spmd_get_mult(
32 1 LAGCOMC,LAGCOMK,N_MULT ,BLL ,IADLL,
33 2 LLL ,JLL ,SLL ,XLL ,COMNTAG,
34 3 ICFTAG ,JCFTAG ,FR_LAGF,N_IK)
35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38 USE spmd_comm_world_mod, ONLY : spmd_comm_world
39#include "implicit_f.inc"
40#include "spmd.inc"
41C-----------------------------------------------
42C C o m m o n B l o c k s
43C-----------------------------------------------
44#include "task_c.inc"
45#include "com01_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER N_MULT, N_IK,
50 . LLL(*), JLL(*), SLL(*), IADLL(*),
51 . COMNTAG(*), ICFTAG(*), JCFTAG(*), FR_LAGF(3,*)
52 my_real
53 . lagcomk(4,*),lagcomc(2,*), xll(*), bll(*)
54C-----------------------------------------------
55C L O C A L V A R I A B L E S
56C-----------------------------------------------
57 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,MSGOFF,MSGOFF2
58 INTEGER MSGTYP,I,NCL,IKL,N, LOC_PROC
59
60 DATA msgoff/12001/
61 DATA msgoff2/12002/
62
63 loc_proc = ispmd+1
64
65 IF (ispmd/=0) THEN
66 IF(fr_lagf(1,loc_proc)>0) THEN
67
68 msgtyp = msgoff
69 CALL mpi_send(
70 1 lagcomc ,2*n_mult,real ,it_spmd(1),msgtyp,
71 2 spmd_comm_world,ierror)
72 msgtyp = msgoff2
73 CALL mpi_send(
74 1 lagcomk ,4*n_ik,real ,it_spmd(1),msgtyp,
75 2 spmd_comm_world,ierror)
76 END IF
77 ELSE
78 DO n = 1, n_mult
79 iadll(n+1) = iadll(n)+nint(lagcomc(1,n))
80 bll(n) = lagcomc(2,n)
81C ICTAG et JCFTAG : id (pas de cond. autre que fixe pour le moment !)
82 icftag(n) = n
83 jcftag(n) = n
84 END DO
85 DO n = 1, n_ik
86 lll(n) = nint(lagcomk(1,n))
87 jll(n) = nint(lagcomk(2,n))
88 sll(n) = nint(lagcomk(3,n))
89 xll(n) = lagcomk(4,n)
90C mise a jour du flag directement ici et non dans LTAG_FXV
91 comntag(lll(n)) = comntag(lll(n))+1
92 END DO
93C
94 DO i=2,nspmd
95 ncl = fr_lagf(1,i)
96 IF(ncl>0)THEN
97 msgtyp = msgoff
98
99 CALL mpi_recv(
100 1 lagcomc(1,n_mult+1),2*ncl ,real ,it_spmd(i),msgtyp,
101 2 spmd_comm_world ,status,ierror)
102
103 DO n = 1, ncl
104 iadll(n_mult+n+1) = iadll(n_mult+n)
105 + +nint(lagcomc(1,n_mult+n))
106 bll(n_mult+n) = lagcomc(2,n_mult+n)
107C ICTAG et JCFTAG : id (pas de cond. autre que fixe pour le moment !)
108 icftag(n_mult+n) = n_mult+n
109 jcftag(n_mult+n) = n_mult+n
110 END DO
111 n_mult=n_mult+ncl
112C
113 msgtyp = msgoff2
114 ikl = fr_lagf(2,i)
115 CALL mpi_recv(
116 1 lagcomk(1,n_ik+1),4*ikl ,real ,it_spmd(i),msgtyp,
117 2 spmd_comm_world ,status,ierror)
118 DO n = 1, ikl
119 lll(n_ik+n) = nint(lagcomk(1,n_ik+n))
120 jll(n_ik+n) = nint(lagcomk(2,n_ik+n))
121 sll(n_ik+n) = nint(lagcomk(3,n_ik+n))
122 xll(n_ik+n) = lagcomk(4,n_ik+n)
123C mise a jour du flag directement ici et non dans LTAG_FXV
124 comntag(lll(n_ik+n)) = comntag(lll(n_ik+n))+1
125 END DO
126 n_ik = n_ik + ikl
127 END IF
128 END DO
129c IF(N_MULT/=FR_LAGF(1,NSPMD+1))
130c . print*,'**error : wrong gather of LAG MULT EQUATIONS',
131c . N_MULT,FR_LAGF(1,NSPMD+1)
132c IF(N_IK/=FR_LAGF(2,NSPMD+1))
133c . print*,'**error : wrong gather of LAG MULT VARIABLES',
134c . N_IK,FR_LAGF(2,NSPMD+1)
135C
136
137 END IF
138C
139 RETURN
140 END
141C
142!||====================================================================
143!|| spmd_gg_mult ../engine/source/mpi/lag_multipliers/spmd_lag.F
144!||--- called by ------------------------------------------------------
145!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
146!||--- uses -----------------------------------------------------
147!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
148!||====================================================================
149 SUBROUTINE spmd_gg_mult(
150 1 A ,AR ,V ,VR ,MS ,
151 2 IN ,AG ,ARG ,VG ,VRG ,
152 3 MSG ,ING ,FR_LAGF,ISIZ ,NBNODL,
153 4 INDEXLAG,NODGLOB ,LLAGF ,NLAGF_L)
154C-----------------------------------------------
155C I m p l i c i t T y p e s
156C-----------------------------------------------
157 USE spmd_comm_world_mod, ONLY : spmd_comm_world
158#include "implicit_f.inc"
159#include "spmd.inc"
160C-----------------------------------------------
161C C o m m o n B l o c k s
162C-----------------------------------------------
163#include "task_c.inc"
164#include "com01_c.inc"
165C-----------------------------------------------
166C D u m m y A r g u m e n t s
167C-----------------------------------------------
168 INTEGER FR_LAGF(3,*), INDEXLAG(*), NODGLOB(*), LLAGF(*),
169 . NBNODL, NLAGF_L, ISIZ
170 my_real
171 . A(3,*), AR(3,*), V(3,*), VR(3,*), MS(*), IN(*),
172 . AG(3,*), ARG(3,*), VG(3,*), VRG(3,*), MSG(*), ING(*)
173C-----------------------------------------------
174C L O C A L V A R I A B L E S
175C-----------------------------------------------
176 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,MSGOFF
177 INTEGER MSGTYP,I,NNOD,N,NLAGF_G,P
178 my_real
179 . BUFCOM(ISIZ,NBNODL)
180
181 DATA MSGOFF/12003/
182C
183C
184C
185 IF (ispmd/=0) THEN
186 IF(nlagf_l>0) THEN
187 IF(iroddl/=0)THEN
188 DO i = 1, nlagf_l
189 n = llagf(i)
190 bufcom(1,i) = nodglob(n)
191 bufcom(2,i) = a(1,n)
192 bufcom(3,i) = a(2,n)
193 bufcom(4,i) = a(3,n)
194 bufcom(5,i) = ms(n)
195 bufcom(6,i) = v(1,n)
196 bufcom(7,i) = v(2,n)
197 bufcom(8,i) = v(3,n)
198 bufcom(9,i) = ar(1,n)
199 bufcom(10,i) = ar(2,n)
200 bufcom(11,i) = ar(3,n)
201 bufcom(12,i) = in(n)
202 bufcom(13,i) = vr(1,n)
203 bufcom(14,i) = vr(2,n)
204 bufcom(15,i) = vr(3,n)
205 END DO
206 ELSE
207 DO i = 1, nlagf_l
208 n = llagf(i)
209 bufcom(1,i) = nodglob(n)
210 bufcom(2,i) = a(1,n)
211 bufcom(3,i) = a(2,n)
212 bufcom(4,i) = a(3,n)
213 bufcom(5,i) = ms(n)
214 bufcom(6,i) = v(1,n)
215 bufcom(7,i) = v(2,n)
216 bufcom(8,i) = v(3,n)
217 END DO
218 END IF
219 msgtyp = msgoff
220 CALL mpi_send(
221 1 bufcom ,isiz*nlagf_l,real ,it_spmd(1),msgtyp,
222 2 spmd_comm_world,ierror)
223 END IF
224Code processeur0
225 ELSE
226 IF(iroddl/=0)THEN
227 DO i = 1, nlagf_l
228 n = llagf(i)
229 indexlag(nodglob(n)) = i
230 ag(1,i) = a(1,n)
231 ag(2,i) = a(2,n)
232 ag(3,i) = a(3,n)
233 msg(i) = ms(n)
234 vg(1,i) = v(1,n)
235 vg(2,i) = v(2,n)
236 vg(3,i) = v(3,n)
237 arg(1,i)= ar(1,n)
238 arg(2,i)= ar(2,n)
239 arg(3,i)= ar(3,n)
240 ing(i) = in(n)
241 vrg(1,i)= vr(1,n)
242 vrg(2,i)= vr(2,n)
243 vrg(3,i)= vr(3,n)
244 END DO
245 ELSE
246 DO i = 1, nlagf_l
247 n = llagf(i)
248 indexlag(nodglob(n)) = i
249 ag(1,i) = a(1,n)
250 ag(2,i) = a(2,n)
251 ag(3,i) = a(3,n)
252 msg(i) = ms(n)
253 vg(1,i) = v(1,n)
254 vg(2,i) = v(2,n)
255 vg(3,i) = v(3,n)
256 END DO
257 END IF
258 nlagf_g = nlagf_l
259C
260 DO p=2,nspmd
261 nnod = fr_lagf(3,p)
262 IF(nnod>0)THEN
263 msgtyp = msgoff
264 CALL mpi_recv(
265 1 bufcom,isiz*nnod ,real ,it_spmd(p),msgtyp,
266 2 spmd_comm_world ,status,ierror)
267 IF(iroddl/=0)THEN
268 DO i = 1, nnod
269 n = nint(bufcom(1,i))
270 indexlag(n) = nlagf_g+i
271 ag(1,nlagf_g+i) = bufcom(2,i)
272 ag(2,nlagf_g+i) = bufcom(3,i)
273 ag(3,nlagf_g+i) = bufcom(4,i)
274 msg(nlagf_g+i) = bufcom(5,i)
275 vg(1,nlagf_g+i) = bufcom(6,i)
276 vg(2,nlagf_g+i) = bufcom(7,i)
277 vg(3,nlagf_g+i) = bufcom(8,i)
278 arg(1,nlagf_g+i)= bufcom(9,i)
279 arg(2,nlagf_g+i)= bufcom(10,i)
280 arg(3,nlagf_g+i)= bufcom(11,i)
281 ing(nlagf_g+i) = bufcom(12,i)
282 vrg(1,nlagf_g+i)= bufcom(13,i)
283 vrg(2,nlagf_g+i)= bufcom(14,i)
284 vrg(3,nlagf_g+i)= bufcom(15,i)
285 END DO
286 ELSE
287 DO i = 1, nnod
288 n = nint(bufcom(1,i))
289 indexlag(n) = nlagf_g+i
290 ag(1,nlagf_g+i) = bufcom(2,i)
291 ag(2,nlagf_g+i) = bufcom(3,i)
292 ag(3,nlagf_g+i) = bufcom(4,i)
293 msg(nlagf_g+i) = bufcom(5,i)
294 vg(1,nlagf_g+i) = bufcom(6,i)
295 vg(2,nlagf_g+i) = bufcom(7,i)
296 vg(3,nlagf_g+i) = bufcom(8,i)
297 END DO
298 END IF
299 nlagf_g=nlagf_g+nnod
300 END IF
301 END DO
302c IF(NLAGF_G/=FR_LAGF(3,NSPMD+1))
303c . print*,'**error : wrong gather of LAG MULT NODAL VALUES',
304c . NLAGF_G,FR_LAGF(3,NSPMD+1)
305C
306
307 END IF
308C
309 RETURN
310 END
311C
312!||====================================================================
313!|| spmd_sg_mult ../engine/source/mpi/lag_multipliers/spmd_lag.F
314!||--- called by ------------------------------------------------------
315!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
316!||--- uses -----------------------------------------------------
317!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
318!||====================================================================
319 SUBROUTINE spmd_sg_mult(
320 1 A ,AR ,AG ,ARG ,FR_LAGF,
321 2 ISIZ ,NBNODL ,LLAGF ,NLAGF_L )
322C-----------------------------------------------
323C I m p l i c i t T y p e s
324C-----------------------------------------------
325 USE spmd_comm_world_mod, ONLY : spmd_comm_world
326#include "implicit_f.inc"
327#include "spmd.inc"
328C-----------------------------------------------
329C C o m m o n B l o c k s
330C-----------------------------------------------
331#include "task_c.inc"
332#include "com01_c.inc"
333C-----------------------------------------------
334C D u m m y A r g u m e n t s
335C-----------------------------------------------
336 INTEGER FR_LAGF(3,*), LLAGF(*),
337 . NBNODL, NLAGF_L, ISIZ
338 my_real
339 . A(3,*), AR(3,*),AG(3,*), ARG(3,*)
340C-----------------------------------------------
341C L O C A L V A R I A B L E S
342C-----------------------------------------------
343 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,MSGOFF
344 INTEGER MSGTYP,I,NNOD,N,NLAGF_G,P
345 my_real
346 . bufcom(isiz,nbnodl)
347
348 DATA msgoff/12004/
349C
350C
351C
352 IF(ispmd/=0) THEN
353 IF(nlagf_l>0) THEN
354
355 msgtyp = msgoff
356 CALL mpi_recv(
357 1 bufcom,isiz*nlagf_l,real ,it_spmd(1),msgtyp,
358 2 spmd_comm_world ,status,ierror)
359 IF(iroddl/=0)THEN
360 DO i = 1, nlagf_l
361 n = llagf(i)
362 a(1,n) = bufcom(1,i)
363 a(2,n) = bufcom(2,i)
364 a(3,n) = bufcom(3,i)
365 ar(1,n) = bufcom(4,i)
366 ar(2,n) = bufcom(5,i)
367 ar(3,n) = bufcom(6,i)
368 END DO
369 ELSE
370 DO i = 1, nlagf_l
371 n = llagf(i)
372 a(1,n) = bufcom(1,i)
373 a(2,n) = bufcom(2,i)
374 a(3,n) = bufcom(3,i)
375 END DO
376 END IF
377 END IF
378Code processeur0
379 ELSE
380 IF(iroddl/=0)THEN
381 DO i = 1, nlagf_l
382 n = llagf(i)
383 a(1,n) = ag(1,i)
384 a(2,n) = ag(2,i)
385 a(3,n) = ag(3,i)
386 ar(1,n) = arg(1,i)
387 ar(2,n) = arg(2,i)
388 ar(3,n) = arg(3,i)
389 END DO
390 ELSE
391 DO i = 1, nlagf_l
392 n = llagf(i)
393 a(1,n) = ag(1,i)
394 a(2,n) = ag(2,i)
395 a(3,n) = ag(3,i)
396 END DO
397 END IF
398 nlagf_g = nlagf_l
399C
400 DO p=2,nspmd
401 nnod = fr_lagf(3,p)
402 IF(nnod>0)THEN
403 IF(iroddl/=0)THEN
404 DO i = 1, nnod
405 bufcom(1,i) = ag(1,nlagf_g+i)
406 bufcom(2,i) = ag(2,nlagf_g+i)
407 bufcom(3,i) = ag(3,nlagf_g+i)
408 bufcom(4,i) = arg(1,nlagf_g+i)
409 bufcom(5,i) = arg(2,nlagf_g+i)
410 bufcom(6,i) = arg(3,nlagf_g+i)
411 END DO
412 ELSE
413 DO i = 1, nnod
414 bufcom(1,i) = ag(1,nlagf_g+i)
415 bufcom(2,i) = ag(2,nlagf_g+i)
416 bufcom(3,i) = ag(3,nlagf_g+i)
417 END DO
418 END IF
419 msgtyp = msgoff
420 CALL mpi_send(
421 1 bufcom ,isiz*nnod,real ,it_spmd(p),msgtyp,
422 2 spmd_comm_world,ierror)
423 nlagf_g=nlagf_g+nnod
424 END IF
425 END DO
426
427 END IF
428C
429 RETURN
430 END
431C
432!||====================================================================
433!|| spmd_sg_fani ../engine/source/mpi/lag_multipliers/spmd_lag.F
434!||--- called by ------------------------------------------------------
435!|| lag_anithp ../engine/source/tools/lagmul/lag_anith.F
436!||--- uses -----------------------------------------------------
437!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
438!||====================================================================
439 SUBROUTINE spmd_sg_fani(
440 1 FANI,FANIG,FR_LAGF,NBNODL,LLAGF,NLAGF_L)
441C-----------------------------------------------
442C I m p l i c i t T y p e s
443C-----------------------------------------------
444 USE spmd_comm_world_mod, ONLY : spmd_comm_world
445#include "implicit_f.inc"
446#include "spmd.inc"
447C-----------------------------------------------
448C C o m m o n B l o c k s
449C-----------------------------------------------
450#include "task_c.inc"
451#include "com01_c.inc"
452C-----------------------------------------------
453C D u m m y A r g u m e n t s
454C-----------------------------------------------
455 INTEGER FR_LAGF(3,*), LLAGF(*),
456 . NBNODL, NLAGF_L
457 my_real
458 . FANI(3,*), FANIG(3,*)
459C-----------------------------------------------
460C L O C A L V A R I A B L E S
461C-----------------------------------------------
462 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,MSGOFF
463 INTEGER MSGTYP,I,NNOD,N,NLAGF_G,P
464 my_real
465 . bufcom(3,nbnodl)
466
467 DATA msgoff/12005/
468C
469C
470C
471 IF(ispmd/=0) THEN
472 IF(nlagf_l>0) THEN
473
474 msgtyp = msgoff
475 CALL mpi_recv(
476 1 bufcom,3*nlagf_l,real ,it_spmd(1),msgtyp,
477 2 spmd_comm_world ,status,ierror)
478 DO i = 1, nlagf_l
479 n = llagf(i)
480 fani(1,n) = bufcom(1,i)
481 fani(2,n) = bufcom(2,i)
482 fani(3,n) = bufcom(3,i)
483 END DO
484 END IF
485Code processeur0
486 ELSE
487 DO i = 1, nlagf_l
488 n = llagf(i)
489 fani(1,n) = fanig(1,i)
490 fani(2,n) = fanig(2,i)
491 fani(3,n) = fanig(3,i)
492 END DO
493 nlagf_g = nlagf_l
494C
495 DO p=2,nspmd
496 nnod = fr_lagf(3,p)
497 IF(nnod>0)THEN
498 DO i = 1, nnod
499 bufcom(1,i) = fanig(1,nlagf_g+i)
500 bufcom(2,i) = fanig(2,nlagf_g+i)
501 bufcom(3,i) = fanig(3,nlagf_g+i)
502 END DO
503 msgtyp = msgoff
504 CALL mpi_send(
505 1 bufcom ,3*nnod,real ,it_spmd(p),msgtyp,
506 2 spmd_comm_world,ierror)
507 nlagf_g=nlagf_g+nnod
508 END IF
509 END DO
510
511 END IF
512C
513 RETURN
514 END
515C
516!||====================================================================
517!|| spmd_exch_mult ../engine/source/mpi/lag_multipliers/spmd_lag.f
518!||--- called by ------------------------------------------------------
519!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
520!||--- uses -----------------------------------------------------
521!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
522!||====================================================================
523 SUBROUTINE spmd_exch_mult(
524 1 A ,AR ,LLAGF , NLAGF_L, FR_LAGF,
525 2 IAD_ELEM,FR_ELEM,LRBUF , ISIZ )
526C-----------------------------------------------
527C I m p l i c i t T y p e s
528C-----------------------------------------------
529 USE spmd_comm_world_mod, ONLY : spmd_comm_world
530#include "implicit_f.inc"
531C-----C-----------------------------------------------------------------
532C M e s s a g e P a s s i n g
533C-----------------------------------------------
534#include "spmd.inc"
535C-----------------------------------------------
536C C o m m o n B l o c k s
537C-----------------------------------------------
538#include "com01_c.inc"
539#include "com04_c.inc"
540#include "task_c.inc"
541C-----------------------------------------------
542C D u m m y A r g u m e n t s
543C-----------------------------------------------
544 INTEGER NLAGF_L,LRBUF,ISIZ,
545 . FR_LAGF(3,*),LLAGF(*),IAD_ELEM(2,*),FR_ELEM(*)
546 my_real
547 . A(3,*), AR(3,*)
548C-----------------------------------------------
549C L o c a l V a r i a b l e s
550C-----------------------------------------------
551 INTEGER I, J, P, N, L, IERROR, MSGOFF, MSGOFF2, ISHIFT,
552 . LOC_PROC, MSGTYP, BUFSIZ, SIZ, INB, NB_NOD, NOD, LSEND,
553 . REQ_R(NSPMD), REQ_S(NSPMD),IAD_SEND(NSPMD+1),
554 . IAD_RECV(NSPMD+1), STATUS(MPI_STATUS_SIZE), ITAG(NUMNOD)
555 my_real
556 . rbuf(lrbuf)
557 DATA msgoff/12006/
558 DATA msgoff2/12007/
559C-----------------------------------------------
560C
561 loc_proc = ispmd+1
562C
563 DO i = 1, numnod
564 itag(i) = 0
565 END DO
566 l = 0
567 DO i = 1, nlagf_l
568 n=llagf(i)
569 itag(n) = 1
570 END DO
571C
572C Echange aux frontieres
573C
574 l = 1
575 iad_recv(1) = 1
576 DO i=1,nspmd
577 IF(iad_elem(1,i+1)-iad_elem(1,i)/=0)THEN
578 siz = isiz*(iad_elem(1,i+1)-iad_elem(1,i))+1
579 msgtyp = msgoff2
580 CALL mpi_irecv(
581 s rbuf(l),siz,real,it_spmd(i),msgtyp,
582 g spmd_comm_world,req_r(i),ierror)
583 l = l + siz
584 ENDIF
585 iad_recv(i+1) = l
586 END DO
587C
588 iad_send(1) = l
589 DO i=1,nspmd
590 IF(iad_elem(1,i+1)-iad_elem(1,i)/=0)THEN
591 inb = l
592 l = l + 1
593 nb_nod = 0
594 ishift = iad_elem(1,i)-1
595 IF(iroddl==0)THEN
596#include "vectorize.inc"
597 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
598 nod = fr_elem(j)
599 IF(itag(nod)==1)THEN
600 rbuf(l) = j-ishift
601C J-ISHIFT donne l'adresse relative du noeud
602 rbuf(l+1) = a(1,nod)
603 rbuf(l+2) = a(2,nod)
604 rbuf(l+3) = a(3,nod)
605 l = l + isiz
606 nb_nod = nb_nod + 1
607 ENDIF
608 END DO
609 ELSE
610#include "vectorize.inc"
611 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
612 nod = fr_elem(j)
613 IF(itag(nod)==1)THEN
614 rbuf(l) = j-ishift
615C J-ISHIFT donne l'adresse relative du noeud
616 rbuf(l+1) = a(1,nod)
617 rbuf(l+2) = a(2,nod)
618 rbuf(l+3) = a(3,nod)
619 rbuf(l+4) = ar(1,nod)
620 rbuf(l+5) = ar(2,nod)
621 rbuf(l+6) = ar(3,nod)
622 l = l + isiz
623 nb_nod = nb_nod + 1
624 ENDIF
625 END DO
626 END IF
627 rbuf(inb) = nb_nod
628 ENDIF
629 iad_send(i+1) = l
630 ENDDO
631C
632C echange messages
633C
634 DO i=1,nspmd
635 IF(iad_elem(1,i+1)-iad_elem(1,i)/=0)THEN
636 msgtyp = msgoff2
637 l = iad_send(i+1)-iad_send(i)
638 lsend = iad_send(i)
639 CALL mpi_isend(
640 s rbuf(lsend),l,real,it_spmd(i),msgtyp,
641 g spmd_comm_world,req_s(i),ierror)
642 ENDIF
643 ENDDO
644C
645C decompactage
646C
647 DO i = 1, nspmd
648 IF(iad_elem(1,i+1)-iad_elem(1,i)/=0)THEN
649 CALL mpi_wait(req_r(i),status,ierror)
650 l = iad_recv(i)
651 nb_nod = nint(rbuf(l))
652 l = l + 1
653 IF (nb_nod/=0) THEN
654 ishift = iad_elem(1,i)-1
655 IF(iroddl==0)THEN
656#include "vectorize.inc"
657 DO j=1,nb_nod
658 nod = fr_elem(nint(rbuf(l))+ishift)
659C on recupere le bon noeud en fct de sa position relative dans fr_elem, liste triee
660 a(1,nod) = rbuf(l+1)
661 a(2,nod) = rbuf(l+2)
662 a(3,nod) = rbuf(l+3)
663 l = l + isiz
664 END DO
665 ELSE
666#include "vectorize.inc"
667 DO j=1,nb_nod
668 nod = fr_elem(nint(rbuf(l))+ishift)
669C on recupere le bon noeud en fct de sa position relative dans fr_elem, liste triee
670 a(1,nod) = rbuf(l+1)
671 a(2,nod) = rbuf(l+2)
672 a(3,nod) = rbuf(l+3)
673 ar(1,nod)= rbuf(l+4)
674 ar(2,nod)= rbuf(l+5)
675 ar(3,nod)= rbuf(l+6)
676 l = l + isiz
677 END DO
678 END IF
679 ENDIF
680 ENDIF
681 ENDDO
682C wait terminaison isend
683 DO i = 1, nspmd
684 IF(iad_elem(1,i+1)-iad_elem(1,i)/=0)
685 . CALL mpi_wait(req_s(i),status,ierror)
686 ENDDO
687C
688 RETURN
689 END
690C
691#elif 1
692
693
694!||====================================================================
695!|| spmd_sg_fani ../engine/source/mpi/lag_multipliers/spmd_lag.F
696!||--- called by ------------------------------------------------------
697!|| lag_anithp ../engine/source/tools/lagmul/lag_anith.F
698!||--- uses -----------------------------------------------------
699!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
700!||====================================================================
701 SUBROUTINE spmd_sg_fani(
702 1 RDUM1, RDUM2,IDUM1,IDUM2,IDUM3, IDUM4)
703C-----------------------------------------------
704 USE spmd_comm_world_mod, ONLY : spmd_comm_world
705#include "implicit_f.inc"
706C-----------------------------------------------
707 integer
708 . idum1, idum2, idum3, idum4, idum5
709 my_real
710 . rdum1, rdum2, rdum3, rdum4, rdum5
711 RETURN
712 END
713C routine simplifiee pour SMP
714!||====================================================================
715!|| spmd_get_mult ../engine/source/mpi/lag_multipliers/spmd_lag.F
716!||--- called by ------------------------------------------------------
717!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
718!||--- uses -----------------------------------------------------
719!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
720!||====================================================================
721 SUBROUTINE spmd_get_mult(
722 1 LAGCOMC,LAGCOMK,N_MULT ,BLL ,IADLL,
723 2 LLL ,JLL ,SLL ,XLL ,COMNTAG,
724 3 ICFTAG ,JCFTAG ,FR_LAGF,N_IK)
725C-----------------------------------------------
726C I m p l i c i t T y p e s
727C-----------------------------------------------
728 USE spmd_comm_world_mod, ONLY : spmd_comm_world
729#include "implicit_f.inc"
730C-----------------------------------------------
731C D u m m y A r g u m e n t s
732C-----------------------------------------------
733 INTEGER N_MULT, N_IK,
734 . LLL(*), JLL(*), SLL(*), IADLL(*),
735 . COMNTAG(*), ICFTAG(*), JCFTAG(*), FR_LAGF(3,*)
736 my_real
737 . lagcomk(4,*),lagcomc(2,*), xll(*), bll(*)
738C-----------------------------------------------
739C L O C A L V A R I A B L E S
740C-----------------------------------------------
741 INTEGER I,NCL,IKL,N
742
743 DO N = 1, n_mult
744 iadll(n+1) = iadll(n)+nint(lagcomc(1,n))
745 bll(n) = lagcomc(2,n)
746C ICTAG et JCFTAG : id (pas de cond. autre que fixe pour le moment !)
747 icftag(n) = n
748 jcftag(n) = n
749 END DO
750 DO n = 1, n_ik
751 lll(n) = nint(lagcomk(1,n))
752 jll(n) = nint(lagcomk(2,n))
753 sll(n) = nint(lagcomk(3,n))
754 xll(n) = lagcomk(4,n)
755C mise a jour du flag directement ici et non dans LTAG_FXV
756 comntag(lll(n)) = comntag(lll(n))+1
757 END DO
758C
759 RETURN
760 END
761C
762!||====================================================================
763!|| spmd_gg_mult ../engine/source/mpi/lag_multipliers/spmd_lag.F
764!||--- called by ------------------------------------------------------
765!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
766!||--- uses -----------------------------------------------------
767!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
768!||====================================================================
769 SUBROUTINE spmd_gg_mult(
770 1 A ,AR ,V ,VR ,MS ,
771 2 IN ,AG ,ARG ,VG ,VRG ,
772 3 MSG ,ING ,FR_LAGF,ISIZ ,NBNODL,
773 4 INDEXLAG,NODGLOB ,LLAGF ,NLAGF_L)
774C-----------------------------------------------
775C I m p l i c i t T y p e s
776C-----------------------------------------------
777 USE spmd_comm_world_mod, ONLY : spmd_comm_world
778#include "implicit_f.inc"
779C-----------------------------------------------
780C C o m m o n B l o c k s
781C-----------------------------------------------
782#include "com01_c.inc"
783C-----------------------------------------------
784C D u m m y A r g u m e n t s
785C-----------------------------------------------
786 INTEGER FR_LAGF(3,*), INDEXLAG(*), NODGLOB(*), LLAGF(*),
787 . NBNODL, NLAGF_L, ISIZ
788 my_real
789 . a(3,*), ar(3,*), v(3,*), vr(3,*), ms(*), in(*),
790 . ag(3,*), arg(3,*), vg(3,*), vrg(3,*), msg(*), ing(*)
791C-----------------------------------------------
792C L O C A L V A R I A B L E S
793C-----------------------------------------------
794 INTEGER I,N
795C
796 IF(IRODDL/=0)then
797 DO i = 1, nlagf_l
798 n = llagf(i)
799 indexlag(nodglob(n)) = i
800 ag(1,i) = a(1,n)
801 ag(2,i) = a(2,n)
802 ag(3,i) = a(3,n)
803 msg(i) = ms(n)
804 vg(1,i) = v(1,n)
805 vg(2,i) = v(2,n)
806 vg(3,i) = v(3,n)
807 arg(1,i)= ar(1,n)
808 arg(2,i)= ar(2,n)
809 arg(3,i)= ar(3,n)
810 ing(i) = in(n)
811 vrg(1,i)= vr(1,n)
812 vrg(2,i)= vr(2,n)
813 vrg(3,i)= vr(3,n)
814 END DO
815 ELSE
816 DO i = 1, nlagf_l
817 n = llagf(i)
818 indexlag(nodglob(n)) = i
819 ag(1,i) = a(1,n)
820 ag(2,i) = a(2,n)
821 ag(3,i) = a(3,n)
822 msg(i) = ms(n)
823 vg(1,i) = v(1,n)
824 vg(2,i) = v(2,n)
825 vg(3,i) = v(3,n)
826 END DO
827 END IF
828C
829 RETURN
830 END
831C
832!||====================================================================
833!|| spmd_sg_mult ../engine/source/mpi/lag_multipliers/spmd_lag.F
834!||--- called by ------------------------------------------------------
835!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
836!||--- uses -----------------------------------------------------
837!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
838!||====================================================================
839 SUBROUTINE spmd_sg_mult(
840 1 A ,AR ,AG ,ARG ,FR_LAGF,
841 2 ISIZ ,NBNODL ,LLAGF ,NLAGF_L )
842C-----------------------------------------------
843C I m p l i c i t T y p e s
844C-----------------------------------------------
845 USE spmd_comm_world_mod, ONLY : spmd_comm_world
846#include "implicit_f.inc"
847C-----------------------------------------------
848C C o m m o n B l o c k s
849C-----------------------------------------------
850#include "com01_c.inc"
851C-----------------------------------------------
852C D u m m y A r g u m e n t s
853C-----------------------------------------------
854 INTEGER FR_LAGF(3,*), LLAGF(*),
855 . NBNODL, NLAGF_L, ISIZ
856 my_real
857 . A(3,*), AR(3,*),AG(3,*), ARG(3,*)
858C-----------------------------------------------
859C L O C A L V A R I A B L E S
860C-----------------------------------------------
861 INTEGER I,N
862C
863 IF(IRODDL/=0)then
864 DO i = 1, nlagf_l
865 n = llagf(i)
866 a(1,n) = ag(1,i)
867 a(2,n) = ag(2,i)
868 a(3,n) = ag(3,i)
869 ar(1,n) = arg(1,i)
870 ar(2,n) = arg(2,i)
871 ar(3,n) = arg(3,i)
872 END DO
873 ELSE
874 DO i = 1, nlagf_l
875 n = llagf(i)
876 a(1,n) = ag(1,i)
877 a(2,n) = ag(2,i)
878 a(3,n) = ag(3,i)
879 END DO
880 END IF
881C
882 RETURN
883 END
884C
885!||====================================================================
886!|| spmd_exch_mult ../engine/source/mpi/lag_multipliers/spmd_lag.F
887!||--- called by ------------------------------------------------------
888!|| lag_multp ../engine/source/tools/lagmul/lag_mult.F
889!||--- uses -----------------------------------------------------
890!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
891!||====================================================================
892 SUBROUTINE spmd_exch_mult(
893 1 A ,AR ,LLAGF , NLAGF_L, FR_LAGF,
894 2 IAD_ELEM,FR_ELEM,LRBUF , ISIZ )
895C-----------------------------------------------
896C I m p l i c i t T y p e s
897C-----------------------------------------------
898 USE spmd_comm_world_mod, ONLY : spmd_comm_world
899#include "implicit_f.inc"
900C-----------------------------------------------
901C D u m m y A r g u m e n t s
902C-----------------------------------------------
903 INTEGER NLAGF_L,LRBUF,ISIZ,
904 . fr_lagf(3,*),llagf(*),iad_elem(2,*),fr_elem(*)
905 my_real
906 . a(3,*), ar(3,*)
907C-----------------------------------------------
908C L o c a l V a r i a b l e s
909C-----------------------------------------------
910 RETURN
911 END
912#endif
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
spmd_sg_fani
subroutine spmd_sg_fani(rdum1, rdum2, idum1, idum2, idum3, idum4)
Definition spmd_lag.F:703
spmd_gg_mult
subroutine spmd_gg_mult(a, ar, v, vr, ms, in, ag, arg, vg, vrg, msg, ing, fr_lagf, isiz, nbnodl, indexlag, nodglob, llagf, nlagf_l)
Definition spmd_lag.F:774
spmd_get_mult
subroutine spmd_get_mult(lagcomc, lagcomk, n_mult, bll, iadll, lll, jll, sll, xll, comntag, icftag, jcftag, fr_lagf, n_ik)
Definition spmd_lag.F:725
spmd_sg_mult
subroutine spmd_sg_mult(a, ar, ag, arg, fr_lagf, isiz, nbnodl, llagf, nlagf_l)
Definition spmd_lag.F:842
spmd_exch_mult
subroutine spmd_exch_mult(a, ar, llagf, nlagf_l, fr_lagf, iad_elem, fr_elem, lrbuf, isiz)
Definition spmd_lag.F:895