C ASNS1     SOURCE    MB234859  26/06/10    21:15:03     12569          
      SUBROUTINE ASNS1 (IPOIRI,MMATRX,INUINY,ITOPOY,IMINIY,IPOY,
     & INCTRY,INCTRZ,IITOPY,ITOPOD,IITOPD,IPODD)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C  CE SUBROUTINE SERT A L'ASSEMBLAGE DE MATRICES NON-SYMETRIQUES
C  EN VUE D'UNE INVERSION PAR UNE METHODE LDUt
C
C  EN ENTREE:
C  ****  IPOIRI: POINTEUR SUR OBJET MRIGIDITE,NON MODIFIE
C  EN SORTIE:
C  ****  INUINV IMINI ITOPO IPOY INCTRY  SONT DES POINTEURS DES SEGMENTS
C        DE TRAVAIL SERVANT A L'ASSEMBLAGE ILS SONT DETRUITS EN FIN
C        D'ASSEMBLAGE OU DE TRIANGULARISATION
C  ****  MMATRI EST LE POINTEUR DE L'OBJET FUTUR MATRICE TRIANGULARISEE.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC SMELEME
-INC SMCOORD
-INC CCREEL
      SEGMENT,IMIN(NNOE)
      SEGMENT,IMINB(NNOE)
      SEGMENT ICPR(nbpts)
C
-INC SMRIGID
-INC SMMATRI
C
      SEGMENT,INUINV(NNGLOB)
      SEGMENT,ITOPO(IENNO)
      SEGMENT,IITOP(NNOE+1)
      SEGMENT,ITOPOB(IENNO)
      SEGMENT,IITOPB(NNOE+1)
      SEGMENT,IMINI(INC)
      SEGMENT,IPOS(NNOE1)
      SEGMENT,IPOD(NNOE1)
      SEGMENT,INCTRR(NIRI)
      SEGMENT,INCTRD(NIRI)
      SEGMENT,INCTRA(NLIGRE)
      SEGMENT DIATMP(maxt,NNOE)
      segment strv
         integer itrv1(maxt)
         integer itrv2(maxt)
         real*8 dtrv1(maxt)
         real*8 dtrv2(maxt)
      endsegment
      segment mondu
         character*(lochpo) mondua(nnn)
         integer ipris(nnn),inosel(nnn)
      endsegment

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
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
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  ****   IPOS(I)=J   : LA 1 ERE INCONNUE DU NOEUD I EST EN J+1 EME
C                       POSITION
C  ****  IMINI(I)=J     LA PLUS PETITE INCONNUE QUI EST RELIEE A LA IEME
C                       EST L'INCONNUE J.
C  ****  INUINV(I)=J    J EST LE NOUVEAU NUMERO DU NOEUD I
C
C  ****  INCTRR(NIRI) - NIRI=NRIGEL du IPOIRI (objet MRIGID passé en argument)
C                       pointeurs sur INCTRA
C
C  Variables locales :
C  --------------------
C     * NNVA = NRIGEL (nombre d'objets MRIGID élémentaires) dans IPOIRI (objet
C              MRIGID) passé en argument)
C     * NLIGRE = NLIGRP - nombre de variables primales (dans un segment DESCR)
C     * IMELP = pointeur d'un MELEME contenant un noeud "normal"
C     * ICDOUR = ???
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

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

*
      NNGLOB=nbpts
      MRIGID=IPOIRI
*
C     Quelquefois, les points de IRIGEL(1,I) ne sont pas
C     tous references par le segment DESCR (cas des QUAFs notamment).
C     Dans ce cas, on fait une reduction du MELEME et on le stocke dans
C     IRIGEL(2,I)
C
      CALL RDSCRM(MRIGID)
      IF (IERR.NE.0) RETURN
*
      SEGACT,MRIGID
      NNVA=IRIGEL(/2)
      NIRI=NNVA
      SEGINI,INCTRR
      SEGINI,INCTRD

      if (nnva.eq.0) goto 801
      MELEME=IRIGEL(1,1)
      SEGACT MELEME
C ... ITYPEL = 27 correspond aux éléments 'ATTA' ...
      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(2,i)
         if (meleme.eq.0) 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
 700  CONTINUE
C
C  **** FABRICATION DU TABLEAU INUINV
C  **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE
C
      NNOE=IKI
      NBETA=0
      DO 710 I=1,NNVA
         meleme=irigel(2,i)
         if (meleme.eq.0) 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 DESCR
*        SEGSUP IPB
 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
      IKK=1
 722  CONTINUE
      MELEME=IRIGEL(1,IKK)
      SEGACT,MELEME
      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,DESCR
      IKK=IKK+1
      IF(IKK.LE.NNVA)  GO TO 722
      DO 4862 I=1,NNVA
         MELEME= IRIGEL(1,I)
         SEGACT MELEME
         IF(ITYPEL.EQ.49) THEN
            DESCR=IRIGEL(3,I  )
            SEGACT,DESCR
            K = 3
            GO TO 721
         ELSE
            SEGDES MELEME
         ENDIF
 4862 CONTINUE
      K=1
      MELEME= IRIGEL(1,1)
      DESCR= IRIGEL(3,1)
      SEGACT MELEME,DESCR

C ... On arrive ici si :
C     * LISINC(K) != 'LX  ' => K est le premier parmi K tels que LISINC(K) != 'LX  '
C     * ITYPEL d'un des maillages = 49 (élément 'MULT') => K = 3
C     * tous les autres cas => K = 1

C ... IA = numéro (dans l'élément) du noeud concerné par le DDL No K ...
C ... I1 = numéro (absolu) du noeud concerné par le DDL No K,
C     Ce noeud sera mis dans un MELEME dont le pointeur est stocké dans IMELP ...

  721 IA=NOELEP(K)
      I1=NUM(IA,1)
      NBSOUS=0
      NBNN=1
      NBREF=0
      NBELEM=1
      SEGDES,DESCR
      SEGINI,MELEME
      ITYPEL=1
      NUM(1,1)=I1
      IMELP=MELEME

C ... Le MELEME créé ici est un MELEME composé qui contiendra le MELEME
C     pointé par IMELP et tous les MELEME pointés par IRIGEL(1,*) ...
      NBSOUS=NNVA+1
      NBREF=0
      NBNN=0
      NBELEM=0
      SEGINI,MELEME
      LISOUS(1)=IMELP
      DO 12 I=1,NNVA
         ipt1=irigel(1,i)
         segact ipt1
         if (irigel(7,i).ne.0.and.ipt1.lisref(/1).ne.0.and.
     >        ipt1.itypel.eq.49) then
            write(6,*) 'assemblage condition non symetrique'
            ipt2=ipt1.lisref(1)
         else
            ipt2=irigel(2,i)
            if (ipt2.eq.0) ipt2=ipt1
         endif
         LISOUS(I+1)=ipt2
   12 CONTINUE
      ICDOUR=0
      SEGINI,INUINV
      SEGDES,INUINV
      CALL NUMOPT(MELEME,INUINV,ICDOUR)
C ... A la sortie INUINV contient l'ordre des noeuds et ICDOUR le nombre de noeuds présents dans MELEME ...
      SEGACT INUINV
      SEGSUP,MELEME
*      MELEME=IMELP
*      SEGDES,MELEME
C
C  ****  CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE
C  ****  RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE
C  ****  TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU-
C  ****  MEROTATION LOCALE).
C
 800  CONTINUE
      NNOE=ICDOUR
      SEGINI,IMIN,IMINB
      NNOE1=NNOE+1
      SEGINI,IPOS,IPOD
      NBSOUS=0
      NBREF=0
      NBNN=1
      NBELEM=ICDOUR
      SEGINI,IPT1
      IPT1.ITYPEL=IPOIN
*     write(6,*) 'asns1 nnva',nnva
      DO 16 IRI=1,NNVA
**       DO  I=1,NNOE
**          ipod(I)=0
**          IPOS(I)=0
**       enddo
         MELEME=IRIGEL(1,IRI)
         SEGACT,MELEME
         DESCR=IRIGEL(3,IRI)
         segact descr
         N2=NUM(/2)
*         write(6,*) 'noelep', ( noelep(iu),iu=1,noelep(/1))
*         write(6,*) 'noeled', ( noeled(iu),iu=1,noeled(/1))
         DO 17 I=1,N2
            DO 171 J=1,NOELEP(/1)
               K = NUM( NOELEP(J),I)
               M=INUINV(K)
               IF(IPOS(M).NE.I) THEN
                  IMIN(M)=IMIN(M)+1
                  IPT1.NUM(1,M)=K
                  IPOS(M)=I
               ENDIF
 171        CONTINUE
            DO 172 J=1,NOELED(/1)
               K = NUM( NOELED(J),I)
               M=INUINV(K)
               IF(IPOD(M).NE.I) THEN
                  IMINB(M)=IMINB(M)+1
                  IPOD(M)=I
               ENDIF
 172        CONTINUE
 17      CONTINUE
         do i=1,n2
           do j=1,noelep(/1)
              k=num(noelep(j),i)
              m=inuinv(k)
              ipos(m)=0
           enddo
           do j=1,noeled(/1)
              k=num(noeled(j),i)
              m=inuinv(k)
              ipod(m)=0
           enddo
         enddo

 16   CONTINUE
C
C  ****  INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
C  ****  DANS ITOPO .
C  ... ITOPO contiendra pour chaque noeud et chaque élément contenant
C      ce noeud 2 nombres :
C            1. numéro de l'élément dans son maillage
C            2. numéro du maillage (dans IRIGEL) de cet élément
C
C ... IITOP servira pour déterminer la taille de ITOPO ainsi que pour
C     se retrouver dedans ...
C
      SEGINI,IITOP,IITOPB
      IITOP(1)=1
      IITOPB(1)=1
*       write(6,*) ' imin', ( imin(iu),iu=1,imin(/1))
*       write(6,*) ' iminb', ( iminb(iu),iu=1,iminb(/1))
      DO 18 I=1,NNOE
         IITOP(I+1)=IMIN(I)* 2  + IITOP(I)
         IITOPB(I+1)=IMINB(I)* 2  + IITOPB(I)
   18 CONTINUE
      DO  I=1,NNOE
         IMINB(I)=0
         IMIN(I)=0
      enddo
C ... IENNO = taille d'ITOPO ...
      IENNO=IITOP(NNOE+1)
      SEGINI,ITOPO
      IENNO=IITOPB(NNOE+1)
      SEGINI ITOPOB
**       DO I=1,NNOE
**          IPOD(I)=0
**          IPOS(I)=0
**       enddo
      DO 21 IRI=1,NNVA
         MELEME=IRIGEL(1,IRI)
         SEGACT,MELEME
         DESCR = IRIGEL(3,IRI)
         N2=NUM(/2)
         DO 22 I=1,N2
             DO 221 J=1,NOELEP(/1)
               M=INUINV(NUM(NOELEP(J),I))
               IF(IPOS(M).NE.I) THEN
                  IMIN(M)=IMIN(M)+1
                  IUY= 2* ( IMIN(M)-1 )  + IITOP(M)
C             ... Remplissage d'ITOPO ...
                  ITOPO(IUY)=I
                  ITOPO(IUY+1)=IRI
                  IPOS(M)=I
               ENDIF
 221        CONTINUE
             DO 222 J=1,NOELED(/1)
               M=INUINV(NUM(NOELED(J),I))
               IF(IPOD(M).NE.I) THEN
                  IMINB(M)=IMINB(M)+1
                  IUY= 2* ( IMINB(M)-1 )  + IITOPB(M)
C             ... Remplissage d'ITOPO ...
                  ITOPOB(IUY)=I
                  ITOPOB(IUY+1)=IRI
                  IPOD(M)=I
               ENDIF
 222        CONTINUE
 22      CONTINUE
         DO  I=1,N2
             DO  J=1,NOELEP(/1)
               M=INUINV(NUM(NOELEP(J),I))
               ipos(m)=0
             enddo
             DO  J=1,NOELED(/1)
               M=INUINV(NUM(NOELED(J),I))
               ipod(m)=0
             enddo
         enddo
   21 CONTINUE
C
C  RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
C  DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
C
C ... On passe cette boucle sans erreur si tous les IRIGEL(5,*) sont égaux
C     soit à NOHA soit à une autre valeur fixe (IARDEF) ...
C
      DO 230 IRI=1,NNVA
         IHARIR=IRIGEL(5,IRI)
         IF( IHARIR . NE. NOHA) THEN
            IARDEF = IHARIR
            GO TO 231
         ENDIF
  230 CONTINUE
c      CALL ERREUR ( 21)
c      RETURN
cbp: si toutes ont pour valeur NOHA, ce n'est a priori pas une erreur...
 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
         if(iimpi.ne.0) then
            write(ioimp,*) 'IRIGEL(5,:)=',(IRIGEL(5,iou),iou=1,NNVA)
         endif
         CALL ERREUR (435)
         RETURN
 232  CONTINUE
C
C  ****  RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
C
C ... Les quatre segments sont à l'origine de longueur nulle ...
      SEGINI,MIDUA
      SEGINI,MIMIK
      SEGINI,MHARK
      SEGINI,MHAR1

      DESCR=IRIGEL(3,1)
      SEGACT,DESCR

      IAAR=IRIGEL(5,1)
      IF(IAAR.EQ.NOHA) IAAR = IARDEF
      IMIK(**)=LISINC(1)
      IHAR(**)= IAAR
      IDUA(**)=LISDUA(1)
      MHAR1.IHAR(**)= IAAR

      MAXINC=1
      DO 23 IRI=1,NNVA
         DESCR=IRIGEL(3,IRI)
         IHARIR=IRIGEL(5,IRI)
         IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
         SEGACT,DESCR
         NLIGRE=LISINC(/2)
         DO 26 I=1,NLIGRE
            DO 24 J=1,MAXINC
               IF(IMIK(J).NE.LISINC(I)) GO TO 24
               IF(IHAR(J).EQ.IHARIR) GO TO 26
   24       CONTINUE
C       ... On empile les valeurs d'IHARIR et LISINC dans
C           leurs segments si le couple (IHARIR,LISINC) n'y est pas
C           encore représenté ...
            MAXINC=MAXINC+1
            IHAR(**)=IHARIR
            IMIK(**)=LISINC(I)
   26    CONTINUE
   23 CONTINUE

      MAXDUA=1
      DO 2322 IRI=1,NNVA
         DESCR=IRIGEL(3,IRI)
         IHARIR=IRIGEL(5,IRI)
         IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
         SEGACT,DESCR
         NLIGRE=LISDUA(/2)
         DO 262 I=1,NLIGRE
            DO 242 J=1,MAXDUA
               IF(IDUA(J).NE.LISDUA(I)) GO TO 242
               IF(MHAR1.IHAR(J).EQ.IHARIR) GO TO 262
  242       CONTINUE
C       ... On empile les valeurs d'IHARIR et LISDUA dans
C           leurs segments si le couple (IHARIR,LISDUA) n'y est pas
C           encore représenté ...
            MAXDUA=MAXDUA+1
            MHAR1.IHAR(**)=IHARIR
            IDUA(**)=LISDUA(I)
  262    CONTINUE
         SEGDES,DESCR
 2322 CONTINUE
*      write(6,*) ' imik'
*      write(6,*) ( imik(iu),iu=1,imik(/2))
*      write(6,*) ' idua avant'
*      write(6,*) ( idua(iu),iu=1,idua(/2))
      nnn = idua(/2)
      nqq = imik(/2)
      if(nnn.ne.nqq) then
*  on verra plus tard
         call erreur(756)
         return
      endif
* petit travail pour mettre dans le meme ordre les inconnues
      segini mondu
      do 476 iu=1,imik(/2)
         lisi=imik(iu)
         CALL PLACE(NOMDD,LNOMDD,idx,lisi)
         IF (idx.NE.0) THEN
            lisi=NOMDU(idx)
         ENDIF
         do 477 io=1,idua(/2)
            if(idua(io).eq.lisi) go to 478
 477     continue
         inosel(iu)=1
         go to 476
 478     continue
         mondua(iu)= idua(io)
         ipris(io)=1
 476  continue
      do 472 iu=1,inosel(/1)
         if (inosel(iu).eq.0) go to 472
         do 473 io=1,ipris(/1)
            if (ipris(io).eq.1) go to 473
            ipris(io)=1
            mondua(iu)=idua(io)
            go to 472
 473     continue
 472  continue
      do 479 iu=1,idua(/2)
         idua(iu)=mondua(iu)
 479  continue
      segsup mondu
*      write(6,*) ' idua apres'
*      write(6,*) ( idua(iu),iu=1,idua(/2))
C
C  **** INITIALISATION DE INCPOS ET DE INCTRA.
C
C ... Les dimensions des segments MINCPO initialisés ci-dessous sont les
C     suivantes : MAXI = nombre de différentes variables primales (ou duales)
C                 NNOE = nombre de noeuds effectivement présents
      MAXI=MAXINC
      SEGINI,MINCPO

      MAXI=MAXDUA
      SEGINI,MIPO1
      maxt=max(maxinc,maxdua)
      SEGINI DIATMP,strv

      DO 29 IRI=1,NNVA
         IHARIR=IRIGEL(5,IRI)
         IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF

         DESCR=IRIGEL(3,IRI)
         SEGACT,DESCR

         NLIGRE=LISINC(/2)
         NLIGRF=LISDUA(/2)
         SEGINI,INCTRA
         INCTRR(IRI)=INCTRA

         MELEME=IRIGEL(1,IRI)
         SEGACT,MELEME
         N2=NUM(/2)

         xmatri = irigel(4,iri)
         segact xmatri

         DO 34 J=1,NLIGRE
            DO 33 K=1,MAXINC
               IF(LISINC(J).NE.IMIK(K)) GO TO 33
               IF(IHAR(K).EQ.IHARIR) GO TO 32
   33       CONTINUE
   32       CONTINUE
C       ... K est tel que LISINC(J)=IMIK(K) et IHARIR=IHAR(K),
C           on le met dans INCTRA(J) (J numérote les variables) correspondant ...
            INCTRA(J)=K
C       ... Dans la boucle ci-dessous on met à 1 les INCPO correspondants à la
C           variable K pour les noeuds des éléments du maillage ...
            DO 31 I=1,N2
               IJ=INUINV(NUM(NOELEP(J),I))
               INCPO(K,IJ)=1
*  terme diagonal
               if (j.le.nligrf) diatmp(K,IJ)=diatmp(k,ij)+
     >              re(j,j,i)*coerig(iri)
 31         continue
 34      CONTINUE
         SEGDES,INCTRA

         NLIGRF=LISINC(/2)
         NLIGRE=LISDUA(/2)
         SEGINI,INCTRA
         INCTRD(IRI)=INCTRA

         DO 342 J=1,NLIGRE
            DO 332 K=1,MAXDUA
               IF(LISDUA(J).NE.IDUA(K)) GO TO 332
               IF(MHAR1.IHAR(K).EQ.IHARIR) GO TO 322
  332       CONTINUE
  322       CONTINUE
C       ... K est tel que LISDUA(J)=IDUA(K) et IHARIR=IHAR(K),
C           on le met dans INCTRA(J) (J numérote les variables) correspondant ...
            INCTRA(J)=K
C       ... Dans la boucle ci-dessous on met à 1 les INCPO correspondants à la
C           variable K pour les noeuds des éléments du maillage ...
            DO  I=1,N2
               IJ=INUINV(NUM(NOELED(J),I))
               MIPO1.INCPO(K,IJ)=1
*  terme diagonal
               if (j.le.nligrf) diatmp(K,IJ)=diatmp(k,ij)+
     >    re(j,j,i)*coerig(iri)
            enddo
  342    CONTINUE

         segdes xmatri
         SEGDES,DESCR
         SEGDES,INCTRA
   29 CONTINUE
C
C  ****  INITIALISATION DE IPOS
C
C ... IPOS(I+1)-IPOS(I) = nombre de colonnes liées au noeud I ...
C ... IPOS(I)+1 = numéro de la première colonne concernant le noeud I ...
      IPOS(1)=0
      IPOD(1)=0
C ... NA = nombre de 1 dans INCPO => nombre de colonnes de la matrice ...
      NA=0
      ND=0
      DO 37 I=1,NNOE
         nad=na
         ndd=nd
         diamax=0.d0
         DO 35 K=1,MAXINC
            IF(INCPO(K,I).EQ.0) GO TO 35
            NA=NA+1
            INCPO(K,I)=NA
            itrv1(na-nad)=k
            dtrv1(na-nad)= -diatmp(k,i)
            diamax=max(diamax,abs(dtrv1(na-nad)))
 35      CONTINUE
         diaref = diamax * xszpre
         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
         IPOS(I+1)=NA
C ... ND = nombre de 1 dans MIPO1.INCPO => nombre de lignes de la matrice ...
         diamax=0.d0
         DO 352 K=1,MAXDUA
            IF(MIPO1.INCPO(K,I).NE.0) THEN
               ND=ND+1
C          ... MIPO1.INCPO(K,I) = numéro de l'équation ...
               MIPO1.INCPO(K,I)=ND
               itrv1(nd-ndd)=k
               dtrv1(nd-ndd)= -diatmp(k,i)
               diamax=max(diamax,abs(dtrv1(nd-ndd)))
            ENDIF
 352     CONTINUE
         diaref = diamax * xszpre
         do k=1,nd-ndd
            if (abs(dtrv1(k)).lt.diaref) then
**      write (6,*) ' terme diag petit ',dtrv1(k)
               dtrv1(k)=dtrv1(k)+diamax
            endif
         enddo
         call triflo(dtrv1,dtrv2,itrv1,itrv2,nd-ndd)
         do k=1,nd-ndd
            mipo1.incpo(itrv1(k),i)=k+ndd
         enddo
         IPOD(I+1)=ND
 37   CONTINUE
*        write(*,*) 'Nb de colonnes de la matrice : ',NA,maxinc
*        write(*,*) 'Nb de lignes   de la matrice : ',ND,maxdua
      SEGDES,MIDUA,MIMIK,MHARK,MHAR1

C ... On va tester que tout est OK pour la suite ...

       IF(NA.NE.ND) THEN
*          write(6,*) ' ipos'
*          write(6,*) ( ipos(IU),IU=1,ipos(/1))
*          write(6,*) ' ipod '
*          write(6,*) ( ipod(IU),IU=1,ipod(/1))
          CALL ERREUR(756)
          RETURN
       ENDIF

       DO 567 IINO=1,NNOE1
          IF(IPOS(IINO).NE.IPOD(IINO)) THEN
             WRITE(*,*) 'ERREUR dans ASNS1 !!! IPOS != IPOD !!!'
             RETURN
          ENDIF
 567  CONTINUE
C
C  ****  INITIALISATION DE IMINI a été supprimée car ce segment
C        ne servait à rien ...
*      write(6,*) ' ipos', ( ipos(iu),iu=1,ipos(/1))
*      write(6,*) ' ipod', ( ipod(iu),iu=1,ipod(/1))
*      write(6,*) ' itopo', ( itopo(iu),iu=1,itopo(/1))
*      write(6,*) ' itopob', ( itopob(iu),iu=1,itopob(/1))
*      write(6,*) ' iitop', ( iitop(iu),iu=1,iitop(/1))
*      write(6,*) ' iitopb', ( iitopb(iu),iu=1,iitopb(/1))
      SEGsup DIATMP,strv
      SEGDES,MRIGID
      SEGDES,IPOS,IPOD
      SEGDES,ITOPO,ITOPOB
      SEGDES,IITOP,IITOPB
      SEGDES,INUINV
      SEGDES,IPT1
      SEGDES,MINCPO
      SEGDES,MIPO1
      SEGSUP,IMIN,IMINB
      SEGDES,INCTRR
      INCTRY=INCTRR
      SEGDES,INCTRD
      INCTRZ=INCTRD
      SEGINI,MMATRI
      NENS=0
      IGEOMA=IPT1
      IIDUA=MIDUA
      IINCPO=MINCPO
      IDUAPO=MIPO1
      IIMIK=MIMIK
      IHARK=MHARK
      IHARDU=MHAR1
      INUINY=INUINV
      ITOPOY=ITOPO
      ITOPOD=ITOPOB
      IITOPD=IITOPB
      IITOPY=IITOP
      MMATRX=MMATRI
ccc      IMINIY=IMINI
         iminiy=0
      IPOY=IPOS
      IPODD=IPOD
      SEGDES,MMATRI
      RETURN
      END