1 : C YFIMP SOURCE MAGN 10/05/18 21:16:59 6675 2 : SUBROUTINE YFIMP 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C*********************************************************************** 6 : C 7 : C SYNTAXE : 8 : C 9 : C I) 10 : C 11 : C FIMP coef 12 : C / / 13 : C On calcule | W S do = | Ma NbSb do 14 : C / / 15 : C EN 2D 16 : C elements SEG2 -> Flux 17 : C elements TRI3 -> Source volumique 18 : C elements QUA4 -> Source volumique 19 : C EN 3D 20 : C elements SEG2 -> Pas de sens !! 21 : C elements TRI3 -> Flux 22 : C elements QUA4 -> Flux 23 : C elements CUB8 -> Source volumique 24 : C elements PRI6 -> Source volumique 25 : C elements TET4 -> Source volumique 26 : C 27 : C 28 : C MTAB1 : Table type EQEX -> RV 29 : C MTABZ : Table type DOMAINE -> Zone definition opérateur 30 : C MTABD : Table type DOMAINE -> Zone Totale apres assemblage 31 : C MTABX : Table type KIZX -> Description opérateur 32 : C 33 : C 34 : C II) Source term into the Euler/Navier Stokes equations 35 : C (FV formulation) (see fimpvf.eso) 36 : C 37 : C 38 : C*********************************************************************** 39 : 40 : -INC CCOPTIO 41 : -INC CCREEL 42 : -INC CCGEOME 43 : -INC SMCHAML 44 : -INC SMCOORD 45 : -INC SMLENTI 46 : -INC SMELEME 47 : POINTEUR MELEM1.MELEME,SPGID.MELEME,SPGZ.MELEME 48 : POINTEUR MELEMD.MELEME,SPGD.MELEME 49 : -INC SMCHPOI 50 : POINTEUR IZG1.MCHPOI, IZGG1.MPOVAL 51 : POINTEUR IZTU1.MPOVAL 52 : POINTEUR MZFLU.MPOVAL 53 : -INC SMMATRIK 54 : -INC SIZFFB 55 : POINTEUR IZF1.IZFFM,IZH2.IZHR,IZW.IZFFM,IZWH.IZHR 56 : SEGMENT SAJT 57 : REAL*8 AJT(IDIM,IDIM,NPG),RF1(NP,MP,IDIM),SM1(NP,IDIM) 58 : REAL*8 TN1(NP,IDIM),TN2(NP,IDIM) 59 : ENDSEGMENT 60 : 61 : -INC SMLMOTS 62 : POINTEUR LINCO.MLMOTS 63 : CHARACTER*8 NOMZ,NOMI,NOMA,TYPE,NOM0,TYPC,MTERR,MTYP,CHAI 64 : CHARACTER*4 NOMD4,CHAR 65 : LOGICAL LOGI,XPG 66 : PARAMETER (NTB=1) 67 : CHARACTER*8 LTAB(NTB),LNOMD(6) 68 : DIMENSION KTAB(NTB),IXV(4) 69 : DATA LTAB/'KIZX '/ 70 : DATA LNOMD/'SOMMET ','FACE ','CENTRE ','CENTREP0','CENTREP1' 71 : & ,'MSOMMET '/ 72 : C***************************************************************************** 73 : CFIMP 74 : c write(6,*)' Debut FIMP' 75 : C 76 : C***** FV Euler/Navier-Stokes equations 77 : C 78 : IRET=0 78 : CALL LIRCHA(CHAR,0,IRET) 79 : IF(IERR.NE.0)GOTO 9999 80 : IF(IRET.NE.0)THEN 81 : IF(CHAR .EQ. 'VF ')THEN 81 : CALL FIMPVF() 82 : GOTO 9999 83 : ELSE 83 : CALL REFUS 84 : ENDIF 85 : ENDIF 86 : C Nouvelle directive EQUA de EQEX 87 : MTYP=' ' 87 : CALL QUETYP(MTYP,0,IRET) 88 : IF(IRET.EQ.0)THEN 89 : C% On attend un des objets : %m1:8 %m9:16 %m17:24 %m25:32 %m33:40 90 : MOTERR( 1: 8) = 'CHAI ' 91 : MOTERR( 9:16) = 'MMODEL ' 92 : MOTERR(17:24) = 'TABLE ' 92 : CALL ERREUR(472) 93 : RETURN 94 : ENDIF 95 : 96 : IF(MTYP.EQ.'MMODEL')THEN 96 : CALL YTCLSF(' S ','FIMP ') 97 : RETURN 98 : ELSEIF(MTYP.EQ.'MOT ')THEN 98 : CALL LIRCHA(CHAI,1,IRET) 98 : CALL YTCLSF(CHAI,'FIMP ') 99 : RETURN 100 : ENDIF 101 : C Fin Nouvelle directive EQUA de EQEX 102 : 102 : CALL LITABS(LTAB,KTAB,NTB,1,IRET) 103 : IF (IERR.NE.0) RETURN 104 : MTABX=KTAB(1) 105 : 106 : C....................................................................... 107 : C 108 : C- Récupération de la table EQEX (pointeur MTAB1) 109 : C 110 : 110 : CALL LEKTAB(MTABX,'EQEX',MTAB1) 111 : IF(MTAB1.EQ.0)THEN 112 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 113 : MOTERR( 1: 8) = ' EQEX ' 114 : MOTERR( 9:16) = ' EQEX ' 115 : MOTERR(17:24) = ' KIZX ' 115 : CALL ERREUR(786) 116 : RETURN 117 : ENDIF 117 : CALL ACME(MTAB1,'NAVISTOK',NASTOK) 118 : IF(NASTOK.EQ.0)THEN 118 : CALL ZZFIMP(MTABX,MTAB1) 119 : RETURN 120 : ENDIF 121 : C 122 : C- Récupération de la table INCO (pointeur KINC) 123 : C 123 : CALL LEKTAB(MTAB1,'INCO',KINC) 124 : IF(KINC.EQ.0)THEN 125 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 126 : MOTERR( 1: 8) = ' INCO ' 127 : MOTERR( 9:16) = ' INCO ' 128 : MOTERR(17:24) = ' EQEX ' 128 : CALL ERREUR(786) 129 : RETURN 130 : ENDIF 131 : C....................................................................... 132 : 132 : CALL ACMM(MTABX,'NOMZONE',NOMZ) 133 : 133 : CALL LIROBJ('MMODEL',MMDZ,0,IRET) 134 : IF(IRET.EQ.0)THEN 135 : TYPE=' ' 135 : CALL ACMO(MTABX,'DOMZ',TYPE,MMDZ) 136 : IF(TYPE.NE.'MMODEL')THEN 137 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 138 : MOTERR( 1: 8) = ' DOMZ ' 139 : MOTERR( 9:16) = ' DOMZ ' 140 : MOTERR(17:24) = ' KIZX ' 140 : CALL ERREUR(786) 141 : RETURN 142 : ENDIF 143 : ENDIF 144 : 145 : C***************************************************************************** 146 : C OPTIONS 147 : C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC 148 : C IDCEN = 0->rien 1-> CENTREE 2-> SUPGDC 3-> SUPG 4-> TVISQUEU 5-> CNG 149 : C KPOIN = 0->SOMMET 1-> FACE 2-> CENTRE 3-> CENTREP0 4-> CENTREP1 5-> MSOMMET 150 : 151 : IAXI=0 152 : IF(IFOMOD.EQ.0)IAXI=2 153 : DEUPI=1.D0 154 : IF(IAXI.NE.0)DEUPI=2.D0*XPI 155 : C 156 : C- Récupération de la table des options KOPT (pointeur KOPTI) 157 : C 157 : CALL LEKTAB(MTABX,'KOPT',KOPTI) 158 : IF (KOPTI.EQ.0) THEN 159 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 160 : MOTERR( 1: 8) = ' KOPT ' 161 : MOTERR( 9:16) = ' KOPT ' 162 : MOTERR(17:24) = ' KIZX ' 162 : CALL ERREUR(786) 163 : RETURN 164 : ENDIF 165 : 166 : 167 : XPG=.FALSE. 167 : CALL ACME(KOPTI,'IDCEN',IDCEN) 167 : CALL ACMF(KOPTI,'CMD ',CMD ) 168 : IF(IDCEN.NE.0)XPG=.TRUE. 169 : KDIM=1 170 : IF(IDCEN.EQ.2)KDIM=IDIM 170 : CALL ACME(KOPTI,'KFORM',KFORM) 170 : CALL ACME(KOPTI,'KPOIND',KPOIND) 171 : c write(6,*)' INCOD=',KPOIND,' IDCEN=',IDCEN 172 : 173 : IF(KFORM.GE.2)THEN 174 : C Option %m1:8 incompatible avec les données 175 : MOTERR( 1: 8) = 'EF/EFM1 ' 175 : CALL ERREUR(803) 176 : RETURN 177 : ENDIF 178 : IF (IERR.NE.0) RETURN 179 : 180 : C write(6,*)' Apres les options ' 181 : C***************************************************************************** 182 : C 183 : C- Récupération de la table DOMAINE associée au domaine local 184 : C 185 : 186 : C E/ MMODEL : Pointeur de la table contenant l'information cherchée 187 : C /S IPOINT : Pointeur sur la table DOMAINE 188 : C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE 189 : C INEFMD=4 LINB 190 : 190 : CALL LEKMOD(MMDZ,MTABZ,INEFMD) 190 : CALL LEKTAB(MTABZ,'MAILLAGE',MELEME) 191 : IF (IERR.NE.0) RETURN 192 : c write(6,*)' INEFMD=',inefmd 193 : 194 : C 195 : C- Vérification des compatiblités Formulation/SPG 196 : C- Identification du spg de l'inconnue 197 : C- SPGZ=spg inco duale de la zone; MELEME=connectivité associée ; 198 : C 199 : 200 : C EFM1 / EF 201 : c write(6,*)' KFORM=',kform,' KPOIND=',kpoind 202 : IF(KPOIND.EQ.99.OR.KPOIND.EQ.0)THEN 203 : 204 : NOMD4= ' ' 205 : KPOIND=0 205 : CALL LEKTAB(MTABZ,'MAILLAGE',MELEMD) 205 : CALL LEKTAB(MTABZ,'SOMMET',SPGD) 206 : c write(6,*)'SOMMET MTABZ=',MTABZ,'SPGD=',SPGD,'MELEMD=',MELEMD 207 : IF (IERR.NE.0) RETURN 208 : 209 : ELSEIF(KPOIND.EQ.2)THEN 210 : 211 : NOMD4= ' ' 211 : c CALL LEKTAB(MTABZ,'MAILLAGE',MELEMD) 211 : CALL LEKTAB(MTABZ,'CENTRE',MELEMD) 211 : CALL LEKTAB(MTABZ,'CENTRE ',SPGD) 212 : IF (IERR.NE.0) RETURN 213 : 214 : ELSEIF(KPOIND.EQ.3)THEN 215 : 216 : MTERR='EF CTRP0' 217 : IF(INEFMD.EQ.2)NOMD4='MCP0' 218 : IF(INEFMD.EQ.3)NOMD4='PRP0' 219 : IF(INEFMD.NE.2.AND.INEFMD.NE.3)GO TO 90 219 : CALL LEKTAB(MTABZ,'CENTREP0',MELEMD) 219 : CALL LEKTAB(MTABZ,'CENTREP0',SPGD) 219 : IF(INEFMD.EQ.2)CALL LEKTAB(MTABZ,'MACRO1',MELEME) 220 : IF (IERR.NE.0) RETURN 221 : 222 : ELSEIF(KPOIND.EQ.4)THEN 223 : 224 : MTERR='EF CTRP1' 225 : IF(INEFMD.EQ.2)NOMD4='MCP1' 226 : IF(INEFMD.EQ.3)NOMD4='PRP1' 227 : IF(INEFMD.NE.2.AND.INEFMD.NE.3)GO TO 90 227 : CALL LEKTAB(MTABZ,'CENTREP1',SPGD) 227 : CALL LEKTAB(MTABZ,'ELTP1NC ',MELEMD) 227 : IF(INEFMD.EQ.2)CALL LEKTAB(MTABZ,'MACRO1',MELEME) 228 : IF (IERR.NE.0) RETURN 229 : 230 : ELSEIF(KPOIND.EQ.5)THEN 231 : 232 : MTERR='EF Pcont' 233 : NOMD4= 'P1P1' 234 : IF(INEFMD.EQ.2)NOMD4='MCF1' 235 : IF(INEFMD.EQ.3)NOMD4='PFP1' 235 : CALL LEKTAB(MTABZ,'MSOMMET',SPGD) 235 : CALL LEKTAB(MTABZ,'MMAIL ',MELEMD) 235 : IF(INEFMD.EQ.2)CALL LEKTAB(MTABZ,'MACRO1',MELEME) 236 : IF (IERR.NE.0) RETURN 237 : 238 : ELSEIF(KPOIND.NE.2.AND.KPOIND.NE.0.AND.KPOIND.NE.3 239 : & .AND.KPOIND.NE.4.AND.KPOIND.NE.5)THEN 240 : C Option %m1:8 incompatible avec les données 241 : MOTERR( 1: 8) = ' EF ' 241 : CALL ERREUR(803) 242 : RETURN 243 : ENDIF 244 : 245 : C************************************************************************* 246 : C Lecture du coefficient 247 : C write(6,*)' Lecture des coefficients ' 248 : 248 : CALL ACME(MTABX,'IARG',IARG) 249 : IF(IARG.NE.1)THEN 250 : C Indice %m1:8 : nombre d'arguments incorrect 251 : MOTERR(1:8) = 'IARG ' 251 : CALL ERREUR(804) 252 : RETURN 253 : ENDIF 254 : 255 : XPG=.FALSE. 256 : IDCEN=0 257 : IVC=0 258 : c write(6,*)' KPOIND=',KPOIND,'INEFMD=',INEFMD,MELEME 258 : CALL LEKMOF(MTABZ,1,MTABX,KINC,IVC,MCHEL4,KPOIND,0,MCHELG) 259 : IF (IERR.NE.0) RETURN 260 : c write(6,*)' MCHEL4=',MCHEL4,'IRET=',IRET 261 : c & ,' MELEMD=',MELEMD,'SPGD=',SPGD 262 : 263 : C Fin lecture Arguments ************************************************** 264 : 265 : C************************************************************************* 266 : C VERIFICATIONS SUR LES INCONNUES 267 : C 268 : C- Récupération du nombre d'inconnues et du nom de l'inconnue NOMI 269 : C 270 : TYPE='LISTMOTS' 270 : CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO) 271 : IF (IERR.NE.0) RETURN 272 : SEGACT LINCO 273 : NBINC=LINCO.MOTS(/2) 274 : IF(NBINC.NE.1)THEN 275 : C Indice %m1:8 : contient plus de %i1 %m9:16 276 : MOTERR( 1:8) = 'LISTINCO' 277 : INTERR(1) = 1 278 : MOTERR(9:16) = ' MOTS ' 278 : CALL ERREUR(799) 279 : RETURN 280 : ENDIF 281 : 282 : NOMI=LINCO.MOTS(1) 283 : 284 : C --> 1 ere Inconnue 285 : 286 : NOMI=LINCO.MOTS(1) 287 : C write(6,*)' NOMI=',nomi 288 : 289 : TYPE=' ' 289 : CALL ACMO(KINC,NOMI,TYPE,MCHPOI) 290 : IF(TYPE.NE.'CHPOINT ')THEN 291 : C Indice %m1:8 : ne contient pas un objet de type %m9:16 292 : MOTERR( 1: 8) = 'INC '//NOMI 293 : MOTERR( 9:16) = 'CHPOINT ' 293 : CALL ERREUR(800) 294 : RETURN 295 : ELSE 295 : CALL LICHT(MCHPOI,IZTU1,TYPC,SPGID) 296 : ENDIF 297 : 298 : C************************************************************************* 299 : C Le domaine de definition est donne par le SPG de la premiere inconnue 300 : C Les inconnues suivantes devront posseder ce meme pointeur 301 : C On verifie que les points de la zone sont tous inclus dans ce SPG 302 : 303 : 303 : CALL KRIPAD(SPGID,MLENTI) 303 : CALL VERPAD(MLENTI,SPGD,IRET) 304 : SEGSUP MLENTI 305 : IF(IRET.NE.0)THEN 306 : WRITE(6,*)'KPOIND =',KPOIND,' SPGD=',SPGD,' SPGID=',SPGID 307 : C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique 308 : MOTERR(1: 8) = 'INC '//NOMI 309 : MOTERR(9:16) = 'CHPOINT ' 309 : CALL ERREUR(788) 310 : RETURN 311 : ENDIF 312 : 313 : NC=IZTU1.VPOCHA(/2) 314 : SEGDES IZTU1 314 : CALL KRCHPT(LNOMD(KPOIND+1),SPGD,NC,MCHPO1,NOMI(1:4)) 315 : 315 : CALL XXSOUR(KPOIND,NOMD4,MCHPO1,XPG,MELEME,MELEMD,SPGD,MCHEL4, 316 : &INEFMD) 317 : 318 : NRIGE=7 319 : NMATRI=0 320 : NKID =9 321 : NKMT =7 322 : SEGINI MATRIK 323 : segdes matrik 323 : CALL ECROBJ('MATRIK',MATRIK) 324 : 325 : segdes MCHPO1 325 : CALL ECROBJ('CHPOINT',MCHPO1) 326 : 327 : SEGDES LINCO 328 : 329 : c write(6,*)' FIN FIMP' 330 : 9999 CONTINUE 331 : RETURN 332 : 90 CONTINUE 333 : C Option %m1:8 incompatible avec les données 334 : MOTERR( 1: 8) = MTERR 334 : CALL ERREUR(803) 335 : RETURN 336 : 337 : 1002 FORMAT(10(1X,1PE11.4)) 338 : END 339 : 340 : 341 : 342 : 343 : 344 : 345 : 346 : 347 : 348 : 349 : 350 : 351 : 352 : 353 : 354 : 355 : 356 : 357 :
© Cast3M 2003 - All rights reserved.
Disclaimer