1 : C YFPU SOURCE FANDEUR 13/02/07 21:15:15 7694 2 : SUBROUTINE YFPU 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C*********************************************************************** 6 : C 7 : C SYNTAXE : 8 : C 9 : C FPU NU UET YP <,VPAROI> 10 : C 11 : C 1------2 12 : C (R1,AL1) LEF FLUIDE NOEUDS 1 2 13 : C 14 : C 15 : C ANU VISCOSITE CINEMATIQUE 16 : C UET U* 17 : C YP DISTANCE A LA PAROI 18 : C VPAROI VITESSE DE LA PAROI (PAR DEFAUT 0.) 19 : C 20 : C CAS TRIDIMENSIONNEL 21 : C 4 ________ 3 22 : C / FLUIDE / 23 : C 1 /________/2 24 : C 25 : C 26 : C*********************************************************************** 27 : 28 : -INC CCVQUA4 29 : -INC CCOPTIO 30 : -INC CCGEOME 31 : -INC SMCOORD 32 : -INC SIZFFB 33 : POINTEUR IZF1.IZFFM,IZH2.IZHR 34 : -INC SMLREEL 35 : POINTEUR MLREE4.MLREEL 36 : -INC SMLENTI 37 : POINTEUR IPADS.MLENTI,IPADT.MLENTI 38 : -INC SMMATRIK 39 : -INC SMELEME 40 : POINTEUR MELEMS.MELEME,MELEKE.MELEME,MELEMX.MELEME,MLEMST.MELEME 41 : -INC SMCHPOI 42 : POINTEUR IZD.MPOVAL,IZDS.MPOVAL,IZDK.MPOVAL,IZDE.MPOVAL 43 : POINTEUR IZG1.MCHPOI, IZGG1.MPOVAL 44 : POINTEUR IZG2.MCHPOI, IZGG2.MPOVAL 45 : POINTEUR IZG3.MCHPOI, IZGG3.MPOVAL 46 : POINTEUR IZGV.MCHPOI, IZGGV.MPOVAL 47 : POINTEUR IZTU1.MPOVAL 48 : POINTEUR MUE.MCHPOI,MZUE.MPOVAL 49 : POINTEUR MYP.MCHPOI,MZYP.MPOVAL 50 : POINTEUR MZNU.MPOVAL 51 : POINTEUR MZRO.MPOVAL,MZMU.MPOVAL 52 : POINTEUR IZVOL.MPOVAL 53 : POINTEUR MNT.MCHPOI,MZNT.MPOVAL 54 : 55 : -INC SMLMOTS 56 : POINTEUR LINCO.MLMOTS 57 : CHARACTER*8 NOMZ,NOMI,TYPE,TYPC,NOM0 58 : CHARACTER*4 NOM4(5) 59 : LOGICAL LOGI 60 : PARAMETER (NTB=1) 61 : CHARACTER*8 LTAB(NTB) 62 : DIMENSION KTAB(NTB),IXV(3),AJ(270),XYZ(90) 63 : DATA LTAB/'KIZX '/ 64 : C***************************************************************************** 65 : CFPU 66 : *pv ca le fait mieux en initialisant ikel 67 : *pv si on ne le fait pas et que par hasard il vaut 1 68 : *pv les resultats ne sont pas ceux attendus 69 : ikel=0 70 : c write(6,*)' debut FPU ' 71 : izdk=0 72 : izde=0 72 : CALL LITABS(LTAB,KTAB,NTB,1,IRET) 73 : IF (IERR.NE.0) RETURN 74 : MTABX=KTAB(1) 75 : C 76 : C- Récupération de la table EQEX (pointeur MTAB1) 77 : C 77 : CALL LEKTAB(MTABX,'EQEX',MTAB1) 78 : IF(MTAB1.EQ.0)THEN 79 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 80 : MOTERR( 1: 8) = ' EQEX ' 81 : MOTERR( 9:16) = ' EQEX ' 82 : MOTERR(17:24) = ' KIZX ' 82 : CALL ERREUR(786) 83 : RETURN 84 : ENDIF 84 : CALL ACME(MTAB1,'NAVISTOK',NASTOK) 85 : IF(NASTOK.EQ.0)THEN 85 : CALL ZFPU(MTABX,MTAB1) 86 : RETURN 87 : ENDIF 88 : C 89 : C- Récupération de la table INCO (pointeur KINC) 90 : C 90 : CALL LEKTAB(MTAB1,'INCO',KINC) 91 : IF(KINC.EQ.0)THEN 92 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 93 : MOTERR( 1: 8) = ' INCO ' 94 : MOTERR( 9:16) = ' INCO ' 95 : MOTERR(17:24) = ' EQEX ' 95 : CALL ERREUR(786) 96 : RETURN 97 : ENDIF 98 : 99 : C***************************************************************************** 100 : C OPTIONS 101 : C KIMPL = 0 -> EXPL 1 -> IMPL 2 -> SEMI 102 : C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC 103 : C IDCEN = 0-> rien 1-> CENTREE 2-> SUPGDC 3-> SUPG 4-> TVISQUEU 5-> CNG 104 : 105 : IKOMP=0 106 : IAXI=0 107 : IF(IFOMOD.EQ.0)IAXI=2 108 : C 109 : C- Récupération de la table des options KOPT (pointeur KOPTI) 110 : C 110 : CALL LEKTAB(MTABX,'KOPT',KOPTI) 111 : IF (KOPTI.EQ.0) THEN 112 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 113 : MOTERR( 1: 8) = ' KOPT ' 114 : MOTERR( 9:16) = ' KOPT ' 115 : MOTERR(17:24) = ' KIZX ' 115 : CALL ERREUR(786) 116 : RETURN 117 : ENDIF 118 : 119 : C write(6,*)' Avant les options ' 120 : TYPE=' ' 120 : CALL ACMO(KOPTI,'PRECAU',TYPE,IENT) 120 : IF(TYPE.EQ.'ENTIER')CALL ACME(KOPTI,'PRECAU',IPRE) 121 : TYPE=' ' 121 : CALL ACMO(KOPTI,'IKOMP',TYPE,IENT) 121 : IF(TYPE.EQ.'ENTIER')CALL ACME(KOPTI,'IKOMP',IKOMP) 122 : 122 : CALL ACME(KOPTI,'KIMPL',KIMPL) 122 : CALL ACME(KOPTI,'KFORM',KFORM) 123 : 124 : IF(KFORM.NE.0.AND.KFORM.NE.1)THEN 125 : C Option %m1:8 incompatible avec les données 126 : MOTERR( 1: 8) = 'EF/EFM1 ' 126 : CALL ERREUR(803) 127 : RETURN 128 : ENDIF 129 : 130 : C***************************************************************************** 131 : C 132 : C- Récupération de la table DOMAINE associée au domaine local 133 : C 133 : CALL ACMM(MTABX,'NOMZONE',NOMZ) 134 : TYPE=' ' 134 : CALL ACMO(MTABX,'DOMZ',TYPE,MMDZ) 135 : IF(TYPE.NE.'MMODEL')THEN 136 : C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 137 : MOTERR( 1: 8) = ' DOMZ ' 138 : MOTERR( 9:16) = ' DOMZ ' 139 : MOTERR(17:24) = ' KIZX ' 139 : CALL ERREUR(786) 140 : RETURN 141 : ENDIF 142 : 143 : C E/ MMODEL : Pointeur de la table contenant l'information cherchée 144 : C /S IPOINT : Pointeur sur la table DOMAINE 145 : C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE 146 : C INEFMD=4 LINB 147 : 147 : CALL LEKMOD(MMDZ,MTABZ,INEFMD) 148 : 148 : CALL LEKTAB(MTABZ,'SOMMET',MELEMS) 148 : CALL LEKTAB(MTABZ,'MAILLAGE',MELEME) 148 : CALL LEKTAB(MTABZ,'CENTRE',MELEMC) 148 : CALL LEKTAB(MTABZ,'XXVOLUM',MCHPOI) 149 : IF (IERR.NE.0) RETURN 150 : 151 : SEGACT MELEME 151 : CALL LICHT(MCHPOI,IZVOL,TYPC,IGEOM) 152 : IF (IERR.NE.0) RETURN 153 : C*** 154 : 155 : TYPE='LISTMOTS' 155 : CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO) 156 : SEGACT LINCO 157 : 157 : CALL ACME(MTABX,'IARG',IARG) 158 : IKOMP=0 159 : 160 : IF (KFORM.EQ.0.AND.IARG.NE.3)THEN 161 : write(6,*)' FPU : nb d arguments incorrect :',IARG 162 : GO TO 90 163 : ENDIF 164 : IF (KFORM.EQ.1.AND.IARG.NE.5.AND.IARG.NE.6)THEN 165 : write(6,*)' FPU : nb d arguments incorrect :',IARG 166 : GO TO 90 167 : ENDIF 168 : IKRS=0 169 : IKR=1 170 : N=1 171 : NC=1 172 : SEGINI MZRO 173 : MZRO.VPOCHA(1,1)=1.D0 174 : 175 : 176 : C--Cas incompressible 177 : IF(IARG.EQ.3)THEN 178 : IF(IKOMP.EQ.0)THEN 179 : C 1er coefficient : nu 180 : IXV(1)=0 181 : IXV(2)=1 182 : IXV(3)=0 183 : IRET=0 183 : CALL LEKCOF('Opérateur FPU :', 184 : & MTABX,KINC,1,IXV,MNU,MZNU,NPT1,NC1,IKM,IRET) 185 : IF(IRET.EQ.0)RETURN 186 : 187 : C 2ème coefficient : uet 188 : IXV(1)=MELEMC 189 : IF(KFORM.EQ.1)IXV(1)=MELEMS 190 : IXV(2)=0 191 : IXV(3)=0 192 : IRET=1 192 : CALL LEKCOF('Opérateur FPU :', 193 : & MTABX,KINC,2,IXV,MUE,MZUE,NPT2,NC2,IK2,IRET) 194 : IF(IRET.EQ.0)RETURN 195 : SEGACT MZUE*MOD 196 : 197 : C 3ème coefficient : yp 198 : IXV(1)=0 199 : IXV(2)=1 200 : IXV(3)=0 201 : IRET=0 201 : CALL LEKCOF('Opérateur FPU :', 202 : & MTABX,KINC,3,IXV,MYP,MZYP,NPT3,NC3,IK3,IRET) 203 : IF(IRET.EQ.0)RETURN 204 : ENDIF 205 : 206 : 207 : C--Cas compressible 208 : ELSEIF(IKOMP.EQ.1)THEN 209 : C 1er coefficient : mu 210 : IXV(1)=MELEMC 211 : IXV(2)=1 212 : IXV(3)=0 213 : IRET=0 213 : CALL LEKCOF('Opérateur FPU :', 214 : & MTABX,KINC,1,IXV,MNU,MZNU,NPT1,NC1,IKM,IRET) 215 : IF(IRET.EQ.0)RETURN 216 : 217 : C 2ème coefficient : uet 218 : IXV(1)=MELEMC 219 : IXV(2)=0 220 : IXV(3)=0 221 : IRET=0 221 : CALL LEKCOF('Opérateur FPU :', 222 : & MTABX,KINC,2,IXV,MUE,MZUE,NPT2,NC2,IK2,IRET) 223 : IF(IRET.EQ.0)RETURN 224 : SEGACT MZUE*MOD 225 : 226 : ENDIF 227 : 227 : CALL KRIPAD(MELEMS,IPADS) 228 : NPTS=MELEMS.NUM(/2) 229 : 230 : C***************************************************************************** 231 : 232 : C VERIFICATIONS SUR LES INCONNUES 233 : NBINC=LINCO.MOTS(/2) 234 : IF(NBINC.NE.1.AND.NBINC.NE.3)THEN 235 : WRITE(6,*)'Nombre d''inconnues incorrect : ',NBINC,' On attend 3' 236 : WRITE(6,*)' On attend 1 ou 3' 237 : C Indice %m1:8 : nombre d'arguments incorrect 238 : MOTERR(1:8) = 'INCO ' 238 : CALL ERREUR(804) 239 : RETURN 240 : ENDIF 241 : 242 : C --> 1 ere Inconnue 243 : 244 : NOMI=LINCO.MOTS(1) 245 : DO 15 I=1,IDIM 246 : WRITE(NOM4(I),FMT='(I1,A3)')I,NOMI(1:3) 247 : 15 CONTINUE 248 : 249 : TYPE=' ' 249 : CALL ACMO(KINC,NOMI,TYPE,MCHPOI) 250 : IF(TYPE.NE.'CHPOINT ')THEN 251 : WRITE(6,*)' L objet CHPOINT ',NOMI,' n existe pas dans la table' 252 : RETURN 253 : ELSE 253 : CALL LICHT(MCHPOI,IZTU1,TYPC,IGEOM0) 254 : ENDIF 254 : CALL KRIPAD(IGEOM0,MLENTI) 255 : 256 : 257 : C._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._ 258 : C--Cas Complet: ro un mu uet yp 259 : IF((IARG.EQ.5.OR.IARG.EQ.6).AND.KFORM.EQ.1)THEN 260 : 261 : C 1er coefficient : ro 262 : IKRS=1 263 : IXV(1)=IGEOM0 264 : IXV(2)=1 265 : IXV(3)=0 266 : IRET=0 266 : CALL LEKCOF('Opérateur FPU :', 267 : & MTABX,KINC,1,IXV,MRO,MZRO,NPT1,NC1,IKR,IRET) 268 : IF(IRET.EQ.0)RETURN 269 : 270 : C 2ème coefficient : un 271 : IXV(1)=-IGEOM0 272 : IXV(2)=0 273 : IXV(3)=0 274 : IRET=1 274 : CALL LEKCOF('Opérateur FPU :', 275 : & MTABX,KINC,2,IXV,MUE,MZUE,NPT2,NC2,IKU,IRET) 276 : IF(IRET.EQ.0)RETURN 277 : SEGACT MZUE*MOD 278 : 279 : C 3ème coefficient : mu 280 : IXV(1)=IGEOM0 281 : IXV(2)=1 282 : IXV(3)=0 283 : IRET=0 283 : CALL LEKCOF('Opérateur FPU :', 284 : & MTABX,KINC,3,IXV,MMU,MZMU,NPT3,NC3,IKM,IRET) 285 : IF(IRET.EQ.0)RETURN 286 : 287 : C 4ème coefficient : uet 288 : IXV(1)=MELEMC 289 : IF(KFORM.EQ.1)IXV(1)=MELEMS 290 : IXV(2)=0 291 : IXV(3)=0 292 : IRET=1 293 : 293 : CALL LEKCOF('Opérateur FPU :', 294 : & MTABX,KINC,4,IXV,MUE,MZUE,NPT2,NC2,IK2,IRET) 295 : IF(IRET.EQ.0)RETURN 296 : SEGACT MZUE*MOD 297 : 298 : TYPE=' ' 298 : CALL ACMO(MTABX,'ARG5',TYPE,MDTOT) 299 : 300 : c####################################################################### 301 : c################# IKEL = 1 => Syntaxe II ############################## 302 : IF(TYPE.EQ.'MMODEL')THEN 303 : IKEL=1 304 : 305 : TYPE=' ' 305 : CALL ACMO(MTABX,'PREFPU',TYPE,MTABP) 306 : IF(TYPE.NE.'TABLE')THEN 307 : KPREFPU=0 308 : write(6,*)'Operateur FPU : On Preconditionne ' 308 : CALL CRTABL(MTABP) 308 : CALL ECMO(MTABX,'PREFPU','TABLE',MTABP) 309 : ELSE 310 : KPREFPU=1 311 : ENDIF 312 : 313 : C 6ème coefficient : NUT 314 : IXV(1)=IGEOM0 315 : IXV(2)=0 316 : IXV(3)=0 317 : IRET=0 317 : CALL LEKCOF('Opérateur FPU :', 318 : & MTABX,KINC,6,IXV,MNT,MZNT,NPT3,NC3,IK3,IRET) 319 : IF(IRET.EQ.0)RETURN 320 : C On calcule le Gradient de U 321 : 322 : * IGEOM0 Support géomtrique domaine complet 323 : * MDTOT modèle pour le maillage complet 324 : * MTABT table domaine en résultant 325 : * MTABZ table domaine de la zone frontière 326 : 326 : CALL LEKMOD(MDTOT,MTABT,INEFMDT) 326 : CALL LEKTAB(MTABT,'MAILLAGE',MELEMT) 326 : CALL LEKTAB(MTABT,'SOMMET' ,MLEMST) 326 : CALL LEKTAB(MTABZ,'SOMMET' ,MELEMS) 327 : 328 : C._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._. 329 : c on extrait les élements s'appuyant largement sur la frontière 330 : c -> MELEMX 331 : IF(KPREFPU.EQ.0)THEN 332 : 333 : SEGACT MUE,MZUE 334 : NSOUPO=MUE.IPCHP(/1) 335 : IF(NSOUPO.GT.1)THEN 336 : C Option %m1:8 incompatible avec les données 337 : MOTERR( 1: 8) = 'NSOUPO>1' 337 : CALL ERREUR(803) 338 : RETURN 339 : ENDIF 340 : NAT=MUE.JATTRI(/1) 341 : N =MZUE.VPOCHA(/1) 342 : NC=MZUE.VPOCHA(/2) 343 : SEGINI MYP,MSOUPO,MZYP 344 : DO 651 I=1,NAT 345 : MYP.JATTRI(I)=MUE.JATTRI(I) 346 : 651 CONTINUE 347 : SEGINI MSOUPO 348 : MYP.IPCHP(1)=MSOUPO 349 : MSOUP1=MUE.IPCHP(1) 350 : SEGACT MSOUP1 351 : DO 652 I=1,NC 352 : NOCOMP(I)=MSOUP1.NOCOMP(I) 353 : NOCONS(I)=MSOUP1.NOCONS(I) 354 : NOHARM(I)=MSOUP1.NOHARM(I) 355 : 652 CONTINUE 356 : IGEOC =MSOUP1.IGEOC 357 : IPOVAL=MZYP 358 : 358 : CALL ECROBJ('MAILLAGE',MELEME) 358 : CALL ECRCHA('POI1') 358 : CALL PRCHAN 358 : CALL ECRCHA('LARGEMENT') 358 : CALL ECRCHA('APPUYE') 358 : CALL ECROBJ('MAILLAGE',MELEMT) 358 : CALL PREXTR 358 : CALL LIROBJ('MAILLAGE',MELEMX,1,IRET) 358 : CALL ECROBJ('MAILLAGE',MELEMX) 358 : CALL NBNO 358 : CALL LIRENT(NPTA,1,IRET) 359 : 359 : call ecmo(mtabx,'MYP' ,'CHPOINT' ,MYP ) 359 : call ecmo(mtabp,'MELEMX','MAILLAGE',MELEMX) 359 : call ecme(mtabp,'NPTA',npta) 360 : ELSE 361 : type=' ' 361 : call acmo(mtabx,'MYP',TYPE,MYP) 362 : SEGACT MYP 363 : MSOUPO=MYP.IPCHP(1) 364 : SEGACT MSOUPO 365 : MZYP=MSOUPO.IPOVAL 366 : SEGACT MZYP 367 : type=' ' 367 : call acmo(mtabp,'MELEMX',TYPE,MELEMX) 367 : call acme(mtabp,'NPTA',npta) 368 : ENDIF 369 : c -> MELEMX 370 : c on extrait les elements s'appuyant largement sur la frontiere 371 : C._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._. 372 : 373 : c write(6,*)' FPU : NBSOUS=',NBSOUS 373 : c CALL ECROBJ('MAILLAGE',MELEMT) 373 : c CALL PRTRAC 373 : c CALL LIROBJ('MAILLAGE',MELEMT,1,IRET) 373 : c CALL ECROBJ('MAILLAGE',MELEMX) 373 : c CALL ECROBJ('MAILLAGE',MELEMS) 373 : c CALL PRFUSE 373 : c CALL PRTRAC 373 : c CALL LIROBJ('MAILLAGE',MELEMX,1,IRET) 374 : 374 : CALL KRIPAD(MLEMST,IPADT) 375 : SEGACT MLEMST 376 : NPTT=MLEMST.NUM(/2) 376 : CALL KRIPAD(MELEMX,MLENT2) 377 : SEGACT MELEMS 377 : CALL KRIPAD(MELEMS,IPADS) 378 : 379 : c nls=MELEMS.NUM(/2) 380 : c write(6,*)'MELEMS=' 381 : c write(6,1001)(MELEMS.NUM(1,ii),ii=1,nls) 382 : 383 : c write(6,*)' I P A D S ' 384 : c npds=ipads.lect(/1) 385 : c write(6,1001)(ipads.lect(ii),ii=1,npds) 386 : 387 : NC=IZTU1.VPOCHA(/2) 388 : NPTI=IZTU1.VPOCHA(/1) 389 : 390 : SEGACT MELEMX 391 : NBSOUS=MELEMX.LISOUS(/1) 392 : IF(NBSOUS.EQ.0)NBSOUS=1 393 : NUTOEL=0 394 : 395 : IES=IDIM 396 : 397 : 398 : DO 19 L=1,NBSOUS 399 : IPT1=MELEMX 400 : IF(NBSOUS.NE.1)IPT1=MELEMX.LISOUS(L) 401 : SEGACT IPT1 402 : 403 : NP =IPT1.NUM(/1) 404 : NBEL=IPT1.NUM(/2) 405 : 406 : IF(KPREFPU.EQ.0)THEN 407 : JG=NBEL*NP 408 : SEGINI MLREE1,MLREE3 409 : JG=NBEL*NP*IDIM 410 : SEGINI MLREE2 410 : CALL ECMO(MTABP,'YP','LISTREEL',MLREE1) 410 : CALL ECMO(MTABP,'AN','LISTREEL',MLREE2) 410 : CALL ECMO(MTABP,'MUEF','LISTREEL',MLREE3) 411 : ELSE 412 : TYPE=' ' 412 : CALL ACMO(MTABP,'YP',TYPE,MLREE1) 413 : TYPE=' ' 413 : CALL ACMO(MTABP,'AN',TYPE,MLREE2) 414 : TYPE=' ' 414 : CALL ACMO(MTABP,'MUEF',TYPE,MLREE3) 415 : SEGACT MLREE1,MLREE2,MLREE3 416 : ENDIF 417 : 417 : CALL LEKTAB(MTABZ,'XXDIAGSI',MCHPOI) 417 : CALL LICHT(MCHPOI,IZD,TYPC,IGEOM) 418 : N=IZD.VPOCHA(/1) 419 : NC=IZD.VPOCHA(/2) 420 : SEGINI IZDS 421 : 422 : IZGG2=IZDS 423 : IF(NBINC.EQ.3)THEN 424 : c write(6,*)' On met les conditions limites sur K et epsilon' 425 : NOM4(4)=LINCO.MOTS(2)(1:4) 426 : NOM4(5)=LINCO.MOTS(3)(1:4) 427 : TYPE='SOMMET' 428 : NC=2 428 : CALL KRCHPT(TYPE,MELEMS,NC,IZG2,NOM4(4)) 428 : c CALL KRCHPT(TYPE,MELEMX,NC,IZG2,NOM4(4)) 428 : CALL LICHT(IZG2,IZGG2,TYPC,IGEOM0) 428 : CALL INITD(IZGG2.VPOCHA,(NC*NPTS),1.D-5) 429 : ENDIF 430 : 430 : CALL FPTAU(IDIM,NP,NBEL,IPT1.NUM,IPADT.LECT,XCOOR, 431 : & IZTU1.VPOCHA,NPTI,NC,IPADS.LECT,NPTS, 432 : & MZNT.VPOCHA,MLREE3.PROG,MLREE1.PROG,MLREE2.PROG,MZRO.VPOCHA,IKR, 433 : & MZMU.VPOCHA,IKM,MZUE.VPOCHA,MZYP.VPOCHA,IPT1.ITYPEL, 434 : & IZGG2.VPOCHA,NBINC) 435 : 436 : 19 CONTINUE 437 : 437 : c CALL ECROBJ('MAILLAGE',MELEMX) 437 : c CALL PRTRAC 437 : c CALL LIROBJ('MAILLAGE',MELEMX,1,IRET) 438 : NC=IZTU1.VPOCHA(/2) 439 : NPTI=IZTU1.VPOCHA(/1) 440 : TYPE='SOMMET' 440 : CALL KRCHPT(TYPE,MELEMS,NC,IZG1,NOM4) 440 : CALL LICHT(IZG1,IZGG1,TYPC,IGEOM) 440 : CALL ECMO(KINC,'FFF','CHPOINT',IZG1) 441 : 442 : C --> Vitesse seulement on l'impose a 0. 443 : 444 : TYPE='SOMMET' 445 : NC=IDIM 445 : CALL KRCHPT(TYPE,MELEMS,NC,IZGV,NOM4(1)) 445 : CALL LICHT(IZGV,IZGGV,TYPC,IGEOM0) 446 : 447 : TYPE=' ' 447 : CALL ACMO(MTAB1,'CLIM',TYPE,KCLIM) 448 : c write(6,*)' Y F P U :: KCLIM = ',KCLIM 449 : 450 : IF(KCLIM.EQ.0)THEN 450 : CALL ECMO(MTAB1,'CLIM','CHPOINT',IZGV) 451 : 452 : ELSE 453 : c On remet à 0 les conditions limites précédentes 454 : MCHPO4=KCLIM 455 : SEGACT MCHPO4 456 : NSP1=MCHPO4.IPCHP(/1) 457 : 458 : DO 882 L=1,NSP1 459 : MSOUPO=MCHPO4.IPCHP(L) 460 : SEGACT MSOUPO 461 : NC=NOCOMP(/2) 462 : MELEKE=IGEOC 463 : MPOVA4=IPOVAL 464 : SEGACT MELEKE,MPOVA4*MOD 465 : NBPKE=MELEKE.NUM(/2) 466 : DO 883 N=1,NC 467 : IF(NOCOMP(N).NE.NOM4(1).AND.NOCOMP(N).NE.NOM4(2) 468 : & .AND.NOCOMP(N).NE.NOM4(3))GO TO 883 469 : DO 884 I=1,NBPKE 470 : NKE=IPADS.LECT(MELEKE.NUM(1,I)) 471 : IF(NKE.NE.0)MPOVA4.VPOCHA(I,N)=0.D0 472 : 884 CONTINUE 473 : 883 CONTINUE 474 : SEGDES MSOUPO,MPOVA4,MELEKE 475 : 882 CONTINUE 476 : 476 : CALL ECROBJ('CHPOINT',KCLIM) 476 : CALL ECROBJ('CHPOINT',IZGV) 476 : CALL PRFUSE 476 : CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) 476 : CALL ECMO(MTAB1,'CLIM','CHPOINT',MCHPOI) 477 : 478 : ENDIF 479 : 480 : C --> FIN Vitesse seulement on l'impose a 0. 481 : 482 : IZGG2=IZGG1 483 : IF(NBINC.EQ.3)THEN 484 : C --> On impose K et Epsilon 485 : c On remet à 0 la condition limite précédente pour NOM4(4) et NOM4(5) 486 : TYPE=' ' 486 : CALL ACMO(MTAB1,'CLIM',TYPE,KCLIM) 487 : 488 : MCHPO4=KCLIM 489 : SEGACT MCHPO4 490 : NSP1=MCHPO4.IPCHP(/1) 491 : 492 : DO 982 L=1,NSP1 493 : MSOUPO=MCHPO4.IPCHP(L) 494 : SEGACT MSOUPO 495 : NC=NOCOMP(/2) 496 : MELEKE=IGEOC 497 : MPOVA4=IPOVAL 498 : SEGACT MELEKE,MPOVA4*MOD 499 : NBPKE=MELEKE.NUM(/2) 500 : DO 983 N=1,NC 501 : IF(NOCOMP(N).NE.NOM4(4).AND.NOCOMP(N).NE.NOM4(5))GO TO 983 502 : DO 984 I=1,NBPKE 503 : NKE=IPADS.LECT(MELEKE.NUM(1,I)) 504 : IF(NKE.NE.0)MPOVA4.VPOCHA(I,N)=0.D0 505 : 984 CONTINUE 506 : 983 CONTINUE 507 : SEGDES MSOUPO,MPOVA4,MELEKE 508 : 982 CONTINUE 509 : 509 : CALL ECROBJ('CHPOINT',KCLIM) 509 : CALL ECROBJ('CHPOINT',IZG2) 509 : CALL PRFUSE 509 : CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) 509 : CALL ECMO(MTAB1,'CLIM','CHPOINT',MCHPOI) 510 : c write(6,*)' On remet les CL sur KN et EN CLIM=',MCHPOI 511 : 511 : c CALL ECROBJ('CHPOINT',MCHPOI) 511 : c CALL PRLIST 512 : ENDIF 513 : 514 : SEGSUP IZDS 515 : IF(IKRS.EQ.0)SEGSUP MZRO 516 : SEGDES IZTU1 517 : SEGDES IZG1,IZGG1 518 : IF(NBINC.EQ.3)SEGDES IZG2,IZGG2 519 : SEGDES IZVOL 520 : SEGDES LINCO 521 : SEGSUP MLENTI,IPADS 522 : 523 : c On crée un MATRIK vide 524 : NRIGE=7 525 : NKID =9 526 : NKMT =7 527 : NMATRI=0 528 : SEGINI MATRIK 529 : 529 : CALL ECROBJ('MATRIK',MATRIK) 529 : CALL ECROBJ('CHPOINT',IZG1) 530 : 531 : c write(6,*)' Fin FPU Syntaxe II' 532 : RETURN 533 : c################# IKEL = 1 => Syntaxe II ## FIN ####################### 534 : c####################################################################### 535 : ELSE 536 : 537 : IKEL=0 538 : C 5ème coefficient : yp 539 : IXV(1)=0 540 : IXV(2)=1 541 : IXV(3)=0 542 : IRET=0 542 : CALL LEKCOF('Opérateur FPU :', 543 : & MTABX,KINC,5,IXV,MYP,MZYP,NPT3,NC3,IK3,IRET) 544 : IF(IRET.EQ.0)RETURN 545 : 546 : ENDIF 547 : ENDIF 548 : 549 : C._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._ 550 : 551 : NC=IZTU1.VPOCHA(/2) 552 : NPTI=IZTU1.VPOCHA(/1) 553 : TYPE='SOMMET' 553 : CALL KRCHPT(TYPE,MELEMS,NC,IZG1,NOM4) 553 : CALL LICHT(IZG1,IZGG1,TYPC,IGEOM) 553 : CALL ECMO(KINC,'FFF','CHPOINT',IZG1) 554 : 555 : IZGG2=IZGG1 556 : IF(NBINC.GT.1)THEN 557 : C --> 2 eme Inconnue 558 : 559 : NOM4(4)=LINCO.MOTS(2)(1:4) 560 : NOM4(5)=LINCO.MOTS(3)(1:4) 561 : TYPE='SOMMET' 562 : NC=2 562 : CALL KRCHPT(TYPE,MELEMS,NC,IZG2,NOM4(4)) 562 : CALL LICHT(IZG2,IZGG2,TYPC,IGEOM0) 563 : 564 : TYPE=' ' 564 : CALL ACMO(MTAB1,'CLIM',TYPE,KCLIM) 565 : IF(KCLIM.NE.0)THEN 566 : 567 : MCHPO4=KCLIM 568 : SEGACT MCHPO4 569 : NSP1=MCHPO4.IPCHP(/1) 570 : 571 : DO 782 L=1,NSP1 572 : MSOUPO=MCHPO4.IPCHP(L) 573 : SEGACT MSOUPO 574 : NC=NOCOMP(/2) 575 : MELEKE=IGEOC 576 : MPOVA4=IPOVAL 577 : SEGACT MELEKE,MPOVA4*MOD 578 : NBPKE=MELEKE.NUM(/2) 579 : DO 783 N=1,NC 580 : IF(NOCOMP(N).NE.NOM4(4).AND.NOCOMP(N).NE.NOM4(5))GO TO 783 581 : DO 784 I=1,NBPKE 582 : NKE=IPADS.LECT(MELEKE.NUM(1,I)) 583 : IF(NKE.NE.0)MPOVA4.VPOCHA(I,N)=0.D0 584 : 784 CONTINUE 585 : 783 CONTINUE 586 : SEGDES MSOUPO,MPOVA4,MELEKE 587 : 782 CONTINUE 588 : ENDIF 589 : SEGDES MCHPO4 590 : ENDIF 591 : 591 : CALL LEKTAB(MTABZ,'XXDIAGSI',MCHPOI) 591 : CALL LICHT(MCHPOI,IZD,TYPC,IGEOM) 592 : N=IZD.VPOCHA(/1) 593 : NC=IZD.VPOCHA(/2) 594 : SEGINI IZDS 595 : IF(KFORM.EQ.1.AND.NBINC.EQ.3)THEN 596 : SEGINI IZDE,IZDK 597 : ENDIF 598 : 599 : 600 : SEGACT MELEME 601 : NBSOUS=LISOUS(/1) 602 : IF(NBSOUS.EQ.0)NBSOUS=1 603 : NUTOEL=0 604 : 605 : IES=IDIM 606 : 607 : DO 1 L=1,NBSOUS 608 : IPT1=MELEME 609 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 610 : SEGACT IPT1 611 : 612 : NOM0=NOMS(IPT1.ITYPEL)//' ' 612 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 613 : SEGACT IZFFM*MOD 614 : IZHR=KZHR(1) 615 : SEGACT IZHR*MOD 616 : IZH2=KZHR(2) 617 : IZF1=KTP(1) 618 : NES=GR(/1) 619 : NPG=GR(/3) 620 : NP =IPT1.NUM(/1) 621 : NBEL=IPT1.NUM(/2) 622 : 623 : 624 : 625 : C SUBROUTINE XCVFPU(NEL,K0,NP,IES,IAXI,IPADL, 626 : C & LEF,XYZ, ----> IPT1,COOR 627 : C & VOLF, ----> IZVOL.T, 628 : C & UN,TK,TE, ----> IZTU1.T,IZTU2.T,IZTU3.T, 629 : C & F, ----> IZG1, 630 : C & DK,DE, ----> IZD2,IZD3 631 : C & ANU,IKC,UET,YP, ----> IZTG1.T,IKM,IZTG2.T,IZTG3.T, 632 : C & VPAROI,IKV, IZTG4.T,IK4, 633 : C & PORO,NPR,IPOR) ----> IZPORO,NPOR,IOP7 634 : if(izde.eq.0) izde=izds 635 : if(izdk.eq.0) izdk=izds 636 : IF(KFORM.EQ.0)THEN 637 : 637 : CALL YCVFPU(NBEL,NUTOEL,NP,IES,IAXI,NPTI,LECT, 638 : & NPTS,IPADS.LECT, 639 : & IPT1.NUM,XCOOR, 640 : & IZVOL.VPOCHA, 641 : & IZTU1.VPOCHA,IZGG2.VPOCHA(1,1),IZGG2.VPOCHA(1,2), 642 : & IZGG1.VPOCHA, 643 : & MZNU.VPOCHA,IKM,MZUE.VPOCHA,MZYP.VPOCHA) 644 : 645 : ELSEIF(KFORM.EQ.1.AND.IKEL.EQ.0)THEN 646 : 646 : CALL XCVFPU(FN,GR,PG,XYZ,HR,PGSQ,RPG, 647 : & NES,IDIM,NP,NPG,IAXI,AJ,NBEL,IPT1.NUM,XCOOR, 648 : & NPTI,LECT,IZTU1.VPOCHA,NPTS,IPADS.LECT,MZUE.VPOCHA, 649 : & IZGG1.VPOCHA,MZMU.VPOCHA,IKM,MZRO.VPOCHA,IKR, 650 : & MZYP.VPOCHA,IZDS.VPOCHA,IZDK.VPOCHA,IZDE.VPOCHA,NBINC) 651 : 652 : ENDIF 653 : 654 : SEGSUP IZFFM,IZF1,IZHR,IZH2 655 : SEGDES IPT1 656 : NUTOEL=NUTOEL+NBEL 657 : 658 : 1 CONTINUE 659 : 660 : IF(KFORM.EQ.1)THEN 661 : 662 : IF(IKEL.EQ.0)THEN 663 : DO 124 I=1,NPTS 664 : MZUE.VPOCHA(I,1)=IZDS.VPOCHA(I,1)/IZD.VPOCHA(I,1) 665 : 124 CONTINUE 666 : ENDIF 667 : 668 : IF(NBINC.EQ.3)THEN 669 : DO 125 I=1,NPTS 670 : IZGG2.VPOCHA(I,1)=IZDK.VPOCHA(I,1)/IZD.VPOCHA(I,1) 671 : IZGG2.VPOCHA(I,2)=IZDE.VPOCHA(I,1)/IZD.VPOCHA(I,1) 672 : 125 CONTINUE 673 : ENDIF 674 : 675 : ENDIF 676 : 677 : SEGSUP IZDS 678 : IF(KFORM.EQ.1.AND.NBINC.EQ.3)THEN 679 : SEGSUP IZDE,IZDK 680 : ENDIF 681 : IF(IKRS.EQ.0)SEGSUP MZRO 682 : SEGDES IZTU1 683 : SEGDES IZG1,IZGG1 684 : IF(NBINC.EQ.3)SEGDES IZG2,IZGG2 685 : SEGDES IZVOL 686 : SEGDES LINCO 687 : SEGSUP MLENTI,IPADS 688 : 689 : NRIGE=7 690 : NKID =9 691 : NKMT =7 692 : NMATRI=0 693 : SEGINI MATRIK 694 : 695 : IF(NBINC.GT.1)THEN 696 : IF(KCLIM.EQ.0)THEN 696 : CALL ECMO(MTAB1,'CLIM','CHPOINT',IZG2) 697 : ELSE 697 : CALL ECROBJ('CHPOINT',KCLIM) 697 : CALL ECROBJ('CHPOINT',IZG2) 697 : CALL PRFUSE 697 : CALL LIROBJ('CHPOINT',MCHPOI,1,IRET) 697 : CALL ECMO(MTAB1,'CLIM','CHPOINT',MCHPOI) 698 : ENDIF 699 : ENDIF 700 : 700 : CALL ECROBJ('MATRIK',MATRIK) 700 : CALL ECROBJ('CHPOINT',IZG1) 701 : 702 : c write(6,*)' Fin FPU' 703 : RETURN 704 : 90 CONTINUE 705 : WRITE(6,*)' Interuption anormale de FPU ' 706 : RETURN 707 : 1001 FORMAT(20(1X,I5)) 708 : 1002 FORMAT(10(1X,1PE11.4)) 709 : END 710 : 711 : 712 : 713 : 714 : 715 :
© Cast3M 2003 - All rights reserved.
Disclaimer