OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
h3d_create_rbe3_impi.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "task_c.inc"
#include "param_c.inc"
#include "spmd_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine h3d_create_rbe3_impi (lrbe3, irbe3, nodglob, weight, nerbe3y, nerbe3t, itab, compid_rbe3s)

Function/Subroutine Documentation

◆ h3d_create_rbe3_impi()

subroutine h3d_create_rbe3_impi ( integer, dimension(*) lrbe3,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) nodglob,
integer, dimension(*) weight,
integer nerbe3y,
integer, dimension(nrbe3g) nerbe3t,
integer, dimension(*) itab,
integer compid_rbe3s )

Definition at line 33 of file h3d_create_rbe3_impi.F.

35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38 USE spmd_comm_world_mod, ONLY : spmd_comm_world
39#include "implicit_f.inc"
40C-----------------------------------------------------------------
41C M e s s a g e P a s s i n g
42C-----------------------------------------------
43#include "spmd.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com01_c.inc"
48#include "com04_c.inc"
49#include "task_c.inc"
50#include "param_c.inc"
51#include "spmd_c.inc"
52C-----------------------------------------------
53C D u m m y A r g u m e n t s
54C-----------------------------------------------
55 INTEGER IRBE3(NRBE3L,*),LRBE3(*),NODGLOB(*),WEIGHT(*),
56 * NERBE3Y,NERBE3T(NRBE3G),ITAB(*),COMPID_RBE3S
57C-----------------------------------------------
58C L o c a l V a r i a b l e s
59C-----------------------------------------------
60#ifdef MPI
61 INTEGER I,N,P, SZLOCRBE3(NRBE3G),PGLOBRBE3(NRBE3G),ID
62 INTEGER SNRBE3,SIZRBE3,SBUFSIZ,PSNRBE3
63 INTEGER NSN,IADG,IAD,SN,MN,NGRBE
64 INTEGER SECNDNODS(NRBE3G),ID_RBE3(NRBE3G)
65 INTEGER, DIMENSION(:),ALLOCATABLE :: SENDBUF,RECBUF,
66 * P0RBE3BUF,IADRBE3
67 INTEGER, DIMENSION(:,:),ALLOCATABLE :: P0RECRBE3, IIN
68
69C MPI variables
70 INTEGER LOC_PROC
71 INTEGER MSGOFF,MSGOFF2,MSGTYP,INFO,ATID,ATAG,ALEN
72 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,ISD(NSPMD)
73
74 DATA msgoff/7020/
75 DATA msgoff2/7021/
76C-----------------------------------------------
77C 1ere etape - envoyer au proc 0 un tableau avec nombre
78C noeuds secnds locaux par RBE3 a envoyer
79C et preparation du buffer d envoi
80C (taille)
81 nerbe3t = 0
82 snrbe3 = 0
83 sbufsiz = 0
84 szlocrbe3=0
85 pglobrbe3 = 0
86
87 DO i=1,nrbe3
88 ngrbe = irbe3(10,i)
89 szlocrbe3(ngrbe) = 0
90 nsn = irbe3(5,i)
91 DO n=1,nsn
92 IF (weight(lrbe3(irbe3(1,i)+n))==1)
93 . szlocrbe3(ngrbe) = szlocrbe3(ngrbe) + 1
94 ENDDO
95 sbufsiz = sbufsiz + szlocrbe3(ngrbe)
96
97 ENDDO
98
99C Envoi vers le proc 0 du tableau des tailles
100
101 IF (ispmd == 0) THEN
102C Proc zero reception des tailles
103 ALLOCATE(p0recrbe3(nrbe3g,nspmd))
104 DO i=1,nrbe3g
105 p0recrbe3(i,1) = szlocrbe3(i)
106 ENDDO
107
108 DO p=2,nspmd
109 msgtyp = msgoff
110 CALL mpi_recv(p0recrbe3(1,p),nrbe3g,mpi_integer,it_spmd(p),
111 * msgtyp,spmd_comm_world,status,ierror)
112 ENDDO
113
114 ELSE
115C Procs autres envoi
116 msgtyp = msgoff
117 CALL mpi_send(szlocrbe3,nrbe3g,mpi_integer,it_spmd(1),
118 . msgtyp,spmd_comm_world,ierror)
119
120 ENDIF
121
122C --------------------------------------------------------------
123C Envoi vers le proc 0 des noeuds des RBE3 & ecriture sur disque
124C --------------------------------------------------------------
125 IF (ispmd /= 0) THEN
126C ------------------------
127C Procs autres que proc 0
128C ------------------------
129 ALLOCATE(sendbuf(sbufsiz))
130 snrbe3 = 0
131 DO i=1,nrbe3
132 nsn = irbe3(5,i)
133 iad = irbe3(1,i)
134 DO n=1,nsn
135 sn = lrbe3(iad+n)
136 IF (weight(sn) == 1 )THEN
137 snrbe3 = snrbe3+1
138 sendbuf(snrbe3)=itab(sn)
139 ENDIF
140 ENDDO
141 ENDDO
142 IF (snrbe3 > 0)THEN
143 msgtyp = msgoff2
144 CALL mpi_send(sendbuf,snrbe3,mpi_integer,it_spmd(1),msgtyp,
145 * spmd_comm_world,ierror)
146 ENDIF
147 DEALLOCATE(sendbuf)
148
149C Envoi des noeuds secnds
150 secndnods = 0
151 DO i=1,nrbe3
152 mn = irbe3(3,i)
153 IF(mn/=0)THEN
154 IF (weight(mn)==1)THEN
155 ngrbe = irbe3(10,i)
156 secndnods(ngrbe)=itab(mn)
157 ENDIF
158 ENDIF
159 ENDDO
160 CALL spmd_glob_isum9(secndnods,nrbe3g)
161
162C Envoi des Ids
163 id_rbe3 = 0
164 DO i=1,nrbe3
165 id = irbe3(2,i)
166 IF(irbe3(3,i)/=0)THEN
167 IF (weight(irbe3(3,i))==1)THEN
168 ngrbe = irbe3(10,i)
169 id_rbe3(ngrbe)=id
170 ENDIF
171 ENDIF
172 ENDDO
173 CALL spmd_glob_isum9(id_rbe3,nrbe3g)
174
175
176 ELSE
177C --------------------------------------------------------------------
178C PROC 0
179C --------------------------------------------------------------------
180C P0RBE3BUF tableau de reception (tableau de reception = LRBE3 Global)
181C IADRBE3 pointeurs vers P0RBE3BUF global
182 ALLOCATE(iadrbe3(nrbe3g+1))
183 ALLOCATE(p0rbe3buf(nerbe3y))
184
185C preparation IADRBE3
186 iadrbe3(1)=0
187 DO i=1,nrbe3g
188 snrbe3 = p0recrbe3(i,1)
189 DO n=2,nspmd
190 snrbe3 = snrbe3 + p0recrbe3(i,n)
191 ENDDO
192 iadrbe3(i+1)=iadrbe3(i)+snrbe3
193 ENDDO
194
195C preparation P0RECRBE3 pour le proc0
196 DO i=1,nrbe3g
197 pglobrbe3(i)=iadrbe3(i)
198 ENDDO
199
200 DO i=1,nrbe3
201 nsn = irbe3(5,i)
202 iad = irbe3(1,i)
203 ngrbe = irbe3(10,i)
204 iadg = iadrbe3(ngrbe)
205 snrbe3 = 0
206 DO n=1,nsn
207 sn = lrbe3( iad+n )
208 IF (weight(sn) == 1 )THEN
209 snrbe3 = snrbe3+1
210 p0rbe3buf(iadg + snrbe3) = itab(sn)
211 ENDIF
212 ENDDO
213 pglobrbe3(ngrbe)=pglobrbe3(ngrbe) + snrbe3
214 ENDDO
215
216
217C Reception des RBE3 des autres procs
218 DO p=2,nspmd
219C Taille du buffer de reception
220 sizrbe3 = 0
221 DO i=1,nrbe3g
222 sizrbe3 = sizrbe3 + p0recrbe3(i,p)
223 ENDDO
224
225 IF (sizrbe3 > 0) THEN
226 ALLOCATE(recbuf(sizrbe3))
227 msgtyp = msgoff2
228 CALL mpi_recv(recbuf,sizrbe3,mpi_integer,it_spmd(p),msgtyp,
229 * spmd_comm_world,status,ierror)
230
231 psnrbe3=0
232 DO i=1,nrbe3g
233 iadg = pglobrbe3(i)
234 DO n=1,p0recrbe3(i,p)
235 psnrbe3 = psnrbe3 + 1
236 p0rbe3buf(iadg + n) = recbuf(psnrbe3)
237 ENDDO
238 pglobrbe3(i) = pglobrbe3(i) + p0recrbe3(i,p)
239 ENDDO
240 DEALLOCATE(recbuf)
241 ENDIF
242 ENDDO
243C Reception des Noeuds secnds
244 secndnods=0
245 DO i=1,nrbe3
246 mn = irbe3(3,i)
247 IF (weight(mn)==1) THEN
248 ngrbe = irbe3(10,i)
249 secndnods(ngrbe)=itab(mn)
250 ENDIF
251 ENDDO
252 CALL spmd_glob_isum9(secndnods,nrbe3g)
253
254C Reception des Ids
255 id_rbe3 = 0
256 DO i=1,nrbe3
257 id = irbe3(2,i)
258 IF(irbe3(3,i)/=0)THEN
259 IF (weight(irbe3(3,i))==1)THEN
260 ngrbe = irbe3(10,i)
261 id_rbe3(ngrbe)=id
262 ENDIF
263 ENDIF
264 ENDDO
265 CALL spmd_glob_isum9(id_rbe3,nrbe3g)
266
267
268 CALL c_h3d_create_rbe3_impi(itab,nrbe3g,iadrbe3,secndnods,p0rbe3buf,id_rbe3,
269 . compid_rbe3s)
270
271 ENDIF
272#endif
273 RETURN
c_h3d_create_rbe3_impi
void c_h3d_create_rbe3_impi(int *ITAB, int *NRBE3, int *IADRBE3, int *SLAVENODS, int *P0RBE3BUF, int *ID_RBE3, int *COMPID_RBE3S)
Definition c_h3d_create_rbe3.cpp:310
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_send
subroutine mpi_send(buf, cnt, datatype, dest, tag, comm, ierr)
Definition mpi.f:480
id
initmumps id
Definition multiplerhs_example.m:4
spmd_glob_isum9
subroutine spmd_glob_isum9(v, len)
Definition spmd_th.F:523