Sources Esope | Cast3M

dmtd
C DMTD      SOURCE    CB215821  24/04/12    21:15:37     11897          
      SUBROUTINE DMTD
C-----------------------------------------------------------------------
C                               -1 t
C  Calcul du CHPOIN scalaire D M    D
C       Somme des termes de chaque matrice elementaire pour former
C  un chpoin dont le support géométrique est le maillage TADOM.CENTRE
C-----------------------------------------------------------------------
C
C---------------------------
C Phrase d'appel (GIBIANE) :
C---------------------------
C
C  CHP1 = 'DMTD'  MMODEL RIG1  ;
C
C------------------------
C Operandes et resultat :
C------------------------
C
C  MMODEL  : MODELE DARCY.
C  RIG1    : Matrices hybrides elementaires de DARCY crees par MHYB.
C  CHP1    : CHPO centre de composante SCAL  coef par élément.
C
C-----------------------------------------------------------------------
C
C Langage : ESOPE + FORTRAN77
C
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMRIGID
-INC SMTABLE
-INC SMMODEL
*
      LOGICAL LOGRE,LOGIN
      CHARACTER*8 TAPIND,TYPOBJ,CHARRE,LETYPE
*
* 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
C  on récupère la table DOMAINE à partir du modèle
C
      IPTABL = 0
      CALL LEKMOD(MMODEL,IPTABL,IRET)
      IF (IERR.NE.0) RETURN
      TYPOBJ = 'MAILLAGE'
      CALL LEKTAB(IPTABL,'ELTFA',IOBRE)
      IF (IERR.NE.0) RETURN
      IELTFA = IOBRE
      CALL LEKTAB(IPTABL,'CENTRE',IOBRE)
      IF (IERR.NE.0) RETURN
      ICENTR = 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
*
* Construction de MCHPOI
*
*
      IPT1=ICENTR
      SEGACT IPT1
      NPN=IPT1.NUM(/2)
      NSOUPO=1
      NAT=1
      SEGINI MCHPOI
      MTYPOI='        '
      MOCHDE='      CHPOIN CREE PAR DMTD                      '
      IFOPOI=IFOUR
      JATTRI(1)=2
      NC=1
      SEGINI MSOUPO
      IPCHP(1)=MSOUPO
      NOCOMP(1)='SCAL'
      NOHARM(1)=0
      IGEOC=ICENTR
      N=NPN
      SEGINI MPOVAL
      IPOVAL=MPOVAL
      NB=N
      CALL INITD(VPOCHA,NB,0.D0)
C
C     Calcul de la somme par element
C
      ITELEM=0
      DO 50 ISOUS=1,NRIGEL
         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)
         CONSD=0.D0
         DO 40 J=1,NLIGRP
         DO 30 I=1,NLIGRD
         CONSD=CONSD+RE(I,J,iel)
   30    CONTINUE
   40    CONTINUE
         VPOCHA(ITELEM,1)=CONSD
*         SEGDES XMATRI
   60    CONTINUE
         SEGDES xMATRI
   50 CONTINUE
      SEGDES MRIGID
       CALL ECROBJ('CHPOINT',MCHPOI)
*
* Ménage
*
      SEGDES MPOVAL,MSOUPO,MCHPOI
 100  CONTINUE
      RETURN
      END