i23buce.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/.
!||====================================================================
!||    i23buce       ../engine/source/interfaces/intsort/i23buce.F
!||--- called by ------------------------------------------------------
!||    i23main_tri   ../engine/source/interfaces/intsort/i23main_tri.F
!||--- calls      -----------------------------------------------------
!||    ancmsg        ../engine/source/output/message/message.F
!||    arret         ../engine/source/system/arret.F
!||    i23trivox     ../engine/source/interfaces/intsort/i23trivox.F
!||--- uses       -----------------------------------------------------
!||    message_mod   ../engine/share/message_module/message_mod.F
!||    tri7box       ../engine/share/modules/tri7box.F
!||====================================================================
       SUBROUTINE i23buce(
     1   X        ,IRECT   ,NSV      ,INACTI  ,
     2   NRTM     ,NSN     ,CAND_E   ,CAND_N  ,GAP      ,
     3   NOINT   ,II_STOK  ,TZINF    , MAXBOX ,MINBOX   ,
     4   NCONTACT,NB_N_B   ,ESHIFT   ,CAND_P  ,NCONT    ,
     6   ILD     ,WEIGHT   ,STFN    ,NIN      ,
     7   STF      ,IGAP    ,GAP_S    ,GAPMIN  ,GAPMAX   ,
     8   ICURV    ,NUM_IMP ,ITASK    ,
     9   I_MEM    ,MSR     ,GAP_M    ,NSNR     ,CURV_MAX,
     A   RENUM    ,NSNROLD ,IFPEN   ,MWAG     ,BMINMA   ,
     B   NMN      ,IRECTG  ,BGAPSMX ,INTHEAT,IDT_THERM,NODADT_THERM)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE tri7box
      USE message_mod
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      "units_c.inc"
#include      "warn_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NRTM, NSN, NOINT, INACTI, NIN, NSNR, NSNROLD, NMN, ITASK
      INTEGER IRECT(4,*), NSV(*), NUM_IMP, IRECTG(4,*)
      INTEGER CAND_E(*),CAND_N(*),MSR(*),MWAG(*),RENUM(*),IFPEN(*)
      INTEGER NCONTACT,ESHIFT,ILD,NB_N_B, I_MEM,IGAP,ICURV,NCONT,
     .        WEIGHT(*),II_STOK
      INTEGER, INTENT(IN) :: INTHEAT
      INTEGER, INTENT(IN) :: IDT_THERM
      INTEGER, INTENT(IN) :: NODADT_THERM
C     REAL
      my_real
     .   gap,tzinf,maxbox,minbox,
     .   gapmin, gapmax, bminma(6),curv_max(nrtm), bgapsmx
      my_real
     .   x(3,*), stfn(*), stf(*), gap_s(*), gap_m(*),
     .   cand_p(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I_ADD_MAX
      parameter(i_add_max = 1001)
C
      INTEGER I, I_ADD, IP0, IP1, MAXSIZ, 
     . add(2,i_add_max), isznsnr
C     REAL
      my_real
     .        xyzm(6,i_add_max-1), marge, aaa
C-----------------------------------------------
C     PROV
C-----------------------------------------------
cc      INTEGER INIVOXEL, VOXEL(LVOXEL),NBX,NBY,NBZ
c      INTEGER INIVOXEL, VOXEL(1),NBX,NBY,NBZ
cc      SAVE INIVOXEL, VOXEL
cc      DATA INIVOXEL /1/
      INTEGER NBX,NBY,NBZ
      INTEGER (KIND=8) :: NBX8,NBY8,NBZ8,RES8,LVOXEL8
 
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C
C----- sorting of elements and nodes by boxes
C
C-----------------------------------------------
C if there is not enough memory for the stacks, the sorting is restarted
C by increasing nb_n_b (number of nodes per finished box)
C     POINTEUR  NOM                 TAILLE
C     p0........                    nsn + 3 [+ nsnrold in the case of spmd]
C     P1........Elt Bas Pile        NRTM
C     P2........Elt PILE            2*NRTM
C     P21.......BPN                 NSN
C     P22.......PN                  NSN
C     P31.......ADDI                2*I_ADD_MAX
      maxsiz = 3*(nrtm+100)
C 
      ip0 = 1
      ip1 = ip0 + nsn + nsnrold + 3
C
C-----initialization of addresses and x, y, z
C
C     ADDE     ADDN     X      Y      Z
C     1        1        XMIN   YMIN   ZMIN
C     1        1        XMAX   YMAX   ZMAX
C
      add(1,1) = 0
      add(2,1) = 0
      add(1,2) = 0
      add(2,2) = 0
      i_add = 1
C
C----- BORNES DU DOMAINE DEJA CALCULEES
C
      xyzm(1,i_add) = bminma(4)
      xyzm(2,i_add) = bminma(5)
      xyzm(3,i_add) = bminma(6)
      xyzm(4,i_add) = bminma(1)
      xyzm(5,i_add) = bminma(2)
      xyzm(6,i_add) = bminma(3)
      i_mem = 0
C
      isznsnr = nsnr
C
C-----start of the sorting phase
C
C       SEPARER B ET N EN TWO
C
       marge = tzinf - sqrt(three)*gap
c      CALL I23TRI(
c     1   ADD      ,NSN      ,IRECT   ,X         ,STF      ,
c     2   STFN     ,XYZM     ,I_ADD   ,MAXSIZ    ,II_STOK  ,
c     3   CAND_N   ,CAND_E  ,NCONTACT  ,NOINT    ,TZINF    ,
c     4   MAXBOX   ,MINBOX  ,I_MEM     ,NB_N_B   ,I_ADD_MAX,
c     5   ESHIFT   ,INACTI  ,NRTM      ,IGAP     ,GAP      ,
c     6   GAP_S    ,GAPMIN  ,GAPMAX    ,MARGE    ,CURV_MAX ,
c     7   DEPTH   ,DRAD     ,MSR      ,GAP_M    ,
c     8   RENUM    ,NSNR     ,ISZNSNR  ,NSNROLD  ,MWAG(IP0),
c     9   IFPEN    ,CAND_P   ,NSV      ,ITAGP    ,IRECTG   )
 
 
      aaa = sqrt(nmn /
     .           ((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) THEN
        nbx = min(100,max(nbx8,1))
        nby = min(100,max(nby8,1))
        nbz = min(100,max(nbz8,1))
      ENDIF
 
C     complete initialization of voxel
C (in // SMP there is possibility of processing redundancy but 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)
 
      CALL i23trivox(
     1   nsn     ,renum    ,nsnr     ,isznsnr  ,i_mem   ,
     2   irect   ,x        ,stf      ,stfn     ,xyzm    ,
     3   nsv     ,ii_stok  ,cand_n   ,eshift   ,cand_e  ,
     4   ncontact,noint    ,tzinf    ,msr      ,
     5   voxel1  ,nbx      ,nby      ,nbz     ,
     6   inacti  ,mwag(ip0),cand_p   ,ifpen   ,
     7   nrtm    ,nsnrold  ,igap     ,gap      ,gap_s   ,
     8   gap_m   ,gapmin   ,gapmax   ,marge    ,curv_max,
     9   nin     ,itask    ,bgapsmx  ,intheat,idt_therm,nodadt_therm)
 
C
C     I_MEM = 1 ==> PAS ASSEZ DE MEMOIRE PILE
C     I_MEM = 2 ==> PAS ASSEZ DE MEMOIRE CANDIDATES
C     I_MEM = 3 ==> TROP NIVEAUX PILE 
      IF (i_mem ==2) RETURN
      IF(i_mem==1)THEN
        nb_n_b = nb_n_b + 1
        IF ( nb_n_b > nsn) THEN
          IF (istamping == 1)THEN
            CALL ancmsg(msgid=101,anmode=aninfo,
     .                  i1=noint,i2=noint)
          ELSE
            CALL ancmsg(msgid=85,anmode=aninfo,
     .                  i1=noint)
          ENDIF
          CALL arret(2)
        ENDIF
        ild = 1
      ELSEIF(i_mem==2) THEN
        IF(debug(1)>=1) THEN
          iwarn = iwarn+1
#include "lockon.inc"
          WRITE(istdo,*)' **WARNING INTERFACE/MEMORY'
          WRITE(iout,*)' **WARNING INTERFACE NB:',noint
          WRITE(iout,*)'       TOO MANY POSSIBLE IMPACTS'
          WRITE(iout,*)'       SIZE OF INFLUENCE ZONE IS'
          WRITE(iout,*)'       MULTIPLIED BY 0.75'
#include "lockoff.inc"
        ENDIF
        RETURN
        tzinf = three_over_4*tzinf
C unconassed gearbox size
C        MINBOX= THREE_OVER_4*MINBOX
C        MAXBOX= THREE_OVER_4*MAXBOX
        IF( tzinf<=gap ) THEN
          CALL ancmsg(msgid=98,anmode=aninfo,
     .            i1=noint,c1='(I23BUCE)')
          CALL arret(2)
        ENDIF
        ild = 1
      ELSEIF(i_mem==3)THEN
        nb_n_b = nb_n_b + 1
        IF ( nb_n_b > ncont) THEN
          CALL ancmsg(msgid=100,anmode=aninfo,
     .            i1=noint)
          CALL arret(2)
        ENDIF
        ild = 1
      ENDIF
C
      RETURN
      END