Sources Esope | Cast3M

rgbase
C RGBASE    SOURCE    CHAT      09/10/09    21:23:01     6519
      SUBROUTINE RGBASE(IPOI2,IRIG,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C  CE SUBROUTINE ENCHAINE LES CALCULS DES RIGIDITES SUIVANTES :
C    . RIGIDITE DUES AUX MODES (MN OU KN) ....RGMODE
C    . COUPLAGE MODE-LIAISONS             ....RGLIMO
C    . COUPLAGE LIAISONS-LIAISONS         ....RGLILI
C  LE RESULTAT EST MIS DANS IRET
C
C  PROGRAMME PAR FARVACQUE
C  APPELE PAR RIGI
C  APPELLE RGLIMO FUSRIG RGLILI RIGMOD
C=======================================================================
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC SMBASEM
-INC SMSOLUT
-INC SMSTRUC
-INC SMATTAC
C
      SEGMENT LIAT(NBASE)
      SEGMENT LRAT(0)
C
      KRIGI=0
      LRAT=0
      IFLAT=0
      LIAT=0
      MBASEM=IPOI2
      SEGACT MBASEM
      NBASE=LISBAS(/1)
C
C  ON TRAITE D ABORD LES OBJETS ATTACHE
C  ON ENVOIT A RGMATT UN ATTACHE OU LES RIGIDITES SONT TOUTES
C  DIFFERENTES POUR NE PAS COMPTER PLUSIEURS FOIS LE MEME TERME
C
      IF(IRIG.NE.2) GOTO 100
      SEGINI LIAT
      NLIA=0
      DO 10 IA=1,NBASE
      MSOBAS=LISBAS(IA)
      SEGACT MSOBAS
      IF(IBSTRM(4).EQ.0) GO TO 12
         DO 11 IAT=1,NLIA
         IF(IBSTRM(4).EQ.LIAT(IAT)) GO TO 12
  11     CONTINUE
      NLIA=NLIA+1
      LIAT(NLIA)=IBSTRM(4)
  12  CONTINUE
      SEGDES MSOBAS
  10  CONTINUE
      IF(NLIA.EQ.0) GO TO 100
      IF(NLIA.EQ.1) THEN
         KATTAC=LIAT(1)
         GO TO 19
      ENDIF
C
      SEGINI LRAT
      DO 13 JAT=1,NLIA
      MATTAC=LIAT(JAT)
      SEGACT MATTAC
      DO 16 JJAT=1,LISATT(/1)
      MSOUMA=LISATT(JJAT)
      SEGACT MSOUMA
         DO 14 KAT=1,IPMATK(/1)
         IF(IPMATK(KAT).EQ.0)GO TO 14
            DO 15 LAT=1,LRAT(/1)
            IF(IPMATK(KAT).EQ.LRAT(LAT))GO TO 14
  15        CONTINUE
            LRAT(**)=IPMATK(KAT)
  14     CONTINUE
      SEGDES MSOUMA
  16  CONTINUE
      SEGDES MATTAC
  13  CONTINUE
C
C  ON CREE L ATTACHE SI BESOIN
C
      IFLAT=1
      N=1
      SEGINI MATTAC
      KATTAC=MATTAC
      N=0
      M=LRAT(/1)
      SEGINI MSOUMA
      LISATT(1)=MSOUMA
      ITYATT='MECA'
      IGEOCH=0
      IPHYCH=0
      DO 18 NLI=1,M
      IPMATK(NLI)=LRAT(NLI)
  18  CONTINUE
C
C  MATTAC ET MSOUMA SEGDESES DANS RGMATT
C
  19  CONTINUE
      CALL RGMATT(KATTAC,KRIG)
      KRIGI=KRIG
C
  100 CONTINUE
      IF(LIAT.NE.0)SEGSUP LIAT
      IF(LRAT.NE.0)SEGSUP LRAT
      IF(IFLAT.NE.0)CALL DTMATT(KATTAC)
      DO 1 IB=1,NBASE
      MSOBAS=LISBAS(IB)
      SEGACT MSOBAS
      ISTRU=IBSTRM(1)
      IMODE=IBSTRM(2)
      ISOLS=IBSTRM(3)
      IF(ISOLS.EQ.0) GO TO 4
      IF(IMODE.EQ.0) GO TO 1032
      IF(IRIG.EQ.2) GO TO 1032
      CALL RGLIMO(IMODE,ISOLS,ISTRU,IRIG,KRIG)
      IF(IERR.NE.0) GO TO 2000
      IF(KRIG.EQ.0) GO TO 1032
      IF(KRIGI.EQ.0) THEN
         KRIGI=KRIG
      ELSE
         CALL FUSRIG(KRIGI,KRIG,IRET)
         MRIGID=KRIGI
         SEGSUP MRIGID
         KRIGI=IRET
      ENDIF
 1032 CALL RGLILI(ISOLS,ISTRU,IRIG,KRIG)
      IF(IERR.NE.0) GO TO 2000
      IF(KRIG.EQ.0) GO TO 4
      IF(KRIGI.EQ.0) THEN
         KRIGI=KRIG
      ELSE
         CALL FUSRIG(KRIGI,KRIG,IRET)
         MRIGID=KRIGI
         SEGSUP MRIGID
         KRIGI=IRET
      ENDIF
 4    CONTINUE
      IF(IMODE.EQ.0) GO TO 1036
      CALL RIGMOD(IMODE,IRIG,KRIG)
      IF(IERR.NE.0) GO TO 2000
      IF(KRIGI.EQ.0) THEN
         KRIGI=KRIG
      ELSE
         CALL FUSRIG(KRIGI,KRIG,IRET)
         MRIGID=KRIGI
         SEGSUP MRIGID
         KRIGI=IRET
      ENDIF
 1036 CONTINUE
      SEGDES MSOBAS
 1    CONTINUE
      SEGDES MBASEM
C
      IRET=KRIGI
 2000 CONTINUE
      RETURN
      END