OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
imp_spmd.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#ifndef MPI
25#define MPI_INTEGER 0
26#define MPI_SUM 0
27#define MPI_STATUS_SIZE 1
28#endif
29!||====================================================================
30!|| spmd_mumps_front ../engine/source/mpi/implicit/imp_spmd.F
31!||--- calls -----------------------------------------------------
32!||--- uses -----------------------------------------------------
33!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
34!||====================================================================
35 SUBROUTINE spmd_mumps_front(ITK , RTK, NKFRONT, NKFLOC, NKLOC,
36 . NDDLG, IPRINT )
37C-----------------------------------------------
38C I m p l i c i t T y p e s
39C-----------------------------------------------
40 USE spmd_comm_world_mod, ONLY : spmd_comm_world
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "task_c.inc"
46#include "units_c.inc"
47#include "com01_c.inc"
48C-----------------------------------------------
49C M e s s a g e P a s s i n g
50C-----------------------------------------------
51#include "spmd.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 INTEGER ITK(2,*), NKFRONT, NKFLOC, NKLOC, NDDLG, IPRINT
56 my_real rtk(*)
57#if defined(MUMPS5)
58C-----------------------------------------------
59C L o c a l V a r i a b l e s
60C-----------------------------------------------
61 INTEGER I, NKFP(NSPMD-1), IRQTAG, REQ1(NSPMD-1),
62 . tstat1(mpi_status_size,nspmd-1), nkf_tot, len, ir, jc,
63 . index, j, k, nn, nkfmax, nkf_new(nspmd), pp, nmin,
64 . pmin, ii, req2(2), tstat2(mpi_status_size,2),
65 . req3(3),
66 . tstat3(mpi_status_size,3),req4(3),
67 . tstat4(mpi_status_size,3), ierr, np, jj, nkip(nspmd-1),
68 . sbuf(2), rbuf(2,nspmd-1), nnzt, nddlp(nspmd-1),
69 . iadfin, iad, iad0, addcm(nddlg)
70 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ITKF, IKFRONT, PKFRONT,KFMAP
71 my_real, DIMENSION(:), ALLOCATABLE :: rtkf, rkfront
72 INTEGER MSGOFF,MSGOFF2,MSGOFF3,MSGOFF4,MSGOFF5,MSGOFF6
73 DATA msgoff/16000/,msgoff2/16062/
74 DATA msgoff3/16000/,msgoff4/16062/
75 DATA msgoff5/16003/,msgoff6/16064/
76
77
78
79C
80 ALLOCATE(itkf(2,nkfront), rtkf(nkfront))
81 DO i=1,nkfront
82 itkf(1,i)=itk(1,nkloc+i)
83 itkf(2,i)=itk(2,nkloc+i)
84 rtkf(i)=rtk(nkloc+i)
85 ENDDO
86C
87 IF (ispmd==0) THEN
88 DO i=1,nspmd-1
89 irqtag=msgoff
90 CALL mpi_irecv(rbuf(1,i), 2, mpi_integer, it_spmd(i+1),
91 . irqtag, spmd_comm_world, req1(i), ierr)
92 ENDDO
93 IF(nspmd > 1) CALL mpi_waitall(nspmd-1, req1, tstat1, ierr)
94 DO i=1,nspmd-1
95 nkfp(i)=rbuf(1,i)
96 nkip(i)=rbuf(2,i)
97 ENDDO
98C
99 nkf_tot=nkfront
100 DO i=1,nspmd-1
101 nkf_tot=nkf_tot+nkfp(i)
102 ENDDO
103 ALLOCATE(ikfront(3,nkf_tot), rkfront(nkf_tot),
104 . pkfront(nspmd+1,nkf_tot))
105C
106C IKFRONT becomes a chained list
107C
108 DO i=1,nddlg
109 addcm(i)=0
110 END DO
111 iadfin=0
112 DO i=1,nkfront
113 ir=itkf(1,i)
114 jc=itkf(2,i)
115 IF(ir>nddlg) stop 1000
116 iad=addcm(ir)
117 DO WHILE (iad /= 0)
118 iad0=iad
119 iad=ikfront(3,iad)
120 END DO
121 iadfin = iadfin+1
122 ikfront(1,iadfin) = jc
123 ikfront(2,iadfin) = ir
124 ikfront(3,iadfin) = 0
125 IF(addcm(ir) == 0)THEN
126 addcm(ir)=iadfin
127 ELSE
128 ikfront(3,iad0)=iadfin
129 ENDIF
130 rkfront(iadfin)=rtkf(i)
131 pkfront(1,iadfin)=1
132 pkfront(2,iadfin)=1
133 END DO
134C
135 nkf_tot=nkfront
136 DEALLOCATE(itkf, rtkf)
137C
138 DO i=1,nspmd-1
139 ALLOCATE(itkf(2,nkfp(i)), rtkf(nkfp(i)))
140 irqtag=msgoff2
141 len=2*nkfp(i)
142 CALL mpi_irecv(itkf, len, mpi_integer, it_spmd(i+1),
143 . irqtag, spmd_comm_world, req2(1), ierr)
144 irqtag=msgoff3
145 len=nkfp(i)
146 CALL mpi_irecv(rtkf, len, real, it_spmd(i+1),
147 . irqtag, spmd_comm_world, req2(2), ierr)
148 CALL mpi_waitall(2, req2, tstat2, ierr)
149C
150 DO j=1,nkfp(i)
151 ir=itkf(1,j)
152 jc=itkf(2,j)
153 index=0
154C chained list
155 IF(ir>nddlg) stop 2000
156 iad=addcm(ir)
157 ! go through IKFRONT until JC is found at INDEX pos
158 DO WHILE (iad /= 0)
159 IF(ikfront(1,iad) == jc)THEN
160 index=iad
161 iad=0
162 ELSE
163 iad0=iad
164 iad=ikfront(3,iad)
165 END IF
166 END DO
167 IF(index == 0) THEN
168 nkf_tot = nkf_tot+1
169 ikfront(1,nkf_tot) = jc
170 ikfront(2,nkf_tot) = ir
171 ikfront(3,nkf_tot) = 0
172 IF(addcm(ir) == 0)THEN
173 addcm(ir)=nkf_tot
174 ELSE
175 ikfront(3,iad0)=nkf_tot
176 ENDIF
177 rkfront(nkf_tot)=rtkf(j)
178 pkfront(1,nkf_tot)=1
179 pkfront(2,nkf_tot)=i+1
180 ELSE
181 rkfront(index)=rkfront(index)+rtkf(j)
182 nn=pkfront(1,index)
183 nn=nn+1
184 pkfront(1,index)=nn
185 pkfront(1+nn,index)=i+1
186 END IF
187 ENDDO
188 DEALLOCATE(itkf, rtkf)
189 ENDDO
190C
191 nnzt=nkloc
192 DO i=1,nspmd-1
193 nnzt=nnzt+nkip(i)
194 ENDDO
195 nnzt=nnzt+nkf_tot
196 IF (ispmd==0.AND.iprint==1) THEN
197 WRITE(istdo,*)
198 WRITE(istdo,'(A21,I10,A8,I10)')
199 . ' MUMPS DIM : NNZ =',nnzt,' NNZFR =',nkf_tot
200 ENDIF
201C
202C Affectation des termes de frontieres aux processeurs
203 nkfmax=nkfront
204 DO i=1,nspmd-1
205 nkfmax=max(nkfmax,nkfp(i))
206 ENDDO
207C
208 ALLOCATE(kfmap(nspmd,nkfmax))
209 DO i=1,nspmd
210 nkf_new(i)=0
211 ENDDO
212C PKFRONT(1,I) => number of proc
213C PKFRONT(2:NSPMD+1) => proc id
214C KFMAP(PKFRONT(2,I),NKF_NEW(PKFRONT(2,I))) = I
215C
216C
217 DO i=1,nkf_tot
218 IF (pkfront(1,i)==1) THEN
219 pp=pkfront(2,i)
220 nn=nkf_new(pp)
221 nn=nn+1
222 kfmap(pp,nn)=i
223 nkf_new(pp)=nn
224 ELSE
225 np=pkfront(1,i)
226 pp=pkfront(2,i)
227 nmin=nkf_new(pp)
228 pmin=pp
229 DO j=2,np
230 pp=pkfront(1+j,i)
231 IF (nkf_new(pp)<nmin) THEN
232 nmin=nkf_new(pp)
233 pmin=pp
234 ENDIF
235 ENDDO
236 nn=nkf_new(pmin)
237 nn=nn+1
238 kfmap(pmin,nn)=i
239 nkf_new(pmin)=nn
240 ENDIF
241 ENDDO
242C
243 IF (ispmd==0.AND.iprint==1) THEN
244 WRITE(istdo,*)
245 DO i=1,nspmd
246 IF (i==1) THEN
247 WRITE(istdo,'(A6,I5,5X,A5,I10,A8,I10)')
248 . ' PROC=',i,'NNZ =',nkloc+nkf_new(1),
249 . ' NNZFR =',nkf_new(1)
250 ELSE
251 WRITE(istdo,'(A6,I5,5X,A5,I10,A8,I10)')
252 . ' PROC=',i,'NNZ =',nkip(i-1)+nkf_new(i),
253 . ' NNZFR =',nkf_new(i)
254 ENDIF
255 ENDDO
256 ENDIF
257C
258 nkfloc=nkf_new(1)
259 DO i=1,nkfloc
260 ii=kfmap(1,i)
261 itk(1,nkloc+i)=ikfront(1,ii)
262 itk(2,nkloc+i)=ikfront(2,ii)
263 rtk(nkloc+i)=rkfront(ii)
264 ENDDO
265C
266 DO i=1,nspmd-1
267 irqtag=msgoff4
268 CALL mpi_isend(nkf_new(i+1), 1, mpi_integer, it_spmd(i+1),
269 . irqtag, spmd_comm_world, req3(1), ierr)
270C
271 ALLOCATE(itkf(2,nkf_new(i+1)), rtkf(nkf_new(i+1)))
272 DO j=1,nkf_new(i+1)
273 jj=kfmap(i+1,j)
274 itkf(1,j)=ikfront(1,jj)
275 itkf(2,j)=ikfront(2,jj)
276 rtkf(j)=rkfront(jj)
277 ENDDO
278 len=2*nkf_new(i+1)
279 irqtag=msgoff5
280 CALL mpi_isend(itkf, len, mpi_integer, it_spmd(i+1),
281 . irqtag, spmd_comm_world,
282 . req3(2), ierr)
283 len=nkf_new(i+1)
284 irqtag=msgoff6
285 CALL mpi_isend(rtkf, len, real, it_spmd(i+1),
286 . irqtag, spmd_comm_world,
287 . req3(3), ierr)
288C
289 CALL mpi_waitall(3, req3, tstat3, ierr)
290C
291 DEALLOCATE(itkf, rtkf)
292 ENDDO
293C
294 DEALLOCATE(ikfront, rkfront, pkfront)
295 ELSE
296 irqtag=msgoff
297 sbuf(1)=nkfront
298 sbuf(2)=nkloc
299 CALL mpi_isend(sbuf, 2, mpi_integer, it_spmd(1),
300 . irqtag, spmd_comm_world, req4(1), ierr)
301 CALL mpi_wait(req4, tstat4, ierr)
302 len=2*nkfront
303 irqtag=msgoff2
304 CALL mpi_isend(itkf, len, mpi_integer, it_spmd(1),
305 . irqtag, spmd_comm_world, req4(2), ierr)
306 len=nkfront
307 irqtag=msgoff3
308 CALL mpi_isend(rtkf, len, real, it_spmd(1),
309 . irqtag, spmd_comm_world, req4(3), ierr)
310
311 CALL mpi_waitall(3, req4, tstat4, ierr)
312 DEALLOCATE(itkf, rtkf)
313C
314 irqtag=msgoff4
315 CALL mpi_irecv(nkfloc, 1, mpi_integer, it_spmd(1),
316 . irqtag, spmd_comm_world, req4, ierr)
317 CALL mpi_wait(req4, tstat4, ierr)
318C
319 ALLOCATE(itkf(2,nkfloc), rtkf(nkfloc))
320 len=2*nkfloc
321 irqtag=msgoff5
322 CALL mpi_irecv(itkf, len, mpi_integer, it_spmd(1),
323 . irqtag, spmd_comm_world, req4(1), ierr)
324 len=nkfloc
325 irqtag=msgoff6
326 CALL mpi_irecv(rtkf, len, real, it_spmd(1),
327 . irqtag, spmd_comm_world, req4(2), ierr)
328 CALL mpi_waitall(2, req4, tstat4, ierr)
329C
330 DO i=1,nkfloc
331 itk(1,nkloc+i)=itkf(1,i)
332 itk(2,nkloc+i)=itkf(2,i)
333 rtk(nkloc+i)=rtkf(i)
334 ENDDO
335 DEALLOCATE(itkf, rtkf)
336 ENDIF
337C
338 RETURN
339#endif
340 END
341!||====================================================================
342!|| spmd_mumps_count ../engine/source/mpi/implicit/imp_spmd.F
343!||--- called by ------------------------------------------------------
344!|| imp_mumps1 ../engine/source/implicit/imp_mumps.F
345!||--- calls -----------------------------------------------------
346!||--- uses -----------------------------------------------------
347!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
348!||====================================================================
349 SUBROUTINE spmd_mumps_count(NZLOC, NZP, NNZ)
350C-----------------------------------------------
351C I m p l i c i t T y p e s
352C-----------------------------------------------
353 USE spmd_comm_world_mod, ONLY : spmd_comm_world
354#include "implicit_f.inc"
355C-----------------------------------------------
356C C o m m o n B l o c k s
357C-----------------------------------------------
358#include "com01_c.inc"
359#include "task_c.inc"
360C-----------------------------------------------
361C M e s s a g e P a s s i n g
362C-----------------------------------------------
363#include "spmd.inc"
364C-----------------------------------------------
365C D u m m y A r g u m e n t s
366C-----------------------------------------------
367 INTEGER NZLOC, NZP(NSPMD-1), NNZ
368#if defined(MUMPS5)
369C-----------------------------------------------
370C L o c a l V a r i a b l e s
371C-----------------------------------------------
372 INTEGER I, IRQTAG, MSGOFF, REQ(NSPMD-1), TSTAT(MPI_STATUS_SIZE,NSPMD-1), IERR
373 DATA msgoff/16001/
374C
375 nnz=0
376 IF (ispmd==0) THEN
377 nnz=nzloc
378 DO i=1,nspmd-1
379 irqtag=msgoff
380 CALL mpi_irecv(nzp(i), 1, mpi_integer, it_spmd(i+1),
381 . irqtag, spmd_comm_world, req(i), ierr)
382 ENDDO
383
384 IF(nspmd > 1) CALL mpi_waitall(nspmd-1, req, tstat, ierr)
385 DO i=1,nspmd-1
386 nnz=nnz+nzp(i)
387 ENDDO
388 ELSE
389 irqtag=msgoff
390 CALL mpi_isend(nzloc, 1, mpi_integer, it_spmd(1),
391 . irqtag, spmd_comm_world, req, ierr)
392 CALL mpi_wait(req, tstat, ierr)
393 ENDIF
394C
395 RETURN
396#endif
397 END
398!||====================================================================
399!|| spmd_mumps_gath ../engine/source/mpi/implicit/imp_spmd.F
400!||--- called by ------------------------------------------------------
401!|| imp_mumps1 ../engine/source/implicit/imp_mumps.F
402!||--- calls -----------------------------------------------------
403!||--- uses -----------------------------------------------------
404!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
405!||====================================================================
406 SUBROUTINE spmd_mumps_gath(ITK, RTK, NZLOC, A, IRN,
407 . JCN, NZP)
408C-----------------------------------------------
409C I m p l i c i t T y p e s
410C-----------------------------------------------
411 USE spmd_comm_world_mod, ONLY : spmd_comm_world
412#include "implicit_f.inc"
413C-----------------------------------------------
414C C o m m o n B l o c k s
415C-----------------------------------------------
416#include "com01_c.inc"
417#include "task_c.inc"
418C-----------------------------------------------
419C M e s s a g e P a s s i n g
420C-----------------------------------------------
421#include "spmd.inc"
422C-----------------------------------------------
423C D u m m y A r g u m e n t s
424C-----------------------------------------------
425 INTEGER ITK(2,*), NZLOC, IRN(*), JCN(*), NZP(*)
426 my_real RTK(*), A(*)
427#if defined(MUMPS5)
428C-----------------------------------------------
429C L o c a l V a r i a b l e s
430C-----------------------------------------------
431 INTEGER NNZ, I, IRQTAG, MSGOFF,MSGOFF2,
432 . LEN, REQ(2), IERR,
433 . tstat(mpi_status_size,2), j
434 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ITKP
435 my_real
436 . , DIMENSION(:), ALLOCATABLE :: rtkp
437 DATA msgoff/16002/
438 DATA msgoff2/16055/
439
440C
441 IF (ispmd==0) THEN
442 nnz=0
443 DO i=1,nzloc
444 nnz=nnz+1
445 irn(nnz)=itk(1,i)
446 jcn(nnz)=itk(2,i)
447 a(nnz)=rtk(i)
448 ENDDO
449C
450 DO i=1,nspmd-1
451 ALLOCATE(itkp(2,nzp(i)), rtkp(nzp(i)))
452 irqtag=msgoff
453 len=2*nzp(i)
454 CALL mpi_irecv(itkp, len, mpi_integer, it_spmd(i+1),
455 . irqtag, spmd_comm_world, req(1), ierr)
456 irqtag=msgoff2
457 len=nzp(i)
458 CALL mpi_irecv(rtkp, len, real, it_spmd(i+1),
459 . irqtag, spmd_comm_world, req(2), ierr)
460
461 CALL mpi_waitall(2, req, tstat, ierr)
462C
463 DO j=1,nzp(i)
464 nnz=nnz+1
465 irn(nnz)=itkp(1,j)
466 jcn(nnz)=itkp(2,j)
467 a(nnz)=rtkp(j)
468 ENDDO
469 DEALLOCATE(itkp, rtkp)
470 ENDDO
471 ELSE
472 irqtag=msgoff
473 len=2*nzloc
474 CALL mpi_isend(itk, len, mpi_integer, it_spmd(1),
475 . irqtag, spmd_comm_world, req(1), ierr)
476 irqtag=msgoff2
477 len=nzloc
478 CALL mpi_isend(rtk, len, real, it_spmd(1),
479 . irqtag, spmd_comm_world, req(2), ierr)
480 CALL mpi_waitall(2, req, tstat, ierr)
481 ENDIF
482C
483 RETURN
484#endif
485 END
486!||====================================================================
487!|| spmd_mumps_ini ../engine/source/mpi/implicit/imp_spmd.F
488!||--- called by ------------------------------------------------------
489!|| imp_buck ../engine/source/implicit/imp_buck.F
490!|| imp_mumps1 ../engine/source/implicit/imp_mumps.F
491!|| lag_mult_sdp ../engine/source/tools/lagmul/lag_mult_solv.F
492!|| resol ../engine/source/engine/resol.F
493!||--- calls -----------------------------------------------------
494!||--- uses -----------------------------------------------------
495!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
496!||====================================================================
497 SUBROUTINE spmd_mumps_ini(MUMPS_PAR, SYM)
498C-----------------------------------------------
499C I m p l i c i t T y p e s
500C-----------------------------------------------
501 USE spmd_comm_world_mod, ONLY : spmd_comm_world
502#include "implicit_f.inc"
503C-----------------------------------------------
504C C o m m o n B l o c k s
505C-----------------------------------------------
506#if defined(MUMPS5)
507#include "dmumps_struc.h"
508#endif
509#include "com01_c.inc"
510#include "task_c.inc"
511C-----------------------------------------------
512C M e s s a g e P a s s i n g
513C-----------------------------------------------
514#include "spmd.inc"
515C-----------------------------------------------
516C D u m m y A r g u m e n t s
517C-----------------------------------------------
518 INTEGER SYM
519#ifdef MUMPS5
520 TYPE(dmumps_struc) MUMPS_PAR
521#else
522 ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
523 INTEGER MUMPS_PAR
524#endif
525
526#if defined(MUMPS5)
527C-----------------------------------------------
528C L o c a l V a r i a b l e s
529C-----------------------------------------------
530C
531#ifdef MPI
532 mumps_par%COMM = spmd_comm_world
533#else
534 mumps_par%COMM = 0
535#endif
536 mumps_par%JOB = -1
537 mumps_par%SYM = sym
538 mumps_par%PAR = 1
539c CALL STARTIME(TIMERS,96)
540 CALL dmumps(mumps_par)
541c CALL STOPTIME(TIMERS,96)
542
543C
544 RETURN
545#endif
546 END
547!||====================================================================
548!|| spmd_mumps_deal ../engine/source/mpi/implicit/imp_spmd.F
549!||--- called by ------------------------------------------------------
550!|| deallocm_imp ../engine/source/implicit/imp_solv.F
551!|| imp_mumps1 ../engine/source/implicit/imp_mumps.F
552!|| lag_mult_sdp ../engine/source/tools/lagmul/lag_mult_solv.F
553!||--- calls -----------------------------------------------------
554!||--- uses -----------------------------------------------------
555!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
556!||====================================================================
557 SUBROUTINE spmd_mumps_deal(MUMPS_PAR)
558C-----------------------------------------------
559C I m p l i c i t T y p e s
560C-----------------------------------------------
561 USE spmd_comm_world_mod, ONLY : spmd_comm_world
562#include "implicit_f.inc"
563C-----------------------------------------------
564C C o m m o n B l o c k s
565C-----------------------------------------------
566#if defined(MUMPS5)
567#include "dmumps_struc.h"
568#endif
569C-----------------------------------------------
570C D u m m y A r g u m e n t s
571C-----------------------------------------------
572#ifdef MUMPS5
573 TYPE(dmumps_struc) MUMPS_PAR
574#else
575 ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
576 INTEGER MUMPS_PAR
577#endif
578
579#if defined(MUMPS5)
580C-----------------------------------------------
581C L o c a l V a r i a b l e s
582C-----------------------------------------------
583C
584 IF (ASSOCIATED(mumps_par%A)) DEALLOCATE(mumps_par%A)
585 IF (ASSOCIATED(mumps_par%IRN)) DEALLOCATE(mumps_par%IRN)
586 IF (ASSOCIATED(mumps_par%JCN)) DEALLOCATE(mumps_par%JCN)
587 IF (ASSOCIATED(mumps_par%A_LOC)) DEALLOCATE(mumps_par%A_LOC)
588 IF (ASSOCIATED(mumps_par%IRN_LOC)) DEALLOCATE(mumps_par%IRN_LOC)
589 IF (ASSOCIATED(mumps_par%JCN_LOC)) DEALLOCATE(mumps_par%JCN_LOC)
590 IF (ASSOCIATED(mumps_par%RHS)) DEALLOCATE(mumps_par%RHS)
591 IF (ASSOCIATED(mumps_par%A)) THEN
592 DEALLOCATE(mumps_par%A)
593 ENDIF
594 mumps_par%JOB=-2
595 CALL dmumps(mumps_par)
596
597C
598 RETURN
599#endif
600 END
601!||====================================================================
602!|| spmd_mumps_rhs ../engine/source/mpi/implicit/imp_spmd.F
603!||--- called by ------------------------------------------------------
604!|| imp_mumps2 ../engine/source/implicit/imp_mumps.F
605!||--- calls -----------------------------------------------------
606!||--- uses -----------------------------------------------------
607!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
608!||====================================================================
609 SUBROUTINE spmd_mumps_rhs(V , CDDLP, RHS, NDDL, ISENS,
610 . NDDLG)
611C-----------------------------------------------
612C I m p l i c i t T y p e s
613C-----------------------------------------------
614 USE spmd_comm_world_mod, ONLY : spmd_comm_world
615#include "implicit_f.inc"
616C-----------------------------------------------
617C C o m m o n B l o c k s
618C-----------------------------------------------
619#include "com01_c.inc"
620#include "task_c.inc"
621C-----------------------------------------------
622C M e s s a g e P a s s i n g
623C-----------------------------------------------
624#include "spmd.inc"
625C-----------------------------------------------
626C D u m m y A r g u m e n t s
627C-----------------------------------------------
628 INTEGER CDDLP(*), NDDL, ISENS, NDDLG
629 my_real V(*), RHS(*)
630#if defined(MUMPS5)
631C-----------------------------------------------
632C L o c a l V a r i a b l e s
633C-----------------------------------------------
634 INTEGER I, IRQTAG, MSGOFF, II, REQ(NSPMD-1),
635 . TSTAT(MPI_STATUS_SIZE,NSPMD-1), IERR,
636 . J, JJ
637 my_real vg(nddlg)
638 my_real, DIMENSION(:,:), ALLOCATABLE :: vp
639 DATA msgoff/16003/
640C
641 IF (ispmd==0) THEN
642C
643 IF (isens==1) THEN
644 ALLOCATE(vp(nddlg,nspmd-1))
645C Gather des forces
646 DO i=1,nddlg
647 rhs(i)=zero
648 ENDDO
649 DO i=1,nddl
650 ii=cddlp(i)
651 rhs(ii)=v(i)
652 ENDDO
653C
654 DO i=1,nspmd-1
655 irqtag=msgoff
656 CALL mpi_irecv(vp(1,i), nddlg, real, it_spmd(i+1),
657 . irqtag, spmd_comm_world, req(i), ierr)
658 ENDDO
659 IF(nspmd > 1) CALL mpi_waitall(nspmd-1, req, tstat, ierr)
660 DO i=1,nspmd-1
661 DO j=1,nddlg
662 rhs(j)=rhs(j)+vp(j,i)
663 ENDDO
664 ENDDO
665C
666 DEALLOCATE(vp)
667C
668 ELSEIF (isens==2) THEN
669C Scatter des deplacements
670 DO i=1,nddl
671 ii=cddlp(i)
672 v(i)=rhs(ii)
673 ENDDO
674C
675 DO i=1,nspmd-1
676 irqtag=msgoff
677 CALL mpi_isend(rhs, nddlg, real, it_spmd(i+1),
678 . irqtag, spmd_comm_world, req(i), ierr)
679 ENDDO
680 IF(nspmd > 1) CALL mpi_waitall(nspmd-1, req, tstat, ierr)
681 ENDIF
682 ELSE
683 IF (isens==1) THEN
684 DO i=1,nddlg
685 vg(i)=zero
686 ENDDO
687 DO i=1,nddl
688 ii=cddlp(i)
689 vg(ii)=v(i)
690 ENDDO
691C
692 irqtag=msgoff
693 CALL mpi_isend(vg, nddlg, real, it_spmd(1),
694 . irqtag, spmd_comm_world, req, ierr)
695 CALL mpi_wait(req, tstat, ierr)
696 ELSEIF (isens==2) THEN
697 irqtag=msgoff
698 CALL mpi_irecv(vg, nddlg, real, it_spmd(1),
699 . irqtag, spmd_comm_world, req, ierr)
700 CALL mpi_wait(req, tstat, ierr)
701C
702 DO i=1,nddl
703 ii=cddlp(i)
704 v(i)=vg(ii)
705 ENDDO
706 ENDIF
707 ENDIF
708C
709 RETURN
710#endif
711 END
712!||====================================================================
713!|| spmd_mumps_exec ../engine/source/mpi/implicit/imp_spmd.F
714!||--- called by ------------------------------------------------------
715!|| imp_mumps2 ../engine/source/implicit/imp_mumps.F
716!|| lag_mult_sdp ../engine/source/tools/lagmul/lag_mult_solv.f
717!||--- calls -----------------------------------------------------
718!|| imp_errmumps ../engine/source/implicit/imp_solv.F
719!|| tmpenvf ../engine/source/system/tmpenv_c.c
720!||--- uses -----------------------------------------------------
721!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
722!||====================================================================
723 SUBROUTINE spmd_mumps_exec(MUMPS_PAR, ITASK)
724C-----------------------------------------------
725C I m p l i c i t T y p e s
726C-----------------------------------------------
727 USE spmd_comm_world_mod, ONLY : spmd_comm_world
728#include "implicit_f.inc"
729C-----------------------------------------------
730C C o m m o n B l o c k s
731C-----------------------------------------------
732#if defined(MUMPS5)
733#include "dmumps_struc.h"
734#endif
735#include "units_c.inc"
736#include "com01_c.inc"
737#include "task_c.inc"
738#include "impl1_c.inc"
739C-----------------------------------------------
740C D u m m y A r g u m e n t s
741C-----------------------------------------------
742 INTEGER ITASK
743#ifdef MUMPS5
744 TYPE(DMUMPS_STRUC) MUMPS_PAR
745#else
746 ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
747 INTEGER MUMPS_PAR
748#endif
749
750#if defined(MUMPS5)
751C-----------------------------------------------
752C L o c a l V a r i a b l e s
753C-----------------------------------------------
754 INTEGER AVAIL_MEM,ESTIM_MEM
755 INTEGER ORDERING_METHOD,METIS,PORD,AUTOMATIC
756 INTEGER :: TLEN
757 LOGICAL :: IS_OOC_AUTORIZED
758
759 is_ooc_autorized = .false.
760 IF(m_ocore == -1) is_ooc_autorized = .true.
761! Only the testing here, initializations are removed into IMP_MUMPS1
762
763 IF (itask==1) THEN
764 metis = 5
765 pord = 4
766
767C Analyse
768 mumps_par%JOB=1
769C CALL STARTIME(TIMERS,97)
770
771
772 CALL dmumps(mumps_par)
773C CALL STOPTIME(TIMERS,97)
774 ordering_method = mumps_par%INFOG(7)
775 IF(mumps_par%INFOG(1) < 0) THEN
776 IF(ispmd ==0 ) THEN
777 WRITE(iout,*) 'Warning: MUMPS Error in Analysis. Retry'
778 ENDIF
779C If there is an error during the analysis, then we retry with
780C Another ordering method
781 IF(ordering_method /= pord) THEN
782 ordering_method = pord
783 ELSE
784 ordering_method = metis
785 ENDIF
786 mumps_par%JOB=1
787 mumps_par%ICNTL(7) = ordering_method
788C CALL STARTIME(TIMERS,97)
789 CALL dmumps(mumps_par)
790C CALL STOPTIME(TIMERS,97)
791 ENDIF
792
793 IF( nspmd == 1) nspmd_per_node = 1
794C Workspace size
795 avail_mem = int(8.0d0 * lmemv /(10.0d0 * nspmd_per_node ))
796 IF(mumps_par%ICNTL(22) == 0 ) THEN
797C In-core :
798C INFOG(16) is the estimation already increased by 20pc.
799C We increase again by 20pc
800 estim_mem = int(mumps_par%INFOG(16) * 1.2d0)
801 ELSE
802C Out-of-core
803 estim_mem = int(mumps_par%INFOG(26) * 1.2d0)
804 ENDIF
805
806
807 IF(is_ooc_autorized .AND. estim_mem > avail_mem) THEN
808 mumps_par%ICNTL(22) = 1
809 mumps_par%ICNTL(23) = estim_mem
810 CALL tmpenvf(mumps_par%OOC_TMPDIR,tlen)
811 ELSE
812 mumps_par%ICNTL(23) = min(avail_mem,estim_mem)
813 ENDIF
814
815C Factorisation
816 mumps_par%JOB=2
817C CALL STARTIME(TIMERS,98)
818 CALL dmumps(mumps_par)
819C CALL STOPTIME(TIMERS,98)
820
821C In-Core:Trying to recover from error
822 IF(mumps_par%INFOG(1) == -8) THEN
823C if internal workspace is too small (IS)
824 IF(ispmd ==0 ) THEN
825 WRITE(iout,*) 'Warning: MUMPS workspace too small. Retry'
826 ENDIF
827 mumps_par%ICNTL(14) = mumps_par%ICNTL(14) * 2
828 mumps_par%JOB=2
829C CALL STARTIME(TIMERS,98)
830 CALL dmumps(mumps_par)
831C CALL STOPTIME(TIMERS,98)
832
833 ELSEIF(mumps_par%INFOG(1)==-9 .OR. mumps_par%INFOG(1)==-11
834 . .OR. mumps_par%INFOG(1)== -19 ) THEN
835C if internal workspace is too small (S)
836 IF(ispmd ==0 ) THEN
837 WRITE(iout,*) 'Warning: MUMPS workspace too small. Retry'
838 ENDIF
839
840 avail_mem = int(9.5d0 * lmemv /(10.0d0 * nspmd_per_node ))
841 estim_mem = avail_mem
842 mumps_par%ICNTL(23) = avail_mem
843 mumps_par%JOB=2
844c CALL STARTIME(TIMERS,98)
845 CALL dmumps(mumps_par)
846c CALL STOPTIME(TIMERS,98)
847
848 ELSEIF(mumps_par%INFOG(1) == -13) THEN
849C if internal workspace is too big: an allocation failed
850 IF(ispmd ==0 ) THEN
851 WRITE(iout,*) 'Warning: MUMPS workspace too large. Retry'
852 ENDIF
853 avail_mem = int(avail_mem * 8.0d0 / 10.0d0)
854 estim_mem = int(estim_mem * 8.0d0 / 10.0d0)
855 mumps_par%ICNTL(23) = min(avail_mem,estim_mem)
856 mumps_par%JOB=2
857c CALL STARTIME(TIMERS,98)
858 CALL dmumps(mumps_par)
859c CALL STOPTIME(TIMERS,98)
860
861 ELSEIF(mumps_par%INFOG(1)<0) THEN
862C Try to deal with other errors
863 IF(ispmd ==0 ) THEN
864 WRITE(iout,*) 'Warning: MUMPS error. Retry'
865 ENDIF
866 avail_mem = int(9.5d0 * lmemv /(10.0d0 * nspmd_per_node ))
867 estim_mem = avail_mem
868 mumps_par%ICNTL(23) = avail_mem
869 IF(ordering_method /= pord) THEN
870 ordering_method = pord
871 ELSE
872 ordering_method = metis
873 ENDIF
874 mumps_par%ICNTL(7) = ordering_method
875 mumps_par%ICNTL(13) = 1
876 mumps_par%JOB=1
877 CALL dmumps(mumps_par)
878 mumps_par%JOB=2
879c CALL STARTIME(TIMERS,98)
880 CALL dmumps(mumps_par)
881c CALL STOPTIME(TIMERS,98)
882 ENDIF ! Recovering from error
883
884
885
886 IF (mumps_par%INFOG(1)<0) THEN
887c WRITE(IOUT,*) 'Warning: failed to solve linear system '
888c WRITE(IOUT,*) 'MUMPS error code :',MUMPS_PAR%INFOG(1)
889 CALL imp_errmumps(mumps_par%INFOG(1))
890
891 ENDIF
892
893
894
895 ELSEIF (itask==2) THEN
896C Resolution
897 mumps_par%JOB=3
898c CALL STARTIME(TIMERS,99)
899 CALL dmumps(mumps_par)
900c CALL STOPTIME(TIMERS,99)
901
902 ENDIF
903C
904 RETURN
905#endif
906 END
907!||====================================================================
908!|| spmd_mumps_flush ../engine/source/mpi/implicit/imp_spmd.F
909!||--- uses -----------------------------------------------------
910!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
911!||====================================================================
912 SUBROUTINE spmd_mumps_flush(MUMPS_PAR)
913C This routine write the centralized matrix and RHS into files
914C-----------------------------------------------
915C I m p l i c i t T y p e s
916C-----------------------------------------------
917 USE spmd_comm_world_mod, ONLY : spmd_comm_world
918#include "implicit_f.inc"
919C-----------------------------------------------
920C C o m m o n B l o c k s
921C-----------------------------------------------
922#if defined(MUMPS5)
923#include "dmumps_struc.h"
924#endif
925#include "com01_c.inc"
926#include "task_c.inc"
927#include "impl1_c.inc"
928C-----------------------------------------------
929C M e s s a g e P a s s i n g
930C-----------------------------------------------
931#include "spmd.inc"
932C-----------------------------------------------
933C D u m m y A r g u m e n t s
934C-----------------------------------------------
935#ifdef MUMPS5
936 TYPE(DMUMPS_STRUC) MUMPS_PAR
937#else
938 ! Fake declaration as DMUMPS_STRUC is shipped with MUMPS
939 INTEGER MUMPS_PAR
940#endif
941
942#if defined(MUMPS5)
943C-----------------------------------------------
944C L o c a l V a r i a b l e s
945C-----------------------------------------------
946 INTEGER I
947 CHARACTER (len=255) file_mat,file_rhs,file_icntl
948c Uncomment the following lines to print the matrix into the matrix
949c Matrix Market format.
950 IF(imumpsd == 2 .AND. ispmd == 0) THEN
951C If centralized matrix on zero
952 OPEN(unit=21,file="matrix",action="write",status="replace",
953 . form='unformatted')
954
955 OPEN(unit=22,file="rhs",action="write",status="replace",
956 . form='unformatted')
957
958 OPEN(unit=23,file="icntl",action="write",status="replace",
959 . form='unformatted')
960
961 WRITE(21) mumps_par%N,mumps_par%NZ
962 DO i = 1,mumps_par%NZ
963 WRITE(21) mumps_par%IRN(i),mumps_par%JCN(i),mumps_par%A(i)
964 END DO
965 WRITE(22) mumps_par%N
966 DO i = 1,mumps_par%N
967 WRITE(22) mumps_par%RHS(i)
968 END DO
969 WRITE(23) mumps_par%ICNTL
970 CLOSE(21)
971 CLOSE(22)
972 CLOSE(23)
973 ELSE
974
975 WRITE(file_mat,"(A4,I4.4)") "mat_",ispmd
976 WRITE(file_rhs,"(A4,I4.4)") "rhs_",ispmd
977 WRITE(file_icntl,"(A4,I4.4)") "opt_",ispmd
978
979 OPEN(unit=21,file=file_mat,action="write",status="replace",
980 . form='unformatted')
981
982 OPEN(unit=22,file=file_rhs,action="write",status="replace",
983 . form='unformatted')
984
985 OPEN(unit=23,file=file_icntl,action="write",status="replace",
986 . form='unformatted')
987
988
989 WRITE(21) mumps_par%N,mumps_par%NZ,mumps_par%NZ_LOC
990 DO i = 1,mumps_par%NZ_LOC
991 WRITE(21) mumps_par%IRN_LOC(i),mumps_par%JCN_LOC(i),
992 . mumps_par%A_LOC(i)
993 END DO
994 IF( ispmd == 0 ) THEN
995 WRITE(22) mumps_par%N
996 DO i = 1,mumps_par%N
997 WRITE(22) mumps_par%RHS(i)
998 END DO
999 ENDIF
1000 WRITE(23) mumps_par%ICNTL
1001 CLOSE(21)
1002 CLOSE(22)
1003 CLOSE(23)
1004
1005 ENDIF
1006 RETURN
1007#endif
1008 END
1009
1010
1011
1012!||====================================================================
1013!|| spmd_sum_s ../engine/source/mpi/implicit/imp_spmd.F
1014!||--- called by ------------------------------------------------------
1015!|| dyna_ivfac ../engine/source/implicit/imp_dyna.F
1016!|| imp_check0 ../engine/source/implicit/imp_solv.F
1017!|| imp_checm0 ../engine/source/implicit/imp_solv.F
1018!|| imp_compabp ../engine/source/implicit/imp_solv.F
1019!|| imp_pcgh ../engine/source/implicit/imp_pcg.F
1020!|| ind_fr_k0 ../engine/source/mpi/implicit/imp_fri.F
1021!|| lin_solvih2 ../engine/source/implicit/lin_solv.F
1022!|| nddli_frb ../engine/source/mpi/implicit/imp_fri.F
1023!|| produt_h ../engine/source/implicit/produt_v.F
1024!|| produt_hp ../engine/source/implicit/produt_v.F
1025!|| produt_u0 ../engine/source/implicit/produt_v.F
1026!|| produt_uhp0 ../engine/source/implicit/produt_v.F
1027!|| produt_v ../engine/source/implicit/produt_v.F
1028!|| produt_w ../engine/source/implicit/produt_v.F
1029!|| sms_produt_h ../engine/source/ams/sms_proj.F
1030!|| spbrm_pre ../engine/source/implicit/imp_solv.F
1031!|| upd_fr_k ../engine/source/mpi/implicit/imp_fri.F
1032!||--- calls -----------------------------------------------------
1033!||--- uses -----------------------------------------------------
1034!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1035!||====================================================================
1036 SUBROUTINE spmd_sum_s(S)
1037C-----------------------------------------------
1038C I m p l i c i t T y p e s
1039C-----------------------------------------------
1040 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1041#include "implicit_f.inc"
1042C-----------------------------------------------
1043C C o m m o n B l o c k s
1044C-----------------------------------------------
1045#include "com01_c.inc"
1046#include "task_c.inc"
1047C-----------------------------------------------
1048C M e s s a g e P a s s i n g
1049C-----------------------------------------------
1050#include "spmd.inc"
1051C-----------------------------------------------
1052C D u m m y A r g u m e n t s
1053C-----------------------------------------------
1054 my_real s
1055#if defined(MPI)
1056C-----------------------------------------------
1057C L o c a l V a r i a b l e s
1058C-----------------------------------------------
1059 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1060 . INDEX, SIZ,
1061 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1062 my_real rbuf(nspmd),si
1063 DATA msgoff/16004/
1064 DATA msgoff2/16005/
1065C-----------------------------------------------
1066C S o u r c e L i n e s
1067C-----------------------------------------------
1068C---try
1069C---try SI=S
1070C---try CALL MPI_REDUCE(SI,S,1,REAL,MPI_SUM,0,SPMD_COMM_WORLD,IERROR)
1071C---try CALL MPI_BCAST(S,1,REAL,0,SPMD_COMM_WORLD,IERROR)
1072 loc_proc = ispmd + 1
1073 siz=1
1074 IF(ispmd==0) THEN
1075 DO i = 2, nspmd
1076 msgtyp=msgoff
1077 CALL mpi_irecv(rbuf(i),siz,real,it_spmd(i),msgtyp,
1078 . spmd_comm_world,req_r(i-1),ierror)
1079 END DO
1080C
1081 DO n = 1, nspmd-1
1082 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1083 i = index+1
1084 s = s + rbuf(i)
1085 END DO
1086C
1087 DO i = 2, nspmd
1088 msgtyp=msgoff2
1089 CALL mpi_send(s,siz,real,it_spmd(i),
1090 . msgtyp,spmd_comm_world,ierror)
1091 END DO
1092 ELSE
1093 msgtyp = msgoff
1094 CALL mpi_send(s,siz,real,it_spmd(1),
1095 . msgtyp,spmd_comm_world,ierror)
1096
1097 msgtyp = msgoff2
1098 CALL mpi_recv(s,siz,real,it_spmd(1),msgtyp,
1099 . spmd_comm_world,status,ierror)
1100 END IF
1101C
1102 RETURN
1103#endif
1104 END
1105!||====================================================================
1106!|| spmd_sum_s2 ../engine/source/mpi/implicit/imp_spmd.F
1107!||--- calls -----------------------------------------------------
1108!||--- uses -----------------------------------------------------
1109!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1110!||====================================================================
1111 SUBROUTINE spmd_sum_s2(S,LEN)
1112C-----------------------------------------------
1113C I m p l i c i t T y p e s
1114C-----------------------------------------------
1115 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1116#include "implicit_f.inc"
1117C-----------------------------------------------
1118C C o m m o n B l o c k s
1119C-----------------------------------------------
1120#include "com01_c.inc"
1121#include "task_c.inc"
1122C-----------------------------------------------
1123C M e s s a g e P a s s i n g
1124C-----------------------------------------------
1125#include "spmd.inc"
1126C-----------------------------------------------
1127C D u m m y A r g u m e n t s
1128C-----------------------------------------------
1129 INTEGER LEN
1130 my_real
1131 . S(LEN)
1132#if defined(MPI)
1133C-----------------------------------------------
1134C L o c a l V a r i a b l e s
1135C-----------------------------------------------
1136 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1137 . INDEX, SIZ, IDEB,
1138 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1139 my_real
1140 . rbuf(nspmd*len),si
1141 DATA msgoff/16006/
1142 DATA msgoff2/16007/
1143C-----------------------------------------------
1144C S o u r c e L i n e s
1145C-----------------------------------------------
1146
1147 loc_proc = ispmd + 1
1148 siz=len
1149 IF(ispmd==0) THEN
1150 ideb = siz+1
1151 DO i = 2, nspmd
1152 msgtyp=msgoff
1153 CALL mpi_irecv(rbuf(ideb),siz,real,it_spmd(i),msgtyp,
1154 . spmd_comm_world,req_r(i-1),ierror)
1155 ideb=ideb+siz
1156 END DO
1157C
1158 DO n = 1, nspmd-1
1159 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1160 ideb=index*siz
1161 DO i = 1, siz
1162 s(i) = s(i) + rbuf(ideb+i)
1163 END DO
1164 END DO
1165C
1166 DO i = 2, nspmd
1167 msgtyp=msgoff2
1168 CALL mpi_send(s,siz,real,it_spmd(i),
1169 . msgtyp,spmd_comm_world,ierror)
1170 END DO
1171 ELSE
1172 msgtyp = msgoff
1173 CALL mpi_send(s,siz,real,it_spmd(1),
1174 . msgtyp,spmd_comm_world,ierror)
1175
1176 msgtyp = msgoff2
1177 CALL mpi_recv(s,siz,real,it_spmd(1),msgtyp,
1178 . spmd_comm_world,status,ierror)
1179 END IF
1180C
1181 RETURN
1182#endif
1183 END
1184!||====================================================================
1185!|| spmd_max_s ../engine/source/mpi/implicit/imp_spmd.F
1186!||--- called by ------------------------------------------------------
1187!|| get_max ../engine/source/implicit/nl_solv.F
1188!|| lecimpl ../engine/source/input/lectur.F
1189!|| sms_check ../engine/source/ams/sms_fsa_inv.F
1190!||--- calls -----------------------------------------------------
1191!||--- uses -----------------------------------------------------
1192!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1193!||====================================================================
1194 SUBROUTINE spmd_max_s(S)
1195C-----------------------------------------------
1196C I m p l i c i t T y p e s
1197C-----------------------------------------------
1198 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1199#include "implicit_f.inc"
1200C-----------------------------------------------
1201C C o m m o n B l o c k s
1202C-----------------------------------------------
1203#include "com01_c.inc"
1204#include "task_c.inc"
1205C-----------------------------------------------
1206C M e s s a g e P a s s i n g
1207C-----------------------------------------------
1208#include "spmd.inc"
1209C-----------------------------------------------
1210C D u m m y A r g u m e n t s
1211C-----------------------------------------------
1212 my_real s
1213#if defined(MPI)
1214C-----------------------------------------------
1215C L o c a l V a r i a b l e s
1216C-----------------------------------------------
1217 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1218 . INDEX, SIZ,
1219 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1220 my_real
1221 . rbuf(nspmd),si
1222 DATA msgoff/16008/,msgoff2/16009/
1223C-----------------------------------------------
1224C S o u r c e L i n e s
1225C-----------------------------------------------
1226 loc_proc = ispmd + 1
1227 siz=1
1228 IF(ispmd==0) THEN
1229 DO i = 2, nspmd
1230 msgtyp=msgoff
1231 CALL mpi_irecv(rbuf(i),siz,real,it_spmd(i),msgtyp,
1232 . spmd_comm_world,req_r(i-1),ierror)
1233 END DO
1234C
1235 DO n = 1, nspmd-1
1236 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1237 i = index+1
1238 s = max(s,rbuf(i))
1239 END DO
1240C
1241 DO i = 2, nspmd
1242 msgtyp=msgoff2
1243 CALL mpi_send(s,siz,real,it_spmd(i),
1244 . msgtyp,spmd_comm_world,ierror)
1245 END DO
1246 ELSE
1247 msgtyp = msgoff
1248 CALL mpi_send(s,siz,real,it_spmd(1),
1249 . msgtyp,spmd_comm_world,ierror)
1250
1251 msgtyp = msgoff2
1252 CALL mpi_recv(s,siz,real,it_spmd(1),msgtyp,
1253 . spmd_comm_world,status,ierror)
1254 END IF
1255C
1256 RETURN
1257#endif
1258 END
1259!||====================================================================
1260!|| spmd_min_s ../engine/source/mpi/implicit/imp_spmd.F
1261!||--- called by ------------------------------------------------------
1262!|| imp_chkm ../engine/source/implicit/imp_solv.F
1263!|| imp_intdt ../engine/source/implicit/imp_int_k.F
1264!|| imp_solv ../engine/source/implicit/imp_solv.F
1265!|| spb_ieref3 ../engine/source/implicit/imp_solv.F
1266!|| spb_ieref_bc ../engine/source/implicit/imp_solv.F
1267!|| spbrm_pre ../engine/source/implicit/imp_solv.F
1268!||--- calls -----------------------------------------------------
1269!||--- uses -----------------------------------------------------
1270!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1271!||====================================================================
1272 SUBROUTINE spmd_min_s(S)
1273C-----------------------------------------------
1274C I m p l i c i t T y p e s
1275C-----------------------------------------------
1276 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1277#include "implicit_f.inc"
1278C-----------------------------------------------
1279C C o m m o n B l o c k s
1280C-----------------------------------------------
1281#include "com01_c.inc"
1282#include "task_c.inc"
1283C-----------------------------------------------
1284C M e s s a g e P a s s i n g
1285C-----------------------------------------------
1286#include "spmd.inc"
1287C-----------------------------------------------
1288C D u m m y A r g u m e n t s
1289C-----------------------------------------------
1290 my_real s
1291#if defined(MPI)
1292C-----------------------------------------------
1293C L o c a l V a r i a b l e s
1294C-----------------------------------------------
1295 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1296 . INDEX, SIZ,
1297 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1298 my_real rbuf(nspmd),si
1299 DATA msgoff/16009/
1300 DATA msgoff2/16010/
1301C-----------------------------------------------
1302C S o u r c e L i n e s
1303C-----------------------------------------------
1304 loc_proc = ispmd + 1
1305 siz=1
1306 IF(ispmd==0) THEN
1307 DO i = 2, nspmd
1308 msgtyp=msgoff
1309 CALL mpi_irecv(rbuf(i),siz,real,it_spmd(i),msgtyp,
1310 . spmd_comm_world,req_r(i-1),ierror)
1311 END DO
1312C
1313 DO n = 1, nspmd-1
1314 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1315 i = index+1
1316 s = min(s,rbuf(i))
1317 END DO
1318C
1319 DO i = 2, nspmd
1320 msgtyp=msgoff2
1321 CALL mpi_send(s,siz,real,it_spmd(i),
1322 . msgtyp,spmd_comm_world,ierror)
1323 END DO
1324 ELSE
1325 msgtyp = msgoff
1326 CALL mpi_send(s,siz,real,it_spmd(1),
1327 . msgtyp,spmd_comm_world,ierror)
1328
1329 msgtyp = msgoff2
1330 CALL mpi_recv(s,siz,real,it_spmd(1),msgtyp,
1331 . spmd_comm_world,status,ierror)
1332 END IF
1333C
1334 RETURN
1335#endif
1336 END
1337!||====================================================================
1338!|| spmd_max_i ../engine/source/mpi/implicit/imp_spmd.F
1339!||--- called by ------------------------------------------------------
1340!|| dim_kinmax ../engine/source/implicit/ind_glob_k.F
1341!|| dyna_ina ../engine/source/implicit/imp_dyna.f
1342!|| imp_check0 ../engine/source/implicit/imp_solv.F
1343!|| imp_checm0 ../engine/source/implicit/imp_solv.f
1344!|| imp_chkm ../engine/source/implicit/imp_solv.F
1345!|| imp_compabp ../engine/source/implicit/imp_solv.F
1346!|| imp_glob_khp ../engine/source/implicit/imp_glob_k.F
1347!|| imp_solv ../engine/source/implicit/imp_solv.F
1348!|| inivel_dt2 ../engine/source/loads/general/inivel/inivel_dt2.F90
1349!|| lin_solvh1 ../engine/source/implicit/lin_solv.f
1350!|| lin_solvih2 ../engine/source/implicit/lin_solv.f
1351!|| rbe2t1 ../engine/source/constraints/general/rbe2/rbe2f.F
1352!|| resol_init ../engine/source/engine/resol_init.F
1353!|| sms_diag_rbe2 ../engine/source/ams/sms_rbe2.f
1354!|| sms_rbe_cnds ../engine/source/ams/sms_rbe2.F
1355!|| sms_rbe_prec ../engine/source/ams/sms_rbe2.F
1356!|| spbrm_pre ../engine/source/implicit/imp_solv.F
1357!||--- calls -----------------------------------------------------
1358!||--- uses -----------------------------------------------------
1359!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1360!||====================================================================
1361 SUBROUTINE spmd_max_i(N)
1362C-----------------------------------------------
1363C I m p l i c i t T y p e s
1364C-----------------------------------------------
1365 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1366#include "implicit_f.inc"
1367C-----------------------------------------------
1368C C o m m o n B l o c k s
1369C-----------------------------------------------
1370#include "com01_c.inc"
1371#include "task_c.inc"
1372C-----------------------------------------------
1373C M e s s a g e P a s s i n g
1374C-----------------------------------------------
1375#include "spmd.inc"
1376C-----------------------------------------------
1377C D u m m y A r g u m e n t s
1378C-----------------------------------------------
1379 INTEGER N
1380#if defined(MPI)
1381C-----------------------------------------------
1382C L o c a l V a r i a b l e s
1383C-----------------------------------------------
1384 INTEGER I,L,MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1385 . INDEX, SIZ,
1386 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1387 integer
1388 . rbuf(nspmd),si
1389 DATA msgoff/16011/,msgoff2/16012/
1390C-----------------------------------------------
1391C S o u r c e L i n e s
1392C-----------------------------------------------
1393 loc_proc = ispmd + 1
1394 siz=1
1395 IF(ispmd==0) THEN
1396 DO i = 2, nspmd
1397 msgtyp=msgoff
1398 CALL mpi_irecv(rbuf(i),siz,mpi_integer,it_spmd(i),msgtyp,
1399 . spmd_comm_world,req_r(i-1),ierror)
1400 END DO
1401C
1402 DO l = 1, nspmd-1
1403 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1404 i = index+1
1405 n = max(n,rbuf(i))
1406 END DO
1407C
1408 DO i = 2, nspmd
1409 msgtyp=msgoff2
1410 CALL mpi_send(n,siz,mpi_integer,it_spmd(i),
1411 . msgtyp,spmd_comm_world,ierror)
1412 END DO
1413 ELSE
1414 msgtyp = msgoff
1415 CALL mpi_send(n,siz,mpi_integer,it_spmd(1),
1416 . msgtyp,spmd_comm_world,ierror)
1417
1418 msgtyp = msgoff2
1419 CALL mpi_recv(n,siz,mpi_integer,it_spmd(1),msgtyp,
1420 . spmd_comm_world,status,ierror)
1421 END IF
1422C
1423
1424 RETURN
1425#endif
1426 END
1427!||====================================================================
1428!|| spmd_min_i ../engine/source/mpi/implicit/imp_spmd.F
1429!||--- called by ------------------------------------------------------
1430!|| imp_solv ../engine/source/implicit/imp_solv.F
1431!||--- calls -----------------------------------------------------
1432!||--- uses -----------------------------------------------------
1433!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1434!||====================================================================
1435 SUBROUTINE spmd_min_i(N)
1436C-----------------------------------------------
1437C I m p l i c i t T y p e s
1438C-----------------------------------------------
1439 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1440#include "implicit_f.inc"
1441C-----------------------------------------------
1442C C o m m o n B l o c k s
1443C-----------------------------------------------
1444#include "com01_c.inc"
1445#include "task_c.inc"
1446C-----------------------------------------------
1447C M e s s a g e P a s s i n g
1448C-----------------------------------------------
1449#include "spmd.inc"
1450C-----------------------------------------------
1451C D u m m y A r g u m e n t s
1452C-----------------------------------------------
1453 INTEGER N
1454#if defined(MPI)
1455C-----------------------------------------------
1456C L o c a l V a r i a b l e s
1457C-----------------------------------------------
1458 INTEGER I,L,MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1459 . INDEX, SIZ,
1460 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1461 integer
1462 . rbuf(nspmd),si
1463 DATA msgoff/16013/,msgoff2/16014/
1464C-----------------------------------------------
1465C S o u r c e L i n e s
1466C-----------------------------------------------
1467 loc_proc = ispmd + 1
1468 siz=1
1469 IF(ispmd==0) THEN
1470 DO i = 2, nspmd
1471 msgtyp=msgoff
1472 CALL mpi_irecv(rbuf(i),siz,mpi_integer,it_spmd(i),msgtyp,
1473 . spmd_comm_world,req_r(i-1),ierror)
1474 END DO
1475C
1476 DO l = 1, nspmd-1
1477 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1478 i = index+1
1479 n = min(n,rbuf(i))
1480 END DO
1481C
1482 DO i = 2, nspmd
1483 msgtyp=msgoff2
1484 CALL mpi_send(n,siz,mpi_integer,it_spmd(i),
1485 . msgtyp,spmd_comm_world,ierror)
1486 END DO
1487 ELSE
1488 msgtyp = msgoff
1489 CALL mpi_send(n,siz,mpi_integer,it_spmd(1),
1490 . msgtyp,spmd_comm_world,ierror)
1491
1492 msgtyp = msgoff2
1493 CALL mpi_recv(n,siz,mpi_integer,it_spmd(1),msgtyp,
1494 . spmd_comm_world,status,ierror)
1495 END IF
1496C
1497 RETURN
1498#endif
1499 END
1500!||====================================================================
1501!|| spmd_inf_g ../engine/source/mpi/implicit/imp_spmd.F
1502!||--- called by ------------------------------------------------------
1503!|| imp_buck ../engine/source/implicit/imp_buck.F
1504!|| imp_mumps1 ../engine/source/implicit/imp_mumps.F
1505!|| pr_infok ../engine/source/implicit/imp_solv.F
1506!||--- calls -----------------------------------------------------
1507!||--- uses -----------------------------------------------------
1508!|| imp_frk ../engine/share/modules/impbufdef_mod.F
1509!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1510!||====================================================================
1511 SUBROUTINE spmd_inf_g(
1512 1 NDDL0 ,NZZK0 ,NDDL ,NZZK ,NNMAX ,
1513 1 NDDL0P ,NZZK0P ,NDDLP ,NZZKP ,NNMAXP )
1514C-----------------------------------------------
1515C M o d u l e s
1516C-----------------------------------------------
1517 USE imp_frk
1518C-----------------------------------------------
1519C I m p l i c i t T y p e s
1520C-----------------------------------------------
1521 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1522#include "implicit_f.inc"
1523C-----------------------------------------------
1524C C o m m o n B l o c k s
1525C-----------------------------------------------
1526#include "com01_c.inc"
1527#include "task_c.inc"
1528#include "impl1_c.inc"
1529C-----------------------------------------------
1530C M e s s a g e P a s s i n g
1531C-----------------------------------------------
1532#include "spmd.inc"
1533C-----------------------------------------------
1534C D u m m y A r g u m e n t s
1535C-----------------------------------------------
1536 INTEGER NDDL,NDDL0,NZZK,NZZK0,NNMAX,
1537 . NDDLP(*),NDDL0P(*),NZZKP(*),NZZK0P(*),NNMAXP(*)
1538#if defined(MPI)
1539C-----------------------------------------------
1540C L o c a l V a r i a b l e s
1541C-----------------------------------------------
1542 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
1543 . INDEX, SIZ,IBUF(2),
1544 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
1545 INTEGER
1546 . RBUF(9,NSPMD),SI
1547 DATA msgoff/16015/
1548 DATA msgoff2/16016/
1549C-----------------------------------------------
1550C S o u r c e L i n e s
1551C-----------------------------------------------
1552 loc_proc = ispmd + 1
1553 siz=9
1554 rbuf(1,1) = nddl0
1555 rbuf(2,1) = nzzk0
1556 rbuf(3,1) = nddl
1557 rbuf(4,1) = nzzk
1558 rbuf(5,1) = nnmax
1559 rbuf(6,1) = nddlfr-2*nddlfrb/3
1560 rbuf(7,1) = nzkfr
1561 rbuf(8,1) = len_v-2*nddlfrb1/3
1562 rbuf(9,1) = len_k-len_v
1563 IF(ispmd==0) THEN
1564 DO i = 2, nspmd
1565 msgtyp=msgoff
1566 CALL mpi_irecv(rbuf(1,i),siz,mpi_integer,it_spmd(i),msgtyp,
1567 . spmd_comm_world,req_r(i-1),ierror)
1568 END DO
1569 nddl0p(1)=rbuf(1,1)
1570 nzzk0p(1)=rbuf(2,1)
1571 nddlp(1)=rbuf(3,1)
1572 nzzkp(1)=rbuf(4,1)
1573 nnmaxp(1)=rbuf(5,1)
1574C
1575 DO n = 1, nspmd-1
1576 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
1577 i = index+1
1578 nddl0p(i)=rbuf(1,i)
1579 nzzk0p(i)=rbuf(2,i)
1580 nddlp(i)=rbuf(3,i)
1581 nzzkp(i)=rbuf(4,i)
1582 nnmaxp(i)=rbuf(5,i)
1583 rbuf(1,1) = rbuf(1,1) + rbuf(1,i)
1584 rbuf(2,1) = rbuf(2,1) + rbuf(2,i)
1585 rbuf(3,1) = rbuf(3,1) + rbuf(3,i)
1586 rbuf(4,1) = rbuf(4,1) + rbuf(4,i)
1587 rbuf(5,1) = max(rbuf(5,1),rbuf(5,i))
1588 rbuf(6,1) = rbuf(6,1) + rbuf(6,i)
1589 rbuf(7,1) = rbuf(7,1) + rbuf(7,i)
1590 rbuf(8,1) = rbuf(8,1) + rbuf(8,i)
1591 rbuf(9,1) = rbuf(9,1) + rbuf(9,i)
1592 END DO
1593C
1594 nddl0 = rbuf(1,1)-nddlfrb
1595 nzzk0 = rbuf(2,1)-rbuf(7,1)/2
1596 nddl = rbuf(3,1)-nddlfrb1
1597 nzzk = rbuf(4,1)-rbuf(9,1)/2
1598 nnmax = rbuf(5,1)
1599 ibuf(1) = nddl
1600 ibuf(2) = nzzk
1601 DO i = 2, nspmd
1602 msgtyp=msgoff2
1603 CALL mpi_send(ibuf ,2,mpi_integer,it_spmd(i),
1604 . msgtyp,spmd_comm_world,ierror)
1605 END DO
1606C
1607 ELSE
1608 msgtyp = msgoff
1609 CALL mpi_send(rbuf,siz,mpi_integer,it_spmd(1),
1610 . msgtyp,spmd_comm_world,ierror)
1611 msgtyp = msgoff2
1612 CALL mpi_recv(ibuf,2,mpi_integer,it_spmd(1),msgtyp,
1613 . spmd_comm_world,status,ierror)
1614 nddl = ibuf(1)
1615 nzzk = ibuf(2)
1616 END IF
1617 nddl_g = nddl
1618 nnzk_g = nzzk
1619 IF (l_lim==0) l_lim = nddl_g
1620C
1621 RETURN
1622#endif
1623 END
1624!||====================================================================
1625!|| spmd_sumf_v ../engine/source/mpi/implicit/imp_spmd.f
1626!||--- called by ------------------------------------------------------
1627!|| ext_rhs ../engine/source/implicit/upd_glob_k.F
1628!|| get_fext ../engine/source/implicit/imp_solv.F
1629!|| imp_check0 ../engine/source/implicit/imp_solv.F
1630!|| imp_frfv ../engine/source/mpi/implicit/imp_fri.F
1631!|| imp_fri ../engine/source/mpi/implicit/imp_fri.f
1632!|| lin_solvh1 ../engine/source/implicit/lin_solv.F
1633!|| mav_ltgh ../engine/source/implicit/produt_v.F
1634!|| mav_lth ../engine/source/implicit/produt_v.F
1635!|| mav_lth0 ../engine/source/implicit/produt_v.F
1636!|| mav_ltp ../engine/source/implicit/produt_v.F
1637!|| mmv_lh ../engine/source/implicit/produt_v.f
1638!|| mmv_lth ../engine/source/implicit/produt_v.F
1639!|| prec_solvgh ../engine/source/implicit/prec_solv.f
1640!|| prec_solvh ../engine/source/implicit/prec_solv.F
1641!|| prec_solvp ../engine/source/implicit/prec_solv.F
1642!|| rer02 ../engine/source/implicit/upd_glob_k.f
1643!|| upd_rhs ../engine/source/implicit/upd_glob_k.F
1644!||--- calls -----------------------------------------------------
1645!||--- uses -----------------------------------------------------
1646!|| imp_frk ../engine/share/modules/impbufdef_mod.F
1647!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1648!||====================================================================
1649 SUBROUTINE spmd_sumf_v(V )
1650C-----------------------------------------------
1651C M o d u l e s
1652C-----------------------------------------------
1653 USE imp_frk
1654C-----------------------------------------------
1655C I m p l i c i t T y p e s
1656C-----------------------------------------------
1657 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1658#include "implicit_f.inc"
1659C-----------------------------------------------
1660C C o m m o n B l o c k s
1661C-----------------------------------------------
1662#include "com01_c.inc"
1663#include "task_c.inc"
1664C-----------------------------------------------
1665C M e s s a g e P a s s i n g
1666C-----------------------------------------------
1667#include "spmd.inc"
1668C-----------------------------------------------
1669C D u m m y A r g u m e n t s
1670C-----------------------------------------------
1671 my_real v(*)
1672#if defined(MPI) && defined(MUMPS5)
1673C-----------------------------------------------
1674C L o c a l V a r i a b l e s
1675C-----------------------------------------------
1676 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
1677 . SIZ,J,K,L,ND,ID,
1678 . STATUS(MPI_STATUS_SIZE),
1679 . REQ_R(NSPMD),REQ_S(NSPMD)
1680 my_real
1681 . rbuf(len_v), sbuf(len_v)
1682 DATA msgoff/16017/
1683C-----------------------------------------------
1684C S o u r c e L i n e s
1685C-----------------------------------------------
1686 IF (nddlfr<=0) RETURN
1687C
1688 loc_proc = ispmd + 1
1689C
1690 l=1
1691 DO i=1,nspmd
1692 siz = nd_fr(i)
1693 IF(siz>0)THEN
1694 msgtyp = msgoff
1695 CALL mpi_irecv(
1696 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
1697 g spmd_comm_world,req_r(i),ierror)
1698 l = l+ nd_fr(i)
1699 ENDIF
1700 END DO
1701C
1702C preparation envoi a proc I
1703C--------------------------------------------------------------------
1704 l = 0
1705 DO i=1,nspmd
1706 IF(nd_fr(i)>0)THEN
1707 DO j=1,nd_fr(i)
1708 id = j + l
1709 nd=ifr2k(id)
1710 sbuf(id) = v(nd)
1711 ENDDO
1712 l = l +nd_fr(i)
1713 ENDIF
1714 ENDDO
1715C
1716C echange messages
1717C--------------------------------------------------------------------
1718 l = 1
1719 DO i=1,nspmd
1720 siz = nd_fr(i)
1721 IF(siz>0)THEN
1722 msgtyp = msgoff
1723 CALL mpi_isend(
1724 s sbuf(l),siz,real,it_spmd(i),msgtyp,
1725 g spmd_comm_world,req_s(i),ierror)
1726 l = l +nd_fr(i)
1727 ENDIF
1728 ENDDO
1729C
1730C assemblage
1731C--------------------------------------------------------------------
1732 l = 0
1733 DO i=1,nspmd
1734 IF(nd_fr(i)>0)THEN
1735 CALL mpi_wait(req_r(i),status,ierror)
1736 DO j=1,nd_fr(i)
1737 id = j + l
1738 nd=ifr2k(id)
1739 v(nd) = v(nd) + rbuf(id)
1740 ENDDO
1741 l = l +nd_fr(i)
1742 ENDIF
1743 ENDDO
1744C
1745C wait terminaison isend
1746C--------------------------------------------------------------------
1747 DO i = 1, nspmd
1748 IF(nd_fr(i)>0)THEN
1749 CALL mpi_wait(req_s(i),status,ierror)
1750 ENDIF
1751 ENDDO
1752C
1753 RETURN
1754#endif
1755 END
1756
1757!||====================================================================
1758!|| spmd_sumfc_v ../engine/source/mpi/implicit/imp_spmd.F
1759!||--- called by ------------------------------------------------------
1760!|| imp_pcgh ../engine/source/implicit/imp_pcg.F
1761!||--- calls -----------------------------------------------------
1762!||--- uses -----------------------------------------------------
1763!|| imp_frk ../engine/share/modules/impbufdef_mod.F
1764!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1765!||====================================================================
1766 SUBROUTINE spmd_sumfc_v(VGAT,VSCA,INDEX,LCOM)
1767C specific communication with compacted V
1768C-----------------------------------------------
1769C M o d u l e s
1770C-----------------------------------------------
1771 USE imp_frk
1772C-----------------------------------------------
1773C I m p l i c i t T y p e s
1774C-----------------------------------------------
1775 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1776#include "implicit_f.inc"
1777C-----------------------------------------------
1778C C o m m o n B l o c k s
1779C-----------------------------------------------
1780#include "com01_c.inc"
1781#include "task_c.inc"
1782C-----------------------------------------------
1783C M e s s a g e P a s s i n g
1784C-----------------------------------------------
1785#include "spmd.inc"
1786C-----------------------------------------------
1787C D u m m y A r g u m e n t s
1788C-----------------------------------------------
1789 INTEGER LCOM, INDEX(LCOM)
1790 my_real
1791 . VGAT(LCOM), VSCA(LCOM)
1792#if defined(MPI)
1793C-----------------------------------------------
1794C L o c a l V a r i a b l e s
1795C-----------------------------------------------
1796 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
1797 . SIZ,J,K,L,ND,ID,
1798 . STATUS(MPI_STATUS_SIZE),
1799 . REQ_R(NSPMD),REQ_S(NSPMD)
1800 DATA MSGOFF/16018/
1801C-----------------------------------------------
1802C S o u r c e L i n e s
1803C-----------------------------------------------
1804 IF (nddlfr<=0) RETURN
1805C
1806 loc_proc = ispmd + 1
1807C
1808 l=1
1809 DO i=1,nspmd
1810 siz = nd_fr(i)
1811 IF(siz>0)THEN
1812 msgtyp = msgoff
1813 CALL mpi_irecv(
1814 s vsca(l),siz ,real,it_spmd(i),msgtyp,
1815 g spmd_comm_world,req_r(i),ierror)
1816 l = l + siz
1817 ENDIF
1818 END DO
1819C
1820 l = 1
1821 DO i=1,nspmd
1822 siz = nd_fr(i)
1823 IF(siz>0)THEN
1824 msgtyp = msgoff
1825 CALL mpi_isend(
1826 s vgat(l),siz,real,it_spmd(i),msgtyp,
1827 g spmd_comm_world,req_s(i),ierror)
1828 l = l + siz
1829 ENDIF
1830 ENDDO
1831C
1832 DO i = 1, nspmd
1833 IF(nd_fr(i)>0)THEN
1834 CALL mpi_wait(req_r(i),status,ierror)
1835 CALL mpi_wait(req_s(i),status,ierror)
1836 ENDIF
1837 ENDDO
1838C
1839C Compactage VSCAT sur CPU
1840C
1841 DO i = 1, lcom
1842 l=index(i)
1843 IF(l /= 0)THEN
1844 vsca(l)=vsca(l)+vsca(i)
1845 END IF
1846 END DO
1847C
1848 RETURN
1849#endif
1850 END
1851
1852!||====================================================================
1853!|| spmd_sumf_k ../engine/source/mpi/implicit/imp_spmd.F
1854!||--- called by ------------------------------------------------------
1855!|| lin_solvh1 ../engine/source/implicit/lin_solv.F
1856!|| lin_solvih2 ../engine/source/implicit/lin_solv.F
1857!|| upd_aspc ../engine/source/constraints/general/bcs/bc_imp0.F
1858!||--- calls -----------------------------------------------------
1859!||--- uses -----------------------------------------------------
1860!|| imp_frk ../engine/share/modules/impbufdef_mod.F
1861!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
1862!||====================================================================
1863 SUBROUTINE spmd_sumf_k(DIAG_K ,L_K )
1864C-----------------------------------------------
1865C M o d u l e s
1866C-----------------------------------------------
1867 USE imp_frk
1868C-----------------------------------------------
1869C I m p l i c i t T y p e s
1870C-----------------------------------------------
1871 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1872#include "implicit_f.inc"
1873C-----------------------------------------------
1874C C o m m o n B l o c k s
1875C-----------------------------------------------
1876#include "com01_c.inc"
1877#include "task_c.inc"
1878C-----------------------------------------------
1879C M e s s a g e P a s s i n g
1880C-----------------------------------------------
1881#include "spmd.inc"
1882C-----------------------------------------------
1883C D u m m y A r g u m e n t s
1884C-----------------------------------------------
1885 my_real
1886 . diag_k(*),l_k(*)
1887#if defined(MPI)
1888C-----------------------------------------------
1889C L o c a l V a r i a b l e s
1890C-----------------------------------------------
1891 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
1892 . SIZ(NSPMD),J,K,L,ND,ID,JD,
1893 . STATUS(MPI_STATUS_SIZE),IAD,JAD,IAD2,
1894 . REQ_R(NSPMD),REQ_S(NSPMD)
1895 my_real
1896 . rbuf(len_k), sbuf(len_k)
1897 DATA msgoff/16019/
1898C-----------------------------------------------
1899C S o u r c e L i n e s
1900C-----------------------------------------------
1901 IF (nddlfr<=0) RETURN
1902C
1903 loc_proc = ispmd + 1
1904C
1905 iad=0
1906 l=1
1907 DO i=1,nspmd
1908 siz(i) = nd_fr(i)+iadfr(nd_fr(i)+iad+1)-iadfr(iad+1)
1909 IF(siz(i)>0)THEN
1910 msgtyp = msgoff
1911 CALL mpi_irecv(
1912 . rbuf(l),siz(i),real,it_spmd(i),msgtyp,
1913 . spmd_comm_world,req_r(i),ierror)
1914 l=l+siz(i)
1915 ENDIF
1916 iad=iad+nd_fr(i)+1
1917 END DO
1918C
1919C preparation envoi a proc I
1920C--------------------------------------------------------------------
1921 iad=0
1922 l=1
1923 iad2=0
1924 jad=0
1925 DO i=1,nspmd
1926 IF(siz(i)>0)THEN
1927 DO j=1,nd_fr(i)
1928 nd=ifr2k(j+iad2)
1929 sbuf(l)= diag_k(nd)
1930 l = l + 1
1931 id = j + iad
1932 DO k=iadfr(id),iadfr(id+1)-1
1933 jd=jfr2k(k+jad)
1934 sbuf(l) = l_k(jd)
1935 l = l + 1
1936 ENDDO
1937 ENDDO
1938 iad2 =iad2 + nd_fr(i)
1939 jad =jad +iadfr(iad+nd_fr(i)+1)-iadfr(iad+1)
1940 ENDIF
1941 iad =iad + nd_fr(i)+1
1942 ENDDO
1943C
1944C echange messages
1945C--------------------------------------------------------------------
1946 l=1
1947 DO i=1,nspmd
1948 IF(siz(i)>0)THEN
1949 msgtyp = msgoff
1950 CALL mpi_isend(
1951 s sbuf(l),siz(i),real,it_spmd(i),msgtyp,
1952 g spmd_comm_world,req_s(i),ierror)
1953 l = l + siz(i)
1954 ENDIF
1955 ENDDO
1956C
1957C assemblage
1958C--------------------------------------------------------------------
1959 iad=0
1960 l=1
1961 iad2=0
1962 jad=0
1963 DO i=1,nspmd
1964 IF(siz(i)>0)THEN
1965 CALL mpi_wait(req_r(i),status,ierror)
1966 DO j=1,nd_fr(i)
1967 nd=ifr2k(j+iad2)
1968 diag_k(nd)=diag_k(nd)+rbuf(l)
1969 l = l + 1
1970 id = j + iad
1971 DO k=iadfr(id),iadfr(id+1)-1
1972 jd=jfr2k(k+jad)
1973 l_k(jd)=l_k(jd)+rbuf(l)
1974 l = l + 1
1975 ENDDO
1976 ENDDO
1977 iad2 =iad2 + nd_fr(i)
1978 jad =jad +iadfr(iad+nd_fr(i)+1)-iadfr(iad+1)
1979 ENDIF
1980 iad =iad + nd_fr(i)+1
1981 ENDDO
1982C
1983C wait terminaison isend
1984C--------------------------------------------------------------------
1985 DO i = 1, nspmd
1986 IF(siz(i)>0)THEN
1987 CALL mpi_wait(req_s(i),status,ierror)
1988 ENDIF
1989 ENDDO
1990C
1991 RETURN
1992#endif
1993 END
1994!||====================================================================
1995!|| spmd_inis ../engine/source/mpi/implicit/imp_spmd.F
1996!||--- called by ------------------------------------------------------
1997!|| imp_frsl ../engine/source/mpi/implicit/imp_fri.F
1998!||--- calls -----------------------------------------------------
1999!||--- uses -----------------------------------------------------
2000!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2001!||====================================================================
2002 SUBROUTINE spmd_inis(IAD_S,IAD_R)
2003C-----------------------------------------------
2004C I m p l i c i t T y p e s
2005C-----------------------------------------------
2006 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2007#include "implicit_f.inc"
2008C-----------------------------------------------
2009C C o m m o n B l o c k s
2010C-----------------------------------------------
2011#include "com01_c.inc"
2012#include "task_c.inc"
2013C-----------------------------------------------
2014C M e s s a g e P a s s i n g
2015C-----------------------------------------------
2016#include "spmd.inc"
2017C-----------------------------------------------
2018C D u m m y A r g u m e n t s
2019C-----------------------------------------------
2020 INTEGER IAD_R(*),IAD_S(*)
2021#if defined(MPI)
2022C-----------------------------------------------
2023C L o c a l V a r i a b l e s
2024C-----------------------------------------------
2025 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
2026 . STATUS(MPI_STATUS_SIZE),
2027 . REQ_R(NSPMD),REQ_S(NSPMD)
2028 INTEGER
2029 . RBUF(NSPMD), SBUF(NSPMD)
2030 DATA msgoff/16020/
2031C-----------------------------------------------
2032C S o u r c e L i n e s
2033C-----------------------------------------------
2034C----creer IAD_R (taille de recevoir)a partir de IAD_S------
2035 loc_proc = ispmd + 1
2036C------recive--
2037 DO i=1,nspmd
2038 msgtyp = msgoff
2039 IF(i/=loc_proc)THEN
2040 CALL mpi_irecv(
2041 s rbuf(i),1 ,mpi_integer,it_spmd(i),msgtyp,
2042 g spmd_comm_world,req_r(i),ierror)
2043 ENDIF
2044 END DO
2045C
2046C echange messages
2047C--------------------------------------------------------------------
2048 DO i=1,nspmd
2049 IF(i/=loc_proc)THEN
2050 msgtyp = msgoff
2051 sbuf(i) = iad_s(i+1)-iad_s(i)
2052 CALL mpi_isend(
2053 s sbuf(i),1,mpi_integer,it_spmd(i),msgtyp,
2054 g spmd_comm_world,req_s(i),ierror)
2055 ENDIF
2056 ENDDO
2057C
2058C assemblage
2059C--------------------------------------------------------------------
2060 iad_r(1)=1
2061 DO i=1,nspmd
2062 IF(i/=loc_proc)THEN
2063 CALL mpi_wait(req_r(i),status,ierror)
2064 iad_r(i+1) = iad_r(i)+rbuf(i)
2065 ELSE
2066 iad_r(i+1) = iad_r(i)
2067 ENDIF
2068 ENDDO
2069C
2070C wait terminaison isend
2071C--------------------------------------------------------------------
2072 DO i = 1, nspmd
2073 IF(i/=loc_proc)THEN
2074 CALL mpi_wait(req_s(i),status,ierror)
2075 ENDIF
2076 ENDDO
2077C
2078 RETURN
2079#endif
2080 END
2081!||====================================================================
2082!|| spmd_inisl ../engine/source/mpi/implicit/imp_spmd.f
2083!||--- called by ------------------------------------------------------
2084!|| imp_frsl ../engine/source/mpi/implicit/imp_fri.F
2085!||--- calls -----------------------------------------------------
2086!||--- uses -----------------------------------------------------
2087!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2088!||====================================================================
2089 SUBROUTINE spmd_inisl(NBINTC,INBSL)
2090C-----------------------------------------------
2091C I m p l i c i t T y p e s
2092C-----------------------------------------------
2093 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2094#include "implicit_f.inc"
2095C-----------------------------------------------
2096C C o m m o n B l o c k s
2097C-----------------------------------------------
2098#if defined(MUMPS5)
2099#include "dmumps_struc.h"
2100#endif
2101#include "com01_c.inc"
2102#include "task_c.inc"
2103C-----------------------------------------------
2104C M e s s a g e P a s s i n g
2105C-----------------------------------------------
2106#include "spmd.inc"
2107C-----------------------------------------------
2108C D u m m y A r g u m e n t s
2109C-----------------------------------------------
2110 INTEGER NBINTC,INBSL(NBINTC,*)
2111#if defined(MPI) && defined(MUMPS5)
2112C-----------------------------------------------
2113C L o c a l V a r i a b l e s
2114C-----------------------------------------------
2115 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
2116 . STATUS(MPI_STATUS_SIZE),
2117 . REQ_R(NSPMD),REQ_S(NSPMD),SIZ,L,J,IAD
2118 INTEGER
2119 . RBUF(NSPMD*NBINTC), SBUF(NSPMD*NBINTC)
2120 DATA msgoff/16021/
2121C-----------------------------------------------
2122C S o u r c e L i n e s
2123C-----------------------------------------------
2124C----creer IAD_R (taille de recevoir)a partir de IAD_S------
2125 loc_proc = ispmd + 1
2126 siz = nbintc
2127C------recive--
2128 l = 1
2129 DO i=1,nspmd
2130 msgtyp = msgoff
2131 IF(i/=loc_proc)THEN
2132 CALL mpi_irecv(
2133 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
2134 g spmd_comm_world,req_r(i),ierror)
2135 l = l + siz
2136 ENDIF
2137 END DO
2138C
2139C echange messages
2140C--------------------------------------------------------------------
2141 l = 1
2142 DO i=1,nspmd
2143 IF(i/=loc_proc)THEN
2144 msgtyp = msgoff
2145 DO j = 1, nbintc
2146 sbuf(l+j-1) = inbsl(j,i)
2147 ENDDO
2148 CALL mpi_isend(
2149 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2150 g spmd_comm_world,req_s(i),ierror)
2151 l = l + siz
2152 ENDIF
2153 ENDDO
2154C
2155C assemblage
2156C--------------------------------------------------------------------
2157 l = 0
2158 DO i=1,nspmd
2159 IF(i/=loc_proc)THEN
2160 CALL mpi_wait(req_r(i),status,ierror)
2161 DO j = 1, nbintc
2162 inbsl(j,i) = rbuf(l+j)
2163 ENDDO
2164 l = l + siz
2165 ENDIF
2166 ENDDO
2167C
2168C wait terminaison isend
2169C--------------------------------------------------------------------
2170 DO i = 1, nspmd
2171 IF(i/=loc_proc)THEN
2172 CALL mpi_wait(req_s(i),status,ierror)
2173 ENDIF
2174 ENDDO
2175C
2176 RETURN
2177#endif
2178 END
2179!||====================================================================
2180!|| spmd_ifc1 ../engine/source/mpi/implicit/imp_spmd.F
2181!||--- called by ------------------------------------------------------
2182!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
2183!|| imp_frki ../engine/source/mpi/implicit/imp_fri.F
2184!||--- calls -----------------------------------------------------
2185!||--- uses -----------------------------------------------------
2186!|| imp_intm ../engine/share/modules/imp_intm.F
2187!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2188!||====================================================================
2189 SUBROUTINE spmd_ifc1(SSIZE ,RSIZE,KSS)
2190C-----------------------------------------------
2191C M o d u l e s
2192C-----------------------------------------------
2193 USE imp_intm
2194C-----------------------------------------------
2195C I m p l i c i t T y p e s
2196C-----------------------------------------------
2197 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2198#include "implicit_f.inc"
2199C-----------------------------------------------
2200C C o m m o n B l o c k s
2201C-----------------------------------------------
2202#if defined(MUMPS5)
2203#include "dmumps_struc.h"
2204#endif
2205#include "com01_c.inc"
2206#include "task_c.inc"
2207C-----------------------------------------------
2208C M e s s a g e P a s s i n g
2209C-----------------------------------------------
2210#include "spmd.inc"
2211C-----------------------------------------------
2212C D u m m y A r g u m e n t s
2213C-----------------------------------------------
2214 INTEGER SSIZE ,RSIZE
2215 my_real
2216 . KSS(6,RSIZE)
2217#if defined(MPI) && defined(MUMPS5)
2218C-----------------------------------------------
2219C L o c a l V a r i a b l e s
2220C-----------------------------------------------
2221 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
2222 . SIZ,J,L,SIZE,STATUS(MPI_STATUS_SIZE),
2223 . REQ_R(NSPMD),REQ_S(NSPMD)
2224 my_real
2225 . RBUF(7*RSIZE), SBUF(7*SSIZE)
2226 DATA msgoff/16022/
2227C-----------------------------------------------
2228C S o u r c e L i n e s
2229C-----------------------------------------------
2230 loc_proc = ispmd + 1
2231C ------com. de numero nodes SECONDARYs et diag_Kss-----
2232C au l appel, SSIZE=IAD_SREM(NSPMD+1)-1
2233C RSIZE=IAD_SL(NSPMD+1)-1
2234C------recive--
2235 size=7
2236 l=1
2237 DO i=1,nspmd
2238 IF(i/=loc_proc)THEN
2239 siz = (iad_sl(i+1)-iad_sl(i))*SIZE
2240 IF(siz>0)THEN
2241 msgtyp = msgoff
2242 CALL mpi_irecv(
2243 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
2244 g spmd_comm_world,req_r(i),ierror)
2245 l = l+siz
2246 ENDIF
2247 ENDIF
2248 END DO
2249C
2250C preparation envoi a proc I
2251C--------------------------------------------------------------------
2252 l=1
2253 DO i=1,nspmd
2254 IF(i/=loc_proc)THEN
2255 DO j=iad_srem(i),iad_srem(i+1)-1
2256 sbuf(l)=fr_srem(j)
2257 sbuf(l+1)=ffi(1,j)
2258 sbuf(l+2)=ffi(2,j)
2259 sbuf(l+3)=ffi(3,j)
2260 sbuf(l+4)=dfi(1,j)
2261 sbuf(l+5)=dfi(2,j)
2262 sbuf(l+6)=dfi(3,j)
2263 l = l+SIZE
2264 ENDDO
2265 ENDIF
2266 ENDDO
2267C
2268C echange messages
2269C--------------------------------------------------------------------
2270 l=1
2271 DO i=1,nspmd
2272 IF(i/=loc_proc)THEN
2273 siz = (iad_srem(i+1)-iad_srem(i))*SIZE
2274 IF(siz>0)THEN
2275 msgtyp = msgoff
2276 CALL mpi_isend(
2277 s sbuf(l),siz,real,it_spmd(i),msgtyp,
2278 g spmd_comm_world,req_s(i),ierror)
2279 l = l+siz
2280 ENDIF
2281 ENDIF
2282 ENDDO
2283C
2284C assemblage
2285C--------------------------------------------------------------------
2286 l=1
2287 DO i=1,nspmd
2288 IF(i/=loc_proc.AND.iad_sl(i+1)>iad_sl(i))THEN
2289 CALL mpi_wait(req_r(i),status,ierror)
2290 DO j=iad_sl(i),iad_sl(i+1)-1
2291 isl(j) = int(rbuf(l))
2292 kss(1,j) = rbuf(l+1)
2293 kss(2,j) = rbuf(l+2)
2294 kss(3,j) = rbuf(l+3)
2295 kss(4,j) = rbuf(l+4)
2296 kss(5,j) = rbuf(l+5)
2297 kss(6,j) = rbuf(l+6)
2298 l = l+SIZE
2299 ENDDO
2300 ENDIF
2301 ENDDO
2302C
2303C wait terminaison isend
2304C--------------------------------------------------------------------
2305 DO i = 1, nspmd
2306 IF(iad_srem(i+1)-iad_srem(i)>0)THEN
2307 CALL mpi_wait(req_s(i),status,ierror)
2308 ENDIF
2309 ENDDO
2310C
2311 RETURN
2312#endif
2313 END
2314
2315!||====================================================================
2316!|| spmd_ifcd ../engine/source/mpi/implicit/imp_spmd.F
2317!||--- called by ------------------------------------------------------
2318!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2319!|| int_matvp ../engine/source/implicit/imp_int_k.F
2320!||--- calls -----------------------------------------------------
2321!||--- uses -----------------------------------------------------
2322!|| imp_intm ../engine/share/modules/imp_intm.F
2323!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2324!||====================================================================
2325 SUBROUTINE spmd_ifcd(D_IMP,SSIZE ,RSIZE)
2326C-----------------------------------------------
2327C M o d u l e s
2328C-----------------------------------------------
2329 USE imp_intm
2330C-----------------------------------------------
2331C I m p l i c i t T y p e s
2332C-----------------------------------------------
2333 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2334#include "implicit_f.inc"
2335C-----------------------------------------------
2336C C o m m o n B l o c k s
2337C-----------------------------------------------
2338#include "com01_c.inc"
2339#include "task_c.inc"
2340C-----------------------------------------------
2341C M e s s a g e P a s s i n g
2342C-----------------------------------------------
2343#include "spmd.inc"
2344C-----------------------------------------------
2345C D u m m y A r g u m e n t s
2346C-----------------------------------------------
2347 INTEGER SSIZE ,RSIZE
2348 my_real
2349 . D_IMP(3,*)
2350#if defined(MPI) && defined(MUMPS5)
2351C-----------------------------------------------
2352C L o c a l V a r i a b l e s
2353C-----------------------------------------------
2354 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
2355 . SIZ,J,L,SIZE,STATUS(MPI_STATUS_SIZE),
2356 . REQ_R(NSPMD),REQ_S(NSPMD)
2357 my_real
2358 . RBUF(3*RSIZE), SBUF(3*SSIZE)
2359 DATA msgoff/16023/
2360C-----------------------------------------------
2361C S o u r c e L i n e s
2362C-----------------------------------------------
2363 loc_proc = ispmd + 1
2364C ------ com. de D nodes SECONDARYs -----
2365C------recive--
2366 size=3
2367 l=1
2368 DO i=1,nspmd
2369 IF(i/=loc_proc)THEN
2370 siz = (iad_srem(i+1)-iad_srem(i))*SIZE
2371 IF(siz>0)THEN
2372 msgtyp = msgoff
2373 CALL mpi_irecv(
2374 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
2375 g spmd_comm_world,req_r(i),ierror)
2376 l = l+siz
2377 ENDIF
2378 ENDIF
2379 END DO
2380C
2381C preparation envoi a proc I
2382C--------------------------------------------------------------------
2383 l=1
2384 DO i=1,nspmd
2385 IF(i/=loc_proc)THEN
2386 DO j=iad_sl(i),iad_sl(i+1)-1
2387 nod=isl(j)
2388 sbuf(l) =d_imp(1,nod)
2389 sbuf(l+1)=d_imp(2,nod)
2390 sbuf(l+2)=d_imp(3,nod)
2391 l = l+SIZE
2392 ENDDO
2393 ENDIF
2394 ENDDO
2395C
2396C echange messages
2397C--------------------------------------------------------------------
2398 l=1
2399 DO i=1,nspmd
2400 IF(i/=loc_proc)THEN
2401 siz = (iad_sl(i+1)-iad_sl(i))*SIZE
2402 IF(siz>0)THEN
2403 msgtyp = msgoff
2404 CALL mpi_isend(
2405 s sbuf(l),siz,real,it_spmd(i),msgtyp,
2406 g spmd_comm_world,req_s(i),ierror)
2407 l = l+siz
2408 ENDIF
2409 ENDIF
2410 ENDDO
2411C
2412C assemblage
2413C--------------------------------------------------------------------
2414 l=1
2415 DO i=1,nspmd
2416 IF(i/=loc_proc.AND.iad_srem(i+1)>iad_srem(i))THEN
2417 CALL mpi_wait(req_r(i),status,ierror)
2418 DO j=iad_srem(i),iad_srem(i+1)-1
2419 dfi(1,j) = rbuf(l)
2420 dfi(2,j) = rbuf(l+1)
2421 dfi(3,j) = rbuf(l+2)
2422 l = l+SIZE
2423 ENDDO
2424 ENDIF
2425 ENDDO
2426C
2427C wait terminaison isend
2428C--------------------------------------------------------------------
2429 DO i = 1, nspmd
2430 IF(iad_sl(i+1)-iad_sl(i)>0)THEN
2431 CALL mpi_wait(req_s(i),status,ierror)
2432 ENDIF
2433 ENDDO
2434C
2435 RETURN
2436#endif
2437 END
2438
2439!||====================================================================
2440!|| spmd_ifcf ../engine/source/mpi/implicit/imp_spmd.F
2441!||--- called by ------------------------------------------------------
2442!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
2443!|| int_matvp ../engine/source/implicit/imp_int_k.F
2444!||--- calls -----------------------------------------------------
2445!||--- uses -----------------------------------------------------
2446!|| imp_intm ../engine/share/modules/imp_intm.F
2447!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2448!||====================================================================
2449 SUBROUTINE spmd_ifcf(F_IMP,SSIZE ,RSIZE)
2450C-----------------------------------------------
2451C M o d u l e s
2452C-----------------------------------------------
2453 USE imp_intm
2454C-----------------------------------------------
2455C I m p l i c i t T y p e s
2456C-----------------------------------------------
2457 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2458#include "implicit_f.inc"
2459C-----------------------------------------------
2460C C o m m o n B l o c k s
2461C-----------------------------------------------
2462#if defined(MUMPS5)
2463#include "dmumps_struc.h"
2464#endif
2465#include "com01_c.inc"
2466#include "task_c.inc"
2467C-----------------------------------------------
2468C M e s s a g e P a s s i n g
2469C-----------------------------------------------
2470#include "spmd.inc"
2471C-----------------------------------------------
2472C D u m m y A r g u m e n t s
2473C-----------------------------------------------
2474 INTEGER SSIZE ,RSIZE
2475 my_real
2476 . F_IMP(3,*)
2477#if defined(MPI) && defined(MUMPS5)
2478C-----------------------------------------------
2479C L o c a l V a r i a b l e s
2480C-----------------------------------------------
2481 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
2482 . SIZ,J,L,SIZE,STATUS(MPI_STATUS_SIZE),
2483 . REQ_R(NSPMD),REQ_S(NSPMD)
2484 my_real
2485 . RBUF(3*RSIZE), SBUF(3*SSIZE)
2486 DATA msgoff/16024/
2487C-----------------------------------------------
2488C S o u r c e L i n e s
2489C-----------------------------------------------
2490 loc_proc = ispmd + 1
2491C ------ comm. de F nodes SECONDARYs -----
2492C------recive--
2493 size=3
2494 l=1
2495 DO i=1,nspmd
2496 IF(i/=loc_proc)THEN
2497 siz = (iad_sl(i+1)-iad_sl(i))*SIZE
2498 IF(siz>0)THEN
2499 msgtyp = msgoff
2500 CALL mpi_irecv(
2501 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
2502 g spmd_comm_world,req_r(i),ierror)
2503 l = l+siz
2504 ENDIF
2505 ENDIF
2506 END DO
2507C
2508C preparation envoi a proc I
2509C--------------------------------------------------------------------
2510 l=1
2511 DO i=1,nspmd
2512 IF(i/=loc_proc)THEN
2513 DO j=iad_srem(i),iad_srem(i+1)-1
2514 sbuf(l) =ffi(1,j)
2515 sbuf(l+1)=ffi(2,j)
2516 sbuf(l+2)=ffi(3,j)
2517 l = l+SIZE
2518 ENDDO
2519 ENDIF
2520 ENDDO
2521C
2522C echange messages
2523C--------------------------------------------------------------------
2524 l=1
2525 DO i=1,nspmd
2526 IF(i/=loc_proc)THEN
2527 siz = (iad_srem(i+1)-iad_srem(i))*SIZE
2528 IF(siz>0)THEN
2529 msgtyp = msgoff
2530 CALL mpi_isend(
2531 s sbuf(l),siz,real,it_spmd(i),msgtyp,
2532 g spmd_comm_world,req_s(i),ierror)
2533 l = l+siz
2534 ENDIF
2535 ENDIF
2536 ENDDO
2537C
2538C assemblage
2539C--------------------------------------------------------------------
2540 l=1
2541 DO i=1,nspmd
2542 IF(i/=loc_proc.AND.iad_sl(i+1)>iad_sl(i))THEN
2543 CALL mpi_wait(req_r(i),status,ierror)
2544 DO j=iad_sl(i),iad_sl(i+1)-1
2545 nod=isl(j)
2546 f_imp(1,nod) = f_imp(1,nod) + rbuf(l)
2547 f_imp(2,nod) = f_imp(2,nod) + rbuf(l+1)
2548 f_imp(3,nod) = f_imp(3,nod) + rbuf(l+2)
2549 l = l+SIZE
2550 ENDDO
2551 ENDIF
2552 ENDDO
2553C
2554C wait terminaison isend
2555C--------------------------------------------------------------------
2556 DO i = 1, nspmd
2557 IF(iad_srem(i+1)-iad_srem(i)>0)THEN
2558 CALL mpi_wait(req_s(i),status,ierror)
2559 ENDIF
2560 ENDDO
2561C
2562 RETURN
2563#endif
2564 END
2565
2566!||====================================================================
2567!|| spmd_nrow ../engine/source/mpi/implicit/imp_spmd.F
2568!||--- called by ------------------------------------------------------
2569!|| dim_fr_k ../engine/source/mpi/implicit/imp_fri.f
2570!|| ini_fr_k ../engine/source/mpi/implicit/imp_fri.F
2571!|| nddli_frb ../engine/source/mpi/implicit/imp_fri.F
2572!||--- calls -----------------------------------------------------
2573!||--- uses -----------------------------------------------------
2574!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2575!||====================================================================
2576 SUBROUTINE spmd_nrow(NROW,FR_NROW,IAD_ELEM,TSIZE)
2577C-----------------------------------------------
2578C I m p l i c i t T y p e s
2579C-----------------------------------------------
2580 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2581#include "implicit_f.inc"
2582C-----------------------------------------------
2583C C o m m o n B l o c k s
2584C-----------------------------------------------
2585#include "com01_c.inc"
2586#include "task_c.inc"
2587C-----------------------------------------------
2588C M e s s a g e P a s s i n g
2589C-----------------------------------------------
2590#include "spmd.inc"
2591C-----------------------------------------------
2592C D u m m y A r g u m e n t s
2593C-----------------------------------------------
2594 INTEGER NROW(*),FR_NROW(*),IAD_ELEM(2,*),TSIZE
2595#if defined(MPI) && defined(MUMPS5)
2596C-----------------------------------------------
2597C L o c a l V a r i a b l e s
2598C-----------------------------------------------
2599 INTEGER MSGOFF,MSGTYP,NOD,LOC_PROC,IERROR,
2600 . STATUS(MPI_STATUS_SIZE),SIZ,
2601 . REQ_R(NSPMD),REQ_S(NSPMD),
2602 . I,J,K,L
2603 INTEGER
2604 . rbuf(tsize), sbuf(tsize)
2605 DATA msgoff/16025/
2606C-----------------------------------------------
2607C S o u r c e L i n e s
2608C-----------------------------------------------
2609 loc_proc = ispmd + 1
2610 DO i=1,nspmd
2611 siz = iad_elem(1,i+1)-iad_elem(1,i)
2612 IF(siz>0)THEN
2613 l = iad_elem(1,i)
2614 msgtyp = msgoff
2615 CALL mpi_irecv(
2616 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
2617 g spmd_comm_world,req_r(i),ierror)
2618 ENDIF
2619 END DO
2620C
2621C preparation envoi a proc I
2622C--------------------------------------------------------------------
2623 DO i=1,nspmd
2624 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
2625 sbuf(j) = nrow(j)
2626 ENDDO
2627 ENDDO
2628C
2629C echange messages
2630C--------------------------------------------------------------------
2631 DO i=1,nspmd
2632 siz = iad_elem(1,i+1)-iad_elem(1,i)
2633 IF(siz>0)THEN
2634 l = iad_elem(1,i)
2635 msgtyp = msgoff
2636 CALL mpi_isend(
2637 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2638 g spmd_comm_world,req_s(i),ierror)
2639 ENDIF
2640 ENDDO
2641C
2642C assemblage
2643C--------------------------------------------------------------------
2644 DO i=1,nspmd
2645 siz = iad_elem(1,i+1)-iad_elem(1,i)
2646 IF(siz>0)THEN
2647 CALL mpi_wait(req_r(i),status,ierror)
2648 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
2649 fr_nrow(j) = rbuf(j)
2650 ENDDO
2651 ENDIF
2652 ENDDO
2653C
2654C wait terminaison isend
2655C--------------------------------------------------------------------
2656 DO i = 1, nspmd
2657 IF((iad_elem(1,i+1)-iad_elem(1,i))>0)THEN
2658 CALL mpi_wait(req_s(i),status,ierror)
2659 ENDIF
2660 ENDDO
2661C
2662 RETURN
2663#endif
2664 END
2665
2666!||====================================================================
2667!|| spmd_icol ../engine/source/mpi/implicit/imp_spmd.f
2668!||--- called by ------------------------------------------------------
2669!|| dim_fr_k ../engine/source/mpi/implicit/imp_fri.F
2670!|| ini_fr_k ../engine/source/mpi/implicit/imp_fri.F
2671!||--- calls -----------------------------------------------------
2672!|| reorder_a ../engine/source/implicit/ind_glob_k.F
2673!||--- uses -----------------------------------------------------
2674!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2675!||====================================================================
2676 SUBROUTINE spmd_icol(
2677 1 IAD_S ,IAD_R ,NNMAX ,ICOL ,NROW ,
2678 2 FR_NROW ,IAD_ELEM ,FR_ELEM ,SSIZE ,RSIZE )
2679C-----------------------------------------------
2680C I m p l i c i t T y p e s
2681C-----------------------------------------------
2682 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2683#include "implicit_f.inc"
2684C-----------------------------------------------
2685C C o m m o n B l o c k s
2686C-----------------------------------------------
2687#include "com01_c.inc"
2688#include "task_c.inc"
2689C-----------------------------------------------
2690C M e s s a g e P a s s i n g
2691C-----------------------------------------------
2692#include "spmd.inc"
2693C-----------------------------------------------
2694C D u m m y A r g u m e n t s
2695C-----------------------------------------------
2696 INTEGER NNMAX
2697 INTEGER IAD_R(*),IAD_S(*),FR_NROW(*),NROW(*),
2698 . IAD_ELEM(2,*),FR_ELEM(*),ICOL(NNMAX,*),
2699 . SSIZE ,RSIZE
2700#if defined(MPI) && defined(MUMPS5)
2701C-----------------------------------------------
2702C L o c a l V a r i a b l e s
2703C-----------------------------------------------
2704 INTEGER MSGOFF,MSGTYP,NOD,LOC_PROC,IERROR,
2705 . STATUS(MPI_STATUS_SIZE),SIZ,
2706 . REQ_R(NSPMD),REQ_S(NSPMD),
2707 . I,J,K,L,N1,NROWT
2708 INTEGER
2709 . RBUF(RSIZE), SBUF(SSIZE)
2710 DATA MSGOFF/16026/
2711C-----------------------------------------------
2712C S o u r c e L i n e s
2713C-----------------------------------------------
2714 loc_proc = ispmd + 1
2715 DO i=1,nspmd
2716 siz = iad_r(i+1)-iad_r(i)
2717 IF(siz>0)THEN
2718 l = iad_r(i)
2719 msgtyp = msgoff
2720 CALL mpi_irecv(
2721 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
2722 g spmd_comm_world,req_r(i),ierror)
2723 ENDIF
2724 END DO
2725C
2726C preparation envoi a proc I
2727C--------------------------------------------------------------------
2728 DO i=1,nspmd
2729 siz = iad_s(i+1)-iad_s(i)
2730 IF(siz>0)THEN
2731 l = iad_s(i)-1
2732 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
2733 DO k=1,nrow(j)
2734 sbuf(k+l) = icol(k,j)
2735 ENDDO
2736 l=l+nrow(j)
2737 ENDDO
2738 ENDIF
2739 ENDDO
2740C
2741C echange messages
2742C--------------------------------------------------------------------
2743 DO i=1,nspmd
2744 siz = iad_s(i+1)-iad_s(i)
2745 IF(siz>0)THEN
2746 l = iad_s(i)
2747 msgtyp = msgoff
2748 CALL mpi_isend(
2749 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2750 g spmd_comm_world,req_s(i),ierror)
2751 ENDIF
2752 ENDDO
2753C
2754C assemblage
2755C--------------------------------------------------------------------
2756 DO i=1,nspmd
2757 siz = iad_r(i+1)-iad_r(i)
2758 IF(siz>0)THEN
2759 CALL mpi_wait(req_r(i),status,ierror)
2760 l=iad_r(i)-1
2761 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
2762 nrowt=nrow(j)
2763 DO k=1,fr_nrow(j)
2764 n1=rbuf(l+k)
2765 CALL reorder_a(nrowt,icol(1,j),n1)
2766 ENDDO
2767 l=l+fr_nrow(j)
2768 fr_nrow(j)=nrowt
2769 ENDDO
2770 ENDIF
2771 ENDDO
2772C
2773C wait terminaison isend
2774C--------------------------------------------------------------------
2775 DO i = 1, nspmd
2776 IF(iad_s(i+1)-iad_s(i)>0)THEN
2777 CALL mpi_wait(req_s(i),status,ierror)
2778 ENDIF
2779 ENDDO
2780C
2781 RETURN
2782#endif
2783 END
2784!||====================================================================
2785!|| spmd_i2d ../engine/source/mpi/implicit/imp_spmd.F
2786!||--- called by ------------------------------------------------------
2787!|| dim_ndof_d ../engine/source/implicit/ind_glob_k.F
2788!||--- calls -----------------------------------------------------
2789!||--- uses -----------------------------------------------------
2790!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2791!||====================================================================
2792 SUBROUTINE spmd_i2d(NDOF,FR_ELEM,IAD_ELEM,TSIZE)
2793C-----------------------------------------------
2794C I m p l i c i t T y p e s
2795C-----------------------------------------------
2796 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2797#include "implicit_f.inc"
2798C-----------------------------------------------
2799C C o m m o n B l o c k s
2800C-----------------------------------------------
2801#include "com01_c.inc"
2802#include "task_c.inc"
2803C-----------------------------------------------
2804C M e s s a g e P a s s i n g
2805C-----------------------------------------------
2806#include "spmd.inc"
2807C-----------------------------------------------
2808C D u m m y A r g u m e n t s
2809C-----------------------------------------------
2810 INTEGER NDOF(*),FR_ELEM(*),IAD_ELEM(*),TSIZE
2811#if defined(MPI) && defined(MUMPS5)
2812C-----------------------------------------------
2813C L o c a l V a r i a b l e s
2814C-----------------------------------------------
2815 INTEGER MSGOFF,MSGTYP,NOD,LOC_PROC,IERROR,
2816 . STATUS(MPI_STATUS_SIZE),SIZ,
2817 . req_r(nspmd),req_s(nspmd),
2818 . i,j,k,l
2819 integer
2820 . rbuf(tsize), sbuf(tsize)
2821 DATA msgoff/16027/
2822C-----------------------------------------------
2823C S o u r c e L i n e s
2824C-----------------------------------------------
2825 loc_proc = ispmd + 1
2826 DO i=1,nspmd
2827 siz = iad_elem(i+1)-iad_elem(i)
2828 IF(siz>0)THEN
2829 l = iad_elem(i)
2830 msgtyp = msgoff
2831 CALL mpi_irecv(
2832 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
2833 g spmd_comm_world,req_r(i),ierror)
2834 ENDIF
2835 END DO
2836C
2837C preparation envoi a proc I
2838C--------------------------------------------------------------------
2839 DO i=1,nspmd
2840 DO j=iad_elem(i),iad_elem(i+1)-1
2841 nod = fr_elem(j)
2842 sbuf(j) = ndof(nod)
2843 ENDDO
2844 ENDDO
2845C
2846C echange messages
2847C--------------------------------------------------------------------
2848 DO i=1,nspmd
2849 siz = iad_elem(i+1)-iad_elem(i)
2850 IF(siz>0)THEN
2851 l = iad_elem(i)
2852 msgtyp = msgoff
2853 CALL mpi_isend(
2854 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
2855 g spmd_comm_world,req_s(i),ierror)
2856 ENDIF
2857 ENDDO
2858C
2859C assemblage
2860C--------------------------------------------------------------------
2861 DO i=1,nspmd
2862 siz = iad_elem(i+1)-iad_elem(i)
2863 IF(siz>0)THEN
2864 CALL mpi_wait(req_r(i),status,ierror)
2865 DO j=iad_elem(i),iad_elem(i+1)-1
2866 nod = fr_elem(j)
2867 ndof(nod) = max(ndof(nod),rbuf(j))
2868 ENDDO
2869 ENDIF
2870 ENDDO
2871C
2872C wait terminaison isend
2873C--------------------------------------------------------------------
2874 DO i = 1, nspmd
2875 IF((iad_elem(i+1)-iad_elem(i))>0)THEN
2876 CALL mpi_wait(req_s(i),status,ierror)
2877 ENDIF
2878 ENDDO
2879C
2880 RETURN
2881#endif
2882 END
2883
2884!||====================================================================
2885!|| spmd_sumf_a ../engine/source/mpi/implicit/imp_spmd.F
2886!||--- called by ------------------------------------------------------
2887!|| dyna_ina ../engine/source/implicit/imp_dyna.F
2888!|| imp_chkm ../engine/source/implicit/imp_solv.F
2889!|| imp_dykv ../engine/source/implicit/imp_dyna.F
2890!|| imp_dykv0 ../engine/source/implicit/imp_dyna.F
2891!|| imp_solv ../engine/source/implicit/imp_solv.F
2892!||--- calls -----------------------------------------------------
2893!||--- uses -----------------------------------------------------
2894!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
2895!||====================================================================
2896 SUBROUTINE spmd_sumf_a(A ,AR,IAD_ELEM,FR_ELEM,SIZE,LR)
2897C-----------------------------------------------
2898C I m p l i c i t T y p e s
2899C-----------------------------------------------
2900 USE spmd_comm_world_mod, ONLY : spmd_comm_world
2901#include "implicit_f.inc"
2902C-----------------------------------------------
2903C C o m m o n B l o c k s
2904C-----------------------------------------------
2905#include "com01_c.inc"
2906#include "task_c.inc"
2907C-----------------------------------------------
2908C M e s s a g e P a s s i n g
2909C-----------------------------------------------
2910#include "spmd.inc"
2911C-----------------------------------------------
2912C D u m m y A r g u m e n t s
2913C-----------------------------------------------
2914 INTEGER FR_ELEM(*),IAD_ELEM(2,*),SIZE,LR
2915 my_real
2916 . A(3,*),AR(3,*)
2917#if defined(MPI)
2918C-----------------------------------------------
2919C L o c a l V a r i a b l e s
2920C-----------------------------------------------
2921 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
2922 . siz,j,l,status(mpi_status_size),
2923 . req_r(nspmd),req_s(nspmd)
2924 my_real
2925 . rbuf(lr*size), sbuf(lr*size)
2926 DATA msgoff/16028/
2927C-----------------------------------------------
2928C S o u r c e L i n e s
2929C-----------------------------------------------
2930 loc_proc = ispmd + 1
2931C ------ com. de D nodes SECONDARYs -----
2932C------recive--
2933 l=1
2934 DO i=1,nspmd
2935 IF(i/=loc_proc)THEN
2936 siz = (iad_elem(1,i+1)-iad_elem(1,i))*SIZE
2937 IF(siz>0)THEN
2938 msgtyp = msgoff
2939 CALL mpi_irecv(
2940 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
2941 g spmd_comm_world,req_r(i),ierror)
2942 l = l+siz
2943 ENDIF
2944 ENDIF
2945 END DO
2946C
2947C preparation envoi a proc I
2948C--------------------------------------------------------------------
2949 l=1
2950 DO i=1,nspmd
2951 IF(i/=loc_proc)THEN
2952 IF(iroddl/=0) THEN
2953#include "vectorize.inc"
2954 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
2955 nod = fr_elem(j)
2956 sbuf(l) =a(1,nod)
2957 sbuf(l+1)=a(2,nod)
2958 sbuf(l+2)=a(3,nod)
2959 sbuf(l+3) = ar(1,nod)
2960 sbuf(l+4) = ar(2,nod)
2961 sbuf(l+5) = ar(3,nod)
2962 l = l+SIZE
2963 ENDDO
2964 ELSE
2965#include "vectorize.inc"
2966 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
2967 nod = fr_elem(j)
2968 sbuf(l ) = a(1,nod)
2969 sbuf(l+1) = a(2,nod)
2970 sbuf(l+2) = a(3,nod)
2971 l = l + SIZE
2972 ENDDO
2973 ENDIF
2974 ENDIF
2975 ENDDO
2976C
2977C echange messages
2978C--------------------------------------------------------------------
2979 l=1
2980 DO i=1,nspmd
2981 IF(i/=loc_proc)THEN
2982 siz = (iad_elem(1,i+1)-iad_elem(1,i))*SIZE
2983 IF(siz>0)THEN
2984 msgtyp = msgoff
2985 CALL mpi_isend(
2986 s sbuf(l),siz,real,it_spmd(i),msgtyp,
2987 g spmd_comm_world,req_s(i),ierror)
2988 l = l+siz
2989 ENDIF
2990 ENDIF
2991 ENDDO
2992C
2993C assemblage
2994C--------------------------------------------------------------------
2995 l=1
2996 DO i=1,nspmd
2997 IF(i/=loc_proc.AND.iad_elem(1,i+1)>iad_elem(1,i))THEN
2998 CALL mpi_wait(req_r(i),status,ierror)
2999 IF(iroddl/=0) THEN
3000#include "vectorize.inc"
3001 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3002 nod = fr_elem(j)
3003 a(1,nod)=a(1,nod)+rbuf(l)
3004 a(2,nod)=a(2,nod)+rbuf(l+1)
3005 a(3,nod)=a(3,nod)+rbuf(l+2)
3006 ar(1,nod)=ar(1,nod)+rbuf(l+3)
3007 ar(2,nod)=ar(2,nod)+rbuf(l+4)
3008 ar(3,nod)=ar(3,nod)+rbuf(l+5)
3009 l = l+SIZE
3010 ENDDO
3011 ELSE
3012#include "vectorize.inc"
3013 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3014 nod = fr_elem(j)
3015 a(1,nod)=a(1,nod)+rbuf(l)
3016 a(2,nod)=a(2,nod)+rbuf(l+1)
3017 a(3,nod)=a(3,nod)+rbuf(l+2)
3018 l = l + SIZE
3019 ENDDO
3020 ENDIF
3021 ENDIF
3022 ENDDO
3023C
3024C wait terminaison isend
3025C--------------------------------------------------------------------
3026 DO i = 1, nspmd
3027 IF(iad_elem(1,i+1)-iad_elem(1,i)>0)THEN
3028 CALL mpi_wait(req_s(i),status,ierror)
3029 ENDIF
3030 ENDDO
3031C
3032 RETURN
3033#endif
3034 END
3035!||====================================================================
3036!|| spmd_ndof ../engine/source/mpi/implicit/imp_spmd.F
3037!||--- called by ------------------------------------------------------
3038!|| dim_glob_k ../engine/source/implicit/ind_glob_k.F
3039!||--- calls -----------------------------------------------------
3040!||--- uses -----------------------------------------------------
3041!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3042!||====================================================================
3043 SUBROUTINE spmd_ndof(NDOF,FR_ELEM,IAD_ELEM,TSIZE)
3044C-----------------------------------------------
3045C I m p l i c i t T y p e s
3046C-----------------------------------------------
3047 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3048#include "implicit_f.inc"
3049C-----------------------------------------------
3050C C o m m o n B l o c k s
3051C-----------------------------------------------"
3052#include "com01_c.inc"
3053#include "task_c.inc"
3054C-----------------------------------------------
3055C M e s s a g e P a s s i n g
3056C-----------------------------------------------
3057#include "spmd.inc"
3058C-----------------------------------------------
3059C D u m m y A r g u m e n t s
3060C-----------------------------------------------
3061 INTEGER NDOF(*),FR_ELEM(*),IAD_ELEM(2,*),TSIZE
3062#if defined(MPI)
3063C-----------------------------------------------
3064C L o c a l V a r i a b l e s
3065C-----------------------------------------------
3066 INTEGER MSGOFF,MSGTYP,NOD,LOC_PROC,IERROR,
3067 . STATUS(MPI_STATUS_SIZE),SIZ,
3068 . req_r(nspmd),req_s(nspmd),
3069 . i,j,k,l
3070 integer
3071 . rbuf(tsize), sbuf(tsize)
3072 DATA msgoff/16029/
3073C-----------------------------------------------
3074C S o u r c e L i n e s
3075C-----------------------------------------------
3076 loc_proc = ispmd + 1
3077 DO i=1,nspmd
3078 siz = iad_elem(1,i+1)-iad_elem(1,i)
3079 IF(siz>0)THEN
3080 l = iad_elem(1,i)
3081 msgtyp = msgoff
3082 CALL mpi_irecv(
3083 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
3084 g spmd_comm_world,req_r(i),ierror)
3085 ENDIF
3086 END DO
3087C
3088C preparation envoi a proc I
3089C--------------------------------------------------------------------
3090 DO i=1,nspmd
3091 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3092 nod = fr_elem(j)
3093 sbuf(j) = ndof(nod)
3094 ENDDO
3095 ENDDO
3096C
3097C echange messages
3098C--------------------------------------------------------------------
3099 DO i=1,nspmd
3100 siz = iad_elem(1,i+1)-iad_elem(1,i)
3101 IF(siz>0)THEN
3102 l = iad_elem(1,i)
3103 msgtyp = msgoff
3104 CALL mpi_isend(
3105 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
3106 g spmd_comm_world,req_s(i),ierror)
3107 ENDIF
3108 ENDDO
3109C
3110C assemblage
3111C--------------------------------------------------------------------
3112 DO i=1,nspmd
3113 siz = iad_elem(1,i+1)-iad_elem(1,i)
3114 IF(siz>0)THEN
3115 CALL mpi_wait(req_r(i),status,ierror)
3116 DO j=iad_elem(1,i),iad_elem(1,i+1)-1
3117 nod = fr_elem(j)
3118 ndof(nod) = max(ndof(nod),rbuf(j))
3119 ENDDO
3120 ENDIF
3121 ENDDO
3122C
3123C wait terminaison isend
3124C--------------------------------------------------------------------
3125 DO i = 1, nspmd
3126 IF((iad_elem(1,i+1)-iad_elem(1,i))>0)THEN
3127 CALL mpi_wait(req_s(i),status,ierror)
3128 ENDIF
3129 ENDDO
3130C
3131 RETURN
3132#endif
3133 END
3134C-----------------------------------------------
3135!||====================================================================
3136!|| spmd_cddl ../engine/source/mpi/implicit/imp_spmd.F
3137!||--- called by ------------------------------------------------------
3138!|| imp_buck ../engine/source/implicit/imp_buck.f
3139!|| imp_mumps1 ../engine/source/implicit/imp_mumps.F
3140!||--- calls -----------------------------------------------------
3141!||--- uses -----------------------------------------------------
3142!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3143!||====================================================================
3144 SUBROUTINE spmd_cddl(NDDL , NODGLOB, IDDL , NDOF , CDDLP,
3145 . INLOC, IKC , NDDLG, NDDLP)
3146C-----------------------------------------------
3147C I m p l i c i t T y p e s
3148C-----------------------------------------------
3149 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3150#include "implicit_f.inc"
3151C-----------------------------------------------
3152C C o m m o n B l o c k s
3153C-----------------------------------------------
3154#include "com01_c.inc"
3155#include "com04_c.inc"
3156#include "task_c.inc"
3157#include "spmd_c.inc"
3158C-----------------------------------------------
3159C M e s s a g e P a s s i n g
3160C-----------------------------------------------
3161#include "spmd.inc"
3162C-----------------------------------------------
3163C D u m m y A r g u m e n t s
3164C-----------------------------------------------
3165 INTEGER NDDL, NODGLOB(*), IDDL(*), NDOF(*), CDDLP(*),
3166 . INLOC(*), IKC(*), NDDLG, NDDLP(*)
3167#if defined(MPI) && defined(MUMPS5)
3168C-----------------------------------------------
3169C L o c a l V a r i a b l e s
3170C-----------------------------------------------
3171 INTEGER I, J, ITAG(6,NUMNODG), NKC, N, ND, ID, TDDL(2,NDDL),
3172 . NDDLGL, NDDLC, LEN, IRQTAG, MSGOFF, REQ(2), IERR,
3173 . stat(mpi_status_size,2), nn, jj,msgoff2,msgoff3
3174 INTEGER, DIMENSION(:), ALLOCATABLE :: CDDLPC
3175 INTEGER, DIMENSION(:,:), ALLOCATABLE :: TDDLC
3176 DATA MSGOFF/16030/,MSGOFF2/16031/,MSGOFF3/16056/
3177
3178C
3179 DO i=1,numnodg
3180 DO j=1,6
3181 itag(j,i)=0
3182 ENDDO
3183 ENDDO
3184C
3185 nkc=0
3186 DO n=1,numnod
3187 i=inloc(n)
3188 DO j=1,ndof(i)
3189 nd=iddl(i)+j
3190 id=nd-nkc
3191 IF (ikc(nd)<1) THEN
3192 tddl(1,id)=nodglob(i)
3193 tddl(2,id)=j
3194 ELSE
3195 nkc=nkc+1
3196 ENDIF
3197 ENDDO
3198 ENDDO
3199C
3200 IF (ispmd==0) THEN
3201 nddlgl=0
3202 DO i=1,nspmd
3203 nddlc=nddlp(i)
3204 ALLOCATE(tddlc(2,nddlc), cddlpc(nddlc))
3205 IF (i==1) THEN
3206 DO j=1,nddlc
3207 tddlc(1,j)=tddl(1,j)
3208 tddlc(2,j)=tddl(2,j)
3209 ENDDO
3210 ELSE
3211 len=2*nddlc
3212 irqtag=msgoff
3213 CALL mpi_irecv(tddlc, len, mpi_integer, it_spmd(i),
3214 . irqtag, spmd_comm_world, req, ierr)
3215 CALL mpi_wait(req, stat, ierr)
3216 ENDIF
3217C
3218 DO j=1,nddlc
3219 nn=tddlc(1,j)
3220 id=tddlc(2,j)
3221 jj=itag(id,nn)
3222 IF (jj==0) THEN
3223 nddlgl=nddlgl+1
3224 itag(id,nn)=nddlgl
3225 jj=nddlgl
3226 ENDIF
3227 cddlpc(j)=jj
3228 ENDDO
3229C
3230 IF (i==1) THEN
3231 DO j=1,nddlc
3232 cddlp(j)=cddlpc(j)
3233 ENDDO
3234 ELSE
3235 irqtag=msgoff3
3236 CALL mpi_isend(cddlpc, nddlc, mpi_integer, it_spmd(i),
3237 . irqtag, spmd_comm_world, req, ierr)
3238 CALL mpi_wait(req, stat, ierr)
3239 ENDIF
3240C
3241 DEALLOCATE(tddlc, cddlpc)
3242 ENDDO
3243 nddlg=nddlgl
3244C +4
3245 DO i = 2, nspmd
3246 irqtag=msgoff2
3247 CALL mpi_send(nddlg,1,mpi_integer,it_spmd(i),
3248 . irqtag,spmd_comm_world,ierr)
3249 END DO
3250 ELSE
3251 len=2*nddl
3252 irqtag=msgoff
3253 CALL mpi_isend(tddl, len, mpi_integer, it_spmd(1),
3254 . irqtag, spmd_comm_world, req(1), ierr)
3255C
3256 irqtag=msgoff3
3257 CALL mpi_irecv(cddlp, nddl, mpi_integer, it_spmd(1),
3258 . irqtag, spmd_comm_world, req(2), ierr)
3259C
3260
3261 CALL mpi_waitall(2, req, stat, ierr)
3262C +3
3263 irqtag = msgoff2
3264 CALL mpi_recv(nddlg,1,mpi_integer,it_spmd(1),irqtag,
3265 . spmd_comm_world,stat,ierr )
3266 ENDIF
3267C
3268 RETURN
3269#endif
3270 END
3271!||====================================================================
3272!|| spmd_vchgrid ../engine/source/mpi/implicit/imp_spmd.F
3273!||--- calls -----------------------------------------------------
3274!||--- uses -----------------------------------------------------
3275!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3276!||====================================================================
3277 SUBROUTINE spmd_vchgrid(V , IV , NV, VG , NVG ,
3278 . NBLOC, NDDL, IS, ISUM)
3279C-----------------------------------------------
3280C I m p l i c i t T y p e s
3281C-----------------------------------------------
3282 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3283#include "implicit_f.inc"
3284C-----------------------------------------------
3285C C o m m o n B l o c k s
3286C-----------------------------------------------
3287#include "com01_c.inc"
3288#include "task_c.inc"
3289C-----------------------------------------------
3290C M e s s a g e P a s s i n g
3291C-----------------------------------------------
3292#include "spmd.inc"
3293C-----------------------------------------------
3294C D u m m y A r g u m e n t s
3295C-----------------------------------------------
3296 INTEGER IV(*), NV, NVG, NBLOC, NDDL, IS, ISUM
3297 my_real V(*), VG(*)
3298#if defined(MPI)
3299C-----------------------------------------------
3300C L o c a l V a r i a b l e s
3301C-----------------------------------------------
3302 INTEGER I, II, ITAG, NVP, IVP(NDDL), J, JJ, NN, IAD,
3303 . ISTAT(MPI_STATUS_SIZE), IERR
3304 my_real
3305 . vv(nddl), vp(nddl)
3306 INTEGER MSGOFF,MSGOFF2,MSGOFF3,MSGOFF4
3307 DATA MSGOFF/16057/,MSGOFF2/16058/,MSGOFF3/16059/,MSGOFF4/16060/
3308
3309C
3310 IF (IS==1) then
3311C Passage de la decomposition DOMDEC a la process grid PARPACK
3312 IF (ispmd==0) THEN
3313 DO i=1,nddl
3314 vv(i)=zero
3315 ENDDO
3316C
3317 DO i=1,nv
3318 ii=iv(i)
3319 vv(ii)=v(i)
3320 ENDDO
3321C
3322 DO i=1,nspmd-1
3323 itag=msgoff
3324 CALL mpi_recv(nvp, 1, mpi_integer, it_spmd(i+1),
3325 . itag, spmd_comm_world, istat, ierr)
3326 itag=msgoff2
3327 CALL mpi_recv(ivp, nvp, mpi_integer, it_spmd(i+1),
3328 . itag, spmd_comm_world, istat, ierr)
3329 itag=msgoff3
3330 CALL mpi_recv(vp, nvp, real, it_spmd(i+1),
3331 . itag, spmd_comm_world, istat, ierr)
3332 IF (isum==1) THEN
3333C Pas de sommation des contributions : valable pour des deplacements
3334 DO j=1,nvp
3335 jj=ivp(j)
3336 vv(jj)=vp(j)
3337 ENDDO
3338 ELSEIF (isum==2) THEN
3339C Sommation des contributions : valable pour des forces
3340 DO j=1,nvp
3341 jj=ivp(j)
3342 vv(jj)=vv(jj)+vp(j)
3343 ENDDO
3344 ENDIF
3345 ENDDO
3346C
3347 nn=min(nbloc,nddl)
3348 DO i=1,nn
3349 vg(i)=vv(i)
3350 ENDDO
3351C
3352 DO i=1,nspmd-1
3353 iad=nbloc*i+1
3354 nn=min(nbloc, nddl-iad+1)
3355 itag=msgoff4
3356 CALL mpi_send(vv(iad), nn, real, it_spmd(i+1),
3357 . itag, spmd_comm_world, ierr)
3358 ENDDO
3359 ELSE
3360 itag=msgoff
3361 CALL mpi_send(nv, 1, mpi_integer, it_spmd(1),
3362 . itag, spmd_comm_world, ierr)
3363 itag=msgoff2
3364 CALL mpi_send(iv, nv, mpi_integer, it_spmd(1),
3365 . itag, spmd_comm_world, ierr)
3366 itag=msgoff3
3367 CALL mpi_send(v, nv, real, it_spmd(1),
3368 . itag, spmd_comm_world, ierr)
3369C
3370 itag=msgoff4
3371 CALL mpi_recv(vg, nvg, real, it_spmd(1),
3372 . itag, spmd_comm_world, istat, ierr)
3373 ENDIF
3374 ELSEIF (is==2) THEN
3375C Passage de la process grid PARPACK a la decomposition DOMDEC
3376 IF (ispmd==0) THEN
3377 nn=min(nbloc,nddl)
3378 DO i=1,nn
3379 vv(i)=vg(i)
3380 ENDDO
3381C
3382 DO i=1,nspmd-1
3383 iad=nbloc*i+1
3384 nn=min(nbloc,nddl-iad+1)
3385 itag=msgoff
3386 CALL mpi_recv(vv(iad), nn, real, it_spmd(i+1),
3387 . itag, spmd_comm_world, istat, ierr)
3388 ENDDO
3389C
3390 DO i=1,nv
3391 ii=iv(i)
3392 v(i)=vv(ii)
3393 ENDDO
3394C
3395 DO i=1,nspmd-1
3396 itag=msgoff2
3397 CALL mpi_recv(nvp, 1, mpi_integer, it_spmd(i+1),
3398 . itag, spmd_comm_world, istat, ierr)
3399 itag=msgoff3
3400 CALL mpi_recv(ivp, nvp, mpi_integer, it_spmd(i+1),
3401 . itag, spmd_comm_world, istat, ierr)
3402 DO j=1,nvp
3403 jj=ivp(j)
3404 vp(j)=vv(jj)
3405 ENDDO
3406 itag=msgoff4
3407 CALL mpi_send(vp, nvp, real, it_spmd(i+1),
3408 . itag, spmd_comm_world, ierr)
3409 ENDDO
3410 ELSE
3411 itag=msgoff
3412 CALL mpi_send(vg, nvg, real, it_spmd(1),
3413 . itag, spmd_comm_world, ierr)
3414 itag=msgoff2
3415 CALL mpi_send(nv, 1, mpi_integer, it_spmd(1),
3416 . itag, spmd_comm_world, ierr)
3417 itag=msgoff3
3418 CALL mpi_send(iv, nv, mpi_integer, it_spmd(1),
3419 . itag, spmd_comm_world, ierr)
3420C
3421 itag=msgoff4
3422 CALL mpi_recv(v, nv, real, it_spmd(1),
3423 . itag, spmd_comm_world, istat, ierr)
3424 ENDIF
3425 ENDIF
3426C
3427 RETURN
3428#endif
3429 END
3430!||====================================================================
3431!|| spmd_isr ../engine/source/mpi/implicit/imp_spmd.F
3432!||--- called by ------------------------------------------------------
3433!|| dim_frkm ../engine/source/mpi/implicit/imp_fri.F
3434!|| dim_frkm1 ../engine/source/mpi/implicit/imp_fri.F
3435!|| ini_frkc ../engine/source/mpi/implicit/imp_fri.F
3436!||--- calls -----------------------------------------------------
3437!||--- uses -----------------------------------------------------
3438!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3439!||====================================================================
3440 SUBROUTINE spmd_isr(IAD_S,IAD_R,ITS,ITR,SSIZE ,RSIZE)
3441C-----------------------------------------------
3442C I m p l i c i t T y p e s
3443C-----------------------------------------------
3444 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3445#include "implicit_f.inc"
3446C-----------------------------------------------
3447C C o m m o n B l o c k s
3448C-----------------------------------------------
3449#include "com01_c.inc"
3450#include "task_c.inc"
3451C-----------------------------------------------
3452C M e s s a g e P a s s i n g
3453C-----------------------------------------------
3454#include "spmd.inc"
3455C-----------------------------------------------
3456C D u m m y A r g u m e n t s
3457C-----------------------------------------------
3458 INTEGER SSIZE ,RSIZE
3459 INTEGER IAD_S(NSPMD+1),IAD_R(NSPMD+1),ITS(SSIZE),ITR(RSIZE)
3460#if defined(MPI) && defined(MUMPS5)
3461C-----------------------------------------------
3462C L o c a l V a r i a b l e s
3463C-----------------------------------------------
3464 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
3465 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
3466 . REQ_R(NSPMD),REQ_S(NSPMD)
3467 integer
3468 . rbuf(rsize), sbuf(ssize)
3469 DATA msgoff/16032/
3470C-----------------------------------------------
3471C S o u r c e L i n e s
3472C-----------------------------------------------
3473 loc_proc = ispmd + 1
3474C ------com. de numero nodes SECONDARYs -----
3475C au l appel, RSIZE=IAD_R(NSPMD+1)-1
3476C SSIZE=IAD_S(NSPMD+1)-1
3477C------recive--
3478 l=1
3479 DO i=1,nspmd
3480 IF(i/=loc_proc)THEN
3481 siz = iad_r(i+1)-iad_r(i)
3482 IF(siz>0)THEN
3483 msgtyp = msgoff
3484 CALL mpi_irecv(
3485 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
3486 g spmd_comm_world,req_r(i),ierror)
3487 l = l+siz
3488 ENDIF
3489 ENDIF
3490 END DO
3491C
3492C preparation envoi a proc I
3493C--------------------------------------------------------------------
3494 l=1
3495 DO i=1,nspmd
3496 IF(i/=loc_proc)THEN
3497 DO j=iad_s(i),iad_s(i+1)-1
3498 sbuf(l)=its(j)
3499 l = l + 1
3500 ENDDO
3501 ENDIF
3502 ENDDO
3503C
3504C echange messages
3505C--------------------------------------------------------------------
3506 l=1
3507 DO i=1,nspmd
3508 IF(i/=loc_proc)THEN
3509 siz = iad_s(i+1)-iad_s(i)
3510 IF(siz>0)THEN
3511 msgtyp = msgoff
3512 CALL mpi_isend(
3513 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
3514 g spmd_comm_world,req_s(i),ierror)
3515 l = l+siz
3516 ENDIF
3517 ENDIF
3518 ENDDO
3519C
3520C assemblage
3521C--------------------------------------------------------------------
3522 l=1
3523 DO i=1,nspmd
3524 IF(i/=loc_proc.AND.iad_r(i+1)>iad_r(i))THEN
3525 CALL mpi_wait(req_r(i),status,ierror)
3526 DO j=iad_r(i),iad_r(i+1)-1
3527 itr(j) = rbuf(l)
3528 l = l + 1
3529 ENDDO
3530 ENDIF
3531 ENDDO
3532C
3533C wait terminaison isend
3534C--------------------------------------------------------------------
3535 DO i = 1, nspmd
3536 IF(iad_s(i+1)-iad_s(i)>0)THEN
3537 CALL mpi_wait(req_s(i),status,ierror)
3538 ENDIF
3539 ENDDO
3540C
3541 RETURN
3542#endif
3543 END
3544
3545!||====================================================================
3546!|| spmd_exci ../engine/source/mpi/implicit/imp_spmd.F
3547!||--- called by ------------------------------------------------------
3548!|| ini_frud ../engine/source/mpi/implicit/imp_fri.F
3549!|| scom_frk1 ../engine/source/mpi/implicit/imp_fri.F
3550!||--- calls -----------------------------------------------------
3551!||--- uses -----------------------------------------------------
3552!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3553!||====================================================================
3554 SUBROUTINE spmd_exci(ITS,ITR,IAD_S,IAD_R,SIZE ,SSIZE ,RSIZE)
3555C-----------------------------------------------
3556C I m p l i c i t T y p e s
3557C-----------------------------------------------
3558 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3559#include "implicit_f.inc"
3560C-----------------------------------------------
3561C C o m m o n B l o c k s
3562C-----------------------------------------------
3563#include "com01_c.inc"
3564#include "task_c.inc"
3565C-----------------------------------------------
3566C M e s s a g e P a s s i n g
3567C-----------------------------------------------
3568#include "spmd.inc"
3569C-----------------------------------------------
3570C D u m m y A r g u m e n t s
3571C-----------------------------------------------
3572 INTEGER SSIZE ,RSIZE,SIZE
3573 INTEGER ITS(SIZE,SSIZE),ITR(SIZE,RSIZE),
3574 . IAD_S(NSPMD+1),IAD_R(NSPMD+1)
3575#if defined(MPI) && defined(MUMPS5)
3576C-----------------------------------------------
3577C L o c a l V a r i a b l e s
3578C-----------------------------------------------
3579 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
3580 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),K,
3581 . req_r(nspmd),req_s(nspmd)
3582 integer
3583 . rbuf(rsize*size), sbuf(ssize*size)
3584 DATA msgoff/16033/
3585C-----------------------------------------------
3586C S o u r c e L i n e s
3587C-----------------------------------------------
3588 loc_proc = ispmd + 1
3589C ------com. de numero nodes SECONDARYs -----
3590C au l appel, RSIZE=IAD_R(NSPMD+1)-1
3591C SSIZE=IAD_S(NSPMD+1)-1
3592C------recive--
3593 l=1
3594 DO i=1,nspmd
3595 IF(i/=loc_proc)THEN
3596 siz = (iad_r(i+1)-iad_r(i))*SIZE
3597 IF(siz>0)THEN
3598 msgtyp = msgoff
3599 CALL mpi_irecv(
3600 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
3601 g spmd_comm_world,req_r(i),ierror)
3602 l = l+siz
3603 ENDIF
3604 ENDIF
3605 END DO
3606C
3607C preparation envoi a proc I
3608C--------------------------------------------------------------------
3609 l=0
3610 DO i=1,nspmd
3611 IF(i/=loc_proc)THEN
3612 DO j=iad_s(i),iad_s(i+1)-1
3613 DO k =1,SIZE
3614 sbuf(l+k)=its(k,j)
3615 ENDDO
3616 l = l + SIZE
3617 ENDDO
3618 ENDIF
3619 ENDDO
3620C
3621C echange messages
3622C--------------------------------------------------------------------
3623 l=1
3624 DO i=1,nspmd
3625 IF(i/=loc_proc)THEN
3626 siz = (iad_s(i+1)-iad_s(i))*SIZE
3627 IF(siz>0)THEN
3628 msgtyp = msgoff
3629 CALL mpi_isend(
3630 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
3631 g spmd_comm_world,req_s(i),ierror)
3632 l = l+siz
3633 ENDIF
3634 ENDIF
3635 ENDDO
3636C
3637C assemblage
3638C--------------------------------------------------------------------
3639 l=0
3640 DO i=1,nspmd
3641 IF(i/=loc_proc.AND.iad_r(i+1)>iad_r(i))THEN
3642 CALL mpi_wait(req_r(i),status,ierror)
3643 DO j=iad_r(i),iad_r(i+1)-1
3644 DO k =1,SIZE
3645 itr(k,j) = rbuf(l+k)
3646 ENDDO
3647 l = l + SIZE
3648 ENDDO
3649 ENDIF
3650 ENDDO
3651C
3652C wait terminaison isend
3653C--------------------------------------------------------------------
3654 DO i = 1, nspmd
3655 IF(iad_s(i+1)-iad_s(i)>0)THEN
3656 CALL mpi_wait(req_s(i),status,ierror)
3657 ENDIF
3658 ENDDO
3659C
3660 RETURN
3661#endif
3662 END
3663
3664!||====================================================================
3665!|| spmd_exck ../engine/source/mpi/implicit/imp_spmd.F
3666!||--- called by ------------------------------------------------------
3667!|| scom_frk ../engine/source/mpi/implicit/imp_fri.F
3668!|| scom_frk1 ../engine/source/mpi/implicit/imp_fri.F
3669!|| scom_frud ../engine/source/mpi/implicit/imp_fri.F
3670!||--- calls -----------------------------------------------------
3671!||--- uses -----------------------------------------------------
3672!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3673!||====================================================================
3674 SUBROUTINE spmd_exck(KS11,KR11,IAD_S,IAD_R,SIZE ,SSIZE,RSIZE)
3675C-----------------------------------------------
3676C I m p l i c i t T y p e s
3677C-----------------------------------------------
3678 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3679#include "implicit_f.inc"
3680C-----------------------------------------------
3681C C o m m o n B l o c k s
3682C-----------------------------------------------"
3683#include "com01_c.inc"
3684#include "task_c.inc"
3685C-----------------------------------------------
3686C M e s s a g e P a s s i n g
3687C-----------------------------------------------
3688#include "spmd.inc"
3689C-----------------------------------------------
3690C D u m m y A r g u m e n t s
3691C-----------------------------------------------
3692 INTEGER SSIZE ,RSIZE,IAD_S(*),IAD_R(*),SIZE
3693 my_real
3694 . KS11(SIZE,*),KR11(SIZE,*)
3695#if defined(MPI) && defined(MUMPS5)
3696C-----------------------------------------------
3697C L o c a l V a r i a b l e s
3698C-----------------------------------------------
3699 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
3700 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
3701 . req_r(nspmd),req_s(nspmd)
3702 my_real
3703 . rbuf(size*rsize),sbuf(size*ssize)
3704 DATA msgoff/16034/
3705C-----------------------------------------------
3706C S o u r c e L i n e s
3707C-----------------------------------------------
3708 loc_proc = ispmd + 1
3709C------recive--
3710 l=1
3711 DO i=1,nspmd
3712 IF(i/=loc_proc)THEN
3713 siz = (iad_r(i+1)-iad_r(i))*SIZE
3714 IF(siz>0)THEN
3715 msgtyp = msgoff
3716 CALL mpi_irecv(
3717 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
3718 g spmd_comm_world,req_r(i),ierror)
3719 l = l+siz
3720 ENDIF
3721 ENDIF
3722 END DO
3723C
3724C preparation envoi a proc I
3725C--------------------------------------------------------------------
3726 l=0
3727 DO i=1,nspmd
3728 IF(i/=loc_proc)THEN
3729 DO j=iad_s(i),iad_s(i+1)-1
3730 DO nod = 1,SIZE
3731 sbuf(l+nod)=ks11(nod,j)
3732 ENDDO
3733 l = l+SIZE
3734 ENDDO
3735 ENDIF
3736 ENDDO
3737C
3738C echange messages
3739C--------------------------------------------------------------------
3740 l=1
3741 DO i=1,nspmd
3742 IF(i/=loc_proc)THEN
3743 siz = (iad_s(i+1)-iad_s(i))*SIZE
3744 IF(siz>0)THEN
3745 msgtyp = msgoff
3746 CALL mpi_isend(
3747 s sbuf(l),siz,real,it_spmd(i),msgtyp,
3748 g spmd_comm_world,req_s(i),ierror)
3749 l = l+siz
3750 ENDIF
3751 ENDIF
3752 ENDDO
3753C
3754C assemblage
3755C--------------------------------------------------------------------
3756 l=0
3757 DO i=1,nspmd
3758 IF(i/=loc_proc.AND.iad_r(i+1)>iad_r(i))THEN
3759 CALL mpi_wait(req_r(i),status,ierror)
3760 DO j=iad_r(i),iad_r(i+1)-1
3761 DO nod = 1,SIZE
3762 kr11(nod,j)=rbuf(l+nod)
3763 ENDDO
3764 l = l+SIZE
3765 ENDDO
3766 ENDIF
3767 ENDDO
3768C
3769C wait terminaison isend
3770C--------------------------------------------------------------------
3771 DO i = 1, nspmd
3772 IF(iad_s(i+1)-iad_s(i)>0)THEN
3773 CALL mpi_wait(req_s(i),status,ierror)
3774 ENDIF
3775 ENDDO
3776C
3777 RETURN
3778#endif
3779 END
3780!||====================================================================
3781!|| spmd_ifru ../engine/source/mpi/implicit/imp_spmd.F
3782!||--- called by ------------------------------------------------------
3783!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
3784!||--- calls -----------------------------------------------------
3785!||--- uses -----------------------------------------------------
3786!|| imp_intm ../engine/share/modules/imp_intm.F
3787!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3788!||====================================================================
3789 SUBROUTINE spmd_ifru(LX )
3790C-----------------------------------------------
3791C M o d u l e s
3792C-----------------------------------------------
3793 USE imp_intm
3794C-----------------------------------------------
3795C I m p l i c i t T y p e s
3796C-----------------------------------------------
3797 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3798#include "implicit_f.inc"
3799C-----------------------------------------------
3800C C o m m o n B l o c k s
3801C-----------------------------------------------
3802#include "com01_c.inc"
3803#include "task_c.inc"
3804C-----------------------------------------------
3805C M e s s a g e P a s s i n g
3806C-----------------------------------------------
3807#include "spmd.inc"
3808C-----------------------------------------------
3809C D u m m y A r g u m e n t s
3810C-----------------------------------------------
3811 my_real
3812 . lx(*)
3813#if defined(MPI) && defined(MUMPS5)
3814C-----------------------------------------------
3815C L o c a l V a r i a b l e s
3816C-----------------------------------------------
3817 INTEGER MSGOFF,MSGTYP,I,ID,LOC_PROC,IERROR,
3818 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
3819 . REQ_R(NSPMD),REQ_S(NSPMD)
3820 my_real
3821 . rbuf(nddl_si), sbuf(nddl_sl)
3822 DATA msgoff/16061/
3823C-----------------------------------------------
3824C S o u r c e L i n e s
3825C-----------------------------------------------
3826 loc_proc = ispmd + 1
3827C ------ com. de D nodes SECONDARYs -----
3828C------recive--
3829 l=1
3830 DO i=1,nspmd
3831 IF(i/=loc_proc)THEN
3832 siz = iad_srem(i+1)-iad_srem(i)
3833 IF(siz>0)THEN
3834 msgtyp = msgoff
3835 CALL mpi_irecv(
3836 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
3837 g spmd_comm_world,req_r(i),ierror)
3838 l = l+siz
3839 ENDIF
3840 ENDIF
3841 END DO
3842C
3843C preparation envoi a proc I
3844C--------------------------------------------------------------------
3845 l=1
3846 DO i=1,nspmd
3847 IF(i/=loc_proc)THEN
3848 DO j=iad_sl(i),iad_sl(i+1)-1
3849 id=iddl_sl(j)
3850 sbuf(l) = lx(id)
3851 l = l+1
3852 ENDDO
3853 ENDIF
3854 ENDDO
3855C
3856C echange messages
3857C--------------------------------------------------------------------
3858 l=1
3859 DO i=1,nspmd
3860 IF(i/=loc_proc)THEN
3861 siz = iad_sl(i+1)-iad_sl(i)
3862 IF(siz>0)THEN
3863 msgtyp = msgoff
3864 CALL mpi_isend(
3865 s sbuf(l),siz,real,it_spmd(i),msgtyp,
3866 g spmd_comm_world,req_s(i),ierror)
3867 l = l+siz
3868 ENDIF
3869 ENDIF
3870 ENDDO
3871C
3872C assemblage
3873C--------------------------------------------------------------------
3874 l=1
3875 DO i=1,nspmd
3876 IF(i/=loc_proc.AND.iad_srem(i+1)>iad_srem(i))THEN
3877 CALL mpi_wait(req_r(i),status,ierror)
3878 DO j=iad_srem(i),iad_srem(i+1)-1
3879 usi(j) = rbuf(l)
3880 l = l+1
3881 ENDDO
3882 ENDIF
3883 ENDDO
3884C
3885C wait terminaison isend
3886C--------------------------------------------------------------------
3887 DO i = 1, nspmd
3888 IF(iad_sl(i+1)-iad_sl(i)>0)THEN
3889 CALL mpi_wait(req_s(i),status,ierror)
3890 ENDIF
3891 ENDDO
3892C
3893 RETURN
3894#endif
3895 END
3896
3897!||====================================================================
3898!|| spmd_ifrf ../engine/source/mpi/implicit/imp_spmd.F
3899!||--- called by ------------------------------------------------------
3900!|| fr_matv ../engine/source/mpi/implicit/imp_fri.F
3901!|| imp_frkd ../engine/source/mpi/implicit/imp_fri.F
3902!||--- calls -----------------------------------------------------
3903!||--- uses -----------------------------------------------------
3904!|| imp_intm ../engine/share/modules/imp_intm.F
3905!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
3906!||====================================================================
3907 SUBROUTINE spmd_ifrf(F_IMP )
3908C-----------------------------------------------
3909C M o d u l e s
3910C-----------------------------------------------
3911 USE imp_intm
3912C-----------------------------------------------
3913C I m p l i c i t T y p e s
3914C-----------------------------------------------
3915 USE spmd_comm_world_mod, ONLY : spmd_comm_world
3916#include "implicit_f.inc"
3917C-----------------------------------------------
3918C C o m m o n B l o c k s
3919C-----------------------------------------------
3920#include "com01_c.inc"
3921#include "task_c.inc"
3922C-----------------------------------------------
3923C M e s s a g e P a s s i n g
3924C-----------------------------------------------
3925#include "spmd.inc"
3926C-----------------------------------------------
3927C D u m m y A r g u m e n t s
3928C-----------------------------------------------
3929 my_real
3930 . f_imp(*)
3931#if defined(MPI) && defined(MUMPS5)
3932C-----------------------------------------------
3933C L o c a l V a r i a b l e s
3934C-----------------------------------------------
3935 INTEGER MSGOFF,MSGTYP,I,ID,LOC_PROC,IERROR,
3936 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
3937 . REQ_R(NSPMD),REQ_S(NSPMD)
3938 my_real
3939 . rbuf(nddl_sl), sbuf(nddl_si)
3940 DATA msgoff/16035/
3941C-----------------------------------------------
3942C S o u r c e L i n e s
3943C-----------------------------------------------
3944 loc_proc = ispmd + 1
3945C ------ comm. de F nodes SECONDARYs -----
3946C------recive--
3947 l=1
3948 DO i=1,nspmd
3949 IF(i/=loc_proc)THEN
3950 siz = iad_sl(i+1)-iad_sl(i)
3951 IF(siz>0)THEN
3952 msgtyp = msgoff
3953 CALL mpi_irecv(
3954 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
3955 g spmd_comm_world,req_r(i),ierror)
3956 l = l+siz
3957 ENDIF
3958 ENDIF
3959 END DO
3960C
3961C preparation envoi a proc I
3962C--------------------------------------------------------------------
3963 l=1
3964 DO i=1,nspmd
3965 IF(i/=loc_proc)THEN
3966 DO j=iad_srem(i),iad_srem(i+1)-1
3967 sbuf(l) = fsi(j)
3968 l = l + 1
3969 ENDDO
3970 ENDIF
3971 ENDDO
3972C
3973C echange messages
3974C--------------------------------------------------------------------
3975 l=1
3976 DO i=1,nspmd
3977 IF(i/=loc_proc)THEN
3978 siz = iad_srem(i+1)-iad_srem(i)
3979 IF(siz>0)THEN
3980 msgtyp = msgoff
3981 CALL mpi_isend(
3982 s sbuf(l),siz,real,it_spmd(i),msgtyp,
3983 g spmd_comm_world,req_s(i),ierror)
3984 l = l+siz
3985 ENDIF
3986 ENDIF
3987 ENDDO
3988C
3989C assemblage
3990C--------------------------------------------------------------------
3991 l=1
3992 DO i=1,nspmd
3993 IF(i/=loc_proc.AND.iad_sl(i+1)>iad_sl(i))THEN
3994 CALL mpi_wait(req_r(i),status,ierror)
3995 DO j=iad_sl(i),iad_sl(i+1)-1
3996 id=iddl_sl(j)
3997 f_imp(id) = f_imp(id) + rbuf(l)
3998 l = l + 1
3999 ENDDO
4000 ENDIF
4001 ENDDO
4002C
4003C wait terminaison isend
4004C--------------------------------------------------------------------
4005 DO i = 1, nspmd
4006 IF(iad_srem(i+1)-iad_srem(i)>0)THEN
4007 CALL mpi_wait(req_s(i),status,ierror)
4008 ENDIF
4009 ENDDO
4010C
4011 RETURN
4012#endif
4013 END
4014!||====================================================================
4015!|| spmd_ifru_gpu ../engine/source/mpi/implicit/imp_spmd.F
4016!||--- called by ------------------------------------------------------
4017!|| fr_matv_gpu ../engine/source/mpi/implicit/imp_fri.F
4018!||--- calls -----------------------------------------------------
4019!||--- uses -----------------------------------------------------
4020!|| imp_intm ../engine/share/modules/imp_intm.F
4021!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
4022!||====================================================================
4023 SUBROUTINE spmd_ifru_gpu(LX,NINDEX)
4024C-----------------------------------------------
4025C M o d u l e s
4026C-----------------------------------------------
4027 USE imp_intm
4028C-----------------------------------------------
4029C I m p l i c i t T y p e s
4030C-----------------------------------------------
4031 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4032#include "implicit_f.inc"
4033C-----------------------------------------------
4034C C o m m o n B l o c k s
4035C-----------------------------------------------
4036#include "com01_c.inc"
4037#include "task_c.inc"
4038C-----------------------------------------------
4039C M e s s a g e P a s s i n g
4040C-----------------------------------------------
4041#include "spmd.inc"
4042C-----------------------------------------------
4043C D u m m y A r g u m e n t s
4044C-----------------------------------------------
4045 INTEGER NINDEX(*)
4046 my_real
4047 . LX(*)
4048#if defined(MPI) && defined(MUMPS5)
4049C-----------------------------------------------
4050C L o c a l V a r i a b l e s
4051C-----------------------------------------------
4052 INTEGER MSGOFF,MSGTYP,I,II,ID,LOC_PROC,IERROR,
4053 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
4054 . req_r(nspmd),req_s(nspmd)
4055 my_real
4056 . rbuf(nddl_si), sbuf(nddl_sl)
4057 DATA msgoff/16036/
4058C-----------------------------------------------
4059C S o u r c e L i n e s
4060C-----------------------------------------------
4061 loc_proc = ispmd + 1
4062C ------ com. de D nodes SECONDARYs -----
4063C------recive--
4064 l=1
4065 DO i=1,nspmd
4066 IF(i/=loc_proc)THEN
4067 siz = iad_srem(i+1)-iad_srem(i)
4068 IF(siz>0)THEN
4069 msgtyp = msgoff
4070 CALL mpi_irecv(
4071 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
4072 g spmd_comm_world,req_r(i),ierror)
4073 l = l+siz
4074 ENDIF
4075 ENDIF
4076 END DO
4077C
4078C preparation envoi a proc I
4079C--------------------------------------------------------------------
4080 l=1
4081 DO i=1,nspmd
4082 IF(i/=loc_proc)THEN
4083 DO j=iad_sl(i),iad_sl(i+1)-1
4084 id=iddl_sl(j)
4085 ii=nindex(id)
4086 sbuf(l) = lx(ii)
4087 l = l+1
4088 ENDDO
4089 ENDIF
4090 ENDDO
4091C
4092C echange messages
4093C--------------------------------------------------------------------
4094 l=1
4095 DO i=1,nspmd
4096 IF(i/=loc_proc)THEN
4097 siz = iad_sl(i+1)-iad_sl(i)
4098 IF(siz>0)THEN
4099 msgtyp = msgoff
4100 CALL mpi_isend(
4101 s sbuf(l),siz,real,it_spmd(i),msgtyp,
4102 g spmd_comm_world,req_s(i),ierror)
4103 l = l+siz
4104 ENDIF
4105 ENDIF
4106 ENDDO
4107C
4108C assemblage
4109C--------------------------------------------------------------------
4110 l=1
4111 DO i=1,nspmd
4112 IF(i/=loc_proc.AND.iad_srem(i+1)>iad_srem(i))THEN
4113 CALL mpi_wait(req_r(i),status,ierror)
4114 DO j=iad_srem(i),iad_srem(i+1)-1
4115 usi(j) = rbuf(l)
4116 l = l+1
4117 ENDDO
4118 ENDIF
4119 ENDDO
4120C
4121C wait terminaison isend
4122C--------------------------------------------------------------------
4123 DO i = 1, nspmd
4124 IF(iad_sl(i+1)-iad_sl(i)>0)THEN
4125 CALL mpi_wait(req_s(i),status,ierror)
4126 ENDIF
4127 ENDDO
4128C
4129 RETURN
4130#endif
4131 END
4132
4133!||====================================================================
4134!|| spmd_ifrf_gpu ../engine/source/mpi/implicit/imp_spmd.F
4135!||--- called by ------------------------------------------------------
4136!|| fr_matv_gpu ../engine/source/mpi/implicit/imp_fri.f
4137!||--- calls -----------------------------------------------------
4138!||--- uses -----------------------------------------------------
4139!|| imp_intm ../engine/share/modules/imp_intm.F
4140!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
4141!||====================================================================
4142 SUBROUTINE spmd_ifrf_gpu(F_IMP,NINDEX)
4143C-----------------------------------------------
4144C M o d u l e s
4145C-----------------------------------------------
4146 USE imp_intm
4147C-----------------------------------------------
4148C I m p l i c i t T y p e s
4149C-----------------------------------------------
4150 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4151#include "implicit_f.inc"
4152C-----------------------------------------------
4153C C o m m o n B l o c k s
4154C-----------------------------------------------
4155#include "com01_c.inc"
4156#include "task_c.inc"
4157C-----------------------------------------------
4158C M e s s a g e P a s s i n g
4159C-----------------------------------------------
4160#include "spmd.inc"
4161C-----------------------------------------------
4162C D u m m y A r g u m e n t s
4163C-----------------------------------------------
4164 INTEGER NINDEX(*)
4165 my_real
4166 . F_IMP(*)
4167#if defined(MPI) && defined(MUMPS5)
4168C-----------------------------------------------
4169C L o c a l V a r i a b l e s
4170C-----------------------------------------------
4171 INTEGER MSGOFF,MSGTYP,I,II,ID,LOC_PROC,IERROR,
4172 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
4173 . req_r(nspmd),req_s(nspmd)
4174 my_real
4175 . rbuf(nddl_sl), sbuf(nddl_si)
4176 DATA msgoff/16037/
4177C-----------------------------------------------
4178C S o u r c e L i n e s
4179C-----------------------------------------------
4180 loc_proc = ispmd + 1
4181C ------ comm. de F nodes SECONDARYs -----
4182C------recive--
4183 l=1
4184 DO i=1,nspmd
4185 IF(i/=loc_proc)THEN
4186 siz = iad_sl(i+1)-iad_sl(i)
4187 IF(siz>0)THEN
4188 msgtyp = msgoff
4189 CALL mpi_irecv(
4190 s rbuf(l),siz ,real,it_spmd(i),msgtyp,
4191 g spmd_comm_world,req_r(i),ierror)
4192 l = l+siz
4193 ENDIF
4194 ENDIF
4195 END DO
4196C
4197C preparation envoi a proc I
4198C--------------------------------------------------------------------
4199 l=1
4200 DO i=1,nspmd
4201 IF(i/=loc_proc)THEN
4202 DO j=iad_srem(i),iad_srem(i+1)-1
4203 sbuf(l) = fsi(j)
4204 l = l + 1
4205 ENDDO
4206 ENDIF
4207 ENDDO
4208C
4209C echange messages
4210C--------------------------------------------------------------------
4211 l=1
4212 DO i=1,nspmd
4213 IF(i/=loc_proc)THEN
4214 siz = iad_srem(i+1)-iad_srem(i)
4215 IF(siz>0)THEN
4216 msgtyp = msgoff
4217 CALL mpi_isend(
4218 s sbuf(l),siz,real,it_spmd(i),msgtyp,
4219 g spmd_comm_world,req_s(i),ierror)
4220 l = l+siz
4221 ENDIF
4222 ENDIF
4223 ENDDO
4224C
4225C assemblage
4226C--------------------------------------------------------------------
4227 l=1
4228 DO i=1,nspmd
4229 IF(i/=loc_proc.AND.iad_sl(i+1)>iad_sl(i))THEN
4230 CALL mpi_wait(req_r(i),status,ierror)
4231 DO j=iad_sl(i),iad_sl(i+1)-1
4232 id=iddl_sl(j)
4233 ii = nindex(id)
4234 f_imp(ii) = f_imp(ii) + rbuf(l)
4235 l = l + 1
4236 ENDDO
4237 ENDIF
4238 ENDDO
4239C
4240C wait terminaison isend
4241C--------------------------------------------------------------------
4242 DO i = 1, nspmd
4243 IF(iad_srem(i+1)-iad_srem(i)>0)THEN
4244 CALL mpi_wait(req_s(i),status,ierror)
4245 ENDIF
4246 ENDDO
4247C
4248 RETURN
4249#endif
4250 END
4251!||====================================================================
4252!|| spmd_ifri ../engine/source/mpi/implicit/imp_spmd.F
4253!||--- called by ------------------------------------------------------
4254!|| mumps_set ../engine/source/implicit/imp_mumps.F
4255!|| mumps_set2 ../engine/source/implicit/imp_mumps.F
4256!||--- calls -----------------------------------------------------
4257!||--- uses -----------------------------------------------------
4258!|| imp_intm ../engine/share/modules/imp_intm.F
4259!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
4260!||====================================================================
4261 SUBROUTINE spmd_ifri(IG, IL)
4262C-----------------------------------------------
4263C M o d u l e s
4264C-----------------------------------------------
4265 USE imp_intm
4266C-----------------------------------------------
4267C I m p l i c i t T y p e s
4268C-----------------------------------------------
4269 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4270#include "implicit_f.inc"
4271C-----------------------------------------------
4272C C o m m o n B l o c k s
4273C-----------------------------------------------
4274#include "com01_c.inc"
4275#include "task_c.inc"
4276C-----------------------------------------------
4277C M e s s a g e P a s s i n g
4278C-----------------------------------------------
4279#include "spmd.inc"
4280C-----------------------------------------------
4281C D u m m y A r g u m e n t s
4282C-----------------------------------------------
4283 INTEGER IG(*), IL(*)
4284#if defined(MPI) && defined(MUMPS5)
4285C-----------------------------------------------
4286C L o c a l V a r i a b l e s
4287C-----------------------------------------------
4288 INTEGER MSGOFF,MSGTYP,I,ID,LOC_PROC,IERROR,
4289 . SIZ,J,L,STATUS(MPI_STATUS_SIZE),
4290 . REQ_R(NSPMD),REQ_S(NSPMD),K
4291 INTEGER RBUF(NDDL_SI), SBUF(NDDL_SL)
4292 DATA msgoff/13038/
4293C-----------------------------------------------
4294C S o u r c e L i n e s
4295C-----------------------------------------------
4296 loc_proc = ispmd + 1
4297C ------ com. de D nodes SECONDARYs -----
4298C------recive--
4299 l=1
4300 DO i=1,nspmd
4301 IF(i/=loc_proc)THEN
4302 siz = iad_srem(i+1)-iad_srem(i)
4303 IF(siz>0)THEN
4304 msgtyp = msgoff
4305 CALL mpi_irecv(
4306 s rbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
4307 g spmd_comm_world,req_r(i),ierror)
4308 l = l+siz
4309 ENDIF
4310 ENDIF
4311 END DO
4312C
4313C preparation envoi a proc I
4314C--------------------------------------------------------------------
4315 l=1
4316 DO i=1,nspmd
4317 IF(i/=loc_proc)THEN
4318 DO j=iad_sl(i),iad_sl(i+1)-1
4319 id=iddl_sl(j)
4320 sbuf(l) = ig(id)
4321 l = l+1
4322 ENDDO
4323 ENDIF
4324 ENDDO
4325C
4326C echange messages
4327C--------------------------------------------------------------------
4328 l=1
4329 DO i=1,nspmd
4330 IF(i/=loc_proc)THEN
4331 siz = iad_sl(i+1)-iad_sl(i)
4332 IF(siz>0)THEN
4333 msgtyp = msgoff
4334 CALL mpi_isend(
4335 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
4336 g spmd_comm_world,req_s(i),ierror)
4337 l = l+siz
4338 ENDIF
4339 ENDIF
4340 ENDDO
4341C
4342C assemblage
4343C--------------------------------------------------------------------
4344 l=1
4345 DO i=1,nspmd
4346 IF(i/=loc_proc.AND.iad_srem(i+1)>iad_srem(i))THEN
4347 CALL mpi_wait(req_r(i),status,ierror)
4348 DO j=iad_srem(i),iad_srem(i+1)-1
4349 il(j) = rbuf(l)
4350 l = l+1
4351 ENDDO
4352 ENDIF
4353 ENDDO
4354C
4355C wait terminaison isend
4356C--------------------------------------------------------------------
4357 DO i = 1, nspmd
4358 IF(iad_sl(i+1)-iad_sl(i)>0)THEN
4359 CALL mpi_wait(req_s(i),status,ierror)
4360 ENDIF
4361 ENDDO
4362C
4363 RETURN
4364#endif
4365 END
4366!||====================================================================
4367!|| spmd_send_vi ../engine/source/mpi/implicit/imp_spmd.f
4368!||--- called by ------------------------------------------------------
4369!|| imp_compabp ../engine/source/implicit/imp_solv.F
4370!||--- calls -----------------------------------------------------
4371!||--- uses -----------------------------------------------------
4372!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
4373!||====================================================================
4374 SUBROUTINE spmd_send_vi(
4375 1 NV ,NSIZ ,VI ,NVMAX ,IOUT )
4376C-----------------------------------------------
4377C I m p l i c i t T y p e s
4378C-----------------------------------------------
4379 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4380#include "implicit_f.inc"
4381C-----------------------------------------------
4382C C o m m o n B l o c k s
4383C-----------------------------------------------
4384#include "com01_c.inc"
4385#include "task_c.inc"
4386C-----------------------------------------------
4387C M e s s a g e P a s s i n g
4388C-----------------------------------------------
4389#include "spmd.inc"
4390C-----------------------------------------------
4391C D u m m y A r g u m e n t s
4392C-----------------------------------------------
4393 INTEGER NV ,NSIZ ,NVMAX ,IOUT
4394 INTEGER VI(NSIZ,*)
4395#if defined(MPI) && defined(MUMPS5)
4396C-----------------------------------------------
4397C L o c a l V a r i a b l e s
4398C-----------------------------------------------
4399 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
4400 . INDEX, SIZ, J , K , L ,IT ,IP ,NN ,
4401 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
4402 INTEGER
4403 . nbuf(nspmd),rbuf(nsiz*nvmax,nspmd)
4404 CHARACTER*25 MSG_TYPE(2)
4405 CHARACTER*25 CSP
4406 DATA MSGOFF/16039/
4407 DATA MSGOFF2/16040/
4408 DATA
4409 . msg_type
4410 . / '** WARNING **',
4411 . '!! ERROR !!'/
4412C-----------------------------------------------
4413C S o u r c e L i n e s
4414C-----------------------------------------------
4415 loc_proc = ispmd + 1
4416 siz = 1
4417 IF(ispmd==0) THEN
4418 DO i = 2, nspmd
4419 msgtyp=msgoff
4420 CALL mpi_irecv(rbuf(1,i),siz,mpi_integer,it_spmd(i),msgtyp,
4421 . spmd_comm_world,req_r(i-1),ierror)
4422 END DO
4423C
4424 DO n = 1, nspmd-1
4425 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
4426 i = index+1
4427 nbuf(i)=rbuf(1,i)
4428 END DO
4429 nbuf(1) = nv
4430C
4431 ELSE
4432 rbuf(1,1) = nv
4433 msgtyp = msgoff
4434 CALL mpi_send(rbuf,siz,mpi_integer,it_spmd(1),
4435 . msgtyp,spmd_comm_world,ierror)
4436 END IF
4437C
4438 IF(ispmd==0) THEN
4439 DO i = 2, nspmd
4440 siz = nsiz*nbuf(i)
4441 msgtyp=msgoff2
4442 CALL mpi_irecv(rbuf(1,i),siz,mpi_integer,it_spmd(i),msgtyp,
4443 . spmd_comm_world,req_r(i-1),ierror)
4444 END DO
4445C
4446 i = 1
4447 l = 1
4448 IF(nsiz==1) THEN
4449 DO j = 1, nbuf(i)
4450 nn = rbuf(l,i)
4451 WRITE(csp,'(A,I2.2)')'INTERFACE TYPE ',nn
4452 WRITE(iout,1100)msg_type(1),csp
4453 l = l + 1
4454 END DO
4455 ELSEIF(nsiz==3) THEN
4456 DO j = 1, nbuf(i)
4457 ip = 1000 + rbuf(l,i)
4458 it = rbuf(l+1,i)
4459 nn = rbuf(l+2,i)
4460 SELECT CASE(ip)
4461 CASE (1)
4462 WRITE(iout,1001)msg_type(it),nn
4463 CASE (2)
4464 WRITE(iout,1002)msg_type(it),nn
4465 CASE (3)
4466 WRITE(iout,1003)msg_type(it),nn
4467 CASE (4)
4468 WRITE(iout,1004)msg_type(it),nn
4469 CASE (5)
4470 WRITE(iout,1005)msg_type(it),nn
4471 CASE (6)
4472 WRITE(iout,1006)msg_type(it),nn
4473 CASE (7)
4474 WRITE(iout,1007)msg_type(it),nn
4475 CASE (8)
4476 WRITE(iout,1008)msg_type(it),nn
4477 CASE (9)
4478 WRITE(iout,1009)msg_type(it),nn
4479 CASE (10)
4480 WRITE(iout,1010)msg_type(it),nn
4481 CASE (11)
4482 WRITE(iout,1011)msg_type(it),nn
4483 CASE (12)
4484 WRITE(iout,1012)msg_type(it),nn
4485 CASE (13)
4486 WRITE(iout,1013)msg_type(it),nn
4487 CASE (14)
4488 WRITE(iout,1014)msg_type(it),nn
4489 CASE (15)
4490 WRITE(iout,1015)msg_type(it),nn
4491 END SELECT
4492 l = l + 3
4493 END DO
4494 END IF
4495 DO n = 1, nspmd-1
4496 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
4497C----------write in *.lis-----------
4498 i = index+1
4499 l = 1
4500 IF(nsiz==1) THEN
4501 DO j = 1, nbuf(i)
4502 nn = rbuf(l,i)
4503 WRITE(csp,'(A,I2.2)')'INTERFACE TYPE ',nn
4504 WRITE(iout,1100)msg_type(1),csp
4505 l = l + 1
4506 END DO
4507 ELSEIF(nsiz==3) THEN
4508 DO j = 1, nbuf(i)
4509 ip = rbuf(l,i)
4510 it = rbuf(l+1,i)
4511 nn = rbuf(l+2,i)
4512 SELECT CASE(ip)
4513 CASE (1)
4514 WRITE(iout,1001)msg_type(it),nn
4515 CASE (2)
4516 WRITE(iout,1002)msg_type(it),nn
4517 CASE (3)
4518 WRITE(iout,1003)msg_type(it),nn
4519 CASE (4)
4520 WRITE(iout,1004)msg_type(it),nn
4521 CASE (5)
4522 WRITE(iout,1005)msg_type(it),nn
4523 CASE (6)
4524 WRITE(iout,1006)msg_type(it),nn
4525 CASE (7)
4526 WRITE(iout,1007)msg_type(it),nn
4527 CASE (8)
4528 WRITE(iout,1008)msg_type(it),nn
4529 CASE (9)
4530 WRITE(iout,1009)msg_type(it),nn
4531 CASE (10)
4532 WRITE(iout,1010)msg_type(it),nn
4533 CASE (11)
4534 WRITE(iout,1011)msg_type(it),nn
4535 CASE (12)
4536 WRITE(iout,1012)msg_type(it),nn
4537 CASE (13)
4538 WRITE(iout,1013)msg_type(it),nn
4539 CASE (14)
4540 WRITE(iout,1014)msg_type(it),nn
4541 CASE (15)
4542 WRITE(iout,1015)msg_type(it),nn
4543 END SELECT
4544 l = l + 3
4545 END DO
4546 END IF
4547 END DO
4548C
4549 ELSE
4550 l = 0
4551 DO j = 1, nv
4552 DO k = 1, nsiz
4553 l = l + 1
4554 rbuf(l,1) = vi(k,j)
4555 END DO
4556 END DO
4557 siz = nsiz*nv
4558 msgtyp = msgoff2
4559 CALL mpi_send(rbuf,siz,mpi_integer,it_spmd(1),
4560 . msgtyp,spmd_comm_world,ierror)
4561 END IF
4562 RETURN
4563 1001 FORMAT(a,' NODE USED FOR DIFF. RBODY MAIN=',i8)
4564 1002 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4565 . 'RBODY MAIN AND INTERF. TYPE2 SECONDARY =',i8)
4566 1003 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4567 . 'INTERF. TYPE2 SECONDARY AND INTERF. TYPE2 SECONDARY=',i8)
4568 1004 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4569 . ' RBODY MAIN AND RBODY SECONDARY=',i8)
4570 1005 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4571 . ' INTERF. TYPE2 SECONDARY AND RBODY SECONDARY=',i8)
4572 1006 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4573 . ' RBODY SECONDARY AND RBODY SECONDARY=',i8)
4574 1007 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4575 . ' BOUNDARY CONDITIONS AND INTERF. TYPE2 SECONDARY=',i8)
4576 1008 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4577 . ' BOUNDARY CONDITIONS AND RBODY SECONDARY=',i8)
4578 1009 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4579 . ' IMPOSED DISP. AND INTERF. TYPE2 SECONDARY=',i8)
4580 1010 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4581 . ' IMPOSED DISP. AND RBODY SECONDARY=',i8)
4582 1011 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4583 . ' IMPOSED DISP. AND BOUNDARY CONDITIONS=',i8)
4584 1012 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4585 . ' RWALL CONTACT AND INTERF. TYPE2 SECONDARY=',i8)
4586 1013 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4587 . ' RWALL CONTACT AND RBODY SECONDARY=',i8)
4588 1014 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4589 . ' RWALL CONTACT AND BOUNDARY CONDITIONS=',i8)
4590 1015 FORMAT(a,' INCOMPABILITY NODE BETWEEN ',/
4591 . ' RWALL CONTACT AND IMPOSED DISP.=',i8)
4592 1100 FORMAT(a,' IMPLICIT IS INCOMPABLE WITH :',a/)
4593#endif
4594 END
4595!||====================================================================
4596!|| spmd_send_vr ../engine/source/mpi/implicit/imp_spmd.F
4597!||--- called by ------------------------------------------------------
4598!|| imp_check0 ../engine/source/implicit/imp_solv.F
4599!|| imp_checm0 ../engine/source/implicit/imp_solv.f
4600!||--- calls -----------------------------------------------------
4601!||--- uses -----------------------------------------------------
4602!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
4603!||====================================================================
4604 SUBROUTINE spmd_send_vr(
4605 1 NV ,NSIZ ,VR ,NVMAX ,IOUT )
4606C-----------------------------------------------
4607C I m p l i c i t T y p e s
4608C-----------------------------------------------
4609 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4610#include "implicit_f.inc"
4611C-----------------------------------------------
4612C C o m m o n B l o c k s
4613C-----------------------------------------------
4614#include "com01_c.inc"
4615#include "task_c.inc"
4616C-----------------------------------------------
4617C M e s s a g e P a s s i n g
4618C-----------------------------------------------
4619#include "spmd.inc"
4620C-----------------------------------------------
4621C D u m m y A r g u m e n t s
4622C-----------------------------------------------
4623 INTEGER NV ,NSIZ ,NVMAX ,IOUT
4624 my_real
4625 . VR(NSIZ,*)
4626#if defined(MPI) && defined(MUMPS5)
4627C-----------------------------------------------
4628C L o c a l V a r i a b l e s
4629C-----------------------------------------------
4630 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
4631 . INDEX, SIZ, J , K , L ,IT ,IP ,NN ,
4632 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
4633 INTEGER
4634 . nbuf(nspmd),nr(nspmd)
4635 my_real
4636 . rbuf(nsiz*nvmax,nspmd) ,s
4637 CHARACTER DIR(3)
4638 DATA DIR/'X','Y','Z'/
4639 DATA MSGOFF/16041/
4640 DATA MSGOFF2/16042/
4641C-----------------------------------------------
4642C S o u r c e L i n e s
4643C-----------------------------------------------
4644 loc_proc = ispmd + 1
4645 siz = 1
4646 IF(ispmd==0) THEN
4647 DO i = 2, nspmd
4648 msgtyp=msgoff
4649 CALL mpi_irecv(nbuf(i),siz,mpi_integer,it_spmd(i),msgtyp,
4650 . spmd_comm_world,req_r(i-1),ierror)
4651 END DO
4652C
4653 DO n = 1, nspmd-1
4654 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
4655 i = index+1
4656 nr(i)=nbuf(i)
4657 END DO
4658 nr(1) = nv
4659C
4660 ELSE
4661 nbuf(1) = nv
4662 msgtyp = msgoff
4663 CALL mpi_send(nbuf,siz,mpi_integer,it_spmd(1),
4664 . msgtyp,spmd_comm_world,ierror)
4665 END IF
4666C
4667 IF(ispmd==0) THEN
4668 DO i = 2, nspmd
4669 siz = nsiz*nr(i)
4670 msgtyp=msgoff2
4671 CALL mpi_irecv(rbuf(1,i),siz,real,it_spmd(i),msgtyp,
4672 . spmd_comm_world,req_r(i-1),ierror)
4673 END DO
4674C
4675 i = 1
4676 l = 1
4677 DO j = 1, nr(i)
4678 nn = int(vr(l,i))
4679 it = int(vr(l+1,i))
4680 s = vr(l+2,i)
4681 IF (it<=3) THEN
4682 WRITE(iout,1001)nn,dir(it),s
4683 ELSE
4684 WRITE(iout,1002)nn,dir(it-3),s
4685 ENDIF
4686 l = l + 3
4687 END DO
4688 DO n = 1, nspmd-1
4689 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
4690C----------write in *.lis-----------
4691 i = index+1
4692 l = 1
4693 DO j = 1, nr(i)
4694 nn = int(rbuf(l,i))
4695 it = int(rbuf(l+1,i))
4696 s = rbuf(l+2,i)
4697 IF (it<=3) THEN
4698 WRITE(iout,1001)nn,dir(it),s
4699 ELSE
4700 WRITE(iout,1002)nn,dir(it-3),s
4701 ENDIF
4702 l = l + 3
4703 END DO
4704 END DO
4705C
4706 ELSE
4707 l = 0
4708 DO j = 1, nv
4709 DO k = 1, nsiz
4710 l = l + 1
4711 rbuf(l,1) = vr(k,j)
4712 END DO
4713 END DO
4714 msgtyp = msgoff2
4715 siz = nsiz*nv
4716 CALL mpi_send(rbuf,siz,real,it_spmd(1),
4717 . msgtyp,spmd_comm_world,ierror)
4718 END IF
4719 RETURN
4720 1001 FORMAT(' NODE NUM. =',i10,5x,'TRA_DIR = ',1a,5x,'VAL.= ',g14.7)
4721 1002 FORMAT(' NODE NUM. =',i10,5x,'ROT_DIR = ',1a,5x,'VAL.= ',g14.7)
4722#endif
4723 END
4724
4725!||====================================================================
4726!|| spmd_nddlig ../engine/source/mpi/implicit/imp_spmd.F
4727!||--- called by ------------------------------------------------------
4728!|| getnddli_g ../engine/source/mpi/implicit/imp_fri.F
4729!||--- calls -----------------------------------------------------
4730!||--- uses -----------------------------------------------------
4731!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
4732!||====================================================================
4733 SUBROUTINE spmd_nddlig(NDDL ,NDDLFR ,NDDLG )
4734C-----------------------------------------------
4735C I m p l i c i t T y p e s
4736C-----------------------------------------------
4737 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4738#include "implicit_f.inc"
4739C-----------------------------------------------
4740C C o m m o n B l o c k s
4741C-----------------------------------------------
4742#include "com01_c.inc"
4743#include "task_c.inc"
4744C-----------------------------------------------
4745C M e s s a g e P a s s i n g
4746C-----------------------------------------------
4747#include "spmd.inc"
4748C-----------------------------------------------
4749C D u m m y A r g u m e n t s
4750C-----------------------------------------------
4751 INTEGER NDDL ,NDDLFR ,NDDLG
4752C-----------------------------------------------
4753C L o c a l V a r i a b l e s
4754C-----------------------------------------------
4755 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
4756 . INDEX, SIZ,
4757 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
4758 INTEGER
4759 . RBUF(NSPMD),SI
4760 DATA MSGOFF/16043/,MSGOFF2/16044/
4761#if defined(MPI) && defined(MUMPS5)
4762C-----------------------------------------------
4763C S o u r c e L i n e s
4764C-----------------------------------------------
4765 loc_proc = ispmd + 1
4766 siz=1
4767 rbuf(1) = nddl
4768 IF(ispmd==0) THEN
4769 DO i = 2, nspmd
4770 msgtyp=msgoff
4771 CALL mpi_irecv(rbuf(i),siz,mpi_integer,it_spmd(i),msgtyp,
4772 . spmd_comm_world,req_r(i-1),ierror)
4773 END DO
4774C
4775 DO n = 1, nspmd-1
4776 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
4777 i = index+1
4778 rbuf(1) = rbuf(1) + rbuf(i)
4779 END DO
4780C
4781 nddlg = rbuf(1)-nddlfr
4782 DO i = 2, nspmd
4783 msgtyp=msgoff2
4784 CALL mpi_send(nddlg,siz,mpi_integer,it_spmd(i),
4785 . msgtyp,spmd_comm_world,ierror)
4786 END DO
4787C
4788 ELSE
4789 msgtyp = msgoff
4790 CALL mpi_send(rbuf,siz,mpi_integer,it_spmd(1),
4791 . msgtyp,spmd_comm_world,ierror)
4792 msgtyp = msgoff2
4793 CALL mpi_recv(nddlg,siz,mpi_integer,it_spmd(1),msgtyp,
4794 . spmd_comm_world,status,ierror)
4795 END IF
4796C
4797 RETURN
4798#endif
4799 END
4800
4801!||====================================================================
4802!|| spmd_max_ii ../engine/source/mpi/implicit/imp_spmd.F
4803!||--- called by ------------------------------------------------------
4804!|| sms_rbe3_nodxi ../engine/source/ams/sms_rbe3.F
4805!||--- calls -----------------------------------------------------
4806!||--- uses -----------------------------------------------------
4807!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.f90
4808!||====================================================================
4809 SUBROUTINE spmd_max_ii(NMAX,IAD_ELEM,TSIZE)
4810C-----------------------------------------------
4811C I m p l i c i t T y p e s
4812C-----------------------------------------------
4813 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4814#include "implicit_f.inc"
4815C-----------------------------------------------
4816C C o m m o n B l o c k s
4817C-----------------------------------------------
4818#include "com01_c.inc"
4819#include "task_c.inc"
4820C-----------------------------------------------
4821C M e s s a g e P a s s i n g
4822C-----------------------------------------------
4823#include "spmd.inc"
4824C-----------------------------------------------
4825C D u m m y A r g u m e n t s
4826C-----------------------------------------------
4827 INTEGER NMAX,IAD_ELEM(*),TSIZE
4828#if defined(MPI)
4829C-----------------------------------------------
4830C L o c a l V a r i a b l e s
4831C-----------------------------------------------
4832 INTEGER MSGOFF,MSGTYP,NOD,LOC_PROC,IERROR,
4833 . STATUS(MPI_STATUS_SIZE),SIZ,
4834 . REQ_R(NSPMD),REQ_S(NSPMD),
4835 . I,J,K,L
4836 INTEGER
4837 . RBUF(TSIZE), SBUF(TSIZE)
4838 DATA msgoff/16045/
4839C-----------------------------------------------
4840C S o u r c e L i n e s
4841C-----------------------------------------------
4842 loc_proc = ispmd + 1
4843 DO i=1,nspmd
4844 siz = iad_elem(i+1)-iad_elem(i)
4845 IF(siz>0)THEN
4846 l = iad_elem(i)
4847 msgtyp = msgoff
4848 CALL mpi_irecv(
4849 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
4850 g spmd_comm_world,req_r(i),ierror)
4851 ENDIF
4852 END DO
4853C
4854C preparation envoi a proc I
4855C--------------------------------------------------------------------
4856 DO i=1,nspmd
4857 DO j=iad_elem(i),iad_elem(i+1)-1
4858 sbuf(j) = nmax
4859 ENDDO
4860 ENDDO
4861C
4862C echange messages
4863C--------------------------------------------------------------------
4864 DO i=1,nspmd
4865 siz = iad_elem(i+1)-iad_elem(i)
4866 IF(siz>0)THEN
4867 l = iad_elem(i)
4868 msgtyp = msgoff
4869 CALL mpi_isend(
4870 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
4871 g spmd_comm_world,req_s(i),ierror)
4872 ENDIF
4873 ENDDO
4874C
4875C assemblage
4876C--------------------------------------------------------------------
4877 DO i=1,nspmd
4878 siz = iad_elem(i+1)-iad_elem(i)
4879 IF(siz>0)THEN
4880 CALL mpi_wait(req_r(i),status,ierror)
4881 DO j=iad_elem(i),iad_elem(i+1)-1
4882 nmax = max(nmax,rbuf(j))
4883 ENDDO
4884 ENDIF
4885 ENDDO
4886C
4887C wait terminaison isend
4888C--------------------------------------------------------------------
4889 DO i = 1, nspmd
4890 IF((iad_elem(i+1)-iad_elem(i))>0)THEN
4891 CALL mpi_wait(req_s(i),status,ierror)
4892 ENDIF
4893 ENDDO
4894C
4895 RETURN
4896#endif
4897 END
4898!||====================================================================
4899!|| spmd_max_f ../engine/source/mpi/implicit/imp_spmd.F
4900!||--- called by ------------------------------------------------------
4901!|| pr_solnfo ../engine/source/implicit/imp_solv.F
4902!||--- calls -----------------------------------------------------
4903!||--- uses -----------------------------------------------------
4904!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.f90
4905!||====================================================================
4906 SUBROUTINE spmd_max_f(F,ITAB,K)
4907C-----------------------------------------------
4908C I m p l i c i t T y p e s
4909C-----------------------------------------------
4910 USE spmd_comm_world_mod, ONLY : spmd_comm_world
4911#include "implicit_f.inc"
4912C-----------------------------------------------
4913C C o m m o n B l o c k s
4914C-----------------------------------------------
4915#include "com01_c.inc"
4916#include "task_c.inc"
4917C-----------------------------------------------
4918C M e s s a g e P a s s i n g
4919C-----------------------------------------------
4920#include "spmd.inc"
4921C-----------------------------------------------
4922C D u m m y A r g u m e n t s
4923C-----------------------------------------------
4924 INTEGER ITAB, K
4925 my_real F
4926#if defined(MPI)
4927C-----------------------------------------------
4928C L o c a l V a r i a b l e s
4929C-----------------------------------------------
4930 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
4931 . MSGTYP2, MSGTYP3, MSGOFF3, MSGOFF4, MSGOFF5, MSGOFF6,
4932 . INDEX, SIZ,SIZ2,SIZ3,
4933 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD),
4934 . IBUF1(NSPMD), IBUF2(NSPMD)
4935 my_real
4936 . rbuf(nspmd),si
4937 DATA msgoff/16046/,msgoff2/16047/
4938 DATA msgoff3/16048/,msgoff4/16049/
4939 DATA msgoff5/16050/,msgoff6/16051/
4940C-----------------------------------------------
4941C S o u r c e L i n e s
4942C-----------------------------------------------
4943 loc_proc = ispmd + 1
4944 siz=1
4945 siz2=1
4946 siz3=1
4947 IF(ispmd==0) THEN
4948 DO i = 2, nspmd
4949 msgtyp=msgoff
4950 msgtyp2=msgoff3
4951 msgtyp3=msgoff5
4952 CALL mpi_irecv(rbuf(i),siz,real,it_spmd(i),msgtyp,
4953 . spmd_comm_world,req_r(i-1),ierror)
4954 CALL mpi_irecv(ibuf1(i),siz2,mpi_integer,it_spmd(i),msgtyp2,
4955 . spmd_comm_world,req_r(i-1),ierror)
4956 CALL mpi_irecv(ibuf2(i),siz3,mpi_integer,it_spmd(i),msgtyp3,
4957 . spmd_comm_world,req_r(i-1),ierror)
4958 END DO
4959C
4960 DO n = 1, nspmd-1
4961 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
4962 i = index+1
4963 IF (abs(rbuf(i)) > abs(f)) THEN
4964 f = rbuf(i)
4965 itab = ibuf1(i)
4966 k = ibuf2(i)
4967 ENDIF
4968 END DO
4969C
4970 DO i = 2, nspmd
4971 msgtyp=msgoff2
4972 msgtyp2=msgoff4
4973 msgtyp3=msgoff6
4974 CALL mpi_send(f,siz,real,it_spmd(i),
4975 . msgtyp,spmd_comm_world,ierror)
4976 CALL mpi_send(itab,siz2,mpi_integer,it_spmd(i),
4977 . msgtyp2,spmd_comm_world,ierror)
4978 CALL mpi_send(k,siz3,mpi_integer,it_spmd(i),
4979 . msgtyp3,spmd_comm_world,ierror)
4980 END DO
4981 ELSE
4982 msgtyp = msgoff
4983 msgtyp2 = msgoff3
4984 msgtyp3 = msgoff5
4985 CALL mpi_send(f,siz,real,it_spmd(1),
4986 . msgtyp,spmd_comm_world,ierror)
4987 CALL mpi_send(itab,siz2,mpi_integer,it_spmd(1),
4988 . msgtyp2,spmd_comm_world,ierror)
4989 CALL mpi_send(k,siz3,mpi_integer,it_spmd(1),
4990 . msgtyp3,spmd_comm_world,ierror)
4991 msgtyp = msgoff2
4992 msgtyp2 = msgoff4
4993 msgtyp3 = msgoff6
4994 CALL mpi_recv(f,siz,real,it_spmd(1),msgtyp,
4995 . spmd_comm_world,status,ierror)
4996 CALL mpi_recv(itab,siz2,mpi_integer,it_spmd(1),msgtyp2,
4997 . spmd_comm_world,status,ierror)
4998 CALL mpi_recv(k,siz3,mpi_integer,it_spmd(1),msgtyp3,
4999 . spmd_comm_world,status,ierror)
5000
5001 END IF
5002C
5003 RETURN
5004#endif
5005 END
5006
5007!||====================================================================
5008!|| spmd_max_iv ../engine/source/mpi/implicit/imp_spmd.F
5009!||--- called by ------------------------------------------------------
5010!|| upd_fr_k ../engine/source/mpi/implicit/imp_fri.F
5011!||--- calls -----------------------------------------------------
5012!||--- uses -----------------------------------------------------
5013!|| imp_frk ../engine/share/modules/impbufdef_mod.F
5014!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
5015!||====================================================================
5016 SUBROUTINE spmd_max_iv(IV )
5017C-----------------------------------------------
5018C M o d u l e s
5019C-----------------------------------------------
5020 USE imp_frk
5021C-----------------------------------------------
5022C I m p l i c i t T y p e s
5023C-----------------------------------------------
5024 USE spmd_comm_world_mod, ONLY : spmd_comm_world
5025#include "implicit_f.inc"
5026C-----------------------------------------------
5027C C o m m o n B l o c k s
5028C-----------------------------------------------
5029#include "com01_c.inc"
5030#include "task_c.inc"
5031C-----------------------------------------------
5032C M e s s a g e P a s s i n g
5033C-----------------------------------------------
5034#include "spmd.inc"
5035C-----------------------------------------------
5036C D u m m y A r g u m e n t s
5037C-----------------------------------------------
5038 integer
5039 . iv(*)
5040#if defined(MPI) && defined(MUMPS5)
5041C-----------------------------------------------
5042C L o c a l V a r i a b l e s
5043C-----------------------------------------------
5044 INTEGER MSGOFF,MSGTYP,I,NOD,LOC_PROC,IERROR,
5045 . SIZ,J,K,L,ND,ID,
5046 . STATUS(MPI_STATUS_SIZE),
5047 . REQ_R(NSPMD),REQ_S(NSPMD)
5048 INTEGER
5049 . rbuf(nddlfr), sbuf(nddlfr)
5050 DATA msgoff/16052/
5051C-----------------------------------------------
5052C S o u r c e L i n e s
5053C-----------------------------------------------
5054 IF (nddlfr<=0) RETURN
5055C
5056 loc_proc = ispmd + 1
5057C
5058 l=1
5059 DO i=1,nspmd
5060 siz = nd_fr(i)
5061 IF(siz>0)THEN
5062 msgtyp = msgoff
5063 CALL mpi_irecv(
5064 s rbuf(l),siz ,mpi_integer,it_spmd(i),msgtyp,
5065 g spmd_comm_world,req_r(i),ierror)
5066 l = l+ nd_fr(i)
5067 ENDIF
5068 END DO
5069C
5070C preparation envoi a proc I
5071C--------------------------------------------------------------------
5072 l = 0
5073 DO i=1,nspmd
5074 IF(nd_fr(i)>0)THEN
5075 DO j=1,nd_fr(i)
5076 id = j + l
5077 sbuf(id) = iv(id)
5078 ENDDO
5079 l = l +nd_fr(i)
5080 ENDIF
5081 ENDDO
5082C
5083C echange messages
5084C--------------------------------------------------------------------
5085 l = 1
5086 DO i=1,nspmd
5087 siz = nd_fr(i)
5088 IF(siz>0)THEN
5089 msgtyp = msgoff
5090 CALL mpi_isend(
5091 s sbuf(l),siz,mpi_integer,it_spmd(i),msgtyp,
5092 g spmd_comm_world,req_s(i),ierror)
5093 l = l +nd_fr(i)
5094 ENDIF
5095 ENDDO
5096C
5097C assemblage
5098C--------------------------------------------------------------------
5099 l = 0
5100 DO i=1,nspmd
5101 IF(nd_fr(i)>0)THEN
5102 CALL mpi_wait(req_r(i),status,ierror)
5103 DO j=1,nd_fr(i)
5104 id = j + l
5105 iv(id) = max(iv(id) ,rbuf(id) )
5106 ENDDO
5107 l = l +nd_fr(i)
5108 ENDIF
5109 ENDDO
5110C
5111C wait terminaison isend
5112C--------------------------------------------------------------------
5113 DO i = 1, nspmd
5114 IF(nd_fr(i)>0)THEN
5115 CALL mpi_wait(req_s(i),status,ierror)
5116 ENDIF
5117 ENDDO
5118C
5119 RETURN
5120#endif
5121 END
5122!||====================================================================
5123!|| spmd_int_allreduce_max ../engine/source/mpi/implicit/imp_spmd.F
5124!||--- called by ------------------------------------------------------
5125!|| print_stiff_mat ../engine/source/implicit/imp_mumps.F
5126!||--- calls -----------------------------------------------------
5127!||--- uses -----------------------------------------------------
5128!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
5129!||====================================================================
5130 SUBROUTINE spmd_int_allreduce_max(SENDBUF,RECVBUF,COUNT)
5131C-----------------------------------------------
5132C I m p l i c i t T y p e s
5133C-----------------------------------------------
5134 USE spmd_comm_world_mod, ONLY : spmd_comm_world
5135#include "implicit_f.inc"
5136C-----------------------------------------------
5137C C o m m o n B l o c k s
5138C-----------------------------------------------
5139#include "com01_c.inc"
5140#include "task_c.inc"
5141C-----------------------------------------------
5142C M e s s a g e P a s s i n g
5143C-----------------------------------------------
5144#include "spmd.inc"
5145C-----------------------------------------------
5146C D u m m y A r g u m e n t s
5147C-----------------------------------------------
5148 INTEGER SENDBUF(*),RECVBUF(*),COUNT
5149#if defined(MPI) && defined(MUMPS5)
5150C-----------------------------------------------
5151C L o c a l V a r i a b l e s
5152C-----------------------------------------------
5153 INTEGER IERROR
5154C-----------------------------------------------
5155C S o u r c e L i n e s
5156C-----------------------------------------------
5157C MPI_ALLREDUCE with MAX function applied to table of integers
5158 CALL MPI_ALLREDUCE(SENDBUF,RECVBUF,COUNT,
5159 . mpi_integer,mpi_max,
5160 . spmd_comm_world,ierror)
5161C
5162 RETURN
5163#endif
5164 END
5165!||====================================================================
5166!|| spmd_e_ref ../engine/source/mpi/implicit/imp_spmd.F
5167!||--- called by ------------------------------------------------------
5168!|| spb_rm_rig ../engine/source/implicit/imp_solv.F
5169!||--- calls -----------------------------------------------------
5170!||--- uses -----------------------------------------------------
5171!|| imp_spbrm ../engine/share/modules/impbufdef_mod.F
5172!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
5173!||====================================================================
5174 SUBROUTINE spmd_e_ref(DMIN)
5175C-----------------------------------------------
5176C M o d u l e s
5177C-----------------------------------------------
5178 USE imp_spbrm
5179C-----------------------------------------------
5180C I m p l i c i t T y p e s
5181C-----------------------------------------------
5182 USE spmd_comm_world_mod, ONLY : spmd_comm_world
5183#include "implicit_f.inc"
5184C-----------------------------------------------
5185C C o m m o n B l o c k s
5186C-----------------------------------------------
5187#include "task_c.inc"
5188#include "com01_c.inc"
5189C-----------------------------------------------
5190C M e s s a g e P a s s i n g
5191C-----------------------------------------------
5192#include "spmd.inc"
5193C-----------------------------------------------
5194C D u m m y A r g u m e n t s
5195C-----------------------------------------------
5196 my_real dmin
5197#if defined(MPI) && defined(MUMPS5)
5198C-----------------------------------------------
5199C L o c a l V a r i a b l e s
5200C-----------------------------------------------
5201 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
5202 . INDEX, SIZ,IBUF(2),L,J,K,
5203 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
5204 my_real
5205 . RBUF(32+10,NSPMD),SI,SBUF(31+10)
5206 DATA MSGOFF/16053/
5207 DATA msgoff2/16054/
5208C-----------------------------------------------
5209C S o u r c e L i n e s
5210C-----------------------------------------------
5211 loc_proc = ispmd + 1
5212 siz = 32+10
5213 rbuf(1,1) = dmin
5214 rbuf(2,1) = n_seg
5215 rbuf(3:8,1) = ikce(1:6)
5216 l = 8
5217 DO i = 1,4
5218 DO k = 1,3
5219 l = l + 1
5220 rbuf(l,1) = x_ref(k,i)
5221 END DO
5222 END DO
5223 DO i = 1,4
5224 DO k = 1,3
5225 l = l + 1
5226 rbuf(l,1) = d_ref(k,i)
5227 END DO
5228 END DO
5229C
5230 DO i = 1,9
5231 l = l + 1
5232 rbuf(l,1) = rlskew(i)
5233 END DO
5234 l = l + 1
5235 rbuf(l,1) = lskew_g
5236C
5237 IF(ispmd==0) THEN
5238 DO i = 2, nspmd
5239 msgtyp=msgoff
5240 CALL mpi_irecv(rbuf(1,i),siz,real,it_spmd(i),msgtyp,
5241 . spmd_comm_world,req_r(i-1),ierror)
5242 END DO
5243C
5244 DO n = 1, nspmd-1
5245 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
5246 i = index+1
5247 IF (rbuf(1,1) > rbuf(1,i)) THEN
5248 rbuf(1,1) = rbuf(1,i)
5249 rbuf(2:8,1) = rbuf(2:8,i)
5250 l = 8
5251 DO j = 1,4
5252 DO k = 1,3
5253 l = l + 1
5254 rbuf(l,1) = rbuf(l,i)
5255 END DO
5256 END DO
5257 DO j = 1,4
5258 DO k = 1,3
5259 l = l + 1
5260 rbuf(l,1) = rbuf(l,i)
5261 END DO
5262 END DO
5263 DO k = 1,10
5264 l = l + 1
5265 rbuf(l,1) = rbuf(l,i)
5266 END DO
5267 END IF
5268 END DO
5269C
5270 l = 31+10
5271 sbuf(1:l)=rbuf(2:l+1,1)
5272 DO i = 2, nspmd
5273 msgtyp=msgoff2
5274 CALL mpi_send(sbuf,l,real,it_spmd(i),
5275 . msgtyp,spmd_comm_world,ierror)
5276 END DO
5277C
5278 ELSE
5279 msgtyp = msgoff
5280 l = 31+10
5281 CALL mpi_send(rbuf,siz,real,it_spmd(1),
5282 . msgtyp,spmd_comm_world,ierror)
5283 msgtyp = msgoff2
5284 CALL mpi_recv(sbuf,l,real,it_spmd(1),msgtyp,
5285 . spmd_comm_world,status,ierror)
5286 rbuf(2:l+1,1) = sbuf(1:l)
5287 END IF
5288 n_seg = int(rbuf(2,1))
5289 ikce(1:6) = int(rbuf(3:8,1))
5290 l = 8
5291 DO i = 1,4
5292 DO k = 1,3
5293 l = l + 1
5294 x_ref(k,i) = rbuf(l,1)
5295 END DO
5296 END DO
5297 DO i = 1,4
5298 DO k = 1,3
5299 l = l + 1
5300 d_ref(k,i) = rbuf(l,1)
5301 END DO
5302 END DO
5303 DO i = 1,9
5304 l = l + 1
5305 rlskew(i) = rbuf(l,1)
5306 END DO
5307 l = l + 1
5308 lskew_g = int(rbuf(l,1))
5309C
5310 RETURN
5311#endif
5312 END
5313!||====================================================================
5314!|| spmd_n_ref ../engine/source/mpi/implicit/imp_spmd.F
5315!||--- called by ------------------------------------------------------
5316!|| spb_rm_rig ../engine/source/implicit/imp_solv.F
5317!||--- calls -----------------------------------------------------
5318!||--- uses -----------------------------------------------------
5319!|| imp_spbrm ../engine/share/modules/impbufdef_mod.F
5320!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
5321!||====================================================================
5322 SUBROUTINE spmd_n_ref
5323C-----------------------------------------------
5324C M o d u l e s
5325C-----------------------------------------------
5326 USE imp_spbrm
5327C-----------------------------------------------
5328C I m p l i c i t T y p e s
5329C-----------------------------------------------
5330 USE spmd_comm_world_mod, ONLY : spmd_comm_world
5331#include "implicit_f.inc"
5332C-----------------------------------------------
5333C C o m m o n B l o c k s
5334C-----------------------------------------------
5335#include "com01_c.inc"
5336#include "task_c.inc"
5337C-----------------------------------------------
5338C M e s s a g e P a s s i n g
5339C-----------------------------------------------
5340#include "spmd.inc"
5341#if defined(MPI) && defined(MUMPS5)
5342C-----------------------------------------------
5343C L o c a l V a r i a b l e s
5344C-----------------------------------------------
5345 INTEGER I, N, MSGOFF, MSGOFF2, MSGTYP, IERROR, LOC_PROC,
5346 . INDEX, SIZ,IBUF(2),L,J,K,
5347 . STATUS(MPI_STATUS_SIZE), REQ_R(NSPMD)
5348 my_real
5349 . RBUF(27+10,NSPMD),SI,SBUF(27+10)
5350 DATA MSGOFF/16053/
5351 DATA MSGOFF2/16054/
5352C-----------------------------------------------
5353C S o u r c e L i n e s
5354C-----------------------------------------------
5355 LOC_PROC = ispmd + 1
5356 siz = 27+10
5357C------- 3xRBUF(1:7,1) :N1,X1,D1; RBUF(22,1) :ILSKEW; RBUF((23:37,1) :RLSKEW,IKCE
5358 l = 1
5359 i = 1
5360 rbuf(l,1) = e_ref(1)
5361 DO k = 1,3
5362 l = l + 1
5363 rbuf(l,1) = x_ref(k,i)
5364 END DO
5365 DO k = 1,3
5366 l = l + 1
5367 rbuf(l,1) = d_ref(k,i)
5368 END DO
5369 i = 2
5370 l = l + 1
5371 rbuf(l,1) = e_ref(2)
5372 DO k = 1,3
5373 l = l + 1
5374 rbuf(l,1) = x_ref(k,i)
5375 END DO
5376 DO k = 1,3
5377 l = l + 1
5378 rbuf(l,1) = d_ref(k,i)
5379 END DO
5380 i = 3
5381 l = l + 1
5382 rbuf(l,1) = e_ref(3)
5383 DO k = 1,3
5384 l = l + 1
5385 rbuf(l,1) = x_ref(k,i)
5386 END DO
5387 DO k = 1,3
5388 l = l + 1
5389 rbuf(l,1) = d_ref(k,i)
5390 END DO
5391C
5392 l = l + 1
5393 rbuf(l,1) = lskew_g
5394 DO i = 1,9
5395 l = l + 1
5396 rbuf(l,1) = rlskew(i)
5397 END DO
5398 DO i = 1,6
5399 l = l + 1
5400 rbuf(l,1) = ikce(i)
5401 END DO
5402C
5403 IF(ispmd==0) THEN
5404 DO i = 2, nspmd
5405 msgtyp=msgoff
5406 CALL mpi_irecv(rbuf(1,i),siz,real,it_spmd(i),msgtyp,
5407 . spmd_comm_world,req_r(i-1),ierror)
5408 END DO
5409C
5410 DO n = 1, nspmd-1
5411 CALL mpi_waitany(nspmd-1,req_r,index,status,ierror)
5412 i = index+1
5413 l = 1 ! K = 1
5414 IF (rbuf(l,1)==zero .AND. rbuf(l,i)>zero) THEN
5415 rbuf(l,1) = rbuf(l,i)
5416c E_REF(1) = INT(RBUF(L,1))
5417 rbuf(l+1:l+6,1) = rbuf(l+1:l+6,i)
5418 END IF
5419 l = 8 ! K = 2
5420 IF (rbuf(l,1)==zero .AND. rbuf(l,i)>zero) THEN
5421 rbuf(l,1) = rbuf(l,i)
5422c E_REF(2) = INT(RBUF(L,1))
5423 rbuf(l+1:l+6,1) = rbuf(l+1:l+6,i)
5424 END IF
5425 l = 15 ! K = 3
5426 IF (rbuf(l,1)==zero .AND. rbuf(l,i)>zero) THEN
5427 rbuf(l,1) = rbuf(l,i)
5428c E_REF(3) = INT(RBUF(L,1))
5429 rbuf(l+1:l+6,1) = rbuf(l+1:l+6,i)
5430 END IF
5431 l = 22
5432 IF (rbuf(l,1)==zero .AND. rbuf(l,i)>zero) THEN
5433 rbuf(l,1) = rbuf(l,i)
5434 rbuf(l+1:l+9,1) = rbuf(l+1:l+9,i)
5435 END IF
5436 DO k=l+10,l+15
5437 IF (rbuf(k,1)==zero .AND. rbuf(k,i)>zero) THEN
5438 rbuf(k,1) = rbuf(k,i)
5439 END IF
5440 END DO
5441 END DO
5442C
5443 l = 27+10
5444 sbuf(1:l)=rbuf(1:l,1)
5445 DO i = 2, nspmd
5446 msgtyp=msgoff2
5447 CALL mpi_send(sbuf,l,real,it_spmd(i),
5448 . msgtyp,spmd_comm_world,ierror)
5449 END DO
5450C
5451 ELSE
5452 msgtyp = msgoff
5453 l = 27+10
5454 CALL mpi_send(rbuf,siz,real,it_spmd(1),
5455 . msgtyp,spmd_comm_world,ierror)
5456 msgtyp = msgoff2
5457 CALL mpi_recv(sbuf,l,real,it_spmd(1),msgtyp,
5458 . spmd_comm_world,status,ierror)
5459 rbuf(1:l,1) = sbuf(1:l)
5460 END IF
5461 n_seg = 3
5462 l = 1
5463 i = 1
5464c RBUF(L,1) = E_REF(1)
5465 DO k = 1,3
5466 l = l + 1
5467 x_ref(k,i) = rbuf(l,1)
5468 END DO
5469 DO k = 1,3
5470 l = l + 1
5471 d_ref(k,i) = rbuf(l,1)
5472 END DO
5473 i = 2
5474 l = l + 1
5475 DO k = 1,3
5476 l = l + 1
5477 x_ref(k,i) = rbuf(l,1)
5478 END DO
5479 DO k = 1,3
5480 l = l + 1
5481 d_ref(k,i) = rbuf(l,1)
5482 END DO
5483c RBUF(L,1) = E_REF(2)
5484 i = 3
5485 l = l + 1
5486 DO k = 1,3
5487 l = l + 1
5488 x_ref(k,i) = rbuf(l,1)
5489 END DO
5490 DO k = 1,3
5491 l = l + 1
5492 d_ref(k,i) = rbuf(l,1)
5493 END DO
5494C
5495 l = l + 1
5496 lskew_g = int(rbuf(l,1))
5497 DO i = 1,9
5498 l = l + 1
5499 rlskew(i) = rbuf(l,1)
5500 END DO
5501 DO i = 1,6
5502 l = l + 1
5503 ikce(i) = int(rbuf(l,1))
5504 END DO
5505C
5506 RETURN
5507#endif
5508 END
5509C
my_real
#define my_real
Definition cppsort.cpp:32
imp_buck
subroutine imp_buck(pm, geo, ipm, igeo, elbuf, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, iparg, tf, npc, fr_wave, w16, bufmat, thke, bufgeo, nsensor, sensor_tab, rby, skew, wa, icodt, icodr, iskew, ibfv, vel, lpby, npby, itab, weight, ms, in, ipari, intbuf_tab, x, itask, cont, icut, xcut, fint, fext, fopt, anin, nstrf, rwbuf, nprw, tani, dd_iad, eani, ipart, nom_opt, igrsurf, bufsf, idata, rdata, kxx, ixx, kxsp, ixsp, nod2sp, spbuf, ixs10, ixs20, ixs16, vr, monvol, volmon, nodglob, iad_elem, fr_elem, fr_sec, fr_rby2, iad_rby2, fr_wall, v, a, graphe, partsav, xframe, dirul, fncont, ftcont, temp, sh4tree, sh3tree, err_thk_sh4, err_thk_sh3, iframe, lprw, elbuf_tab, fsav, fsavd, rwsav, ar, irbe3, lrbe3, frbe3, fr_i2m, iad_i2m, fr_rbe3m, iad_rbe3m, frwl6, ibcl, forc, irbe2, lrbe2, iad_rbe2, fr_rbe2, weight_md, cluster, fcluster, mcluster, xfem_tab, ale_connect, w, nv46, nercvois, nesdvois, lercvois, lesdvois, crkedge, stack, dimfb, fbsav6, stabsen, tabsensor, indx_crk, xedge4n, xedge3n, sph2sol, stifn, stifr, drape_sh4n, drape_sh3n, h3d_data, subset, igrnod, fcont_max, fncontp2, ftcontp2, nddl0, nnzk0, impbuf_tab, drapeg, matparam_tab, glob_therm, output)
Definition imp_buck.F:106
dyna_ina
subroutine dyna_ina(ibcl, forc, snpc, npc, tf, a, v, x, skews, ar, vr, sensor_tab, weight, wfexc, iads_f, fsky, igrv, agrv, ms, in, lgrav, itask, nrbyac, irbyac, npby, rby, fr_elem, iad_elem, nddl, nnzk, idiv, h3d_data, cptreac, fthreac, nodreac, nsensor, th_surf, dpl0cld, vel0cld, d, dr, numnod, nsurf, nfunct, nconld, ngrav, ninvel, stf, numskw, wfext, python)
Definition imp_dyna.F:744
dim_fr_k
subroutine dim_fr_k(elbuf, iparg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs20, ixs16, ndof, nnmax, inloc, fr_elem, iad_elem, n_fr, igeo, fr_i2m, iad_i2m, elbuf_tab)
Definition imp_fri.F:3339
fr_matv_gpu
subroutine fr_matv_gpu(nsrem, nsl, lx, f, nindex)
Definition imp_fri.F:2494
imp_fri
subroutine imp_fri(num_imp, ns_imp, ne_imp, ipari, intbuf_tab, npby, lpby, itab, nrbyac, irbyac, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, lj, skew, xframe, iskew, icodt, a, ud, lb, ifdis, nddl, urd, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:45
imp_solv
subroutine imp_solv(timers, python, icode, iskew, iskwn, ipart, ixtg, ixs, ixq, ixc, ixt, ixp, ixr, ixtg1, itab, itabm1, npc, ibcl, ibfv, sensor_tab, nnlink, lnlink, iparg, igrv, ipari, intbuf_tab, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, icodt, icodr, isky, adsky, iads_f, ilink, llink, weight, itask, ibvel, lbvel, fbvel, x, d, v, vr, dr, thke, damp, ms, in, pm, skews, geo, eani, bufmat, bufgeo, bufsf, tf, forc, vel, fsav, agrv, fr_wave, parts0, elbuf, rby, rivet, fr_elem, iad_elem, wa, a, ar, stifn, stifr, partsav, fsky, fskyi, iframe, xframe, w16, iactiv, fskym, igeo, ipm, wfext, nodft, nodlt, nint7, num_imp, ns_imp, ne_imp, ind_imp, it, rwbuf, lprw, fr_wall, nbintc, intlist, fopt, rwsav, fsavd, graphe, fac_k, ipiv_k, nkcond, nsensor, monvol, igrsurf, fr_mv, volmon, dirul, nodglob, mumps_par, cddlp, isendto, irecvfrom, newfront, imsch, i2msch, isizxv, ilenxv, islen7, irlen7, islen11, irlen11, islen17, irlen17, irlen7t, islen7t, kinet, num_imp1, temp, dt2prev, waint, lgrav, sh4tree, sh3tree, irlen20, islen20, irlen20t, islen20t, irlen20e, islen20e, irbe3, lrbe3, frbe3, fr_i2m, iad_i2m, fr_rbe3m, iad_rbe3m, frwl6, irbe2, lrbe2, intbuf_tab_c, ikine, diag_sms, icfield, lcfield, cfield, count_remslv, count_remslve, elbuf_tab, elbuf_imp, xdp, weight_md, stack, dimfb, fbsav6, stabsen, tabsensor, drape_sh4n, drape_sh3n, h3d_data, multi_fvm, igrbric, igrsh4n, igrsh3n, igrbeam, forneqs, maxdgap, nddl0, nnzk0, it_t, impbuf_tab, cptreac, fthreac, nodreac, drapeg, interfaces, th_surf, dpl0cld, vel0cld, snpc, stf, glob_therm, wfext_md)
Definition imp_solv.F:173
imp_errmumps
subroutine imp_errmumps(ierr)
Definition imp_solv.F:8622
imp_checm0
subroutine imp_checm0(itab, nddl, iddl, diag_m, ndof, ikc, inloc, nddl0, iwar, ierr)
Definition imp_solv.F:2912
spmd_ndof
subroutine spmd_ndof(ndof, fr_elem, iad_elem, tsize)
Definition imp_spmd.F:3044
spmd_ifrf_gpu
subroutine spmd_ifrf_gpu(f_imp, nindex)
Definition imp_spmd.F:4143
spmd_ifri
subroutine spmd_ifri(ig, il)
Definition imp_spmd.F:4262
spmd_max_ii
subroutine spmd_max_ii(nmax, iad_elem, tsize)
Definition imp_spmd.F:4810
spmd_mumps_rhs
subroutine spmd_mumps_rhs(v, cddlp, rhs, nddl, isens, nddlg)
Definition imp_spmd.F:611
spmd_min_s
subroutine spmd_min_s(s)
Definition imp_spmd.F:1273
spmd_ifru
subroutine spmd_ifru(lx)
Definition imp_spmd.F:3790
spmd_exci
subroutine spmd_exci(its, itr, iad_s, iad_r, size, ssize, rsize)
Definition imp_spmd.F:3555
spmd_max_f
subroutine spmd_max_f(f, itab, k)
Definition imp_spmd.F:4907
spmd_min_i
subroutine spmd_min_i(n)
Definition imp_spmd.F:1436
spmd_isr
subroutine spmd_isr(iad_s, iad_r, its, itr, ssize, rsize)
Definition imp_spmd.F:3441
spmd_max_s
subroutine spmd_max_s(s)
Definition imp_spmd.F:1195
spmd_mumps_flush
subroutine spmd_mumps_flush(mumps_par)
Definition imp_spmd.F:913
spmd_mumps_ini
subroutine spmd_mumps_ini(mumps_par, sym)
Definition imp_spmd.F:498
spmd_exck
subroutine spmd_exck(ks11, kr11, iad_s, iad_r, size, ssize, rsize)
Definition imp_spmd.F:3675
spmd_mumps_gath
subroutine spmd_mumps_gath(itk, rtk, nzloc, a, irn, jcn, nzp)
Definition imp_spmd.F:408
spmd_sumf_k
subroutine spmd_sumf_k(diag_k, l_k)
Definition imp_spmd.F:1864
spmd_mumps_deal
subroutine spmd_mumps_deal(mumps_par)
Definition imp_spmd.F:558
spmd_mumps_count
subroutine spmd_mumps_count(nzloc, nzp, nnz)
Definition imp_spmd.F:350
spmd_sumf_v
subroutine spmd_sumf_v(v)
Definition imp_spmd.F:1650
spmd_int_allreduce_max
subroutine spmd_int_allreduce_max(sendbuf, recvbuf, count)
Definition imp_spmd.F:5131
spmd_ifcd
subroutine spmd_ifcd(d_imp, ssize, rsize)
Definition imp_spmd.F:2326
spmd_ifrf
subroutine spmd_ifrf(f_imp)
Definition imp_spmd.F:3908
spmd_inf_g
subroutine spmd_inf_g(nddl0, nzzk0, nddl, nzzk, nnmax, nddl0p, nzzk0p, nddlp, nzzkp, nnmaxp)
Definition imp_spmd.F:1514
spmd_nddlig
subroutine spmd_nddlig(nddl, nddlfr, nddlg)
Definition imp_spmd.F:4734
spmd_mumps_front
subroutine spmd_mumps_front(itk, rtk, nkfront, nkfloc, nkloc, nddlg, iprint)
Definition imp_spmd.F:37
spmd_mumps_exec
subroutine spmd_mumps_exec(mumps_par, itask)
Definition imp_spmd.F:724
spmd_i2d
subroutine spmd_i2d(ndof, fr_elem, iad_elem, tsize)
Definition imp_spmd.F:2793
spmd_inis
subroutine spmd_inis(iad_s, iad_r)
Definition imp_spmd.F:2003
spmd_ifru_gpu
subroutine spmd_ifru_gpu(lx, nindex)
Definition imp_spmd.F:4024
spmd_send_vr
subroutine spmd_send_vr(nv, nsiz, vr, nvmax, iout)
Definition imp_spmd.F:4606
spmd_inisl
subroutine spmd_inisl(nbintc, inbsl)
Definition imp_spmd.F:2090
spmd_ifc1
subroutine spmd_ifc1(ssize, rsize, kss)
Definition imp_spmd.F:2190
spmd_e_ref
subroutine spmd_e_ref(dmin)
Definition imp_spmd.F:5175
spmd_vchgrid
subroutine spmd_vchgrid(v, iv, nv, vg, nvg, nbloc, nddl, is, isum)
Definition imp_spmd.F:3279
spmd_sum_s2
subroutine spmd_sum_s2(s, len)
Definition imp_spmd.F:1112
spmd_send_vi
subroutine spmd_send_vi(nv, nsiz, vi, nvmax, iout)
Definition imp_spmd.F:4376
spmd_ifcf
subroutine spmd_ifcf(f_imp, ssize, rsize)
Definition imp_spmd.F:2450
spmd_sumfc_v
subroutine spmd_sumfc_v(vgat, vsca, index, lcom)
Definition imp_spmd.F:1767
spmd_cddl
subroutine spmd_cddl(nddl, nodglob, iddl, ndof, cddlp, inloc, ikc, nddlg, nddlp)
Definition imp_spmd.F:3146
spmd_sumf_a
subroutine spmd_sumf_a(a, ar, iad_elem, fr_elem, size, lr)
Definition imp_spmd.F:2897
spmd_n_ref
subroutine spmd_n_ref
Definition imp_spmd.F:5323
spmd_sum_s
subroutine spmd_sum_s(s)
Definition imp_spmd.F:1037
spmd_icol
subroutine spmd_icol(iad_s, iad_r, nnmax, icol, nrow, fr_nrow, iad_elem, fr_elem, ssize, rsize)
Definition imp_spmd.F:2679
spmd_max_i
subroutine spmd_max_i(n)
Definition imp_spmd.F:1362
spmd_max_iv
subroutine spmd_max_iv(iv)
Definition imp_spmd.F:5017
spmd_nrow
subroutine spmd_nrow(nrow, fr_nrow, iad_elem, tsize)
Definition imp_spmd.F:2577
reorder_a
subroutine reorder_a(n, ic, id)
Definition ind_glob_k.F:4268
lag_mult_sdp
subroutine lag_mult_sdp(nh, nc, ncr, a, v, mas, iadll, lll, jll, xll, iadh, jcih, hh, z, p, r, q, ltsm, hl, diag_h, diag_l, work1, work2, work3, lambda, rbyl, npbyl, ar, vr, in, iadhf, jcihf, icftag, jcftag, ncf_s, ncf_e, indexlag)
Definition lag_mult_solv.F:802
lag_mult_solv
subroutine lag_mult_solv(nh, nc, ncr, a, v, mas, iadll, lll, jll, xll, iadh, jcih, hh, z, p, r, q, ltsm, hl, diag_h, diag_l, work1, work2, work3, lambda, rbyl, npbyl, ar, vr, in, iadhf, jcihf, icftag, jcftag, ncf_s, ncf_e)
Definition lag_mult_solv.F:41
lin_solv
subroutine lin_solv(nddl, iddl, ndof, ikc, d, dr, tol, nnz, iadk, jdik, diag_k, lt_k, nddli, iadi, jdii, diag_i, lt_i, itok, iadm, jdim, diag_m, lt_m, f, f_u, inloc, fr_elem, iad_elem, w_ddl, itask, icprec, istop, a, ar, ve, ms, xe, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, it, graphe, itab, fac_k, ipiv_k, nk, nmonv, imonv, monvol, igrsurf, fr_mv, volmon, ibfv, skew, xframe, mumps_par, cddlp, ind_imp, xi_c, irbe3, lrbe3, irbe2, lrbe2)
Definition lin_solv.F:74
lin_solvh1
subroutine lin_solvh1(tol, max_l, nddl, nnz, iadk, jdik, diag_k, lt_k, nddli, itok, iadi, jdii, lt_i, diag_m, lt_m, x, f, itask, icprec, iprint, f_u, isolv, iprec, l_lim, itol, inega, w_ddl, a, ar, ve, ms, xe, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, p_mach, maxb, istop, nmonv, imonv, monvol, igrsurf, fr_mv, volmon, ibfv, skew, xframe, ind_imp, diag_i, xi_c, f0, nddli_g, intp_c, irbe3, lrbe3, irbe2, lrbe2)
Definition lin_solv.F:878
lin_solvih2
subroutine lin_solvih2(tol, n_pat, maxb1, nddl, nnz, iadk, jdik, diag_k, lt_k, nddli, itok, iadi, jdii, lt_i, iadm, jdim, diag_m, lt_m, x, f, max_l, d_tol, itask, icprec, iprint, f_u, isolv, iprec, l_lim, itol, inega, w_ddl, a, ar, ve, ms, xe, d, dr, ndof, ipari, intbuf_tab, num_imp, ns_imp, ne_imp, nsrem, nsl, p_mach, maxb, istop, nmonv, imonv, monvol, igrsurf, fr_mv, volmon, ibfv, skew, xframe, ind_imp, diag_i, xi_c, f0, nddli_g, intp_c, irbe3, lrbe3, irbe2, lrbe2)
Definition lin_solv.F:1176
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
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_waitall
subroutine mpi_waitall(cnt, array_of_requests, status, ierr)
Definition mpi.f:536
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
mpi_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
imp_dyna
Definition impbufdef_mod.F:314
imp_frk
Definition impbufdef_mod.F:740
imp_frk::nddlfrb1
integer nddlfrb1
Definition impbufdef_mod.F:746
imp_frk::ifr2k
integer, dimension(:), allocatable ifr2k
Definition impbufdef_mod.F:758
imp_frk::len_v
integer len_v
Definition impbufdef_mod.F:742
imp_frk::iadfr
integer, dimension(:), allocatable iadfr
Definition impbufdef_mod.F:754
imp_frk::jfr2k
integer, dimension(:), allocatable jfr2k
Definition impbufdef_mod.F:758
imp_frk::len_k
integer len_k
Definition impbufdef_mod.F:742
imp_frk::nd_fr
integer, dimension(:), allocatable nd_fr
Definition impbufdef_mod.F:754
imp_frk::nzkfr
integer nzkfr
Definition impbufdef_mod.F:742
imp_frk::nddlfr
integer nddlfr
Definition impbufdef_mod.F:742
imp_frk::nddlfrb
integer nddlfrb
Definition impbufdef_mod.F:746
imp_intm
Definition imp_intm.F:118
imp_intm::iddl_sl
integer, dimension(:), allocatable iddl_sl
Definition imp_intm.F:178
imp_intm::fr_srem
integer, dimension(:), allocatable fr_srem
Definition imp_intm.F:131
imp_intm::iad_sl
integer, dimension(:), allocatable iad_sl
Definition imp_intm.F:145
imp_intm::nddl_si
integer nddl_si
Definition imp_intm.F:173
imp_intm::nddl_sl
integer nddl_sl
Definition imp_intm.F:173
imp_intm::iad_srem
integer, dimension(:), allocatable iad_srem
Definition imp_intm.F:145
imp_intm::isl
integer, dimension(:), allocatable isl
Definition imp_intm.F:138
imp_spbrm
Definition impbufdef_mod.F:696
imp_spbrm::lskew_g
integer lskew_g
Definition impbufdef_mod.F:698
imp_spbrm::ikce
integer, dimension(6) ikce
Definition impbufdef_mod.F:698
imp_spbrm::n_seg
integer n_seg
Definition impbufdef_mod.F:698
imp_spbrm::e_ref
integer, dimension(4) e_ref
Definition impbufdef_mod.F:698
prec_solvgh
subroutine prec_solvgh(iprec, itask, nddl, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl)
Definition prec_solv.F:710
prec_solv
subroutine prec_solv(iprec, iadk, jdik, diag_k, lt_k, itask, graphe, itab, insolv, it, fac_k, ipiv_k, nk, idsc, isolv, iprint, nddl, nnz, iadm, jdim, diag_m, lt_m, v, z)
Definition prec_solv.F:42
mmv_lh
subroutine mmv_lh(nddl, iadm, jdim, diag_m, lt_m, v, z, f_ddl, l_ddl, itask)
Definition produt_v.F:3113
produt_v
subroutine produt_v(nddl, x, y, r)
Definition produt_v.F:33
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339
sms_diag_rbe2
subroutine sms_diag_rbe2(irbe2, lrbe2, nodxi_sms, jad_sms, jdi_sms, lt_sms, nmrbe2, ms, diag_sms, prec_sms3, iad_rbe2, fr_rbe2m, weight, skew)
Definition sms_rbe2.F:35
tmpenvf
void tmpenvf(char *tmpdir, int *tmplen)
Definition tmpenv_c.c:149
rer02
subroutine rer02(rby, lpby, npby, skew, iskew, itab, weight, ms, in, ibfv, vel, icodt, icodr, nrbyac, irbyac, nint2, iint2, ipari, intbuf_tab, ndof, d, dr, x, xframe, lj, ixr, ixc, ixtg, sh4tree, sh3tree, irbe3, lrbe3, frbe3, iadk, jdik, diag_k, lt_k, iddl, ikc, inloc, num_imp, ns_imp, ne_imp, index2, nddl, w_ddl, a, ar, r02, irbe2, lrbe2, x_c)
Definition upd_glob_k.F:940
upd_glob_k
subroutine upd_glob_k(icodt, icodr, iskew, ibfv, npc, tf, vel, xframe, rby, x, skew, lpby, npby, itab, weight, ms, in, nrbyac, irbyac, nsc, isij, nmc, imij, nss, iss, nint2, iint2, nsc2, isij2, nss2, iss2, ipari, intbuf_tab, nddl, nnz, iadk, jdik, diag_k, lt_k, ndof, iddl, ikc, ud, b, nkud, ikud, bkud, nmc2, imij2, nt_rw, rd, lj, irbe3, lrbe3, frbe3, iss3, irbe2, lrbe2, isb2, nsrb2)
Definition upd_glob_k.F:66