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 (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 ( 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 anim_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 INTEGER IPARI(NPARI,*),IAD_ELEM(2,*),FR_ELEM(*),
77 * SLVNDTAG(*),TAGPENE(*),ITAB(*),MODE
78C
79 my_real
80 . mtf(14,*),a(3,*),fcont(3,*)
81
82 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
83 TYPE(H3D_DATABASE) :: H3D_DATA
84C-----------------------------------------------
85C L o c a l V a r i a b l e s
86C-----------------------------------------------
87#ifdef MPI
88 INTEGER STATUS(MPI_STATUS_SIZE),
89 * REQ_SI(NSPMD),REQ_RI(NSPMD)
90 INTEGER P,LENSD,LENRV,IADS(NSPMD+1),IADR(NSPMD+1),IERROR,
91 * SIZ,LOC_PROC,MSGTYP,IDEB(NINTER), MSGOFF, MSGOFF2
92 INTEGER NIN,NTY,INACTI
93 INTEGER J,L,NB,NN,K,N,NOD,LEN,ALEN,ND,FLG
94 my_real ,
95 * DIMENSION(:), ALLOCATABLE :: bbufs, bbufr
96 DATA msgoff/148/
97 DATA msgoff2/149/
98C-----------------------------------------------
99C Sur la type 18KINE, il y a 3 comm qui sont bases
100C sur le meme schemas avec des
101C donn es differentes
102C MODE =
103C 1 : PENE + PENEMIN
104C 2 : Vitesses noeuds seconds
105C 3 : Accelerations noeuds seconds
106
107 loc_proc = ispmd+1
108 iads = 0
109 iadr = 0
110 lensd = 0
111 lenrv = 0
112
113 IF(mode==1)THEN
114 alen=5
115 ELSEIF(mode==2)THEN
116 alen=3
117 ELSEIF(mode==3)THEN
118 alen=7
119 ENDIF
120C Comptage des tailles de buffer Receeption et envoi
121 DO p=1,nspmd
122 iadr(p)=lenrv+1
123 DO nin=1,ninter
124 nty=ipari(7,nin)
125 inacti =ipari(22,nin)
126 IF((nty==7.and.ipari(34,nin)==-2.and.inacti==7).OR.
127 . (nty==22.and.ipari(34,nin)==-2.and.inacti==7))THEN
128 lensd = lensd + nsnfi(nin)%P(p)*alen
129 lenrv = lenrv + nsnsi(nin)%P(p)*alen
130 ENDIF
131 ENDDO
132 ENDDO
133 iadr(nspmd+1)=lenrv+1
134
135 IF(lensd>0)THEN
136 ALLOCATE(bbufs(lensd),stat=ierror)
137 IF(ierror/=0) THEN
138 CALL ancmsg(msgid=20,anmode=aninfo)
139 CALL arret(2)
140 ENDIF
141 ENDIF
142
143C Preparation du recieve
144 IF(lenrv>0)THEN
145 ALLOCATE(bbufr(lenrv),stat=ierror)
146 IF(ierror/=0) THEN
147 CALL ancmsg(msgid=20,anmode=aninfo)
148 CALL arret(2)
149 ENDIF
150 ENDIF
151C Send
152 l=1
153 ideb=0
154 DO p=1, nspmd
155 iads(p)=l
156 IF (p/= loc_proc) THEN
157 DO nin=1,ninter
158 nty =ipari(7,nin)
159 inacti =ipari(22,nin)
160 IF((nty==7.and.ipari(34,nin)==-2.and.inacti==7).OR.
161 . (nty==22.and.ipari(34,nin)==-2.and.inacti==7)) THEN
162C Preparation du send
163 nb = nsnfi(nin)%P(p)
164 IF (mode==1)THEN
165 DO nn=1,nb
166 bbufs(l)= mtfi_pene(nin)%P(nn+ideb(nin))
167 bbufs(l+1)=mtfi_penemin(nin)%P(nn+ideb(nin))
168 bbufs(l+2)=mtfi_n(nin)%P(1,nn+ideb(nin))
169 bbufs(l+3)=mtfi_n(nin)%P(2,nn+ideb(nin))
170 bbufs(l+4)=mtfi_n(nin)%P(3,nn+ideb(nin))
171 l=l+5
172 ENDDO
173 ideb(nin)=ideb(nin)+nb
174
175 ELSEIF (mode==2)THEN
176 DO nn=1,nb
177 bbufs(l )=mtfi_v(nin)%P(1,nn+ideb(nin))
178 bbufs(l+1)=mtfi_v(nin)%P(2,nn+ideb(nin))
179 bbufs(l+2)=mtfi_v(nin)%P(3,nn+ideb(nin))
180c BBUFS(L+3)=MTFI_V(NIN)%P(4,NN+IDEB(NIN))
181c BBUFS(L+4)=MTFI_V(NIN)%P(5,NN+IDEB(NIN))
182c BBUFS(L+5)=MTFI_V(NIN)%P(6,NN+IDEB(NIN))
183 l=l+3
184 ENDDO
185 ideb(nin)=ideb(nin)+nb
186 ELSEIF (mode==3)THEN
187 DO nn=1,nb
188 bbufs(l )=mtfi_a(nin)%P(1,nn+ideb(nin))
189 bbufs(l+1)=mtfi_a(nin)%P(2,nn+ideb(nin))
190 bbufs(l+2)=mtfi_a(nin)%P(3,nn+ideb(nin))
191 bbufs(l+3)=mtfi_a(nin)%P(4,nn+ideb(nin))
192 bbufs(l+4)=mtfi_a(nin)%P(5,nn+ideb(nin))
193 bbufs(l+5)=mtfi_a(nin)%P(6,nn+ideb(nin))
194 bbufs(l+6)=mtfi_a(nin)%P(7,nn+ideb(nin))
195 l=l+7
196 ENDDO
197 ideb(nin)=ideb(nin)+nb
198 ENDIF
199 ENDIF
200 ENDDO
201 siz = l-iads(p)
202 IF(siz>0)THEN
203 msgtyp = msgoff
204C Send
205 CALL mpi_isend(
206 . bbufs(iads(p)),siz,real ,it_spmd(p),msgtyp,
207 . spmd_comm_world,req_si(p),ierror )
208 ENDIF
209 ENDIF
210 ENDDO
211C Recieve
212 l=0
213 ideb = 0
214 DO p=1, nspmd
215 l=0
216 siz=iadr(p+1)-iadr(p)
217 IF (siz > 0) THEN
218 msgtyp = msgoff
219
220C Send
221 CALL mpi_recv( bbufr(iadr(p)),siz,real,it_spmd(p),msgtyp,
222 * spmd_comm_world,status,ierror )
223 DO nin=1,ninter
224 nty =ipari(7,nin)
225 inacti =ipari(22,nin)
226
227 IF((nty==7.and.ipari(34,nin)==-2.and.inacti==7).OR.
228 . (nty==22.and.ipari(34,nin)==-2.and.inacti==7))THEN
229 nb = nsnsi(nin)%P(p)
230 IF (nb > 0)THEN
231C
232 IF(nty==7.OR.nty==10.OR.nty==22)THEN
233 IF(mode==1)THEN
234 DO k=1,nb
235 nd = nsvsi(nin)%P(ideb(nin)+k)
236 nod=intbuf_tab(nin)%NSV(nd)
237 mtf(10,nod) = mtf(10,nod)+ bbufr(iadr(p)+l)
238 IF(bbufr(iadr(p)+l+1) > mtf(11,nod))THEN
239 mtf(11,nod) = bbufr(iadr(p)+l+1)
240 tagpene(nod) = p
241 ENDIF
242c MTF(11,NOD) = MAX(MTF(11,NOD),BBUFR(IADR(P)+L+1))
243 mtf(12,nod) = mtf(12,nod)+bbufr(iadr(p)+l+2)
244 mtf(13,nod) = mtf(13,nod)+bbufr(iadr(p)+l+3)
245 mtf(14,nod) = mtf(14,nod)+bbufr(iadr(p)+l+4)
246 l=l+5
247 ENDDO
248 ELSEIF(mode==2)THEN
249 DO k=1,nb
250 nd = nsvsi(nin)%P(ideb(nin)+k)
251 nod=intbuf_tab(nin)%NSV(nd)
252c IF(BBUFR(IADR(P)+L) /= 0)THEN
253 mtf(1,nod) = mtf(1,nod)+bbufr(iadr(p)+l)
254 mtf(2,nod) = mtf(2,nod)+bbufr(iadr(p)+l+1)
255 mtf(3,nod) = mtf(3,nod)+bbufr(iadr(p)+l+2)
256c MTF(4,NOD) = BBUFR(IADR(P)+L+3)
257c MTF(5,NOD) = BBUFR(IADR(P)+L+4)
258c MTF(6,NOD) = BBUFR(IADR(P)+L+5)
259c ENDIF
260 l=l+3
261 ENDDO
262 ELSEIF(mode==3)THEN
263 DO k=1,nb
264 nd = nsvsi(nin)%P(ideb(nin)+k)
265 nod=intbuf_tab(nin)%NSV(nd)
266 IF(bbufr(iadr(p)+l+6) /= 0)THEN
267 a(1,nod) = bbufr(iadr(p)+l)
268 a(2,nod) = bbufr(iadr(p)+l+1)
269 a(3,nod) = bbufr(iadr(p)+l+2)
270 IF(anim_v(4)+outp_v(4)+h3d_data%N_VECT_CONT>0.AND.
271 . ((tt>=tanim .AND. tt<=tanim_stop).OR.tt>=toutp.OR.(tt>=h3d_data%TH3D.AND.tt<=h3d_data%TH3D_STOP).OR.
272 . (manim>=4.AND.manim<=15)))THEN
273 IF(inconv == 1) THEN
274 fcont(1,nod) = fcont(1,nod)+bbufr(iadr(p)+l+3)
275 fcont(2,nod) = fcont(2,nod)+bbufr(iadr(p)+l+4)
276 fcont(3,nod) = fcont(3,nod)+bbufr(iadr(p)+l+5)
277 ENDIF
278 ENDIF
279 slvndtag(nod)=1
280 ENDIF
281 l=l+7
282 ENDDO
283 ENDIF
284 ENDIF
285 ENDIF
286 ENDIF
287 ideb(nin)=ideb(nin)+nb
288 ENDDO
289 ENDIF
290 l=l+siz
291 ENDDO
292
293C Fin du send
294 DO p = 1, nspmd
295 IF (p==nspmd)THEN
296 siz=lensd-iads(p)
297 ELSE
298 siz=iads(p+1)-iads(p)
299 ENDIF
300 IF(siz>0) THEN
301 CALL mpi_wait(req_si(p),status,ierror)
302 ENDIF
303 ENDDO
304
305 IF (ALLOCATED(bbufs)) DEALLOCATE(bbufs)
306 IF (ALLOCATED(bbufr)) DEALLOCATE(bbufr)
307
308C--------------------------------------------------
309C 2eme partie - echanges sur les noeuds frontieres
310C--------------------------------------------------
311 IF(mode==1)THEN
312 len=5
313 ELSEIF(mode==2)THEN
314 len=6
315 ELSEIF(mode==3)THEN
316 len=4
317 ELSE
318 len=0
319 ENDIF
320 lenrv = (iad_elem(1,nspmd+1)-iad_elem(1,1))*len
321
322 ALLOCATE(bbufs(lenrv))
323 ALLOCATE(bbufr(lenrv))
324
325 iadr(1) = 1
326 l=1
327 DO p=1,nspmd
328 siz = (iad_elem(1,p+1)-iad_elem(1,p))*len
329 IF(siz/=0)THEN
330 msgtyp = msgoff2
331 CALL mpi_irecv(
332 s bbufr(l),siz,real,it_spmd(p),msgtyp,
333 g spmd_comm_world,req_ri(p),ierror)
334 l = l + siz
335 ENDIF
336 iadr(p+1) = l
337 END DO
338
339
340C Remplis le Buffer
341 l=1
342 DO p=1,nspmd
343 iads(p)=l
344 DO j=iad_elem(1,p),iad_elem(1,p+1)-1
345 nod = fr_elem(j)
346 IF(mode==1)THEN
347 bbufs(l)=mtf(10,nod)
348 bbufs(l+1)=mtf(11,nod)
349 bbufs(l+2)=mtf(12,nod)
350 bbufs(l+3)=mtf(13,nod)
351 bbufs(l+4)=mtf(14,nod)
352 l=l+5
353 ELSEIF(mode==2)THEN
354 bbufs(l) =mtf(1,nod)
355 bbufs(l+1)=mtf(2,nod)
356 bbufs(l+2)=mtf(3,nod)
357C MTF(4-6) ne sont pas des valeurs de cumuls initialises dans les parties
358c ou l on en a besoin. Inutile de les communiquer
359c BBUFS(L+3)=MTF(4,NOD)
360c BBUFS(L+4)=MTF(5,NOD)
361c BBUFS(L+5)=MTF(6,NOD)
362 l=l+3
363 ELSEIF(mode==3)THEN
364 bbufs(l)=a(1,nod)
365 bbufs(l+1)=a(2,nod)
366 bbufs(l+2)=a(3,nod)
367 bbufs(l+3)=slvndtag(nod)
368 l=l+4
369 ENDIF
370 ENDDO
371 ENDDO
372 iads(nspmd+1)=l
373C
374C--------------------------------------------------------------------
375C echange messages
376C
377
378 DO p=1,nspmd
379 IF(iad_elem(1,p+1)-iad_elem(1,p)>0)THEN
380 msgtyp = msgoff2
381 siz = iads(1+p)-iads(p)
382 l = iads(p)
383 CALL mpi_isend(
384 s bbufs(l),siz,real,it_spmd(p),msgtyp,
385 g spmd_comm_world,req_si(p),ierror)
386 ENDIF
387 ENDDO
388C--------------------------------------------------------------------
389C Reception
390 DO p = 1, nspmd
391 nb = iad_elem(1,p+1)-iad_elem(1,p)
392 IF(nb>0)THEN
393 CALL mpi_wait(req_ri(p),status,ierror)
394 l = iadr(p)
395 DO j=iad_elem(1,p),iad_elem(1,p+1)-1
396 nod = fr_elem(j)
397 IF(mode==1)THEN
398 mtf(10,nod) = mtf(10,nod)+bbufr(l)
399 IF(bbufr(l+1) > abs(mtf(11,nod)))THEN
400 mtf(11,nod) = bbufr(l+1)
401 tagpene(nod) = p
402 ELSEIF(bbufr(l+1) == abs(mtf(11,nod)) .and.
403 . ispmd+1 > p)THEN
404 ELSE
405 mtf(11,nod) = abs(bbufr(l+1)*(1-em6))
406 ENDIF
407 mtf(12,nod) = mtf(12,nod)+bbufr(l+2)
408 mtf(13,nod) = mtf(13,nod)+bbufr(l+3)
409 mtf(14,nod) = mtf(14,nod)+bbufr(l+4)
410 l=l+5
411 ELSEIF(mode==2)THEN
412 mtf(1,nod)=mtf(1,nod)+bbufr(l)
413 mtf(2,nod)=mtf(2,nod)+bbufr(l+1)
414 mtf(3,nod)=mtf(3,nod)+bbufr(l+2)
415C MTF(4-6) ne sont pas des valeurs de cumuls initialises dans les parties
416c ou l on en a besoin. Inutile de les communiquer
417c MTF(4,NOD)=BBUFR(L+3)
418c MTF(5,NOD)=BBUFR(L+4)
419c MTF(6,NOD)=BBUFR(L+5)
420 l=l+3
421 ELSEIF(mode==3)THEN
422 flg=nint(bbufr(l+3))
423 IF(flg==1)THEN
424 a(1,nod)=bbufr(l)
425 a(2,nod)=bbufr(l+1)
426 a(3,nod)=bbufr(l+2)
427 ENDIF
428 l=l+4
429 ENDIF
430 ENDDO
431 ENDIF
432 ENDDO
433
434C Fin du send
435 DO p = 1, nspmd
436 siz=iads(p+1)-iads(p)
437 IF(siz>0) THEN
438 CALL mpi_wait(req_si(p),status,ierror)
439 ENDIF
440 ENDDO
441
442#endif
443 RETURN
444C-----------------------------------------------
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
anim_mod
Definition anim_mod.F:96
h3d_mod
Definition h3d_mod.F:308
message_mod
Definition message_mod.F:1249
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:889
arret
subroutine arret(nn)
Definition arret.F:87