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

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_tri7vox_optimized (nsv, nsn, x, v, ms, bminmal, weight, stifn, nin, isendto, ircvfrom, iad_elem, fr_elem, nsnr, igap, gap_s, itab, kinet, ifq, inacti, nsnfiold, intth, ielec, areas, temp, num_imp, nodnx_sms, gap_s_l, ityp, irtlm, i24_time_s, i24_frfi, i24_pene_old, i24_stif_old, nbinflg, ilev, i24_icont_i, intfric, ipartfrics, itied, ivis2, if_adh)

Function/Subroutine Documentation

◆ spmd_tri7vox_optimized()

subroutine spmd_tri7vox_optimized ( integer, dimension(*) nsv,
integer nsn,
x,
v,
ms,
bminmal,
integer, dimension(*) weight,
stifn,
integer nin,
integer, dimension(ninter+1,*) isendto,
integer, dimension(ninter+1,*) ircvfrom,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer nsnr,
integer igap,
gap_s,
integer, dimension(*) itab,
integer, dimension(*) kinet,
integer ifq,
integer inacti,
integer, dimension(*) nsnfiold,
integer intth,
integer, dimension(*) ielec,
areas,
temp,
integer num_imp,
integer, dimension(*) nodnx_sms,
gap_s_l,
integer ityp,
integer, dimension(*) irtlm,
i24_time_s,
i24_frfi,
i24_pene_old,
i24_stif_old,
integer, dimension(*) nbinflg,
integer ilev,
integer, dimension(*) i24_icont_i,
integer intfric,
integer, dimension(*) ipartfrics,
integer itied,
integer ivis2,
integer, dimension(*) if_adh )

Definition at line 38 of file spmd_tri7vox_optimized.F.

48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE tri7box
52 USE message_mod
53 USE comm_tri7vox_mod
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57 USE spmd_comm_world_mod, ONLY : spmd_comm_world
58#include "implicit_f.inc"
59C-----------------------------------------------
60C M e s s a g e P a s s i n g
61C-----------------------------------------------
62#include "spmd.inc"
63C-----------------------------------------------
64C C o m m o n B l o c k s
65C-----------------------------------------------
66#include "com01_c.inc"
67#include "com04_c.inc"
68#include "task_c.inc"
69#include "timeri_c.inc"
70#include "sms_c.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER NIN, NSN, IFQ, INACTI, IGAP,INTTH,NSNR,INTFRIC,
75 . ITIED, IVIS2,
76 . NSNFIOLD(*), NSV(*), WEIGHT(*),
77 . ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*),
78 . IAD_ELEM(2,*), FR_ELEM(*), ITAB(*), KINET(*),
79 . IELEC(*),NUM_IMP, NODNX_SMS(*),IRTLM(*),ITYP,
80 . NBINFLG(*),ILEV,I24_ICONT_I(*),IPARTFRICS(*),IF_ADH(*)
81
82 my_real
83 . x(3,*), v(3,*), ms(*), bminmal(*), stifn(*), gap_s(*),
84 . areas(*),temp(*),gap_s_l(*),i24_time_s(*),i24_frfi(6,*),
85 . i24_pene_old(5,*),i24_stif_old(2,*)
86C-----------------------------------------------
87C L o c a l V a r i a b l e s
88C-----------------------------------------------
89#ifdef MPI
90 INTEGER MSGTYP,INFO,I,NOD, DT_CST, LOC_PROC,P,IDEB,
91 . SIZ,J, L, BUFSIZ, LEN, NB, IERROR1, IAD,
92 . STATUS(MPI_STATUS_SIZE),IERROR,REQ_SB(NSPMD),
93 . REQ_RB(NSPMD),KK,NBIRECV,IRINDEXI(NSPMD),
94 . REQ_RD(NSPMD),REQ_SD(NSPMD),REQ_SD2(NSPMD),
95 . REQ_RC(NSPMD),REQ_SC(NSPMD),
96 . INDEXI,ISINDEXI(NSPMD),INDEX(NUMNOD),NBOX(NSPMD),
97 . NBX,NBY,NBZ,IX,IY,IZ,
98 . MSGOFF, MSGOFF2, MSGOFF3, MSGOFF4, MSGOFF5,
99 . RSIZ, ISIZ, L2, REQ_SD3(NSPMD),REQ_RD2(NSPMD),
100 . LEN2, RSHIFT, ISHIFT, ND, JDEB, Q, NBB
101
102 INTEGER :: P_LOC
103 INTEGER :: SEND_SIZE_BMINMA
104 INTEGER :: REQUEST_BMINMA
105 INTEGER, DIMENSION(COMM_TRI7VOX(NIN)%proc_number) :: RCV_SIZE_BMINMA,DISPLS_BMINMA
106
107 INTEGER :: SEND_SIZE_CRVOX
108 INTEGER :: REQUEST_CRVOX
109 INTEGER, DIMENSION(COMM_TRI7VOX(NIN)%proc_number) :: RCV_SIZE_CRVOX,DISPLS_CRVOX
110 my_real, DIMENSION(6) :: bminma_loc
111 INTEGER, DIMENSION(0:LRVOXEL,0:LRVOXEL) :: CRVOXEL_LOC
112
113
114 integer :: key,code
115
116 DATA msgoff/6000/
117 DATA msgoff2/6001/
118 DATA msgoff3/6002/
119 DATA msgoff4/6003/
120 DATA msgoff5/6004/
121
122 my_real
123 . bminma(6,nspmd),
124 . xmaxb,ymaxb,zmaxb,xminb,yminb,zminb
125
126 TYPE(real_pointer), DIMENSION(NSPMD) :: RBUF
127 TYPE(int_pointer) , DIMENSION(NSPMD) :: IBUF
128 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAGNSNFI
129 my_real, DIMENSION(:,:), ALLOCATABLE :: xtmp
130 INTEGER, DIMENSION(NSPMD) :: TAB_NB
131
132C-----------------------------------------------
133C S o u r c e L i n e s
134C-----------------------------------------------
135C
136C=======================================================================
137C tag des boites contenant des facettes
138C et creation des candidats
139C=======================================================================
140 loc_proc = ispmd + 1
141
142 nbx = lrvoxel
143 nby = lrvoxel
144 nbz = lrvoxel
145C
146C Sauvegarde valeur ancienne des nsn frontieres
147C
148 IF(inacti==5.OR.inacti==6.OR.inacti==7.OR.ifq>0
149 . .OR.num_imp>0.OR.itied/=0.OR.ityp==23.OR.ityp==24
150 . .OR.ityp==25) THEN
151 DO p = 1, nspmd
152 nsnfiold(p) = nsnfi(nin)%P(p)
153 END DO
154 END IF
155C
156C boite minmax pour le tri provenant de i7buce BMINMA
157C
158 IF(ircvfrom(nin,loc_proc)==0.AND.
159 . isendto(nin,loc_proc)==0) RETURN
160 bminma(1,loc_proc) = bminmal(1)
161 bminma(2,loc_proc) = bminmal(2)
162 bminma(3,loc_proc) = bminmal(3)
163 bminma(4,loc_proc) = bminmal(4)
164 bminma(5,loc_proc) = bminmal(5)
165 bminma(6,loc_proc) = bminmal(6)
166
167! --------------------------
168! compute the displacement and size of send/rcv message
169! for allgatherv communications
170 send_size_bminma = 0
171 send_size_crvox = 0
172 rcv_size_bminma(1:comm_tri7vox(nin)%proc_number) = 0
173 displs_bminma(1:comm_tri7vox(nin)%proc_number) = 0
174 rcv_size_crvox(1:comm_tri7vox(nin)%proc_number) = 0
175 displs_crvox(1:comm_tri7vox(nin)%proc_number) = 0
176 IF(ircvfrom(nin,loc_proc)/=0) THEN
177 send_size_bminma = 6
178 send_size_crvox = (lrvoxel+1)*(lrvoxel+1)
179 ENDIF
180
181 DO p_loc = 1, comm_tri7vox(nin)%PROC_NUMBER
182 p = comm_tri7vox(nin)%PROC_LIST(p_loc)
183 IF(ircvfrom(nin,p)/=0) THEN
184 rcv_size_bminma(p_loc) = 6
185 rcv_size_crvox(p_loc) = (lrvoxel+1)*(lrvoxel+1)
186 ENDIF
187 ENDDO
188
189 p_loc=comm_tri7vox(nin)%RANK+1
190 rcv_size_bminma(p_loc) = send_size_bminma
191 rcv_size_crvox(p_loc) = send_size_crvox
192
193 DO p_loc = 1, comm_tri7vox(nin)%PROC_NUMBER
194 p = comm_tri7vox(nin)%PROC_LIST(p_loc)
195 IF(p>0) THEN
196 displs_bminma(p_loc) = (p-1)*6
197 displs_crvox(p_loc) = (p-1)*(lrvoxel+1)*(lrvoxel+1)
198 ELSE
199 displs_bminma(p_loc) = 0
200 displs_crvox(p_loc) = 0
201 ENDIF
202 ENDDO
203! --------------------------
204
205! send/rcv min-max
206 bminma_loc(1:6) = bminma(1:6,loc_proc)
207 CALL spmd_iallgatherv(bminma_loc,bminma,send_size_bminma,
208 . 6*nspmd,rcv_size_bminma,displs_bminma,request_bminma,
209 . comm_tri7vox(nin)%COMM,comm_tri7vox(nin)%PROC_NUMBER)
210
211! send/rcv voxel
212 crvoxel_loc(0:lrvoxel,0:lrvoxel) = crvoxel(0:lrvoxel,0:lrvoxel,loc_proc)
213 CALL spmd_iallgatherv_int(crvoxel_loc(0,0),crvoxel(0,0,1),send_size_crvox,
214 . (lrvoxel+1)*(lrvoxel+1)*nspmd,rcv_size_crvox,displs_crvox,request_crvox,
215 . comm_tri7vox(nin)%COMM,comm_tri7vox(nin)%PROC_NUMBER)
216
217 IF(isendto(nin,loc_proc)/=0) THEN
218 nbirecv=0
219 DO p = 1, nspmd
220 IF(ircvfrom(nin,p)/=0) THEN
221 IF(loc_proc/=p) THEN
222 nbirecv=nbirecv+1
223 irindexi(nbirecv)=p
224 ENDIF
225 ENDIF
226 ENDDO
227 ENDIF
228
229C
230C envoi voxel + boite min/max
231C
232
233C
234C envoi de XREM
235C
236C computation of real and integer sending buffers sizes
237c general case
238 rsiz = 8
239 isiz = 6
240
241c specific cases
242c IGAP=1 or IGAP=2
243 IF(igap==1 .OR. igap==2)THEN
244 rsiz = rsiz + 1
245c IGAP=3
246 ELSEIF(igap==3)THEN
247 rsiz = rsiz + 2
248 ENDIF
249
250C thermic
251 IF(intth > 0 ) THEN
252 rsiz = rsiz + 2
253 isiz = isiz + 1
254 ENDIF
255
256C Interface Adhesion
257 IF(ityp==25.AND.ivis2==-1 ) THEN
258 IF(intth==0) rsiz = rsiz + 1 ! areas
259 isiz = isiz + 2 ! if_adh+ioldnsnfi
260 ENDIF
261
262C Friction
263 IF(intfric > 0 ) THEN
264 isiz = isiz + 1
265 ENDIF
266
267C -- IDTMINS==2
268 IF(idtmins == 2)THEN
269 isiz = isiz + 2
270C -- IDTMINS_INT /= 0
271 ELSEIF(idtmins_int/=0)THEN
272 isiz = isiz + 1
273 END IF
274
275c INT24
276 IF(ityp==24)THEN
277 rsiz = rsiz + 8
278 isiz = isiz + 3
279C-----for NBINFLG
280 IF (ilev==2) isiz = isiz + 1
281
282 ENDIF
283
284c INT25
285 IF(ityp==25)THEN
286 rsiz = rsiz + 3
287 isiz = isiz + 6
288C-----for NBINFLG
289 IF (ilev==2) isiz = isiz + 1
290 ENDIF
291 ideb = 1
292
293 jdeb = 0
294 IF(ityp==25)THEN
295 ALLOCATE(itagnsnfi(numnod),stat=ierror)
296 itagnsnfi(1:numnod) = 0
297 END IF
298 tab_nb(1:nspmd) = 0
299
300#if _PLMPI
301! -------------------------
302! PLMPI uses MPI-2.x version without non blocking allgatherv comm
303! -------------------------
304#else
305! -------------------------
306! wait the previous comm
307 CALL mpi_wait(request_bminma,status,ierror)
308 CALL mpi_wait(request_crvox,status,ierror)
309! -------------------------
310#endif
311
312 IF(isendto(nin,loc_proc)/=0) THEN
313
314 DO kk = 1, nbirecv
315 p=irindexi(kk)
316C Traitement special sur d.d. ne consever que les noeuds internes
317 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
318 nod = fr_elem(j)
319C weight < 0 temporairement pour ne conserver que les noeuds non frontiere
320 weight(nod) = weight(nod)*(-1)
321 ENDDO
322C
323 l = ideb
324 nbox(p) = 0
325 nb = 0
326 xmaxb = bminma(1,p)
327 ymaxb = bminma(2,p)
328 zmaxb = bminma(3,p)
329 xminb = bminma(4,p)
330 yminb = bminma(5,p)
331 zminb = bminma(6,p)
332 DO i=1,nsn
333 nod = nsv(i)
334 IF(weight(nod)==1)THEN
335 IF(stifn(i)>zero)THEN
336 IF(itied/=0.AND.ityp==7.AND.candf_si(nin)%P(i)/=0) THEN
337 nb = nb + 1
338 index(nb) = i
339 ELSE
340 IF(ityp==25) THEN
341 IF(irtlm(4*(i-1)+4)==p)THEN
342 nb = nb + 1
343 index(nb) = i
344 cycle
345 ENDIF
346 ENDIF
347
348 IF(x(1,nod) < xminb) cycle
349 IF(x(1,nod) > xmaxb) cycle
350 IF(x(2,nod) < yminb) cycle
351 IF(x(2,nod) > ymaxb) cycle
352 IF(x(3,nod) < zminb) cycle
353 IF(x(3,nod) > zmaxb) cycle
354
355 ix=int(nbx*(x(1,nod)-xminb)/(xmaxb-xminb))
356 IF(ix >= 0 .AND. ix <= nbx) THEN
357 iy=int(nby*(x(2,nod)-yminb)/(ymaxb-yminb))
358 IF(iy >= 0 .AND. iy <= nby) THEN
359 iz=int(nbz*(x(3,nod)-zminb)/(zmaxb-zminb))
360 IF(iz >= 0 .AND. iz <= nbz) THEN
361 IF(btest(crvoxel(iy,iz,p),ix)) THEN
362 nb = nb + 1
363 index(nb) = i
364 ENDIF
365 ENDIF
366 ENDIF
367 ENDIF
368 ENDIF
369 ENDIF
370 ENDIF
371 ENDDO
372 nbox(p) = nb
373C
374 DO j = iad_elem(1,p), iad_elem(1,p+1)-1
375 nod = fr_elem(j)
376C remise de weight > 0
377 weight(nod) = weight(nod)*(-1)
378 ENDDO
379C old tag
380 IF(ityp==25)THEN
381 jdeb = 0
382 DO q=1,p-1
383 jdeb = jdeb + nsnsi(nin)%P(q)
384 END DO
385 nbb = nsnsi(nin)%P(p)
386 DO j = 1, nbb
387 nd = nsvsi(nin)%P(jdeb+j)
388 nod= nsv(nd)
389 itagnsnfi(nod)=j
390 END DO
391 END IF
392C
393C Envoi taille msg
394C
395 msgtyp = msgoff3
396 CALL mpi_isend(nbox(p),1,mpi_integer,it_spmd(p),msgtyp,
397 . spmd_comm_world,req_sd(p),ierror)
398C
399C Alloc buffer
400C
401 IF (nb>0) THEN
402 ALLOCATE(rbuf(p)%P(rsiz*nb),stat=ierror)
403 ALLOCATE(ibuf(p)%P(isiz*nb),stat=ierror)
404 IF(ierror/=0) THEN
405 CALL ancmsg(msgid=20,anmode=aninfo)
406 CALL arret(2)
407 ENDIF
408 l = 0
409 l2= 0
410
411#include "vectorize.inc"
412 DO j = 1, nb
413 i = index(j)
414 nod = nsv(i)
415 rbuf(p)%p(l+1) = x(1,nod)
416 rbuf(p)%p(l+2) = x(2,nod)
417 rbuf(p)%p(l+3) = x(3,nod)
418 rbuf(p)%p(l+4) = v(1,nod)
419 rbuf(p)%p(l+5) = v(2,nod)
420 rbuf(p)%p(l+6) = v(3,nod)
421 rbuf(p)%p(l+7) = ms(nod)
422 rbuf(p)%p(l+8) = stifn(i)
423 ibuf(p)%p(l2+1) = i
424 ibuf(p)%p(l2+2) = itab(nod)
425 ibuf(p)%p(l2+3) = kinet(nod)
426! save specifics IREM and XREM indexes for INT24 sorting
427 ibuf(p)%p(l2+4) = 0 !IGAPXREMP
428 ibuf(p)%p(l2+5) = 0 !I24XREMP
429 ibuf(p)%p(l2+6) = 0 !I24IREMP
430 l = l + rsiz
431 l2 = l2 + isiz
432 END DO
433
434c shift for real variables (prepare for next setting)
435 rshift = 9
436c shift for integer variables (prepare for next setting)
437 ishift = 7
438
439c specific cases
440c IGAP=1 or IGAP=2
441 IF(igap==1 .OR. igap==2)THEN
442 l = 0
443 igapxremp = rshift
444#include "vectorize.inc"
445 DO j = 1, nb
446 i = index(j)
447 rbuf(p)%p(l+rshift)= gap_s(i)
448 l = l + rsiz
449 ENDDO
450 rshift = rshift + 1
451
452c IGAP=3
453 ELSEIF(igap==3)THEN
454 l = 0
455 igapxremp = rshift
456#include "vectorize.inc"
457 DO j = 1, nb
458 i = index(j)
459 rbuf(p)%p(l+rshift) = gap_s(i)
460 rbuf(p)%p(l+rshift+1)= gap_s_l(i)
461 l = l + rsiz
462 END DO
463 rshift = rshift + 2
464 ENDIF
465
466C thermic
467 IF(intth>0)THEN
468 l = 0
469 l2 = 0
470#include "vectorize.inc"
471 DO j = 1, nb
472 i = index(j)
473 nod = nsv(i)
474 rbuf(p)%p(l+rshift) = temp(nod)
475 rbuf(p)%p(l+rshift+1) = areas(i)
476 ibuf(p)%p(l2+ishift) = ielec(i)
477 l = l + rsiz
478 l2 = l2 + isiz
479 END DO
480 rshift = rshift + 2
481 ishift = ishift + 1
482 ENDIF
483
484C Interface Adhesion
485 IF(ityp==25.AND.ivis2==-1)THEN
486 l = 0
487 l2 = 0
488#include "vectorize.inc"
489 DO j = 1, nb
490 i = index(j)
491 nod = nsv(i)
492 IF(intth==0) rbuf(p)%p(l+rshift) = areas(i)
493 ibuf(p)%p(l2+ishift) = if_adh(i)
494 ibuf(p)%p(l2+ishift+1)=itagnsnfi(nod)
495 IF(intth==0)l = l + rsiz
496 l2 = l2 + isiz
497 END DO
498 IF(intth==0) rshift = rshift + 1
499 ishift = ishift + 2
500 ENDIF
501
502C Friction
503 IF(intfric>0)THEN
504 l2 = 0
505#include "vectorize.inc"
506 DO j = 1, nb
507 i = index(j)
508 ibuf(p)%p(l2+ishift) = ipartfrics(i)
509 l2 = l2 + isiz
510 END DO
511 ishift = ishift + 1
512 ENDIF
513
514C -- IDTMINS==2
515 IF(idtmins==2)THEN
516 l2 = 0
517#include "vectorize.inc"
518 DO j = 1, nb
519 i = index(j)
520 nod = nsv(i)
521 ibuf(p)%p(l2+ishift) = nodnx_sms(nod)
522 ibuf(p)%p(l2+ishift+1)= nod
523 l2 = l2 + isiz
524 END DO
525 ishift = ishift + 2
526
527C -- IDTMINS_INT /= 0
528 ELSEIF(idtmins_int/=0)THEN
529 l2 = 0
530#include "vectorize.inc"
531 DO j = 1, nb
532 i = index(j)
533 nod = nsv(i)
534 ibuf(p)%p(l2+ishift)= nod
535 l2 = l2 + isiz
536 END DO
537 ishift = ishift + 1
538 ENDIF
539
540c INT24
541 IF(ityp==24)THEN
542
543 l = 0
544 i24xremp = rshift
545#include "vectorize.inc"
546 DO j = 1, nb
547 i = index(j)
548 rbuf(p)%p(l+rshift) =i24_time_s(i)
549 rbuf(p)%p(l+rshift+1) =i24_frfi(1,i)
550 rbuf(p)%p(l+rshift+2) =i24_frfi(2,i)
551 rbuf(p)%p(l+rshift+3) =i24_frfi(3,i)
552 rbuf(p)%p(l+rshift+4) =i24_pene_old(1,i)
553 rbuf(p)%p(l+rshift+5) =i24_stif_old(1,i)
554 rbuf(p)%p(l+rshift+6) =i24_pene_old(3,i)
555 rbuf(p)%p(l+rshift+7) =i24_pene_old(5,i)
556 l = l + rsiz
557 END DO
558 rshift = rshift + 8
559
560 l2 = 0
561 i24iremp = ishift
562#include "vectorize.inc"
563 DO j = 1, nb
564 i = index(j)
565C IRTLM(2,NSN) in TYPE24
566 ibuf(p)%p(l2+ishift) =irtlm(2*(i-1)+1)
567 ibuf(p)%p(l2+ishift+1)=irtlm(2*(i-1)+2)
568 ibuf(p)%p(l2+ishift+2)=i24_icont_i(i)
569 l2 = l2 + isiz
570 END DO
571 ishift = ishift + 3
572C---pay attention in i24sto.F IREM(I24IREMP+3,N-NSN) is used,
573C----change the shift value when new table was added like I24_ICONT_I
574 IF (ilev==2) THEN
575 l2 = 0
576#include "vectorize.inc"
577 DO j = 1, nb
578 i = index(j)
579 ibuf(p)%p(l2+ishift)=nbinflg(i)
580 l2 = l2 + isiz
581 END DO
582 END IF
583 ishift = ishift + 1
584
585 END IF !(ITYP==24)
586
587c INT25
588 IF(ityp==25)THEN
589 l = 0
590 i24xremp = rshift
591#include "vectorize.inc"
592 DO j = 1, nb
593 i = index(j)
594 rbuf(p)%p(l+rshift) =i24_time_s(2*(i-1)+1)
595 rbuf(p)%p(l+rshift+1) =i24_time_s(2*(i-1)+2)
596 rbuf(p)%p(l+rshift+2) =i24_pene_old(5,i) ! used only at time=0
597 l = l + rsiz
598 END DO
599 rshift = rshift + 3
600
601 l2 = 0
602 i24iremp = ishift
603
604#include "vectorize.inc"
605 DO j = 1, nb
606 i = index(j)
607 nod = nsv(i)
608C IRTLM(3,NSN) en TYPE25 / IRTLM(3,-) inutile ici
609 ibuf(p)%p(l2+ishift) =irtlm(4*(i-1)+1)
610 ibuf(p)%p(l2+ishift+1)=irtlm(4*(i-1)+2)
611C
612C IRTLM(3,I) == local n of the impacted segment is shared but only valid on proc == IRTLM(4,I)
613 ibuf(p)%p(l2+ishift+2)=irtlm(4*(i-1)+3)
614 ibuf(p)%p(l2+ishift+3)=irtlm(4*(i-1)+4)
615 ibuf(p)%p(l2+ishift+4)=i24_icont_i(i)
616 ibuf(p)%p(l2+ishift+5)=itagnsnfi(nod)
617 l2 = l2 + isiz
618 END DO
619 ishift = ishift + 6
620C---pay attention in i25sto.F IREM(I24IREMP+4,N-NSN) is used,
621C----change the shift value when new table was added like IRTLM(3*(I-1)+2)
622 IF (ilev==2) THEN
623 l2 = 0
624#include "vectorize.inc"
625 DO j = 1, nb
626 i = index(j)
627 ibuf(p)%p(l2+ishift)=nbinflg(i)
628 l2 = l2 + isiz
629 END DO
630 END IF
631 ishift = ishift + 1
632
633 END IF !(ITYP==25)
634C
635 !save specifics IREM and XREM indexes for INT24 sorting
636 l2 = 0
637#include "vectorize.inc"
638 DO j = 1, nb
639 i = index(j)
640 nod = nsv(i)
641 !save specifics IREM and XREM indexes for INT24 sorting
642 ibuf(p)%p(l2+4) = igapxremp
643 ibuf(p)%p(l2+5) = i24xremp
644 ibuf(p)%p(l2+6) = i24iremp
645 l2 = l2 + isiz
646 END DO
647 tab_nb(p) = nb
648 ENDIF
649C
650C reset old tag for next P
651 IF(ityp==25)THEN
652 nbb = nsnsi(nin)%P(p)
653 DO j = 1, nbb
654 nd = nsvsi(nin)%P(jdeb+j)
655 nod= nsv(nd)
656 itagnsnfi(nod)=0
657 END DO
658 END IF
659 ENDDO
660 ENDIF
661C
662 IF(ityp==25) DEALLOCATE(itagnsnfi)
663C
664C reception des donnees XREM
665C
666 IF(ircvfrom(nin,loc_proc)/=0) THEN
667 nsnr = 0
668 l=0
669 DO p = 1, nspmd
670 nsnfi(nin)%P(p) = 0
671 IF(isendto(nin,p)/=0) THEN
672 IF(loc_proc/=p) THEN
673 msgtyp = msgoff3
674 CALL mpi_recv(nsnfi(nin)%P(p),1,mpi_integer,it_spmd(p),
675 . msgtyp,spmd_comm_world,status,ierror)
676 IF(nsnfi(nin)%P(p)>0) THEN
677 l=l+1
678 isindexi(l)=p
679 nsnr = nsnr + nsnfi(nin)%P(p)
680 ENDIF
681 ENDIF
682 ENDIF
683 ENDDO
684 nbirecv=l
685C
686C Allocate total size
687C
688
689 IF(nsnr>0) THEN
690
691 ALLOCATE(xrem(rsiz,nsnr),stat=ierror)
692 ALLOCATE(irem(isiz,nsnr),stat=ierror)
693
694
695 IF(ierror/=0) THEN
696 CALL ancmsg(msgid=20,anmode=aninfo)
697 CALL arret(2)
698 ENDIF
699 ideb = 1
700 DO l = 1, nbirecv
701 p = isindexi(l)
702 len = nsnfi(nin)%P(p)*rsiz
703 msgtyp = msgoff4
704
705 CALL mpi_irecv(
706 1 xrem(1,ideb),len,real,it_spmd(p),
707 2 msgtyp,spmd_comm_world,req_rd(l),ierror)
708
709 len2 = nsnfi(nin)%P(p)*isiz
710 msgtyp = msgoff5
711 CALL mpi_irecv(
712 1 irem(1,ideb),len2,mpi_integer,it_spmd(p),
713 2 msgtyp,spmd_comm_world,req_rd2(l),ierror)
714 ideb = ideb + nsnfi(nin)%P(p)
715 ENDDO
716 ENDIF
717 ENDIF
718
719 DO p=1,nspmd
720 IF(tab_nb(p) /= 0 ) THEN
721 msgtyp = msgoff4
722 CALL mpi_isend(
723 1 rbuf(p)%P(1),tab_nb(p)*rsiz,real,it_spmd(p),msgtyp,
724 2 spmd_comm_world,req_sd2(p),ierror)
725 msgtyp = msgoff5
726 CALL mpi_isend(
727 1 ibuf(p)%P(1),tab_nb(p)*isiz,mpi_integer,it_spmd(p),msgtyp,
728 2 spmd_comm_world,req_sd3(p),ierror)
729 ENDIF
730 ENDDO
731
732 IF(ircvfrom(nin,loc_proc)/=0) THEN
733 IF(nsnr>0) THEN
734 DO l = 1, nbirecv
735 CALL mpi_waitany(nbirecv,req_rd,indexi,status,ierror)
736 CALL mpi_waitany(nbirecv,req_rd2,indexi,status,ierror)
737 ENDDO
738 !set specifics IREM and XREM indexes for INT24 sorting
739 igapxremp = irem(4,1)
740 i24xremp = irem(5,1)
741 i24iremp = irem(6,1)
742 ENDIF
743 ENDIF
744C
745 IF(isendto(nin,loc_proc)/=0) THEN
746 DO p = 1, nspmd
747 IF(ircvfrom(nin,p)/=0) THEN
748 IF(p/=loc_proc) THEN
749 CALL mpi_wait(req_sd(p),status,ierror)
750 IF(nbox(p)/=0) THEN
751 CALL mpi_wait(req_sd2(p),status,ierror)
752 DEALLOCATE(rbuf(p)%p)
753 CALL mpi_wait(req_sd3(p),status,ierror)
754 DEALLOCATE(ibuf(p)%p)
755 END IF
756 ENDIF
757 ENDIF
758 ENDDO
759 ENDIF
760C
761
762C
763#endif
764 RETURN
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_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
comm_tri7vox_mod
Definition comm_tri7vox_mod.F:29
comm_tri7vox_mod::comm_tri7vox
type(comm_tri7vox_type), dimension(:), allocatable comm_tri7vox
Definition comm_tri7vox_mod.F:60
message_mod
Definition message_mod.F:1249
tri7box::candf_si
type(int_pointer), dimension(:), allocatable candf_si
Definition tri7box.F:560
tri7box::nsvsi
type(int_pointer), dimension(:), allocatable nsvsi
Definition tri7box.F:485
tri7box::i24iremp
integer i24iremp
Definition tri7box.F:423
tri7box::crvoxel
integer, dimension(0:lrvoxel, 0:lrvoxel) crvoxel
Definition tri7box.F:56
tri7box::nsnsi
type(int_pointer), dimension(:), allocatable nsnsi
Definition tri7box.F:491
tri7box::i24xremp
integer i24xremp
Definition tri7box.F:423
tri7box::igapxremp
integer igapxremp
Definition tri7box.F:423
tri7box::lrvoxel
integer lrvoxel
Definition tri7box.F:54
tri7box::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
tri7box::irem
integer, dimension(:,:), allocatable irem
Definition tri7box.F:339
spmd_iallgatherv
subroutine spmd_iallgatherv(sendbuf, recvbuf, send_size, total_rcv_size, rcv_size, displs, request, comm, size_)
Definition spmd_iallgatherv.F:31
spmd_iallgatherv_int
subroutine spmd_iallgatherv_int(sendbuf, recvbuf, send_size, total_rcv_size, rcv_size, displs, request, comm, size_)
Definition spmd_iallgatherv_int.F:31
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