rbycor.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/.
!||====================================================================
!||    rbycor     ../engine/source/constraints/general/rbody/rbycor.F
!||--- called by ------------------------------------------------------
!||    resol      ../engine/source/engine/resol.F
!||--- calls      -----------------------------------------------------
!||    rgbcor     ../engine/source/constraints/general/rbody/rgbcor.F
!||--- uses       -----------------------------------------------------
!||    imp_dyna   ../engine/share/modules/impbufdef_mod.F
!||====================================================================
      SUBROUTINE rbycor(RBY ,X   ,V    ,VR  ,SKEW    ,FSAV     ,
     2                  LPBY,NPBY,ISKEW,ITAB,WEIGHT  ,A        ,
     3                  AR  ,MS  ,IN   ,KIND,IRBKIN_L,NRBYKIN_L,
     3                  WEIGHT_MD,MS_2D)
C-----------------------------------------------
      USE imp_dyna
C----6---------------------------------------------------------------7---------8
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "scr11_c.inc"
#include      "param_c.inc"
#include      "impl1_c.inc"
C-----------------------------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER WEIGHT(*),LPBY(*),NPBY(NNPBY,*),ISKEW(*),ITAB(*),
     .        KIND(NRBYKIN),IRBKIN_L(*),NRBYKIN_L,WEIGHT_MD(*)
C     REAL
      my_real
     .   rby(nrby,*) ,x(3,*) ,v(3,*) ,vr(3,*),skew(*),
     .   fsav(nthvki,*) ,a(3,*),ar(3,*),in(*),ms(*) ,ms_2d(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER  J,K,N,KK
C     REAL
      my_real
     .   enrot_t,encin_t,xmass_t,
     .   xmomt_t,ymomt_t,zmomt_t,encin2_t,enrot2_t
C-----------------------------------------------
C-------------------------------------
C CALCUL SUPER RIGID BODIES (non multi-thread) sur premiere tache libre
C-------------------------------------
!$OMP SINGLE
      DO kk=1,nrbykin_l
        n=irbkin_l(kk)
        k  = kind(n)
        IF(npby(7,n)>0.AND.npby(4,n)/=0)THEN
          j = ninter+nrwall+n
          IF( idyna>0 ) THEN
            CALL rgbcor(
     1        dy_v,dy_vr,x,rby(1,n),lpby(k),
     2        npby(1,n),skew,iskew,fsav(1,j),itab,
     3        weight,dy_a,dy_ar,ms,in,enrot,encin,xmass,
     4        xmomt,ymomt,zmomt,npby(4,n),weight_md,encin2,enrot2,
     5        ms_2d)
          ELSE
            CALL rgbcor(
     1        v,vr,x,rby(1,n),lpby(k),
     2        npby(1,n),skew,iskew,fsav(1,j),itab,
     3        weight,a,ar,ms,in,enrot,encin,xmass,
     4        xmomt,ymomt,zmomt,npby(4,n),weight_md,encin2,enrot2,
     5        ms_2d)
          ENDIF
        ENDIF
      ENDDO
!$omp END single
C-------------------------------------
C CALCUL FORCE RIGID BODIES CLASSIQUES (multi-thread)
C-------------------------------------
C
C   optimisation locks
      enrot_t=zero
      encin_t=zero
      xmass_t=zero
      xmomt_t=zero
      ymomt_t=zero
      zmomt_t=zero
      enrot2_t=zero
      encin2_t=zero         
C
!$OMP DO SCHEDULE(DYNAMIC,1)
      DO kk=1,nrbykin_l
        n = irbkin_l(kk)
        k  = kind(n)
        IF( npby(7,n)>0.AND.npby(4,n)==0)THEN
          j = ninter+nrwall+n
          IF( idyna>0 ) THEN
            CALL rgbcor(
     1        dy_v,dy_vr,x,rby(1,n),lpby(k),
     2        npby(1,n),skew,iskew,fsav(1,j),itab,
     3        weight,dy_a,dy_ar,ms,in,enrot_t,encin_t,xmass_t,
     4        xmomt_t,ymomt_t,zmomt_t,npby(4,n),weight_md,encin2_t,
     5        enrot2_t,ms_2d)
          ELSE
            CALL rgbcor(
     1        v,vr,x,rby(1,n),lpby(k),
     2        npby(1,n),skew,iskew,fsav(1,j),itab,
     3        weight,a,ar,ms,in,enrot_t,encin_t,xmass_t,
     4        xmomt_t,ymomt_t,zmomt_t,npby(4,n),weight_md,encin2_t,
     5        enrot2_t,ms_2d)
          ENDIF
        ENDIF
      ENDDO
!$OMP END DO NOWAIT
C
#include "lockon.inc"
      enrot=enrot + enrot_t
      encin=encin + encin_t    
      xmass=xmass + xmass_t
      xmomt=xmomt + xmomt_t
      ymomt=ymomt + ymomt_t
      zmomt=zmomt + zmomt_t
      encin2=encin2 + encin2_t
      enrot2=enrot2 + enrot2_t              
#include "lockoff.inc"
C
      RETURN
      END