OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_exch_press.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!|| spmd_exch_press ../engine/source/mpi/interfaces/spmd_exch_press.F
25!||--- called by ------------------------------------------------------
26!|| resol ../engine/source/engine/resol.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!||--- uses -----------------------------------------------------
31!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
32!|| message_mod ../engine/share/message_module/message_mod.F
33!|| outputs_mod ../common_source/modules/outputs_mod.f
34!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
35!|| tri25ebox ../engine/share/modules/tri25ebox.F
36!|| tri7box ../engine/share/modules/tri7box.F
37!||====================================================================
38 SUBROUTINE spmd_exch_press(
39 1 IPARI ,INTLIST ,NBINTC ,FNCONT ,
40 2 FTCONT ,ISLEN7 ,IRLEN7 ,IRLEN7T ,ISLEN7T,
41 3 IRLEN20 ,ISLEN20,IRLEN20T,ISLEN20T,INTBUF_TAB,
42 4 N_CSE_FRIC_INTER, N_SCAL_CSE_EFRIC )
43C-----------------------------------------------
44C M o d u l e s
45C-----------------------------------------------
46 USE tri7box
47 USE tri25ebox
48 USE message_mod
49 USE intbufdef_mod
50 USE outputs_mod
51C-----------------------------------------------
52C I m p l i c i t T y p e s
53C-----------------------------------------------
54 USE spmd_comm_world_mod, ONLY : spmd_comm_world
55#include "implicit_f.inc"
56#include "assert.inc"
57C-----------------------------------------------
58C M e s s a g e P a s s i n g
59C-----------------------------------------------
60#include "spmd.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "com01_c.inc"
65#include "com04_c.inc"
66#include "param_c.inc"
67#include "task_c.inc"
68C-----------------------------------------------
69C D u m m y A r g u m e n t s
70C-----------------------------------------------
71 INTEGER NBINTC,ISLEN7, IRLEN7,IRLEN7T, ISLEN7T,
72 . IRLEN20, ISLEN20, IRLEN20T, ISLEN20T,
73 . IPARI(NPARI,*), INTLIST(*)
74 INTEGER , INTENT(IN) :: N_SCAL_CSE_EFRIC,N_CSE_FRIC_INTER(NINTER)
75 my_real
76 . fncont(3,*), ftcont(3,*)
77 TYPE(intbuf_struct_) INTBUF_TAB(*)
78C-----------------------------------------------
79C L o c a l V a r i a b l e s
80C-----------------------------------------------
81#ifdef MPI
82 INTEGER P, L, ADD, LL, NB, LEN, SIZ, KFI, LOC_PROC, MULTIMP, II,
83 . NIN, IDEB, N, MSGTYP, IERROR, NI, NOD, I,
84 . NTY, IALLOCS, IALLOCR, MSGOFF,INTERFRIC,LF,
85 . STATUS(MPI_STATUS_SIZE),DEBUT(NINTER),
86 . adds(nspmd+1), addr(nspmd+1),
87 . req_si(nspmd),req_ri(nspmd)
88 DATA msgoff/190/
89 LOGICAL ITEST
90 my_real ,DIMENSION(:), ALLOCATABLE :: BBUFS, BBUFR
91C-----------------------------------------------
92C S o u r c e L i n e s
93C-----------------------------------------------
94 loc_proc = ispmd + 1
95C
96 len = 7
97 IF(ninefric > 0) len = len +1
98 IF(n_scal_cse_efric > 0) len = len +1
99C
100C Partie 1 envoi et preparation buffer reception
101C
102 DO ii = 1, nbintc
103 nin = intlist(ii)
104 debut(nin) = 0
105 ENDDO
106 iallocs = len*(irlen7+irlen25) + len*(irlen7t+irlen25t) + len*irlen20 + len*irlen20t
107 ierror=0
108 IF(iallocs>0)
109 + ALLOCATE(bbufs(iallocs+nbintc*nspmd),stat=ierror) ! nbintc*NSPMD majorant place supplementaire bufs
110 IF(ierror/=0) THEN
111 CALL ancmsg(msgid=20,anmode=aninfo)
112 CALL arret(2)
113 END IF
114 iallocr = len*(islen7+islen25) + len*(islen7t+islen25t) + len*islen20 + len*islen20t
115 ierror=0
116 IF(iallocr>0)
117 + ALLOCATE(bbufr(iallocr+nbintc*nspmd),stat=ierror) ! nbintc*NSPMD majorant place supplementaire bufs
118 IF(ierror/=0) THEN
119 CALL ancmsg(msgid=20,anmode=aninfo)
120 CALL arret(2)
121 END IF
122 assert(irlen25 >= 0)
123C
124C Receive
125C
126 l = 0
127 DO p = 1, nspmd
128 add = l+1
129 addr(p) = add
130 siz = 0
131 IF(p/=loc_proc)THEN
132C test en plus pour savoir si com globale necessaire entre les 2 procs
133 DO ii = 1, nbintc
134 nin = intlist(ii)
135 nb = nsnsi(nin)%P(p)
136 nty = ipari(7,nin)
137 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==22.OR.
138 . nty==23.OR.nty==24.OR.nty==25) THEN
139 IF(nb>0) THEN
140 l = l + 1 + nb*len
141 ENDIF
142 ENDIF
143 ENDDO
144 siz = l+1-add
145 assert(add + siz -1 <= iallocr+nbintc*nspmd)
146 IF(siz>0)THEN
147 msgtyp = msgoff
148 CALL mpi_irecv(
149 . bbufr(add),siz,real ,it_spmd(p),msgtyp,
150 . spmd_comm_world,req_ri(p),ierror )
151 ENDIF
152 ENDIF
153 ENDDO
154 addr(nspmd+1) = addr(nspmd)+siz
155C
156C Send
157C
158 l = 0
159 DO p = 1, nspmd
160 add = l+1
161 adds(p) = add
162 siz = 0
163 IF(p/=loc_proc)THEN
164C test en plus pour savoir si com globale necessaire entre les 2 procs
165 DO ii = 1, nbintc
166 nin = intlist(ii)
167 ideb = debut(nin)
168 nb = nsnfi(nin)%P(p)
169 nty = ipari(7,nin)
170 interfric = n_cse_fric_inter(nin)
171 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==22.OR.
172 . nty==23.OR.nty==24.OR.nty==25) THEN
173 IF(nb>0) THEN
174 ll = l+1
175 l = l + 1
176 DO n = 1, nb
177 IF(nsvfi(nin)%P(ideb+n)<0)THEN
178C node generating force
179 bbufs(l+1) = -nsvfi(nin)%P(ideb+n)
180 bbufs(l+2) = fnconti(nin)%P(1,ideb+n)
181 bbufs(l+3) = fnconti(nin)%P(2,ideb+n)
182 bbufs(l+4) = fnconti(nin)%P(3,ideb+n)
183 bbufs(l+5) = ftconti(nin)%P(1,ideb+n)
184 bbufs(l+6) = ftconti(nin)%P(2,ideb+n)
185 bbufs(l+7) = ftconti(nin)%P(3,ideb+n)
186 lf = 7
187 IF(interfric>0) THEN
188 bbufs(l+lf+1) = efricfi(nin)%P(ideb+n)
189 efricfi(nin)%P(ideb+n) = zero
190 lf=lf+1
191 ELSEIF(ninefric>0) THEN
192 bbufs(l+lf+1) = zero
193 lf=lf+1
194 ENDIF
195 IF(n_scal_cse_efric>0) THEN
196 bbufs(l+lf+1) = efricgfi(nin)%P(ideb+n)
197 efricgfi(nin)%P(ideb+n) = zero
198 ENDIF
199 fnconti(nin)%P(1,ideb+n) = zero
200 fnconti(nin)%P(2,ideb+n) = zero
201 fnconti(nin)%P(3,ideb+n) = zero
202 ftconti(nin)%P(1,ideb+n) = zero
203 ftconti(nin)%P(2,ideb+n) = zero
204 ftconti(nin)%P(3,ideb+n) = zero
205 l = l + len
206 ELSEIF(interfric > 0.OR.n_scal_cse_efric>0) THEN
207C node not generating force but energy is cumulated
208 bbufs(l+1) = nsvfi(nin)%P(ideb+n)
209 bbufs(l+2) = zero
210 bbufs(l+3) = zero
211 bbufs(l+4) = zero
212 bbufs(l+5) = zero
213 bbufs(l+6) = zero
214 bbufs(l+7) = zero
215 lf = 7
216 IF(interfric>0) THEN
217 bbufs(l+lf+1) = efricfi(nin)%P(ideb+n)
218 efricfi(nin)%P(ideb+n) = zero
219 lf=lf+1
220 ELSEIF(ninefric>0) THEN
221 bbufs(l+lf+1) = zero
222 lf=lf+1
223 ENDIF
224 IF(n_scal_cse_efric>0) THEN
225 bbufs(l+lf+1) = efricgfi(nin)%P(ideb+n)
226 efricgfi(nin)%P(ideb+n) = zero
227 ENDIF
228 l = l + len
229 ENDIF
230 ENDDO
231 bbufs(ll) = (l-ll)/len
232 debut(nin) = debut(nin) + nb
233 END IF
234 END IF
235 ENDDO
236 siz = l+1-add
237 IF(siz>0)THEN
238 msgtyp = msgoff
239 assert(add + siz -1 <= iallocs+nbintc*nspmd)
240 CALL mpi_isend(
241 . bbufs(add),siz,real ,it_spmd(p),msgtyp,
242 . spmd_comm_world,req_si(p),ierror )
243 ENDIF
244 ENDIF
245 ENDDO
246 adds(nspmd+1)=adds(nspmd)+siz
247C
248C Attente reception buffer et decompactage
249C
250C
251C Attente IRECV
252C
253 DO p = 1, nspmd
254 IF(addr(p+1)-addr(p)>0) THEN
255 CALL mpi_wait(req_ri(p),status,ierror)
256 l = addr(p)
257 DO ii = 1, nbintc
258 nin = intlist(ii)
259 IF(nsnsi(nin)%P(p)>0)THEN
260 nty =ipari(7,nin)
261 interfric = n_cse_fric_inter(nin)
262 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==22.OR.
263 . nty==23.OR.nty==24.OR.nty==25)THEN
264 nb = nint(bbufr(l))
265 l = l + 1
266 DO i = 1, nb
267 n = nint(bbufr(l+len*(i-1)))
268 nod = intbuf_tab(nin)%NSV(n)
269C ----
270C T24 E2E Fictive nodes may have Node ID over NUMNOD
271C
272 IF(nod<=numnod)THEN
273 fncont(1,nod) = fncont(1,nod) + bbufr(l+len*(i-1)+1)
274 fncont(2,nod) = fncont(2,nod) + bbufr(l+len*(i-1)+2)
275 fncont(3,nod) = fncont(3,nod) + bbufr(l+len*(i-1)+3)
276 ftcont(1,nod) = ftcont(1,nod) + bbufr(l+len*(i-1)+4)
277 ftcont(2,nod) = ftcont(2,nod) + bbufr(l+len*(i-1)+5)
278 ftcont(3,nod) = ftcont(3,nod) + bbufr(l+len*(i-1)+6)
279 lf = 6
280 IF(interfric>0) THEN
281 efric(interfric,nod)= efric(interfric,nod)+ bbufr(l+len*(i-1)+lf+1)
282 lf = lf+1
283 ELSEIF(ninefric>0) THEN
284 lf=lf+1
285 ENDIF
286 IF(n_scal_cse_efric>0) THEN
287 efricg(nod)= efricg(nod)+ bbufr(l+len*(i-1)+lf+1)
288 ENDIF
289 ENDIF
290 ENDDO
291 l = l + nb*len
292 END IF
293 ENDIF
294 ENDDO
295 ENDIF
296 ENDDO
297C Deallocation R
298 IF(iallocr>0) THEN
299 DEALLOCATE(bbufr)
300 END IF
301C
302C Attente ISEND
303C
304 DO p = 1, nspmd
305 IF(adds(p+1)-adds(p)>0) THEN
306 CALL mpi_wait(req_si(p),status,ierror)
307 ENDIF
308 ENDDO
309C Deallocation S
310 IF(iallocs>0) THEN
311 DEALLOCATE(bbufs)
312 END IF
313C
314#endif
315 RETURN
316 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_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
message_mod
Definition message_mod.F:1249
outputs_mod
Definition outputs_mod.F:59
outputs_mod::ninefric
integer ninefric
Definition outputs_mod.F:65
tri25ebox::irlen25
integer irlen25
Definition tri25ebox.F:76
tri25ebox::irlen25t
integer irlen25t
Definition tri25ebox.F:78
tri25ebox::islen25t
integer islen25t
Definition tri25ebox.F:78
tri25ebox::islen25
integer islen25
Definition tri25ebox.F:76
tri7box::fnconti
type(real_pointer2), dimension(:), allocatable fnconti
Definition tri7box.F:510
tri7box::efricgfi
type(real_pointer), dimension(:), allocatable efricgfi
Definition tri7box.F:511
tri7box::nsnsi
type(int_pointer), dimension(:), allocatable nsnsi
Definition tri7box.F:491
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::efricfi
type(real_pointer), dimension(:), allocatable efricfi
Definition tri7box.F:511
tri7box::ftconti
type(real_pointer2), dimension(:), allocatable ftconti
Definition tri7box.F:510
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
spmd_exch_press
subroutine spmd_exch_press(ipari, intlist, nbintc, fncont, ftcont, islen7, irlen7, irlen7t, islen7t, irlen20, islen20, irlen20t, islen20t, intbuf_tab, n_cse_fric_inter, n_scal_cse_efric)
Definition spmd_exch_press.F:43
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
arret
subroutine arret(nn)
Definition arret.F:87