sptri.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
 
!||====================================================================
!||    mod_sptri   ../starter/source/elements/sph/sptri.F
!||--- called by ------------------------------------------------------
!||    sptri       ../starter/source/elements/sph/sptri.F
!||====================================================================
      module mod_sptri
      implicit none
      INTEGER, DIMENSION(:), ALLOCATABLE :: wreduce
      END MODULE mod_sptri
 
!||====================================================================
!||    sptri         ../starter/source/elements/sph/sptri.F
!||--- called by ------------------------------------------------------
!||    lectur        ../starter/source/starter/lectur.F
!||    spinih        ../starter/source/elements/sph/spinih.F
!||--- calls      -----------------------------------------------------
!||    ancmsg        ../starter/source/output/message/message.F
!||    arret         ../starter/source/system/arret.F
!||    spbuc31       ../starter/source/elements/sph/spbuc31.F
!||    spclasv       ../starter/source/elements/sph/spclasv.F
!||--- uses       -----------------------------------------------------
!||    message_mod   ../starter/share/message_module/message_mod.F
!||    mod_sptri     ../starter/source/elements/sph/sptri.F
!||====================================================================
      SUBROUTINE sptri(KXSP,IXSP,NOD2SP,X,SPBUF,
     .                 LPRTSPH,LONFSPH,IPARTSP,SZ_INTP_DIST,MAX_INTP_DIST_PART,
     .                 PRE_SEARCH)
C-----------------------------------------------
      USE message_mod
      USE mod_sptri
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      "com04_c.inc"
#include      "sphcom.inc"
#include      "buckr_c.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-----------------------------------------------
      INTEGER KXSP(NISP,*), IXSP(KVOISPH,*), NOD2SP(*),
     .        LPRTSPH(2,0:NPART) ,LONFSPH(*)
      INTEGER ,INTENT(IN) :: IPARTSP(NUMSPH),PRE_SEARCH,SZ_INTP_DIST
      my_real
     .        spbuf(nspbuf,*), x(3,*)
      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 N,J,K, IREDUCE, NVOIS, IERROR,JVOIS(NUMSPH), JSTOR(NUMSPH), JPERM(NUMSPH)
      INTEGER NS, WASPACT(NUMSPH), IPRT
      my_real dvois(numsph), bminma(6), myspatrue,xmax, ymax, zmax
C-----------------------------------------------
      nvois = 0
C-----------------------------------------------      
      ALLOCATE(wreduce(numsph),stat=ierror)
      IF(ierror/=0) THEN
        CALL ancmsg(msgid=19,msgtype=msgerror,anmode=aninfo,
     .              c1='(SPH)')
        CALL arret(2)
      END IF
      ireduce=0
      wreduce(1:numsph)=0
C-----------------------------------------------      
      IF(nsphio==0)THEN
        nsphact=0
        DO n=1,numsph
          IF(kxsp(2,n)/=0)THEN
            nsphact=nsphact+1
            waspact(nsphact)=n
          ENDIF
        ENDDO
      ELSE
        nsphact=0
        DO iprt=1,npart
          DO k=lprtsph(2,iprt-1)+1,lprtsph(1,iprt)
           nsphact=nsphact+1
           waspact(nsphact)=lonfsph(k)
          ENDDO
        ENDDO
      END IF
C
      DO ns=1,nsphact
        n=waspact(ns)
        kxsp(5,n)=0
      END DO
C-----------------------------------------------
      bminma(1) = -ep30
      bminma(2) = -ep30 
      bminma(3) = -ep30
      bminma(4) =  ep30
      bminma(5) =  ep30
      bminma(6) =  ep30
C
      xmin=ep30
      xmax=-ep30
      ymin=ep30
      ymax=-ep30
      zmin=ep30
      zmax=-ep30     
C
C        Bucket sort. DBUC + MIN / MAX
C
      dbuc=zero
      DO ns=1,nsphact
        n=waspact(ns)
        dbuc=max(dbuc,spbuf(1,n))
C
        j=kxsp(3,n)
        xmin= min(xmin,x(1,j))
        ymin= min(ymin,x(2,j))
        zmin= min(zmin,x(3,j))
        xmax= max(xmax,x(1,j))
        ymax= max(ymax,x(2,j))
        zmax= max(zmax,x(3,j))
      END DO
C
      bminma(1) = max(bminma(1),xmax) 
      bminma(2) = max(bminma(2),ymax) 
      bminma(3) = max(bminma(3),zmax) 
      bminma(4) = min(bminma(4),xmin) 
      bminma(5) = min(bminma(5),ymin) 
      bminma(6) = min(bminma(6),zmin)
C
      dbuc=dbuc*sqrt(one +spatrue)*onep0001
      bminma(1) = bminma(1)+dbuc
      bminma(2) = bminma(2)+dbuc
      bminma(3) = bminma(3)+dbuc
      bminma(4) = bminma(4)-dbuc
      bminma(5) = bminma(5)-dbuc
      bminma(6) = bminma(6)-dbuc
C-----------------------------------------------
      CALL spbuc31(x      ,kxsp  ,ixsp  ,nod2sp,
     .             spbuf  ,waspact,jvois,jstor ,jperm  ,
     .             dvois  ,ireduce,wreduce,bminma,ipartsp ,
     .             sz_intp_dist,max_intp_dist_part,pre_search)
C-----------------------------------------------
C     re-tri voisins (voisins vrais, voisins dans la zone de securite).
C
      IF (pre_search==0) THEN
      myspatrue=spatrue
C     /---------------/
C      CALL MY_BARRIER
C     /---------------/
      CALL spclasv(x     ,spbuf ,kxsp    ,ixsp   ,nod2sp   ,
     1             waspact,myspatrue,ireduce,wreduce)
C     /---------------/
C      CALL MY_BARRIER
C     /---------------/
      IF(myspatrue<spatrue)spatrue=myspatrue
      ELSE     
        DEALLOCATE(wreduce)       
      ENDIF
 
      RETURN
      END