test_support_fct.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/.
!||====================================================================
!||    test_support_fct   ../starter/source/elements/ige3d/test_support_fct.F
!||--- called by ------------------------------------------------------
!||    prerafig3d         ../starter/source/elements/ige3d/prerafig3d.F
!||--- calls      -----------------------------------------------------
!||====================================================================
      SUBROUTINE test_support_fct(IXIG3D, KXIG3D, KNOTLOCPC, DEGTANG1, DEGTANG2, DIR,
     .                            TAB_ELCUT, L_TAB_ELCUT,
     .                            TAB_COINKNOT,L_TAB_COINKNOT,
     .                            TAB_FCTCUT,L_TAB_FCTCUT,DECALGEO,FLAG)
C----------------------------------------------------------------------
C   ------------------------>   case of quads  <-----------------------c
C   ENSEMBLE D'ELEMENTS DU PATCH QUI VONT POTENTIELLEMENT ETRE MODIFIEES 
C   by inserting the knot of the meshsurf
C   this routine uses an inclusion detection algorithm
C   of segments in a surface (slightly modified)
C----------------------------------------------------------------------
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "param_c.inc"
#include      "ige3d_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IXIG3D(*),KXIG3D(NIXIG3D,*),DEGTANG1,DEGTANG2,DIR,DECALGEO,
     .        TAB_ELCUT(L_TAB_ELCUT),L_TAB_ELCUT,L_TAB_COINKNOT,
     .        TAB_FCTCUT(L_TAB_FCTCUT),L_TAB_FCTCUT,FLAG
      my_real knotlocpc(deg_max,3,*),tab_coinknot(2,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,K,DIRTANG1,DIRTANG2,
     .        IEL,INTERSEC,
     .        WORK(70000),SIZ_LIST_FCTTOT,IDFCT,IOUT
      my_real det, t1, t2, xa(5),ya(5),coin(2,2),
     .        xb, yb, xc, yc, xd, yd, tol
      INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX, LIST_FCTTOT, LIST_FCTTRI
C-----------------------------------------------
c
      l_tab_fctcut = 0
      tol = em06
c
      IF(dir==1) THEN
        dirtang1 = 2
        dirtang2 = 3
      ELSEIF(dir==2) THEN
        dirtang1 = 3
        dirtang2 = 1
      ELSEIF(dir==3) THEN
        dirtang1 = 1
        dirtang2 = 2
      ELSE
        dirtang1 = -huge(dirtang1)
        dirtang2 = -huge(dirtang2)
      ENDIF
c
C----------------------------------------------------------------------
c  all functions to be processed are listed and sorted for
c  Do not treat the same function twice
C----------------------------------------------------------------------
c
      siz_list_fcttot = l_tab_elcut*kxig3d(3,tab_elcut(1))
      ALLOCATE(list_fcttot(siz_list_fcttot))
      ALLOCATE(list_fcttri(siz_list_fcttot))
      list_fcttot(:) = ep06
c
      DO i=1,l_tab_elcut
        iel=tab_elcut(i)
        DO j=1,kxig3d(3,iel)
          list_fcttot((i-1)*kxig3d(3,iel)+j) = ixig3d(kxig3d(4,iel)+j-1)
        ENDDO
      ENDDO
c
      ALLOCATE(index(2*siz_list_fcttot))
      CALL my_orders(0, work, list_fcttot, index, siz_list_fcttot , 1)
c
      DO i=1,siz_list_fcttot
        list_fcttri(i)=list_fcttot(index(i))
      ENDDO
c
      DEALLOCATE(list_fcttot)
      DEALLOCATE(index)
c
      coin(1,1) = minval(tab_coinknot(1,1:(l_tab_coinknot)))
      coin(2,1) = minval(tab_coinknot(2,1:(l_tab_coinknot)))
      coin(1,2) = maxval(tab_coinknot(1,1:(l_tab_coinknot)))
      coin(2,2) = maxval(tab_coinknot(2,1:(l_tab_coinknot)))
c
      DO i=1,siz_list_fcttot
c
        IF(i/=1) THEN
          IF(list_fcttri(i-1)==list_fcttri(i)) cycle
        ENDIF
c
        idfct = list_fcttri(i)
        iout=0
c
C----------------------------------------------------------------------
c  creation of working variables: corner of the knot extents of the function
c  A TESTER
C----------------------------------------------------------------------
c
        xa(1) = knotlocpc(1,dirtang1,decalgeo+idfct) + tol
        xa(2) = knotlocpc(degtang1+1,dirtang1,decalgeo+idfct) - tol
        xa(3) = knotlocpc(degtang1+1,dirtang1,decalgeo+idfct) - tol
        xa(4) = knotlocpc(1,dirtang1,decalgeo+idfct) + tol
        xa(5) = xa(1)
c
        ya(1) = knotlocpc(1,dirtang2,decalgeo+idfct) + tol
        ya(2) = knotlocpc(1,dirtang2,decalgeo+idfct) + tol
        ya(3) = knotlocpc(degtang2+1,dirtang2,decalgeo+idfct) - tol
        ya(4) = knotlocpc(degtang2+1,dirtang2,decalgeo+idfct) - tol
        ya(5) = ya(1)
c
C----------------------------------------------------------------------
c  1st test: test of the 4 points according to the 4 convex corners of the meshsurf
C----------------------------------------------------------------------
c
        IF(xa(1)<coin(1,1).OR.ya(1)<coin(2,1)) cycle
        IF(xa(3)>coin(1,2).OR.ya(3)>coin(2,2)) cycle
c
C----------------------------------------------------------------------
c2nd test: test if the segment formed with a distant point intersects a side of the polygon
C----------------------------------------------------------------------
c
        xb=coin(1,1)-1000  ! a point far enough from the meshsurf is taken
        yb=coin(2,1)-2000
        DO j=1,4  ! loop over the 4 corners of the extent
          intersec=0
          DO k=1,l_tab_coinknot-1
            xc=tab_coinknot(1,k)
            yc=tab_coinknot(2,k)
            xd=tab_coinknot(1,k+1)
            yd=tab_coinknot(2,k+1)
            det = (xb-xa(j))*(yc-yd) - (xc-xd)*(yb-ya(j))
            IF(det==0) THEN
c             parallel or collinear segments
            ELSE
              t1 = ((xc-xa(j))*(yc-yd)-(xc-xd)*(yc-ya(j)))/det
              t2 = ((xb-xa(j))*(yc-ya(j))-(xc-xa(j))*(yb-ya(j)))/det
              IF(t1>1.OR.t1<0.OR.t2>1.OR.t2<=0) THEN ! pas d'intersection
c                ! pas d'intersection
              ELSE
                intersec = intersec + 1 
c                intersection: increment the counter by 1
              ENDIF
            ENDIF
          ENDDO
          IF(mod(intersec,2)==0) iout=1 ! even number of intersections, the point is outside the meshsurf
        ENDDO
c
        IF(iout==1) cycle
c
C----------------------------------------------------------------------
c  3rd test: to handle concave polygons, the segments formed by the extents must be tested
C----------------------------------------------------------------------
c
        DO j=1,4  ! loop over the 4 corners of the extent
          DO k=1,l_tab_coinknot-1
            xc=tab_coinknot(1,k)
            yc=tab_coinknot(2,k)
            xd=tab_coinknot(1,k+1)
            yd=tab_coinknot(2,k+1)
            det = (xa(j+1)-xa(j))*(yc-yd) - (xc-xd)*(ya(j+1)-ya(j))
            IF(det==0) THEN
c             parallel or collinear segments, so loop over another segment of the polygon
            ELSE
              t1 = ((xc-xa(j))*(yc-yd)-(xc-xd)*(yc-ya(j)))/det
              t2 = ((xa(j+1)-xa(j))*(yc-ya(j))-(xc-xa(j))*(ya(j+1)-ya(j)))/det
              IF(t1>1.OR.t1<0.OR.t2>1.OR.t2<=0) THEN ! pas d'intersection
c                ! pas d'intersection
              ELSE
                iout=1 ! intersection : fonction a exclure
                cycle
              ENDIF
            ENDIF
          ENDDO
        ENDDO
C
C----------------------------------------------------------------------
C  sizing and storage of the array of functions to be refined
C----------------------------------------------------------------------
C
        IF(iout==0) THEN
          IF(flag==0) THEN
            l_tab_fctcut = l_tab_fctcut + 1
          ELSE
            l_tab_fctcut = l_tab_fctcut + 1 
            tab_fctcut(l_tab_fctcut) = idfct
          ENDIF
        ENDIF
c
      ENDDO
c
      DEALLOCATE(list_fcttri)
C
      RETURN
      END
c