C ASSEM1    SOURCE    MB234859  26/06/10    21:15:06     12569          
      SUBROUTINE ASSEM1(IPOIRI,MMATRX,INUINY,ITOPOY,IMINIY,IPOY
     $     ,INCTRY,IITOPY)
C
C  CE SUBROUTINE SERT A L'ASSEMBLAGE DE MATRICES SYMETRIQUES
C  EN VUE D'UNE INVERSION PAR UNE METHODE DE CROUT
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.
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC CCREEL
      SEGMENT,IMIN(NNOE)
      SEGMENT ICPR(nbpts)
C      SEGMENT IPB(NLIGRE)
C
-INC SMRIGID
C
-INC SMMATRI
C
      SEGMENT,INUINV(NNGLOB)
      SEGMENT,ITOPO(IENNO)
      SEGMENT,IITOP(NNOE+1)
      SEGMENT,IMINI(INC)
      SEGMENT,IPOS(NNOE1)
      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
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
*      DATA MOALFA/'ALFA'/
      CHARACTER*4 CNOHA
      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

      if (nnva.eq.0) goto 801
      MELEME=IRIGEL(1,1)
      SEGACT MELEME
      IF(ITYPEL.NE.27) GO TO 801
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
      NALFA=0
      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)
*     SEGINI IPB                         A QUOI CA SERT  PV
*     DO 703 K=1,NLIGRE
*     IPB(NOELEP(K))=K
*703  CONTINUE
         DO  I1=1,NBELEM
            DO 711 I2=1,NBNN
               IP1=NUM(I2,I1)
               IF(ICPR(IP1).EQ.0) GO TO 711
*     IJA=IPB(I2)
*     IF(IJA.NE.MOALFA) GO TO 715
*     NALFA=NALFA+1
*     IKI=NALFA
*     GO TO 716
 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
      IF(IKK.GT.NNVA)  GO TO 723
      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
 723  continue
      DO 4862 I=1,NNVA
         MELEME= IRIGEL(1,I)
         SEGACT MELEME
         if (num(/2).eq.0) goto 4862
         IF(ITYPEL.EQ.49) THEN
            DESCR=IRIGEL(3,I  )
            SEGACT,DESCR
            K = 3
            if (num(/2).le.2) k=num(/2)
            GO TO 4863
         ENDIF
 4862 CONTINUE
      K=1
      do ir=1,nnva
       MELEME= IRIGEL(1,ir)
       segact meleme
       if (num(/2).ne.0.and.itypel.ne.49) goto 4864
      enddo
      call erreur(5)
4864  continue
      DESCR= IRIGEL(3,ir)
      SEGACT MELEME,DESCR
4863  CONTINUE
  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
      INCMOY = 0
      NOEMOY = 0
      DO 12 I=1,NNVA
*     write (6,*) ' dans assem1 ',irigel(6,i)
         ipt1=IRIGEL(1,I)
         DESCR = irigel(3,i)
         segact descr
         NLIGRE=LISINC(/2)
         INCMOY = INCMOY + NLIGRE*ipt1.num(/2)
         NOEMOY = NOEMOY + ipt1.num(/1)*ipt1.num(/2)
*  cas du frottement, on met -49 dans itypel pour le savoir dans numopt
         IF (IRIGEL(6,i).eq.2) then
            IPT8=ipt1
            if(ipt8.itypel.eq.49) then
               segact IPT8*mod
               ipt8.itypel=-49
            endif
            ipt2=ipt8
         else
            ipt2=irigel(2,i)
            if (ipt2.eq.0) ipt2=ipt1
         ENDIF
         LISOUS(I+1)=ipt2
   12 CONTINUE
**    write(6,*) 'ASSEM1 incmoy noemoy ',incmoy,noemoy
      INCMOY = INCMOY/NOEMOY
**    write(6,*) 'ASSEM1 incmoy ',incmoy
      ICDOUR=0
      SEGINI,INUINV
      SEGDES,INUINV
      CALL NUMOPT(MELEME,INUINV,ICDOUR)
*
      goto 58
*  on ne deplace pas les multiplicateurs car le terme diagonal n'est pas nul
*  deplacer les multiplicateur present dans les super elements
      do 50 ir=1,nnva
       ipt5= IRIGEL(1,ir)
       segact ipt5
       if (ipt5.itypel.ne.28) goto 50
       descr=irigel(3,ir)
       segact descr
*  recherche du plus haut noeud non mult
       do 51 iel=1,ipt5.num(/2)
       ihaut=0
       do 55 il=1,lisinc(/2)
*       write (6,*) ' lisinc ',il,lisinc(il)
        if (lisinc(il).eq.'LX  ') goto 55
        ihaut=max(ihaut,inuinv(ipt5.num(noelep(il),iel)))
  55   continue
       do 60 il=1,lisinc(/2)
        if (lisinc(il).eq.'LX  ') then
* un mult ! on le deplace en ihaut
         ipmult=inuinv(ipt5.num(noelep(il),iel))
*        write (6,*) ' ASSEM1 ipmult ihaut ',ipmult,ihaut
         if (ipmult.gt.ihaut) goto 60
         do j=1,inuinv(/1)
          if (inuinv(j).gt.ipmult.and.inuinv(j).le.ihaut)
     >         inuinv(j)=inuinv(j)-1
         enddo
         inuinv(ipt5.num(noelep(il),iel))=ihaut
         ihaut=ihaut-1
        endif
  60   continue
  51  continue
  50  continue
  58  continue
*
      segact meleme
      do i=1,lisous(/1)
       ipt8=lisous(i)
       segact ipt8
       if (ipt8.itypel.eq.-49) then
        segact ipt8*mod
        ipt8.itypel=49
       endif
      enddo
      SEGACT INUINV
      SEGSUP,MELEME
*     MELEME=IMELP
*     SEGSUP,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
      NNOE1=NNOE+1
      SEGINI,IPOS
      NBSOUS=0
      NBREF=0
      NBNN=1
      NBELEM=ICDOUR
      SEGINI,IPT1
      IPT1.ITYPEL=IPOIN
      DO 16 IRI=1,NNVA
*      DO 170 I=1,NNOE
*  170 IPOS(I)=0
         meleme=IRIGEL(2,IRI)
         if (meleme.eq.0) 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)
               IF(IPOS(M).NE.I) THEN
                  IMIN(M)=IMIN(M)+1
                  IPT1.NUM(1,M)=K
                  IPOS(M)=I
               ENDIF
            enddo
         enddo
         DO  I=1,N2
            DO  J=1,N1
               K=NUM(J,I)
               M=INUINV(K)
               ipos(m)=0
            enddo
         enddo
   16 CONTINUE
C
C  ****  INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
C  ****  DANS ITOPO .
C
      SEGINI,IITOP
      IITOP(1)=1
      DO 18 I=1,NNOE
         IITOP(I+1)=IMIN(I)* 2  + IITOP(I)
   18 CONTINUE
      DO  I=1,NNOE
         IMIN(I)=0
      enddo
      IENNO=IITOP(NNOE+1)
      SEGINI,ITOPO
      DO 21 IRI=1,NNVA
*      DO 220 I=1,NNOE
* 220  IPOS(I)=0
C     DESCR=IRIGEL(3,IRI)
C     SEGACT,DESCR
C     N3=LISINC(/2)
C     SEGDES,DESCR
         meleme=IRIGEL(2,IRI)
         if (meleme.eq.0) meleme=IRIGEL(1,IRI)
         SEGACT,MELEME
         N1=NUM(/1)
         N2=NUM(/2)
         DO  I=1,N2
            DO  J=1,N1
               M=INUINV(NUM(J,I))
               IF(IPOS(M).NE.I) THEN
                  IMIN(M)=IMIN(M)+1
                  IUY= 2* ( IMIN(M)-1 )  + IITOP(M)
                  ITOPO(IUY)=I
                  ITOPO(IUY+1)=IRI
                  IPOS(M)=I
               ENDIF
            enddo
         enddo
         DO  I=1,N2
            DO  J=1,N1
               M=INUINV(NUM(J,I))
               IPOS(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
      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  ) GOTO 232
         IF( IRIGEL(5,IRI).EQ.IARDEF) GOTO 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
      SEGINI,MIDUA
      SEGINI,MIMIK
      SEGINI,MHARK

      DESCR=IRIGEL(3,1)
      SEGACT,DESCR

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

      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).OR.IDUA(J).NE.LISDUA(I).OR.
     >              IHAR(J).NE.IHARIR) GO TO 24
               GO TO 26
 24         CONTINUE
            MAXINC=MAXINC+1
            IHAR(**)=IHARIR
            IMIK(**)=LISINC(I)
            IDUA(**)=LISDUA(I)
 26      CONTINUE
         SEGDES,DESCR
   23 CONTINUE
      NDUA=IDUA(/2)
C
C  **** INITIALISATION DE INCPOS ET DE INCTRA.
C
      MAXI=MAXINC
      SEGINI,MINCPO

      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)
         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(IMIK(K).NE.LISINC(J).OR.IHAR(K).NE.IHARIR) GO TO 33
               IF(IDUA(K).NE.LISDUA(J)) THEN
                  MOTERR(1:4)=IMIK(K)
                  MOTERR(5:8)=IDUA(K)
                  MOTERR(9:12)=LISDUA(J)
                  CALL ERREUR(1026)
                  RETURN
               ENDIF
               GOTO 32
 33         CONTINUE
            CALL ERREUR(5)
 32         CONTINUE
            INCTRA(J)=K
            DO 31 I=1,N2
               IJ=INUINV(NUM(NOELEP(J),I))
               INCPO(K,IJ)=1
*  terme diagonal
               diatmp(K,IJ)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
 31         continue
 34      CONTINUE
         SEGDES,DESCR
         SEGDES,INCTRA
         SEGDES XMATRI
 29   CONTINUE
C
C  ****  INITIALISATION DE IPOS
C
      IPOS(1)=0
      NA=0
      DO 37 I=1,NNOE
         nad=na
         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

**    write(6,*) ' avant ',(incpo(k,i),k=1,maxinc)
*  trier incpo suivant les val de diatmp
         call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
         do 351 k=1,na-nad
            incpo(itrv1(k),i)=k+nad
 351     continue
**    write(6,*) ' apres ',(incpo(k,i),k=1,maxinc)
         IPOS(I+1)=NA
 37   CONTINUE
      SEGDES,MIDUA,MIMIK,MHARK
C
C  ****  INITIALISATION DE IMINI
C SG 2024/11 on saute car ne semble pas utilisé
      GOTO 444
      INC=NA
      SEGINI,IMINI
      INC1=INC+1
      DO 38 I=1,INC
         IMINI(I)=INC1
  38  CONTINUE
      DO 40 IRI=1,NNVA
         MELEME=IRIGEL(1,IRI)
         SEGACT,MELEME
         DESCR=IRIGEL(3,IRI)
         SEGACT,DESCR
         INCTRA=INCTRR(IRI)
         SEGACT,INCTRA
         N1=NOELEP(/1)
         N2=NUM(/2)
         N3=NUM(/1)
         DO 41 I=1,N2
            IJ=NNOE+1
            DO 42 J=1,N3
               IJ1=INUINV(NUM(J,I))
               IJ=MIN(IJ1,IJ)
 42         CONTINUE
            IPR=IPOS(IJ)+1
            DO 43 JJ=1,N1
               IJA=INUINV(NUM(NOELEP(JJ),I))
               IJB=INCTRA(JJ)
               IK=INCPO(IJB,IJA)
               IMINI(IK)=MIN(IMINI(IK),IPR)
 43         CONTINUE
 41      CONTINUE
         SEGDES,DESCR
         SEGDES,INCTRA
 40   CONTINUE
*
 444  CONTINUE
      segsup diatmp,strv
      SEGDES,MRIGID
      SEGDES,IPOS
ccc      SEGDES,IMINI
      SEGDES,ITOPO
      SEGDES,IITOP
      SEGDES,INUINV
      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
ccc      IMINIY=IMINI
         iminiy=0
      IPOY=IPOS
      SEGDES,MMATRI
      RETURN
      END