C RIGSUR    SOURCE    PV090527  26/04/30    21:16:21     12529          
  
      SUBROUTINE RIGSUR(ISOU ,IPOI6, IMODEL)     

C---------------------------------------------------------------------*
C subroutine construisant les sousmatrices de rigidité pour les 
C sous-modeles de type SURE classiques :
C  itypel=48, nformod=259, mfr=1
C---------------------------------------------------------------------*
C---------------------------------------------------------------------*
C                                                                     *
C   ENTREES :                                                         *
C   ________                                                          *
C                                                                     *
C        IMODEL   pointeur sur le sous modele de sure                 *
C   ENTREES/SORTIE :                                                  *
C   ________                                                          *
C                                                                     *
C        IPOI6    pointeur sur la rigidite construite                 *
C        ISOU     compteur des sous matrices de rigidite construite   *
C---------------------------------------------------------------------*
c
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C

-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
C-INC SMINTE
-INC SMMODEL
-INC SMELEME
-INC CCHAMP
-INC CCGEOME
-INC SMCOORD
C

C
C Petit tableau des "couleurs" des relations de conformite
      DIMENSION LCOLOR(6)
      DATA LCOLOR / 1, 3, 6, 10, 16, 24 /
C
      MELEME=imamod
      SEGACT, MELEME
      IDEBUT = LCOLOR(ICOLOR(1)) - 3

c récupérations du nom des composantes obligatoire du modele de sure
      nomid=IMODEL.lnomid(1)
      SEGACT, nomid
      
C**********************************************************************
C Boucle sur les composantes primales obligatoires du sure
C**********************************************************************
      ICOMP=0

      DO 2 ICOMP=1,nomid.lesobl(/2)

C====================
c creation d'un maillage avec un premier noeud par lélément 
c correspondant à un multiplicateur de lagrange
C====================
          NBNN=NUM(/1)+1
          NBELEM=NUM(/2)
          NBSOUS=0
          NBREF=0
          SEGINI, IPT4
          IPT4.ITYPEL=22
          DO 1 J=1,NUM(/2)
              ipt4.icolor(j)=icolor(j)
              DO 11 I=1,NUM(/1)
                  IPT4.NUM(I+1,J)=NUM(I,J)
  11          CONTINUE
  1       CONTINUE
C creation n'un nouveau noeud pour supporter chaque multiplicateur de lagrange
          segact mcoord*mod
          NBPT1= nbpts
          NBPTS=NBPT1+(IPT4.NUM(/2))
          SEGADJ MCOORD
          DO 12 J=1,NUM(/2)
             NGLOB=(NBPT1+J-1)*(IDIM+1)
C remplissage des coordonees des nouveux points
             DO 13 ID= 1,IDIM
                 XCOOR(NGLOB+ID)=XCOOR((IPT4.NUM(2,J)-1)*(IDIM+1)+ID)
  13         CONTINUE
             IPT4.NUM(1,J) = NBPT1 + J
  12      CONTINUE
      
C====================
C *** SEGMENT XMATRI
C====================
         NLIGRD=IPT4.NUM(/1)
         NLIGRP=NLIGRD
         NELRIG=IPT4.NUM(/2)
         rigrel=0
         SEGINI, XMATRI
         DO 3 I=1,NELRIG
            RE(1,2,i)=-1.
            RE(2,1,i)=-1.
            DO 4 ICAZ=3,NLIGRD
               RE(1,ICAZ,i)=XCOEFF(IDEBUT+ICAZ)
               RE(ICAZ,1,i)=RE(1,ICAZ,i)
  4        CONTINUE
  3      CONTINUE
C         write(*,*) 'COMPOSANTE OBLIGATOIRE DU SURE :'
C         write(*,*) (nomid.lesobl(ICOMP))
C         write(*,*) 'MATRICE elementaire :' 
C         DO 5 I=1,NLIGRD
C            write(*,*) (RE(i,iou,1), iou=1,NLIGRD)
C  5      CONTINUE

C====================
C *** SEGMENT DESCR
C====================

         NEXIST=0
         DO 6 I=1,LNOMDD
           IF (NOMDD(I).EQ.nomid.lesobl(ICOMP)) NEXIST = I
  6      CONTINUE
         
         IF (NEXIST.EQ.0) THEN
           CALL ERREUR(837)
         ENDIF

         SEGINI, DESCR
         LISINC(1)='LX  '
         LISDUA(1)='FLX '
         NOELEP(1)=1
         NOELED(1)=1
         DO 7 I=2,NLIGRD
           LISINC(I)=NOMDD(NEXIST)
           LISDUA(I)=NOMDU(NEXIST)
           NOELEP(i)=i
           NOELED(i)=i
  7      CONTINUE

C====================
C *** SEGMENT MRIGID
C====================
         MRIGID=IPOI6
         SEGACT, MRIGID*mod

C       Ajustement du segment rigidite si plus d'une composante
        IF (ICOMP.GT.1) THEN
            nrigel=IRIGEL(/2)+1
            SEGADJ, MRIGID
            isou = isou+1
         ENDIF       
         COERIG(isou)=1.
         IRIGEL(1,isou)=IPT4
         IRIGEL(2,isou)=0
         IRIGEL(3,isou)=DESCR
         IRIGEL(4,isou)=XMATRI
         IRIGEL(5,isou)=0
         IRIGEL(6,isou)=0
         IRIGEL(7,isou)=0
         IRIGEL(8,isou)=0

c         SEGDES, MRIGID
         SEGDES, DESCR
         SEGDES, XMATRI
C**********************************************************************
C FIN Boucle sur les composantes primales obligatoires du sure
C**********************************************************************
  2   CONTINUE

      RETURN
      END