OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_exch_sorting_efric.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_sorting_efric ../engine/source/mpi/interfaces/spmd_exch_sorting_efric.F
25!||--- called by ------------------------------------------------------
26!|| inttri ../engine/source/interfaces/intsort/inttri.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../engine/source/output/message/message.F
29!|| arret ../engine/source/system/arret.F
30!||--- uses -----------------------------------------------------
31!|| h3d_mod ../engine/share/modules/h3d_mod.F
32!|| intbufdef_mod ../common_source/modules/interfaces/intbufdef_mod.F90
33!|| message_mod ../engine/share/message_module/message_mod.F
34!|| outputs_mod ../common_source/modules/outputs_mod.F
35!|| spmd_comm_world_mod ../engine/source/mpi/spmd_comm_world.F90
36!|| tri25ebox ../engine/share/modules/tri25ebox.F
37!|| tri7box ../engine/share/modules/tri7box.F
38!||====================================================================
39 SUBROUTINE spmd_exch_sorting_efric(
40 1 IPARI ,INTLIST ,NBINTC ,ISLEN7 ,IRLEN7 ,
41 2 IRLEN7T ,ISLEN7T ,IRLEN20 ,ISLEN20,IRLEN20T,
42 3 ISLEN20T,INTBUF_TAB,H3D_DATA )
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
51 USE h3d_mod
52C-----------------------------------------------
53C I m p l i c i t T y p e s
54C-----------------------------------------------
55 USE spmd_comm_world_mod, ONLY : spmd_comm_world
56#include "implicit_f.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 , INTENT(IN) ::
72 . NBINTC,ISLEN7, IRLEN7,IRLEN7T, ISLEN7T,
73 . IRLEN20, ISLEN20, IRLEN20T, ISLEN20T,
74 . ipari(npari,ninter), intlist(nbintc)
75
76 TYPE(intbuf_struct_),INTENT(IN) :: INTBUF_TAB(NINTER)
77 TYPE(H3D_DATABASE), INTENT(IN) :: H3D_DATA
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, LOC_PROC, II,
83 . NIN, IDEB, N, MSGTYP, IERROR, NI, NOD, I,
84 . NTY, IALLOCS, IALLOCR, MSGOFF,INTERFRIC,
85 . nbefric,
86 . status(mpi_status_size),debut(ninter),
87 . adds(nspmd+1), addr(nspmd+1),
88 . req_si(nspmd),req_ri(nspmd),intsort(nbintc)
89 DATA msgoff/190/
90 LOGICAL ITEST
91 my_real DIST
92 my_real ,DIMENSION(:), ALLOCATABLE :: bbufs, bbufr
93 LOGICAL :: IS_EFRIC_COM_NEEDED
94C-----------------------------------------------
95C S o u r c e L i n e s
96C-----------------------------------------------
97 loc_proc = ispmd + 1
98C
99 len = 3
100C
101C Part 1 : prepare send/reception buffers and if comm is needed
102C
103 intsort(1:nbintc) = 0
104 nbefric = 0
105 is_efric_com_needed = .false.
106 DO ii = 1, nbintc
107 nin = intlist(ii)
108 nty = ipari(7,nin)
109 dist = intbuf_tab(nin)%VARIABLES(5)
110 IF(nty==7.OR.nty==24) THEN ! only Inter type 7 our 24, Inter type 25 is already done each cycle
111 IF (dist<=zero) THEN ! only for interfaces that will be sorted
112 interfric = h3d_data%N_CSE_FRIC_INTER(nin)
113 IF(h3d_data%N_SCAL_CSE_FRIC > 0) THEN
114 nbefric = nbefric +1
115 intsort(ii) = 1
116 is_efric_com_needed = .true.
117 ELSEIF(interfric > 0)THEN
118 nbefric = nbefric +1
119 intsort(ii) = 1
120 is_efric_com_needed = .true.
121 ENDIF
122 ENDIF
123 ENDIF
124 debut(nin) = 0
125 ENDDO
126
127 IF(is_efric_com_needed) THEN
128
129 iallocs = len*irlen7 + len*irlen7t
130 ierror=0
131 IF(iallocs>0)
132 + ALLOCATE(bbufs(iallocs+nbintc*nspmd),stat=ierror)
133 IF(ierror/=0) THEN
134 CALL ancmsg(msgid=20,anmode=aninfo)
135 CALL arret(2)
136 END IF
137 iallocr = len*islen7 + len*islen7t
138 ierror=0
139 IF(iallocr>0)
140 + ALLOCATE(bbufr(iallocr+nbintc*nspmd),stat=ierror)
141 IF(ierror/=0) THEN
142 CALL ancmsg(msgid=20,anmode=aninfo)
143 CALL arret(2)
144 END IF
145C
146C Receive
147C
148 l = 0
149 DO p = 1, nspmd
150 add = l+1
151 addr(p) = add
152 siz = 0
153 IF(p/=loc_proc)THEN
154 DO ii = 1, nbintc
155 nin = intlist(ii)
156 nb = nsnsi(nin)%P(p)
157 IF(intsort(ii) > 0 ) THEN
158 IF(nb>0) THEN
159 l = l + 1 + nb*len
160 ENDIF
161 ENDIF
162 ENDDO
163 siz = l+1-add
164 IF(siz>0)THEN
165 msgtyp = msgoff
166 CALL mpi_irecv(
167 . bbufr(add),siz,real ,it_spmd(p),msgtyp,
168 . spmd_comm_world,req_ri(p),ierror )
169 ENDIF
170 ENDIF
171 ENDDO
172 addr(nspmd+1) = addr(nspmd)+siz
173C
174C Send
175C
176 l = 0
177 DO p = 1, nspmd
178 add = l+1
179 adds(p) = add
180 siz = 0
181 IF(p/=loc_proc)THEN
182 DO ii = 1, nbintc
183 nin = intlist(ii)
184 ideb = debut(nin)
185 nb = nsnfi(nin)%P(p)
186 interfric = h3d_data%N_CSE_FRIC_INTER(nin)
187 IF(intsort(ii) > 0) THEN
188 IF(nb>0) THEN
189 ll = l+1
190 l = l + 1
191 DO n = 1, nb
192c IF(NSVFI(NIN)%P(IDEB+N)<0)THEN ! after i7com nodes really impacting are no more tagged : to be optimized
193 bbufs(l+1) = nsvfi(nin)%P(ideb+n)
194 IF(interfric>0) THEN
195 bbufs(l+2) = efricfi(nin)%P(ideb+n)
196 efricfi(nin)%P(ideb+n) = zero
197 ELSE
198 bbufs(l+2) = zero
199 ENDIF
200 IF(h3d_data%N_SCAL_CSE_FRIC>0) THEN
201 bbufs(l+3) = efricgfi(nin)%P(ideb+n)
202 efricgfi(nin)%P(ideb+n) = zero
203 ELSE
204 bbufs(l+3) = zero
205 ENDIF
206 l = l + len
207c ENDIF
208 ENDDO
209 bbufs(ll) = (l-ll)/len
210 debut(nin) = debut(nin) + nb
211 END IF
212 END IF
213 ENDDO
214 siz = l+1-add
215 IF(siz>0)THEN
216 msgtyp = msgoff
217 CALL mpi_isend(
218 . bbufs(add),siz,real ,it_spmd(p),msgtyp,
219 . spmd_comm_world,req_si(p),ierror )
220 ENDIF
221 ENDIF
222 ENDDO
223 adds(nspmd+1)=adds(nspmd)+siz
224C
225C Waiting reception
226C
227 DO p = 1, nspmd
228 IF(addr(p+1)-addr(p)>0) THEN
229 CALL mpi_wait(req_ri(p),status,ierror)
230 l = addr(p)
231 DO ii = 1, nbintc
232 nin = intlist(ii)
233 IF(nsnsi(nin)%P(p)>0)THEN
234 interfric = h3d_data%N_CSE_FRIC_INTER(nin)
235 IF(intsort(ii) > 0) THEN
236 nb = nint(bbufr(l))
237 l = l + 1
238 DO i = 1, nb
239 n = nint(bbufr(l+len*(i-1)))
240 nod = intbuf_tab(nin)%NSV(n)
241 IF(nod<=numnod)THEN
242 IF(interfric>0) efric(interfric,nod)= efric(interfric,nod)+ bbufr(l+len*(i-1)+1)
243 IF(h3d_data%N_SCAL_CSE_FRIC>0) efricg(nod)= efricg(nod)+ bbufr(l+len*(i-1)+2)
244 ENDIF
245
246 ENDDO
247 l = l + nb*len
248 END IF
249 ENDIF
250 ENDDO
251 ENDIF
252 ENDDO
253C Deallocation R
254 IF(iallocr>0) THEN
255 DEALLOCATE(bbufr)
256 END IF
257C
258C Attente ISEND
259C
260 DO p = 1, nspmd
261 IF(adds(p+1)-adds(p)>0) THEN
262 CALL mpi_wait(req_si(p),status,ierror)
263 ENDIF
264 ENDDO
265C Deallocation S
266 IF(iallocs>0) THEN
267 DEALLOCATE(bbufs)
268 END IF
269C
270 ENDIF ! IS_EFRIC_COM_NEEDED
271C
272#endif
273 RETURN
274 END SUBROUTINE spmd_exch_sorting_efric
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
h3d_mod
Definition h3d_mod.F:308
message_mod
Definition message_mod.F:1249
outputs_mod
Definition outputs_mod.F:59
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::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
spmd_exch_sorting_efric
subroutine spmd_exch_sorting_efric(ipari, intlist, nbintc, islen7, irlen7, irlen7t, islen7t, irlen20, islen20, irlen20t, islen20t, intbuf_tab, h3d_data)
Definition spmd_exch_sorting_efric.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