OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
h3d_create_rbe2_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_rbe2_impi (lrbe2, irbe2, nodglob, weight, nerbe2y, nerbe2t, itab, compid_rbe2s)

Function/Subroutine Documentation

◆ h3d_create_rbe2_impi()

subroutine h3d_create_rbe2_impi ( integer, dimension(*) lrbe2,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) nodglob,
integer, dimension(*) weight,
integer nerbe2y,
integer, dimension(nrbe2g) nerbe2t,
integer, dimension(*) itab,
integer compid_rbe2s )

Definition at line 33 of file h3d_create_rbe2_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 IRBE2(NRBE2L,*),LRBE2(*),NODGLOB(*),WEIGHT(*),
56 * NERBE2Y,NERBE2T(NRBE2G),ITAB(*),COMPID_RBE2S
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, SZLOCRBE2(NRBE2G),PGLOBRBE2(NRBE2G),ID
62 INTEGER SNRBE2,SIZRBE2,SBUFSIZ,PSNRBE2
63 INTEGER NSN,IADG,IAD,SN,MN,NGRBE
64 INTEGER MAINNODS(NRBE2G),ID_RBE2(NRBE2G)
65 INTEGER, DIMENSION(:),ALLOCATABLE :: SENDBUF,RECBUF,
66 * P0RBE2BUF,IADRBE2
67 INTEGER, DIMENSION(:,:),ALLOCATABLE :: P0RECRBE2, 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 RBE2 a envoyer
79C et preparation du buffer d envoi
80C (taille)
81 nerbe2t = 0
82 snrbe2 = 0
83 sbufsiz = 0
84 szlocrbe2=0
85 pglobrbe2 = 0
86
87 DO i=1,nrbe2
88 ngrbe = irbe2(10,i)
89 szlocrbe2(ngrbe) = 0
90 nsn = irbe2(5,i)
91 DO n=1,nsn
92 IF (weight(lrbe2(irbe2(1,i)+n))==1)
93 . szlocrbe2(ngrbe) = szlocrbe2(ngrbe) + 1
94 ENDDO
95 sbufsiz = sbufsiz + szlocrbe2(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(p0recrbe2(nrbe2g,nspmd))
104 DO i=1,nrbe2g
105 p0recrbe2(i,1) = szlocrbe2(i)
106 ENDDO
107
108 DO p=2,nspmd
109 msgtyp = msgoff
110 CALL mpi_recv(p0recrbe2(1,p),nrbe2g,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(szlocrbe2,nrbe2g,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 RBE2 & criture sur disque
124C --------------------------------------------------------------
125 IF (ispmd /= 0) THEN
126C ------------------------
127C Procs autres que proc 0
128C ------------------------
129 ALLOCATE(sendbuf(sbufsiz))
130 snrbe2 = 0
131 DO i=1,nrbe2
132 nsn = irbe2(5,i)
133 iad = irbe2(1,i)
134 DO n=1,nsn
135 sn = lrbe2(iad+n)
136 IF (weight(sn) == 1 )THEN
137 snrbe2 = snrbe2+1
138 sendbuf(snrbe2)=itab(sn)
139 ENDIF
140 ENDDO
141 ENDDO
142 IF (snrbe2 > 0)THEN
143 msgtyp = msgoff2
144 CALL mpi_send(sendbuf,snrbe2,mpi_integer,it_spmd(1),msgtyp,
145 * spmd_comm_world,ierror)
146 ENDIF
147 DEALLOCATE(sendbuf)
148
149C Envoi des noeuds secnds
150 mainnods = 0
151 DO i=1,nrbe2
152 mn = irbe2(3,i)
153 IF(mn/=0)THEN
154 IF (weight(mn)==1)THEN
155 ngrbe = irbe2(10,i)
156 mainnods(ngrbe)=itab(mn)
157 ENDIF
158 ENDIF
159 ENDDO
160 CALL spmd_glob_isum9(mainnods,nrbe2g)
161
162C Envoi des Ids
163 id_rbe2 = 0
164 DO i=1,nrbe2
165 id = irbe2(2,i)
166 IF(irbe2(3,i)/=0)THEN
167 IF (weight(irbe2(3,i))==1)THEN
168 ngrbe = irbe2(10,i)
169 id_rbe2(ngrbe)=id
170 ENDIF
171 ENDIF
172 ENDDO
173 CALL spmd_glob_isum9(id_rbe2,nrbe2g)
174
175
176 ELSE
177C --------------------------------------------------------------------
178C PROC 0
179C --------------------------------------------------------------------
180C P0RBE2BUF tableau de reception (tableau de reception = LRBE2 Global)
181C IADRBE2 pointeurs vers P0RBE2BUF global
182 ALLOCATE(iadrbe2(nrbe2g+1))
183 ALLOCATE(p0rbe2buf(nerbe2y))
184
185C preparation IADRBE2
186 iadrbe2(1)=0
187 DO i=1,nrbe2g
188 snrbe2 = p0recrbe2(i,1)
189 DO n=2,nspmd
190 snrbe2 = snrbe2 + p0recrbe2(i,n)
191 ENDDO
192 iadrbe2(i+1)=iadrbe2(i)+snrbe2
193 ENDDO
194
195C preparation P0RECRBE2 pour le proc0
196 DO i=1,nrbe2g
197 pglobrbe2(i)=iadrbe2(i)
198 ENDDO
199
200 DO i=1,nrbe2
201 nsn = irbe2(5,i)
202 iad = irbe2(1,i)
203 ngrbe = irbe2(10,i)
204 iadg = iadrbe2(ngrbe)
205 snrbe2 = 0
206 DO n=1,nsn
207 sn = lrbe2( iad+n )
208 IF (weight(sn) == 1 )THEN
209 snrbe2 = snrbe2+1
210 p0rbe2buf(iadg + snrbe2) = itab(sn)
211 ENDIF
212 ENDDO
213 pglobrbe2(ngrbe)=pglobrbe2(ngrbe) + snrbe2
214 ENDDO
215
216
217C Reception des RBE2 des autres procs
218 DO p=2,nspmd
219C Taille du buffer de reception
220 sizrbe2 = 0
221 DO i=1,nrbe2g
222 sizrbe2 = sizrbe2 + p0recrbe2(i,p)
223 ENDDO
224
225 IF (sizrbe2 > 0) THEN
226 ALLOCATE(recbuf(sizrbe2))
227 msgtyp = msgoff2
228 CALL mpi_recv(recbuf,sizrbe2,mpi_integer,it_spmd(p),msgtyp,
229 * spmd_comm_world,status,ierror)
230
231 psnrbe2=0
232 DO i=1,nrbe2g
233 iadg = pglobrbe2(i)
234 DO n=1,p0recrbe2(i,p)
235 psnrbe2 = psnrbe2 + 1
236 p0rbe2buf(iadg + n) = recbuf(psnrbe2)
237 ENDDO
238 pglobrbe2(i) = pglobrbe2(i) + p0recrbe2(i,p)
239 ENDDO
240 DEALLOCATE(recbuf)
241 ENDIF
242 ENDDO
243C Reception des Noeuds mains
244 mainnods=0
245 DO i=1,nrbe2
246 mn = irbe2(3,i)
247 IF (weight(mn)==1) THEN
248 ngrbe = irbe2(10,i)
249 mainnods(ngrbe)=itab(mn)
250 ENDIF
251 ENDDO
252 CALL spmd_glob_isum9(mainnods,nrbe2g)
253
254C Reception des Ids
255 id_rbe2 = 0
256 DO i=1,nrbe2
257 id = irbe2(2,i)
258 IF(irbe2(3,i)/=0)THEN
259 IF (weight(irbe2(3,i))==1)THEN
260 ngrbe = irbe2(10,i)
261 id_rbe2(ngrbe)=id
262 ENDIF
263 ENDIF
264 ENDDO
265 CALL spmd_glob_isum9(id_rbe2,nrbe2g)
266
267
268 CALL c_h3d_create_rbe2_impi(itab,nrbe2g,iadrbe2,mainnods,p0rbe2buf,id_rbe2,
269 . compid_rbe2s)
270
271 ENDIF
272#endif
273 RETURN
c_h3d_create_rbe2_impi
void c_h3d_create_rbe2_impi(int *ITAB, int *NRBE2, int *IADRBE2, int *MASTERNODS, int *P0RBE2BUF, int *ID_RBE2, int *COMPID_RBE2S)
Definition c_h3d_create_rbe2.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