table2d_intersect.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/.
!||====================================================================
!||    table2d_intersect   ../starter/source/tools/curve/table2d_intersect.F
!||--- called by ------------------------------------------------------
!||    law76_upd           ../starter/source/materials/mat/mat076/law76_upd.F
!||--- uses       -----------------------------------------------------
!||    table_mod           ../starter/share/modules1/table_mod.F
!||====================================================================
      SUBROUTINE table2d_intersect(TABLE  ,I1    ,I2    ,NPT    ,
     .                             XFAC   ,XINT  ,YINT  )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE table_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
      INTEGER      ,INTENT(IN)  :: I1,I2,NPT
      my_real      ,INTENT(IN)  :: xfac
      TYPE(ttable) ,INTENT(IN)  :: TABLE
      my_real      ,INTENT(OUT) :: xint,yint
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I,J1,J2,K
      my_real :: s1,s2,t1,t2,x1,x2,y1,y2,ax,ay,bx,by,cx,cy,dm,alpha,beta
c-----------------------------------------------
c     This routine checks if the functions in a 2 dim table do not intersect 
c     with respect to the second independent variable
C=======================================================================
c     Check segment intersections between 2 functions
 
      xint  = zero
      yint  = zero
      
c     I1 = index of first  strain rate 
c     I2 = index of second strain rate 
c
      j1 = (i1 - 1)*npt
      j2 = (i2 - 1)*npt
 
      DO k = 2,npt
        s1 = table%X(1)%VALUES(k-1)*xfac 
        s2 = table%X(1)%VALUES(k)  *xfac
        x1 = s1
        x2 = s2
        t1 = table%Y%VALUES(j1 + k-1) 
        t2 = table%Y%VALUES(j1 + k) 
        y1 = table%Y%VALUES(j2 + k-1) 
        y2 = table%Y%VALUES(j2 + k) 
c
        ax = x2 - x1
        ay = y2 - y1
        bx = s1 - s2
        by = t1 - t2
        dm = ay*bx - ax*by
        IF (dm /= zero) THEN  ! check if segments are not parallel
          cx = s1 - x1
          cy = t1 - y1
          alpha = (bx * cy - by * cx) / dm
          beta  = (ax * cy - ay * cx) / dm
          IF (alpha >= zero .and. alpha < one .and.
     .        beta  <= zero .and. beta  >-one .and. s1 > zero) THEN
            xint = x1 + alpha * ax
            yint = y1 + alpha * ay
            EXIT
          ENDIF
        ENDIF
      END DO
c-----------
      RETURN
      END