rcheckmass.F File Reference

#include "implicit_f.inc"
#include "param_c.inc"
#include "com04_c.inc"
#include "scr17_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	rcheckmass (ixr, geo, pm, msr, inr, ms, in, itab, igeo, ipm, uparam, ipart, ipartr, npby, lpby)

Function/Subroutine Documentation

rcheckmass()

subroutine rcheckmass	(	integer, dimension(nixr,*)	ixr,
			geo,
			pm,
			msr,
			inr,
			ms,
			in,
		integer, dimension(*)	itab,
		integer, dimension(npropgi,*)	igeo,
		integer, dimension(npropmi,*)	ipm,
			uparam,
		integer, dimension(lipart1,*)	ipart,
		integer, dimension(*)	ipartr,
		integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	lpby )

Definition at line 33 of file rcheckmass.F.

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