rini33_rb.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/.
!||====================================================================
!||    rini33_rb              ../starter/source/elements/joint/rjoint/rini33_rb.F
!||--- called by ------------------------------------------------------
!||    initia                 ../starter/source/elements/initia/initia.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    find_rby               ../starter/source/elements/joint/rjoint/rini33_rb.F
!||    fretitl2               ../starter/source/starter/freform.F
!||    get_u_geo              ../starter/source/user_interface/uaccess.F
!||    get_u_skew             ../starter/source/user_interface/uaccess.F
!||    prod_atb               ../starter/source/elements/joint/rjoint/rini33.F
!||    reset_u_geo            ../starter/source/user_interface/uaccess.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE rini33_rb(NEL,NUVAR,IPROP,IXR,NPBY,LPBY,RBY,STIFR,
     1                     UVAR,ITAB,IGEO,IXR_KJ,GMASS)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE names_and_titles_mod , ONLY : nchartitle
C-------------------------------------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   G l o b a l   P a r a m e t e r s
C-----------------------------------------------
#include      "param_c.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "vect01_c.inc"
#include      "com04_c.inc"
#include      "scr17_c.inc"
C----------------------------------------------------------
C   D u m m y   A r g u m e n t s   a n d   F u n c t i o n
C----------------------------------------------------------
      INTEGER NEL,NUVAR,IPROP,IXR(NIXR,*),NPBY(NNPBY,NRBODY),LPBY(*),
     .        itab(*),ixr_kj(5,*),igeo(npropgi)
      my_real
     . rby(nrby,nrbody),stifr(*),uvar(nuvar,*),gmass(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,II,IEL,J,K,N,L,S,NN,NSL,IERROR,NODES,USR,
     .        idsk(2),isk,nsk,isk2,jtyp,m(2),nod(2),nodf(3),
     .        reset_u_geo,get_u_skew,srb(6),no(3),idskrb(2),
     .        idrb(2),err_flg,n1,n2,n3,n4,id_kj,numel_kj,ielusr,
     .        rb1,rb2,ipid,idsk2   
C
      my_real
     .   mass,iner,rm,ri,knn,kr,l2,u(lskew),q(lskew),get_u_geo,v(lskew),
     .   xsk1,xsk2,len
C
      INTEGER ID
      CHARACTER(LEN=NCHARTITLE)::TITR
C-----------------------------------------------
      INTEGER FIND_RBY
      EXTERNAL get_u_geo,reset_u_geo,get_u_skew
      DATA nodes/2/
C=======================================================================
 
      id=igeo(1)
      CALL fretitl2(titr,igeo(npropgi-ltitr+1),ltitr)  
C      
      jtyp = nint(get_u_geo(1,iprop))
      isk2 = nint(get_u_geo(3,iprop))
      knn  = get_u_geo(10,iprop)
      nsk = 2
      IF (isk2==0) nsk = 1
      err_flg = 0
      ipid=ixr(1,1+nft)       
C------------------check sur les skews-----------------
      DO i=1,nsk
        idsk(i) = nint(get_u_geo(1+i,iprop))
        isk = get_u_skew(idsk(i),no(1),no(2),no(3),u)
        IF (isk==0) THEN
           CALL ancmsg(msgid=926,
     .                 msgtype=msgerror,
     .                 anmode=aninfo,
     .                 i1=id,
     .                 c1=titr,
     .                 i2=idsk(i))
             err_flg = 1
             GOTO 500
          ENDIF
        DO j=1,3
            srb(j+3*(i-1)) = find_rby(no(j),npby,lpby)
        END DO
        IF((srb(1+3*(i-1))==(srb(2+3*(i-1)))).AND.
     .     (srb(1+3*(i-1))==(srb(3+3*(i-1))))) THEN
            idskrb(i) = srb(1+3*(i-1))
        ELSE
            idskrb(i) = 0
            IF (srb(1+3*(i-1))+srb(2+3*(i-1))+srb(3+3*(i-1))==0) THEN
            CALL ancmsg(msgid=392,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_2,
     .                  i1=id,
     .                  c1=titr,
     .                  i2=idsk(i))
            ELSE
            CALL ancmsg(msgid=919,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_2,
     .                  i1=id,
     .                  c1=titr,
     .                  i2=idsk(i))
            ENDIF
        ENDIF
500     CONTINUE
      ENDDO
      IF (err_flg==1) THEN
         GOTO 1000
      ENDIF
      IF (isk2==0) THEN
            idskrb(2) = idskrb(1)
      ENDIF
      
C------------------Boucle sur les neuds-----------------
 
      IF(nrbody==0) THEN
        CALL ancmsg(msgid=390,
     .              msgtype=msgwarning,
     .              anmode=aninfo_blind_2,
     .              i1=id,
     .              c1=titr)
      ELSE
        DO iel=1,nel
          l2 = 0.
          rm = 1.e30
          ri = 1.e30
            idrb(1)=0
            idrb(2)=0
C-->
          DO i=1,nodes
            m(i) = 0
            k = 0
            nod(i)=ixr(1+i,nft+iel)
            DO n=1,nrbody
              nsl=npby(2,n)
              IF (npby(1,n)==nod(i)) THEN 
C-- Tag for error message - Can't be attached to main node-              
          idrb(i)=-n
                uvar(37+i,iel)= n                
                EXIT
              ENDIF
C
              DO j=1,nsl
                nn = lpby(j+k)
                IF(nn==nod(i)) THEN
            idrb(i)=n
                  m(i) = npby(1,n)
                  mass = rby(14,n)
                  iner = (rby(10,n)+rby(11,n)+rby(12,n))/3.0
C                 L2 = INER/MASS
                  uvar(33+i,iel)= mass
                  uvar(35+i,iel)= iner
                  uvar(37+i,iel)= n
                  IF((i==2).AND.(isk2==0)) THEN
c---              rigid body principal frame
                    DO ii=1,9
                      u(ii)= uvar(3+ii,iel)
                    END DO
                    CALL prod_atb(rby(1,n),u,q)
                    uvar(4,iel) = q(1)
                    uvar(5,iel) = q(2)
                    uvar(6,iel) = q(3)
                    uvar(7,iel) = q(4)
                    uvar(8,iel) = q(5)
                    uvar(9,iel) = q(6)
                    uvar(10,iel)= q(7)
                    uvar(11,iel)= q(8)
                    uvar(12,iel)= q(9)
                  ENDIF
C-->      
                  GOTO 100
                ENDIF
              ENDDO
100           k = k+nsl
C
            ENDDO
C
C-->  Stockage d'une masse elementaire (masse hormonique) pour calcul d'energie specifique
            gmass(iel) = (uvar(34,iel)*uvar(35,iel))/max(em20,uvar(34,iel)+uvar(35,iel))
C-->
            IF (idrb(i)==0) THEN      
                usr = itab(nod(i))
              CALL ancmsg(msgid=391,
     .                    msgtype=msgwarning,
     .                    anmode=aninfo_blind_2,
     .                    i1=id,
     .                    c1=titr,
     .                    i2=usr)
            ELSEIF (idrb(i) < 0) THEN      
                usr = itab(nod(i))
              CALL ancmsg(msgid=1768,
     .                    msgtype=msgerror,
     .                    anmode=aninfo_blind_2,
     .                    i1=id,
     .                    c1=titr,
     .                    i2=ixr(nixr,nft+iel),
     .                    i3=usr)
            ELSEIF ((idrb(i)/=idskrb(1)).AND.
     .             (idrb(i)/=idskrb(2))) THEN
                usr = itab(nod(i))
              CALL ancmsg(msgid=920,
     .                    msgtype=msgwarning,
     .                    anmode=aninfo_blind_2,
     .                    i1=id,
     .                    c1=titr,
     .                    i2=usr,
     .                    c2="OR",
     .                    i3=idsk(1),
     .                    i4=idsk(2))
              ENDIF
          ENDDO
 
C---> Control consistence Noeud / Skew --------------------
         IF((idrb(1)==idskrb(1)).AND.(idrb(2)==idskrb(2)))GOTO 350
         IF((idrb(1)==idskrb(2)).AND.(idrb(2)==idskrb(1)))THEN
C-->        permutation skews
            CALL ancmsg(msgid=921,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_2,
     .                  i1=id,
     .                  c1=titr,
     .                  i2=idsk(2),
     .                  i3=idsk(1))
            xsk1 = idsk(2)
            xsk2 = idsk(1)
              ierror = reset_u_geo(2,iprop,xsk1)
              ierror = reset_u_geo(3,iprop,xsk2)
              GOTO 350
            ENDIF
350       CONTINUE
C-->
        ENDDO
      ENDIF
             
C-------------------------------------------------------
 1000 CONTINUE
 
      RETURN
 
      RETURN
      END
C
!||====================================================================
!||    find_rby    ../starter/source/elements/joint/rjoint/rini33_rb.F
!||--- called by ------------------------------------------------------
!||    rini33_rb   ../starter/source/elements/joint/rjoint/rini33_rb.F
!||    rini45_rb   ../starter/source/elements/joint/rjoint/rini45_rb.F
!||====================================================================
      INTEGER FUNCTION find_rby(IDNOD,NPBY,LPBY)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   A n a l y s e   M o d u l e
C-----------------------------------------------
#include      "param_c.inc"
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER idnod,npby(nnpby,*),lpby(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER i,n,k,nsl
C=======================================================================
 
      find_rby = 0
 
      k = 0
      DO n=1,nrbykin
        nsl=npby(2,n)
          DO i=1,nsl
            IF (npby(7,n)/=0) THEN
              IF (idnod==lpby(k+i)) THEN
                 find_rby = n
                 EXIT
              ENDIF
            ENDIF
          END DO
        k=k+nsl
      ENDDO
 
C-----------------------
      RETURN
      END