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

Function/Subroutine Documentation

◆ spmd_dparrbe2()

subroutine spmd_dparrbe2 ( integer, dimension(*) lrbe2,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) nodglob,
integer, dimension(*) weight,
integer nerbe2y,
integer, dimension(nrbe2g) nerbe2t )

Definition at line 34 of file spmd_dparrbe2.F.

36C-----------------------------------------------
37C I m p l i c i t T y p e s
38C-----------------------------------------------
39 USE spmd_comm_world_mod, ONLY : spmd_comm_world
40#include "implicit_f.inc"
41C-----------------------------------------------------------------
42C M e s s a g e P a s s i n g
43C-----------------------------------------------
44#include "spmd.inc"
45C-----------------------------------------------
46C C o m m o n B l o c k s
47C-----------------------------------------------
48#include "com01_c.inc"
49#include "com04_c.inc"
50#include "task_c.inc"
51#include "param_c.inc"
52#include "spmd_c.inc"
53C-----------------------------------------------
54C D u m m y A r g u m e n t s
55C-----------------------------------------------
56 INTEGER IRBE2(NRBE2L,*),LRBE2(*),NODGLOB(*),WEIGHT(*),
57 * NERBE2Y,NERBE2T(NRBE2G)
58C-----------------------------------------------
59C L o c a l V a r i a b l e s
60C-----------------------------------------------
61#ifdef MPI
62 INTEGER I,N,P
63 INTEGER SNRBE2,SIZRBE2,SBUFSIZ,PSNRBE2
64 INTEGER NSN,IADG,IAD,SN,MN,NGRBE
65
66 INTEGER, DIMENSION(:),ALLOCATABLE :: SZLOCRBE2,PGLOBRBE2,MAINNODS
67 INTEGER, DIMENSION(:),ALLOCATABLE :: SENDBUF,RECBUF,
68 * P0RBE2BUF,IADRBE2
69 INTEGER, DIMENSION(:,:),ALLOCATABLE :: P0RECRBE2, IIN
70
71C MPI variables
72 INTEGER LOC_PROC
73 INTEGER MSGOFF,MSGOFF2,MSGTYP,INFO,ATID,ATAG,ALEN
74 INTEGER STATUS(MPI_STATUS_SIZE),IERROR,ISD(NSPMD)
75
76 DATA msgoff/7020/
77 DATA msgoff2/7021/
78C-----------------------------------------------
79 ALLOCATE(szlocrbe2(nrbe2g))
80 ALLOCATE(pglobrbe2(nrbe2g))
81 ALLOCATE(mainnods(nrbe2g))
82C-----------------------------------------------
83C 1ere etape - envoyer au proc 0 un tableau avec nombre
84C noeuds secnds locaux par RBE2 a envoyer
85C et preparation du buffer d envoi
86C (taille)
87 nerbe2t = 0
88 snrbe2 = 0
89 sbufsiz = 0
90 szlocrbe2=0
91 pglobrbe2 = 0
92
93 DO i=1,nrbe2
94 ngrbe = irbe2(10,i)
95 szlocrbe2(ngrbe) = 0
96 nsn = irbe2(5,i)
97 DO n=1,nsn
98 IF (weight(lrbe2(irbe2(1,i)+n))==1)
99 . szlocrbe2(ngrbe) = szlocrbe2(ngrbe) + 1
100 ENDDO
101 sbufsiz = sbufsiz + szlocrbe2(ngrbe)
102
103 ENDDO
104
105C Envoi vers le proc 0 du tableau des tailles
106
107 IF (ispmd == 0) THEN
108C Proc zero reception des tailles
109 ALLOCATE(p0recrbe2(nrbe2g,nspmd))
110 DO i=1,nrbe2g
111 p0recrbe2(i,1) = szlocrbe2(i)
112 ENDDO
113
114 DO p=2,nspmd
115 msgtyp = msgoff
116 CALL mpi_recv(p0recrbe2(1,p),nrbe2g,mpi_integer,it_spmd(p),
117 * msgtyp,spmd_comm_world,status,ierror)
118 ENDDO
119
120 ELSE
121C Procs autres envoi
122 msgtyp = msgoff
123 CALL mpi_send(szlocrbe2,nrbe2g,mpi_integer,it_spmd(1),
124 . msgtyp,spmd_comm_world,ierror)
125
126 ENDIF
127
128C --------------------------------------------------------------
129C Envoi vers le proc 0 des noeuds des RBE2 & criture sur disque
130C --------------------------------------------------------------
131 IF (ispmd /= 0) THEN
132C ------------------------
133C Procs autres que proc 0
134C ------------------------
135 ALLOCATE(sendbuf(sbufsiz))
136 snrbe2 = 0
137 DO i=1,nrbe2
138 nsn = irbe2(5,i)
139 iad = irbe2(1,i)
140 DO n=1,nsn
141 sn = lrbe2(iad+n)
142 IF (weight(sn) == 1 )THEN
143 snrbe2 = snrbe2+1
144 sendbuf(snrbe2)=nodglob(sn)
145 ENDIF
146 ENDDO
147 ENDDO
148 IF (snrbe2 > 0)THEN
149 msgtyp = msgoff2
150 CALL mpi_send(sendbuf,snrbe2,mpi_integer,it_spmd(1),msgtyp,
151 * spmd_comm_world,ierror)
152 ENDIF
153 DEALLOCATE(sendbuf)
154
155C Envoi des noeuds secnds
156 mainnods = 0
157 DO i=1,nrbe2
158 mn = irbe2(3,i)
159 IF(mn/=0)THEN
160 IF (weight(mn)==1)THEN
161 ngrbe = irbe2(10,i)
162 mainnods(ngrbe)=nodglob(mn)
163 ENDIF
164 ENDIF
165 ENDDO
166 CALL spmd_glob_isum9(mainnods,nrbe2g)
167
168
169 ELSE
170C --------------------------------------------------------------------
171C PROC 0
172C --------------------------------------------------------------------
173C P0RBE2BUF tableau de reception (tableau de reception = LRBE2 Global)
174C IADRBE2 pointeurs vers P0RBE2BUF global
175 ALLOCATE(iadrbe2(nrbe2g+1))
176 ALLOCATE(p0rbe2buf(nerbe2y))
177
178C preparation IADRBE2
179 iadrbe2(1)=0
180 DO i=1,nrbe2g
181 snrbe2 = p0recrbe2(i,1)
182 DO n=2,nspmd
183 snrbe2 = snrbe2 + p0recrbe2(i,n)
184 ENDDO
185 iadrbe2(i+1)=iadrbe2(i)+snrbe2
186 ENDDO
187
188C preparation P0RECRBE2 pour le proc0
189 DO i=1,nrbe2g
190 pglobrbe2(i)=iadrbe2(i)
191 ENDDO
192
193 DO i=1,nrbe2
194 nsn = irbe2(5,i)
195 iad = irbe2(1,i)
196 ngrbe = irbe2(10,i)
197 iadg = iadrbe2(ngrbe)
198 snrbe2 = 0
199 DO n=1,nsn
200 sn = lrbe2( iad+n )
201 IF (weight(sn) == 1 )THEN
202 snrbe2 = snrbe2+1
203 p0rbe2buf(iadg + snrbe2) = nodglob(sn)
204 ENDIF
205 ENDDO
206 pglobrbe2(ngrbe)=pglobrbe2(ngrbe) + snrbe2
207 ENDDO
208
209C Reception des RBE2 des autres procs
210 DO p=2,nspmd
211C Taille du buffer de reception
212 sizrbe2 = 0
213 DO i=1,nrbe2g
214 sizrbe2 = sizrbe2 + p0recrbe2(i,p)
215 ENDDO
216
217 IF (sizrbe2 > 0) THEN
218 ALLOCATE(recbuf(sizrbe2))
219 msgtyp = msgoff2
220 CALL mpi_recv(recbuf,sizrbe2,mpi_integer,it_spmd(p),msgtyp,
221 * spmd_comm_world,status,ierror)
222
223 psnrbe2=0
224 DO i=1,nrbe2g
225 iadg = pglobrbe2(i)
226 DO n=1,p0recrbe2(i,p)
227 psnrbe2 = psnrbe2 + 1
228 p0rbe2buf(iadg + n) = recbuf(psnrbe2)
229 ENDDO
230 pglobrbe2(i) = pglobrbe2(i) + p0recrbe2(i,p)
231 ENDDO
232 DEALLOCATE(recbuf)
233 ENDIF
234 ENDDO
235C Reception des Noeuds mains
236 mainnods=0
237 DO i=1,nrbe2
238 mn = irbe2(3,i)
239 IF (weight(mn)==1) THEN
240 ngrbe = irbe2(10,i)
241 mainnods(ngrbe)=nodglob(mn)
242 ENDIF
243 ENDDO
244 CALL spmd_glob_isum9(mainnods,nrbe2g)
245
246C Ecriture sur disque
247 DO i=1,nrbe2g
248 nsn = iadrbe2(i+1) - iadrbe2(i)
249 iadg =iadrbe2(i)
250 mn = mainnods(i)
251 ALLOCATE(iin(2,nsn))
252 nerbe2t(i)=nsn
253 DO n=1,nsn
254 iin(1,n)=mn-1
255 iin(2,n)=p0rbe2buf(iadg + n)-1
256 ENDDO
257 CALL write_i_c(iin,2*nsn)
258 DEALLOCATE(iin)
259 ENDDO
260 DEALLOCATE(iadrbe2)
261 DEALLOCATE(p0rbe2buf)
262 DEALLOCATE(p0recrbe2)
263 ENDIF
264
265
266 DEALLOCATE(szlocrbe2)
267 DEALLOCATE(pglobrbe2)
268 DEALLOCATE(mainnods)
269
270#endif
271 RETURN
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
spmd_glob_isum9
subroutine spmd_glob_isum9(v, len)
Definition spmd_th.F:523
write_i_c
void write_i_c(int *w, int *len)
Definition write_routtines.c:645