C KOPIDR    SOURCE    GOUNAND   11/05/24    21:15:32     6976           
      SUBROUTINE KOPIDR(IGEOM,LPRIM,MRIGID)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : KOPIDR
C DESCRIPTION : Transforme un CHPOINt MCHPOI en matrice 
C               diagonale MRIGID
C
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C ENTREES            : IGEOM,LPRIM
C ENTREES/SORTIES    :
C SORTIES            : MRIGID
C***********************************************************************
C VERSION    : v1, 10/05/2011, version initiale
C HISTORIQUE : v1, 10/05/2011, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
-INC CCOPTIO
-INC SMRIGID
-INC SMELEME
-INC SMLMOTS
-INC CCHAMP
*     
* Executable statements
*
C  
C
C**** On controle que le MELEME soit de type POI1
C     Si non changer
C
      MELEME = IGEOM
      SEGACT MELEME
      NBSOUS = MELEME.LISOUS(/1)
      NTYP = MELEME.ITYPEL
C
      IF ((NBSOUS.NE.0).OR.(NTYP.NE.1)) THEN
* In CHANGE : SEGINI MELEME
         CALL CHANGE(MELEME,1)
         IPT1 = IGEOM
         SEGDES IPT1
         IF (IERR.NE.0) RETURN
      ENDIF
*
      MLMOTS=LPRIM
      SEGACT MLMOTS
      NRIGEL=MOTS(/2)
      SEGINI MRIGID
      MTYMAT='DIAGONAL'
C
      NBEL=NUM(/2)
      DO I=1,NRIGEL
         COERIG(I)=1.D0
         IRIGEL(1,I)=MELEME
         NLIGRP=1
         NLIGRD=1
         SEGINI DESCR
         LISINC(1)=MOTS(I)
         CALL PLACE(NOMDD,LNOMDD,idx,MOTS(I))
         IF (idx.NE.0) THEN
            LISDUA(1)=NOMDU(idx)
         ELSE
            LISDUA(1)=MOTS(I)
         ENDIF
         NOELEP(1)=1
         NOELED(1)=1
         SEGDES DESCR
         IRIGEL(3,I)=DESCR
         NELRIG=NBEL
         SEGINI XMATRI
         DO IBEL=1,NBEL
            RE(1,1,IBEL)=1.D0
         ENDDO
         SEGDES XMATRI
         IRIGEL(4,I)=XMATRI
      ENDDO
      SEGDES MRIGID
      SEGDES MLMOTS
      SEGDES MELEME
*
* Normal termination
*
      RETURN
*
* End of subroutine KOPIDR
*
      END