i23tri.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/.
!||====================================================================
!||    i23tri                 ../starter/source/interfaces/inter3d1/i23tri.F
!||--- called by ------------------------------------------------------
!||    i23buc1                ../starter/source/interfaces/inter3d1/i23buc3.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    i23cor3t               ../starter/source/interfaces/inter3d1/i23cor3t.F
!||    i7cmp3                 ../starter/source/interfaces/inter3d1/i7cmp3.F
!||    i7dst3                 ../starter/source/interfaces/inter3d1/i7dst3.F
!||    i7dstk                 ../starter/source/interfaces/inter3d1/i7dstk.F
!||    i7pen3                 ../starter/source/interfaces/inter3d1/i7pen3.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE i23tri(
     1      BPE    ,PE    ,BPN   ,PN    ,ADD   ,
     2      IRECT  ,X     ,NB_NC ,NB_EC ,XYZM  ,
     3      I_ADD  ,NSV   ,I_AMAX,XMAX  ,YMAX  ,
     4      ZMAX   ,MAXSIZ,I_STOK,I_MEM ,NB_N_B,
     5      CAND_N ,CAND_E,NSN   ,NOINT ,TZINF ,
     6      MAXBOX ,MINBOX,J_STOK,MSR   ,
     7      MULTIMP,ITAB  ,GAP   ,GAP_S ,IGAP  ,
     8      GAPMIN,GAPMAX,MARGE  ,ID    ,TITR  ,
     9      GAP_M ,PROV_N,PROV_E ,IX1,IX2,
     1      IX3   ,IX4   ,NSVG   ,X1 ,X2 ,
     2      X3    ,X4    ,Y1     ,Y2 ,Y3 ,
     3      Y4    ,Z1    ,Z2     ,Z3 ,Z4 ,
     4      XI    ,YI    ,ZI     ,X0 ,Y0 ,
     5      Z0    ,NX1   ,NY1    ,NZ1,NX2,
     6      NY2   ,NZ2   ,NX3    ,NY3,NZ3,
     7      NX4   ,NY4   ,NZ4    ,P1 ,P2 ,
     8      P3    ,P4    ,LB1    ,LB2,LB3,
     9      LB4   ,LC1   ,LC2    ,LC3,LC4,
     1      N11   ,N21   ,N31    ,PENE)
      USE message_mod
      USE names_and_titles_mod , ONLY : nchartitle
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      "com01_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "vect07_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NB_NC,NB_EC,I_ADD,MAXSIZ,I_STOK,J_STOK,I_MEM
      INTEGER I_BID, I_AMAX,NB_N_B, NOINT, NSN,MULTIMP, IGAP
      INTEGER ADD(2,0:*),IRECT(4,*),BPE(*),PE(*),BPN(*),PN(*)
      INTEGER NSV(*),CAND_N(*),CAND_E(*), ITAB(*), MSR(*)
C     REAL
      my_real
     .   X(3,*),XYZM(6,*),TZINF,
     .   MAXBOX,MINBOX, XMAX, YMAX, ZMAX,
     .   GAP, GAP_S(*), GAP_M(*),
     .   GAPMIN, GAPMAX, MARGE, GAPSMX, BGAPSMX
      INTEGER ID
      CHARACTER(LEN=NCHARTITLE) :: TITR
      INTEGER, DIMENSION(MVSIZ), INTENT(INOUT) ::PROV_N,PROV_E
      INTEGER, DIMENSION(MVSIZ), INTENT(INOUT) :: IX1,IX2,IX3,IX4,NSVG
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: X1,X2,X3,X4
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: Y1,Y2,Y3,Y4
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: Z1,Z2,Z3,Z4
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: XI,YI,ZI
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: X0,Y0,Z0
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: n11,n21,n31,pene
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx1,ny1,nz1
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx2,ny2,nz2
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx3,ny3,nz3
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: nx4,ny4,nz4
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: p1,p2,p3,p4
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: lb1,lb2,lb3,lb4
      my_real, DIMENSION(MVSIZ), INTENT(INOUT) :: lc1,lc2,lc3,lc4
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NB_NCN, NB_ECN, ADDNN, ADDNE, I, J
      INTEGER INF,SUP,DIR,N1,N2,N3,N4,NN,NE
C     REAL
      my_real
     .   dx,dy,dz,dsup,seuil,xmx,xmn,
     .   gapv(mvsiz)
C-----------------------------------------------
C   Role of the routine:
C   ===================
C   Classifies the elements of BPE and the nodes of BPN into two zones
C   > or < to a boundary determined here and outputs everything
C   Into bpe, hpe, and bpn, hpn
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C
C     NOM          DESCRIPTION                       E/S
C
C     BPE          ARRAY OF FACETTES TO SORT      E/S
C                  And the result on the max side
C     PE           ARRAY OF FACETTES              S
C                  RESULTAT COTE MIN
C     BPN          SORTED NODES ARRAY        E/S
C                  And the result on the max side
C     PN           NODES ARRAY S
C                  RESULTAT COTE MIN
C     ADD(2,*)     ARRAY OF ADRESSES              E/S 
C          1.......ADRESSES NODES C          2.......ADRESSES ELEMENTS
C     ZYZM(6,*)     ARRAY OF XYZMIN               E/S 
C          1.......XMIN BOITE
C          2.......YMIN BOITE
C          3.......ZMIN BOITE
C          4.......XMAX BOITE
C          5.......YMAX BOITE
C          6.......ZMAX BOITE
C     IRECT(4,*)   ARRAY OF CONEC FACETTES        E
C     X(3,*)       COORDONNEES NODALES               E
C     NB_NC        NUMBER OF CANDIDATE NODES        E/S
C     NB_EC        NUMBER OF CANDIDATE ELEMENTS           E/S
C     i_add position in the input/output address table
C     NSV          NOS SYSTEMES DES NODES E
C     Xmax larger abcisse existing e
C     XMAX largest order.existing E
C     Xmax larger existing side E
C     MAXSIZ       TAILLE MEMOIRE MAX POSSIBLE       E
C     i_stok storage level of the pairs
C                                CANDIDATES impact    E/S
C     CAND_N       boites resultats nodes C     CAND_E       adresses des boites resultat elements
C                  multimp*nsn current maximum allowed size for the
C                  COUPLES NODES,ELT CANDIDATES
C     NOINT        INTERFACE USER NUMBER
C     TZINF        TAILLE ZONE INFLUENCE
C     MAXBOX       TAILLE MAX BUCKET
C     MINBOX       TAILLE MIN BUCKET
C=======================================================================
C
C
C    1- TEST ARRET = BOITE VIDE
C                    BOITE TROP PETITE 
C                    BOITE NE CONTENANT QU'ONE NODE C                    No More Memory Available
C
C-----------------------------------------------------------
C
C      IF(MEMX>ADD(2,1)+NB_EC)THEN
C        WRITE(ISTDO,*)' *******MEM MAX=',MEMX
C        MEMX=-1
C      ELSEIF(MEMX/=-1)THEN
C        MEMX=ADD(2,1)+NB_EC
C      ENDIF
C--------------------test on empty boxes--------------
C
      IF(nb_ec==0.OR.nb_nc==0) THEN
C       write(6,*)" BOITE VIDE"
C       the bottoms of the stacks must be copied into the corresponding bas_de_pile
C       before descending again into the neighboring branch
        CALL i7dstk(i_add,nb_nc,nb_ec,add,bpn,pn,bpe,pe)
        RETURN
      ENDIF
C
C-------------------test on end of branch / memory exceeded------------
C
      dx = xyzm(4,i_add) - xyzm(1,i_add)
      dy = xyzm(5,i_add) - xyzm(2,i_add)
      dz = xyzm(6,i_add) - xyzm(3,i_add)
      dsup= max(dx,dy,dz)
C
      IF(add(2,1)+nb_ec>=maxsiz) THEN
C       no more space in the stack of elements, boxes too small
        IF ( nb_n_b == numnod) THEN
C          WRITE(IOUT,*)'***ERROR INFINITE LOOP DETECTED '
C          WRITE(ISTDO,*)'***ERROR INFINITE LOOP DETECTED '
C          CALL ARRET(2)
           IF (istamping == 1) THEN
             CALL ancmsg(msgid=775,
     .                   msgtype=msgerror,
     .                   anmode=aninfo,
     .                   i1=id,
     .                   c1=titr)
           ELSE
             CALL ancmsg(msgid=685,
     .                   msgtype=msgerror,
     .                   anmode=aninfo,
     .                   i1=id,
     .                   c1=titr)
           ENDIF
        ENDIF
        i_mem = 1
        RETURN
      ENDIF
      IF(dsup<minbox.OR.
     .   nb_nc<=nb_n_b.AND.dsup<maxbox.OR.   
     .   nb_nc<=nb_n_b.AND.nb_ec==1) THEN
C
C       write(6,*)" NOUVELLE BOITE "
C       1- storage of the candidate node(s) and the corresponding elements
C       remove the unnecessary ones
        DO 20 i=1,nb_ec
            ne = bpe(i)
            n1=irect(1,ne)
            n2=irect(2,ne) 
            n3=irect(3,ne) 
            n4=irect(4,ne) 
            DO 20 j=1,nb_nc
              nn=nsv(bpn(j))
              IF(nn/=n1.AND.nn/=n2.AND.nn/=n3.AND.nn/=n4) THEN
                j_stok = j_stok + 1
                prov_n(j_stok) = bpn(j)
                prov_e(j_stok) = ne
                IF(j_stok==nvsiz) THEN
                  lft = 1
                  llt = nvsiz
                  nft = 0
                  j_stok = 0
                  CALL i23cor3t(x    ,irect,nsv  ,prov_e ,prov_n,
     2                        gapv ,igap  ,gap   ,gap_s,gapmin ,
     3                        gapmax,msr  ,gap_m ,ix1     ,ix2    ,
     4                   ix3   ,ix4   ,nsvg  ,x1      ,x2     ,
     5                   x3    ,x4    ,y1    ,y2      ,y3     ,
     6                   y4    ,z1    ,z2    ,z3      ,z4     ,
     7                   xi    ,yi    ,zi    )
                  CALL i7dst3(ix3,ix4,x1 ,x2 ,x3 ,
     1                  x4 ,y1 ,y2 ,y3 ,y4 ,
     2                  z1 ,z2 ,z3 ,z4 ,xi ,
     3                  yi ,zi ,x0 ,y0 ,z0 ,
     4                  nx1,ny1,nz1,nx2,ny2,
     5                  nz2,nx3,ny3,nz3,nx4,
     6                  ny4,nz4,p1 ,p2 ,p3 ,
     7                  p4 ,lb1,lb2,lb3,lb4,
     8                  lc1,lc2,lc3,lc4,llt)
                  CALL i7pen3(marge,gapv,n11,n21,n31,
     1                  pene ,nx1 ,ny1,nz1,nx2,
     2                  ny2  ,nz2 ,nx3,ny3,nz3,
     3                  nx4  ,ny4 ,nz4,p1 ,p2 ,
     4                  p3   ,p4,llt)
                  IF(i_stok+nvsiz<multimp*nsn) THEN
                    CALL i7cmp3(i_stok,cand_e  ,cand_n,1,pene,
     1                  prov_n,prov_e)
                  ELSE
                    i_bid = 0
                    CALL i7cmp3(i_bid,cand_e,cand_n,0,pene,
     1                  prov_n,prov_e)
                    IF(i_stok+i_bid<multimp*nsn) THEN
                      CALL i7cmp3(i_stok,cand_e,cand_n,1,pene,
     1                  prov_n,prov_e)
                    ELSE
                      i_mem = 2
C                      WRITE(IOUT,*)' **INFO: INTERFACE NB:',NOINT
C                      WRITE(IOUT,*)'       TOO MANY POSSIBLE IMPACTS'
C                      WRITE(IOUT,*)'       SIZE OF INFLUENCE ZONE IS' 
C                      WRITE(IOUT,*)'       MULTIPLIED BY 0.75'
                      CALL ancmsg(msgid=103,
     .                            msgtype=msgwarning,
     .                            anmode=aninfo_blind_2,
     .                            i1=id,
     .                            c1=titr)
                      RETURN
                    ENDIF
                  ENDIF
                ENDIF
C               write(6,*)"Node candidat",BPN(J)
C               write(6,*)"Element  candidat",NE
              ENDIF  
   20   CONTINUE 
C       the bottoms of the stacks must be copied into the corresponding bas_de_pile
C       before descending again into the neighboring branch
        CALL i7dstk(i_add,nb_nc,nb_ec,add,bpn,pn,bpe,pe)
        RETURN
      ENDIF
C
C-----------------------------------------------------------
C
C
C    2- sorting phase on the median according to the largest direction
C                    
C                   
C-----------------------------------------------------------
C
C
C    1- DETERMINER LA DIRECTION A DIVISER X,Y OU Z
C
      dir = 1
      IF(dy==dsup) THEN
        dir = 2
      ELSE IF(dz==dsup) THEN
        dir = 3
      ENDIF
      seuil =(xyzm(dir+3,i_add)+xyzm(dir,i_add))/2
C
C    2- DIVISER LES NODES EN TWO ZONES 
C
      nb_ncn= 0
      addnn= add(1,1)
      inf = 0
      sup = 0
      IF(igap==0)THEN
       DO i=1,nb_nc
        IF(x(dir,nsv(bpn(i)))<seuil) THEN
C         store in the bottom of the bp stack
          addnn = addnn + 1
          pn(addnn) = bpn(i)
          inf = 1
        ELSE
          nb_ncn = nb_ncn + 1
          bpn(nb_ncn) = bpn(i)
C         ON STOCKE EN ECRASANT PROGRESSIVEMENT BPN
          sup = 1
        ENDIF
       END DO
      ELSE
       gapsmx  = zero
       bgapsmx = zero
       DO i=1,nb_nc
        IF(x(dir,nsv(bpn(i)))<seuil) THEN
C         store in the bottom of the bp stack
          addnn = addnn + 1
          pn(addnn) = bpn(i)
          gapsmx = max(gapsmx,gap_s(bpn(i)))
          inf = 1
        ELSE
C         ON STOCKE EN ECRASANT PROGRESSIVEMENT BPN
          nb_ncn = nb_ncn + 1
          bpn(nb_ncn) = bpn(i)
          bgapsmx = max(bgapsmx,gap_s(bpn(i)))
          sup = 1
        ENDIF
       END DO
      END IF
CC
CC    3- DIVISER LES ELEMENTS 
CC
C      NB_ECN= 0
C      ADDNE= ADD(2,1)
C      SEUILI = SEUIL-TZINF
C      SEUILS = SEUIL+TZINF
C      DO 85 I=1,NB_EC
C        INF = 0
C        SUP = 0
C        DO 80 J=1,4
C          IP = IRECT(J,BPE(I))
C          IF(X(DIR,IP)<SEUILS) THEN
C            INF = 1
C            IF(SUP==1) GOTO 81
C          ENDIF
C          IF(X(DIR,IP)>=SEUILI) THEN
C            SUP = 1
C            IF(INF==1) GOTO 81
C          ENDIF
C   80   CONTINUE
C
C   81   CONTINUE
C        IF(INF==1) THEN
C         store in the bottom of the bp stack
C          ADDNE = ADDNE + 1
C          PE(ADDNE) = BPE(I)
C        ENDIF
C        IF(SUP==1) THEN
C         ON STOCKE EN ECRASANT PROGRESSIVEMENT BPE
C          NB_ECN = NB_ECN + 1
C          BPE(NB_ECN) = BPE(I)
C        ENDIF
C   85 CONTINUE
C
C    3- divide the elements
C
C 2 LIGNES PROV FOR TEST
C      INF = 1
C      SUP = 1
C
      nb_ecn= 0
      addne= add(2,1)
      IF(igap==0)THEN
       DO i=1,nb_ec
        xmx=max(x(dir,irect(1,bpe(i))),x(dir,irect(2,bpe(i))),
     .          x(dir,irect(3,bpe(i))),x(dir,irect(4,bpe(i))))
     .      + tzinf
        xmn=min(x(dir,irect(1,bpe(i))),x(dir,irect(2,bpe(i))),
     .          x(dir,irect(3,bpe(i))),x(dir,irect(4,bpe(i))))
     .      - tzinf
        IF(xmn<seuil.AND.inf==1) THEN
C         store in the bottom of the bp stack
          addne = addne + 1
          pe(addne) = bpe(i)
        ENDIF
        IF(xmx>=seuil.AND.sup==1) THEN
C         ON STOCKE EN ECRASANT PROGRESSIVEMENT BPE
          nb_ecn = nb_ecn + 1
          bpe(nb_ecn) = bpe(i)
        ENDIF
       ENDDO
      ELSE       
       DO i=1,nb_ec
        xmn=min(x(dir,irect(1,bpe(i))),x(dir,irect(2,bpe(i))),
     .          x(dir,irect(3,bpe(i))),x(dir,irect(4,bpe(i))))
     -      -sqrt(three)*min(max(gapsmx+gap_m(bpe(i)),gapmin),gapmax)
     -      -marge
        IF(xmn<seuil.AND.inf==1) THEN
C         store in the bottom of the bp stack
          addne = addne + 1
          pe(addne) = bpe(i)
        ENDIF
        xmx=max(x(dir,irect(1,bpe(i))),x(dir,irect(2,bpe(i))),
     .          x(dir,irect(3,bpe(i))),x(dir,irect(4,bpe(i))))
     +      +sqrt(three)*min(max(bgapsmx+gap_m(bpe(i)),gapmin),gapmax)
     +      +marge
        IF(xmx>=seuil.AND.sup==1) THEN
C         ON STOCKE EN ECRASANT PROGRESSIVEMENT BPE
          nb_ecn = nb_ecn + 1
          bpe(nb_ecn) = bpe(i)
        ENDIF
       ENDDO
      END IF
C
C    4- REMPLIR LES TABLEAUX D'ADRESSES
C
      add(1,2) = addnn
      add(2,2) = addne
C-----fill the min of the next box and the max of the current one
C     (i.e. threshold is a max for the current one)
C     We're going to go down and so we define a new box
C     fill the max of the new box
C     initialises in i7buc1 a 1.E30 comme ca on recupere
C     either xmax or the max of the box
      xyzm(1,i_add+1) = xyzm(1,i_add) 
      xyzm(2,i_add+1) = xyzm(2,i_add)
      xyzm(3,i_add+1) = xyzm(3,i_add)
      xyzm(4,i_add+1) = xyzm(4,i_add)
      xyzm(5,i_add+1) = xyzm(5,i_add)
      xyzm(6,i_add+1) = xyzm(6,i_add)
      xyzm(dir,i_add+1) = seuil
      xyzm(dir+3,i_add) = seuil
C
      nb_nc = nb_ncn
      nb_ec = nb_ecn
C     increment the descent level before exiting
      i_add = i_add + 1
      IF(i_add>=1000) THEN
C       TROP NIVEAUX PILE ON VAS LES PRENDRE PLUS GRANDES...
        IF ( nb_n_b == numnod) THEN
C          WRITE(IOUT,*)'***COMPUTATION STOPPED WHILE INFINITELY LOOPING'
C          WRITE(ISTDO,*)'***COMPUTATION STOPPED WHILE INFINITELY LOOPING'
C          CALL ARRET(2)
           IF (istamping == 1) THEN
             CALL ancmsg(msgid=775,
     .                   msgtype=msgerror,
     .                   anmode=aninfo,
     .                   i1=id,
     .                   c1=titr)
           ELSE
             CALL ancmsg(msgid=685,
     .                   msgtype=msgerror,
     .                   anmode=aninfo,
     .                   i1=id,
     .                   c1=titr)
           ENDIF
        ENDIF
        i_mem = 1
        RETURN
      ENDIF
C
C     this return is only reached when ok = 0
      RETURN
      END