Esope source files

   1 : C TDIAG2    SOURCE    CHAT      09/10/09    21:25:17     6519           
   2 :       SUBROUTINE TDIAG2(ITY1,NOMDU1,NOMPR1,IPTMAIL,IPCH1,IPRIGI)
   3 : C
   4 : C**********************************************************************
   5 : C
   6 : C     Subroutine appelée par TDIAG.
   7 : C     Création d'une matrice de couplage dans le cas où les 
   8 : C     supports des inconnues primales et duales sont identiques.
   9 : C
  10 : C  ENTREES :
  11 : C  --------
  12 : C
  13 : C  ITY1    :  Cas MAILLAGE SEG2 couple (Primal,Dual)
  14 : C       = 1 si support inc P&D correspond au maillage de connectivite
  15 : C       = 2 si support inc P&D dans l'ordre different du maillage de 
  16 : C           connectivite
  17 : C  NOMDU1  :  Nom de l'inconnue duale.
  18 : C  NOMPR1  :  Nom de l'inconnue primale.
  19 : C  IPTMAIL :  Pointeur du maillage de connectivite
  20 : C  IPCH1   :  Pointeur sur le champ multiplicateur.
  21 : C
  22 : C  SORTIE :
  23 : C  -------
  24 : C
  25 : C  IPRIGI  :  Pointeur sur la matrice de couplage élémentaire.
  26 : C
  27 : C
  28 : C AUTEUR, DATE DE CREATION:
  29 : C -------------------------
  30 : C
  31 : C     Laurent DADA      décembre 1996
  32 : C
  33 : C AUTEUR, DATE DE MODIFICATION:
  34 : C -----------------------------
  35 : C
  36 : C     Alexandre BLEYER          Novembre 2002
  37 : C     Modifications : - creation des matrices elementaires simplifiee
  38 : C                     - utilisation d'un maillage de connectivite 
  39 : C                       entre l'inc. duale et l'inc. primale
  40 : C
  41 : C LANGAGE:
  42 : C --------
  43 : C
  44 : C     ESOPE + FORTRAN77
  45 : C
  46 : C**********************************************************************
  47 : C
  48 :       IMPLICIT INTEGER(I-N)
  49 :       IMPLICIT REAL*8 (A-H,O-Z)
  50 : C
  51 : -INC CCOPTIO
  52 : -INC CCGEOME
  53 : -INC SMCOORD
  54 : -INC SMCHPOI
  55 : -INC SMELEME
  56 :       POINTEUR IPTMAIL.MELEME,IPTC1.MELEME
  57 : -INC SMRIGID
  58 : C
  59 :       SEGMENT REDI
  60 :         INTEGER IPOS1(NNGOT)
  61 :       ENDSEGMENT
  62 : C
  63 :       CHARACTER*8 TYPE,NOMDU1,NOMPR1
  64 :       LOGICAL LPRIMA,LDUA
  65 : C
  66 : C Récupération du pointeur des valeurs
  67 : C du champ multiplicateur.
  68 : C Remplissage du tableau de redirection
  69 : C
  70 :       NNGOT = XCOOR(/1)/(IDIM+1)
  71 :       SEGINI REDI
  72 : C
  73 :       MCHPOI = IPCH1
  74 :       SEGACT MCHPOI
  75 :       MSOUPO = IPCHP(1)
  76 :       SEGDES MCHPOI
  77 :       SEGACT MSOUPO
  78 :       IPTC1  = IGEOC
  79 :       MPOVAL = IPOVAL
  80 :       SEGACT MPOVAL
  81 :       SEGDES MSOUPO
  82 :       SEGACT IPTC1
  82 :       IF (IPTC1.ITYPEL.NE.1)   CALL CHANGE (IPTC1,1)
  83 :       NBELC1 = IPTC1.NUM(/2)
  84 :       DO 100 I100=1,NBELC1
  85 :         IPOS1(IPTC1.NUM(1,I100)) = I100
  86 : 100    CONTINUE
  87 : C
  88 : C activation du SPG de l'inconnue duale
  89 : C
  90 :       SEGACT IPTMAIL
  91 :       IF (IPTMAIL.ITYPEL.NE.2) THEN
  91 :         CALL ERREUR(16)
  92 :         RETURN
  93 :       ENDIF
  94 :       NBEL1 = IPTMAIL.NUM(/2)
  95 : C
  96 : C Voir si le support du champ multiplicateur est le support
  97 : C de l'inconne duale ou le support de l'inconnue primale
  98 : C
  99 :       I11 = 0
 100 :       I12 = 0
 101 :       DO 10 I10=1,NBELC1
 102 :         IF (IPTC1.NUM(1,I10).EQ.IPTMAIL.NUM(1,1)) I11 = 1
 103 :         IF (IPTC1.NUM(1,I10).EQ.IPTMAIL.NUM(2,1)) I12 = 1
 104 :  10   CONTINUE
 105 :       
 106 :       LPRIMA =.FALSE.
 107 :       LDUA   =.FALSE.
 108 :       IF ((I11.EQ.1).AND.(I12.EQ.0)) THEN
 109 :          LPRIMA=.TRUE.
 110 :       ELSEIF ((I11.EQ.0).AND.(I12.EQ.1)) THEN
 111 :          LDUA=.TRUE.
 112 :       ELSE
 113 :         MOTERR(1:8)  = 'CHPO    '
 113 :         CALL ERREUR (708)
 114 :         RETURN
 115 :       ENDIF
 116 : C
 117 :       SEGDES IPTC1
 118 : C
 119 : C Création de la RIGIDITE
 120 : C
 121 :       NRIGE  = 8
 122 :       NRIGEL = 1
 123 :       SEGINI MRIGID
 124 :       IPRIGI = MRIGID
 125 : C
 126 :       MTYMAT = 'RIGIDITE'
 127 :       IFORIG = IFOMOD
 128 :       ICHOLE = 0
 129 :       IMGEO1 = 0
 130 :       IMGEO2 = 0
 131 :       ISUPEQ = 0
 132 :       COERIG(1)   = 1.D0
 133 :       IRIGEL(1,1) = IPTMAIL
 134 :       IRIGEL(2,1) = 0
 135 :       IRIGEL(5,1) = NIFOUR
 136 :       IRIGEL(6,1) = 0
 137 :       IRIGEL(7,1) = 2
 138 :       IRIGEL(8,1) = 0
 139 : C
 140 : C Remplissage du descripteur de l'objet RIGIDITE
 141 : C
 142 :       NLIGRP = 1
 143 :       NLIGRD = 1
 144 :       SEGINI DESCR
 145 :       IRIGEL(3,1) = DESCR
 146 : C
 147 :         IF (ITY1.EQ.1) THEN
 148 :           NOELEP(1) = 1
 149 :           NOELED(1) = 2
 150 :         ELSEIF (ITY1.EQ.2) THEN
 151 :           NOELEP(1) = 2
 152 :           NOELED(1) = 1
 153 :         ENDIF
 154 :         LISINC(1) = NOMPR1
 155 :         LISDUA(1) = NOMDU1
 156 : C
 157 :       SEGDES DESCR
 158 : C
 159 : C Remplissage des matrices elementaires
 160 : C
 161 :       NELRIG = NBEL1
 162 :       SEGINI xMATRI
 163 :       DO 30 I30=1,NBEL1
 164 : *        SEGINI XMATRI
 165 : *        IMATTT(I30) = XMATRI
 166 :         IF (LPRIMA) NUMPT1 = IPTMAIL.NUM(1,I30)
 167 :         IF (LDUA)   NUMPT1 = IPTMAIL.NUM(2,I30)
 168 :         IF (IPOS1(NUMPT1).NE.0) THEN
 169 :           XVALM1 = VPOCHA(IPOS1(NUMPT1),1)
 170 :         ELSE
 171 :           MOTERR(1:8)  = 'CHPO    '
 171 :           CALL ERREUR(708)
 172 :           RETURN
 173 :         ENDIF
 174 :         RE(1,1,i30) = XVALM1
 175 : *        SEGDES XMATRI
 176 : 30    CONTINUE
 177 : 
 178 :       IRIGEL(4,1) = xMATRI
 179 :       SEGDES xMATRI
 180 : C
 181 :       SEGDES IPTMAIL
 182 :       SEGDES MPOVAL
 183 :       SEGDES MRIGID
 184 :       SEGSUP REDI
 185 : C
 186 :       END
 187 :           
 188 :  
 189 :