OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_i18kine_pene_com_poff.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "task_c.inc"
#include "com01_c.inc"
#include "com06_c.inc"
#include "com08_c.inc"
#include "scr07_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "impl1_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_i18kine_pene_com_poff (output, ipari, intbuf_tab, fcont, mtf, a, iad_elem, fr_elem, mode, slvndtag, tagpene, itab, h3d_data)

Function/Subroutine Documentation

◆ spmd_i18kine_pene_com_poff()

subroutine spmd_i18kine_pene_com_poff ( type(output_), intent(inout) output,
integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
fcont,
mtf,
a,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer mode,
integer, dimension(*) slvndtag,
integer, dimension(*) tagpene,
integer, dimension(*) itab,
type(h3d_database) h3d_data )

Definition at line 40 of file spmd_i18kine_pene_com_poff.F.

43C-----------------------------------------------
44C M o d u l e s
45C-----------------------------------------------
46 USE tri7box
47 USE message_mod
48 USE intbufdef_mod
49 USE h3d_mod
50 USE output_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"
56C-----------------------------------------------
57C M e s s a g e P a s s i n g
58C-----------------------------------------------
59#include "spmd.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "param_c.inc"
64#include "com04_c.inc"
65#include "task_c.inc"
66#include "com01_c.inc"
67#include "com06_c.inc"
68#include "com08_c.inc"
69#include "scr07_c.inc"
70#include "scr14_c.inc"
71#include "scr16_c.inc"
72#include "impl1_c.inc"
73C-----------------------------------------------
74C D u m m y A r g u m e n t s
75C-----------------------------------------------
76 TYPE(OUTPUT_), intent(inout) :: OUTPUT
77 INTEGER IPARI(NPARI,*),IAD_ELEM(2,*),FR_ELEM(*),
78 * SLVNDTAG(*),TAGPENE(*),ITAB(*),MODE
79C
80 my_real
81 . mtf(14,*),a(3,*),fcont(3,*)
82
83 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
84 TYPE(H3D_DATABASE) :: H3D_DATA
85C-----------------------------------------------
86C L o c a l V a r i a b l e s
87C-----------------------------------------------
88#ifdef MPI
89 INTEGER STATUS(MPI_STATUS_SIZE),
90 * REQ_SI(NSPMD),REQ_RI(NSPMD)
91 INTEGER P,LENSD,LENRV,IADS(NSPMD+1),IADR(NSPMD+1),IERROR,
92 * SIZ,LOC_PROC,MSGTYP,IDEB(NINTER), MSGOFF, MSGOFF2
93 INTEGER NIN,NTY,INACTI
94 INTEGER J,L,NB,NN,K,NOD,LEN,ALEN,ND,FLG
95 my_real ,
96 * DIMENSION(:), ALLOCATABLE :: bbufs, bbufr
97 DATA msgoff/148/
98 DATA msgoff2/149/
99C-----------------------------------------------
100C On the 18KINE type, there are 3 comms that are based
101C on the same schema with
102C different data
103C MODE =
104C 1 : PENE + PENEMIN
105C 2: Second node velocities
106C 3 : Accelerations noeuds seconds
107
108 loc_proc = ispmd+1
109 iads = 0
110 iadr = 0
111 lensd = 0
112 lenrv = 0
113
114 IF(mode==1)THEN
115 alen=5
116 ELSEIF(mode==2)THEN
117 alen=3
118 ELSEIF(mode==3)THEN
119 alen=7
120 ENDIF
121C Counting buffer sizes Reception and sending
122 DO p=1,nspmd
123 iadr(p)=lenrv+1
124 DO nin=1,ninter
125 nty=ipari(7,nin)
126 inacti =ipari(22,nin)
127 IF((nty==7.and.ipari(34,nin)==-2.and.inacti==7).OR.
128 . (nty==22.and.ipari(34,nin)==-2.and.inacti==7))THEN
129 lensd = lensd + nsnfi(nin)%P(p)*alen
130 lenrv = lenrv + nsnsi(nin)%P(p)*alen
131 ENDIF
132 ENDDO
133 ENDDO
134 iadr(nspmd+1)=lenrv+1
135
136 IF(lensd>0)THEN
137 ALLOCATE(bbufs(lensd),stat=ierror)
138 IF(ierror/=0) THEN
139 CALL ancmsg(msgid=20,anmode=aninfo)
140 CALL arret(2)
141 ENDIF
142 ENDIF
143
144C Preparation of the receive
145 IF(lenrv>0)THEN
146 ALLOCATE(bbufr(lenrv),stat=ierror)
147 IF(ierror/=0) THEN
148 CALL ancmsg(msgid=20,anmode=aninfo)
149 CALL arret(2)
150 ENDIF
151 ENDIF
152C Send
153 l=1
154 ideb=0
155 DO p=1, nspmd
156 iads(p)=l
157 IF (p/= loc_proc) THEN
158 DO nin=1,ninter
159 nty =ipari(7,nin)
160 inacti =ipari(22,nin)
161 IF((nty==7.and.ipari(34,nin)==-2.and.inacti==7).OR.
162 . (nty==22.and.ipari(34,nin)==-2.and.inacti==7)) THEN
163C Preparation of the send
164 nb = nsnfi(nin)%P(p)
165 IF (mode==1)THEN
166 DO nn=1,nb
167 bbufs(l)= mtfi_pene(nin)%P(nn+ideb(nin))
168 bbufs(l+1)=mtfi_penemin(nin)%P(nn+ideb(nin))
169 bbufs(l+2)=mtfi_n(nin)%P(1,nn+ideb(nin))
170 bbufs(l+3)=mtfi_n(nin)%P(2,nn+ideb(nin))
171 bbufs(l+4)=mtfi_n(nin)%P(3,nn+ideb(nin))
172 l=l+5
173 ENDDO
174 ideb(nin)=ideb(nin)+nb
175
176 ELSEIF (mode==2)THEN
177 DO nn=1,nb
178 bbufs(l )=mtfi_v(nin)%P(1,nn+ideb(nin))
179 bbufs(l+1)=mtfi_v(nin)%P(2,nn+ideb(nin))
180 bbufs(l+2)=mtfi_v(nin)%P(3,nn+ideb(nin))
181c BBUFS(L+3)=MTFI_V(NIN)%P(4,NN+IDEB(NIN))
182c BBUFS(L+4)=MTFI_V(NIN)%P(5,NN+IDEB(NIN))
183c BBUFS(L+5)=MTFI_V(NIN)%P(6,NN+IDEB(NIN))
184 l=l+3
185 ENDDO
186 ideb(nin)=ideb(nin)+nb
187 ELSEIF (mode==3)THEN
188 DO nn=1,nb
189 bbufs(l )=mtfi_a(nin)%P(1,nn+ideb(nin))
190 bbufs(l+1)=mtfi_a(nin)%P(2,nn+ideb(nin))
191 bbufs(l+2)=mtfi_a(nin)%P(3,nn+ideb(nin))
192 bbufs(l+3)=mtfi_a(nin)%P(4,nn+ideb(nin))
193 bbufs(l+4)=mtfi_a(nin)%P(5,nn+ideb(nin))
194 bbufs(l+5)=mtfi_a(nin)%P(6,nn+ideb(nin))
195 bbufs(l+6)=mtfi_a(nin)%P(7,nn+ideb(nin))
196 l=l+7
197 ENDDO
198 ideb(nin)=ideb(nin)+nb
199 ENDIF
200 ENDIF
201 ENDDO
202 siz = l-iads(p)
203 IF(siz>0)THEN
204 msgtyp = msgoff
205C Send
206 CALL mpi_isend(
207 . bbufs(iads(p)),siz,real ,it_spmd(p),msgtyp,
208 . spmd_comm_world,req_si(p),ierror )
209 ENDIF
210 ENDIF
211 ENDDO
212C Recieve
213 l=0
214 ideb = 0
215 DO p=1, nspmd
216 l=0
217 siz=iadr(p+1)-iadr(p)
218 IF (siz > 0) THEN
219 msgtyp = msgoff
220
221C Send
222 CALL mpi_recv( bbufr(iadr(p)),siz,real,it_spmd(p),msgtyp,
223 * spmd_comm_world,status,ierror )
224 DO nin=1,ninter
225 nty =ipari(7,nin)
226 inacti =ipari(22,nin)
227
228 IF((nty==7.and.ipari(34,nin)==-2.and.inacti==7).OR.
229 . (nty==22.and.ipari(34,nin)==-2.and.inacti==7))THEN
230 nb = nsnsi(nin)%P(p)
231 IF (nb > 0)THEN
232C
233 IF(nty==7.OR.nty==10.OR.nty==22)THEN
234 IF(mode==1)THEN
235 DO k=1,nb
236 nd = nsvsi(nin)%P(ideb(nin)+k)
237 nod=intbuf_tab(nin)%NSV(nd)
238 mtf(10,nod) = mtf(10,nod)+ bbufr(iadr(p)+l)
239 IF(bbufr(iadr(p)+l+1) > mtf(11,nod))THEN
240 mtf(11,nod) = bbufr(iadr(p)+l+1)
241 tagpene(nod) = p
242 ENDIF
243c MTF(11,NOD) = MAX(MTF(11,NOD),BBUFR(IADR(P)+L+1))
244 mtf(12,nod) = mtf(12,nod)+bbufr(iadr(p)+l+2)
245 mtf(13,nod) = mtf(13,nod)+bbufr(iadr(p)+l+3)
246 mtf(14,nod) = mtf(14,nod)+bbufr(iadr(p)+l+4)
247 l=l+5
248 ENDDO
249 ELSEIF(mode==2)THEN
250 DO k=1,nb
251 nd = nsvsi(nin)%P(ideb(nin)+k)
252 nod=intbuf_tab(nin)%NSV(nd)
253c IF(BBUFR(IADR(P)+L) /= 0)THEN
254 mtf(1,nod) = mtf(1,nod)+bbufr(iadr(p)+l)
255 mtf(2,nod) = mtf(2,nod)+bbufr(iadr(p)+l+1)
256 mtf(3,nod) = mtf(3,nod)+bbufr(iadr(p)+l+2)
257c MTF(4,NOD) = BBUFR(IADR(P)+L+3)
258c MTF(5,NOD) = BBUFR(IADR(P)+L+4)
259c MTF(6,NOD) = BBUFR(IADR(P)+L+5)
260c ENDIF
261 l=l+3
262 ENDDO
263 ELSEIF(mode==3)THEN
264 DO k=1,nb
265 nd = nsvsi(nin)%P(ideb(nin)+k)
266 nod=intbuf_tab(nin)%NSV(nd)
267 IF(bbufr(iadr(p)+l+6) /= 0)THEN
268 a(1,nod) = bbufr(iadr(p)+l)
269 a(2,nod) = bbufr(iadr(p)+l+1)
270 a(3,nod) = bbufr(iadr(p)+l+2)
271 IF(anim_v(4)+outp_v(4)+h3d_data%N_VECT_CONT>0.AND.
272 . ((tt>=output%TANIM .AND. tt<=output%TANIM_STOP).OR.tt>=toutp.OR.
273 . (tt>=h3d_data%TH3D.AND.tt<=h3d_data%TH3D_STOP).OR.
274 . (manim>=4.AND.manim<=15)))THEN
275 IF(inconv == 1) THEN
276 fcont(1,nod) = fcont(1,nod)+bbufr(iadr(p)+l+3)
277 fcont(2,nod) = fcont(2,nod)+bbufr(iadr(p)+l+4)
278 fcont(3,nod) = fcont(3,nod)+bbufr(iadr(p)+l+5)
279 ENDIF
280 ENDIF
281 slvndtag(nod)=1
282 ENDIF
283 l=l+7
284 ENDDO
285 ENDIF
286 ENDIF
287 ENDIF
288 ENDIF
289 ideb(nin)=ideb(nin)+nb
290 ENDDO
291 ENDIF
292 l=l+siz
293 ENDDO
294
295C End of the send
296 DO p = 1, nspmd
297 IF (p==nspmd)THEN
298 siz=lensd-iads(p)
299 ELSE
300 siz=iads(p+1)-iads(p)
301 ENDIF
302 IF(siz>0) THEN
303 CALL mpi_wait(req_si(p),status,ierror)
304 ENDIF
305 ENDDO
306
307 IF (ALLOCATED(bbufs)) DEALLOCATE(bbufs)
308 IF (ALLOCATED(bbufr)) DEALLOCATE(bbufr)
309
310C--------------------------------------------------
311C 2nd part - exchanges on the boundary nodes
312C--------------------------------------------------
313 IF(mode==1)THEN
314 len=5
315 ELSEIF(mode==2)THEN
316 len=6
317 ELSEIF(mode==3)THEN
318 len=4
319 ELSE
320 len=0
321 ENDIF
322 lenrv = (iad_elem(1,nspmd+1)-iad_elem(1,1))*len
323
324 ALLOCATE(bbufs(lenrv))
325 ALLOCATE(bbufr(lenrv))
326
327 iadr(1) = 1
328 l=1
329 DO p=1,nspmd
330 siz = (iad_elem(1,p+1)-iad_elem(1,p))*len
331 IF(siz/=0)THEN
332 msgtyp = msgoff2
333 CALL mpi_irecv(
334 s bbufr(l),siz,real,it_spmd(p),msgtyp,
335 g spmd_comm_world,req_ri(p),ierror)
336 l = l + siz
337 ENDIF
338 iadr(p+1) = l
339 END DO
340
341
342C Fill the Buffer
343 l=1
344 DO p=1,nspmd
345 iads(p)=l
346 DO j=iad_elem(1,p),iad_elem(1,p+1)-1
347 nod = fr_elem(j)
348 IF(mode==1)THEN
349 bbufs(l)=mtf(10,nod)
350 bbufs(l+1)=mtf(11,nod)
351 bbufs(l+2)=mtf(12,nod)
352 bbufs(l+3)=mtf(13,nod)
353 bbufs(l+4)=mtf(14,nod)
354 l=l+5
355 ELSEIF(mode==2)THEN
356 bbufs(l) =mtf(1,nod)
357 bbufs(l+1)=mtf(2,nod)
358 bbufs(l+2)=mtf(3,nod)
359C MTF(4-6) are not initialized cumulative values in the parts
360c where they are needed. No need to communicate them
361c BBUFS(L+3)=MTF(4,NOD)
362c BBUFS(L+4)=MTF(5,NOD)
363c BBUFS(L+5)=MTF(6,NOD)
364 l=l+3
365 ELSEIF(mode==3)THEN
366 bbufs(l)=a(1,nod)
367 bbufs(l+1)=a(2,nod)
368 bbufs(l+2)=a(3,nod)
369 bbufs(l+3)=slvndtag(nod)
370 l=l+4
371 ENDIF
372 ENDDO
373 ENDDO
374 iads(nspmd+1)=l
375C
376C--------------------------------------------------------------------
377C echange messages
378C
379
380 DO p=1,nspmd
381 IF(iad_elem(1,p+1)-iad_elem(1,p)>0)THEN
382 msgtyp = msgoff2
383 siz = iads(1+p)-iads(p)
384 l = iads(p)
385 CALL mpi_isend(
386 s bbufs(l),siz,real,it_spmd(p),msgtyp,
387 g spmd_comm_world,req_si(p),ierror)
388 ENDIF
389 ENDDO
390C--------------------------------------------------------------------
391C Reception
392 DO p = 1, nspmd
393 nb = iad_elem(1,p+1)-iad_elem(1,p)
394 IF(nb>0)THEN
395 CALL mpi_wait(req_ri(p),status,ierror)
396 l = iadr(p)
397 DO j=iad_elem(1,p),iad_elem(1,p+1)-1
398 nod = fr_elem(j)
399 IF(mode==1)THEN
400 mtf(10,nod) = mtf(10,nod)+bbufr(l)
401 IF(bbufr(l+1) > abs(mtf(11,nod)))THEN
402 mtf(11,nod) = bbufr(l+1)
403 tagpene(nod) = p
404 ELSEIF(bbufr(l+1) == abs(mtf(11,nod)) .and.
405 . ispmd+1 > p)THEN
406 ELSE
407 mtf(11,nod) = abs(bbufr(l+1)*(1-em6))
408 ENDIF
409 mtf(12,nod) = mtf(12,nod)+bbufr(l+2)
410 mtf(13,nod) = mtf(13,nod)+bbufr(l+3)
411 mtf(14,nod) = mtf(14,nod)+bbufr(l+4)
412 l=l+5
413 ELSEIF(mode==2)THEN
414 mtf(1,nod)=mtf(1,nod)+bbufr(l)
415 mtf(2,nod)=mtf(2,nod)+bbufr(l+1)
416 mtf(3,nod)=mtf(3,nod)+bbufr(l+2)
417C MTF(4-6) are not initialized cumulative values in the parts
418c where they are needed. No need to communicate them
419c MTF(4,NOD)=BBUFR(L+3)
420c MTF(5,NOD)=BBUFR(L+4)
421c MTF(6,NOD)=BBUFR(L+5)
422 l=l+3
423 ELSEIF(mode==3)THEN
424 flg=nint(bbufr(l+3))
425 IF(flg==1)THEN
426 a(1,nod)=bbufr(l)
427 a(2,nod)=bbufr(l+1)
428 a(3,nod)=bbufr(l+2)
429 ENDIF
430 l=l+4
431 ENDIF
432 ENDDO
433 ENDIF
434 ENDDO
435
436C End of the send
437 DO p = 1, nspmd
438 siz=iads(p+1)-iads(p)
439 IF(siz>0) THEN
440 CALL mpi_wait(req_si(p),status,ierror)
441 ENDIF
442 ENDDO
443
444#endif
445 RETURN
446C-----------------------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
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
h3d_mod
Definition h3d_mod.F:311
message_mod
Definition message_mod.F:1257
tri7box::nsvsi
type(int_pointer), dimension(:), allocatable nsvsi
Definition tri7box.F:485
tri7box::mtfi_a
type(real_pointer2), dimension(:), allocatable mtfi_a
Definition tri7box.F:459
tri7box::mtfi_pene
type(real_pointer), dimension(:), allocatable mtfi_pene
Definition tri7box.F:449
tri7box::nsnsi
type(int_pointer), dimension(:), allocatable nsnsi
Definition tri7box.F:491
tri7box::mtfi_n
type(real_pointer2), dimension(:), allocatable mtfi_n
Definition tri7box.F:459
tri7box::mtfi_penemin
type(real_pointer), dimension(:), allocatable mtfi_penemin
Definition tri7box.F:449
tri7box::mtfi_v
type(real_pointer2), dimension(:), allocatable mtfi_v
Definition tri7box.F:459
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
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:895
arret
subroutine arret(nn)
Definition arret.F:86