OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spclasv.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!|| spclasv ../engine/source/elements/sph/spclasv.F
25!||--- called by ------------------------------------------------------
26!|| sphprep ../engine/source/elements/sph/sphprep.F
27!||--- calls -----------------------------------------------------
28!|| my_barrier ../engine/source/system/machine.f
29!|| myqsort ../common_source/tools/sort/myqsort.F
30!|| spmd_allglob_isum9 ../engine/source/mpi/generic/spmd_allglob_isum9.F
31!|| spmd_sphgeth ../engine/source/mpi/elements/spmd_sph.F
32!||--- uses -----------------------------------------------------
33!|| sph_struct_mod ../engine/share/modules/sph_struct_mod.F
34!|| sphbox ../engine/share/modules/sphbox.F
35!||====================================================================
36 SUBROUTINE spclasv(X ,SPBUF ,KXSP ,IXSP ,NOD2SP ,
37 1 ISPSYM ,XSPSYM,WSP2SORT,ITASK ,MYSPATRUE,
38 2 IREDUCE,KREDUCE,LGAUGE ,GAUGE ,ISORTSP)
39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE sphbox
43 USE sph_struct_mod
44C-----------------------------------------------
45C I m p l i c i t T y p e s
46C-----------------------------------------------
47#include "implicit_f.inc"
48C-----------------------------------------------
49C C o m m o n B l o c k s
50C-----------------------------------------------
51#include "com01_c.inc"
52#include "com04_c.inc"
53#include "sphcom.inc"
54#include "param_c.inc"
55#include "parit_c.inc"
56#include "task_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER KXSP(NISP,*),IXSP(KVOISPH,*),NOD2SP(*),
61 . ISPSYM(NSPCOND,*),WSP2SORT(*), ITASK, IREDUCE, KREDUCE(*),
62 . lgauge(3,*),isortsp
63C REAL
64 my_real
65 . x(3,*),spbuf(nspbuf,*),xspsym(3,*), myspatrue, gauge(llgauge,*)
66C-----------------------------------------------
67C L o c a l V a r i a b l e s
68C-----------------------------------------------
69 integer
70 . n,inod,jnod,j,nvois,m,ncand,k1,k2,nvois1,nvois2,
71 . nvoiss,nvoiss1,nvoiss2, iaux, ierror,
72 . k, l, jk, nc, js, ns, nn, nb,jj1,jj2, jj, jjj,
73 . mwa(2*kvoisph),jstor(kvoisph), jperm(kvoisph),
74 . lvoired, ig
75 my_real
76 . dms,dms2,dk,
77 . xi,yi,zi,di,xj,yj,zj,dj,dd,dvois(kvoisph),
78 . dwa(numsph)
79 SAVE lvoired
80 LOGICAL :: SORTING_CONDITION
81C-----------------------------------------------
82 lvoired = 0
83 IF(ireduce==0)GO TO 100
84C-------------------------------------------
85C tri voisins / ne garder que LVOISPH voisins effectifs
86C
87C /---------------/
88 CALL my_barrier
89C /---------------/
90C
91 DO ns=itask+1,nsp2sort,nthread
92 n=wsp2sort(ns)
93 dwa(n)=one
94 nvois1 =kxsp(4,n)
95 nvoiss1=kxsp(6,n)
96 IF(kreduce(n)/=0.OR.nvois1+nvoiss1>lvoisph)THEN
97C
98 IF(nvois1+nvoiss1>lvoisph)THEN
99 kreduce(n)=kreduce(n)+10
100 lvoired = 1
101 END IF
102C
103 inod=kxsp(3,n)
104 xi=x(1,inod)
105 yi=x(2,inod)
106 zi=x(3,inod)
107 di=spbuf(1,n)
108 nvois=kxsp(5,n)
109 ncand=kxsp(5,n)+kxsp(7,n)
110 DO k=1,nvois
111 jnod = ixsp(k,n)
112 IF(jnod>0)THEN
113 m =nod2sp(jnod)
114 xj=x(1,jnod)
115 yj=x(2,jnod)
116 zj=x(3,jnod)
117 dj=spbuf(1,m)
118 ELSE ! cellule remote
119 nn = -jnod
120 xj=xsphr(3,nn)
121 yj=xsphr(4,nn)
122 zj=xsphr(5,nn)
123 dj=xsphr(2,nn)
124 END IF
125 dms =di+dj
126 dms2=dms*dms
127 dvois(k)=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
128 dvois(k)=dvois(k)/dms2
129 END DO
130 DO k=nvois+1,ncand
131 jk = ixsp(k,n)
132 IF(jk>0)THEN
133 nc=mod(jk,nspcond+1)
134 m=jk/(nspcond+1)
135 js=ispsym(nc,m)
136 dj=spbuf(1,m)
137 ELSE ! symmetrical particle from remote one
138 nc=mod(-jk,nspcond+1)
139 m =-jk/(nspcond+1)
140 js=ispsymr(nc,m)
141 dj =xsphr(2,m)
142 END IF
143 xj =xspsym(1,js)
144 yj =xspsym(2,js)
145 zj =xspsym(3,js)
146 dms =di+dj
147 dms2=dms*dms
148 dvois(k)=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
149 dvois(k)=dvois(k)/dms2
150 END DO
151C
152 sorting_condition = (.NOT.(bool_sph_sort(n)).OR.isortsp==0.OR.nvois/=ncand)
153 IF(sorting_condition) THEN
154 CALL myqsort(ncand,dvois,jperm,ierror)
155 ELSE
156 DO k=1,kxsp(4,n)
157 jperm(k) = k
158 ENDDO
159 DO k=1,kxsp(5,n)-kxsp(4,n)+1
160 jperm(kxsp(4,n)+k) = kxsp(5,n)-k+1
161 ENDDO
162 ENDIF
163
164 DO k=1,ncand
165 jstor(k) = ixsp(k,n)
166 END DO
167C
168 IF(kreduce(n) >= 10)dwa(n)=sqrt(dvois(lvoisph))
169C
170 k1=0
171 k2=0
172 DO k=1,ncand
173 jk=jstor(jperm(k))
174 IF(jperm(k) <= nvois) THEN
175 k1=k1+1
176 ixsp(k1,n) = jk
177 ELSE
178 k2=k2+1
179 ixsp(nvois+k2,n) = jk
180 END IF
181 END DO
182C
183 END IF
184 END DO
185C-------------------------------------------
186C adapte diametre (reduction only)
187C
188C /---------------/
189 CALL my_barrier
190C /---------------/
191C
192 IF(lvoired /= 0)THEN
193C
194 DO ns=itask+1,nsp2sort,nthread
195 n=wsp2sort(ns)
196 spbuf(1,n)=min(spbuf(1,n),dwa(n)*spbuf(1,n))
197 spbuf(8,n)=spbuf(1,n)
198 END DO
199 END IF
200C
201 IF(nspmd > 1)THEN
202C
203C /---------------/
204 CALL my_barrier
205C /---------------/
206 IF(itask==0) THEN
207c CALL SPMD_GLOB_IMAX9(LVOIRED,1)
208 CALL spmd_allglob_isum9(lvoired,1)
209C
210C il faut encore echanger SPBUF(1,*)
211 IF(lvoired /= 0) CALL spmd_sphgeth(kxsp ,spbuf)
212 END IF
213 END IF
214C
215C /---------------/
216 CALL my_barrier
217C /---------------/
218C
219 DO ns=itask+1,nsp2sort,nthread
220 n=wsp2sort(ns)
221C
222 IF(mod(kreduce(n),10)/=0)THEN
223C
224 nvois1 =kxsp(4,n)
225 nvois =kxsp(5,n)
226 nvoiss1=kxsp(6,n)
227 nvoiss =kxsp(7,n)
228 inod=kxsp(3,n)
229 xi=x(1,inod)
230 yi=x(2,inod)
231 zi=x(3,inod)
232 di=spbuf(1,n)
233C
234C on est forcement plus proche de la particule vraie que de la particule fantome
235 jnod = ixsp(nvois,n)
236 IF(jnod>0)THEN
237 m =nod2sp(jnod)
238 xj=x(1,jnod)
239 yj=x(2,jnod)
240 zj=x(3,jnod)
241 dj=spbuf(1,m)
242 ELSE
243 nn = -jnod
244 xj=xsphr(3,nn)
245 yj=xsphr(4,nn)
246 zj=xsphr(5,nn)
247 dj=xsphr(2,nn)
248 END IF
249 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
250 dms =di+dj
251 dms2=dms*dms
252 dk=dd/dms2
253 myspatrue=max(zero,min(myspatrue,dk-one))
254 END IF
255C
256 END DO
257C-------------------------------------------
258 100 CONTINUE
259 IF(nspcond==0) THEN
260 DO n = itask+1,nsphr,nthread
261C remise a zero du flag de reperage des cellules actives en spmd multiprocesseurs
262 isphr(n) = 0
263 END DO
264 ELSE
265C si condition de symetrie alors pas d'optimisation sur particules active
266C car particule symetrique de particule inactive eventuellement active
267 DO n = itask+1,nsphr,nthread
268 isphr(n) = 1
269 END DO
270 END IF
271C /---------------/
272 CALL my_barrier
273C /---------------/
274C
275 IF(iparit/=0)THEN
276 DO ns=itask+1,nsp2sort,nthread
277 n=wsp2sort(ns)
278 inod=kxsp(3,n)
279 xi=x(1,inod)
280 yi=x(2,inod)
281 zi=x(3,inod)
282 ncand=kxsp(5,n)
283 nvois1=0
284 nvois2=0
285 DO j=1,ncand
286 jnod=ixsp(j,n)
287 IF(jnod>0)THEN
288 m=nod2sp(jnod)
289 xj=x(1,jnod)
290 yj=x(2,jnod)
291 zj=x(3,jnod)
292 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
293 dms =spbuf(1,n)+spbuf(1,m)
294 dms2=dms*dms
295 IF (kxsp(2,m)/=0.AND.dd<dms2) THEN
296 nvois1=nvois1+1
297 mwa(nvois1)=jnod
298 ELSE
299 nvois2=nvois2+1
300 mwa(kvoisph+nvois2)=jnod
301 END IF
302 ELSE ! cellule remote
303 nn = -jnod
304 xj=xsphr(3,nn)
305 yj=xsphr(4,nn)
306 zj=xsphr(5,nn)
307 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
308 dms =spbuf(1,n)+xsphr(2,nn)
309 dms2=dms*dms
310 IF (nint(xsphr(13,nn))/=0.AND.dd<dms2) THEN
311 nvois1=nvois1+1
312 mwa(nvois1)=jnod
313 isphr(nn) = 1 ! flag reperage cellule active
314 ELSE
315 nvois2=nvois2+1
316 mwa(kvoisph+nvois2)=jnod
317 ENDIF
318 END IF
319 ENDDO
320C---------
321 kxsp(4,n)=nvois1
322 DO j=1,nvois1
323 ixsp(j,n)=mwa(j)
324 ENDDO
325 DO j=1,nvois2
326 ixsp(nvois1+j,n)=mwa(kvoisph+j)
327 ENDDO
328C------------------
329C Tri des particules effectives suivant no particule pour conservation Parith/ON
330 DO k = 1, nvois1
331 jk = ixsp(k,n)
332 IF(jk>0)THEN
333 dvois(k) = kxsp(8,nod2sp(jk)) ! ID particule stoke ds DVOIS
334 ELSE
335 dvois(k) = nint(xsphr(6,-jk))
336 END IF
337 END DO
338 CALL myqsort(nvois1,dvois,jperm,ierror)
339 DO k=1,nvois1
340 jstor(k) = ixsp(k,n)
341 END DO
342 DO k=1,nvois1
343 ixsp(k,n) = jstor(jperm(k))
344 END DO
345 ENDDO
346C--------------------------------------------
347C Re-ordonne les particules fantomes.
348 DO ns=itask+1,nsp2sort,nthread
349 n=wsp2sort(ns)
350 inod=kxsp(3,n)
351 xi =x(1,inod)
352 yi =x(2,inod)
353 zi =x(3,inod)
354 di =spbuf(1,n)
355 nvois2 =kxsp(5,n)
356 nvoiss =kxsp(7,n)
357 nvoiss1=0
358 nvoiss2=0
359 DO k=nvois2+1,nvois2+nvoiss
360 jk=ixsp(k,n)
361 IF(jk>0)THEN
362 nc=mod(jk,nspcond+1)
363 m =jk/(nspcond+1)
364 js=ispsym(nc,m)
365 dj =spbuf(1,m)
366 xj =xspsym(1,js)
367 yj =xspsym(2,js)
368 zj =xspsym(3,js)
369 dms =di+dj
370 dms2=dms*dms
371 dd=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
372 IF (kxsp(2,m)/=0.AND.dd<dms2) THEN
373 nvoiss1=nvoiss1+1
374 mwa(nvoiss1)=jk
375 ELSE
376 nvoiss2=nvoiss2+1
377 mwa(kvoisph+nvoiss2)=jk
378 ENDIF
379 ELSE ! particule symetrique de particule remote
380 nc=mod(-jk,nspcond+1)
381 m =-jk/(nspcond+1)
382 js=ispsymr(nc,m)
383 dj =xsphr(2,m)
384 xj =xspsym(1,js)
385 yj =xspsym(2,js)
386 zj =xspsym(3,js)
387 dms =di+dj
388 dms2=dms*dms
389 dd=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
390 IF (nint(xsphr(13,m))/=0.AND.dd<dms2) THEN
391 nvoiss1=nvoiss1+1
392 mwa(nvoiss1)=jk
393 ELSE
394 nvoiss2=nvoiss2+1
395 mwa(kvoisph+nvoiss2)=jk
396 ENDIF
397 END IF
398 ENDDO
399 kxsp(6,n)=nvoiss1
400 DO j=1,nvoiss1
401 ixsp(nvois2+j,n)=mwa(j)
402 ENDDO
403 DO j=1,nvoiss2
404 ixsp(nvois2+nvoiss1+j,n)=mwa(kvoisph+j)
405 ENDDO
406C Tri des particules symetriques suivant no particule pour conservation Parith/ON
407 DO k = 1, nvoiss1
408 jk = ixsp(nvois2+k,n)
409 IF(jk>0)THEN
410 m=jk/(nspcond+1)
411 nc=mod(jk,nspcond+1)
412 dvois(k) = kxsp(8,m) ! ID particule stoke ds DVOIS
413cc DVOIS(K) = KXSP(8,nod2sp(M)) ! ID particule stoke ds DVOIS
414 mwa(k) = nc
415 ELSE
416 m=-jk/(nspcond+1)
417 nc=mod(-jk,nspcond+1)
418 dvois(k) = xsphr(6,m)
419 mwa(k) = nc
420 END IF
421 END DO
422 CALL myqsort(nvoiss1,dvois,jperm,ierror)
423 DO k=1,nvoiss1
424 jstor(k) = ixsp(nvois2+k,n)
425 END DO
426 DO k=1,nvoiss1
427 ixsp(nvois2+k,n) = jstor(jperm(k))
428 END DO
429 DO k=1,nvoiss1
430 jstor(k) = mwa(k)
431 END DO
432 DO k=1,nvoiss1
433 mwa(k) = jstor(jperm(k))
434 END DO
435 IF(nspcond>1) THEN
436C Tri des particules symetriques suivant NSPCOND pour un meme no particule pour conservation Parith/ON
437 m = nint(dvois(1))
438 nb = 1
439 DO k = 2, nvoiss1
440 IF(nint(dvois(k))/=m) THEN
441 IF(nb>1)THEN
442 jj1 = k-nb
443 jj2 = k-1
444C petit tri bulle
445 DO jj = jj1, jj2-1
446 DO jjj = jj+1, jj2
447 IF(mwa(jj)>mwa(jjj))THEN
448 iaux = mwa(jj)
449 mwa(jj) = mwa(jjj)
450 mwa(jjj) = iaux
451 iaux = ixsp(nvois2+jj,n)
452 ixsp(nvois2+jj,n) = ixsp(nvois2+jjj,n)
453 ixsp(nvois2+jjj,n) = iaux
454 END IF
455 END DO
456 END DO
457 END IF
458 m = nint(dvois(k))
459 nb = 1
460 ELSE
461 nb = nb + 1
462 END IF
463 END DO
464C terminaison
465 IF(nb>1)THEN
466 jj1 = nvoiss1-nb+1
467 jj2 = nvoiss1
468C petit tri bulle
469 DO jj = jj1, jj2-1
470 DO jjj = jj+1, jj2
471 IF(mwa(jj)>mwa(jjj))THEN
472 iaux = mwa(jj)
473 mwa(jj) = mwa(jjj)
474 mwa(jjj) = iaux
475 iaux = ixsp(nvois2+jj,n)
476 ixsp(nvois2+jj,n) = ixsp(nvois2+jjj,n)
477 ixsp(nvois2+jjj,n) = iaux
478 END IF
479 END DO
480 END DO
481 END IF
482 END IF
483C fin traitement special parith/on en spmd
484 ENDDO
485C--------------------------------------------
486 ELSE ! IF(IPARIT/=0)THEN
487 DO ns=itask+1,nsp2sort,nthread
488 n=wsp2sort(ns)
489 inod=kxsp(3,n)
490 xi=x(1,inod)
491 yi=x(2,inod)
492 zi=x(3,inod)
493 ncand=kxsp(5,n)
494 nvois1=0
495 nvois2=0
496 DO j=1,ncand
497 jnod=ixsp(j,n)
498 IF(jnod>0)THEN
499 m=nod2sp(jnod)
500 xj=x(1,jnod)
501 yj=x(2,jnod)
502 zj=x(3,jnod)
503 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
504 dms =spbuf(1,n)+spbuf(1,m)
505 dms2=dms*dms
506 IF (kxsp(2,m)/=0.AND.dd<dms2) THEN
507 nvois1=nvois1+1
508 mwa(nvois1)=jnod
509 ELSE
510 nvois2=nvois2+1
511 mwa(kvoisph+nvois2)=jnod
512 END IF
513 ELSE ! cellule remote
514 nn = -jnod
515 xj=xsphr(3,nn)
516 yj=xsphr(4,nn)
517 zj=xsphr(5,nn)
518 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
519 dms =spbuf(1,n)+xsphr(2,nn)
520 dms2=dms*dms
521 IF (nint(xsphr(13,nn))/=0.AND.dd<dms2) THEN
522 nvois1=nvois1+1
523 mwa(nvois1)=jnod
524 isphr(nn) = 1 ! flag reperage cellule active
525 ELSE
526 nvois2=nvois2+1
527 mwa(kvoisph+nvois2)=jnod
528 ENDIF
529 END IF
530 ENDDO
531C---------
532 kxsp(4,n)=nvois1
533 DO j=1,nvois1
534 ixsp(j,n)=mwa(j)
535 ENDDO
536 DO j=1,nvois2
537 ixsp(nvois1+j,n)=mwa(kvoisph+j)
538 ENDDO
539 ENDDO ! NS=ITASK+1,NSP2SORT,NTHREAD
540C--------------------------------------------
541C Re-ordonne les particules fantomes.
542 DO ns=itask+1,nsp2sort,nthread
543 n=wsp2sort(ns)
544 inod=kxsp(3,n)
545 xi =x(1,inod)
546 yi =x(2,inod)
547 zi =x(3,inod)
548 di =spbuf(1,n)
549 nvois2 =kxsp(5,n)
550 nvoiss =kxsp(7,n)
551 nvoiss1=0
552 nvoiss2=0
553 DO k=nvois2+1,nvois2+nvoiss
554 jk=ixsp(k,n)
555 IF(jk>0)THEN
556 nc=mod(jk,nspcond+1)
557 m =jk/(nspcond+1)
558 js=ispsym(nc,m)
559 dj =spbuf(1,m)
560 xj =xspsym(1,js)
561 yj =xspsym(2,js)
562 zj =xspsym(3,js)
563 dms =di+dj
564 dms2=dms*dms
565 dd=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
566 IF (kxsp(2,m)/=0.AND.dd<dms2) THEN
567 nvoiss1=nvoiss1+1
568 mwa(nvoiss1)=jk
569 ELSE
570 nvoiss2=nvoiss2+1
571 mwa(kvoisph+nvoiss2)=jk
572 ENDIF
573 ELSE ! particule symetrique de particule remote
574 nc=mod(-jk,nspcond+1)
575 m =-jk/(nspcond+1)
576 js=ispsymr(nc,m)
577 dj =xsphr(2,m)
578 xj =xspsym(1,js)
579 yj =xspsym(2,js)
580 zj =xspsym(3,js)
581 dms =di+dj
582 dms2=dms*dms
583 dd=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
584 IF (nint(xsphr(13,m))/=0.AND.dd<dms2) THEN
585 nvoiss1=nvoiss1+1
586 mwa(nvoiss1)=jk
587 ELSE
588 nvoiss2=nvoiss2+1
589 mwa(kvoisph+nvoiss2)=jk
590 ENDIF
591 END IF
592 ENDDO
593 kxsp(6,n)=nvoiss1
594 DO j=1,nvoiss1
595 ixsp(nvois2+j,n)=mwa(j)
596 ENDDO
597 DO j=1,nvoiss2
598 ixsp(nvois2+nvoiss1+j,n)=mwa(kvoisph+j)
599 ENDDO
600 ENDDO ! ns=itask+1,nsp2sort,nthread
601 END IF
602C-----------------------------------------------
603!$omp DO schedule(dynamic,1)
604 DO ig=1,nbgauge
605 IF(lgauge(1,ig) > -(numels+1))cycle
606 n=numsph+ig
607 xi =gauge(2,ig)
608 yi =gauge(3,ig)
609 zi =gauge(4,ig)
610 ncand=kxsp(5,n)
611 nvois1=0
612 nvois2=0
613 DO j=1,ncand
614 jnod=ixsp(j,n)
615 IF(jnod>0)THEN
616 m=nod2sp(jnod)
617 xj=x(1,jnod)
618 yj=x(2,jnod)
619 zj=x(3,jnod)
620 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
621 dms =two*spbuf(1,m)
622 dms2=dms*dms
623 IF (kxsp(2,m)/=0.AND.dd<dms2) THEN
624 nvois1=nvois1+1
625 mwa(nvois1)=jnod
626 ELSE
627 nvois2=nvois2+1
628 mwa(kvoisph+nvois2)=jnod
629 END IF
630 ELSE ! cellule remote
631 nn = -jnod
632 xj=xsphr(3,nn)
633 yj=xsphr(4,nn)
634 zj=xsphr(5,nn)
635 dd =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
636 dms =two*xsphr(2,nn)
637 dms2=dms*dms
638 IF (nint(xsphr(13,nn))/=0.AND.dd<dms2) THEN
639 nvois1=nvois1+1
640 mwa(nvois1)=jnod
641 isphr(nn) = 1 ! flag reperage cellule active
642 ELSE
643 nvois2=nvois2+1
644 mwa(kvoisph+nvois2)=jnod
645 ENDIF
646 END IF
647 ENDDO
648C--------
649 kxsp(4,n)=nvois1
650 DO j=1,nvois1
651 ixsp(j,n)=mwa(j)
652 ENDDO
653 DO j=1,nvois2
654 ixsp(nvois1+j,n)=mwa(kvoisph+j)
655 ENDDO
656C-------------------------------------------
657C Re-ordonne les particules fantomes.
658 nvois2 =kxsp(5,n)
659 nvoiss =kxsp(7,n)
660 nvoiss1=0
661 nvoiss2=0
662 DO k=nvois2+1,nvois2+nvoiss
663 jk=ixsp(k,n)
664 IF(jk>0)THEN
665 nc=mod(jk,nspcond+1)
666 m =jk/(nspcond+1)
667 js=ispsym(nc,m)
668 dj =spbuf(1,m)
669 xj =xspsym(1,js)
670 yj =xspsym(2,js)
671 zj =xspsym(3,js)
672 dms =two*dj
673 dms2=dms*dms
674 dd=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
675 IF (kxsp(2,m)/=0.AND.dd<dms2) THEN
676 nvoiss1=nvoiss1+1
677 mwa(nvoiss1)=jk
678 ELSE
679 nvoiss2=nvoiss2+1
680 mwa(kvoisph+nvoiss2)=jk
681 ENDIF
682 ELSE ! particule symetrique de particule remote
683 nc=mod(-jk,nspcond+1)
684 m =-jk/(nspcond+1)
685 js=ispsymr(nc,m)
686 dj =xsphr(2,m)
687 xj =xspsym(1,js)
688 yj =xspsym(2,js)
689 zj =xspsym(3,js)
690 dms =two*dj
691 dms2=dms*dms
692 dd=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
693 IF (nint(xsphr(13,m))/=0.AND.dd<dms2) THEN
694 nvoiss1=nvoiss1+1
695 mwa(nvoiss1)=jk
696 ELSE
697 nvoiss2=nvoiss2+1
698 mwa(kvoisph+nvoiss2)=jk
699 ENDIF
700 END IF
701 ENDDO
702 kxsp(6,n)=nvoiss1
703 DO j=1,nvoiss1
704 ixsp(nvois2+j,n)=mwa(j)
705 ENDDO
706 DO j=1,nvoiss2
707 ixsp(nvois2+nvoiss1+j,n)=mwa(kvoisph+j)
708 ENDDO
709 ENDDO
710!$OMP END DO
711C-----------------------------------------------
712 RETURN
713 END
my_real
#define my_real
Definition cppsort.cpp:32
spclasv
subroutine spclasv(x, spbuf, kxsp, ixsp, nod2sp, ispsym, xspsym, wsp2sort, itask, myspatrue, ireduce, kreduce, lgauge, gauge, isortsp)
Definition spclasv.F:39
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
myqsort
subroutine myqsort(n, a, perm, error)
Definition myqsort.F:51
sph_struct_mod
Definition sph_struct_mod.F:30
sph_struct_mod::bool_sph_sort
logical, dimension(:), allocatable bool_sph_sort
Definition sph_struct_mod.F:34
sphbox::isphr
integer, dimension(:), allocatable isphr
Definition sphbox.F:87
sphbox::ispsymr
integer, dimension(:,:), allocatable ispsymr
Definition sphbox.F:93
sphbox::nsphr
integer nsphr
Definition sphbox.F:83
spmd_allglob_isum9
subroutine spmd_allglob_isum9(v, len)
Definition spmd_allglob_isum9.F:46
spmd_sphgeth
subroutine spmd_sphgeth(kxsp, spbuf)
Definition spmd_sph.F:1051
my_barrier
subroutine my_barrier
Definition machine.F:31