C ASSEM2    SOURCE    MB234859  26/09/01    21:15:06     12631          
      SUBROUTINE ASSEM2(ITRAV1,INSYM,MMMTRI,INUIN1,
     &                  ITOPO1,IPO1,IITOP1,INCTR1,
     &                  ITOPO2,IPO2,IITOP2,INCTR2,INORMU)
C-----------------------------------------------------------------------
C Realise l'assemblage des matrices elementaires
C
C  Entrees :
C  ---------
C    ITRAV1 : Pointeur sur un objet MRIGID
C    INSYM  : Entier precisant si les matrices sont symetriques (=0) 
C             ou non (=1)
C    MMMTRI : Pointeur sur un objet MMATRI
C    Informations provenant de ASSEM1 :
C    INUIN1 : Pointeur sur le segment INUINV
C    ITOPO1 : Pointeur sur le segment ITOPO
C    IPO1   : Pointeur sur le segment IPOS
C    IITOP1 : Pointeur sur le segment IITOP
C    INCTR1 : Pointeur sur le segment INCTRR
C    Pour les matrices non symetriques, les informations supplementaires
C    ITOPO2 : Pointeur sur le segment ITOPO
C    IPO2   : Pointeur sur le segment IPOS
C    IITOP2 : Pointeur sur le segment IITOP
C    INCTR2 : Pointeur sur le segment INCTRR
C    INORMU : Entier indiquant si on veut normaliser les multiplicateurs 
C             de Lagrange (>0) ou non (=0)
C
C  Sorties :
C  ---------
C    MMMTRI : Pointeur sur un objet MMATRI contenant les informations 
C             suiavntes en plus
C    IJMAX  : Entier donnant le nb de terme max sur une ligne
C    IDIAG  : Pointeur sur le segment MDIAG
C    IDNORM : Pointeur sur le segment MDNOR
C    IILIGN : Pointeur sur le segment MILIGN de la partie inferieure
C    En plus pour les matrices non symetriques
C    IDNORD : Pointeur sur le segment MDNOR
C    IILIGS : Pointeur sur le segment MILIGN de la partie superieure
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCREEL
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMRIGID
-INC SMMATRI
C
      SEGMENT,INUINV(NNGLOB)
      SEGMENT,ITOPO(IENNO)
      SEGMENT,IITOP(NNOE+1)
      SEGMENT,IPOS(NNOE1)
      SEGMENT,INCTRR(NIRI)
      SEGMENT,INCTRS(NIRI)
      SEGMENT,INCTRA(NLIGRE)
      SEGMENT,INCTRB(NLIGRE)
      SEGMENT,IPV(NNOE)
      SEGMENT,VMAX(INC)
      SEGMENT,IVAL(NNN)
      SEGMENT,ITRA(NNN,2)
      SEGMENT TRATRA
        REAL*8  XTRA(INCRED,INCDIF)
        INTEGER LTRA(INC,INCDIF)
        INTEGER NTRA(INCRED,INCDIF)
        INTEGER MTRA(INCDIF)
      ENDSEGMENT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C  ****  IVAL(I)=J    : LA I EME LIGNE D'UNE PETITE MATRICE S'ASSEMBLE
C                       DANS LA J EME DE LA GRANDE.
C  ****  ITRAV(I,1)=J : LA IEME INCONNUE DU NOEUD EN COURS D'ASSEMBLAGE
C                       ET QUI SE TROUVE DANS LA PETITE MATRICE SE TROUVE
C                       EN J EME POSITION DE LA PETITE MATRICE.
C  ****  ITRAV(I,2)   : LA IEME INCONNUE DU NOEUD EN COURS D'ASSEMBLAGE
C                       PRESENT DANS LA PETITE MATRICE EST EN JEME
C                       POSITION DANS LA GRANDE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SEGMENT,RA(N1,N1)*D
      SEGMENT JNOMUL
         LOGICAL INOMUL(NNR)
      ENDSEGMENT
      REAL*8 DMAX,COER,DMAXY,DMAXGE
      LOGICAL NOMUL,bSUP,bNONSYM,bNORMAL
C
      SAVE NJTOT
      DATA NJTOT/0/
C
      bNONSYM=(INSYM.EQ.1)
      bNORMAL=(NORINC.NE.0)
C
C  PV  ON ACTIVE UNE FOIS POUR TOUTES LES MELEME DESCR... DE LA RIGIDITE
C      ON EN PROFITE POUR CREER INOMUL
C
C  ****  RECHERCHE DE LA DIMENSION MAX DE IVAL,ET SEGINI DE IVAL ET ITRA
C
      INCTRR=INCTR1
      SEGACT,INCTRR
      IF (bNONSYM) THEN
        INCTRS=INCTR2
        SEGACT,INCTRS
      ENDIF
C
      MRIGID=ITRAV1
      SEGACT,MRIGID*MOD
      MRIGID.ICHOLE=MMMTRI
      NNR=IRIGEL(/2)
      NNN=0
      SEGINI JNOMUL
      DO 1 IRI=1,NNR
        IPT1=IRIGEL(1,IRI)
        SEGACT,IPT1
        ipt2=IRIGEL(2,IRI)
        if (ipt2.ne.0) segact,ipt2
        INCTRA=INCTRR(IRI)
        SEGACT,INCTRA
        DESCR=IRIGEL(3,IRI)
        SEGACT,DESCR
        NA=LISINC(/2)
        IF (bNONSYM) THEN
          INCTRB=INCTRS(IRI)
          SEGACT,INCTRB
          NA=MAX(NA,LISDUA(/2))
        ENDIF
        NNN=MAX(NA,NNN)
        INOMUL(IRI)=.TRUE.
        IF (IPT1.ITYPEL.EQ.49) INOMUL(IRI)=.FALSE.
   1  CONTINUE
      SEGINI,IVAL
      SEGINI,ITRA
C
C  ****  ACTIVATION DES SEGMENTS DE TRAVAILS ET DE MMATRI
C
      MMATRI=MMMTRI
      SEGACT,MMATRI*MOD
      INUINV=INUIN1
      SEGACT,INUINV
      ITOPO=ITOPO1
      SEGACT,ITOPO
      IITOP=IITOP1
      SEGACT,IITOP
      IPOS=IPO1
      SEGACT,IPOS
      MINCPO=IINCPO
      SEGACT,MINCPO
      INCDIF=INCPO(/1)
      IF (bNONSYM) THEN
        ITOPO=ITOPO2
        SEGACT,ITOPO
        IITOP=IITOP2
        SEGACT,IITOP
        IPOS=IPO2
        SEGACT,IPOS
        MIPO1=IDUAPO
        SEGACT,MIPO1
        INCDID=MIPO1.INCPO(/1)
        INCDIF=MAX(INCDIF,INCDID)
      ELSE
        ITOPO2=ITOPO1
        IITOP2=IITOP1
        IPO2=IPO1
      ENDIF
C     NNOE : nombre de noeuds
      NNOE=IPOS(/1)-1
C     INC : dimension de la matrice
      INC=IPOS(NNOE+1)
      NJTOT=0
      IJMAX=0
      SEGINI,MDIAG
      IDIAG=MDIAG
      SEGINI,MILIGN
      IILIGN=MILIGN
      IF (bNONSYM) THEN
        SEGINI,MILIGN
        IILIGS=MILIGN
      ENDIF
C
      SEGINI IPV
      INCRED=0
      DO 80 INO=1,NNOE
C
        ICOMPT=0
        ITOPO=ITOPO2
        IITOP=IITOP2
        IPOS=IPO2
        bSUP=.FALSE.
C
 84     CONTINUE
        MAXELE = (IITOP(INO+1)-IITOP(INO))/2
        DO 81 IELE=1,MAXELE
          IIU=IITOP(INO) + IELE + IELE -2
          IEL=ITOPO(IIU)
          IRI=ITOPO(IIU+1)
          meleme=IRIGEL(2,IRI)
          if (meleme.eq.0) meleme=IRIGEL(1,IRI)
          DO 83 I=1,NUM(/1)
            IP=INUINV(NUM(I,IEL))
            IF (IP.GT.INO) GOTO 83
            IF (IPV(IP).EQ.INO) GOTO 83
            IPV(IP)=INO
            ICOMPT=ICOMPT+1
 83       CONTINUE
 81     CONTINUE
        INCRED=MAX(INCRED,ICOMPT)
C
        IF (bNONSYM.AND.(.NOT.bSUP)) THEN
          ITOPO=ITOPO1
          IITOP=IITOP1
          IPOS=IPO1
          bSUP=.TRUE.
          GOTO 84
        ENDIF
C
  80  CONTINUE
      SEGSUP IPV
C
      INCRED=INCRED*INCDIF
      SEGINI TRATRA
      SEGINI VMAX
C
C ... Coefficients de normalisation ...
C     -----------------------------
      SEGINI,MDNOR
      IDNORM=MDNOR
      IF (bNONSYM) THEN
        SEGINI,MDNO1
        IDNORD=MDNO1
      ENDIF
      IF (bNORMAL) THEN
        inwuit=0
        CALL ASSE10(MRIGID,1,INUIN1,inwuit)
      ELSE
        DO IU=1,INC
          DNOR(IU)=1.d0
          IF (bNONSYM) MDNO1.DNOR(IU)=1.d0
        ENDDO
      ENDIF
C
C  ****  BOUCLE   *100* SUR LES NUMEROS DE NOEUDS QUE L'ON ASSEMBLE
C        -------------------------------------------------------------
      LLVNUL=0
      DO 100 INO=1,NNOE
C
        MILIGN=IILIGN
        ITOPO=ITOPO2
        IITOP=IITOP2
        IPOS=IPO2
        bSUP=.FALSE.
C
 113    CONTINUE
        DO 101 IIT=1,INCDIF
          MTRA(IIT)=0
 101    CONTINUE

        IPRE=IPOS(INO)+1
        IDER=IPOS(INO+1)
        LLVVA=0
C
C  ****  BOUCLE   *99*   SUR LES ELEMENTS TOUCHANT LE NOEUD INO
C                        POUR LES ELEMNTS MULTIPLICATEUR ON NE FAIT PAS
C                        L'ASSEMBLAGE
C
        MAXELE= (IITOP(INO+1) -IITOP(INO))/2
        DO 99 IELE=1,MAXELE
          IIU=IITOP(INO) + IELE + IELE - 2
          IEL=ITOPO(IIU)
          IRI=ITOPO(IIU+1)
          MELEME=IRIGEL(1,IRI)
          DESCR=IRIGEL(3,IRI)
          INCTRA=INCTRR(IRI)
          IF (bNONSYM) INCTRB=INCTRS(IRI)
          XMATRI=IRIGEL(4,IRI)
          SEGACT,XMATRI
          COER=COERIG(IRI)
          NOMUL=INOMUL(IRI)
C
C  ****  NOMUL =.FALSE.  IL EXISTE  UN MULTIPLICATEUR
C  ****  INITIALISATION DE IVAL. IVAL(I)=J VEUT DIRE QUE
C  ****  LA I EME LIGNE DE LA PETITE MATRICE S'ASSEMBLE DANS
C  ****  LA J EME DE LA GRANDE MATRICE.
C
          NA=0
          IF (bNONSYM) THEN
C
C           Identifier les lignes (colonnes) a remplir
            IF (bSUP) THEN
              NIN=LISINC(/2)
            ELSE
              NIN=LISDUA(/2)
            ENDIF
            DO 96 ICO=1,NIN
              IF (bSUP) THEN
                IJA=INUINV(NUM(NOELEP(ICO),IEL))
                IJB=INCTRA(ICO)
              ELSE
                IJA=INUINV(NUM(NOELED(ICO),IEL))
                IJB=INCTRB(ICO)
              ENDIF
              IF (IJA.NE.INO) GOTO 96
C             NA-eme DDL associe au noeud
C             bSUP = T : partie superieure
C             Sa colonne dans la matrice elementaire est ICO
C             Sa colonne dans la matrice assemblee   est ICA
C             bSUP = F : partie inferieure
C             Sa ligne dans la matrice elementaire est ICO
C             Sa ligne dans la matrice assemblee   est ICA
              NA=NA+1
              ITRA(NA,1)=ICO
              IF (bSUP) THEN
                ICA=INCPO(IJB,IJA)
              ELSE
                ICA=MIPO1.INCPO(IJB,IJA)
              ENDIF
              ITRA(NA,2)=ICA
 96         CONTINUE

            IF (bSUP) THEN
              NIN=LISDUA(/2)
            ELSE
              NIN=LISINC(/2)
            ENDIF
C           Identifier les colonnes (lignes) ou ajouter des valeurs
            DO 98 ICO=1,NIN
              IF (bSUP) THEN
                IJA=INUINV(NUM(NOELED(ICO),IEL))
                IJB=INCTRB(ICO)
                IVAL(ICO)=MIPO1.INCPO(IJB,IJA)
              ELSE
                IJA=INUINV(NUM(NOELEP(ICO),IEL))
                IJB=INCTRA(ICO)
                IVAL(ICO)=INCPO(IJB,IJA)
              ENDIF
  98        CONTINUE
          ELSE
            NIN=LISINC(/2)
            DO 97 ICO=1,NIN
              IJA=INUINV(NUM(NOELEP(ICO),IEL))
              IJB=INCTRA(ICO)
              IVAL(ICO)=INCPO(IJB,IJA)
              IF (IJA.NE.INO)  GOTO 97
              NA=NA+1
              ITRA(NA,1)=ICO
              ITRA(NA,2)=IVAL(ICO)
 97         CONTINUE
          ENDIF
C
C  ****  BOUCLE  *95* SUR LES INCONNUES DE LA PETITE MATRICE
C
          DO 95 INCC=1,NA
            INCO=ITRA(INCC,2)
            if (inco.gt.ider) goto 95
            ILOC=INCO-IPRE+1
            JJ=ITRA(INCC,1)
            DO 90 IK=1,NIN
              IO=IVAL(IK)
              IF (IO.GT.INCO)  GOTO 90
              ILTT= LTRA(IO,ILOC)
              IF (ILTT.EQ.0) THEN
                LLVVA=LLVVA+1
                IMMTT=MTRA(ILOC)+1
                MTRA(ILOC)=IMMTT
                XTRA(IMMTT,ILOC)=0.D0
                NTRA(IMMTT,ILOC)=IO
                LTRA(IO,ILOC)=IMMTT
                ILTT=IMMTT
              ENDIF
              IF (NOMUL) THEN
C               Symetrie de RE
                IF ((.NOT.bNONSYM).OR.(bSUP)) THEN
                  XTRA(ILTT,ILOC)=XTRA(ILTT,ILOC)+RE(IK,JJ,IEL)*COER
                ELSE
                  XTRA(ILTT,ILOC)=XTRA(ILTT,ILOC)+RE(JJ,IK,IEL)*COER
                ENDIF
              ENDIF
 90         CONTINUE
 95       CONTINUE
 99     CONTINUE
C
C  *** COMPACTAGE DES LIGNES, EN MEME TEMPS CALCUL DE IJMAX QUI SERA
C  *** LA DIMENSION MAX D'UN SEGMENT LIGN.
C  *** LE SEGMENT ASSOCIE A UNE LIGNE (SEGMENT LLIGN) EST DE LA FORME :
C  *** IMMMM(NA) PERMET DE SAVOIR SI UN MOUVEMENT D'ENSEMBLE SUR LA
C  *** LIGNE EXISTE. IPPO(NA+1) DONNE LA POSITION DANS XXVA LA 1ERE
C  *** VALEUR DE LA LIGNE .XXVA  VALEUR DE LA MATRICE.
C  *** LINC(I) DONNE LE NUMERO DE LA COLONNE DU IEME ELEM DE XXVA
C
        NA = IDER-IPRE+1
        LLVNUL=LLVNUL+LLVVA
        SEGINI,LLIGN
        MILIGN.ILIGN(INO)=LLIGN
        NBA=0
        DO 120 JPA=1,NA
          IIIN=IPRE+JPA -1
          IMMMM(JPA)=IIIN
          IPPO(JPA)=NBA
          DO 121 IPAK = 1,MTRA(JPA)
            IUNPAK=NTRA(IPAK,JPA)
            LTRA(IUNPAK,JPA)=0
            NBA=NBA+1
            LINC(NBA)=IUNPAK
            XXVA(NBA)=XTRA(IPAK,JPA)
            vmax(iiin)=max(abs(xxva(nba)),vmax(iiin))
            IF (.NOT.bSUP) THEN
              IF (IIIN.EQ.IUNPAK) DIAG(IIIN)=XXVA(NBA)
            ENDIF
 121      CONTINUE
 120    CONTINUE
        IPPO(NA+1)= NBA
        NJMAX=0
C  recherche du mini globale sur toutes les inconnues
        LPA=IPRE
        DO 126 JPA=IPRE,IDER
          MILIGN.IPNO(JPA)=INO
          IPDE=IPPO(JPA-IPRE+1)+1
          IPDF=IPPO(JPA-IPRE+2)
          DO 155 JHT=IPDE,IPDF
            LPA=MIN(LPA,LINC(JHT))
 155      CONTINUE
 126    CONTINUE
        DO 127 JPA=IPRE,IDER
          LDEB(JPA-IPRE+1)=LPA
          NNA= JPA- LPA       +1
          NJMAX=NJMAX+NNA
 127    CONTINUE
        NJTOT=NJTOT+NJMAX
        IF (IJMAX.LT.NJMAX) IJMAX=NJMAX
        SEGDES,LLIGN
C
        IF (bNONSYM.AND.(.NOT.bSUP)) THEN
          MILIGN=IILIGS
          ITOPO=ITOPO1
          IITOP=IITOP1
          IPOS=IPO1
          bSUP=.TRUE.
          GOTO 113
        ENDIF
C
 100  CONTINUE
      SEGSUP TRATRA
C
C  ****  ON REPREND TOUTE LES MATRICES CONTENANT LES MULTIPLICATEURS
C  ****  POUR MULTIPLIER TOUS LEURS TERMES PAR UNE NORME ATTACHEE
C  ****  A CHAQUE MULTIPLICATEUR. PUIS ON LES ASSEMBLE.
C
*  d'abord etablir une norme generale pour le cas ou on n'arrive pas
*  a calculer la norme particuliere
      DMAXGE=XPETIT
      DO 378 I=1,INC
        DMAXGE=MAX(DMAXGE,abs(vmax(i)))
  378 CONTINUE
      if (iimpi.ne.0)
     >  write (6,*) ' nb inconnues facteur multiplicatif general ',
     >  INC,DMAXGE
      if (dmaxge.lt.xpetit/xzprec) dmaxge=1.d0
      IENMU=0
C
 375  CONTINUE
      IENMU1=IENMU
      IENMU =0
      DO 376 I=1,NNR
        IF (.NOT.INOMUL(I)) IENMU=IENMU+1
 376  CONTINUE
      IF (IENMU.EQ.0) GOTO 3750
      DO 11 I=1,NNR
        IF (INOMUL(I)) GOTO 11
        DESCR=IRIGEL(3,I)
        N3=LISINC(/2)
        COER=COERIG(I)
        MELEME=IRIGEL(1,I)
        INCTRA=INCTRR(I)
        XMATRI=IRIGEL(4,I)
        N2=NUM(/2)
        IF (RE(/3).EQ.0) THEN
          INOMUL(I)=.TRUE.
          SEGDES XMATRI
          GOTO 11
        ENDIF
        N1=RE(/1)
C
C       ERREUR 756 : La matrice de rigidite n'est pas carree
        IF (N1.NE.RE(/2)) THEN
          CALL ERREUR(756)
          RETURN
        ENDIF
C
        SEGINI,RA
        DO 14 IEL=1,N2
C
          MILIGN=IILIGN
          bSUP=.FALSE.
C
 213      CONTINUE
          DO 15 ICO=1,N3
            IJA=INUINV(NUM(NOELEP(ICO),IEL))
            IJB=INCTRA(ICO)
            IVAL(ICO)=INCPO(IJB,IJA)
 15       CONTINUE
C
C         JCARDO => pour les fous qui veulent se passer de la
C                   normalisation des mult. de Lagrange :)
          IF (INORMU.EQ.0) THEN
            DMAX=1.D0
            DMAXY=DMAX
          ELSE
C           Max termes diag des inconnues presentes dans la relation
            DMAX=xpetit
C           Boucle demarre a 3 car les deux premiers sont les multiplicateurs de lagrange
            DO 19 ICO=3,N3
              DMAX=MAX(DMAX,vmax(IVAL(ICO)))
 19         CONTINUE
C   AUX FINS D'EVITER DES PROBLEMES DANS LA DECOMPOSITION
            IF (IIMPI.EQ.1524) WRITE(IOIMP,7391)DMAX,IENMU,IENMU1,I,IEL
 7391       FORMAT(' DMAX IENMU IENMU1 I IEL',1E12.5,4I3)
            IF (DMAX.LE.XZPREC*DMAXGE) THEN
              IF (IENMU.NE.IENMU1.AND.IEL.EQ.1) GOTO 377
              DMAX=DMAXGE
            ENDIF
            DMAX=DMAX*1.5D0
C           Max des coeffs de la relation
            DMAXY=SQRT(XPETIT)*1D5
            IF (.NOT.bNORMAL) DMAXY=1.D0
*  demarrage a 3 aussi. On a toujours 1 -1 sur les LX
            DO ICO=3,N1
              DMAXY=MAX(DMAXY,ABS(RE(ICO,1,IEL)))
            ENDDO
            DMAX = DMAX / DMAXY
C
            if (bSUP) dmax=dnor(ival(1))
          ENDIF
C
          IF (IIMPI.EQ.1524) WRITE(IOIMP,7398) DMAX
 7398     FORMAT('  facteur multiplicatif de norme ',e12.5)
          DO 21 ICO=1,N1
            DO 2110 IKO=1,N3
              RA(ICO,IKO)=RE(ICO,IKO,IEL)*COER*DMAX
 2110       CONTINUE
 21       CONTINUE
**  si on ne booste pas l'egalite des mults on a des problemes de precision sur ceux ci
          IF (.NOT.bNORMAL) DMAXY=DMAXY*2.D0
          RA(1,1)=RA(1,1)*DMAXY
          RA(2,1)=RA(2,1)*DMAXY
          RA(1,2)=RA(1,2)*DMAXY
          RA(2,2)=RA(2,2)*DMAXY
          IF (.NOT.bSUP) THEN
            DO 22 ICO=1,2
              DNOR(IVAL(ICO))=DMAX
              IF (bNONSYM) MDNO1.DNOR(IVAL(ICO))=DMAX
   22       CONTINUE
          ENDIF
          DO 24 ICO=1,N3
            INO=INUINV(NUM(NOELEP(ICO),IEL))
            IO=IVAL(ICO)
            if (ico.eq.1) io1=io
            if (ico.eq.2) io2=io
            LLIGN=MILIGN.ILIGN(INO)
            SEGACT,LLIGN*MOD
            IF (.NOT.bSUP) DIAG(IO)=DIAG(IO)+RA(ICO,ICO)
            DO 132 JLIJ=1,IMMMM(/1)
              JLIJ1=JLIJ
              IF (IMMMM(JLIJ).EQ.IO) GOTO 133
 132        CONTINUE
            IF (IIMPI.EQ.1524) WRITE(IOIMP,7354)
 7354       FORMAT( ' PREMIERE ERREUR 5')
            CALL ERREUR(5)
            RETURN
 133        CONTINUE
            DO 26 IRO=1,N1
              IA=IVAL(IRO)
              IF (IA.GT.IO) GOTO 26
              JLT=IPPO(JLIJ1+1)
              JLD=IPPO(JLIJ1)+1
              DO 134 JL=JLD,JLT
                JL1=JL
                IF (LINC(JL).EQ.IA) GOTO 135
 134          CONTINUE
              IF (IIMPI.NE.1524) WRITE(IOIMP,7355)
 7355         FORMAT( ' DEUXIEME ERREUR 5')
              CALL ERREUR(5)
              RETURN
 135          CONTINUE
              IF (bSUP) THEN
                XXVA(JL1)=XXVA(JL1)+RA(IRO,ICO)
              else
                XXVA(JL1)=XXVA(JL1)+RA(ICO,IRO)
              endif
 26         CONTINUE
            SEGDES,LLIGN
 24       CONTINUE
C  on stocke dans ittr les couples de LX
          MILIGN.ittr(io1)=io2
          MILIGN.ittr(io2)=io1
C
          IF (bNONSYM.AND.(.NOT.bSUP)) THEN
            MILIGN=IILIGS
            bSUP=.TRUE.
            GOTO 213
          ENDIF
C
 14     CONTINUE
        INOMUL(I)=.TRUE.
 377    CONTINUE
        SEGSUP,RA
 11   CONTINUE
      GOTO 375
C
 3750 CONTINUE
C  PV ON DESACTIVE TOUT
      NNR=IRIGEL(/2)
      DO 2 IRI=1,NNR
        DESCR=IRIGEL(3,IRI)
        SEGDES DESCR
        IPT1=IRIGEL(1,IRI)
        XMATRI=IRIGEL(4,IRI)
        SEGDES XMATRI
   2  CONTINUE
C
      IF (IIMPI.EQ.1457) WRITE(IOIMP,4821) LLVNUL,NJTOT
 4821 FORMAT('  NB DE VALEURS NON NULLES DANS LA MATRICE ',I9,/
     &       '  NB DE VALEURS DANS LA MATRICE            ',I9)
C
C     Suppression des matrices normalisees
      IF (bNORMAL) CALL ASSE10(MRIGID,2,INUIN1,inwuit)
C
      ITOPO=ITOPO1
      IITOP=IITOP1
      IPOS=IPO1
      SEGSUP,IITOP,ITOPO,IPOS
      DO IK=1,NNR
        INCTRA=INCTRR(IK)
        SEGSUP,INCTRA
      ENDDO
      SEGSUP,INCTRR
      IF (bNONSYM) THEN
        ITOPO=ITOPO2
        IITOP=IITOP2
        IPOS=IPO2
        SEGSUP,IITOP,ITOPO,IPOS
        DO IK=1,NNR
          INCTRB=INCTRS(IK)
          SEGSUP,INCTRB
        ENDDO
        SEGSUP,INCTRS
        SEGDES,MIPO1
      ENDIF
      SEGSUP,INUINV
C
      SEGACT MRIGID*MOD
      NNR=IRIGEL(/2)
      DO IRI=1,NNR
        IPT2=IRIGEL(2,IRI)
        IF (IPT2.NE.0) THEN
          SEGSUP,IPT2
          IRIGEL(2,IRI)=0
        ENDIF
      ENDDO
      SEGDES,MRIGID
      SEGDES,MINCPO
      SEGDES,MDIAG
      SEGDES,MDNOR
      SEGDES,MILIGN
      SEGDES,MMATRI
      SEGSUP,IVAL,ITRA,JNOMUL,VMAX
      END