spclasv.F File Reference

#include "implicit_f.inc"
#include "sphcom.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	spclasv (x, spbuf, kxsp, ixsp, nod2sp, waspact, myspatrue, ireduce, kreduce)

Function/Subroutine Documentation

spclasv()

subroutine spclasv	(		x,
			spbuf,
		integer, dimension(nisp,*)	kxsp,
		integer, dimension(kvoisph,*)	ixsp,
		integer, dimension(*)	nod2sp,
		integer, dimension(*)	waspact,
			myspatrue,
		integer	ireduce,
		integer, dimension(*)	kreduce )

Definition at line 30 of file spclasv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "sphcom.inc"
C-----------------------------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER KXSP(NISP,*),IXSP(KVOISPH,*),NOD2SP(*),
     .        WASPACT(*), IREDUCE, KREDUCE(*)
      my_real
     .   x(3,*),spbuf(nspbuf,*), myspatrue
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer
     .   n,inod,jnod,j,nvois,m,ncand,k1,k2,nvois1,nvois2,
     .   nvoiss,nvoiss1,nvoiss2, iaux, ierror,
     .   k, l, jk, nc, js, ns, nn, nb,jj1,jj2, jj, jjj,
     .   mwa(2*kvoisph),jstor(kvoisph), jperm(kvoisph),
     .   lvoired, ig
      my_real
     .       dms,dms2,dk,
     .       xi,yi,zi,di,xj,yj,zj,dj,dd,dvois(kvoisph),
     .       dwa(numsph)
      SAVE lvoired
C-----------------------------------------------
C       force sorting for domain decomposition
        DO ns=1,nsphact
         n=waspact(ns)
         inod=kxsp(3,n)
         xi=x(1,inod)
         yi=x(2,inod)
         zi=x(3,inod)
         di=spbuf(1,n)
         nvois=kxsp(5,n)
         DO k=1,nvois
           jnod = ixsp(k,n)
           m =nod2sp(jnod)
           xj=x(1,jnod)
           yj=x(2,jnod)
           zj=x(3,jnod)
           dj=spbuf(1,m)
           dms =di+dj
           dms2=dms*dms
           dvois(k)=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
           dvois(k)=dvois(k)/dms2
         END DO
C
         CALL myqsort(nvois,dvois,jperm,ierror)
         DO k=1,nvois
           jstor(k) = ixsp(k,n)
         END DO
C
         k1=0
         DO k=1,nvois
           jk=jstor(jperm(k))
           k1=k1+1
           ixsp(k1,n) = jk
         END DO
C
C--- Closest neighbor is stored for tensile instability treatment --
C
         IF (nspbuf==15) THEN
           spbuf(15,n)=two*sqrt(dvois(1))
         ENDIF
C
        END DO
C-----------------------------------------------
        lvoired = 0
        IF(ireduce==0)GO TO 100
C-------------------------------------------
C       tri voisins / ne garder que LVOISPH voisins effectifs
C
        DO ns=1,nsphact
         n=waspact(ns)
         dwa(n)=one
         nvois1 =kxsp(4,n)
         IF(kreduce(n)/=0.OR.nvois1>lvoisph)THEN
C
           IF(nvois1>lvoisph)THEN
             kreduce(n)=kreduce(n)+10
             lvoired = 1
           END IF
C
           inod=kxsp(3,n)
           xi=x(1,inod)
           yi=x(2,inod)
           zi=x(3,inod)
           di=spbuf(1,n)
           nvois=kxsp(5,n)
           DO k=1,nvois
             jnod = ixsp(k,n)
             m =nod2sp(jnod)
             xj=x(1,jnod)
             yj=x(2,jnod)
             zj=x(3,jnod)
             dj=spbuf(1,m)
             dms =di+dj
             dms2=dms*dms
             dvois(k)=(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
             dvois(k)=dvois(k)/dms2
           END DO
C
           CALL myqsort(nvois,dvois,jperm,ierror)
           DO k=1,nvois
             jstor(k) = ixsp(k,n)
           END DO
C
           IF(kreduce(n) >= 10)dwa(n)=sqrt(dvois(lvoisph))
C
           k1=0
           DO k=1,nvois
             jk=jstor(jperm(k))
             k1=k1+1
             ixsp(k1,n) = jk
           END DO
C
         END IF
        END DO
C-------------------------------------------
C adapte diametre (reduction only) 
C
        IF(lvoired /= 0)THEN
C
          DO ns=1,nsphact
           n=waspact(ns)
           spbuf(1,n)=min(spbuf(1,n),dwa(n)*spbuf(1,n))
           spbuf(8,n)=spbuf(1,n)
          END DO
        END IF
C
        DO ns=1,nsphact
         n=waspact(ns)
C
         IF(mod(kreduce(n),10)/=0)THEN
C
           nvois1 =kxsp(4,n)
           nvois  =kxsp(5,n)
           inod=kxsp(3,n)
           xi=x(1,inod)
           yi=x(2,inod)
           zi=x(3,inod)
           di=spbuf(1,n)
C
           jnod = ixsp(nvois,n)
           m =nod2sp(jnod)
           xj=x(1,jnod)
           yj=x(2,jnod)
           zj=x(3,jnod)
           dj=spbuf(1,m)
           dd  =(xi-xj)*(xi-xj)+(yi-yj)*(yi-yj)+(zi-zj)*(zi-zj)
           dms =di+dj
           dms2=dms*dms
           dk=dd/dms2
           myspatrue=max(zero,min(myspatrue,dk-one))
         END IF
C
       END DO
C-------------------------------------------
 100   CONTINUE
C-----------------------------------------------
      RETURN