rcheckmass.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/.
!||====================================================================
!||    rcheckmass             ../starter/source/elements/spring/rcheckmass.F
!||--- called by ------------------------------------------------------
!||    initia                 ../starter/source/elements/initia/initia.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl2               ../starter/source/starter/freform.F
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE rcheckmass(
     .                  IXR      ,GEO      ,PM       ,MSR      ,INR    ,
     .                  MS       ,IN       ,ITAB     ,IGEO     ,IPM    ,
     .                  UPARAM   ,IPART    ,IPARTR   ,NPBY     ,LPBY   )
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE my_alloc_mod
      USE message_mod
      USE names_and_titles_mod , ONLY : nchartitle
      use element_mod , only : nixr
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"
#include      "com04_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IXR(NIXR,*), ITAB(*),
     .        IGEO(NPROPGI,*),IPM(NPROPMI,*),IPART(LIPART1,*),IPARTR(*),
     .        NPBY(NNPBY,*),LPBY(*)
C     REAL
      my_real
     .   geo(npropg,*),pm(npropm,*),uparam(*),msr(*),inr(*),ms(*),in(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I,NR,N1,N2,IPID,IGTYP,IMAT,MTN,IADBUF,IEQUI,IP,IPREV,
     .        K1,K11,K12,K13,K14,IERR2,N,M,NSL,IAD,NS,NERR
      INTEGER WORK(70000)
      INTEGER, ALLOCATABLE, DIMENSION(:) :: INDEX,ITRI,TAGSLV
C     REAL
      my_real
     .   xkm, xcm, xkr, xcr
      CHARACTER(LEN=NCHARTITLE)::TITL
C-----------------------------------------------------
C     Check for springs with stiffness but no mass
C-----------------------------------------------------
      CALL my_alloc(index,2*numelr)
      CALL my_alloc(itri ,numelr)
C
      CALL my_alloc(tagslv,numnod)
      tagslv(1:numnod)=0
      DO n=1,nrbykin
        m  =npby(1,n)
        IF(npby(7,n)/=0.AND.ms(m)/=zero.AND.in(m)/=zero)THEN
                             ! RBODY is active <=> not a rigid body activated with sensor
                             ! A node may be secnd of several rbodies (cf /RBODY/ON, /RBODY/OFF)
                             ! Then an error could be written when starting the engine
          nsl=npby(2,n)
          iad=npby(11,n)
          DO i=1,nsl
            ns=lpby(iad+i)
            tagslv(ns)=1
          END DO
        END IF
      END DO
C
      DO i=1,numelr
        itri(i)=ipartr(i)
      END DO
C
      CALL my_orders( 0, work, itri, index, numelr , 1)
C
      iprev=0
      nerr =0
      DO i=1,numelr
        nr=index(i)
        ipid  = ixr(1,nr)
        igtyp = igeo(11,ipid)
        imat  = ixr(5,nr)
        ip    = ipartr(nr)
        ierr2 = 0
        IF(igtyp==23)THEN
C
          iadbuf = ipm(7,imat) - 1
          mtn    = ipm(2,imat)
C
          k1 = 4
          k11 = 64
          k12 = k11 + 6
          k13 = k12 + 6
          k14 = k13 + 6
C
          IF(mtn == 108) THEN
            iequi = uparam(iadbuf+2)
            n1  =ixr(2,nr)
            n2  =ixr(3,nr)
            IF((tagslv(n1)==0.AND.(ms(n1)==zero.OR.in(n1)==zero)).OR.
     .         (tagslv(n2)==0.AND.(ms(n2)==zero.OR.in(n2)==zero)))THEN
 
              IF(ip/=iprev.AND.nerr/=0)THEN
                iprev=ip
C
                CALL fretitl2(titl,ipart(lipart1-ltitr+1,ip),ltitr)
                CALL ancmsg(msgid=1870,
     .                      msgtype=msgerror,
     .                      anmode=aninfo_blind_1,
     .                      i1=ipart(4,ip),
     .                      c1=titl)
C
C               Depile messages...
                CALL ancmsg(msgid=1871,
     .                      msgtype=msgerror,
     .                      anmode=aninfo_blind_1,
     .                      prmod=msg_print)
C
                nerr = 0
C
              END IF
              xkm= max(uparam(iadbuf + k11 + 1)*uparam(iadbuf + k1 + 1),
     .                 uparam(iadbuf + k11 + 2)*uparam(iadbuf + k1 + 2),
     .                 uparam(iadbuf + k11 + 3)*uparam(iadbuf + k1 + 3))   ! /XL(I)
              xcm= max(uparam(iadbuf + k12 + 1),uparam(iadbuf + k12 + 2),uparam(iadbuf + k12 + 3))
              xkr= max(uparam(iadbuf + k11 + 4)*uparam(iadbuf + k1 + 4),
     .                 uparam(iadbuf + k11 + 5)*uparam(iadbuf + k1 + 5),
     .                 uparam(iadbuf + k11 + 6)*uparam(iadbuf + k1 + 6))   ! /XL(I)
              xcr= max(uparam(iadbuf + k12 + 4),uparam(iadbuf + k12 + 5),uparam(iadbuf + k12 + 6))
              IF((tagslv(n1)==0.AND.ms(n1)==zero).OR.(tagslv(n2)==0.AND.ms(n2)==zero))THEN
                IF(xkm/=zero.OR.xcm/=zero)ierr2=ierr2+1
              END IF
              IF((tagslv(n1)==0.AND.in(n1)==zero).OR.(tagslv(n2)==0.AND.in(n2)==zero))THEN
                IF(xkr/=zero.OR.xcr/=zero.OR.(iequi/=0.AND.(xkm/=zero.OR.xcm/=zero)))ierr2=ierr2+1
              END IF
            END IF
          END IF
        END IF 
        IF(ierr2/=0)THEN
          nerr=nerr+1
          CALL ancmsg(msgid=1871,
     .                msgtype=msgerror,
     .                anmode=aninfo_blind_1,
     .                i1=ixr(nixr,nr),
     .                i2=itab(n1),
     .                i3=itab(n2),
     .                prmod=msg_cumu)
        END IF
      END DO
C
      CALL ancmsg(msgid=1871,
     .            msgtype=msgerror,
     .            anmode=aninfo_blind_1,
     .            prmod=msg_print)
C
      DEALLOCATE(index,itri,tagslv)
C------------------------------------------
      RETURN
      END