polyhedr.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/.
!||====================================================================
!||    polyhedr   ../starter/source/airbag/polyhedr.F
!||--- called by ------------------------------------------------------
!||    fvmesh1    ../starter/source/airbag/fvmesh.f
!||====================================================================
      SUBROUTINE polyhedr(IPOLY, RPOLY   , POLB  , NPOLB, POLH,
     .                    NPOLH, NRPMAX  , NPHMAX, IBRIC, LMIN,
     .                    INFO , NPOLHMAX, NPPMAX)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NPPMAX, IPOLY(6+NPPMAX,*), POLB(*), NPOLB, NPHMAX, 
     .        POLH(NPHMAX+2,*),NPOLH, NRPMAX, IBRIC, INFO, NPOLHMAX
      my_real
     .        rpoly(nrpmax,*), lmin
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, ITAG(NPOLB), ICMAX, ICUR, II, J, JJ, K, KK, ISTOP,
     .        L, LL, ICUR_OLD, ITY, JMIN, PMIN, POLD
      my_real
     .        x1, y1, z1, x2, y2, z2, xx1, yy1, zz1, xx2, yy2, zz2,
     .        dd11, dd12, dd21, dd22, tole
C
      my_real
     .        dlamch_rd
      EXTERNAL dlamch_rd
C
      tole=epsilon(zero)*0.5*lmin*lmin
C
      DO i=1,npolb
         itag(i)=0
      ENDDO
C
      icmax=0
      DO i=1,npolb
         IF (itag(i)==0) THEN
            icmax=icmax+1
            itag(i)=icmax
            icur=icmax
         ELSE
            icur=itag(i)
         ENDIF
         ii=polb(i)
         DO j=1,ipoly(2,ii)
            IF (j/=ipoly(2,ii)) THEN
               jj=j+1
            ELSE
               jj=1
            ENDIF
            x1=rpoly(4+3*(j-1)+1,ii)
            y1=rpoly(4+3*(j-1)+2,ii)
            z1=rpoly(4+3*(j-1)+3,ii)
            x2=rpoly(4+3*(jj-1)+1,ii)
            y2=rpoly(4+3*(jj-1)+2,ii)
            z2=rpoly(4+3*(jj-1)+3,ii)
            DO k=1,npolb
               IF (k==i) cycle
               kk=polb(k)
               istop=0
               l=0
               DO WHILE (istop==0.AND.l<ipoly(2,kk))
                  l=l+1
                  IF (l/=ipoly(2,kk)) THEN
                     ll=l+1
                  ELSE
                     ll=1
                  ENDIF
                  xx1=rpoly(4+3*(l-1)+1,kk)
                  yy1=rpoly(4+3*(l-1)+2,kk)
                  zz1=rpoly(4+3*(l-1)+3,kk)
                  xx2=rpoly(4+3*(ll-1)+1,kk)
                  yy2=rpoly(4+3*(ll-1)+2,kk)
                  zz2=rpoly(4+3*(ll-1)+3,kk)
                  dd11=(xx1-x1)**2+(yy1-y1)**2+(zz1-z1)**2
                  dd21=(xx2-x1)**2+(yy2-y1)**2+(zz2-z1)**2
                  dd12=(xx1-x2)**2+(yy1-y2)**2+(zz1-z2)**2
                  dd22=(xx2-x2)**2+(yy2-y2)**2+(zz2-z2)**2
                  IF ((dd11<=tole.AND.dd22<=tole).OR.
     .                (dd21<=tole.AND.dd12<=tole)) istop=l
               ENDDO
               IF (istop/=0) THEN
                  IF (itag(k)==0) THEN
                     itag(k)=icur
                  ELSE
                     icur_old=icur
                     icur=itag(k)
                     DO l=1,npolb
                        IF (itag(l)==icur_old) itag(l)=icur
                     ENDDO
                  ENDIF
               ENDIF
            ENDDO
         ENDDO
      ENDDO
C
      npolh=0
      DO i=1,icmax
         ii=0
         DO j=1,npolb
            IF (itag(j)==i) ii=ii+1
         ENDDO
         IF (ii/=0) npolh=npolh+1
      ENDDO
      IF (npolh>npolhmax) THEN
         info=1
         npolhmax=npolh
         RETURN
      ENDIF
C
      npolh=0
      DO i=1,icmax
         ii=0
         DO j=1,npolb
            IF (itag(j)==i) ii=ii+1
         ENDDO
         IF (ii/=0) THEN
            npolh=npolh+1
            polh(1,npolh)=ii
            polh(2,npolh)=ibric
            ii=0
            DO j=1,npolb
               IF (itag(j)==i) THEN
                  ii=ii+1
                  jj=polb(j)
                  polh(2+ii,npolh)=jj
                  ity=ipoly(1,jj)
                  IF (ity==1) THEN
                     ipoly(5,jj)=npolh
                     cycle
                  ENDIF
                  IF (ipoly(5,jj)==0) THEN
                     ipoly(5,jj)=npolh
                  ELSE
                     ipoly(6,jj)=npolh
                  ENDIF
               ENDIF
            ENDDO
C Sorting in ascending order of polh
            DO j=1,polh(1,npolh)
               jmin=j
               pmin=polh(2+j,npolh)
               DO k=j+1,polh(1,npolh)
                  IF (polh(2+k,npolh)<pmin) THEN
                     jmin=k
                     pmin=polh(2+k,npolh)
                  ENDIF
               ENDDO
               pold=polh(2+j,npolh)
               polh(2+j,npolh)=pmin
               polh(2+jmin,npolh)=pold
            ENDDO
         ENDIF
      ENDDO
C
      info=0
      RETURN
      END