C QZCONS    SOURCE    BP208322  12/10/03    21:15:26     7517           
      SUBROUTINE QZCONS(RI1,RI2,RI3,XMATR1,XMATR2,MELEME,MLMOTS,DOUBLE)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
**********************************************************************************
*                                                                                *
*          CONSTITUTION DES MATRICES A ET B DE TAILLE 2Nx2N POUR LE QZ           *
* ______________________________________________________________________________ *
*                                                                                *
*                                                                                *
*    DATE : le 24 Fevrier 1995                                                   *
*    AUTEUR : Nicolas BENECH                                                     *
* ______________________________________________________________________________ *
*                                                                                *
*    MODULE(S) APPELANT(S) : VIBRAC                                              *
*                                                                                *
*    MODULE(S) APPELE(S) : ASSMAT, POSPT                                         *
* ______________________________________________________________________________ *
*                                                                                *
*   EN ENTREE :                                                                  *
*      - RI1 : matrice masse                                                     *
*      - RI2 : matrice raideur                                                   *
*      - RI3 : matrice amortissement                                             *
*      -DOUBLE : indique si on double le maillage                                *
*                                                                                *
*      !!!! RI1, RI2 et RI3 sont SUPPRIMEES en fin de QZCONS !!!                 *
*                                                                                *
*   EN SORTIE :                                                                  *
*      - XMATR1, XMATR2 : les matrices A et B 2nx2n                              *
*               | -K . 0  |            |  C . M  |                               *
*           A = | ....... |        B = | ....... |                               *
*               |  0 . M  |            |  M . 0  |                               *
*                                                                                *
*      - MELEME : le maillage support                                            *
*      - MLMOTS : les composantes                                                *
**********************************************************************************
*
-INC CCOPTIO
-INC SMELEME
-INC SMLMOTS
-INC SMRIGID
*
      LOGICAL AFFICH,DOUBLE
      INTEGER I, J, NBPT, P, MAT(3), NUMAFF
*
* Affichage des messages pour verification
*
      NUMAFF = 21
      AFFICH = ((MOD(IIMPI,NUMAFF) .EQ. 0) .AND. (IIMPI.NE.0) )
*
      SEGACT, RI1
        IPT1=RI1.IRIGEL(1,1)
        DESCR=RI1.IRIGEL(3,1)
      SEGDES, RI1
*
      SEGINI, MELEME=IPT1
        NBPT = MELEME.NUM(/1)
c       SEGDES, MELEME
*
* Tests sur les matrices a assembler : maillages identiques ? dimensions ? ...
*
      MAT(1)=RI1
      MAT(2)=RI2
      MAT(3)=RI3
      
      DO 5, I=1, 3
      
        MRIGID=MAT(I)
        
        IF (MRIGID.NE.0) THEN
          SEGACT, MRIGID
            xMATRI=MRIGID.IRIGEL(4,1)
            IPT1= MRIGID.IRIGEL(1,1)
          SEGDES, MRIGID
*
* Verification des maillages
*
          SEGACT, IPT1
            IF (IPT1.NUM(/1) .NE. NBPT) THEN
              CALL ERREUR(47)
              RETURN
            ENDIF
            DO 7, J=1, NBPT
              CALL POSPT(IPT1,J,MELEME, P)
              IF (P.EQ.0) THEN
                CALL ERREUR(47)
                RETURN
              ENDIF
 7          CONTINUE
          SEGDES, IPT1
*
* Verification de la dimension des matrices
*
*          SEGACT, IMATRI
*            XMATRI=IMATRI.IMATTT(1)
*          SEGDES, IMATRI
          SEGACT, XMATRI
            IF (((XMATRI.RE(/1)).NE.NBPT)
     &         .OR. ((XMATRI.RE(/2)).NE.NBPT)) THEN
                CALL ERREUR(47)
                RETURN
            ENDIF
          SEGDES, XMATRI
        ENDIF
        
 5    CONTINUE
*
* Assemblages
*
      IF (AFFICH)
     &  WRITE (*,*) 'Assemblage de la premiere matrice ...'
      NLIGRD=2*NBPT
      NLIGRP=2*NBPT
          nelrig=1
      SEGINI, XMATR1
c       SEGDES, XMATR1
      CALL ASSMAT (MELEME,-1.d0,RI2,0.d0,0,0.d0,0,1.d0,RI1,XMATR1)
      SEGINI, XMATR2
c       SEGDES, XMATR2
      IF (AFFICH)
     &  WRITE (*,*) 'Assemblage de la seconde matrice ...'
      CALL ASSMAT (MELEME,1.d0,RI3,1.d0,RI1,1.d0,RI1,0.d0,0,XMATR2)
*
* Recuperation des composantes
*
      SEGACT, DESCR
        IF (AFFICH) THEN
          WRITE (*,*) 'Longueur du DESCR : ', DESCR.LISINC(/2)
          WRITE (*,*) 'Nombre de points : ', NBPT
        ENDIF
        JGM = INT(DESCR.LISINC(/2)/NBPT)
        JGN=4
        SEGINI, MLMOTS
          DO 10, I=1,JGM
            MLMOTS.MOTS(I)=DESCR.LISINC(I)
 10       CONTINUE
        SEGDES, MLMOTS
      SEGDES, DESCR
*
* Reorganisation du maillage pour la creation des CHPOINTs
*
      NBELEM = NBPT
      NBNN=1
      NBSOUS=0
      NBREF=0
      SEGINI , IPT1
c         SEGACT, MELEME
          DO 1, I=1, NBPT
            IPT1.NUM(1,I)=MELEME.NUM(I,1)
 1        CONTINUE
        SEGSUP, MELEME
        IF (DOUBLE) THEN
          NBELEM = NBPT*2
          SEGADJ, IPT1
          DO 2, I=1, NBPT
            CALL CREPO1 (0.0D0,0.0D0,0.0D0,IPOIN)
            IPT1.NUM(1,I+NBPT)=IPOIN
 2        CONTINUE
        ENDIF
      SEGDES, IPT1
      MELEME = IPT1
*
* Menage !
*
      SEGSUP, RI1
      SEGSUP, RI2
      IF (RI3.NE.0) SEGSUP, RI3
*
      RETURN
      END