C TDIAG1    SOURCE    PV090527  26/04/30    21:16:38     12529          
      SUBROUTINE TDIAG1(NOMDU1,NOMPR1,IPTMAIL,IPCH1,IPRIGI)
C
C**********************************************************************
C
C     Subroutine appelée par TDIAG.
C     Création d'une matrice de couplage dans le cas où les
C     supports des inconnues primales et duales sont identiques.
C
C  ENTREES :
C  --------
C
C  NOMDU1  :  Nom de l'inconnue duale.
C  NOMPR1  :  Nom de l'inconnue primale.
C  IPTMAIL :  Pointeur du maillage de connectivite
C  IPCH1   :  Pointeur sur le champ multiplicateur.
C
C  SORTIE :
C  -------
C
C  IPRIGI  :  Pointeur sur la matrice de couplage élémentaire.
C
C
C AUTEUR, DATE DE CREATION:
C -------------------------
C
C     Laurent DADA      décembre 1996
C
C AUTEUR, DATE DE MODIFICATION:
C -----------------------------
C
C     Alexandre BLEYER          Novembre 2002
C     Modifications : - creation des matrices elementaires simplifiee
C                     - utilisation d'un maillage de connectivite
C                      ici S.P.G des inconnues (spg Primale=spg Duale)
C
C LANGAGE:
C --------
C
C     ESOPE + FORTRAN77
C
C**********************************************************************
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
-INC SMCHPOI
-INC SMELEME
      POINTEUR IPTMAIL.MELEME,IPTC1.MELEME
-INC SMRIGID
C
      SEGMENT REDI
        INTEGER IPOS1(NNGOT)
      ENDSEGMENT
C
      CHARACTER*8 TYPE,NOMDU1,NOMPR1
C
C Récupération du pointeur des valeurs
C du champ multiplicateur.
C Remplissage du tableau de redirection
C
      NNGOT = nbpts
      SEGINI REDI
C
      MCHPOI = IPCH1
      SEGACT MCHPOI
      MSOUPO = IPCHP(1)
      SEGDES MCHPOI
      SEGACT MSOUPO
      IPTC1  = IGEOC
      MPOVAL = IPOVAL
      SEGACT MPOVAL
      SEGDES MSOUPO
      SEGACT IPTC1
      NBELC1 = IPTC1.NUM(/2)
      DO 100 I100=1,NBELC1
        IPOS1(IPTC1.NUM(1,I100)) = I100
100    CONTINUE
      SEGDES IPTC1
C
C activation du SPG de l'inconnue duale
C
      SEGACT IPTMAIL
      IF (IPTMAIL.ITYPEL.NE.1) THEN
        CALL ERREUR(16)
        RETURN
      ENDIF
      NBEL1 = IPTMAIL.NUM(/2)
C
C Création de la RIGIDITE
C
      NRIGE  = 8
      NRIGEL = 1
      SEGINI MRIGID
      IPRIGI = MRIGID
C
      MTYMAT = 'RIGIDITE'
      IFORIG = IFOUR
      ICHOLE = 0
      IMGEO1 = 0
      IMGEO2 = 0
      ISUPEQ = 0
      COERIG(1)   = 1.D0
      IRIGEL(1,1) = IPTMAIL
      IRIGEL(2,1) = 0
      IRIGEL(5,1) = NIFOUR
      IRIGEL(6,1) = 0
      IF (NOMPR1 .EQ. NOMDU1) THEN
         IRIGEL(7,1) = 0
      ELSE
         IRIGEL(7,1) = 2
      ENDIF
      IRIGEL(8,1) = 0
C
C Remplissage du descripteur de l'objet RIGIDITE
C
      NLIGRP = 1
      NLIGRD = 1
      SEGINI DESCR
      IRIGEL(3,1) = DESCR
C
        NOELEP(1) = 1
        LISINC(1) = NOMPR1
        NOELED(1) = 1
        LISDUA(1) = NOMDU1
C
      SEGDES DESCR
C
      NELRIG = NBEL1
      rigrel=0
      SEGINI xMATRI
      DO 30 I30=1,NBEL1
*        SEGINI XMATRI
*        IMATTT(I30) = XMATRI
        NUMPT1 = IPTMAIL.NUM(1,I30)
        IF (IPOS1(NUMPT1).NE.0) THEN
          XVALM1 = VPOCHA(IPOS1(NUMPT1),1)
        ELSE
          MOTERR(1:8)  = 'CHPO    '
          CALL ERREUR(708)
          RETURN
        ENDIF
        RE(1,1,i30) = XVALM1
*        SEGDES XMATRI
30    CONTINUE

      IRIGEL(4,1) = xMATRI
      SEGDES xMATRI
C
C
      SEGDES IPTMAIL
      SEGDES MPOVAL
      SEGDES MRIGID
      SEGSUP REDI
C
      END