OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_exchmsr_idel.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "task_c.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_exchmsr_idel (bufs, lbufs, ixs, ixc, ixtg, ixq, iparg, itagl, nodes, irsize, irecv, cnel, addcnel, ofc, oft, oftg, ofur, ofr, ofp, lindex, ixp, ixr, ixt, geo, tagel, iad_elem)

Function/Subroutine Documentation

◆ spmd_exchmsr_idel()

subroutine spmd_exchmsr_idel ( integer, dimension(*) bufs,
integer lbufs,
integer, dimension(nixs,*) ixs,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(nixq,*) ixq,
integer, dimension(nparg,*) iparg,
integer, dimension(*) itagl,
type(nodal_arrays_), intent(inout) nodes,
integer irsize,
integer, dimension(*) irecv,
integer, dimension(0:*) cnel,
integer, dimension(0:*) addcnel,
integer ofc,
integer oft,
integer oftg,
integer ofur,
integer ofr,
integer ofp,
integer lindex,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixt,*) ixt,
geo,
integer, dimension(*) tagel,
integer, dimension(2,nspmd+1), intent(in) iad_elem )

Definition at line 33 of file spmd_exchmsr_idel.F.

40 USE nodal_arrays_mod
41C-----------------------------------------------
42C I m p l i c i t T y p e s
43C-----------------------------------------------
44 USE spmd_comm_world_mod, ONLY : spmd_comm_world
45#include "implicit_f.inc"
46C-----------------------------------------------------------------
47C M e s s a g e P a s s i n g
48C-----------------------------------------------
49#include "spmd.inc"
50C-----------------------------------------------
51C C o m m o n B l o c k s
52C-----------------------------------------------
53#include "task_c.inc"
54#include "com01_c.inc"
55#include "com04_c.inc"
56#include "param_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 TYPE(nodal_arrays_), INTENT(INOUT) :: NODES
61 INTEGER IXS(NIXS,*), IXQ(NIXQ,*), IXC(NIXC,*), IXP(NIXP,*),
62 . IXR(NIXR,*), IXT(NIXT,*), TAGEL(*),
63 . IXTG(NIXTG,*), IPARG(NPARG,*),
64 . BUFS(*),ITAGL(*), IRECV(*), CNEL(0:*), ADDCNEL(0:*),
65 . IRSIZE, LBUFS, OFC, OFT, OFTG, OFUR, OFR, OFP, LINDEX
66 INTEGER, DIMENSION(2,NSPMD+1), INTENT(in) :: IAD_ELEM
67
68C REAL
69 my_real
70 . geo(npropg,*)
71C-----------------------------------------------
72C L o c a l V a r i a b l e s
73C-----------------------------------------------
74#ifdef MPI
75 INTEGER MSGOFF2 ,MSGOFF3, MSGTYP, LOC_PROC,
76 . IERROR,I, IDEB, LEN, N1, N2, N3, N4,
77 . K, IX, LFT, LLT, II, NN, J, IOFF,
78 . JD(50), KD(50), NG, IDEL, ITYP, NBEL,
79 . ITY, MLW, NEL, NFT, KAD, NPT, ISTRA, IHBE,
80 . REQ_S2(NSPMD),REQ_S3(NSPMD),STATUS(MPI_STATUS_SIZE),
81 . REQ_R1(NSPMD)
82 INTEGER, DIMENSION(:), ALLOCATABLE :: BUFR, BUFS2
83 INTEGER :: SIZ
84 DATA msgoff2/188/
85 DATA msgoff3/189/
86C-----------------------------------------------
87 ALLOCATE(bufr(irsize))
88 loc_proc = ispmd+1
89
90 ideb = 1
91 ioff = 0
92 len = 0
93 req_r1(1:nspmd) = mpi_request_null
94 DO i = 1, nspmd
95 IF(irecv(i)>0) THEN
96 msgtyp = msgoff2
97 CALL mpi_irecv(
98 . bufr(ideb),irecv(i),mpi_integer,it_spmd(i),msgtyp,
99 . spmd_comm_world,req_r1(i),ierror)
100 len = len+irecv(i)
101 ideb = len + 1
102 ENDIF
103 ENDDO
104
105C Proc sends the same BUFS to everybody
106 DO i = 1, nspmd
107 siz = (iad_elem(1,i+1)-iad_elem(1,i))
108 IF(i.NE.loc_proc.AND.lbufs.GT.0.AND.siz>0) THEN
109 msgtyp = msgoff2
110 CALL mpi_isend(
111 c bufs,lbufs,mpi_integer,it_spmd(i),msgtyp,
112 g spmd_comm_world,req_s2(i),ierror)
113 ENDIF
114 ENDDO
115 ideb = 1
116 ioff = 0
117 len = 0
118C Proc receive only if IRECV(I) > 0
119 DO i = 1, nspmd
120 IF(irecv(i)>0) THEN
121 msgtyp = msgoff2
122 CALL mpi_wait(req_r1(i),status,ierror)
123c CALL MPI_RECV(
124c . BUFR(IDEB),IRECV(I),MPI_INTEGER,IT_SPMD(I),MSGTYP,
125c . SPMD_COMM_WORLD,STATUS,IERROR)
126 len = len+irecv(i)
127 irecv(i)=0
128 DO WHILE (ideb<=len)
129 idel = bufr(ideb)
130 ityp = bufr(ideb+1)
131 nbel = bufr(ideb+2)+bufr(ideb+3)
132 ideb = ideb+4
133C
134 IF(((ityp==7.OR.ityp==10.OR.ityp==3.OR.ityp==5.OR.
135 + ityp==20.OR.ityp==22.OR.ityp==23.OR.ityp==24.OR.
136 + ityp==25.OR.ityp==2 ).AND.idel==2) )THEN
137 DO nn = 1, nbel
138 n1 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+1))
139 bufr(nn+ioff) = 0
140 IF(n1/=0) THEN
141 n2 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+2))
142 IF(n2/=0) THEN
143 n3 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+3))
144 IF(n3/=0) THEN
145 n4 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+4))
146 IF(n4/=0) THEN
147 DO j=addcnel(n1),addcnel(n1+1)-1
148 ii = cnel(j)
149 IF(tagel(ii)<0) THEN ! elt detruit trouve
150 itagl(n1) = 0
151 itagl(n2) = 0
152 itagl(n3) = 0
153 itagl(n4) = 0
154 IF(ii<=ofc) THEN ! solide detruit
155 DO k = 2, 9
156 ix = ixs(k,ii)
157 itagl(ix) = 1
158 END DO
159 ELSEIF(ii>ofc.AND.ii<=oft) THEN ! shell detruit
160 ii = ii - ofc
161 DO k=2,5
162 ix = ixc(k,ii)
163 itagl(ix)=1
164 END DO
165 ELSEIF(ii>oftg.AND.ii<=ofur)THEN
166 ii = ii - oftg
167 DO k=2,4
168 ix = ixtg(k,ii)
169 itagl(ix) = 1
170 END DO
171 END IF
172 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4)==4)THEN
173 bufr(nn+ioff) = 1
174 GOTO 400
175 END IF
176 END IF
177 END DO
178 400 CONTINUE
179 ENDIF
180 ENDIF
181 ENDIF
182 ENDIF
183 ENDDO
184 ideb = ideb + 4*nbel
185 ELSEIF(((ityp==7.OR.ityp==10.OR.ityp==3.OR.ityp==5
186 + .OR.ityp==20.OR.ityp==22.OR.ityp==23.OR.ityp==24
187 + .OR.ityp==25.OR.ityp==2) .AND. idel == 1))THEN
188 DO nn = 1, nbel
189 n1 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+1))
190 bufr(nn+ioff) = 0
191 IF(n1/=0) THEN
192 n2 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+2))
193 IF(n2/=0) THEN
194 n3 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+3))
195 IF(n3/=0) THEN
196 n4 = get_local_node_id(nodes, bufr(ideb-1+4*(nn-1)+4))
197 IF(n4/=0) THEN
198 DO j=addcnel(n1),addcnel(n1+1)-1
199 ii = cnel(j)
200 IF(tagel(ii)>0) THEN ! elt actif trouve
201 itagl(n1) = 0
202 itagl(n2) = 0
203 itagl(n3) = 0
204 itagl(n4) = 0
205 IF(ii<=ofc) THEN ! solide actif
206 DO k = 2, 9
207 ix = ixs(k,ii)
208 itagl(ix) = 1
209 END DO
210 ELSEIF(ii>ofc.AND.ii<=oft) THEN ! shell actif
211 ii = ii - ofc
212 DO k=2,5
213 ix = ixc(k,ii)
214 itagl(ix)=1
215 END DO
216 ELSEIF(ii>oftg.AND.ii<=ofur)THEN ! triangle actif
217 ii = ii - oftg
218 DO k=2,4
219 ix = ixtg(k,ii)
220 itagl(ix) = 1
221 END DO
222 END IF
223 IF(itagl(n1)+itagl(n2)+itagl(n3)+itagl(n4)==4)THEN
224 bufr(nn+ioff) = 1
225 GOTO 410
226 ENDIF
227 END IF
228 ENDDO
229 410 CONTINUE
230 ENDIF
231 ENDIF
232 ENDIF
233 ENDIF
234 END DO
235 ideb = ideb + 4*nbel
236 ELSEIF((ityp==11.OR.ityp==-20).AND.idel==2)THEN ! -20 => type20 edge
237 DO nn = 1, nbel
238 n1 = get_local_node_id(nodes, bufr(ideb-1+2*(nn-1)+1))
239 bufr(nn+ioff) = 0
240 IF(n1/=0) THEN
241 n2 = get_local_node_id(nodes, bufr(ideb-1+2*(nn-1)+2))
242 IF(n2/=0) THEN
243 DO j=addcnel(n1),addcnel(n1+1)-1
244 ii = cnel(j)
245 IF(tagel(ii)<0) THEN ! elt detruit trouve
246 itagl(n1) = 0
247 itagl(n2) = 0
248 IF(ii<=ofc) THEN ! solide detruit
249 DO k = 2, 9
250 ix = ixs(k,ii)
251 itagl(ix) = 1
252 END DO
253 ELSEIF(ii>ofc.AND.ii<=oft) THEN ! shell detruit
254 ii = ii - ofc
255 DO k=2,5
256 ix = ixc(k,ii)
257 itagl(ix)=1
258 END DO
259 ELSEIF(ii>oftg.AND.ii<=ofur)THEN
260 ii = ii - oftg
261 DO k=2,4
262 ix = ixtg(k,ii)
263 itagl(ix) = 1
264 END DO
265 ELSEIF(ii>oft.AND.ii<=ofp)THEN
266 ii = ii - oft
267 DO k=2,3
268 ix = ixt(k,ii)
269 itagl(ix) = 1
270 ENDDO
271 ELSEIF(ii>ofp.AND.ii<=ofr)THEN
272 ii = ii - ofp
273 DO k=2,3
274 ix = ixp(k,ii)
275 itagl(ix) = 1
276 ENDDO
277 ELSEIF(ii>ofr.AND.ii<=oftg)THEN
278 ii = ii - ofr
279 DO k=2,3
280 ix = ixr(k,ii)
281 itagl(ix) = 1
282 ENDDO
283 IF(nint(geo(12,ixr(1,ii)))==12) THEN
284 ix = ixr(4,ii)
285 itagl(ix) = 1
286 ENDIF
287 END IF
288 IF(itagl(n1)+itagl(n2)==2)THEN
289 bufr(nn+ioff) = 1
290 GO TO 420
291 END IF
292 END IF
293 END DO
294C
295 420 CONTINUE
296 END IF
297 END IF
298 END DO
299 ideb = ideb + 2*nbel
300 ELSEIF((ityp==11.OR.ityp==-20).AND.idel==1)THEN ! -20 => type20 edge
301 DO nn = 1, nbel
302 n1 = get_local_node_id(nodes, bufr(ideb-1+2*(nn-1)+1))
303 bufr(nn+ioff) = 0
304 IF(n1/=0) THEN
305 n2 = get_local_node_id(nodes, bufr(ideb-1+2*(nn-1)+2))
306 IF(n2/=0) THEN
307 DO j=addcnel(n1),addcnel(n1+1)-1
308 ii = cnel(j)
309 IF(tagel(ii)>0) THEN ! elt actif trouve
310 itagl(n1) = 0
311 itagl(n2) = 0
312 IF(ii<=ofc) THEN ! solide actif
313 DO k = 2, 9
314 ix = ixs(k,ii)
315 itagl(ix) = 1
316 END DO
317 ELSEIF(ii>ofc.AND.ii<=oft) THEN ! shell actif
318 ii = ii - ofc
319 DO k=2,5
320 ix = ixc(k,ii)
321 itagl(ix)=1
322 END DO
323 ELSEIF(ii>oftg.AND.ii<=ofur)THEN ! triangle actif
324 ii = ii - oftg
325 DO k=2,4
326 ix = ixtg(k,ii)
327 itagl(ix) = 1
328 END DO
329 ELSEIF(ii>oft.AND.ii<=ofp)THEN ! truss actif
330 ii = ii - oft
331 DO k=2,3
332 ix = ixt(k,ii)
333 itagl(ix) = 1
334 ENDDO
335 ELSEIF(ii>ofp.AND.ii<=ofr)THEN ! poutre actif
336 ii = ii - ofp
337 DO k=2,3
338 ix = ixp(k,ii)
339 itagl(ix) = 1
340 ENDDO
341 ELSEIF(ii>ofr.AND.ii<=oftg)THEN ! ressort actif
342 ii = ii - ofr
343 DO k=2,3
344 ix = ixr(k,ii)
345 itagl(ix) = 1
346 ENDDO
347 IF(nint(geo(12,ixr(1,ii)))==12) THEN ! ressort actif
348 ix = ixr(4,ii)
349 itagl(ix) = 1
350 ENDIF
351 END IF
352 IF(itagl(n1)+itagl(n2)==2)THEN
353 bufr(nn+ioff) = 1
354 GOTO 430
355 ENDIF
356 ENDIF
357 ENDDO
358C
359 430 CONTINUE
360 ENDIF
361 ENDIF
362 END DO
363 ideb = ideb + 2*nbel
364 ELSE ! autre idel ou interf a reecrire
365 END IF
366 ioff = ioff + nbel
367 irecv(i)=irecv(i)+nbel
368 END DO
369 ENDIF
370 ENDDO
371C
372C Envoi BUFR
373C
374 ideb = 1
375 DO i = 1, nspmd
376 IF(irecv(i)>0) THEN
377 len = irecv(i)
378 msgtyp = msgoff3
379 CALL mpi_isend(
380 c bufr(ideb),len,mpi_integer,it_spmd(i),msgtyp,
381 g spmd_comm_world,req_s3(i),ierror)
382 ideb = ideb + len
383 ENDIF
384 ENDDO
385C
386C Test reception envoi BUFS
387C
388 DO i = 1, nspmd
389 siz = (iad_elem(1,i+1)-iad_elem(1,i))
390 IF(i.NE.loc_proc.AND.lbufs.GT.0.AND.siz>0) THEN
391 CALL mpi_wait(req_s2(i),status,ierror)
392 ENDIF
393 ENDDO
394C
395C Reception BUFR dans BUFS2
396C
397 ALLOCATE(bufs2(lindex))
398 IF(lindex>0) THEN
399 DO i = 1, lindex
400 bufs(i) = 0
401 ENDDO
402 DO i = 1, nspmd
403 siz = (iad_elem(1,i+1)-iad_elem(1,i))
404 IF(i.NE.loc_proc.AND.lindex.GT.0.AND.siz>0) THEN
405 msgtyp = msgoff3
406 CALL mpi_recv(
407 . bufs2,lindex,mpi_integer,it_spmd(i),msgtyp,
408 . spmd_comm_world,status,ierror)
409 DO j = 1, lindex
410 bufs(j) = max(bufs(j),bufs2(j))
411 ENDDO
412 ENDIF
413 ENDDO
414 ENDIF
415 DEALLOCATE(bufs2)
416
417C
418C Test reception envoi BUFR
419C
420 DO i = 1, nspmd
421 IF(irecv(i)>0) THEN
422 CALL mpi_wait(req_s3(i),status,ierror)
423 ENDIF
424 ENDDO
425C
426 DEALLOCATE(bufr)
427#endif
428 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
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