C ASSEM4    SOURCE    PV090527  26/04/30    21:15:08     12529          
      SUBROUTINE ASSEM4(IPOIRI,NOINC,SNOMIN,NOMAI,MMATRX,
     #   INUINY,ITOPOY,INCTRY,IITOPY,NBNNMA,NLIGRA,SNTT,SNTO,DES1)

** CETTE SUBROUTINE EFFECTUE LA PREPARATION A L'ASSEMBLAGE DANS LE CAS DU CALCUL DU
**  SUPER-ELEMENT

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER*4 CMOT


-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC SMRIGID
-INC SMMATRI
-INC CCREEL

      SEGMENT,IMIN(NNOE)
      SEGMENT,ICPR(nbpts)
      SEGMENT,INUINV(NNGLOB)
      SEGMENT,INUIN2(2*NNOE)
      SEGMENT,ITOPO(IENNO)
      SEGMENT,IITOP(NNOE+1)
      SEGMENT,INCTRR(NIRI)
      SEGMENT,INCTRA(NLIGRE)
      SEGMENT DIATMP(maxinc,NNOE)
      segment strv
       integer itrv1(maxinc)
       integer itrv2(maxinc)
       real*8 dtrv1(maxinc)
       real*8 dtrv2(maxinc)
      endsegment
C
C  ****  CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG
C  ****  IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE.
C
C
C  ****   MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD
C
C  ****   IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN
C                    IEME POSITION DANS ITOPO
C  ****   ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA
C         ITOPO(I+1)=M  MATRICE EST LE LIEME  DE L'OBJET GEOMETRIE
C                       DEFINI PAR LE POINTEUR M
C  ****  INUINV(I)=J    J EST LE NOUVEAU NUMERO DU NOEUD I
C

**  SEGMENTS DE TRAVAIL

      SEGMENT NOMAI(nbpts)
      SEGMENT NOINC(NNIN,ITA)
      SEGMENT SNOMIN
        CHARACTER*(LOCOMP) NOMIN(M)
      ENDSEGMENT
      SEGMENT SNTO
        INTEGER NTOTMA(NN)
      ENDSEGMENT
C
      SEGMENT SNTT
        INTEGER NTTMAI(NN)
      ENDSEGMENT
C
      SEGMENT ILOCAL(NBNUM)
C
**   NOMAI(I)<>0 SI LE NOEUD I EST MAITRE (I=N° ABSOLU)
C
**   NOINC(I,J)=1 SI L'INCONNUE I EXISTE POUR LE NOEUD J (J=N° LOCAL)
C
**   NOMIN(I)= INCO : L'INCONNUE N°I EST L'INCONNUE DE NOM 'INCO'
**                 CE SEGMENT NE CONTIENT QUE LES INCONNUES MAITRESSES
**   NTOTMA : SEGMENT DES NOEUDS MAITRES POUR LESQUELS TOUTES LES INCONNUES
**            SONT MAITRESSES
**   NTTMAI : SEGMENT DES NOEUDS MAITRES QUI N'ONT PAS TOUTES LEURS INCONNUES
**            MAITRESSES
**   ILOCAL : SEGMENT DES NUMEROS LOCAUX


*      DATA MOALFA/'ALFA'/
       CHARACTER*4 CNOHA
       integer*4 noha
       equivalence (cnoha,noha)
       DATA CNOHA/'NOHA'/
      DATA IPOIN/1/

      NNGLOB=nbpts

      MRIGID=IPOIRI
      SEGACT,MRIGID

      NNVA=IRIGEL(/2)
      NIRI=NNVA
      SEGINI,INCTRR
      MVA=IRIGEL(/1)
      MELEME=IRIGEL(1,1)
      SEGACT,MELEME
      IF(ITYPEL.NE.27) GO TO 801
      SEGDES MELEME
C
C  **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS
C  **** DANS ICPR
C
      SEGINI,INUINV,ICPR
      IKI=0
      DO 700 I=1,NNVA
      MELEME=IRIGEL(1,I)
      SEGACT,MELEME
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
      DO I1=1,NBELEM
      DO 701 I2=1,NBNN
      IP1=NUM(I2,I1)
      IF(ICPR(IP1).NE.0) GO TO 701
      IKI=IKI+1
      ICPR(IP1)=IKI
 701  CONTINUE
      enddo
      SEGDES MELEME
 700  CONTINUE
C
C  **** FABRICATION DU TABLEAU INUINV
C  **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE
C
      NNOE=IKI
      NALFA=0
      NBETA=0
      DO 710 I=1,NNVA
      MELEME=IRIGEL(1,I)
      DESCR =IRIGEL(3,I)
      SEGACT,MELEME,DESCR
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
      NLIGRE=LISINC(/2)
      DO I1=1,NBELEM
      DO 711 I2=1,NBNN
      IP1=NUM(I2,I1)
      IF(ICPR(IP1).EQ.0) GO TO 711
 715  CONTINUE
      NBETA=NBETA+1
      IKI=NNOE-NBETA+1
 716  CONTINUE
      INUINV(IP1)=IKI
      ICPR(IP1)=0
 711  CONTINUE
      enddo
      SEGDES MELEME,DESCR
 710  CONTINUE
      SEGSUP,ICPR
      ICDOUR=NNOE
      GO TO 800
C
C  ****  ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
C  ****  GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS
C  ****  GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI
C  ****  FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
C  ****  NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
C  ****  LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
C  ****  DE LA MATRICE, ETC...
C

 801  CONTINUE

      NUMDEB=INT(nbpts)
      MAXNUM=NUMDEB

      NBNUM=NUMDEB
      SEGINI,ILOCAL

**  NUMEROTATION LOCALE DE TOUS LES NOEUDS
      IKOU=0
      SEGACT NOMAI
      SEGADJ NOMAI
***   write (6,*) ' dimension de nomai ',nomai(/1),nnglob
      DO 50 I0=1,NNVA
         MELEME=IRIGEL(1,I0)
         SEGACT,MELEME
         DO I2=1,NUM(/2)
          DO 51 I1=1,NUM(/1)
            IJ=NUM(I1,I2)
            IF (ILOCAL(IJ).NE.0.or.nomai(ij).ne.0)  GOTO 51
            IKOU=IKOU+1
            ILOCAL(IJ)=IKOU
  51     CONTINUE
         enddo
        SEGDES MELEME
  50  CONTINUE
      NNOE=IKOU
      DO 52 I=1,NOMAI(/1)
        IF(NOMAI(I).NE.0.AND.ILOCAL(I).EQ.0) THEN
          NNOE=NNOE+1
          ILOCAL(I)=ikou+nomai(i)
        ENDIF
 52   CONTINUE
      SEGDES NOMAI
C
C  RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
C  DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
C
      DO 230 IRI=1,NNVA
      IHARIR=IRIGEL(5,IRI)
      IF(IHARIR.NE.NOHA) THEN
        IARDEF = IHARIR
        GO TO 231
      ENDIF
  230 CONTINUE
      CALL ERREUR ( 21)
      RETURN
  231 CONTINUE
      DO 232 IRI=1,NNVA
      IF( IRIGEL(5,IRI).EQ.NOHA) GO TO 232
      IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232
      CALL ERREUR (21)
      RETURN
 232  CONTINUE
C
C  ****  RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
C
      SEGINI,MIDUA
      SEGINI,MIMIK
      SEGINI,MHARK
      DESCR=IRIGEL(3,1)
      SEGACT,DESCR
      IMIK(**)=LISINC(1)
      IAAR=IRIGEL(5,1)
      IF(IAAR.EQ.NOHA) IAAR = IARDEF
      IHAR(**)= IAAR
      IDUA(**)=LISDUA(1)
      MAXINC=1
      DO 323 IRI=1,NNVA
      DESCR=IRIGEL(3,IRI)
      IHARIR=IRIGEL(5,IRI)
      IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
      SEGACT,DESCR
      NLIGRE=LISINC(/2)
      DO 326 I=1,NLIGRE
      DO 324 J=1,MAXINC
      IF(IMIK(J).NE.LISINC(I)) GO TO 324
      IF(IHAR(J).EQ.IHARIR) GO TO 326
  324 CONTINUE
      MAXINC=MAXINC+1
      IHAR(**)=IHARIR
      IMIK(**)=LISINC(I)
      IDUA(**)=LISDUA(I)
  326 CONTINUE
      SEGDES,DESCR
  323 CONTINUE
      NDUA=IDUA(/2)

C
C  **** INITIALISATION DE INCPOS ET DE INCTRA.
C
      MAXI=MAXINC
      SEGINI DIATMP,strv
      SEGINI,MINCPO
      DO 329 IRI=1,NNVA
       DESCR=IRIGEL(3,IRI)
       IHARIR=IRIGEL(5,IRI)
       IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
       SEGACT,DESCR
       MELEME=IRIGEL(1,IRI)
       SEGACT,MELEME
       NLIGRE=LISINC(/2)
       SEGINI,INCTRA
       INCTRR(IRI)=INCTRA
       N2=NUM(/2)
       IADS=nbpts
       xmatri=irigel(4,iri)
       segact xmatri
       DO 334 J=1,NLIGRE
        DO 333 K=1,MAXINC
         IF(LISINC(J).NE.IMIK(K)) GO TO 333
         IF(IHAR(K).EQ.IHARIR) GO TO 332
  333   CONTINUE
  332   CONTINUE
        INCTRA(J)=K
        DO 331 I=1,N2
         IJ=ILOCAL(NUM(NOELEP(J),I))
         INCPO(K,IJ)=1
         diatmp(k,ij)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
  331    continue
  334  CONTINUE
       SEGDES,DESCR
       SEGDES,INCTRA
  329 CONTINUE
C
      SEGACT,SNOMIN
      SEGACT,NOMAI
      SEGACT,NOINC
      DO 3301 I=1,NOMAI(/1)
        IF(NOMAI(I).EQ.0) GOTO 3301
        N1=NOMAI(I)
        DO 3302 J=1,NOMIN(/2)
          IF(NOINC(J,N1).EQ.0) GOTO 3302
           DO 3303 K=1,IMIK(/2)
            IF(NOMIN(J).EQ.IMIK(K)) GO TO 3304
 3303     CONTINUE
 3304     CONTINUE
          INCPO(K,ILOCAL(I))=1
 3302   CONTINUE
 3301 CONTINUE
C
C
      MAXPOD=MAXINC*NNOE+1
      MAXPO=MAXPOD
      NBNNMA=0
      DO 299 I=1,INCPO(/1)
        DO 2991 J=1,INCPO(/2)
           NBNNMA=NBNNMA+INCPO(I,J)
 2991   CONTINUE
 299  CONTINUE
C
C ** ON EFFECTUE UN TRI DES NOEUDS MAITRES POUR DISTINGUER LES NOEUDS
C ** "TOTALEMENT MAITRES" DES NOEUDS "NON TOTALEMENT MAITRES"
C
      NLIGRA=0
      DO 30 I=1,NOMAI(/1)
        IF (NOMAI(I).EQ.0) GOTO 30
 32     CONTINUE
        NINCMA=0
        NINC = 0
        DO 33 J=1,INCPO(/1)
          N2=J
          IF (INCPO(J,ILOCAL(I)).NE.1) GOTO 33
          NINC=NINC+1
          DO 34 JJ=1,NOMIN(/2)
            N3=JJ
            IF (IMIK(J).EQ.NOMIN(JJ)) GOTO 35
**          IF (IMIK(J).EQ.NOMIN(JJ).AND.IHAR(J).EQ.IHARMA(JJ)) GOTO 35
 34       CONTINUE
          GOTO 33
 35       CONTINUE
          IF (NOINC(N3,NOMAI(I)).EQ.1) THEN
            INCPO(N2,ILOCAL(I))=MAXPOD
            NINCMA=NINCMA+1
            NLIGRA=NLIGRA+1
            NBNNMA=NBNNMA-1
          ENDIF
 33     CONTINUE
        IF(NINCMA.GT.0) THEN
          IF(NINCMA.EQ.NINC) THEN
             NTOTMA(**)=ILOCAL(I)
             DO 3333 J=1,INCPO(/1)
                IF(INCPO(J,ILOCAL(I)).EQ.MAXPOD)
     &             INCPO(J,ILOCAL(I))=1
 3333        CONTINUE
          ELSE
            NTTMAI(**)=ILOCAL(I)
          ENDIF
        ENDIF
 30   CONTINUE
      NODDEB=NNOE
      SEGDES NOINC
C
C  ****  ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
C  ****  GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA+1 OBJETS
C  ****  GEOMETRIQUES ELEMENTAIRES. LE PREMIER SOUS-OBJET CONTIENT
C  ****  LES NOEUDS TOTALEMENT MAITRES (S'IL Y EN A), QUI SERONT
C  ****  PLACES EN FIN DE NUMEROTATION. ON APPELLE NUMOPT2 (OU NUMOPT)
C  ****  QUI FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
C  ****  NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
C  ****  LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
C  ****  DE LA MATRICE, ETC...
C
C        on met d'abord en tete un point bidon pour etre coherent
C        avec le precontionnement dans numopt
C
**     write(6,*) ' ntotma ',ntotma(/1)
**     write(6,*) ' nttmai ',nttmai(/1)


       IF(NTOTMA(/1).NE.0) THEN
         NBNN=1
         NBSOUS=0
         NBREF=0
         NBELEM=1
         SEGINI,IPT5
         IPT5.ITYPEL=28
         DO 221 J=1,ILOCAL(/1)
           IF (ILOCAL(J).EQ.NTOTMA(1))  GOTO 222
 221     CONTINUE
         CALL ERREUR(5)
 222     CONTINUE
         IPT5.NUM(1,1)=J
         NBELEM=NTOTMA(/1)
         SEGINI,IPT3
*  en fait on n'utilisera pas ipt3 dans numop2
*  contre performant + bug
         IPT3.ITYPEL=28
         DO 200 I=1,NTOTMA(/1)
         DO 201 J=1,ILOCAL(/1)
           IF (ILOCAL(J).EQ.NTOTMA(I))  GOTO 202
 201     CONTINUE
         CALL ERREUR(5)
         RETURN
 202     CONTINUE
         IPT3.NUM(1,I)=J
 200     CONTINUE

       ELSE

         IKK=1
 722     CONTINUE
         MELEME=IRIGEL(1,IKK)
         SEGACT,MELEME
         if (num(/2).eq.0) then
         ikk=ikk+1
         IF(IKK.LE.NNVA)  GO TO 722
         write(6,*) 'assem4 ikk nnva',ikk,nnva
         endif
         DESCR=IRIGEL(3,IKK)
         SEGACT,DESCR
         NLIGRE=LISINC(/2)
         DO 720 K=1,NLIGRE
         IF(LISINC(K).NE.'LX  ') GO TO 721
  720    CONTINUE
         SEGDES,MELEME
         SEGDES,DESCR
         IKK=IKK+1
         IF(IKK.LE.NNVA)  GO TO 722
         DO 4862 I=1,NNVA
         MELEME= IRIGEL(1,I)
         SEGACT MELEME
*        write(6,*) 'num en 420',num(/1),num(/2),itypel
         if (num(/2).eq.0) goto 4862
         IF(ITYPEL.EQ.49) THEN
         DESCR=IRIGEL(3,I  )
         SEGACT,DESCR
         K = 3
         GO TO 4863
         ELSE
         SEGDES MELEME
         ENDIF
 4862    CONTINUE
         K=1
         MELEME= IRIGEL(1,1)
         DESCR= IRIGEL(3,1)
         SEGACT MELEME,DESCR
4863     CONTINUE
  721    IA=NOELEP(K)
         I1=NUM(IA,1)
         NBSOUS=0
         NBNN=1
         NBREF=0
         NBELEM=1
         SEGINI,IPT3
         IPT3.ITYPEL=1
         IPT3.NUM(1,1)=I1
         ipt5=ipt3
         SEGDES,MELEME,DESCR
       ENDIF
      SEGDES IPT3
      NBSOUS=NNVA+2
      NBREF=0
      NBNN=0
      NBELEM=0
      SEGINI,IPT2
      IPT2.LISOUS(1)=IPT5
      IPT2.LISOUS(2)=IPT3
      NOSOUS=3
      DO 210 I=1,NNVA
        IPT2.LISOUS(NOSOUS)=IRIGEL(1,I)
        NOSOUS=NOSOUS+1
 210  CONTINUE

      NNGLOB=ILOCAL(/1)
      SEGINI,INUINV
      DO 450 I=1,NNGLOB
        INUINV(I)=ILOCAL(I)
 450  CONTINUE

        CALL NUMOPT(IPT2,INUINV,NNOE)
        segact inuinv*mod
      IF(NTOTMA(/1).NE.0) THEN
*  on remet les noeuds totalement maitre a la fin, ce que numopt ne fait
*  pas
      nbtmai=ntotma(/1)
      segact ipt3
      do i=1,nbtmai
**     write(6,*) ' assem4 nnglob ',nnoe-ntotma(/1),
**   >   inuinv(ipt3.num(1,i))
        inuinv(ipt3.num(1,i))= inuinv(ipt3.num(1,i))+nnoe  
      enddo
      segini inuin2
      do i=1,nnglob
        if (inuinv(i).ne.0) inuin2(inuinv(i))=i
      enddo
      icour=0
      do 803 i=1,2*nnoe  
        if (inuin2(i).eq.0) goto 803
        icour=icour+1
        inuin2(icour)=inuin2(i)
        if (i.ne.icour) inuin2(i)=0
 803  continue
      if(icour.gt.nnoe) call erreur(5)
      do i=1,nnglob
        inuinv(i)=0
      enddo
      do i=1,nnoe
        if (inuin2(i).ne.0) inuinv(inuin2(i))=i
      enddo
      segsup inuin2
      ENDIF


 800  CONTINUE

**  ON APPLIQUE LA NOUVELLE NUMEROTATION A INCPO ET A NTTMAI

      SEGINI,MIPO1=MINCPO
      DO 600 I=1,NNGLOB  
        if (ilocal(i).eq.0.and.inuinv(i).ne.0) then       
        write(6,*)  'i ilocal inuinv',i,ilocal(i),inuinv(i)
        call erreur(5)
        return
        endif
        if (ilocal(i).ne.0.and.inuinv(i).eq.0) then
         write(6,*) 'i ilocal inuinv',i,ilocal(i),inuinv(i)
        call erreur(5)
        return
        endif
        IF (ILOCAL(I).EQ.0) GOTO 600
        DO 610 II=1,MAXINC
          INCPO(II,INUINV(I))=MIPO1.INCPO(II,ILOCAL(I))
 610    CONTINUE
 600  CONTINUE

      SEGSUP,MIPO1
      DO 615 I=1,NTTMAI(/1)
        DO 616 II=1,ILOCAL(/1)
          IF (NTTMAI(I).EQ.ILOCAL(II)) THEN
             NTTMAI(I)=INUINV(II)
             GOTO 615
          ENDIF
 616    CONTINUE
 615  CONTINUE

      DO 617 I=1,NTOTMA(/1)
        DO 618 II=1,ILOCAL(/1)
          IF (NTOTMA(I).EQ.ILOCAL(II)) THEN
             NTOTMA(I)=INUINV(II)
             GOTO 617
          ENDIF
 618    CONTINUE
 617  CONTINUE
C
C  ****  CREATION D'UN OBJET GEOMETRIE (IPT1) QU'IL FAUDRA CHANGER EN CAS DE
C  ****  RENUMEROTATION GENERALE. ON PROFITE DE LA BOUCLE POUR CREER LE
C  ****  TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I (NU-
C  ****  MEROTATION LOCALE).
C
      SEGINI,IMIN
      NBSOUS=0
      NBREF=0
      NBNN=1
      NBELEM=NNOE
      SEGINI,IPT1
      IPT1.ITYPEL=IPOIN
      DO 316 IRI=1,NNVA
      MELEME=IRIGEL(1,IRI)
      SEGACT,MELEME
      N1=NUM(/1)
      N2=NUM(/2)
      DO  I=1,N2
      DO  J=1,N1
      K=NUM(J,I)
      M=INUINV(K)
      IMIN(M)=IMIN(M)+1
      IPT1.NUM(1,M)=K
      enddo
      enddo
      SEGDES,MELEME
  316 CONTINUE
      DO 3161 I=1,NOMAI(/1)
         IF(NOMAI(I).EQ.0) GO TO 3161
         IPT1.NUM(1,INUINV(I))=I
 3161 CONTINUE


C  ****  INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
C  ****  DANS ITOPO .
C
      SEGINI,IITOP
      IITOP(1)=1
      DO 318 I=1,NNOE
      IITOP(I+1)=IMIN(I)* 2  + IITOP(I)
  318 CONTINUE
      DO  I=1,NNOE
      IMIN(I)=0
      enddo
      IENNO=IITOP(NNOE+1)
      SEGINI,ITOPO
      DO 321 IRI=1,NNVA
      MELEME=IRIGEL(1,IRI)
      SEGACT,MELEME
      N1=NUM(/1)
      N2=NUM(/2)
      DO  I=1,N2
      DO  J=1,N1
      K=NUM(J,I)
      M=INUINV(K)
      IMIN(M)=IMIN(M)+1
      IUY= 2* ( IMIN(M)-1 )  + IITOP(M)
      ITOPO(IUY)=I
      ITOPO(IUY+1)=IRI
      enddo
      enddo
      SEGDES,MELEME
  321 CONTINUE
C
C ***  NUMEROTATION DES INCONNUES DE INCPO
C
      NA=0

       DO 337 I=1,NNOE
        nad=na
        diamax=0.d0
        DO 335 K=1,MAXINC
        IF(INCPO(K,I).EQ.0) GO TO 335
        IF (INCPO(K,I).LT.MAXPOD) THEN
          NA=NA+1
          INCPO(K,I)=NA
          itrv1(na-nad)=k
          dtrv1(na-nad)= -diatmp(k,i)
          diamax=max(diamax,abs(dtrv1(na-nad)))
        ENDIF
  335   CONTINUE
      diaref = diamax * xszpre
*  pour les multiplicateurs de lagrange?
      do k=1,na-nad
       if (abs(dtrv1(k)).lt.diaref) then
**      write (6,*) ' terme diag petit ',dtrv1(k)
        dtrv1(k)=dtrv1(k)+diamax
       endif
      enddo
*  trier incpo suivant les val de diatmp
      call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
      do k=1,na-nad
       incpo(itrv1(k),i)=k+nad
      enddo
  337  CONTINUE
      DO 339 I=1,NTTMAI(/1)
        NAD=NA
        diamax=0.d0
        N1=NTTMAI(I)
        DO 338 K=1,MAXINC
        IF(INCPO(K,N1).EQ.0) GO TO 338
        IF (INCPO(K,N1).EQ.MAXPOD) THEN
          NA=NA+1
          INCPO(K,N1)=NA
          itrv1(na-nad)=k
          dtrv1(na-nad)= -diatmp(k,n1)
          diamax=max(diamax,abs(dtrv1(na-nad)))
        ENDIF
 338    CONTINUE
      diaref = diamax * xszpre
*  pour les multiplicateurs de lagrange?
      do k=1,na-nad
       if (abs(dtrv1(k)).lt.diaref) then
**      write (6,*) ' terme diag petit ',dtrv1(na-nad)
        dtrv1(k)=dtrv1(k)+diamax
       endif
      enddo
*  trier incpo suivant les val de diatmp
      call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
      do  k=1,na-nad
       incpo(itrv1(k),n1)=k+nad
      enddo 
 339  CONTINUE
C
C  CREATION DU DESCRIPTEUR DE LA RIGIDITE EQUIVALENTE
C
      NLIGRD=NLIGRA
      NLIGRP=NLIGRA
      SEGINI,DES1
      DO 341 IGLOB=1,NOMAI(/1)
        IF(NOMAI(IGLOB).EQ.0) GOTO 341
        ILOC=INUINV(IGLOB)
        DO 342 I=1,INCPO(/1)
           IF(INCPO(I,ILOC).GT.NBNNMA) THEN
              ICOL=INCPO(I,ILOC)-NBNNMA
              DES1.NOELEP(ICOL)=NOMAI(IGLOB)
              DES1.NOELED(ICOL)=NOMAI(IGLOB)
              DES1.LISINC(ICOL)=IMIK(I)
              DES1.LISDUA(ICOL)=IDUA(I)
            ENDIF
 342    CONTINUE
 341  CONTINUE
      segsup diatmp,strv
      SEGDES DES1

      SEGDES,MIDUA,MIMIK,MHARK

      SEGDES,MRIGID

      SEGDES,ITOPO
      SEGDES,IITOP
      SEGDES,INUINV
      SEGDES,IPT1
      SEGDES,MINCPO
      SEGSUP,IMIN
      SEGDES,INCTRR
      INCTRY=INCTRR
      SEGINI,MMATRI
      NENS=0
      IGEOMA=IPT1
      IIDUA=MIDUA
      IINCPO=MINCPO
      IIMIK=MIMIK
      IHARK=MHARK
      INUINY=INUINV
      ITOPOY=ITOPO
      IITOPY=IITOP
      MMATRX=MMATRI
      SEGDES,MMATRI
      SEGDES,ILOCAL
      SEGDES,MELEME
      SEGDES,DESCR
      SEGDES,SNTT
      SEGDES,SNTO
      SEGDES NOMAI
      SEGDES SNOMIN
      RETURN
      END