checkrby.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/.
!||====================================================================
!||    checkrby               ../starter/source/constraints/general/rbody/checkrby.F
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    anodset                ../starter/source/output/analyse/analyse_node.c
!||    fretitl2               ../starter/source/starter/freform.F
!||    kinset                 ../starter/source/constraints/general/kinset.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE checkrby(RBY     ,NPBY    ,LPBY    ,ITAB    ,
     2                    IKINE   ,IDDLEVEL,NOM_OPT ,NUMSL   )
C-------------------------------------
C     LECTURE STRUCTURE RIGIDES IFORM8=2
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   A n a l y s e   M o d u l e
C-----------------------------------------------
#include      "analyse_name.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
#include      "scr17_c.inc"
#include      "scr03_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NPBY(NNPBY,*), LPBY(*), ITAB(*)
      INTEGER IKINE(*), IDDLEVEL, NUMSL
      my_real rby(nrby,*)
      INTEGER NOM_OPT(LNOPT1,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,J,L,K,KK,M,N,NSL,NSKEW,IC,
     .   ispher,idir,p,ig,id,icdg,nsl_xtra,
     .   nrb,numsl_tmp
      CHARACTER(LEN=NCHARTITLE)::TITR
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: TABSL
      INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX,IKINE1
      INTEGER IWORK(70000),IOLD
      INTEGER IFLAGI1,IFLAGDBL,IRB
C-----------------------------------
C   NPBY( 1,N) = main NODE
C   NPBY( 2,N) = NUMBER OF SECND NODES
C   NPBY( 3,N) = ICDG
C   NPBY( 4,N) = ISENS gw117
C   NPBY( 5,N) = FLAG SPHERICAL INERTIA
C   NPBY( 6,N) = IDENTIFICATEUR
C   NPBY( 7,N) = 1 ON(1) OFF(0)
C   NPBY( 8,N) = ISU
C   NPBY( 9,N) = NSKEW
C   NPBY(10,N) = IEXPAMS (AMS - Hidden)
C                 = 1 (default) : AMS expansion ; = 2 (Hidden) : No expansion
C   NPBY(11,N) = IAD => secnd nodes LPBY(IAD+1:IAD+NSN)
C   NPBY(12,N) = RBODY LEVEL
C   NPBY(13,N) = RBODY IFLAG
C   NPBY(14,N) = NUMBER OF XTRA_NODE with Iflag=1
C   NPBY(15,N) = NUMBER OF XTRA_NODE with Iflag=2
C   NPBY(16,N) = NUMBER OF XTRA_NODE with Iflag=3
C=======================================================================
      IF (numsl > 0) THEN
        ALLOCATE(tabsl(2,numsl))
        ALLOCATE(index(3*numsl))
        tabsl=0
        index=0
      END IF
      n=0
      k=0
      kk=0
      nrb = 0
C
      ALLOCATE(ikine1(3*numnod))
      DO i=1,3*numnod
        ikine1(i) = 0
      ENDDO
C
      DO n=1,nrbykin
        nsl=npby(2,n)
        nsl_xtra=npby(14,n)+npby(15,n)+npby(16,n)
        ispher = npby(5,n)
        icdg = npby(3,n)
        id=nom_opt(1,n)
c
        DO j=1,nsl-nsl_xtra
          CALL anodset(lpby(j+k), check_rb_s)
          tabsl(1,j+kk)=itab(lpby(j+k))
          tabsl(2,j+kk)=n
        ENDDO
C
        IF(iddlevel==0)THEN
         IF(ikrem == 0)THEN
          DO j=1,nsl
           DO idir=1,6
             CALL kinset(8,itab(lpby(j+k)),ikine(lpby(j+k)),idir,0,
     .                   ikine1(lpby(j+k)))
           ENDDO
          ENDDO
         ELSE
          DO j=1,nsl
           DO idir=1,6
             CALL kinset(128,itab(lpby(j+k)),ikine(lpby(j+k)),idir,0,
     .                   ikine1(lpby(j+k)))
           ENDDO
          ENDDO
         ENDIF
        ENDIF
C
        k=k+nsl
        kk=kk+nsl-nsl_xtra
      ENDDO
      numsl_tmp=kk
C-------------------------------------
C Bilan secnd nodes doubles (sans les XTRA_NODES qui sont teste avant)
C-------------------------------------
      IF (nrbykin > 1) THEN
      iwork=0
      iflagdbl=0
      DO i=1,numsl_tmp
        index(i)=i
      END DO
      CALL my_orders(0,iwork,tabsl,index,numsl_tmp,2)
      IF (numsl_tmp > 0) THEN
        iold=-1
        DO i=1,numsl_tmp
        IF (tabsl(1,index(i))==iold) THEN
          IF (iflagdbl==0) THEN
            iflagi1=i-1
          END IF
          iflagdbl=1
        ELSE
          IF (iflagdbl/=0) THEN
            DO j=iflagi1,i-1
              irb=tabsl(2,index(j))
              id=nom_opt(1,irb)
              CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,irb),ltitr)
              CALL ancmsg(msgid=1026,
     .                    msgtype=msgwarning,
     .                    anmode=aninfo_blind_2,
     .                    i1=id,
     .                    c1=titr,
     .                    prmod=msg_cumu)
            END DO
            CALL ancmsg(msgid=1026,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_1,
     .                  i1=tabsl(1,index(iflagi1)),
     .                  prmod=msg_print)
            iflagdbl=0
          END IF
        END IF
        iold=tabsl(1,index(i))     
        END DO
      END IF
      END IF
C
C------------------------------------
      IF(ALLOCATED(tabsl))DEALLOCATE(tabsl)
      IF(ALLOCATED(index))DEALLOCATE(index)
      IF(ALLOCATED(ikine1)) DEALLOCATE(ikine1)
C------------------------------------
      RETURN
C
      END SUBROUTINE checkrby
C