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 MSGOFF,MSGOFF2,MSGTYP
73 INTEGER STATUS(MPI_STATUS_SIZE),IERROR
74
75 DATA msgoff/7022/
76 DATA msgoff2/7023/
77C-----------------------------------------------
78 ALLOCATE(secndnods(nrbe3g))
79 ALLOCATE(szlocrbe3(nrbe3g))
80 ALLOCATE(pglobrbe3(nrbe3g))
81C-----------------------------------------------
82C 1st step - send to pro 0 a table with number
83C Local main nodes by Rbe3 to send
84C and preparation of the send buffer
85C (taille)
86 nerbe3t = 0
87 snrbe3 = 0
88 sbufsiz = 0
89 szlocrbe3 = 0
90
91 DO i=1,nrbe3
92 ngrbe = irbe3(10,i)
93 szlocrbe3(ngrbe) = 0
94 nsn = irbe3(5,i)
95 DO n=1,nsn
96 IF (weight(lrbe3(irbe3(1,i)+n))==1)
97 . szlocrbe3(ngrbe) = szlocrbe3(ngrbe) + 1
98 ENDDO
99 sbufsiz = sbufsiz + szlocrbe3(ngrbe)
100 ENDDO
101C Sending to proc 0 of the sizes array
102
103 IF (ispmd == 0) THEN
104C Procement reception of sizes
105 ALLOCATE(p0recrbe3(nrbe3g,nspmd))
106 DO i=1,nrbe3g
107 p0recrbe3(i,1) = szlocrbe3(i)
108 ENDDO
109
110 DO p=2,nspmd
111 msgtyp = msgoff
112 CALL mpi_recv(p0recrbe3(1,p),nrbe3g,mpi_integer,it_spmd(p),
113 * msgtyp,spmd_comm_world,status,ierror)
114 ENDDO
115
116
117 ELSE
118C Procs Other shipments
119 msgtyp = msgoff
120 CALL mpi_send(szlocrbe3,nrbe3g,mpi_integer,it_spmd(1),
121 . msgtyp,spmd_comm_world,ierror)
122
123 ENDIF
124
125
126C --------------------------------------------------------------
127C Sending to proc 0 of the nodes of RBE3 & writing to disk
128C --------------------------------------------------------------
129 IF (ispmd /= 0) THEN
130C ------------------------
131C Procs other than pro 0
132C ------------------------
133 ALLOCATE(sendbuf(sbufsiz))
134 snrbe3 = 0
135 DO i=1,nrbe3
136 nsn = irbe3(5,i)
137 iad = irbe3(1,i)
138 DO n=1,nsn
139 sn = lrbe3(iad+n)
140 IF (weight(sn) == 1 )THEN
141 snrbe3 = snrbe3+1
142 sendbuf(snrbe3)=nodglob(sn)
143 ENDIF
144 ENDDO
145 ENDDO
146 IF (snrbe3 > 0)THEN
147 msgtyp = msgoff2
148 CALL mpi_send(sendbuf,snrbe3,mpi_integer,it_spmd(1),msgtyp,
149 * spmd_comm_world,ierror)
150 ENDIF
151 DEALLOCATE(sendbuf)
152
153C Sending of secondary nodes
154 secndnods=0
155 DO i=1,nrbe3
156 mn = irbe3(3,i)
157 IF(mn/=0)THEN
158 IF (weight(mn)==1) THEN
159 ngrbe = irbe3(10,i)
160 secndnods(ngrbe)=nodglob(mn)
161 ENDIF
162 ENDIF
163 ENDDO
164 CALL spmd_glob_isum9(secndnods,nrbe3g)
165
166 ELSE
167C --------------------------------------------------------------------
168C PROC 0
169C --------------------------------------------------------------------
170C P0RBE3BUF reception table (reception table = LRBE3 Global)
171C IAdrbe3 pointers towards p0rbe3buf global
172 ALLOCATE(iadrbe3(nrbe3g+1))
173 ALLOCATE(p0rbe3buf(nerbe3y))
174
175C preparation IADRBE3
176 iadrbe3(1)=0
177 DO i=1,nrbe3g
178 snrbe3 = p0recrbe3(i,1)
179 DO n=2,nspmd
180 snrbe3 = snrbe3 + p0recrbe3(i,n)
181 ENDDO
182 iadrbe3(i+1)=iadrbe3(i)+snrbe3
183 ENDDO
184
185C preparing P0RECRBE3 for proc0
186 pglobrbe3=0
187 DO i=1,nrbe3g
188 pglobrbe3(i)=iadrbe3(i)
189 ENDDO
190
191 DO i=1,nrbe3
192 nsn = irbe3(5,i)
193 iad = irbe3(1,i)
194 ngrbe = irbe3(10,i)
195 iadg = iadrbe3(ngrbe)
196 snrbe3 = 0
197 DO n=1,nsn
198 sn = lrbe3( iad+n )
199 IF (weight(sn) == 1 )THEN
200 snrbe3 = snrbe3+1
201 p0rbe3buf(iadg + snrbe3) = nodglob(sn)
202 ENDIF
203 ENDDO
204 pglobrbe3(ngrbe)= pglobrbe3(ngrbe) + snrbe3
205 ENDDO
206
207C Reception of RBE3 from other procs
208 DO p=2,nspmd
209C Size of the reception buffer
210 sizrbe3 = 0
211 DO i=1,nrbe3g
212 sizrbe3 = sizrbe3 + p0recrbe3(i,p)
213 ENDDO
214 IF (sizrbe3 > 0) THEN
215 ALLOCATE(recbuf(sizrbe3))
216 msgtyp = msgoff2
217 CALL mpi_recv(recbuf,sizrbe3,mpi_integer,it_spmd(p),msgtyp,
218 * spmd_comm_world,status,ierror)
219
220 psnrbe3=0
221 DO i=1,nrbe3g
222 iadg = pglobrbe3(i)
223 DO n=1,p0recrbe3(i,p)
224 psnrbe3 = psnrbe3 + 1
225 p0rbe3buf(iadg + n) = recbuf(psnrbe3)
226 ENDDO
227 pglobrbe3(i) = pglobrbe3(i) + p0recrbe3(i,p)
228 ENDDO
229 DEALLOCATE(recbuf)
230 ENDIF
231 ENDDO
232C Reception of SECONDARY Nodes
233 secndnods=0
234 DO i=1,nrbe3
235 mn = irbe3(3,i)
236 IF(mn/=0)THEN
237 IF (weight(mn)==1) THEN
238 ngrbe = irbe3(10,i)
239 secndnods(ngrbe)=nodglob(mn)
240 ENDIF
241 ENDIF
242 ENDDO
243 CALL spmd_glob_isum9(secndnods,nrbe3g)
244
245C Writing to disk
246 DO i=1,nrbe3g
247 nsn = iadrbe3(i+1) - iadrbe3(i)
248 iadg =iadrbe3(i)
249 mn = secndnods(i)
250 ALLOCATE(iin(2,nsn))
251 nerbe3t(i)=nsn
252 DO n=1,nsn
253 iin(1,n)=mn-1
254 iin(2,n)=p0rbe3buf(iadg + n)-1
255 ENDDO
256 CALL write_i_c(iin,2*nsn)
257 DEALLOCATE(iin)
258 ENDDO
259 DEALLOCATE(iadrbe3)
260 DEALLOCATE(p0rbe3buf)
261 DEALLOCATE(p0recrbe3)
262 ENDIF
263
264C-----------------------------------------------
265 DEALLOCATE(secndnods)
266 DEALLOCATE(szlocrbe3)
267 DEALLOCATE(pglobrbe3)
268
269#endif
270 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:520
write_i_c
void write_i_c(int *w, int *len)
Definition write_routines.c:645