OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_fvb_gath.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
24C
25!||====================================================================
26!|| spmd_fvb_gath ../engine/source/mpi/airbags/spmd_fvb_gath.F
27!||--- called by ------------------------------------------------------
28!|| fv_up_switch ../engine/source/airbag/fv_up_switch.F
29!|| fvbag1 ../engine/source/airbag/fvbag1.F
30!|| fvbric ../engine/source/airbag/fvbric.F
31!|| fvmesh1 ../engine/source/airbag/fvmesh.F
32!|| fvrezone1 ../engine/source/airbag/fvrezone.F
33!|| lecfvbag ../engine/source/input/lecfvbag.F
34!||--- calls -----------------------------------------------------
35!||--- uses -----------------------------------------------------
36!|| fvbag_mod ../engine/share/modules/fvbag_mod.F
37!||====================================================================
38 SUBROUTINE spmd_fvb_gath(IFV, X, XXX, XXXA, XXXSA,
39 . IDO)
40C Gather local X into XXX,XXXA,XXXSA on the PMAIN of the FVM
41C depending on IDO
42
43C IF IDO = 1 : gather X(1:NN_L) into X
44C IF IDO = 2 : gather X(1:NN_L) into X
45C and X(1:NNA_L) into XXXA
46C and X(1:NNSA_L) into XXXSA
47C IF IDO = 3 : gather X(1:NN_L + NNI_L) into X
48C and X(1:NNA_L) into XXXA
49C and X(1:NNSA_L) into XXXSA
50C IF IDO = 4 : gather X(1:NN_L + NNI_L) into X
51
52C-----------------------------------------------
53C M o d u l e s
54C-----------------------------------------------
55 USE fvbag_mod
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------------------------
61C M e s s a g e P a s s i n g
62C-----------------------------------------------
63#include "spmd.inc"
64C-----------------------------------------------
65C C o m m o n B l o c k s
66C-----------------------------------------------
67#include "com01_c.inc"
68#include "com04_c.inc"
69#include "task_c.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73 INTEGER IFV, IDO
74 my_real
75 . x(3,*), xxx(3,*), xxxa(3,*), xxxsa(3,*)
76C-----------------------------------------------
77C L o c a l V a r i a b l e s
78C-----------------------------------------------
79#ifdef MPI
80 INTEGER II, I, ITAG, LEN, ITAB(3,NSPMD-1),REQ(2*(NSPMD-1)),
81 . stat(mpi_status_size,2*(nspmd-1)), ierr, leni, lenr,
82 . iadi(nspmd-1), iadr(nspmd-1), iad, i1, i2, iad1, iad2,
83 . j, j1, itabl(3), pmain, msgoff, ido1, ido2
84 INTEGER, DIMENSION(:), ALLOCATABLE :: IBUF
85 my_real
86 . , DIMENSION(:), ALLOCATABLE :: rbuf
87C
88 DATA msgoff/204/
89C
90 ido2 = 0
91 ido1 = ido
92 IF (ido == 4) THEN
93 ido1 = 1
94 ido2 = 1 ! add NNI_L
95 ELSEIF (ido == 3) THEN
96 ido2 = 1 ! add NNI_L
97 ENDIF
98
99 IF (fvspmd(ifv)%RANK == 0) THEN
100 DO i=1,fvspmd(ifv)%NSPMD-1
101 itab(1,i) = fvspmd(ifv)%ITAB(1,i)
102 IF( ido2 == 1) itab(1,i)=itab(1,i)+fvspmd(ifv)%ITAB(4,i)
103 IF (ido1 > 1) THEN
104 itab(2,i)=fvspmd(ifv)%ITAB(2,i)
105 itab(3,i)=fvspmd(ifv)%ITAB(3,i)
106 ELSE
107 itab(2,i)=0
108 itab(3,i)=0
109 ENDIF
110 ENDDO
111
112 leni=0
113 lenr=0
114 ii=0
115 DO i=1,fvspmd(ifv)%NSPMD-1
116 ii=ii+1
117 iadi(ii)=leni+1
118 iadr(ii)=lenr+1
119 leni=leni+itab(1,ii)+itab(2,ii)+itab(3,ii)
120 lenr=lenr+3*(itab(1,ii)+itab(2,ii)+itab(3,ii))
121 ENDDO
122 ALLOCATE(ibuf(leni), rbuf(lenr))
123 rbuf(1:lenr) = zero
124 ibuf(1:leni) = 0
125C Reception des entiers
126 ii=0
127 DO i=1,fvspmd(ifv)%NSPMD-1
128 ii=ii+1
129 itag=msgoff
130 iad=iadi(ii)
131 len=itab(1,ii)+itab(2,ii)+itab(3,ii)
132 req(ii) = mpi_request_null
133 IF(len > 0) CALL mpi_irecv(ibuf(iad), len, mpi_integer, i,
134 . itag, fvspmd(ifv)%MPI_COMM, req(ii), ierr)
135 ENDDO
136C Reception des reels
137 ii=0
138 DO i=1,fvspmd(ifv)%NSPMD-1
139 ii=ii+1
140 itag=msgoff
141 iad=iadr(ii)
142 len=3*(itab(1,ii)+itab(2,ii)+itab(3,ii))
143 req(fvspmd(ifv)%NSPMD-1+ii) = mpi_request_null
144 IF(len >0 ) CALL mpi_irecv(rbuf(iad), len, real, i, itag,
145 . fvspmd(ifv)%MPI_COMM, req(fvspmd(ifv)%NSPMD-1+ii), ierr)
146 ENDDO
147C Remplissage des tableaux de sortie XXX, XXXA, XXXSA
148 len = fvspmd(ifv)%NN_L
149C ajout noeuds internes
150 IF(ido2 == 1)len = len + fvspmd(ifv)%NNI_L
151 DO i=1,len
152 i1=fvspmd(ifv)%IBUF_L(1,i)
153 i2=fvspmd(ifv)%IBUF_L(2,i)
154 xxx(1,i1)=x(1,i2)
155 xxx(2,i1)=x(2,i2)
156 xxx(3,i1)=x(3,i2)
157 ENDDO
158 IF (ido1 > 1) THEN
159 DO i=1,fvspmd(ifv)%NNA_L
160 i1=fvspmd(ifv)%IBUFA_L(1,i)
161 i2=fvspmd(ifv)%IBUFA_L(2,i)
162 IF (i2 <= numnod) THEN
163 ! IF MESHGEMS IS USED, EXTRA NODES ARE NOT INCLUDED WITHIN THE NUMNOD NODES
164 xxxa(1,i1)=x(1,i2)
165 xxxa(2,i1)=x(2,i2)
166 xxxa(3,i1)=x(3,i2)
167 ENDIF
168 ENDDO
169 DO i=1,fvspmd(ifv)%NNSA_L
170 i1=fvspmd(ifv)%IBUFSA_L(1,i)
171 i2=fvspmd(ifv)%IBUFSA_L(2,i)
172 IF (i2 <= numnod) THEN
173 ! IF MESHGEMS IS USED, EXTRA NODES ARE NOT INCLUDED WITHIN THE NUMNOD NODES
174 xxxsa(1,i1)=x(1,i2)
175 xxxsa(2,i1)=x(2,i2)
176 xxxsa(3,i1)=x(3,i2)
177 ENDIF
178 ENDDO
179 ENDIF
180
181 ii=0
182 DO i=1,fvspmd(ifv)%NSPMD-1
183 CALL mpi_wait(req(i), stat, ierr)
184 CALL mpi_wait(req(fvspmd(ifv)%NSPMD-1+i), stat, ierr)
185 ii=ii+1
186 iad1=iadi(ii)
187 iad2=iadr(ii)
188 DO j=1,itab(1,ii)
189 j1=ibuf(iad1-1+j)
190 xxx(1,j1)=rbuf(iad2-1+3*(j-1)+1)
191 xxx(2,j1)=rbuf(iad2-1+3*(j-1)+2)
192 xxx(3,j1)=rbuf(iad2-1+3*(j-1)+3)
193 ENDDO
194 iad1=iad1+itab(1,ii)
195 iad2=iad2+3*itab(1,ii)
196 DO j=1,itab(2,ii)
197 j1=ibuf(iad1-1+j)
198 xxxa(1,j1)=rbuf(iad2-1+3*(j-1)+1)
199 xxxa(2,j1)=rbuf(iad2-1+3*(j-1)+2)
200 xxxa(3,j1)=rbuf(iad2-1+3*(j-1)+3)
201 ENDDO
202 iad1=iad1+itab(2,ii)
203 iad2=iad2+3*itab(2,ii)
204 DO j=1,itab(3,ii)
205 j1=ibuf(iad1-1+j)
206 xxxsa(1,j1)=rbuf(iad2-1+3*(j-1)+1)
207 xxxsa(2,j1)=rbuf(iad2-1+3*(j-1)+2)
208 xxxsa(3,j1)=rbuf(iad2-1+3*(j-1)+3)
209 ENDDO
210 ENDDO
211 DEALLOCATE(ibuf, rbuf)
212 ELSE IF(fvspmd(ifv)%RANK > 0) THEN
213 itabl(1)=fvspmd(ifv)%NN_L
214C ajout noeuds internes
215 IF(ido2== 1 ) itabl(1)=itabl(1)+fvspmd(ifv)%NNI_L
216 IF (ido1 > 1) THEN
217 itabl(2)=fvspmd(ifv)%NNA_L
218 itabl(3)=fvspmd(ifv)%NNSA_L
219 ELSE
220 itabl(2)=0
221 itabl(3)=0
222 ENDIF
223 pmain=fvspmd(ifv)%PMAIN
224C
225 len=itabl(1)+itabl(2)+itabl(3)
226 ALLOCATE(ibuf(len), rbuf(3*len))
227 iad1=1
228 iad2=1
229 len = fvspmd(ifv)%NN_L
230 IF(ido2 == 1) len = len + fvspmd(ifv)%NNI_L
231 DO i=1,len
232 i1=fvspmd(ifv)%IBUF_L(1,i)
233 i2=fvspmd(ifv)%IBUF_L(2,i)
234 ibuf(iad1-1+i)=i1
235 rbuf(iad2-1+3*(i-1)+1)=x(1,i2)
236 rbuf(iad2-1+3*(i-1)+2)=x(2,i2)
237 rbuf(iad2-1+3*(i-1)+3)=x(3,i2)
238 ENDDO
239 IF (ido1 > 1) THEN
240 iad1=iad1+len
241 iad2=iad2+3*len
242 DO i=1,fvspmd(ifv)%NNA_L
243 i1=fvspmd(ifv)%IBUFA_L(1,i)
244 i2=fvspmd(ifv)%IBUFA_L(2,i)
245 ibuf(iad1-1+i)=i1
246 IF (i2 <= numnod) THEN
247 ! IF MESHGEMS IS USED, EXTRA NODES ARE NOT INCLUDED WITHIN THE NUMNOD NODES
248 rbuf(iad2-1+3*(i-1)+1)=x(1,i2)
249 rbuf(iad2-1+3*(i-1)+2)=x(2,i2)
250 rbuf(iad2-1+3*(i-1)+3)=x(3,i2)
251 ENDIF
252 ENDDO
253 iad1=iad1+fvspmd(ifv)%NNA_L
254 iad2=iad2+3*fvspmd(ifv)%NNA_L
255 DO i=1,fvspmd(ifv)%NNSA_L
256 i1=fvspmd(ifv)%IBUFSA_L(1,i)
257 i2=fvspmd(ifv)%IBUFSA_L(2,i)
258 ibuf(iad1-1+i)=i1
259 IF (i2 <= numnod) THEN
260 ! IF MESHGEMS IS USED, EXTRA NODES ARE NOT INCLUDED WITHIN THE NUMNOD NODES
261 rbuf(iad2-1+3*(i-1)+1)=x(1,i2)
262 rbuf(iad2-1+3*(i-1)+2)=x(2,i2)
263 rbuf(iad2-1+3*(i-1)+3)=x(3,i2)
264 ENDIF
265 ENDDO
266 ENDIF
267C
268 itag=msgoff
269 len=itabl(1)+itabl(2)+itabl(3)
270 req(1) = mpi_request_null
271 req(2) = mpi_request_null
272 IF(len > 0) CALL mpi_isend(ibuf, len, mpi_integer, 0,
273 . itag, fvspmd(ifv)%MPI_COMM, req(1), ierr)
274C
275 itag=msgoff
276 len=3*(itabl(1)+itabl(2)+itabl(3))
277 IF(len > 0 ) CALL mpi_isend(rbuf, len, real, 0,
278 . itag, fvspmd(ifv)%MPI_COMM, req(2), ierr)
279C
280 CALL mpi_waitall(2, req, stat, ierr)
281 DEALLOCATE(ibuf, rbuf)
282 ENDIF
283C
284
285#endif
286 RETURN
287 END
my_real
#define my_real
Definition cppsort.cpp:32
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_waitall
subroutine mpi_waitall(cnt, array_of_requests, status, ierr)
Definition mpi.f:536
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
fvbag_mod
Definition fvbag_mod.F:44
fvbag_mod::fvspmd
type(fvbag_spmd), dimension(:), allocatable fvspmd
Definition fvbag_mod.F:129
spmd_fvb_gath
subroutine spmd_fvb_gath(ifv, x, xxx, xxxa, xxxsa, ido)
Definition spmd_fvb_gath.F:40