OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_dparrbe3.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_dparrbe3 (lrbe3, irbe3, nodglob, weight, nerbe3y, nerbe3t)

Function/Subroutine Documentation

◆ spmd_dparrbe3()

subroutine spmd_dparrbe3 ( integer, dimension(*) lrbe3,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) nodglob,
integer, dimension(*) weight,
integer nerbe3y,
integer, dimension(nrbe3g) nerbe3t )

Definition at line 33 of file spmd_dparrbe3.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)
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
62 INTEGER SNRBE3,SIZRBE3,SBUFSIZ,PSNRBE3
63 INTEGER NSN,IADG,IAD,SN,MN,NGRBE
64
65 INTEGER, DIMENSION(:),ALLOCATABLE :: SECNDNODS,SZLOCRBE3,PGLOBRBE3
66
67 INTEGER, DIMENSION(:),ALLOCATABLE :: SENDBUF,RECBUF,
68 * P0RBE3BUF,IADRBE3
69 INTEGER, DIMENSION(:,:),ALLOCATABLE :: P0RECRBE3, 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/7022/
77 DATA msgoff2/7023/
78C-----------------------------------------------
79 ALLOCATE(secndnods(nrbe3g))
80 ALLOCATE(szlocrbe3(nrbe3g))
81 ALLOCATE(pglobrbe3(nrbe3g))
82C-----------------------------------------------
83C 1ere etape - envoyer au proc 0 un tableau avec nombre
84C noeuds MAIN locaux par RBE3 a envoyer
85C et preparation du buffer d envoi
86C (taille)
87 nerbe3t = 0
88 snrbe3 = 0
89 sbufsiz = 0
90 szlocrbe3 = 0
91
92 DO i=1,nrbe3
93 ngrbe = irbe3(10,i)
94 szlocrbe3(ngrbe) = 0
95 nsn = irbe3(5,i)
96 DO n=1,nsn
97 IF (weight(lrbe3(irbe3(1,i)+n))==1)
98 . szlocrbe3(ngrbe) = szlocrbe3(ngrbe) + 1
99 ENDDO
100 sbufsiz = sbufsiz + szlocrbe3(ngrbe)
101 ENDDO
102C Envoi vers le proc 0 du tableau des tailles
103
104 IF (ispmd == 0) THEN
105C Proc zero reception des tailles
106 ALLOCATE(p0recrbe3(nrbe3g,nspmd))
107 DO i=1,nrbe3g
108 p0recrbe3(i,1) = szlocrbe3(i)
109 ENDDO
110
111 DO p=2,nspmd
112 msgtyp = msgoff
113 CALL mpi_recv(p0recrbe3(1,p),nrbe3g,mpi_integer,it_spmd(p),
114 * msgtyp,spmd_comm_world,status,ierror)
115 ENDDO
116
117
118 ELSE
119C Procs autres envoi
120 msgtyp = msgoff
121 CALL mpi_send(szlocrbe3,nrbe3g,mpi_integer,it_spmd(1),
122 . msgtyp,spmd_comm_world,ierror)
123
124 ENDIF
125
126
127C --------------------------------------------------------------
128C Envoi vers le proc 0 des noeuds des RBE3 & criture sur disque
129C --------------------------------------------------------------
130 IF (ispmd /= 0) THEN
131C ------------------------
132C Procs autres que proc 0
133C ------------------------
134 ALLOCATE(sendbuf(sbufsiz))
135 snrbe3 = 0
136 DO i=1,nrbe3
137 nsn = irbe3(5,i)
138 iad = irbe3(1,i)
139 DO n=1,nsn
140 sn = lrbe3(iad+n)
141 IF (weight(sn) == 1 )THEN
142 snrbe3 = snrbe3+1
143 sendbuf(snrbe3)=nodglob(sn)
144 ENDIF
145 ENDDO
146 ENDDO
147 IF (snrbe3 > 0)THEN
148 msgtyp = msgoff2
149 CALL mpi_send(sendbuf,snrbe3,mpi_integer,it_spmd(1),msgtyp,
150 * spmd_comm_world,ierror)
151 ENDIF
152 DEALLOCATE(sendbuf)
153
154C Envoi des noeuds secnds
155 secndnods=0
156 DO i=1,nrbe3
157 mn = irbe3(3,i)
158 IF(mn/=0)THEN
159 IF (weight(mn)==1) THEN
160 ngrbe = irbe3(10,i)
161 secndnods(ngrbe)=nodglob(mn)
162 ENDIF
163 ENDIF
164 ENDDO
165 CALL spmd_glob_isum9(secndnods,nrbe3g)
166
167 ELSE
168C --------------------------------------------------------------------
169C PROC 0
170C --------------------------------------------------------------------
171C P0RBE3BUF tableau de reception (tableau de reception = LRBE3 Global)
172C IADRBE3 pointeurs vers P0RBE3BUF global
173 ALLOCATE(iadrbe3(nrbe3g+1))
174 ALLOCATE(p0rbe3buf(nerbe3y))
175
176C preparation IADRBE3
177 iadrbe3(1)=0
178 DO i=1,nrbe3g
179 snrbe3 = p0recrbe3(i,1)
180 DO n=2,nspmd
181 snrbe3 = snrbe3 + p0recrbe3(i,n)
182 ENDDO
183 iadrbe3(i+1)=iadrbe3(i)+snrbe3
184 ENDDO
185
186C preparation P0RECRBE3 pour le proc0
187 pglobrbe3=0
188 DO i=1,nrbe3g
189 pglobrbe3(i)=iadrbe3(i)
190 ENDDO
191
192 DO i=1,nrbe3
193 nsn = irbe3(5,i)
194 iad = irbe3(1,i)
195 ngrbe = irbe3(10,i)
196 iadg = iadrbe3(ngrbe)
197 snrbe3 = 0
198 DO n=1,nsn
199 sn = lrbe3( iad+n )
200 IF (weight(sn) == 1 )THEN
201 snrbe3 = snrbe3+1
202 p0rbe3buf(iadg + snrbe3) = nodglob(sn)
203 ENDIF
204 ENDDO
205 pglobrbe3(ngrbe)= pglobrbe3(ngrbe) + snrbe3
206 ENDDO
207
208C Reception des RBE3 des autres procs
209 DO p=2,nspmd
210C Taille du buffer de reception
211 sizrbe3 = 0
212 DO i=1,nrbe3g
213 sizrbe3 = sizrbe3 + p0recrbe3(i,p)
214 ENDDO
215 IF (sizrbe3 > 0) THEN
216 ALLOCATE(recbuf(sizrbe3))
217 msgtyp = msgoff2
218 CALL mpi_recv(recbuf,sizrbe3,mpi_integer,it_spmd(p),msgtyp,
219 * spmd_comm_world,status,ierror)
220
221 psnrbe3=0
222 DO i=1,nrbe3g
223 iadg = pglobrbe3(i)
224 DO n=1,p0recrbe3(i,p)
225 psnrbe3 = psnrbe3 + 1
226 p0rbe3buf(iadg + n) = recbuf(psnrbe3)
227 ENDDO
228 pglobrbe3(i) = pglobrbe3(i) + p0recrbe3(i,p)
229 ENDDO
230 DEALLOCATE(recbuf)
231 ENDIF
232 ENDDO
233C Reception des Noeuds SECONDARYs
234 secndnods=0
235 DO i=1,nrbe3
236 mn = irbe3(3,i)
237 IF(mn/=0)THEN
238 IF (weight(mn)==1) THEN
239 ngrbe = irbe3(10,i)
240 secndnods(ngrbe)=nodglob(mn)
241 ENDIF
242 ENDIF
243 ENDDO
244 CALL spmd_glob_isum9(secndnods,nrbe3g)
245
246C Ecriture sur disque
247 DO i=1,nrbe3g
248 nsn = iadrbe3(i+1) - iadrbe3(i)
249 iadg =iadrbe3(i)
250 mn = secndnods(i)
251 ALLOCATE(iin(2,nsn))
252 nerbe3t(i)=nsn
253 DO n=1,nsn
254 iin(1,n)=mn-1
255 iin(2,n)=p0rbe3buf(iadg + n)-1
256 ENDDO
257 CALL write_i_c(iin,2*nsn)
258 DEALLOCATE(iin)
259 ENDDO
260 DEALLOCATE(iadrbe3)
261 DEALLOCATE(p0rbe3buf)
262 DEALLOCATE(p0recrbe3)
263 ENDIF
264
265C-----------------------------------------------
266 DEALLOCATE(secndnods)
267 DEALLOCATE(szlocrbe3)
268 DEALLOCATE(pglobrbe3)
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