Télécharger towa.eso

Retour à la liste

towa
C TOWA      SOURCE    FANDEUR   22/01/03    21:15:52     11237          
      SUBROUTINE TOWA (IPTAB1)
C
C***********************************************************************
C
C
C FONCTION:
C ---------
C
C   en "1D/0D" sur des éléments de type POINT.
C
C
C ENTREE :
C ----------
C
C   IPTAB1          : Pointeur sur la TABLE de soustype 'OPER_0D'
C                     contenant les indices suivants :
C
C   TAB1 . 'GEOINF' : TABLE des informations géométriques de soustype
C                     'GEOINF' (type ENTIER).
C   TAB1 . 'INCO'   : TABLE de soustype 'INCO' contenant l'ensemble
C                     des champs à l'itération précédant l'itération
C                     courante (type ENTIER).
C   TAB1 . 'DUAL'   : Nom de l'inconnue duale (doit être un indice de
C                     la table de soustype 'INCO' et de support
C                     'WALL') (type MOT).
C   TAB1 . 'PRIMAL' : Nom de l'inconnue duale (doit être un indice de
C                     la table de soustype 'INCO' et de support
C                     'WALL') (type MOT).
C   TAB1 . 'DT'     : Pas de temps (type FLOTTANT ou MOT).
C   TAB1 . 'CP'     : Chaleurs spécifiques des murs
C                     (type CHPO, de support 'WALL', à 2 composantes)
C   TAB1 . 'RHO'    : Masses volumiques des murs
C                     (type CHPO, de support 'WALL', à 2 composantes)
C   TAB1 . 'LBD'    : Conductivités thermiques spécifiques des murs
C                     (type CHPO, de support 'WALL', à 2 composantes)
C   TAB1 . 'THICK'  : Epaisseurs des murs
C                     (type CHPO, de support 'WALL', à 2 composantes)
C
C RESULTATS:
C ---------
C
C   TAB1 . 'LHS' : Matrice élémentaire (union des matrices
C                  élémentaires associées à l'opération
C                  type RIGIDITE).
C   TAB1 . 'RHS' : Second membre associé à l'opération
C                  (type CHPO partitionné).
C
C
C AUTEUR, DATE DE CREATION:
C -------------------------
C
C     Laurent DADA      décembre 1996
C
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 SMTABLE
      POINTEUR IPTAB1.MTABLE,IPTAB2.MTABLE,IPTABG.MTABLE
      POINTEUR IPTABS.MTABLE,IPTABI.MTABLE
-INC SMCHPOI
      POINTEUR MPOVC1.MPOVAL,MPOVR1.MPOVAL,MPOVD1.MPOVAL
      POINTEUR MPOVL1.MPOVAL,MPOVT1.MPOVAL,MPOVQ1.MPOVAL
-INC SMELEME
      POINTEUR IPCEN.MELEME,IPINW.MELEME
-INC SMRIGID
-INC SMLMOTS
C
C Tableaux des correspondances entre les numéros des points et
C leurs positions dans les MELEME des champs
C
      SEGMENT REDIR
        INTEGER IPOSC1(NNGOT)
        INTEGER IPOSR1(NNGOT)
        INTEGER IPOSL1(NNGOT)
        INTEGER IPOST1(NNGOT)
        INTEGER IPOSQ1(NNGOT)
        INTEGER IPOSD1(NNGOT)
      ENDSEGMENT
C
C Tableaux des positions des noms de composantes "gauches et droites"
C pour les champs de propriétés matérielles
C
      SEGMENT NOCOPO
        INTEGER NOCOC1(2)
        INTEGER NOCOR1(2)
        INTEGER NOCOL1(2)
        INTEGER NOCOT1(2)
      ENDSEGMENT
C
C
      CHARACTER*8 TYPE,MOTI,MOT1,NOMPR1,NOMDU1,NOSUD1,NOMDT1
      CHARACTER*8 NOMP1,NOMP2,NOMPR2,NOSUP2,NOMFL1,NOSUF1
      CHARACTER*8 MTYPI,MTYPR,CHARI,CHARR
      LOGICAL     LOGII,LOGIR
C
C
C Lecture de la table GEOINF de la table OPER_0D
C
      TYPE = 'TABLE   '
      CALL ACMO (IPTAB1,'GEOINF',TYPE,IPTABG)
      IF (IERR.NE.0) RETURN
C
      MOTI = 'SOUSTYPE'
      CALL ACMM (IPTABG,MOTI,MOT1)
      IF (IERR.NE.0) RETURN
      IF (MOT1(1:6).NE.'GEOINF') THEN
        MOTERR(1:8) = 'GEOINF  '
        CALL ERREUR (-173)
        RETURN
      ENDIF
C
C Lecture de la table INCO dans la table OPER_0D
C
      TYPE = 'TABLE   '
      CALL ACMO (IPTAB1,'INCO',TYPE,IPTAB2)
      IF (IERR.NE.0) RETURN
C
      MOTI = 'SOUSTYPE'
      CALL ACMM (IPTAB2,MOTI,MOT1)
      IF (IERR.NE.0) RETURN
      IF (MOT1(1:4).NE.'INCO') THEN
        MOTERR(1:8) = 'INCO    '
        CALL ERREUR (-173)
        RETURN
      ENDIF
C
C Lecture de la table SUPPORT dans la table INCO
C
C      TYPE = 'TABLE   '
C      CALL ACMO (IPTAB2,'SUPPORT',TYPE,IPTABS)
C      IF (IERR.NE.0) RETURN
C
C Lecture de l'inconnue DUALE
C
      TYPE = '        '
      CALL ACMO (IPTAB1,'DUAL',TYPE,IDU1)
      IF (TYPE.EQ.'MOT     ') THEN
        CALL ACMM (IPTAB1,'DUAL',NOMDU1)
        IF (IERR.NE.0) RETURN
      ENDIF
C
C Lecture du nom du support de l'inconnue duale
C
C      TYPE = '        '
C      CALL ACMO (IPTABS,NOMDU1,TYPE,ISUD1)
C      IF (TYPE.EQ.'MOT     ') THEN
C        CALL ACMM (IPTABS,NOMDU1,NOSUD1)
C        IF (IERR.NE.0) RETURN
C      ENDIF
C
C Contrôle du support de l'inconnue duale
C
C      IF (NOSUD1.NE.'WALL') THEN
C        MOTERR(1:8)  = 'DUAL    '
C        MOTERR(9:16) = 'CHPOINT '
C        CALL ERREUR (788)
C        RETURN
C      ENDIF
C
C Lecture de l'inconnue primale
C
      TYPE = '        '
      CALL ACMO (IPTAB1,'PRIMAL',TYPE,IPR1)
      IF (TYPE.EQ.'MOT     ') THEN
        CALL ACMM (IPTAB1,'PRIMAL',NOMPR1)
        IF (IERR.NE.0) RETURN
        IF (NOMPR1.NE.NOMDU1) THEN
          MOTERR(1:8)  = 'PRIMAL  '
          MOTERR(9:16) = NOMPR1
          CALL ERREUR (787)
          RETURN
        ENDIF
      ENDIF
C
C Lecture du pas de temps
C
      TYPE = '        '
      CALL ACMO (IPTAB1,'DT',TYPE,IPR1)
      IF (IERR.NE.0) RETURN
      IF (TYPE.EQ.'MOT     ') THEN
        CALL ACMM (IPTAB1,'DT',NOMDT1)
        IF (IERR.NE.0) RETURN
C récupération du pas de temps dans la table INCO
        CALL ACMF (IPTAB2,NOMDT1,XDT1)
        IF (IERR.NE.0) RETURN
      ELSEIF (TYPE.EQ.'FLOTTANT') THEN
        CALL ACMF (IPTAB1,'DT',XDT1)
        IF (IERR.NE.0) RETURN
      ELSE
        MOTERR(1:8)  = 'DT      '
        MOTERR(9:16) = TYPE
        CALL ERREUR (787)
        RETURN
      ENDIF
C
C
C Récupération des propriétés matérielles des murs
C Récupération des segments MPOVAL des champs
C Initialisation des tableaux des correspondances
C Initialisation des tableaux des positions des noms des composantes
C
      NNGOT = nbpts
      SEGINI REDIR
      SEGINI NOCOPO
C
C Les chaleurs spécifiques
C
      TYPE = 'CHPOINT '
      CALL ACMO (IPTAB1,'CP',TYPE,MCHPO1)
      IF (IERR.NE.0) RETURN
      SEGACT MCHPO1
      MSOUPO = MCHPO1.IPCHP(1)
      SEGDES MCHPO1
      SEGACT MSOUPO
      NC1 = NOCOMP(/2)
      IF (NC1.NE.2) THEN
        MOTERR(1:8)  = 'CP      '
        MOTERR(9:16) = 'CHPOINT '
        CALL ERREUR (784)
        RETURN
      ENDIF
      IF ((NOCOMP(1).EQ.'1CW').AND.(NOCOMP(2).EQ.'2CW')) THEN
        NOCOC1(1) = 1
        NOCOC1(2) = 2
      ELSEIF ((NOCOMP(2).EQ.'1CW').AND.(NOCOMP(1).EQ.'2CW')) THEN
        NOCOC1(1) = 2
        NOCOC1(2) = 1
      ELSE
        MOTERR(1:8)  = 'CP      '
        MOTERR(9:16) = 'composan'
        CALL ERREUR (787)
        RETURN
      ENDIF
      MPOVC1 = IPOVAL
      IPT1   = IGEOC
      SEGDES MSOUPO
C
      SEGACT IPT1
      NBEL1 = IPT1.NUM(/2)
      DO 100 I100=1,NBEL1
        IPOSC1(IPT1.NUM(1,I100)) = I100
100   CONTINUE
      SEGDES IPT1
C
C Les masses volumiques
C
      TYPE = 'CHPOINT '
      CALL ACMO (IPTAB1,'RHO',TYPE,MCHPO1)
      IF (IERR.NE.0) RETURN
      SEGACT MCHPO1
      MSOUPO = MCHPO1.IPCHP(1)
      SEGDES MCHPO1
      SEGACT MSOUPO
      NC1 = NOCOMP(/2)
      IF (NC1.NE.2) THEN
        MOTERR(1:8)  = 'RHO     '
        MOTERR(9:16) = 'CHPOINT '
        CALL ERREUR (784)
        RETURN
      ENDIF
      IF ((NOCOMP(1).EQ.'1RW').AND.(NOCOMP(2).EQ.'2RW')) THEN
        NOCOR1(1) = 1
        NOCOR1(2) = 2
      ELSEIF ((NOCOMP(2).EQ.'1RW').AND.(NOCOMP(1).EQ.'2RW')) THEN
        NOCOR1(1) = 2
        NOCOR1(2) = 1
      ELSE
        MOTERR(1:8)  = 'RHO     '
        MOTERR(9:16) = 'composan'
        CALL ERREUR (787)
        RETURN
      ENDIF
      MPOVR1 = IPOVAL
      IPT1   = IGEOC
      SEGDES MSOUPO
C
      SEGACT IPT1
      NBEL1 = IPT1.NUM(/2)
      DO 200 I200=1,NBEL1
        IPOSR1(IPT1.NUM(1,I200)) = I200
200   CONTINUE
      SEGDES IPT1
C
C Les conductivités thermiques
C
      TYPE = 'CHPOINT '
      CALL ACMO (IPTAB1,'LBD',TYPE,MCHPO1)
      IF (IERR.NE.0) RETURN
      SEGACT MCHPO1
      MSOUPO = MCHPO1.IPCHP(1)
      SEGDES MCHPO1
      SEGACT MSOUPO
      NC1 = NOCOMP(/2)
      IF (NC1.NE.2) THEN
        MOTERR(1:8)  = 'LBD     '
        MOTERR(9:16) = 'CHPOINT '
        CALL ERREUR (784)
        RETURN
      ENDIF
      IF ((NOCOMP(1).EQ.'1LW').AND.(NOCOMP(2).EQ.'2LW')) THEN
        NOCOL1(1) = 1
        NOCOL1(2) = 2
      ELSEIF ((NOCOMP(2).EQ.'1LW').AND.(NOCOMP(1).EQ.'2LW')) THEN
        NOCOL1(1) = 2
        NOCOL1(2) = 1
      ELSE
        MOTERR(1:8)  = 'LBD     '
        MOTERR(9:16) = 'composan'
        CALL ERREUR (787)
        RETURN
      ENDIF
      MPOVL1 = IPOVAL
      IPT1   = IGEOC
      SEGDES MSOUPO
C
      SEGACT IPT1
      NBEL1 = IPT1.NUM(/2)
      DO 300 I300=1,NBEL1
        IPOSL1(IPT1.NUM(1,I300)) = I300
300   CONTINUE
      SEGDES IPT1
C
C Les épaisseurs
C
      TYPE = 'CHPOINT '
      CALL ACMO (IPTAB1,'THICK',TYPE,MCHPO1)
      IF (IERR.NE.0) RETURN
      SEGACT MCHPO1
      MSOUPO = MCHPO1.IPCHP(1)
      SEGDES MCHPO1
      SEGACT MSOUPO
      NC1 = NOCOMP(/2)
      IF (NC1.NE.2) THEN
        MOTERR(1:8)  = 'THICK   '
        MOTERR(9:16) = 'CHPOINT '
        CALL ERREUR (784)
        RETURN
      ENDIF
      IF ((NOCOMP(1).EQ.'1TW').AND.(NOCOMP(2).EQ.'2TW')) THEN
        NOCOT1(1) = 1
        NOCOT1(2) = 2
      ELSEIF ((NOCOMP(2).EQ.'1TW').AND.(NOCOMP(1).EQ.'2TW')) THEN
        NOCOT1(1) = 2
        NOCOT1(2) = 1
      ELSE
        MOTERR(1:8)  = 'THICK   '
        MOTERR(9:16) = 'composan'
        CALL ERREUR (787)
        RETURN
      ENDIF
      MPOVT1 = IPOVAL
      IPT1   = IGEOC
      SEGDES MSOUPO
C
      SEGACT IPT1
      NBEL1 = IPT1.NUM(/2)
      DO 400 I400=1,NBEL1
        IPOST1(IPT1.NUM(1,I400)) = I400
400   CONTINUE
      SEGDES IPT1
C
C Récupération des valeurs de l'inconnue duale à l'itération
C précédente
C
      TYPE = 'CHPOINT '
      CALL ACMO (IPTAB2,NOMDU1,TYPE,IPCHD1)
      IF (IERR.NE.0) RETURN
      CALL LICHT (IPCHD1,MPOVD1,TYPE,IPT1)
      SEGACT IPT1
      NBEL1 = IPT1.NUM(/2)
      DO 500 I500=1,NBEL1
        IPOSD1(IPT1.NUM(1,I500)) = I500
500   CONTINUE
      SEGDES IPT1
      SEGDES MPOVD1
C
C Récupération du MAILLAGE de POI1 localisant les centres des murs
C
      TYPE = 'MAILLAGE'
      CALL ACMO (IPTABG,'CENTRW',TYPE,IPCEN)
      IF (IERR.NE.0) RETURN
      SEGACT IPCEN
      IF ((IPCEN.ITYPEL).NE.1) THEN
        MOTERR(1:8)  = 'CENTRW  '
        MOTERR(9:16) = 'non POI1'
        CALL ERREUR (787)
        SEGDES IPCEN
        RETURN
      ENDIF
C
C Récupération de la TABLE des correspondances
C                  centres des murs -> points des murs
C
      TYPE = 'TABLE   '
      CALL ACMO (IPTABG,'INWALL',TYPE,IPTABI)
      IF (IERR.NE.0) RETURN
C
C Création de la RIGIDITE
C
      NBELC1 = IPCEN.NUM(/2)
C
      NRIGE  = 7
      NRIGEL = NBELC1
      SEGINI MRIGID
      MTYMAT = 'RIGIDITE'
      IFORIG = IFOUR
      ICHOLE = 0
      IMGEO1 = 0
      IMGEO2 = 0
      ISUPEQ = 0
C
C
C Création des matrices élémentaires
C et des seconds membres
C
C
      SEGDES REDIR
      SEGDES NOCOPO
C
      MTYPI = 'POINT   '
      MTYPR = 'MAILLAGE'
      DO 10 I10=1,NBELC1
        NUM1 = IPCEN.NUM(1,I10)
C Récupération du MAILLAGE de POI1, support des points du mur
C associé au point centre NUM1
        CALL ACCTAB (IPTABI,MTYPI,IVALI,XVARI,CHARI,LOGII,NUM1,
     &               MTYPR,IVALR,XVALR,CHARR,LOGIR,IRETR)
        IF (IERR.NE.0) RETURN
        IPINW = IRETR
        SEGACT IPINW
        IF ((IPINW.ITYPEL).NE.1) THEN
          MOTERR(1:8)  = 'INWALL  '
          MOTERR(9:16) = 'non POI1'
          CALL ERREUR (787)
          SEGDES IPINW
          RETURN
        ENDIF
C
C Transformation du maillage de POI1
C en un maillage de type SUPER-ELEMENT pour la RIGIDITE
C
        NBNN   = IPINW.NUM(/2)
        NBSOUS = 0
        NBREF  = 0
        NBELEM = 1
        SEGINI MELEME
        ICOLOR(1) = IDCOUL
        ITYPEL    = 28
        DO 11 I11=1,NBNN
          NUM(I11,1) = IPINW.NUM(1,I11)
 11     CONTINUE
        SEGDES IPINW
        SEGDES MELEME
C
        COERIG(I10)   = 1.D0
        IRIGEL(1,I10) = MELEME
        IRIGEL(2,I10) = 0
        IRIGEL(5,I10) = NIFOUR
        IRIGEL(6,I10) = 0
        IRIGEL(7,I10) = 2
C création de la matrice élémentaire et du second membre
        CALL TOWA1 (REDIR,NOCOPO,NOMDU1,IPINW,NOMPR1,
     &              MPOVD1,MPOVC1,MPOVR1,MPOVL1,MPOVT1,
     &              XDT1,DESCR,xMATRI,MCHPO1)
C
        IRIGEL(3,I10) = DESCR
        IRIGEL(4,I10) = xMATRI
C
        SEGACT MCHPO1*MOD
        MCHPO1.JATTRI(1) = 2
        SEGDES MCHPO1
C
        IF (I10.EQ.1) THEN
          MCHPOI = MCHPO1
        ELSE
          CALL FUCHPO (MCHPOI,MCHPO1,IRET1)
          MCHPOI = IRET1
        ENDIF
C
 10   CONTINUE
C
      SEGDES MRIGID
      SEGDES IPCEN
      SEGSUP REDIR
      SEGSUP NOCOPO
C
C Remplissage de la table
C
      TYPE = 'RIGIDITE'
      CALL ECMO (IPTAB1,'LHS',TYPE,MRIGID)
      IF (IERR.NE.0) RETURN
      TYPE = 'CHPOINT '
      CALL ECMO (IPTAB1,'RHS',TYPE,MCHPOI)
      IF (IERR.NE.0) RETURN
C
      END
 
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales