spbuc31.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	spbuc31 (x, kxsp, ixsp, nod2sp, spbuf, ma, jvois, jstor, jperm, dvois, ireduce, kreduce, bminma, ipartsp, sz_intp_dist, max_intp_dist_part, pre_search)
subroutine	sppro31 (il, kxsp, ixsp, nod2sp, jvois, jstor, jperm, dvois, ireduce, kreduce)

Function/Subroutine Documentation

spbuc31()

subroutine spbuc31	(		x,
		integer, dimension(nisp,*)	kxsp,
		integer, dimension(kvoisph,*)	ixsp,
		integer, dimension(*)	nod2sp,
			spbuf,
		integer, dimension(nsphact)	ma,
		integer, dimension(*)	jvois,
		integer, dimension(*)	jstor,
		integer, dimension(*)	jperm,
			dvois,
		integer	ireduce,
		integer, dimension(*)	kreduce,
			bminma,
		integer, dimension(numsph), intent(in)	ipartsp,
		integer, intent(in)	sz_intp_dist,
		dimension(sz_intp_dist), intent(inout)	max_intp_dist_part,
		integer, intent(in)	pre_search )

Definition at line 32 of file spbuc31.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE tri7box
C-----------------------------------------------
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     PRE_SEARCH = 0 -> full search of neigbours 
C     PRE_SEARCH = 1 -> pre-search of neigbours for computation of max interparticle dist 
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
C     REAL
      INTEGER KXSP(NISP,*), IXSP(KVOISPH,*), NOD2SP(*),
     .        JVOIS(*), JSTOR(*), JPERM(*), IREDUCE, MA(NSPHACT),
     .        KREDUCE(*)
      INTEGER ,INTENT(IN) :: IPARTSP(NUMSPH),PRE_SEARCH,SZ_INTP_DIST
C     REAL
      my_real
     .        x(3,*),spbuf(nspbuf,*),dvois(*), bminma(6)
      my_real ,INTENT(INOUT) :: max_intp_dist_part(sz_intp_dist)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, NSPHACTF, NSPHACTL
C     REAL
      my_real
     .        aaa
      INTEGER NBX,NBY,NBZ
      INTEGER (KIND=8) :: NBX8,NBY8,NBZ8,RES8,LVOXEL8
C-----------------------------------------------
 
      aaa = sqrt(nsphact /
     .           ((bminma(1)-bminma(4))*(bminma(2)-bminma(5))
     .           +(bminma(2)-bminma(5))*(bminma(3)-bminma(6))
     .           +(bminma(3)-bminma(6))*(bminma(1)-bminma(4))))
 
      aaa = 0.75*aaa
              
      nbx = nint(aaa*(bminma(1)-bminma(4)))
      nby = nint(aaa*(bminma(2)-bminma(5)))
      nbz = nint(aaa*(bminma(3)-bminma(6)))
      nbx = max(nbx,1)
      nby = max(nby,1)
      nbz = max(nbz,1)
 
      nbx8=nbx
      nby8=nby
      nbz8=nbz
      res8=(nbx8+2)*(nby8+2)*(nbz8+2)
      lvoxel8 = lvoxel      
 
      IF(res8 > lvoxel8) THEN
        aaa = lvoxel
        aaa = aaa/((nbx8+2)*(nby8+2)*(nbz8+2))
        aaa = aaa**(third)
        nbx = int((nbx+2)*aaa)-2
        nby = int((nby+2)*aaa)-2
        nbz = int((nbz+2)*aaa)-2
        nbx = max(nbx,1)
        nby = max(nby,1)
        nbz = max(nbz,1)
      ENDIF
      
      nbx8=nbx
      nby8=nby
      nbz8=nbz
      res8=(nbx8+2)*(nby8+2)*(nbz8+2)
      
      IF(res8 > lvoxel8) stop 678  
 
C     initialisation complete de VOXEL
C (en // SMP il y a possibilite de redondance de traitement mais no pb)
      DO i=inivoxel,(nbx+2)*(nby+2)*(nbz+2)
        voxel1(i)=0
      ENDDO
      inivoxel = max(inivoxel,(nbx+2)*(nby+2)*(nbz+2)+1)
 
c      CALL MY_BARRIER fait dans SPTRIVOX
C--------------------------------------------------
C     VOXEL SORT
C--------------------------------------------------
      nsphactf=1
      nsphactl=nsphact
      CALL sptrivox(
     1      nsphact ,x       ,bminma  ,nod2sp ,
     2      nbx     ,nby    ,nbz     ,
     3      ma      ,spbuf  ,jvois   ,jstor   ,jperm  ,
     4      dvois   ,ireduce,nsphactf,nsphactl,voxel1 ,
     5      kxsp    ,ixsp   ,kreduce ,ipartsp ,sz_intp_dist,
     6      max_intp_dist_part,pre_search)
C
      RETURN

sppro31()

subroutine sppro31	(	integer	il,
		integer, dimension(nisp,*)	kxsp,
		integer, dimension(kvoisph,*)	ixsp,
		integer, dimension(*)	nod2sp,
		integer, dimension(*)	jvois,
		integer, dimension(*)	jstor,
		integer, dimension(*)	jperm,
			dvois,
		integer	ireduce,
		integer, dimension(*)	kreduce )

Definition at line 143 of file spbuc31.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "mvsiz_p.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(*),
     .   JVOIS(*),JSTOR(*), JPERM(*), IREDUCE, KREDUCE(*)
C     REAL
      my_real
     .   dvois(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER J, KB, JB, NSBT, IB, IL, MM1, MM2, KM, MM, MG,
     .   JJL, NFT, LLT, JL, JG, JLO, LL1, LL2, LL, LG, N, NN,
     .   NVOIS, KL, K, JK, L, NVOIS1, NVOIS2, IERROR , ig
C     REAL
      my_real
     .   xjj, yjj, zjj,dk, dl   
 
 
C-----------------
C     TRI DE LA LISTE, GARDE LES KVOISPH PREMIERS 
C     (COEF DE SECURITE CROISSANT).
C-----------------
      nvois=kxsp(5,il)
      IF(nvois>kvoisph)THEN
 
        ireduce    =1 
        kreduce(il)=1 
        CALL myqsort(nvois,dvois,jperm,ierror)
        DO k=1,nvois
         jstor(k)=jvois(k)
        ENDDO
        DO k=1,kvoisph
         jvois(k)=jstor(jperm(k))
        ENDDO
 
        dk=dvois(kvoisph)
 
C-----------------
C Choix des cellules a conserver tq distance < DK pour eviter pb de parith/on
        nvois=0
        DO k=1,kxsp(5,il)
          IF(dvois(k)<dk)THEN
            nvois=nvois+1
          END IF
        END DO
 
      ENDIF
C-----------------
      nvois=min(nvois,kvoisph)
      kxsp(5,il)=nvois
      nvois1=0
      nvois2=nvois
      DO k=1,nvois
       jk       =jvois(k)
       dk       =dvois(k)
 
       jg       =kxsp(3,jk)
 
       IF(dk<one)THEN
        nvois1=nvois1+1
        ixsp(nvois1,il)=jg
       ELSE
        ixsp(nvois2,il)=jg
        nvois2=nvois2-1
       ENDIF
      ENDDO
      kxsp(4,il)=nvois1
C
      IF(nvois1>lvoisph)ireduce=1
C-----------------------------------------------------------
C
      RETURN