C BMTD      SOURCE    CHAT      11/03/16    21:15:45     6902           
      SUBROUTINE BMTD
C-----------------------------------------------------------------------
C                       -1 t
C  Calcul du produit B M    D  CHPcentre
C         le résultat est un CHPface
C-----------------------------------------------------------------------
C
C---------------------------
C Phrase d'appel (GIBIANE) :
C---------------------------
C
C  CHP2 = 'BMTD'  MMODEL RIG1  CHP1 ;
C
C------------------------
C Operandes et resultat :
C------------------------
C
C  MMODEL  : MODELE permettant de récuperer la TABLE DOMAINE
C            contenant les maillages et les connectivités.
C            On attend un modèle DARCY
C  RIG1    : Matrices hybrides elementaires de DARCY crees par MHYB.
C  CHP1    : CHPO centre à plusieur composantes.
C  CHP2    : CHPO face à plusieur composantes dont le support géometrique
C            est le maillage de la rigidité les noms des composantes
C            sont ceux de CHP1
C
C-----------------------------------------------------------------------
C
C Langage : ESOPE + FORTRAN77
C
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*
-INC CCOPTIO                         
-INC SMCOORD
-INC SMCHPOI
-INC SMELEME
-INC SMRIGID
-INC SMTABLE
-INC SMMODEL
*                                                                 
      SEGMENT ICCPR
         INTEGER ICPR(NNGOT)
      ENDSEGMENT
*
      LOGICAL LOGRE,LOGIN
      CHARACTER*8 TAPIND,CHARRE,LETYPE
      CHARACTER*4 NOMTOT(1)
*                                                 
* Initialisations
*
      IVALIN = 0
      XVALIN = 0.D0
      LOGIN  = .TRUE.
      IOBIN  = 0
      TAPIND = 'MOT     '
*                                                 
*                                                
* Lecture du MMODEL
*                                                        
      CALL LIROBJ('MMODEL',IPMODE,1,IRET)
      IF(IERR.NE.0)RETURN
      MMODEL=IPMODE
      SEGACT MMODEL
      N1=KMODEL(/1)
      DO 7 I=1,N1
         IMODEL=KMODEL(I)
         SEGACT IMODEL
         IF(FORMOD(1).NE.'DARCY')THEN
             MOTERR(1:16)  = 'DARCY           '
             CALL ERREUR(719)
             RETURN
         ENDIF
    7 CONTINUE
C  on récupère la table DOMAINE
      IPTABL = 0
      CALL LEKMOD(MMODEL,IPTABL,IRET)
      IF (IERR.NE.0) RETURN
*                                                        
      CALL LEKTAB(IPTABL,'ELTFA',IOBRE)
      IF (IERR.NE.0) RETURN
      IELTFA = IOBRE
      CALL LEKTAB(IPTABL,'CENTRE',IOBRE)
      IF (IERR.NE.0) RETURN
      ICENTR = IOBRE
      CALL LEKTAB(IPTABL,'FACE',IOBRE)
      IF (IERR.NE.0) RETURN
      IFACE = IOBRE
*                                                                      
* Lecture de RIGIDITE
*                                                                     
      CALL LIROBJ('RIGIDITE',IPRIGI,1,IRET)
      IF (IERR.NE.0) RETURN                                           
      MRIGID = IPRIGI
*
*                                                 
*                                                                      
* Test du sous-type de la matrice de rigiditée récupérée
*                                                                     
      SEGACT MRIGID
      LETYPE = MTYMAT
      IF (LETYPE.NE.'DARCY') THEN
         MOTERR(1:8)  = 'RIGIDITE'
         MOTERR(9:16) = 'DARCY   '
         CALL ERREUR(79)
         SEGDES MRIGID
         GOTO 100
      ENDIF
*                                                                      
* Controle des pointeurs de MELEME de la rigidité
*                                                                     
      NRIGEL=IRIGEL(/2)
      MELEME=IELTFA
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)THEN
          IF((NRIGEL.NE.1).OR.(IRIGEL(1,1).NE.MELEME))THEN
               MOTERR(1:8)  = 'DARCY   '
               MOTERR(9:16) = 'ELTFA   '
               INTERR(1)    = 1
               CALL ERREUR(698)
               SEGDES MRIGID
               GOTO 100
          ENDIF
      ELSE
          IF(NRIGEL.NE.NBSOUS)THEN
               MOTERR(1:8)  = 'DARCY   '
               MOTERR(9:16) = 'ELTFA   '
               INTERR(1)    = 1
               CALL ERREUR(698)
               SEGDES MRIGID
               GOTO 100
          ENDIF
          DO 10 ISOUS=1,NBSOUS
            IF (LISOUS(ISOUS).NE.IRIGEL(1,ISOUS)) THEN
               MOTERR(1:8)  = 'DARCY   '
               MOTERR(9:16) = 'ELTFA   '
               INTERR(1)    = ISOUS
               CALL ERREUR(698)
               SEGDES MRIGID
               GOTO 100
            ENDIF
 10       CONTINUE
      ENDIF
      CALL LIROBJ('CHPOINT',IPCHC,1,IRET)
      IF(IRET.NE.1) RETURN
      MCHPO1=IPCHC
      NOMTOT(1)='    '
      INDIC=0
      NBCOMP=-1
      CALL QUEPOI(MCHPO1,ICENTR,INDIC,NBCOMP,NOMTOT)
      IF(IERR.NE.0)RETURN
      SEGACT MCHPO1
      MSOUP1=MCHPO1.IPCHP(1)
      SEGACT MSOUP1
      MPOVA1=MSOUP1.IPOVAL
      SEGACT MPOVA1
*                                                                    
* Construction de MCHPOI
*                                                                    
*
      IPT2=IFACE
      SEGACT IPT2
      NPN=IPT2.NUM(/2)
      NSOUPO=1
      NAT=1
      SEGINI MCHPOI
      MTYPOI='        '
      MOCHDE='      CHPOIN CREE PAR BMTD                      '
      IFOPOI=IFOUR
      JATTRI(1)=2
      NC=NBCOMP
      SEGINI MSOUPO
      IPCHP(1)=MSOUPO
      DO 5 L=1,NBCOMP
            NOCOMP(L)=MSOUP1.NOCOMP(L)
            NOHARM(L)=MSOUP1.NOHARM(L)
    5 CONTINUE
      IGEOC=IFACE
      N=NPN
      SEGINI MPOVAL
      IPOVAL=MPOVAL
      NB=N*NC
      CALL INITD(VPOCHA,NB,0.D0)
*
*       Creation du tableau ICPR
*
      IK     = 0
      NNGOT  = XCOOR(/1)/(IDIM+1)
      SEGINI ICCPR
C      MELEME = IFACE
C      SEGACT MELEME
      N2 = IPT2.NUM(/2)
      DO 15 I2=1,N2
         K = IPT2.NUM(1,I2)
         IF (ICPR(K).EQ.0) THEN
            IK      = IK + 1
            ICPR(K) = IK
         ENDIF
  15  CONTINUE
      SEGDES IPT2
C
C     Calcul du produit
C
      ITELEM=0
      MELEME=IELTFA
C     call ecmail(meleme)
      SEGACT MELEME
      IPT1=MELEME
      DO 50 ISOUS=1,NRIGEL
         IF(NRIGEL.NE.1)IPT1= LISOUS(ISOUS)
         SEGACT IPT1
         xMATRI=IRIGEL(4,ISOUS)
         SEGACT xMATRI
         NELRIG=re(/3)
         DO 60 IEL=1,NELRIG
         ITELEM=ITELEM+1
*         XMATRI=IMATTT(IEL)
*         SEGACT XMATRI
         NLIGRD=RE(/1)
         NLIGRP=RE(/2)
         DO 40 I=1,NLIGRD
         RLIGN=0.D0
         DO 30 J=1,NLIGRP
         RLIGN=RLIGN+RE(I,J,iel)
   30    CONTINUE
         IPOPTS=ICPR(IPT1.NUM(I,IEL))
         DO 20 K=1,NBCOMP
              VPOCHA(IPOPTS,K)=VPOCHA(IPOPTS,K)+RLIGN*
     *                   MPOVA1.VPOCHA(ITELEM,K)
   20    CONTINUE

   40    CONTINUE
*         SEGDES XMATRI
   60    CONTINUE
         SEGDES xMATRI
         SEGDES IPT1
   50 CONTINUE
      IF(NRIGEL.NE.1)SEGDES MELEME
      SEGDES MRIGID
       CALL ECROBJ('CHPOINT',MCHPOI)
*
* Ménage
*
      SEGSUP ICCPR
      SEGDES MPOVAL,MSOUPO,MCHPOI
      SEGDES MPOVA1,MSOUP1,MCHPO1
 100  CONTINUE
      RETURN                                                          
      END