C BLOQUE    SOURCE    MB234859  26/07/23    21:15:06     12603          
C-----------------------------------------------------------------------
C  Cet operateur impose les BLOCAGES
C
C  Syntaxe 1 :
C
C        ENC1 = BLOQUER ( DEPL ) ( ROTA )  POI1
C
C    ou  ENC1 = BLOQUER  RADIAL  P1  (P2)  MELEME
C                        ORTHOR  P1  (P2)  MELEME
C
C    ou  ENC1 = BLOQUER (DEPL) (ROTA) DIRECTION V1  MELEME
C
C        DIM = 1        ( UX UY UZ ) ou ( UR UZ )  |
C        DIM = 2 OU 3   ( UX UY UZ RX RY RZ )      | MELEME
C        AXISYM         ( RX RZ RT UT )            |
C       
C        POI1   = OBJET DE TYPE POINT
C        MELEME = OBJET DE TYPE MELEME
C        ENC1   = OBJET DE TYPE RIGIDITE
C
C  Remarques :
C  1) On peut imposer des BLOCAGES UNILATERAUX en specifiant les
C     mots-cles MINIMUM ou MAXIMUM.
C  2) La condition peut etre imposee strictement ou en moyenne sur les
C     noeuds du maillage en specifiant le mot-cle FAIB.
C
C  Syntaxe 2 :
C
C        ENC1 = BLOQUER TAB1
C
C        POI1   = OBJET DE TYPE TABLE de sous-type LIAISONS_STATIQUES
C        ENC1   = OBJET DE TYPE RIGIDITE
C-----------------------------------------------------------------------
C  Juillet 2003 : passage a un seul multiplicateur
C-----------------------------------------------------------------------

      SUBROUTINE BLOQUE

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

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCREEL
-INC CCHAMP
-INC SMCHPOI
-INC TMTRAV
      POINTEUR MTRAF.MTRAV
-INC SMCOORD
-INC SMELEME
-INC SMLMOTS
-INC SMMODEL
-INC SMCHAML
-INC SMRIGID
-INC SMTABLE

      DIMENSION XNOR(3),U1(3),U2(3)

      CHARACTER*(LOCHPO) CHADDL
      CHARACTER*8 MOTRIG
      CHARACTER*4 MOTTCL(1),MOTPV(3) ,MOTBLO(5)
      CHARACTER*4 MODEPL(6),MODEDU(6),MOROTA(5),MORODU(5)
      CHARACTER*4 MODE1D(2),MOFO1D(2)

      DATA EPSI   / 1.D-12 /
      DATA MOTRIG / 'RIGIDITE' /
      DATA MOTTCL / 'FAIB' /
      DATA MOTPV  / 'MINI','MAXI','FROT' /
      DATA MOTBLO / 'DEPL','ROTA','RADI','ORTH','DIRE' /
      DATA MODEPL / 'UX  ','UY  ','UZ  ','UR  ','UZ  ','UT  ' /
      DATA MODEDU / 'FX  ','FY  ','FZ  ','FR  ','FZ  ','FT  ' /
      DATA MOROTA / 'RX  ','RY  ','RZ  ','RT  ','RS  ' /
      DATA MORODU / 'MX  ','MY  ','MZ  ','MT  ','MS  ' /
C Tableaux MODE1D et MOFO1D sont utilises pour certains modes 1D
      DATA MODE1D / 'UX  ','UZ  ' /
      DATA MOFO1D / 'FX  ','FZ  ' /

C  Pour ne pas avoir de verrouillage sur MCOORD en //
      SEGDES,MCOORD
      SEGACT,MCOORD*MOD
C     ------------------------------------------------------------------
C     Syntaxe 2 : Lecture d'une table LIAISONS STATIQUES
C     ------------------------------------------------------------------
      CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou)
      IF (IRETOU.NE.0) THEN
        CALL BLOQU2(IPT)
        RETURN
      ENDIF
C     ------------------------------------------------------------------
C     Syntaxe 1 : Lecture des arguments
C     ------------------------------------------------------------------
C     0- Initialisations selon le type de probleme
      idimp1=IDIM+1
      ISPE1D=0
C     Deformations planes ou contraintes planes ou defo. plane gene :
      IF (IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
        LDEPL=2
        IADEPL=0
        LROTA=1
        IAROTA=2
C     Axisymetrique :
      ELSE IF (IFOUR.EQ.0) THEN
        LDEPL=2
        IADEPL=3
        LROTA=1
        IAROTA=3
C     Fourier :
      ELSE IF (IFOUR.EQ.1) THEN
        LDEPL=3
        IADEPL=3
        LROTA=1
        IAROTA=3
C     Tridimensionnel :
      ELSE IF (IFOUR.EQ.2) THEN
        LDEPL=3
        IADEPL=0
        LROTA=3
        IAROTA=0
C     Massif 1D (IDIM=1) :
      ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
        IF (IFOUR.LE.6) THEN
          LDEPL=1
          IADEPL=0
        ELSE IF (IFOUR.GE.7.AND.IFOUR.LE.10) THEN
          LDEPL=2
          IADEPL=0
          IF (IFOUR.EQ.9.OR.IFOUR.EQ.10) ISPE1D=1
        ELSE IF (IFOUR.EQ.11) THEN
          LDEPL=3
          IADEPL=0
        ELSE IF (IFOUR.EQ.15) THEN
          LDEPL=2
          IADEPL=3
        ELSE
          LDEPL=1
          IADEPL=3
        ENDIF
        LROTA=0
        IAROTA=0
C     Autres cas :
      ELSE
        LDEPL=0
        IADEPL=0
        LROTA=0
        IAROTA=0
      ENDIF
C
      KPOINT=0
      ILUMO1=0
      ILUMO2=0
      MLMOT1=0
      MLMOT2=0
      MTRAV=0
      MTRAF=0
C
C     1- Type de la condition (unilaterale ou non)
C     Lecture eventuelle de 'MAXI','MINI'
C     -----------------------------------------------------------------
      NILATE=0
      CALL LIRMOT(MOTPV,3,IPO,0)
      IF (IPO.EQ.1) NILATE=-1
      IF (IPO.EQ.2) NILATE=1
      IF (IPO.EQ.3) NILATE=2
C     Pas de frottement en 1D
      IF (IPO.EQ.3.AND.IDIM.EQ.1) THEN
        INTERR(1)=IDIM
        MOTERR(1:4)=MOTPV(3)
        CALL ERREUR(971)
        GOTO 1000
      ENDIF
C
C     2- Lecture eventuelle des MOTS autres que des DDLS
C     ------------------------------------------------------------------
      IRADIA=0
      IDIREC=0
      IDEPL=0
      IROTA=0
C
C     Lecture eventuelle de 'FAIB'
C     -----------------------------------------------------------------     
      CALL LIRMOT(MOTTCL,1,IFAIBL,0)
C
C     Lecture eventuelle de 'RADI','ORTH'
C     -----------------------------------------------------------------     
      CALL LIRMOT(MOTBLO(3),2,IMOT,0)
      IF (IMOT.NE.0) THEN
C       En DIMENSION 1, les mots-cles 'RADI,'ORTH' sont interdits
        IF (IDIM.EQ.1) THEN
          INTERR(1)=IDIM
          MOTERR(1:4)=MOTBLO(2+IMOT)
          CALL ERREUR(971)
          GOTO 1000
        ENDIF
        IRADIA=IMOT
C
        CALL LIROBJ('POINT',IPOIN1,1,IRETOU)
        IF (IRETOU.EQ.0) GOTO 1000
        j=(IPOIN1-1)*idimp1
        DO i=1,IDIM
          U1(i)=XCOOR(j+i)
        ENDDO
        IF (IDIM.EQ.3) THEN
          CALL LIROBJ('POINT',IPOIN2,1,IRETOU)
          IF (IRETOU.EQ.0) GOTO 1000
          j=(IPOIN2-1)*idimp1
          YL=0.D0
          DO i=1,IDIM
            U2(i)=XCOOR(j+i)-U1(i)
            YL=YL+U2(i)*U2(i)
          ENDDO
C         Calcul du vecteur directeur unitaire de l'axe (U2)
          IF (YL.LT.EPSI) THEN
            CALL ERREUR(237)
            GOTO 1000
          ENDIF
          YL=1.D0/SQRT(YL)
          DO i=1,IDIM
            U2(i)=U2(i)*YL
          ENDDO
        ENDIF
C
        IBDDL=LDEPL
        GOTO 4481
      ENDIF
C
C     Lecture eventuelle de 'DEPL' et/ou 'ROTA'
C     -----------------------------------------------------------------     
      IBDDL=0
 4480 CONTINUE
      CALL LIRMOT(MOTBLO,2,IMOT,0)
      IF (IMOT.EQ.1) THEN
        IDEPL=1
        IBDDL=IBDDL+LDEPL
        GOTO 4480
      ELSEIF (IMOT.EQ.2) THEN
        IROTA=1
        IBDDL=IBDDL+LROTA
        GOTO 4480
      ENDIF
C
 4481 CONTINUE
      IF (IRADIA.NE.0 .OR. IDEPL.NE.0 .OR. IROTA.NE.0) THEN
        JGN=LOCHPO
        JGM=IBDDL
        SEGINI,MLMOT1,MLMOT2
C
        IDEB=0
        IF (IRADIA.NE.0 .OR. IDEPL.EQ.1) THEN
C         Cas particulier pour certains modes de IDIM=1
          IF (ISPE1D.EQ.1) THEN
            DO i=1,LDEPL
              MLMOT1.MOTS(i)=MODE1D(IADEPL+i)
              MLMOT2.MOTS(i)=MOFO1D(IADEPL+i)
            ENDDO
C         Cas general
          ELSE
            DO i=1,LDEPL
              MLMOT1.MOTS(i)=MODEPL(IADEPL+i)
              MLMOT2.MOTS(i)=MODEDU(IADEPL+i)
            ENDDO
          ENDIF
          IDEB=LDEPL
        ENDIF
        IF (IROTA.EQ.1) THEN
          DO i=1,LROTA
            MLMOT1.MOTS(IDEB+i)=MOROTA(IAROTA+i)
            MLMOT2.MOTS(IDEB+i)=MORODU(IAROTA+i)
          ENDDO
        ENDIF
      ENDIF
      IF (IRADIA.NE.0) GOTO 449
C
C     Lecture eventuelle de 'DIRE'
C     -----------------------------------------------------------------     
      CALL LIRMOT(MOTBLO(5),1,IMOT,0)
      IF (IMOT.EQ.0) THEN
        IF (IBDDL.NE.0) GOTO 449
        IF (IBDDL.EQ.0) GOTO 445
      ENDIF
      IDIREC=1
C
      IF (IDEPL.NE.0.AND.IROTA.NE.0) THEN
        MOTERR(1:128)='DEPL ROTA'
        CALL ERREUR(-385)
        MOTERR(1:8)='DIRE'
        CALL ERREUR(803)
        GOTO 1000
      ENDIF
C
      CALL LIROBJ('POINT',IPOINT,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
        CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
        CALL ACTOBJ('CHPOINT ',MCHPOI,1)
        IF (IERR.NE.0) GOTO 1000
        IDIREC=2
        IF (IDEPL.EQ.0.AND.IROTA.EQ.0) THEN
C         Les composantes seront donnees par le champ
          IDIREC=3
          CALL EXTR11(MCHPOI,MLMOT3)
          SEGACT,MLMOT3
          IBDDL=MLMOT3.MOTS(/2)
          IF (IBDDL.LE.0) THEN
            MOTERR(1:8)='CHPOINT'
            CALL ERREUR(1027)
            GOTO 1000
          ENDIF
C
          JGN=LOCHPO
          JGM=IBDDL
          SEGINI,MLMOT1,MLMOT2
C
          DO IC=1,IBDDL
            CALL PLACE(NOMDU,LNOMDU,IDUA,MLMOT3.MOTS(IC))
            IF (IDUA.NE.0) THEN
              MLMOT1.MOTS(IC)=NOMDD(IDUA)
              MLMOT2.MOTS(IC)=NOMDU(IDUA)
            ELSE
              CALL PLACE(NOMDD,LNOMDD,IPRI,MLMOT3.MOTS(IC))
              IF (IPRI.EQ.0) THEN
                MOTERR(1:4)=MLMOT3.MOTS(IC)
                CALL ERREUR(108)
                GOTO 1000
              ENDIF
              MLMOT1.MOTS(IC)=NOMDD(IPRI)
              MLMOT2.MOTS(IC)=NOMDU(IPRI)
            ENDIF
          ENDDO
          SEGSUP,MLMOT3
        ENDIF
        MCHPO1=0
        CALL NOMC2(MCHPOI,MLMOT2,MLMOT1,MCHPO1)
        IF (IERR.NE.0) GOTO 1000
      ELSE
        j=(IPOINT-1)*idimp1
        YL=0.D0
        DO i=1,IDIM
          XNOR(i)=XCOOR(j+i)
          YL=YL+XNOR(i)*XNOR(i)
        ENDDO
        IF (YL.LT.EPSI) THEN
          CALL ERREUR(239)
          GOTO 1000
        ENDIF
        YL=1.D0/SQRT(YL)
        DO i=1,IDIM
          XNOR(i)=XNOR(i)*YL
        ENDDO
      ENDIF
      GOTO 449
C
C     3- Lecture eventuelle de DDLs
C     -----------------------------------------------------------------
 445  CONTINUE
C     Sous la forme de LISTMOTS
      CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
      IF (IERR.NE.0) GOTO 1000
      IF (IRETOU.EQ.0) GOTO 444
      ILUMO1=MLMOT1
C
      CALL LIROBJ('LISTMOTS',MLMOT2,0,IRETO2)
      IF (IERR.NE.0) GOTO 1000
C
      SEGACT,MLMOT1
      IBDDL=MLMOT1.MOTS(/2)
      IF (IBDDL.LE.0) THEN
        CALL ERREUR(643)
        GOTO 1000
      ENDIF
C
      IF (IRETO2.EQ.0) THEN
C       Les composantes DUALES ne sont pas fournies : piocher dans NOMDU
        SEGINI,MLMOT2=MLMOT1
        DO IMOT=1,IBDDL
          CALL PLACE(NOMDD,LNOMDD,idd,MLMOT1.MOTS(IMOT))
          IF (IERR.NE.0) GOTO 1000
          IF (IDD.LE.0) THEN
            MOTERR(1:4)=MLMOT1.MOTS(IMOT)
            CALL ERREUR(108)
            GOTO 1000
          ELSE
            MLMOT2.MOTS(IMOT)=NOMDU(IDD)
          ENDIF
        ENDDO
      ELSE
        ILUMO2=MLMOT2
        SEGACT,MLMOT2
        IF (IBDDL.NE.MLMOT2.MOTS(/2)) THEN
          CALL ERREUR(854)
          SEGDES,MLMOT1,MLMOT2
          GOTO 1000
        ENDIF
      ENDIF
      GOTO 449
C
 444  CONTINUE
C
      JGN=LOCHPO
      JGM=6
      SEGINI,MLMOT1,MLMOT2
      IBDDL=0
C
 446  CONTINUE
C     Sous forme de MOTs
      CALL LIRCHA(CHADDL,0,IMOT)
      IF (IMOT.EQ.0) THEN
        JGN=LOCHPO
        JGM=IBDDL
        SEGADJ,MLMOT1,MLMOT2
        GOTO 447
      ENDIF
      CALL PLACE(NOMDD,LNOMDD,IMOT,CHADDL)
      IF (IERR.NE.0) GOTO 1000
      IF (IMOT.NE.0) THEN
        IBDDL=IBDDL+1
        IF (IBDDL.GT.MLMOT1.MOTS(/2)) THEN
          JGN=LOCHPO
          JGM=JGM+6
          SEGADJ,MLMOT1,MLMOT2
        ENDIF
        MLMOT1.MOTS(IBDDL)=NOMDD(IMOT)
        MLMOT2.MOTS(IBDDL)=NOMDU(IMOT)
      ELSE
        MOTERR(1:4)=CHADDL
        CALL ERREUR(108)
        GOTO 1000
      ENDIF
      GOTO 446
C
C     Conditions aux limites via un MODELE --> non documente
 447  CONTINUE
      IPMODL=0
      CALL LIROBJ('MMODEL  ',IPMODL,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 449
      CALL ACTOBJ('MMODEL  ',IPMODL,1)
      CALL NOVARD(IPMODL,'DEPL')
      CALL LIROBJ('LISTMOTS',MLMOT1,1,IRETOU)
      IF (IERR.NE.0) GOTO 1000
      CALL NOVARD(IPMODL,'FORC')
      CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
      IF (IERR.NE.0) GOTO 1000
      SEGACT,MLMOT1,MLMOT2
      IBDDL=MLMOT1.MOTS(/2)
C
 449  CONTINUE
C
C     Verifier que le nombre de DDLs a bloquer n'est pas nul
      IF (IBDDL.EQ.0) THEN
        CALL ERREUR(107)
        GOTO 1000
      ENDIF
C
C     4- Lecture d'un POINT ou d'un MAILLAGE
C     -----------------------------------------------------------------
      CALL LIROBJ('POINT',KPOINT,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
        CALL LIROBJ('MAILLAGE',KOBJET,1,IRETOU)
        IF (IERR.NE.0) GOTO 1000
        IPMAIL=KOBJET
        MELEME=KOBJET
        SEGACT,MELEME
        IF (ITYPEL.NE.1) CALL CHANGE(MELEME,1)
        NBPOIN=NUM(/2)
      ELSE
        MELEME=KPOINT
C       Transforme le POINT en POI1
        CALL CRELEM(MELEME)
        IPMAIL=MELEME
        NBPOIN=1
      ENDIF
      IF (IERR.NE.0) GOTO 1000
C
C     5- Coefficients de la matrice de blocage
C     -----------------------------------------------------------------
      IF (IDIREC.GE.2) THEN
C       MTRAV contient les directions normees (DEPL ou ROTA) ou non
C       1) Recopie des composantes et valeurs pertinentes du chpoint
C          dans le TMTRAV
        CALL CP2TR2(MLMOT1,MELEME,MCHPO1,MTRAV)
        SEGSUP,MCHPO1
        IF (IERR.NE.0) GOTO 1000
C       SEGPRT,MTRAV
C       2) On norme la direction dans le cas DEPL ou ROTA
        IF (IDIREC.EQ.2) THEN
          SEGACT MTRAV*MOD
          DO IBPOIN=1,NBPOIN
            YL=0.D0
            DO I=1,IDIM
              XNOR(I)=BB(I,IBPOIN)
              YL=YL+XNOR(I)*XNOR(I)
            ENDDO
            IF (YL.LT.XPETIT) THEN
              CALL ERREUR(239)
              GOTO 1000
            ENDIF
            YL=1.D0/SQRT(YL)
            DO I=1,IBDDL
              BB(I,IBPOIN)=XNOR(I)*YL
            ENDDO
          ENDDO
C         SEGPRT,MTRAV
        ENDIF
      ENDIF
C
      IF (IRADIA.NE.0) THEN
C       CHPOINT de travail
        NC=IBDDL
        N=NBPOIN
        NAT=1
        NSOUPO=1
        SEGINI,MPOVA2,MSOUP2,MCHPO2
        MCHPO2.IPCHP(1)=MSOUP2
        MSOUP2.IGEOC=MELEME
        MSOUP2.IPOVAL=MPOVA2
        DO IC=1,IBDDL
          MSOUP2.NOCOMP(IC)=MLMOT1.MOTS(IC)
        ENDDO
C
        DO IB=1,NBPOIN
          j=(NUM(1,IB)-1)*idimp1
          DO i=1,IDIM
            XNOR(i)=XCOOR(j+i)-U1(i)
          ENDDO
          IF (IDIM.EQ.2) THEN
            YL=XNOR(1)*XNOR(1)+XNOR(2)*XNOR(2)
            IF (YL.LT.EPSI) THEN
              CALL ERREUR(238)
              GOTO 1000
            ENDIF
            YL=1.D0/SQRT(YL)
            IF (IRADIA.EQ.1) THEN
              XNOR(1)=XNOR(1)*YL
              XNOR(2)=XNOR(2)*YL
            ELSE IF (IRADIA.EQ.2) THEN
              XX=XNOR(1)
              XNOR(1)=-XNOR(2)*YL
              XNOR(2)=XX*YL
            ENDIF
            MPOVA2.VPOCHA(IB,1)=XNOR(1)
            MPOVA2.VPOCHA(IB,2)=XNOR(2)
          ELSE
            YL=XNOR(1)*U2(1)+XNOR(2)*U2(2)+XNOR(3)*U2(3)
            XL=0.D0
            DO i=1,3
              XNOR(i)=XNOR(i)-YL*U2(i)
              XL=XL+XNOR(i)*XNOR(i)
            ENDDO
            IF (XL.LT.EPSI) THEN
              CALL ERREUR(238)
              GOTO 1000
            ENDIF
            IF (IRADIA.EQ.1) THEN
              XL=1.D0/SQRT(XL)
              XNOR(1)=XNOR(1)*XL
              XNOR(2)=XNOR(2)*XL
              XNOR(3)=XNOR(3)*XL
            ELSE IF (IRADIA.EQ.2) THEN
              XX=XNOR(1)
              YY=XNOR(2)
              ZZ=XNOR(3)
              XNOR(1)=YY*U2(3)-ZZ*U2(2)
              XNOR(2)=ZZ*U2(1)-XX*U2(3)
              XNOR(3)=XX*U2(2)-YY*U2(1)
            ENDIF
            MPOVA2.VPOCHA(IB,1)=XNOR(1)
            MPOVA2.VPOCHA(IB,2)=XNOR(2)
            MPOVA2.VPOCHA(IB,3)=XNOR(3)
          ENDIF
        ENDDO
        CALL CP2TR2(MLMOT1,MELEME,MCHPO2,MTRAV)
        SEGSUP,MPOVA2,MSOUP2,MCHPO2
      ENDIF
C
      IF (IFAIBL.EQ.1) THEN
        CALL BLOFAI(IPMAIL,MLMOT1,MCHPO1)
        IF (IERR.NE.0) GOTO 1000
        CALL CP2TR2(MLMOT1,MELEME,MCHPO1,MTRAF)
        SEGSUP,MCHPO1
        YL=0.D0
        DO IC=1,IBDDL
          DO IB=1,NBPOIN
           YL=YL+MTRAF.BB(IC,IB)
          ENDDO
        ENDDO
        IF (YL.LT.XPETIT) THEN
          CALL ERREUR(239)
          GOTO 1000
        ENDIF
        YL=1.D0/YL
        DO IC=1,IBDDL
          ZL=YL
          IF (IDIREC.EQ.1) ZL=YL*XNOR(IC)
          DO IB=1,NBPOIN
            IF ((IDIREC.GE.2).OR.(IRADIA.NE.0)) ZL=YL*BB(IC,IB)
            MTRAF.BB(IC,IB)=MTRAF.BB(IC,IB)*ZL
          ENDDO
        ENDDO
      ENDIF
C
C     6- Creation et remplissage de la rigidite
C     -----------------------------------------------------------------
C     NNMAT : nombre de DDLs a bloquer par noeud et donc nombre de 
C             multiplicateurs a creer par noeud
C     Les cas RADIal et DIREction n'ecrivent qu'une condition par noeud
      NNMAT=IBDDL
      NINCO=1
      NNOEU=1
      IF (IDIREC.NE.0 .OR. IRADIA.NE.0 .OR. IFAIBL.EQ.1) THEN
        NNMAT=1
        NINCO=IBDDL
        IF (IFAIBL.EQ.1) THEN
          NNOEU=NBPOIN
          NBPOIN=1
        ENDIF
      ENDIF
C
C     Initialisation de l'objet RIGIDITE associe aux BLOCAGES
      NRIGEL=NNMAT
      SEGINI,MRIGID
      MTYMAT=MOTRIG
      IFORIG=IFOUR
      ICHOLE=0
      IMGEO1=0
      IMGEO2=0
C
C     Noeud support de chaque multiplicateur de Lagrange
C     NBPOIN : nombre de points du maillage MELEME a bloquer
      NBNO=nbpts
      NBPTS=NBNO+NNMAT*NBPOIN
      SEGADJ,MCOORD
C
C     Boucle sur le nombre de DDLs a bloquer
      DO IAA=1,NNMAT
C
C       Creation du maillage MELEME de MULTiplicateurs associe aux BLOCAGES
        NBSOUS=0
        NBREF=0
        NBNN=1+NNOEU
        NBELEM=NBPOIN
        SEGINI,IPT1
        IPT1.ITYPEL=22
        DO i=1,NBPOIN
          j=(IAA-1)*NBPOIN+i
          IPT1.NUM(1,i)=NBNO+j
          DO k=1,NNOEU
            IPT1.NUM(1+k,i)=NUM(k,i)
            IPT1.ICOLOR(i)=IDCOUL
          ENDDO
C
C         Coordonnees du noeuds support du LX (meme position que les noeuds)
          IREF1=(NBNO+j  -1)*idimp1
          IREF3=(NUM(1,i)-1)*idimp1
          DO j=1,IDIM
            XCOOR(IREF1+j)=XCOOR(IREF3+j)
          ENDDO
        ENDDO
C
C       Creation du descripteur associe au IAA-eme multplicateur
        NLIGRP=1+(NINCO*NNOEU)
        NLIGRD=NLIGRP
        SEGINI,DESCR
        NOELEP(1)=1
        NOELED(1)=1
        LISINC(1)='LX  '
        LISDUA(1)='FLX '
        IF (IDIREC.NE.0 .OR. IRADIA.NE.0 .OR. IFAIBL.EQ.1) THEN
          DO i=1,NINCO
            DO k=1,NNOEU
              l=1+k+(i-1)*NNOEU
              NOELEP(l)=1+k
              NOELED(l)=1+k
              LISINC(l)=MLMOT1.MOTS(i)
              LISDUA(l)=MLMOT2.MOTS(i)
            ENDDO
          ENDDO
        ELSE
          NOELEP(2)=2
          NOELED(2)=2
          LISINC(2)=MLMOT1.MOTS(IAA)
          LISDUA(2)=MLMOT2.MOTS(IAA)
        ENDIF
C
C       Creation de la matrice de rigidite elementaire
        NELRIG=NBPOIN
        RIGREL=0
        SEGINI,XMATRI
C
        IF (IFAIBL.EQ.1) THEN
          DO IB=1,NBPOIN
            RE(1,1,IB)=0.D0
            DO IC=1,NINCO
              DO IK=1,NNOEU
                l=1+ik+(ic-1)*NNOEU
                RE(l,1,IB)=MTRAF.BB(IC,IK)
                RE(1,l,IB)=MTRAF.BB(IC,IK)
              ENDDO
            ENDDO
          ENDDO
        ELSEIF ((IRADIA.NE.0).OR.(IDIREC.GE.2))THEN
          DO IB=1,NBPOIN
            RE(1,1,IB)=0.D0
            DO IC=1,NINCO
              RE(IC+1,1,IB)=BB(IC,IB)
              RE(1,IC+1,IB)=BB(IC,IB)
            ENDDO
          ENDDO
        ELSE IF (IDIREC.EQ.1) THEN
          DO IB=1,NBPOIN
            RE(1,1,IB)=0.D0
            DO IC=1,IDIM
              RE(IC+1,1,IB)=XNOR(IC)
              RE(1,IC+1,IB)=XNOR(IC)
            ENDDO
          ENDDO
        ELSE
          DO IB=1,NBPOIN
            RE(1,1,IB)=0.D0
            RE(2,1,IB)=1.D0
            RE(2,2,IB)=0.D0
            RE(1,2,IB)=RE(2,1,IB)
          ENDDO
        ENDIF
C
C       IAA-eme rigidite elementaire
        COERIG(IAA)=1.D0
        IRIGEL(1,IAA)=IPT1
        IRIGEL(2,IAA)=0
        IRIGEL(3,IAA)=DESCR
        IRIGEL(4,IAA)=XMATRI
        IRIGEL(5,IAA)=NIFOUR
        IRIGEL(6,IAA)=NILATE
      ENDDO
C     Fin de la boucle sur les IAA DDLs a bloquer
C
      CALL RELASI(MRIGID)
      CALL ACTOBJ('RIGIDITE',MRIGID,1)
      CALL ECROBJ('RIGIDITE',MRIGID)
C     ------------------------------------------------------------------
C     Menage avant de quitter
C     ------------------------------------------------------------------
 1000 CONTINUE
      IF (KPOINT.NE.0) SEGSUP,MELEME
      IF (MLMOT1.NE.0 .AND. ILUMO1.EQ.0) SEGSUP,MLMOT1
      IF (MLMOT2.NE.0 .AND. ILUMO2.EQ.0) SEGSUP,MLMOT2
      IF (MTRAV .NE.0) SEGSUP,MTRAV
      IF (MTRAF .NE.0) SEGSUP,MTRAF
C
      END