sphtri0.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/.
!||====================================================================
!||    sphtri0         ../engine/source/elements/sph/sphtri0.F
!||--- called by ------------------------------------------------------
!||    sphprep         ../engine/source/elements/sph/sphprep.F
!||--- calls      -----------------------------------------------------
!||    my_barrier      ../engine/source/system/machine.F
!||    spmd_all_dmax   ../engine/source/mpi/elements/spmd_sph.F
!||    spmd_barrier    ../engine/source/mpi/spmd_mod.F90
!||    spmd_sphvox     ../engine/source/mpi/sph/spmd_sphvox.F
!||    spmd_sphvox0    ../engine/source/mpi/elements/spmd_sph.F
!||    startime        ../engine/source/system/timer_mod.f90
!||    stoptime        ../engine/source/system/timer_mod.F90
!||--- uses       -----------------------------------------------------
!||    spmd_mod        ../engine/source/mpi/spmd_mod.F90
!||    timer_mod       ../engine/source/system/timer_mod.F90
!||    tri7box         ../engine/share/modules/tri7box.f
!||====================================================================
      SUBROUTINE sphtri0(TIMERS, X   , SPBUF, KXSP, WSP2SORT,BMINMA , DMAX,
     2                 NSP2SORTF,NSP2SORTL,NMN,ITASK, DBUC)  
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE spmd_mod, ONLY : spmd_barrier
      USE timer_mod
      USE tri7box
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "sphcom.inc"
#include      "task_c.inc"
#include      "timeri_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE(timer_), INTENT(INOUT) :: TIMERS
      INTEGER KXSP(NISP,*), WSP2SORT(*),NSP2SORTF,NSP2SORTL,ITASK,NMN
      my_real x(3,*),spbuf(nspbuf,*), bminma(12),  dmax, dbuc
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER N, J, NS,LOC_PROC
      my_real xmax,ymax,zmax,xmin,ymin,zmin,dbucl,mx,my,mz,dx,dy,dz,sx,sy,sz,sx2,sy2,sz2
     
C-----------------------------------------------
      xmin=ep30
      xmax=-ep30
      ymin=ep30
      ymax=-ep30
      zmin=ep30
      zmax=-ep30     
      sx=zero
      sy=zero
      sz=zero
      sx2=zero
      sy2=zero
      sz2=zero
C        
C
C        Bucket sort. DBUC + MIN / MAX
 
      dbucl=zero
      DO ns=nsp2sortf,nsp2sortl
        n=wsp2sort(ns)
        dbucl=max(dbucl,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))
        sx=sx+x(1,j)
        sy=sy+x(2,j)
        sz=sz+x(3,j)
        sx2=sx2+x(1,j)**2
        sy2=sy2+x(2,j)**2
        sz2=sz2+x(3,j)**2
      END DO
 
      IF(itask == 0)THEN
         bminma(7:12)=0
         bminma(1)=-ep30
         bminma(2)=-ep30
         bminma(3)=-ep30
         bminma(4)=ep30
         bminma(5)=ep30
         bminma(6)=ep30
         dbuc = zero
      ENDIF
 
      CALL my_barrier
 
#include "lockon.inc"
      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)
      dbuc = max(dbuc,dbucl) 
      dmax = dbuc
      bminma(7) = bminma(7)+sx
      bminma(8) = bminma(8)+sy
      bminma(9) = bminma(9)+sz
      bminma(10)= bminma(10)+sx2
      bminma(11)= bminma(11)+sy2
      bminma(12)= bminma(12)+sz2
#include "lockoff.inc"
C
      CALL my_barrier
 
!$OMP SINGLE
        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   Computation of standard deviation of X main
C   use the formula dev = sum(xi  )-n.m  
C   mean value m by direction
        mx=bminma(7)/max(nmn,1)
        my=bminma(8)/max(nmn,1)
        mz=bminma(9)/max(nmn,1)
c          print*,noint,'m=',mx,my,mz,NMN,NRTM
C   standard deviation by direction
        dx=sqrt(bminma(10)/max(nmn,1)-mx**2)
        dy=sqrt(bminma(11)/max(nmn,1)-my**2)
        dz=sqrt(bminma(12)/max(nmn,1)-mz**2)
c          print*,noint,'var=',dx,dy,dz
C   Computation of new boundary of the domain mean values +/- 2 sigma
C   => 95% of the population for normal distribution
        bminma(7) =min(mx+2*dx,bminma(1))
        bminma(8) =min(my+2*dy,bminma(2))
        bminma(9) =min(mz+2*dz,bminma(3))
        bminma(10)=max(mx-2*dx,bminma(4))
        bminma(11)=max(my-2*dy,bminma(5))
        bminma(12)=max(mz-2*dz,bminma(6))
   
C   Test cas particulier 2D
        IF(bminma(10)==bminma(7))THEN
          bminma(10)=bminma(4)
          bminma(7)=bminma(1)
        END IF
        IF(bminma(11)==bminma(8))THEN
          bminma(11)=bminma(5)
          bminma(8)=bminma(2)
        END IF
        IF(bminma(12)==bminma(9))THEN
          bminma(12)=bminma(6)
          bminma(9)=bminma(3)
        END IF
!$OMP END SINGLE
                
 
      IF(nspmd>1) THEN
C
C     Boite   MIN / MAX en SPMD
C
        IF(itask==0) THEN
          loc_proc = ispmd+1
          crvoxel(0:lrvoxel,0:lrvoxel,loc_proc)=0
        ENDIF
 
        CALL my_barrier
 
        CALL spmd_sphvox0(kxsp ,spbuf,wsp2sort,bminma,x,
     2                    nsp2sortf,nsp2sortl)
 
        CALL my_barrier
 
        IF(itask==0)THEN
C
         IF(imonm == 2)THEN
           CALL startime(timers,95)
           CALL spmd_barrier()
           CALL stoptime(timers,95)
         END IF
         CALL startime(timers,91)
C Recuperation des cellules SPH remotes NSPHR stockees dans XSPHR
C 
         CALL spmd_sphvox(kxsp ,spbuf,wsp2sort,bminma,x)
         CALL spmd_all_dmax(dmax,1)
C
         CALL stoptime(timers,91)
        ENDIF
 
      END IF 
  
      CALL my_barrier
C
      RETURN
      END