C QZADRG    SOURCE    BP208322  12/10/03    21:15:15     7517           
      SUBROUTINE QZADRG (RI1, RI2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*
************************************************************************
*             ADDITION DES RIGIDITES ELEMENTAIRES DE RI1               *
*       (RI1 ETANT UNE RIGIDITE PROJETEE SUR UNE BASE MODALE)          *
*           POUR GENERER UNE SEULE RIGIDITE ELEMENTAIRE RI2            *
*  (EQUIVALENT DE L'ASSEMBLAGE LORSQUE RI1 EST PORTEE PAR UN MAILLAGE  *
*   PHYSIQUE)                                                          *
* _____________________________________________________________________*
*                                                                      *
*     DATE : le 9 Mars 1995                                            *
*     AUTEUR : Nicolas BENECH                                          *
* _____________________________________________________________________*
*                                                                      *
*     MODULE(S) APPELANT(S) : VIBRAC                                   *
*                                                                      *
*     MODULE(S) APPELE(S) : POSPT                                      *
* _____________________________________________________________________*
*                                                                      *
*     EN ENTREE :                                                      *
*           RI1 : matrice rigidite a "assembler"                       *
*                                                                      *
*     EN SORTIE :                                                      *
*           RI2 : matrice rigidite elementaire                         *
*                                                                      *
************************************************************************
*
-INC CCOPTIO
-INC SMELEME
-INC SMRIGID

      INTEGER I, J, IP, ID, IPP, IDP, LONG, NUMAFF
      LOGICAL AFFICH
      CHARACTER*8 LETYP1
*
* Affichage des messages pour verification
*
      NUMAFF = 20
      AFFICH = ((MOD(IIMPI,NUMAFF) .EQ. 0) .AND. (IIMPI .NE. 0))
*
      SEGACT, RI1
        LETYP1=RI1.MTYMAT
        NRIGEL=RI1.COERIG(/1)
*        IPT1=RI1.IRIGEL(1,1)
c       SEGDES, RI1
*
      NBNN=0
      NBELEM=1
      NBSOUS=0
      NBREF=0
      SEGINI, MELEME
c       SEGDES, MELEME
*
*  Construction de XMATRI
*
      NLIGRD=0
      NLIGRP=0
      nelrig=1
      SEGINI, XMATRI
*
* On parcourt les sous-rigidités ...
*
        IF (AFFICH) WRITE (*,*) 'Debut de l assemblage ...'
c         SEGACT, RI1
        
          DO 20, I=1, NRIGEL
            IPT2 = RI1.IRIGEL(1,I)
            xMATR2 = RI1.IRIGEL(4,I)
*
            SEGACT, IPT2
              LONG = IPT2.NUM(/1)
c             SEGDES, IPT2
*
*            SEGACT, IMATR2
*              XMATR2=IMATR2.IMATTT(1)
*            SEGDES, IMATR2
*
            IF (AFFICH) THEN
              WRITE (*,*) 'Rigidite elementaire ',I
              WRITE (*,*) 'IPT2 = ',IPT2
*              WRITE (*,*) 'IMATR2 = ', IMATR2
              WRITE (*,*) 'XMATR2 = ',XMATR2
              WRITE (*,*) 'Contribution : '
            ENDIF
*
* Calcul de la contribution de la sous-rigidite
*
            SEGACT, XMATR2
            
              DO 30, ID=1, LONG      
                CALL POSPT (IPT2, ID, MELEME, IDP)
* si IDP = 0 le noeud n'a pas ete trouve ...on le rajoute
                IF (IDP.EQ.0) THEN
                  NBNN=NBNN+1
                  SEGADJ, MELEME
c                     SEGACT, IPT2
                      MELEME.NUM(NBNN,1)=IPT2.NUM(ID,1)
c                     SEGDES, IPT2
c                   SEGDES, MELEME
                  IDP = NBNN
                  nelrig=1
                  NLIGRD = NLIGRD+1
                  NLIGRP = NLIGRP+1
                  SEGADJ, XMATRI
                ENDIF
                
                DO 40, IP=1, LONG
                  CALL POSPT (IPT2, IP, MELEME, IPP)
* si IPP = 0 le noeud n'a pas ete trouve ... on le rajoute
                  IF (IPP.EQ.0) THEN
                    NBNN=NBNN+1
                    SEGADJ, MELEME
c                       SEGACT, IPT2
                        MELEME.NUM(NBNN,1)=IPT2.NUM(IP,1)
c                       SEGDES, IPT2
c                     SEGDES, MELEME
                    IPP = NBNN
                    NLIGRD = NLIGRD+1
                    NLIGRP = NLIGRP+1
                    SEGADJ, XMATRI
                  ENDIF
                  XMATRI.RE(IDP,IPP,1)=XMATRI.RE(IDP,IPP,1)
     &                      +RI1.COERIG(I)*XMATR2.RE(ID,IP,1)
 40             CONTINUE
 
 30           CONTINUE
 
            SEGDES,XMATR2,IPT2
            IF (AFFICH) WRITE (*,*) 'Ok !'
            
 20       CONTINUE
 
c       on desactive
        SEGDES,RI1,MELEME,XMATRI
*
* Sauvegarde de XMATRI dans IMATRI
*
       NELRIG = 1
*      SEGINI, IMATRI
*        IMATRI.IMATTT(1) = XMATRI
*      SEGDES, IMATRI
*
* Description des inconnues et duales
*
      SEGINI, DESCR
        DO 3, I=1, NLIGRP
            DESCR.LISINC(I) = 'ALFA'
            DESCR.NOELEP(I) = I
 3        CONTINUE
          DO 4, I=1, NLIGRD
            DESCR.LISDUA(I) = 'FALF'
            DESCR.NOELED(I) = I
 4        CONTINUE
      SEGDES, DESCR
*
* Construction de la rigidite finale
*
      NRIGE=7
      NRIGEL=1
      SEGINI, RI2
        RI2.MTYMAT = LETYP1
        RI2.IFORIG = IFOMOD
        RI2.IMGEO1 = 0
        RI2.IMGEO2 = 0
        RI2.COERIG = 1.D0
        RI2.IRIGEL(1,1) = MELEME
        RI2.IRIGEL(2,1) = 0
        RI2.IRIGEL(3,1) = DESCR
        RI2.IRIGEL(4,1) = xMATRI
        RI2.IRIGEL(5,1) = NIFOUR
        RI2.IRIGEL(6,1) = 0
        RI2.IRIGEL(7,1) = 2
      SEGDES, RI2
*
      RETURN
      END