rdbox.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/.
!||====================================================================
!||    checkpara               ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    box_surf_sh             ../starter/source/model/box/bigbox.F
!||    boxtage                 ../starter/source/model/box/bigbox.F
!||    boxtagn                 ../starter/source/model/box/bigbox.F
!||    elstagbox               ../starter/source/model/box/bigbox.F
!||    simple_elt_box          ../starter/source/model/sets/simpl_elt_box.F
!||    simple_node_box         ../starter/source/model/sets/simple_node_box.F
!||    simple_rbody_box        ../starter/source/model/sets/simple_rbody_box.F
!||--- calls      -----------------------------------------------------
!||    inside_parallelepiped   ../starter/source/model/box/rdbox.F
!||    projskew                ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE checkpara(XP1,YP1,ZP1,XP2,YP2,ZP2,
     .                     ISK,NODIN,SKEW,OK)
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"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ISK,OK
      my_real
     .    xp1,yp1,zp1,xp2,yp2,zp2,skew(lskew,*),nodin(3)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I
      my_real
     .    p1(3),p2(3),p3(3),p4(3),pp2(3)
C-----------------------------------------------
      p1(1) = xp1
      p1(2) = yp1
      p1(3) = zp1
      CALL projskew(p1,skew,isk)
C
      pp2(1) = xp2
      pp2(2) = yp2
      pp2(3) = zp2
      CALL projskew(pp2,skew,isk)
C
      p2(1) = pp2(1)
      p2(2) = p1(2)
      p2(3) = p1(3)
C
      p3(1) = p1(1)
      p3(2) = pp2(2)
      p3(3) = p1(3)
C
      p4(1) = p1(1)
      p4(2) = p1(2)
      p4(3) = pp2(3)
C
      CALL projskew(nodin,skew,isk)
C
      CALL inside_parallelepiped(p1, p2, p3, p4, nodin, ok)
C
      RETURN
      END
!||====================================================================
!||    projskew    ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    checkpara   ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE projskew(PO,SK,ISK)
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"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER ISK
      my_real
     .      po(3),sk(lskew,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,JSK
      my_real
     .    sum,pn(3)
C-----------------------------------------------
      jsk = isk + 1
C
      pn(1) = po(1)*sk(1,jsk) + po(2)*sk(2,jsk) + po(3)*sk(3,jsk)
      sum   = sk(1,jsk)**2 + sk(2,jsk)**2 + sk(3,jsk)**2
      sum   = sqrt(sum)
      pn(1) = pn(1) / sum
C
      pn(2) = po(1)*sk(4,jsk) + po(2)*sk(5,jsk) + po(3)*sk(6,jsk)
      sum   = sk(4,jsk)**2 + sk(5,jsk)**2 + sk(6,jsk)**2
      sum   = sqrt(sum)
      pn(2) = pn(2) / sum
C
      pn(3) = po(1)*sk(7,jsk) + po(2)*sk(8,jsk) + po(3)*sk(9,jsk)
      sum   = sk(7,jsk)**2 + sk(8,jsk)**2 + sk(9,jsk)**2
      sum   = sqrt(sum)
      pn(3) = pn(3) / sum
C
      po(1) = pn(1)
      po(2) = pn(2)
      po(3) = pn(3)
C
      RETURN
      END
!||====================================================================
!||    inside_parallelepiped   ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    checkpara               ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE inside_parallelepiped(P1, P2, P3, P4, P, OK)
C  nodes inside parallelepiped in 3D.
C
C
C         *------------------*
C        / .                / \
C       /   .              /   \
C      /     .            /     \
C    P4------------------*       \
C      \        .         \       \
C       \        .         \       \
C        \        .         \       \
C         \       P2.........\.......\
C          \     .            \     /
C           \   .              \   /
C            \ .                \ /
C            P1-----------------P3
C
C
C  Parameters:
C
C    Input, reals: P1(3), P2(3), P3(3), P4(3), four corners
C    of the parallelepiped.  It is assumed that P2, P3 and P4 are
C    immediate neighbors of P1.
C
C    Input, real: P(3), the node to be checked.
C
C    IF integer "OK == 1", the node P
C    is inside the parallelepiped, or on its boundary.
C
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 OK
      my_real
     .    p1(3),p2(3),p3(3),p4(3),p(3)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      my_real
     .    dot,suma
C-----------------------------------------------
      dot = dot_product( p(1:3) - p1(1:3),
     .                  p2(1:3) - p1(1:3))
      IF(dot < zero)RETURN
      suma = sum((p2(1:3) - p1(1:3) )**2)
      IF((suma == zero . and. p(1) /= p1(1)) .OR.
     .    suma < dot)RETURN
C---
      dot = dot_product( p(1:3) - p1(1:3),
     .                  p3(1:3) - p1(1:3))
      IF(dot < zero)RETURN
      suma = sum((p3(1:3) - p1(1:3) )**2)
      IF((suma == zero . and. p(2) /= p1(2)) .OR.
     .    suma < dot)RETURN
C---
      dot = dot_product( p(1:3) - p1(1:3),
     .                  p4(1:3) - p1(1:3))
      IF(dot < zero)RETURN
      suma = sum((p4(1:3) - p1(1:3) )**2)
      IF((suma == zero . and. p(3) /= p1(3)) .OR.
     .    suma < dot)RETURN
C---
      ok = 1
C---
      RETURN
      END
!||====================================================================
!||    checkcyl           ../starter/source/model/box/rdbox.f
!||--- called by ------------------------------------------------------
!||    box_surf_sh        ../starter/source/model/box/bigbox.F
!||    boxtage            ../starter/source/model/box/bigbox.F
!||    boxtagn            ../starter/source/model/box/bigbox.F
!||    elstagbox          ../starter/source/model/box/bigbox.F
!||    simple_elt_box     ../starter/source/model/sets/simpl_elt_box.F
!||    simple_node_box    ../starter/source/model/sets/simple_node_box.f
!||    simple_rbody_box   ../starter/source/model/sets/simple_rbody_box.F
!||--- calls      -----------------------------------------------------
!||    inside_cylinder    ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE checkcyl(XP1, YP1, ZP1, XP2, YP2, ZP2,
     .                    NODIN, D, OK )
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 OK
      my_real
     .    xp1,yp1,zp1,xp2,yp2,zp2,nodin(3),d
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      my_real
     .    p1(3),p2(3)
C-----------------------------------------------
 
C-----------------------------------------------
      p1(1) = xp1
      p1(2) = yp1
      p1(3) = zp1
C
      p2(1) = xp2
      p2(2) = yp2
      p2(3) = zp2
C
      CALL inside_cylinder(p1, p2, nodin, d, ok)
C
      RETURN
      END
!||====================================================================
!||    inside_cylinder   ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    checkcyl          ../starter/source/model/box/rdbox.F
!||--- calls      -----------------------------------------------------
!||    vec_length        ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE inside_cylinder(P1, P2, P, D, OK)
C-----------------------------------------------
C    The surface and interior of a (finite) cylinder in 3D is defined
C    by an axis, which is the line segment from point P1 to P2, and a
C    diameter D.  The points contained in the volume include:
C    * points at a distance less than or equal to D/2 from the line through P1
C      and P2, whose nearest point on the line through P1 and P2 is, in fact,
C      P1, P2, or any point between them.
C---
C    Input, D, the diameter of the cylinder.
C    Input, P(3), the checked point.
C    Input, P1(3), P2(3), the points defining the cylinder axis.
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 OK
      my_real
     .    p1(3),p2(3),p(3),d
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      my_real
     .  axis(3),axis_length,vec_length,off_axix_component,
     .  p_dot_axis,p_length
C-----------------------------------------------
      axis(1:3) = p2(1:3) - p1(1:3)
      axis_length = vec_length(3,axis)
      IF(axis_length == zero)RETURN
C
      axis(1:3) = axis(1:3) / axis_length
      p_dot_axis = dot_product(p(1:3) - p1(1:3),axis)
C
C  If the point lies below or above the "caps" of the cylinder, we're done.
C
      IF(p_dot_axis < zero .or. axis_length < p_dot_axis)RETURN
C
C  Otherwise, determine the distance from P to the axis.
C
      p_length = vec_length(3, p1(1:3) - (p(1:3) - p_dot_axis * axis(1:3)))
      IF(p_length <= half*d)ok = 1
C
      RETURN
      END
C-----------------
!||====================================================================
!||    vec_length        ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    inside_cylinder   ../starter/source/model/box/rdbox.F
!||====================================================================
      FUNCTION vec_length(DIMENS,X)
C-----------------
C  VEC_LENGTH returns the Euclidean length of a vector.
C
      IMPLICIT NONE
C
      INTEGER dimens
      my_real
     .  vec_length,x(dimens)
C-------------------------------
      vec_length = sqrt(sum((x(1:dimens))**2))
C
      RETURN
      END
!||====================================================================
!||    checksphere        ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    box_surf_sh        ../starter/source/model/box/bigbox.F
!||    boxtage            ../starter/source/model/box/bigbox.F
!||    boxtagn            ../starter/source/model/box/bigbox.F
!||    elstagbox          ../starter/source/model/box/bigbox.F
!||    simple_elt_box     ../starter/source/model/sets/simpl_elt_box.F
!||    simple_node_box    ../starter/source/model/sets/simple_node_box.F
!||    simple_rbody_box   ../starter/source/model/sets/simple_rbody_box.f
!||--- calls      -----------------------------------------------------
!||    inside_sphere      ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE checksphere(XP, YP, ZP, NODIN, D, OK)
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 OK
      my_real
     .    xp,yp,zp,nodin(3),d
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      my_real
     .    p(3)
C-----------------------------------------------
      p(1) = xp
      p(2) = yp
      p(3) = zp
C
      CALL inside_sphere(p, nodin, d, ok)
C
      RETURN
      END
!||====================================================================
!||    inside_sphere   ../starter/source/model/box/rdbox.F
!||--- called by ------------------------------------------------------
!||    checksphere     ../starter/source/model/box/rdbox.F
!||====================================================================
      SUBROUTINE inside_sphere(PC, P, D, OK)
C-----------------------------------------------
C    Implicit sphere equation:
C
C      SUM ( ( P(1:3) - PC(1:3) )**2 ) = D**2/4
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 OK
      my_real
     .    pc(3),p(3),d
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      my_real
     .    p1(3),p2(3),suma
C-----------------------------------------------
      suma = sum((p(1:3) - pc(1:3))**2)
      suma = four*suma
      IF(suma <= d**2) ok = 1
C
      RETURN
      END