1 : C ZECHI1 SOURCE PV 09/03/12 21:38:46 6325 2 : SUBROUTINE ZECHI1(IKAS,IVOL1,MTAB1,MTAB2,MPOVA1,MPOVA2,IKH,IKT, 3 : & MELEMD,MELEVF,MLENTI,MLENT1,NOMD) 4 : C----------------------------------------------------------------------- 5 : C Discrétisation de l'opérateur ECHIMP en explicite EFM1 et VF, le 6 : C coeff d'échange étant un SCAL ou CHPO CENTRE, le champ exterieur 7 : C un SCAL, un CHPO CENTRE ou un CHPO SOMMET. 8 : C----------------------------------------------------------------------- 9 : C 10 : C-------------------- 11 : C Paramètres Entrée : 12 : C-------------------- 13 : C 14 : C E/ IKAS : Type de situation à traiter (1=EF, 2 ou 3=VF) 15 : C E/ IVOL1 : Type d'échange (0=surfacique, 1=volumique) 16 : C E/ MTAB1 : Pointeur de la table EQEX 17 : C E/ MTAB2 : Pointeur de la table DOMAINE locale 18 : C E/ MPOVA1 : MPOVAL des valeurs du coefficient d'échange 19 : C E/ MPOVA2 : MPOVAL des valeurs du champ exterieur 20 : C E/ IKH : Forme originel du coefficient d'échange 21 : C (0=CHPO CENTRE, 1=FLOTTANT) 22 : C E/ IKT : Forme originel du champ exterieur 23 : C (0=CHPO CENTRE, 1=FLOTTANT, 4=CHPO SOMMET) 24 : C E/ MELEMD : Pointeur du spg de l'inconnue 25 : C E/ MELEVF : Pointeur vers les points CENTRE du maillage volumique 26 : C en correspondance avec les points CENTRE surfacique 27 : C (Utilisé en Formulation VF et échange surfacique) 28 : C E/ MLENTI : Correspondance numéotation globale/numérotation locale 29 : C LECT(I)=J : le point numéro I est le Jième de MELEMD 30 : C E/ MLENT1 : Idem MLENTI pour le spg du champ exterieur 31 : C (Utilisé lorsque le champ exterieur est au SOMMET) 32 : C E/ NOMD : Nom de l'inconnue 33 : C 34 : C------------------ 35 : C Champs calculés : 36 : C------------------ 37 : C 38 : C MPOVA3 : MPOVAL des valeurs de la matrice diagonale 39 : C Stocké à l'indice NOMD de la table KIZG1 40 : C MPOVA4 : MPOVAL des valeurs du second membre 41 : C Stocké à l'indice NOMD de la table KIZG 42 : C 43 : C----------------------------------------------------------------------- 44 : IMPLICIT INTEGER(I-N) 45 : IMPLICIT REAL*8 (A-H,O-Z) 46 : C 47 : -INC CCOPTIO 48 : -INC SMCHPOI 49 : -INC SMCHAML 50 : -INC SMELEME 51 : -INC SMLENTI 52 : C 53 : CHARACTER*8 NOMD,TYPE,TYPC,TYPS 54 : C 55 : C- Initialisations 56 : C 57 : NBCOMP = 1 58 : IF (IKAS.EQ.1) THEN 59 : TYPS = 'SOMMET ' 60 : ELSE 61 : TYPS = 'CENTRE ' 62 : ENDIF 63 : C 64 : C- Récup/Création des tables KIZG (pointeur KIZG) et KIZG1 (KIZG1) 65 : C 65 : CALL LEKTAB(MTAB1,'KIZG',KIZG) 66 : IF (KIZG.EQ.0) THEN 66 : CALL CRTABL(KIZG) 66 : CALL ECMM(KIZG,'SOUSTYPE','KIZG') 66 : CALL ECMO(MTAB1,'KIZG','TABLE ',KIZG) 67 : ENDIF 67 : CALL LEKTAB(MTAB1,'KIZG1',KIZG1) 68 : IF (KIZG1.EQ.0) THEN 68 : CALL CRTABL(KIZG1) 68 : CALL ECMM(KIZG1,'SOUSTYPE','KIZG1') 68 : CALL ECMO(MTAB1,'KIZG1','TABLE ',KIZG1) 69 : ENDIF 70 : C 71 : C- Récup/Création des CHPO stockés dans les tables KIZG et KIZG1 à 72 : C- l'indice mot NOMD (nom de l'inconnue) 73 : C 74 : TYPE = ' ' 74 : CALL ACMO(KIZG1,NOMD,TYPE,IZG1) 75 : IF (TYPE.NE.'CHPOINT ') THEN 75 : CALL CRCHPT(TYPS,MELEMD,NBCOMP,IZG1) 75 : CALL ECMO(KIZG1,NOMD,'CHPOINT ',IZG1) 76 : ENDIF 76 : CALL LICHT(IZG1,MPOVA3,TYPC,IGEOM) 77 : IF (IGEOM.NE.MELEMD) THEN 78 : C Les champs par point ont des supports géométriques incompatibles 78 : CALL ERREUR(348) 79 : RETURN 80 : ENDIF 81 : C 82 : TYPE = ' ' 82 : CALL ACMO(KIZG,NOMD,TYPE,IZG) 83 : IF (TYPE.NE.'CHPOINT ') THEN 83 : CALL CRCHPT(TYPS,MELEMD,NBCOMP,IZG) 83 : CALL ECMO(KIZG,NOMD,'CHPOINT ',IZG) 84 : ENDIF 84 : CALL LICHT(IZG,MPOVA4,TYPC,IGEOM) 85 : IF (IGEOM.NE.MELEMD) THEN 86 : C Les champs par point ont des supports géométriques incompatibles 86 : CALL ERREUR(348) 87 : RETURN 88 : ENDIF 89 : C 90 : C- Activation 91 : C 92 : SEGACT MPOVA1 93 : SEGACT MPOVA2 94 : SEGACT MLENTI 95 : SEGACT MLENT1 96 : C 97 : C---------------------------------------------------------------------- 98 : C- Traitement d'une formulation EF ou EMM1 explicite, le champ 99 : C- exterieur étant 1) un SCAL ou un CHPO CENTRE, 2) un CHPO SOMMET. 100 : C- Dans les deux cas, l'indice XXPSOML de la table domaine local suffit 101 : C- (contient l'intégrale sur chaque élément des fonctions de forme). 102 : C- En effet, en explicite les matrices masses sont condensées (EF=EFM1) 103 : C---------------------------------------------------------------------- 104 : C 105 : IF (IKAS.EQ.1) THEN 105 : CALL LEKTAB(MTAB2,'MAILLAGE',MELEME) 105 : CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM) 106 : IF (IERR.NE.0) RETURN 107 : SEGACT MCHELM 108 : SEGACT MELEME 109 : NBSOUS = LISOUS(/1) 110 : IF (NBSOUS.EQ.0) NBSOUS=1 111 : NUTOEL = 0 112 : DO 30 L=1,NBSOUS 113 : IPT1 = MELEME 114 : IF (NBSOUS.NE.1) IPT1=LISOUS(L) 115 : SEGACT IPT1 116 : NP = IPT1.NUM(/1) 117 : NBEL = IPT1.NUM(/2) 118 : MCHAML = ICHAML(L) 119 : SEGACT MCHAML 120 : MELVAL = IELVAL(1) 121 : SEGACT MELVAL 122 : DO 20 K=1,NBEL 123 : NK = NUTOEL + K 124 : KPOS = 1 + (1-IKH)*(NK-1) 125 : DO 10 I=1,NP 126 : II = IPT1.NUM(I,K) 127 : IPOS = LECT(II) 128 : VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K) 129 : MPOVA3.VPOCHA(IPOS,1) = MPOVA3.VPOCHA(IPOS,1) + VAL1 130 : IF (IKT.EQ.4) THEN 131 : JPOS = MLENT1.LECT(II) 132 : ELSE 133 : JPOS = 1 + (1-IKT)*(NK-1) 134 : ENDIF 135 : VAL2 = VAL1 * MPOVA2.VPOCHA(JPOS,1) 136 : MPOVA4.VPOCHA(IPOS,1) = MPOVA4.VPOCHA(IPOS,1) - VAL2 137 : 10 CONTINUE 138 : 20 CONTINUE 139 : SEGDES IPT1 140 : SEGDES MCHAML,MELVAL 141 : NUTOEL = NUTOEL + NBEL 142 : 30 CONTINUE 143 : IF (NBSOUS.NE.1) SEGDES MELEME 144 : SEGDES MCHELM 145 : C 146 : C---------------------------------------------------------------------- 147 : C- Traitement d'une formulation VF Explicite, le champ exterieur étant 148 : C- 1) un SCAL ou un CHPO CENTRE, 2) un CHPO SOMMET. 149 : C- 150 : C- Le traitement différe pour le second membre : 151 : C- Dans le premier cas, l'indice XXVOLUM de la table domaine local, 152 : C- utilisé pour calculer la matrice suffit (contient le volume de 153 : C- chaque élément). Dans le deuxième cas, on a également besoin de 154 : C- l'indice XXPSOML que l'on sature par le champ exterieur au sommet. 155 : C- 156 : C- Le spg des champoints résultats dépend du type d'échange : 157 : C- Lorsque l'échange est volumique, les points CENTRE de la table 158 : C- domaine local sont à considerer. En surfacique, on a construit 159 : C- la correspondance entre centre(volume)-centre(surface); les CENTRE 160 : C- des volumes concernés sont rangés dans MELEVF. 161 : C---------------------------------------------------------------------- 162 : C 163 : ELSE 163 : CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPOI) 163 : CALL LICHT(MCHPOI,MPOVA5,TYPC,MELEMC) 164 : IF (IVOL1.EQ.0) THEN 165 : IPT2 = MELEVF 166 : ELSE 167 : IPT2 = MELEMC 168 : ENDIF 169 : SEGACT IPT2 170 : IF (IKT.EQ.0 .OR. IKT.EQ.1) THEN 171 : NBEL = IPT2.NUM(/2) 172 : DO 40 K=1,NBEL 173 : IPOS = LECT(IPT2.NUM(1,K)) 174 : KPOS = 1 + (1-IKH)*(K-1) 175 : KTEX = 1 + (1-IKT)*(K-1) 176 : VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA5.VPOCHA(K,1) 177 : MPOVA3.VPOCHA(IPOS,1) = MPOVA3.VPOCHA(IPOS,1) + VAL1 178 : VAL2 = MPOVA2.VPOCHA(KTEX,1) * VAL1 179 : MPOVA4.VPOCHA(IPOS,1) = MPOVA4.VPOCHA(IPOS,1) - VAL2 180 : 40 CONTINUE 181 : ELSE 181 : CALL LEKTAB(MTAB2,'MAILLAGE',MELEME) 181 : CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM) 182 : IF (IERR.NE.0) RETURN 183 : SEGACT MCHELM 184 : SEGACT MELEME 185 : NBSOUS = LISOUS(/1) 186 : IF (NBSOUS.EQ.0) NBSOUS=1 187 : NUTOEL = 0 188 : DO 70 L=1,NBSOUS 189 : IPT1 = MELEME 190 : IF (NBSOUS.NE.1) IPT1=LISOUS(L) 191 : SEGACT IPT1 192 : NP = IPT1.NUM(/1) 193 : NBEL = IPT1.NUM(/2) 194 : MCHAML = ICHAML(L) 195 : SEGACT MCHAML 196 : MELVAL = IELVAL(1) 197 : SEGACT MELVAL 198 : DO 60 K=1,NBEL 199 : NK = NUTOEL + K 200 : IPOS = LECT(IPT2.NUM(1,NK)) 201 : KPOS = 1 + (1-IKH)*(NK-1) 202 : VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA5.VPOCHA(NK,1) 203 : MPOVA3.VPOCHA(IPOS,1) = MPOVA3.VPOCHA(IPOS,1) + VAL1 204 : VAL2 = 0.D0 205 : DO 50 I=1,NP 206 : II = IPT1.NUM(I,K) 207 : JPOS = MLENT1.LECT(II) 208 : VAL2 = VAL2 + MPOVA1.VPOCHA(KPOS,1) 209 : & * MPOVA2.VPOCHA(JPOS,1) * VELCHE(I,K) 210 : 50 CONTINUE 211 : MPOVA4.VPOCHA(IPOS,1) = MPOVA4.VPOCHA(IPOS,1) - VAL2 212 : 60 CONTINUE 213 : NUTOEL = NUTOEL + NBEL 214 : SEGDES IPT1 215 : SEGDES MELVAL,MCHAML 216 : 70 CONTINUE 217 : IF (NBSOUS.NE.1) SEGDES MELEME 218 : SEGDES MCHELM 219 : ENDIF 220 : SEGDES IPT2 221 : SEGDES MPOVA5 222 : ENDIF 223 : C 224 : C- Désactivation 225 : C 226 : SEGDES MPOVA1 227 : SEGDES MPOVA2 228 : SEGDES MPOVA3 229 : SEGDES MPOVA4 230 : SEGSUP MLENTI 231 : SEGSUP MLENT1 232 : RETURN 233 : END 234 : 235 : 236 : 237 : 238 :
© Cast3M 2003 - All rights reserved.
Disclaimer