OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_dparrbe2.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23
24!||====================================================================
25!|| spmd_dparrbe2 ../engine/source/mpi/anim/spmd_dparrbe2.F
26!||--- called by ------------------------------------------------------
27!|| genani ../engine/source/output/anim/generate/genani.F
28!||--- calls -----------------------------------------------------
29!|| spmd_glob_isum9 ../engine/source/mpi/interfaces/spmd_th.F
30!|| write_i_c ../common_source/tools/input_output/write_routines.c
31!||--- uses -----------------------------------------------------
32!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
33!||====================================================================
34 SUBROUTINE spmd_dparrbe2(LRBE2, IRBE2,NODGLOB,WEIGHT,NERBE2Y,
35 * NERBE2T )
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 MSGOFF,MSGOFF2,MSGTYP
73 INTEGER STATUS(MPI_STATUS_SIZE),IERROR
74
75 DATA msgoff/7020/
76 DATA msgoff2/7021/
77C-----------------------------------------------
78 ALLOCATE(szlocrbe2(nrbe2g))
79 ALLOCATE(pglobrbe2(nrbe2g))
80 ALLOCATE(mainnods(nrbe2g))
81C-----------------------------------------------
82C 1st step - send to pro 0 a table with number
83C Local send nodes by Rbe2 to send
84C and preparation of the send buffer
85C (taille)
86 nerbe2t = 0
87 snrbe2 = 0
88 sbufsiz = 0
89 szlocrbe2=0
90 pglobrbe2 = 0
91
92 DO i=1,nrbe2
93 ngrbe = irbe2(10,i)
94 szlocrbe2(ngrbe) = 0
95 nsn = irbe2(5,i)
96 DO n=1,nsn
97 IF (weight(lrbe2(irbe2(1,i)+n))==1)
98 . szlocrbe2(ngrbe) = szlocrbe2(ngrbe) + 1
99 ENDDO
100 sbufsiz = sbufsiz + szlocrbe2(ngrbe)
101
102 ENDDO
103
104C Sending to proc 0 of the size table
105
106 IF (ispmd == 0) THEN
107C Procement reception of sizes
108 ALLOCATE(p0recrbe2(nrbe2g,nspmd))
109 DO i=1,nrbe2g
110 p0recrbe2(i,1) = szlocrbe2(i)
111 ENDDO
112
113 DO p=2,nspmd
114 msgtyp = msgoff
115 CALL mpi_recv(p0recrbe2(1,p),nrbe2g,mpi_integer,it_spmd(p),
116 * msgtyp,spmd_comm_world,status,ierror)
117 ENDDO
118
119 ELSE
120C Procs Other shipments
121 msgtyp = msgoff
122 CALL mpi_send(szlocrbe2,nrbe2g,mpi_integer,it_spmd(1),
123 . msgtyp,spmd_comm_world,ierror)
124
125 ENDIF
126
127C --------------------------------------------------------------
128C Sending to proc 0 of the nodes of RBE2 & writing to disk
129C --------------------------------------------------------------
130 IF (ispmd /= 0) THEN
131C ------------------------
132C Procs other than pro 0
133C ------------------------
134 ALLOCATE(sendbuf(sbufsiz))
135 snrbe2 = 0
136 DO i=1,nrbe2
137 nsn = irbe2(5,i)
138 iad = irbe2(1,i)
139 DO n=1,nsn
140 sn = lrbe2(iad+n)
141 IF (weight(sn) == 1 )THEN
142 snrbe2 = snrbe2+1
143 sendbuf(snrbe2)=nodglob(sn)
144 ENDIF
145 ENDDO
146 ENDDO
147 IF (snrbe2 > 0)THEN
148 msgtyp = msgoff2
149 CALL mpi_send(sendbuf,snrbe2,mpi_integer,it_spmd(1),msgtyp,
150 * spmd_comm_world,ierror)
151 ENDIF
152 DEALLOCATE(sendbuf)
153
154C Sending of secondary nodes
155 mainnods = 0
156 DO i=1,nrbe2
157 mn = irbe2(3,i)
158 IF(mn/=0)THEN
159 IF (weight(mn)==1)THEN
160 ngrbe = irbe2(10,i)
161 mainnods(ngrbe)=nodglob(mn)
162 ENDIF
163 ENDIF
164 ENDDO
165 CALL spmd_glob_isum9(mainnods,nrbe2g)
166
167
168 ELSE
169C --------------------------------------------------------------------
170C PROC 0
171C --------------------------------------------------------------------
172C P0RBE2BUF reception table (reception table = LRBE2 Global)
173C IADRBE2 Pointers to P0RBE2BUF Global
174 ALLOCATE(iadrbe2(nrbe2g+1))
175 ALLOCATE(p0rbe2buf(nerbe2y))
176
177C preparation IADRBE2
178 iadrbe2(1)=0
179 DO i=1,nrbe2g
180 snrbe2 = p0recrbe2(i,1)
181 DO n=2,nspmd
182 snrbe2 = snrbe2 + p0recrbe2(i,n)
183 ENDDO
184 iadrbe2(i+1)=iadrbe2(i)+snrbe2
185 ENDDO
186
187C preparation P0RECRBE2 for proc0
188 DO i=1,nrbe2g
189 pglobrbe2(i)=iadrbe2(i)
190 ENDDO
191
192 DO i=1,nrbe2
193 nsn = irbe2(5,i)
194 iad = irbe2(1,i)
195 ngrbe = irbe2(10,i)
196 iadg = iadrbe2(ngrbe)
197 snrbe2 = 0
198 DO n=1,nsn
199 sn = lrbe2( iad+n )
200 IF (weight(sn) == 1 )THEN
201 snrbe2 = snrbe2+1
202 p0rbe2buf(iadg + snrbe2) = nodglob(sn)
203 ENDIF
204 ENDDO
205 pglobrbe2(ngrbe)=pglobrbe2(ngrbe) + snrbe2
206 ENDDO
207
208C Reception of RBE2 from other procs
209 DO p=2,nspmd
210C Size of the reception buffer
211 sizrbe2 = 0
212 DO i=1,nrbe2g
213 sizrbe2 = sizrbe2 + p0recrbe2(i,p)
214 ENDDO
215
216 IF (sizrbe2 > 0) THEN
217 ALLOCATE(recbuf(sizrbe2))
218 msgtyp = msgoff2
219 CALL mpi_recv(recbuf,sizrbe2,mpi_integer,it_spmd(p),msgtyp,
220 * spmd_comm_world,status,ierror)
221
222 psnrbe2=0
223 DO i=1,nrbe2g
224 iadg = pglobrbe2(i)
225 DO n=1,p0recrbe2(i,p)
226 psnrbe2 = psnrbe2 + 1
227 p0rbe2buf(iadg + n) = recbuf(psnrbe2)
228 ENDDO
229 pglobrbe2(i) = pglobrbe2(i) + p0recrbe2(i,p)
230 ENDDO
231 DEALLOCATE(recbuf)
232 ENDIF
233 ENDDO
234C Reception of main Nodes
235 mainnods=0
236 DO i=1,nrbe2
237 mn = irbe2(3,i)
238 IF (weight(mn)==1) THEN
239 ngrbe = irbe2(10,i)
240 mainnods(ngrbe)=nodglob(mn)
241 ENDIF
242 ENDDO
243 CALL spmd_glob_isum9(mainnods,nrbe2g)
244
245C Writing to disk
246 DO i=1,nrbe2g
247 nsn = iadrbe2(i+1) - iadrbe2(i)
248 iadg =iadrbe2(i)
249 mn = mainnods(i)
250 ALLOCATE(iin(2,nsn))
251 nerbe2t(i)=nsn
252 DO n=1,nsn
253 iin(1,n)=mn-1
254 iin(2,n)=p0rbe2buf(iadg + n)-1
255 ENDDO
256 CALL write_i_c(iin,2*nsn)
257 DEALLOCATE(iin)
258 ENDDO
259 DEALLOCATE(iadrbe2)
260 DEALLOCATE(p0rbe2buf)
261 DEALLOCATE(p0recrbe2)
262 ENDIF
263
264
265 DEALLOCATE(szlocrbe2)
266 DEALLOCATE(pglobrbe2)
267 DEALLOCATE(mainnods)
268
269#endif
270 RETURN
271 END
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_dparrbe2
subroutine spmd_dparrbe2(lrbe2, irbe2, nodglob, weight, nerbe2y, nerbe2t)
Definition spmd_dparrbe2.F:36
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