1 : C SYM4D3 SOURCE FANDEUR 13/01/29 21:16:30 7683 2 : C NOR4D3 SOURCE PV 09/03/12 21:29:31 6325 3 : SUBROUTINE SYM4D3( 4 : & MELEFA,MELEFL,MLECEN,MELEFP,MLESOM,MPONOR, 5 : & MPOSUR,MELTFA,MLEFA,MLEFA2,MPOTEN,MPOCHP,MLENCL, 6 : & MPOVCL,ICHTE,ICHCL,ICHCO,MPOVCO,IOP, 7 : & IPO2,SCMB,INDLI,VAL1,VAL2,IND22,IND2,IND, 8 : & IPO3,TAB,MPOGRA,MELVA1,MELVA2, 9 : & NSOMM,NBMAX,NBFAC,NBCOT,MCHEL2,MCHAM2) 10 : C 11 : C PROJET : CASTEM 2000 12 : C 13 : C NOM : NORV4 14 : C 15 : C DESCRIPTION : Appelle par NORV1 16 : C 17 : C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec extensions CISI) 18 : C 19 : C AUTEUR : C. LE POTIER, DM2S/SFME/MTMS 20 : C 21 : C************************************************************************ 22 : C 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT real*8 (a-h,o-z) 25 : -INC SMLENTI 26 : -INC SMELEME 27 : -INC SMCHPOI 28 : -INC CCOPTIO 29 : -INC SMCOORD 30 : -INC SMLREEL 31 : POINTEUR MELEFL.MELEME, MELEFP.MELEME, MELEFA.MELEME, 32 : & MELTFA.MELEME,MELEP2.MELEME 33 : POINTEUR MPOSUR.MPOVAL, MPONOR.MPOVAL, 34 : & MPOCHP.MPOVAL, MPOVCL.MPOVAL, MPGSOM.MPOVAL, MPVOSO.MPOVAL, 35 : & MPOGRA.MPOVAL,MPOTEN.MPOVAL,MPOVCO.MPOVAL 36 : POINTEUR MLENCL.MLENTI, MLECEN.MLENTI, MLESOM.MLENTI, 37 : & MLEFA.MLENTI,MLEFA2.MLENTI 38 : -INC SMCHAML 39 : INTEGER NBNN,NBREF,NBMAX 40 : 41 : 42 : 43 : C 44 : C**** Variables de COOPTIO 45 : C 46 : C 47 : C**** Variables de COOPTIO 48 : C 49 : INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 50 : & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 51 : & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 52 : & ,IECHO, IIMPI, IOSPI 53 : & ,IDIM 54 : C & ,MCOORD 55 : & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 56 : & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 57 : & ,NORINC,NORVAL,NORIND,NORVAD 58 : & ,NUCROU, IPSAUV 59 : 60 : C**** Variable de SMLENTI, SMCHPOI 61 : C 62 : INTEGER JG, N, NC, NSOUPO, NAT, NBSOUS, NBNO,NBELEM 63 : C 64 : C**** Les includes 65 : C 66 : INTEGER I1,ICOMP,ICOMGR,IGEOM 67 : & ,IOP1,ICEN,ISOMM,IFAC,IFACEL,IFACEP,INORM 68 : & ,ISURF,IMAIL,ICHPO,ICHCL,ICHGRA,ICOEFF 69 : & ,NTOT,NSOMM,NCOMP,NFAC,NCEN 70 : & ,NLCF,NGCF,NGCF1,NGCF2,NGCG,NGCD,NLCG,NLCD,NGS1,NGS2 71 : & ,NLS1,NLS2,NLFCL 72 : & ,ISOUS,IELEM,INOEUD,ICELL,NCON,NFIN,INDGA,INDDR 73 : INTEGER ICEN2 74 : REAL*8 SCNX,SCNY,SCNZ,SURF,VOL,VAL,VALX,VALY,VALZ,XG,XD,XF,XS1,XS2 75 : & ,YG,YD,YF,YS1,YS2,ZG,ZD,ZF,ZS1,ZS2, 76 : & PSCA,XNORM,VECX,VECY,PSCAGX,PSCAGY,PSCAGZ, 77 : & PSCADX,PSCADY,PSCADZ,K11G,K22G,K21G,K31G,K32G,K33G, 78 : & K11D,K22D,K21D,K31D,K32D,K33D,VXG1,VXG2, 79 : & VXAU,VYAU,VZAU,VXD1,VXD2,VYG1,VYG2,VYD1,VYD2,VZG1,VZG2,VZD1,VZD2, 80 : & TRG1,TRG2,TRG3, 81 : & TRD1,TRD2,TRD3,TRG,TRD,AUX,AUY,AUZ,AUXMA,THETA,COEFDD 82 : REAL*8 XLONG,AG1,AG2,AD1,AD2,PSCAG1,PSCAG2,PSCAD1,PSCAD2, 83 : & COEF1,COEF2,COEF3,COEF4,SCN1X,SCN1Y,SCN1Z,VX,VY,VZ,COEF1X,COEF2X, 84 : & COEF1Y,COEF2Y,COEF1Z,COEF2Z,CX,CY,CZ,ANCX,ANCY,ANCZ, 85 : & DIFFX,DIFFY,DIFFZ,XLONGG,XLONGD 86 : & VALD,VALG,COEF,GX,GY,GZ,UN,EXPR1,EXPR2 87 : 88 : c REAL*8 VECXG1(2),VECYG1(2) 89 : c REAL*8 VECXG2(2),VECYG2(2) 90 : c REAL*8 VECXD1(2),VECYD1(2) 91 : c REAL*8 VECXD2(2),VECYD2(2) 92 : 93 : REAL*8 VECXG(4,4),VECYG(4,4),VECZG(4,4) 94 : REAL*8 VECXD(4,4),VECYD(4,4),VECZD(4,4) 95 : REAL*8 VOLUG(4),SURFAGX(4),SURFAGY(4),SURFAGZ(4),COEFG(4) 96 : REAL*8 VOLUD(4),SURFADX(4),SURFADY(4),SURFADZ(4),COEFD(4) 97 : REAL*8 PX(3,4),PY(3,4),PZ(3,4),TRGAUX(4) 98 : REAL*8 XPRO,TRACE 99 : INTEGER NGS(4),NLS(4) 100 : INTEGER NLOCFG(4,4),NLOCFD(4,4) 101 : INTEGER IGNS(4) 102 : REAL*8 EPS,ALPHA 103 : REAL*8 XARG(4,4),YARG(4,4),ZARG(4,4),XCOUR,YCOUR,ZCOUR 104 : REAL*8 XFACG(4,4),YFACG(4,4),ZFACG(4,4),VAX,VAY,VAZ 105 : REAL*8 XARD(4,4),YARD(4,4),ZARD(4,4),XCO,YCO,ZCO 106 : REAL*8 XFACD(4,4),YFACD(4,4),ZFACD(4,4) 107 : REAL*8 XA,YA,ZA,DIST1,DIST2 108 : REAL*8 VAUX(3),VAUY(3),VAUZ(3) 109 : REAL*8 PVECX,PVECY,PVECZ 110 : INTEGER ICRIT 111 : CHARACTER*(4) NOMCOM(3) 112 : CHARACTER*8 TYPE 113 : C 114 : DATA NOMCOM /'P1DX','P1DY','P1DZ'/ 115 : 116 : INTEGER NDIM 117 : SEGMENT MMAT1 118 : REAL*8 PM(NDIM,NDIM),PM1(NDIM,NDIM),XSOL(NDIM) 119 : INTEGER IC(NDIM) 120 : ENDSEGMENT 121 : 122 : INTEGER K1,K2 123 : SEGMENT INDICE 124 : INTEGER NUME(K1,K2) 125 : ENDSEGMENT 126 : POINTEUR IND.INDICE,IND2.INDICE,IND22.INDICE 127 : 128 : SEGMENT MATRICE 129 : REAL*8 MAT(K1,K2) 130 : ENDSEGMENT 131 : POINTEUR VAL1.MATRICE,VAL2.MATRICE,SCMB.MATRICE 132 : 133 : INTEGER K3 134 : SEGMENT POINT2 135 : INTEGER POINT(K3) 136 : ENDSEGMENT 137 : POINTEUR IPO2.POINT2 138 : 139 : SEGMENT MATRICE2 140 : REAL*8 MAT2(K1,K2) 141 : ENDSEGMENT 142 : POINTEUR MATR1.MATRICE2,MATR2.MATRICE2 143 : 144 : SEGMENT POINT3 145 : INTEGER POINT33(K3) 146 : ENDSEGMENT 147 : POINTEUR IPO3.POINT3 148 : 149 : SEGMENT INDICE3 150 : INTEGER NU(K1,K2) 151 : ENDSEGMENT 152 : POINTEUR INDIC.INDICE3 153 : 154 : SEGMENT REP 155 : INTEGER ID(K3) 156 : ENDSEGMENT 157 : POINTEUR TAB.REP,INDLI.REP 158 : 159 : INTEGER K5 160 : SEGMENT NBFAC 161 : INTEGER NBFACEL(K5) 162 : INTEGER IMELEM(K5) 163 : ENDSEGMENT 164 : 165 : INTEGER K6 166 : SEGMENT NBCOT 167 : INTEGER NBCOTE(K6) 168 : INTEGER IMECOTE(K6) 169 : ENDSEGMENT 170 : 171 : INTEGER K7,K8 172 : SEGMENT MISZERO 173 : INTEGER TABL(K7) 174 : INTEGER TABL2(K7) 175 : INTEGER TABL1(K8),IPOS(K8),ICOURANT(K8) 176 : REAL*8 XMAX(K7) 177 : ENDSEGMENT 178 : POINTEUR ITAB.MISZERO 179 : 180 : 181 : 182 : 183 : c ALPHA = 2.0/3.0 184 : ALPHA = 2.0/3.0 185 : NMAI1 = 0 186 : NMAI2 = 0 187 : NMAI3 = 0 188 : NMAI4 = 0 189 : NBSO = MAX(1,MELTFA.LISOUS(/1)) 190 : c WRITE(6,*) 'NBSO MAILLE= ',NBSO 191 : c WRITE(6,*) 'MELTFA= ',MELTFA 192 : IELTFA = MELTFA 193 : IF (NBSO.EQ.1) THEN 194 : K5 = MELTFA.NUM(/2) 195 : ELSEIF (NBSO.EQ.2) THEN 196 : IPT1 = MELTFA.LISOUS(1) 197 : SEGACT IPT1 198 : N1 = IPT1.NUM(/2) 199 : NMAI1 = N1 200 : SEGDES IPT1 201 : IPT2 = MELTFA.LISOUS(2) 202 : SEGACT IPT2 203 : N2 = IPT2.NUM(/2) 204 : NMAI2 = N2 205 : SEGDES IPT2 206 : K5 = N1 + N2 207 : ELSEIF (NBSO.EQ.3) THEN 208 : IPT1 = MELTFA.LISOUS(1) 209 : SEGACT IPT1 210 : N1 = IPT1.NUM(/2) 211 : NMAI1 = N1 212 : SEGDES IPT1 213 : c WRITE(6,*) 'N1= ',N1 214 : IPT2 = MELTFA.LISOUS(2) 215 : SEGACT IPT2 216 : N2 = IPT2.NUM(/2) 217 : NMAI2 = N2 218 : SEGDES IPT2 219 : c WRITE(6,*) 'N2= ',N2 220 : IPT3 = MELTFA.LISOUS(3) 221 : SEGACT IPT3 222 : N3 = IPT3.NUM(/2) 223 : NMAI3 = N3 224 : c WRITE(6,*) 'N3= ',N3 225 : SEGDES IPT3 226 : K5 = N1 + N2 + N3 227 : ELSEIF (NBSO.EQ.4) THEN 228 : IPT1 = MELTFA.LISOUS(1) 229 : SEGACT IPT1 230 : N1 = IPT1.NUM(/2) 231 : NMAI1 = N1 232 : SEGDES IPT1 233 : IPT2 = MELTFA.LISOUS(2) 234 : SEGACT IPT2 235 : N2 = IPT2.NUM(/2) 236 : NMAI2 = N2 237 : SEGDES IPT2 238 : IPT3 = MELTFA.LISOUS(3) 239 : SEGACT IPT3 240 : N3 = IPT3.NUM(/2) 241 : NMAI3 = N3 242 : SEGDES IPT3 243 : IPT4 = MELTFA.LISOUS(4) 244 : SEGACT IPT4 245 : N4 = IPT4.NUM(/2) 246 : NMAI4 = N4 247 : SEGDES IPT4 248 : K5 = N1 + N2 + N3 + N4 249 : ENDIF 250 : c WRITE(6,*) 'K5= ',K5 251 : 252 : 253 : 254 : IF (NBSO.EQ.1) THEN 255 : DO I = 1,K5 256 : NTYPE = MELTFA.ITYPEL 257 : c WRITE(6,*) 'NTYPE= ',NTYPE 258 : IF (NTYPE .EQ. 16) THEN 259 : NBFACEL(I) = 6 260 : IMELEM(I) = MELTFA 261 : ELSEIF (NTYPE .EQ. 25) THEN 262 : NBFACEL(I) = 5 263 : IMELEM(I) = MELTFA 264 : ELSEIF (NTYPE .EQ. 23) THEN 265 : NBFACEL(I) = 4 266 : IMELEM(I) = MELTFA 267 : ELSEIF (NTYPE .EQ. 9) THEN 268 : NBFACEL(I) = 5 269 : IMELEM(I) = MELTFA 270 : ENDIF 271 : c SEGDES MELTFA 272 : ENDDO 273 : ELSEIF (NBSO.EQ.2) THEN 274 : IPT1 = MELTFA.LISOUS(1) 275 : SEGACT IPT1 276 : IPT2 = MELTFA.LISOUS(2) 277 : SEGACT IPT2 278 : DO I = 1,K5 279 : N1 = IPT1.NUM(/2) 280 : IF (I.LE.N1) THEN 281 : NTYPE = IPT1.ITYPEL 282 : IF (NTYPE .EQ. 16) THEN 283 : NBFACEL(I) = 6 284 : IMELEM(I) = IPT1 285 : ELSEIF (NTYPE .EQ. 25) THEN 286 : NBFACEL(I) = 5 287 : IMELEM(I) = IPT1 288 : ELSEIF (NTYPE .EQ. 23) THEN 289 : NBFACEL(I) = 4 290 : IMELEM(I) = IPT1 291 : ELSEIF (NTYPE .EQ. 9) THEN 292 : NBFACEL(I) = 5 293 : IMELEM(I) = IPT1 294 : ENDIF 295 : ELSE 296 : NTYPE = IPT2.ITYPEL 297 : IF (NTYPE .EQ. 16) THEN 298 : NBFACEL(I) = 6 299 : IMELEM(I) = IPT2 300 : ELSEIF (NTYPE .EQ. 25) THEN 301 : NBFACEL(I) = 5 302 : IMELEM(I) = IPT2 303 : ELSEIF (NTYPE .EQ. 23) THEN 304 : NBFACEL(I) = 4 305 : IMELEM(I) = IPT2 306 : ELSEIF (NTYPE .EQ. 9) THEN 307 : NBFACEL(I) = 5 308 : IMELEM(I) = IPT2 309 : ENDIF 310 : ENDIF 311 : ENDDO 312 : ELSEIF (NBSO.EQ.3) THEN 313 : c WRITE(6,*) 'COUCOU' 314 : IPT1 = MELTFA.LISOUS(1) 315 : SEGACT IPT1 316 : NTYPE = IPT1.ITYPEL 317 : c WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL 318 : IPT2 = MELTFA.LISOUS(2) 319 : SEGACT IPT2 320 : NTYPE = IPT2.ITYPEL 321 : c WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL 322 : IPT3 = MELTFA.LISOUS(3) 323 : SEGACT IPT3 324 : NTYPE = IPT3.ITYPEL 325 : c WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL 326 : N1 = IPT1.NUM(/2) 327 : N2 = IPT2.NUM(/2) 328 : N3 = IPT3.NUM(/2) 329 : DO I = 1,K5 330 : IF (I.LE.N1) THEN 331 : NTYPE = IPT1.ITYPEL 332 : IF (NTYPE .EQ. 16) THEN 333 : NBFACEL(I) = 6 334 : IMELEM(I) = IPT1 335 : ELSEIF (NTYPE .EQ. 25) THEN 336 : NBFACEL(I) = 5 337 : IMELEM(I) = IPT1 338 : ELSEIF (NTYPE .EQ. 23) THEN 339 : NBFACEL(I) = 4 340 : IMELEM(I) = IPT1 341 : ELSEIF (NTYPE .EQ. 9) THEN 342 : NBFACEL(I) = 5 343 : IMELEM(I) = IPT1 344 : ENDIF 345 : ELSEIF (I.LE.(N1+N2)) THEN 346 : NTYPE = IPT2.ITYPEL 347 : IF (NTYPE .EQ. 16) THEN 348 : NBFACEL(I) = 6 349 : IMELEM(I) = IPT2 350 : ELSEIF (NTYPE .EQ. 25) THEN 351 : NBFACEL(I) = 5 352 : IMELEM(I) = IPT2 353 : ELSEIF (NTYPE .EQ. 23) THEN 354 : NBFACEL(I) = 4 355 : IMELEM(I) = IPT2 356 : ELSEIF (NTYPE .EQ. 9) THEN 357 : NBFACEL(I) = 5 358 : IMELEM(I) = IPT2 359 : ENDIF 360 : ELSE 361 : NTYPE = IPT3.ITYPEL 362 : IF (NTYPE .EQ. 16) THEN 363 : NBFACEL(I) = 6 364 : IMELEM(I) = IPT3 365 : ELSEIF (NTYPE .EQ. 25) THEN 366 : NBFACEL(I) = 5 367 : IMELEM(I) = IPT3 368 : ELSEIF (NTYPE .EQ. 23) THEN 369 : NBFACEL(I) = 4 370 : IMELEM(I) = IPT3 371 : ELSEIF (NTYPE .EQ. 9) THEN 372 : NBFACEL(I) = 5 373 : IMELEM(I) = IPT3 374 : ENDIF 375 : ENDIF 376 : ENDDO 377 : ELSEIF (NBSO.EQ.4) THEN 378 : IPT1 = MELTFA.LISOUS(1) 379 : SEGACT IPT1 380 : NTYPE = IPT1.ITYPEL 381 : c WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL 382 : IPT2 = MELTFA.LISOUS(2) 383 : SEGACT IPT2 384 : NTYPE = IPT2.ITYPEL 385 : c WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL 386 : IPT3 = MELTFA.LISOUS(3) 387 : SEGACT IPT3 388 : NTYPE = IPT3.ITYPEL 389 : c WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL 390 : IPT4 = MELTFA.LISOUS(4) 391 : SEGACT IPT4 392 : NTYPE = IPT4.ITYPEL 393 : c WRITE(6,*) 'NTYPE= ',IPT4.ITYPEL 394 : N1 = IPT1.NUM(/2) 395 : N2 = IPT2.NUM(/2) 396 : N3 = IPT3.NUM(/2) 397 : N4 = IPT4.NUM(/2) 398 : DO I = 1,K5 399 : IF (I.LE.N1) THEN 400 : NTYPE = IPT1.ITYPEL 401 : IF (NTYPE .EQ. 16) THEN 402 : NBFACEL(I) = 6 403 : IMELEM(I) = IPT1 404 : ELSEIF (NTYPE .EQ. 25) THEN 405 : NBFACEL(I) = 5 406 : IMELEM(I) = IPT1 407 : ELSEIF (NTYPE .EQ. 23) THEN 408 : NBFACEL(I) = 4 409 : IMELEM(I) = IPT1 410 : ELSEIF (NTYPE .EQ. 9) THEN 411 : NBFACEL(I) = 5 412 : IMELEM(I) = IPT1 413 : ENDIF 414 : ELSEIF (I.LE.(N1+N2)) THEN 415 : NTYPE = IPT2.ITYPEL 416 : IF (NTYPE .EQ. 16) THEN 417 : NBFACEL(I) = 6 418 : IMELEM(I) = IPT2 419 : ELSEIF (NTYPE .EQ. 25) THEN 420 : NBFACEL(I) = 5 421 : IMELEM(I) = IPT2 422 : ELSEIF (NTYPE .EQ. 23) THEN 423 : NBFACEL(I) = 4 424 : IMELEM(I) = IPT2 425 : ELSEIF (NTYPE .EQ. 9) THEN 426 : NBFACEL(I) = 5 427 : IMELEM(I) = IPT2 428 : ENDIF 429 : ELSEIF (I.LE.(N1+N2+N3)) THEN 430 : NTYPE = IPT3.ITYPEL 431 : IF (NTYPE .EQ. 16) THEN 432 : NBFACEL(I) = 6 433 : IMELEM(I) = IPT3 434 : ELSEIF (NTYPE .EQ. 25) THEN 435 : NBFACEL(I) = 5 436 : IMELEM(I) = IPT3 437 : ELSEIF (NTYPE .EQ. 23) THEN 438 : NBFACEL(I) = 4 439 : IMELEM(I) = IPT3 440 : ELSEIF (NTYPE .EQ. 9) THEN 441 : NBFACEL(I) = 5 442 : IMELEM(I) = IPT3 443 : ENDIF 444 : ELSE 445 : NTYPE = IPT4.ITYPEL 446 : IF (NTYPE .EQ. 16) THEN 447 : NBFACEL(I) = 6 448 : IMELEM(I) = IPT4 449 : ELSEIF (NTYPE .EQ. 25) THEN 450 : NBFACEL(I) = 5 451 : IMELEM(I) = IPT4 452 : ELSEIF (NTYPE .EQ. 23) THEN 453 : NBFACEL(I) = 4 454 : IMELEM(I) = IPT4 455 : ELSEIF (NTYPE .EQ. 9) THEN 456 : NBFACEL(I) = 5 457 : IMELEM(I) = IPT4 458 : ENDIF 459 : ENDIF 460 : ENDDO 461 : ENDIF 462 : 463 : c CAS OU LES FACES SONT DES TRIANGLES OU DES FACES 464 : MAUX = MELEFP 465 : NFAI1 = 0 466 : NBSOF = MAX(1,MELEFP.LISOUS(/1)) 467 : c WRITE(6,*) 'NBSOF FACE= ',NBSOF 468 : IELTFA = MELTFA 469 : IF (NBSOF.EQ.1) THEN 470 : K6 = MELEFP.NUM(/2) 471 : ELSEIF (NBSOF.EQ.2) THEN 472 : IPT5 = MELEFP.LISOUS(1) 473 : SEGACT IPT5 474 : N1 = IPT5.NUM(/2) 475 : NFAI1 = N1 476 : SEGDES IPT5 477 : IPT6 = MELEFP.LISOUS(2) 478 : SEGACT IPT6 479 : N2 = IPT6.NUM(/2) 480 : NFAI2 = N2 481 : SEGDES IPT6 482 : K6 = N1 + N2 483 : ENDIF 484 : 485 : C ON EST ICI 486 : IF (NBSOF.EQ.1) THEN 487 : DO I = 1,K6 488 : NTYPE = MELEFP.ITYPEL 489 : c WRITE(6,*) 'NTYPE= ',NTYPE 490 : IF (NTYPE .EQ. 5) THEN 491 : NBCOTE(I) = 3 492 : IMECOTE(I) = MELEFP 493 : ELSE 494 : NBCOTE(I) = 4 495 : IMECOTE(I) = MELEFP 496 : ENDIF 497 : c SEGDES MELTFA 498 : ENDDO 499 : ELSEIF (NBSOF.EQ.2) THEN 500 : c WRITE(6,*) 'POINT2' 501 : IPT5 = MELEFP.LISOUS(1) 502 : SEGACT IPT5 503 : IPT6 = MELEFP.LISOUS(2) 504 : SEGACT IPT6 505 : c WRITE(6,*) 'IPT5= ',IPT5.ITYPEL 506 : c WRITE(6,*) 'IPT6= ',IPT6.ITYPEL 507 : DO I = 1,K6 508 : N1 = IPT5.NUM(/2) 509 : C MISE A JOUR DE MLEFA.LECT 510 : IF (I.LE.N1) THEN 511 : N0 = IPT5.NUM(/1) 512 : NGFAUX = IPT5.NUM(N0,I) 513 : MLEFA2.LECT(NGFAUX) = I 514 : c WRITE(6,*) 'NGFAUX = ',NGFAUX, 515 : c & 'MLEFA2=',MLEFA2.LECT(NGFAUX) 516 : IF (IPT5.ITYPEL .EQ. 5) THEN 517 : NBCOTE(I) = 3 518 : IMECOTE(I) = IPT5 519 : ELSE 520 : NBCOTE(I) = 4 521 : IMECOTE(I) = IPT5 522 : ENDIF 523 : c SEGDES IPT5 524 : ELSE 525 : N0 = IPT6.NUM(/1) 526 : NGFAUX = IPT6.NUM(N0,I-NFAI1) 527 : MLEFA2.LECT(NGFAUX) = I 528 : IF (IPT6.ITYPEL .EQ. 5) THEN 529 : NBCOTE(I) = 3 530 : IMECOTE(I) = IPT6 531 : ELSE 532 : NBCOTE(I) = 4 533 : IMECOTE(I) = IPT6 534 : ENDIF 535 : c SEGDES IPT6 536 : ENDIF 537 : 538 : ENDDO 539 : ENDIF 540 : 541 : 542 : 543 : NFAC=MELEFL.NUM(/2) 544 : 545 : 546 : c ON MAJORE SUPERIEUREMENT NBNN : ON LE REAJUSTERA PAR LA SUITE 547 : NCON = ((2*NBMAX)) + 1 548 : NBNN = NCON 549 : NESSAI = NCON 550 : NBNN = NESSAI 551 : c WRITE(6,*) 'NBMAX= ',NBMAX 552 : c WRITE(6,*) 'NBNN= ',NBNN 553 : c WRITE(6,*) 'NFAC= ',NFAC 554 : 555 : 556 : 557 : C DEFINITION DES PARAMETRES DU CHAMELEM DES COEFFICIENTS 558 : 559 : c INITIALISATION DU CHAMELEM 560 : N1=1 561 : N2=1 562 : c WRITE(6,*) 'N2= ',N2 563 : N3=6 564 : L1=8 565 : SEGINI MCHELM 566 : ICOEFF = MCHELM 567 : MCHELM.TITCHE='Gradient' 568 : MCHELM.IFOCHE=IFOUR 569 : C 570 : ISOUS=0 571 : NBSOUS=0 572 : NBREF=0 573 : NBELEM = NFAC 574 : ISOUS=ISOUS+1 575 : SEGINI MELEME 576 : C ITYPEL=32 -> 'POLY' 577 : ITYPEL=32 578 : MCHELM.IMACHE(ISOUS)=MELEME 579 : SEGINI MCHAML 580 : MCHELM.ICHAML(ISOUS)=MCHAML 581 : MCHAML.NOMCHE(1)='SCAL' 582 : MCHAML.TYPCHE(1)='REAL*8 ' 583 : N1PTEL=NESSAI 584 : N1EL=NBELEM 585 : N2PTEL=0 586 : N2EL=0 587 : SEGINI MELVA1 588 : MCHAML.IELVAL(1)=MELVA1 589 : 590 : 591 : 592 : 593 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 594 : C CALCUL DE LA VITESSE EN CHAQUE FACE 595 : AA = 0.0 596 : BB = 0.0 597 : C INDICE QUI COMPTE LES COEFFICIENTS POUR CHAQUE FACE 598 : NAUX2 = 0 599 : NMOY = 0 600 : DO NLCF= 1, NFAC, 1 601 : NCON = 1 602 : 603 : NGCF=MELEFL.NUM(2,NLCF) 604 : NGCG=MELEFL.NUM(1,NLCF) 605 : NGCD=MELEFL.NUM(3,NLCF) 606 : NLCG=MLECEN.LECT(NGCG) 607 : NLCD=MLECEN.LECT(NGCD) 608 : 609 : SCNX=MPONOR.VPOCHA(NLCF,1) 610 : SCNY=MPONOR.VPOCHA(NLCF,2) 611 : SCNZ=MPONOR.VPOCHA(NLCF,3) 612 : SCN1X = SCNX 613 : SCN1Y = SCNY 614 : SCN1Z = SCNZ 615 : SURF=0.5D0*MPOSUR.VPOCHA(NLCF,1) 616 : SCNX=SCNX*SURF 617 : SCNY=SCNY*SURF 618 : SCNZ=SCNZ*SURF 619 : 620 : C 4=IDIM+1 621 : ICELL=(4*(NGCG -1))+1 622 : XG=MCOORD.XCOOR(ICELL) 623 : YG=MCOORD.XCOOR(ICELL+1) 624 : ZG=MCOORD.XCOOR(ICELL+2) 625 : ICELL=(4*(NGCD -1))+1 626 : XD=MCOORD.XCOOR(ICELL) 627 : YD=MCOORD.XCOOR(ICELL+1) 628 : ZD=MCOORD.XCOOR(ICELL+2) 629 : ICELL=(4*(NGCF -1))+1 630 : XF=MCOORD.XCOOR(ICELL) 631 : YF=MCOORD.XCOOR(ICELL+1) 632 : ZF=MCOORD.XCOOR(ICELL+2) 633 : 634 : 635 : MELEME.NUM(1,NLCF)=NGCF 636 : MELVA1.VELCHE(1,NLCF)=0.0D0 637 : 638 : DO J= 1,NBNN 639 : MELVA1.VELCHE(J,NLCF) = 0.0D0 640 : ENDDO 641 : 642 : C MISE A ZERO DE NLOC 643 : DO JA=1,4 644 : DO IA=1,3 645 : NLOCFG(IA,JA) = 0 646 : NLOCFD(IA,JA) = 0 647 : ENDDO 648 : ENDDO 649 : 650 : 651 : MELTFA = IMELEM(NLCG) 652 : NBF = NBFACEL(NLCG) 653 : IF (NLCG.LE.NMAI1) THEN 654 : NGAUX = NLCG 655 : ELSEIF ((NLCG.GT.NMAI1).AND.(NLCG.LE.(NMAI1+NMAI2))) THEN 656 : NGAUX = NLCG - NMAI1 657 : ELSEIF ((NLCG.GT.(NMAI1+NMAI2)).AND. 658 : & (NLCG.LE.(NMAI1+NMAI2+NMAI3))) THEN 659 : NGAUX = NLCG - (NMAI1+NMAI2) 660 : ELSEIF (NLCG.GT.(NMAI1+NMAI2+NMAI3)) THEN 661 : NGAUX = NLCG - (NMAI1+NMAI2+NMAI3) 662 : ENDIF 663 : 664 : 665 : 666 : c ON TIENT COMPTE DU CHANGEMENT DE NUMEROTATION 667 : 668 : 669 : 670 : NLCF1 = MLEFA2.LECT(NGCF) 671 : NBNO = NBCOTE(NLCF1) 672 : MELEFP = IMECOTE(NLCF1) 673 : IF (NLCF1.GT.NFAI1) THEN 674 : NLCF1AUX = NLCF1 - NFAI1 675 : ELSE 676 : NLCF1AUX = NLCF1 677 : ENDIF 678 : 679 : 680 : DO IA=1,NBNO 681 : NGS(IA) = MELEFP.NUM(IA,NLCF1AUX) 682 : NLS(IA) = MLESOM.LECT(NGS(IA)) 683 : ICELL=(4*(NGS(IA) -1))+1 684 : ENDDO 685 : 686 : DO JA = 1,NBNO 687 : NGS(JA) = MELEFP.NUM(JA,NLCF1AUX) 688 : ICELL=(4*(NGS(JA) -1))+1 689 : XA = MCOORD.XCOOR(ICELL) 690 : YA = MCOORD.XCOOR(ICELL+1) 691 : ZA = MCOORD.XCOOR(ICELL+2) 692 : 693 : 694 : C ON CALCULE P2 ET P3, VOIR RAPPORT PAGE 17 695 : DIST2 = -100000000000. 696 : Con CALCULE LE PLUS GRAND 697 : DO I1 =1,NBNO 698 : NSOM1 = MELEFP.NUM(I1,NLCF1AUX) 699 : ICELL=(4*(NSOM1 -1))+1 700 : XCOUR=MCOORD.XCOOR(ICELL) 701 : YCOUR=MCOORD.XCOOR(ICELL+1) 702 : ZCOUR=MCOORD.XCOOR(ICELL+2) 703 : DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) 704 : DIST1 = SQRT( DIST1) 705 : IF ((DIST1.GT.DIST2)) THEN 706 : DIST2 = DIST1 707 : ICOURAN = I1 708 : ENDIF 709 : ENDDO 710 : 711 : IF (JA.EQ.1) ICOURAN=3 712 : IF (JA.EQ.2) ICOURAN=4 713 : IF (JA.EQ.3) ICOURAN=1 714 : IF (JA.EQ.4) ICOURAN=2 715 : 716 : IF (NBNO.EQ.3) THEN 717 : ICOURAN = 0 718 : ENDIF 719 : 720 : 721 : INDFAC=2 722 : c WRITE(6,*) 'ICOURAN= ',ICOURAN 723 : c WRITE(6,*) 'JA= ',JA 724 : DO I1 =1,NBNO 725 : NSOM1 = MELEFP.NUM(I1,NLCF1AUX) 726 : ICELL=(4*(NSOM1 -1))+1 727 : XCOUR=MCOORD.XCOOR(ICELL) 728 : YCOUR=MCOORD.XCOOR(ICELL+1) 729 : ZCOUR=MCOORD.XCOOR(ICELL+2) 730 : 731 : IF ((I1.NE.ICOURAN).AND.(I1.NE.JA)) THEN 732 : XARG(INDFAC,JA) = 0.5D0*(XA+XCOUR) 733 : YARG(INDFAC,JA) = 0.5D0*(YA+YCOUR) 734 : ZARG(INDFAC,JA) = 0.5D0*(ZA+ZCOUR) 735 : c WRITE(6,*) 'X= ',XARG(INDFAC,JA), 736 : c & 'Y= ',YARG(INDFAC,JA),'Z= ',ZARG(INDFAC,JA) 737 : c WRITE(6,*) 'XA= ',XA, 738 : c & 'YA= ',YA,'ZA= ',ZA 739 : c WRITE(6,*) 'XCOUR= ',XCOUR, 740 : c & 'YCOUR= ',YCOUR,'ZCOUR= ',ZCOUR 741 : INDFAC= INDFAC+1 742 : ENDIF 743 : ENDDO 744 : 745 : c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA 746 : c WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', 747 : c & ZARG(2,JA) 748 : c WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', 749 : c & ZARG(3,JA) 750 : c WRITE(6,*) 'D', 'X= ',XF,'Y= ',YF,'Z= ',ZF 751 : 752 : 753 : c IF (NLCF.EQ.14) then 754 : c WRITE(6,*) 'NGAUX= ',NGAUX,'JA= ',JA,'NGS= ',NGS(JA) 755 : c WRITE(6,*) 'NGCF= ',NGCF,'NLCF= ',NLCF 756 : c ENDIF 757 : 758 : ICOUR = 1 759 : DO J = 1,NBF 760 : N1 = MELTFA.NUM(J,NGAUX) 761 : NL1 = MLEFA2.LECT(N1) 762 : NBNO2 = NBCOTE(NL1) 763 : MELEP2 = IMECOTE(NL1) 764 : IF (NL1.GT.NFAI1) THEN 765 : NL1AUX = NL1 - NFAI1 766 : ELSE 767 : NL1AUX = NL1 768 : ENDIF 769 : c IF (NLCF.EQ.14) then 770 : c WRITE(6,*) 'N1= ',N1,'NL1= ',NL1,'NL1AUX= ',NL1AUX 771 : c ENDIF 772 : 773 : 774 : 775 : 776 : 777 : DO IA =1,NBNO2 778 : NSOM1 = MELEP2.NUM(IA,NL1AUX) 779 : 780 : 781 : 782 : c IF (NLCF.EQ.14) then 783 : c WRITE(6,*) 'NBNO2= ',NBNO2,'IA= ',IA,'NSOM1= ',NSOM1 784 : c ENDIF 785 : IF (NSOM1.EQ.NGS(JA)) THEN 786 : 787 : ICELL=(4*(N1 -1))+1 788 : XF=MCOORD.XCOOR(ICELL) 789 : YF=MCOORD.XCOOR(ICELL+1) 790 : ZF=MCOORD.XCOOR(ICELL+2) 791 : 792 : 793 : 794 : C ON CALCULE P1 VOIR RAPPORT p 17 795 : IF (N1.NE.NGCF) THEN 796 : ICOUR = ICOUR + 1 797 : VECXG(ICOUR,JA) = (XF - XG) 798 : VECYG(ICOUR,JA) = (YF - YG) 799 : VECZG(ICOUR,JA) = (ZF - ZG) 800 : NLOCFG(ICOUR,JA) = N1 801 : XFACG(ICOUR,JA) = XF 802 : YFACG(ICOUR,JA) = YF 803 : ZFACG(ICOUR,JA) = ZF 804 : 805 : DIST2 = -1.e+15 806 : DO I1 =1,NBNO2 807 : NSOM1 = MELEP2.NUM(I1,NL1AUX) 808 : ICELL=(4*(NSOM1 -1))+1 809 : XCOUR=MCOORD.XCOOR(ICELL) 810 : YCOUR=MCOORD.XCOOR(ICELL+1) 811 : ZCOUR=MCOORD.XCOOR(ICELL+2) 812 : DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) 813 : DIST1 = SQRT( DIST1) 814 : IF ((DIST1.GT.DIST2)) THEN 815 : DIST2 = DIST1 816 : ICOURAN = I1 817 : ENDIF 818 : ENDDO 819 : IF (IA.EQ.1) ICOURAN=3 820 : IF (IA.EQ.2) ICOURAN=4 821 : IF (IA.EQ.3) ICOURAN=1 822 : IF (IA.EQ.4) ICOURAN=2 823 : IF (NBNO2.EQ.3) THEN 824 : ICOURAN = 0 825 : ENDIF 826 : 827 : 828 : DO I1 =1,NBNO2 829 : NSOM1 = MELEP2.NUM(I1,NL1AUX) 830 : ICELL=(4*(NSOM1 -1))+1 831 : XCOUR=MCOORD.XCOOR(ICELL) 832 : YCOUR=MCOORD.XCOOR(ICELL+1) 833 : ZCOUR=MCOORD.XCOOR(ICELL+2) 834 : XCO = 0.5D0*(XCOUR + XA) 835 : YCO = 0.5D0*(YCOUR + YA) 836 : ZCO = 0.5D0*(ZCOUR + ZA) 837 : DIST1 = ((XCO-XARG(2,JA))**2) + 838 : & ((YCO-YARG(2,JA))**2) + 839 : & ((ZCO-ZARG(2,JA))**2) 840 : DIST1 = SQRT(DIST1) 841 : 842 : IF (DIST1.LT.1e-5) THEN 843 : VAX = XARG(ICOUR,JA) 844 : VAY = YARG(ICOUR,JA) 845 : VAZ = ZARG(ICOUR,JA) 846 : C CHANGEMENT INDICE 847 : XARG(ICOUR,JA) = XCO 848 : YARG(ICOUR,JA) = YCO 849 : ZARG(ICOUR,JA) = ZCO 850 : XARG(2,JA) = VAX 851 : YARG(2,JA) = VAY 852 : ZARG(2,JA) = VAZ 853 : ENDIF 854 : 855 : 856 : DIST2 = ((XCO-XARG(3,JA))**2) + 857 : & ((YCO-YARG(3,JA))**2) + 858 : & ((ZCO-ZARG(3,JA))**2) 859 : DIST2 = SQRT(DIST2) 860 : IF (DIST2.LT.1e-5) THEN 861 : VAX = XARG(ICOUR,JA) 862 : VAY = YARG(ICOUR,JA) 863 : VAZ = ZARG(ICOUR,JA) 864 : C CHANGEMENT INDICE 865 : XARG(ICOUR,JA) = XCO 866 : YARG(ICOUR,JA) = YCO 867 : ZARG(ICOUR,JA) = ZCO 868 : XARG(3,JA) = VAX 869 : YARG(3,JA) = VAY 870 : ZARG(3,JA) = VAZ 871 : ENDIF 872 : 873 : INDFAC=1 874 : c ON VERIFIE QUE LE POINT TROUVE EST BIEN DIFFERENT DE P2 ET P3 875 : IF ((I1.NE.ICOURAN).AND.(I1.NE.IA).AND. 876 : & (DIST1.GT.1e-5).AND.(DIST2.GT.1e-5)) THEN 877 : XARG(INDFAC,JA) = XCO 878 : YARG(INDFAC,JA) = YCO 879 : ZARG(INDFAC,JA) = ZCO 880 : c WRITE(6,*) 'JA = ',JA 881 : c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA 882 : c WRITE(6,*) 'P1', 'X= ',XARG(1,JA),'Y= ',YARG(1,JA),'Z= ', 883 : c & ZARG(1,JA) 884 : ENDIF 885 : ENDDO 886 : ENDIF 887 : C ON PERMUTE 888 : C ICI 889 : 890 : IF (N1.EQ.NGCF) THEN 891 : VECXG(1,JA) = (XF - XG) 892 : VECYG(1,JA) = (YF - YG) 893 : VECZG(1,JA) = (ZF - ZG) 894 : XFACG(1,JA) = XF 895 : YFACG(1,JA) = YF 896 : ZFACG(1,JA) = ZF 897 : NLOCFG(1,JA) = N1 898 : ENDIF 899 : ENDIF 900 : ENDDO 901 : ENDDO 902 : c IF (NLCF.EQ.14) THEN 903 : c WRITE(6,*) 'JA= ',JA 904 : c WRITE(6,*) 'ICOUR= ',ICOUR 905 : c ENDIF 906 : ENDDO 907 : 908 : 909 : 910 : C ON REPERE LES VECTEURS PRINCIPAUX DE LA BASE 911 : 912 : 913 : 914 : MPOGRA.VPOCHA(NLCF,1) = 0.D0 915 : DO JA = 1,NBNO 916 : 917 : c CALCUL DU VOLUME : ON SOMME LE VOLUME DES 6 TETRAEDRES 918 : ICELL=(4*(NGS(JA) -1))+1 919 : XA = MCOORD.XCOOR(ICELL) 920 : YA = MCOORD.XCOOR(ICELL+1) 921 : ZA = MCOORD.XCOOR(ICELL+2) 922 : 923 : c WRITE(6,*) 'JA = ',JA 924 : c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA 925 : c WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', 926 : c & ZARG(2,JA) 927 : c WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', 928 : c & ZARG(3,JA) 929 : c WRITE(6,*) 'D', 'X= ',XFACG(1,JA),'Y= ',YFACG(1,JA),'Z= ', 930 : c & ZFACG(1,JA) 931 : c WRITE(6,*) 'B', 'X= ',XFACG(2,JA),'Y= ',YFACG(2,JA),'Z= ', 932 : c & ZFACG(2,JA) 933 : c WRITE(6,*) 'C', 'X= ',XFACG(3,JA),'Y= ',YFACG(3,JA),'Z= ', 934 : c & ZFACG(3,JA) 935 : c WRITE(6,*) 'P1', 'X= ',XARG(1,JA),'Y= ',YARG(1,JA),'Z= ', 936 : c & ZARG(1,JA) 937 : c WRITE(6,*) 'A', 'X= ',XD,'Y= ',YD,'Z= ',ZD 938 : 939 : VAUX(1) = XA - XARG(1,JA) 940 : VAUY(1) = YA - YARG(1,JA) 941 : VAUZ(1) = ZA - ZARG(1,JA) 942 : 943 : VAUX(2) = XA - XARG(2,JA) 944 : VAUY(2) = YA - YARG(2,JA) 945 : VAUZ(2) = ZA - ZARG(2,JA) 946 : 947 : VAUX(3) = XA - XARG(3,JA) 948 : VAUY(3) = YA - YARG(3,JA) 949 : VAUZ(3) = ZA - ZARG(3,JA) 950 : 951 : PVECX = VAUY(2)*VAUZ(3) - VAUZ(2)*VAUY(3) 952 : PVECY = VAUZ(2)*VAUX(3) - VAUX(2)*VAUZ(3) 953 : PVECZ = VAUX(2)*VAUY(3) - VAUY(2)*VAUX(3) 954 : 955 : VOL = 956 : & 1.D0/6.D0*ABS((VAUX(1)*PVECX) + (VAUY(1)*PVECY) + 957 : & (VAUZ(1)*PVECZ)) 958 : 959 : c CALCUL DU PREMIER VOLUME 960 : VOLUG(JA) = VOL 961 : 962 : 963 : DO KA = 1,ICOUR 964 : C PRODUIT MIXTES 965 : C PRODUIT VECTORIEL 966 : 967 : IF (KA.EQ.1) THEN 968 : 969 : VAUX(2) = XA - XARG(2,JA) 970 : VAUY(2) = YA - YARG(2,JA) 971 : VAUZ(2) = ZA - ZARG(2,JA) 972 : 973 : VAUX(3) = XA - XARG(3,JA) 974 : VAUY(3) = YA - YARG(3,JA) 975 : VAUZ(3) = ZA - ZARG(3,JA) 976 : c WRITE(6,*) 'ZA= ',ZA,'ZARG(3)= ',ZARG(3,JA), 977 : c & 'DIFF',ZA - ZARG(3,JA),'VAUXZ3',VAUZ(3) 978 : 979 : 980 : c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA 981 : c WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', 982 : c 983 : c & ZARG(2,JA) 984 : c 985 : c WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', 986 : c & ZARG(3,JA) 987 : c WRITE(6,*) 'D', 'X= ',XFACG(1,JA),'Y= ',YFACG(1,JA),'Z= ', 988 : c & ZFACG(1,JA) 989 : c WRITE(6,*) 'JA = ',JA,'KA=',KA,'VAUX2',VAUX(2), 990 : c & 'VAUY2',VAUY(2),'VAUZ2',VAUZ(2) 991 : c WRITE(6,*) 'ZA= ',ZA,'ZARG(3)= ',ZARG(3,JA), 992 : c & 'DIFF',ZA - ZARG(3,JA),'VAUXZ3',VAUZ(3) 993 : c WRITE(6,*) 'JA = ',JA,'KA=',KA,'VAUX3',VAUX(3), 994 : c & 'VAUY3',VAUY(3),'VAUZ3',VAUZ(3) 995 : PSCAGX = (VAUY(2)*VAUZ(3)) - 996 : & (VAUZ(2)*VAUY(3)) 997 : PSCAGY = (VAUZ(2)*VAUX(3)) - 998 : & (VAUX(2)*VAUZ(3)) 999 : PSCAGZ = (VAUX(2)*VAUY(3)) - 1000 : & (VAUY(2)*VAUX(3)) 1001 : PSCA = (VECXG(1,JA)* PSCAGX) + (VECYG(1,JA)* PSCAGY) + 1002 : & (VECZG(1,JA)* PSCAGZ) 1003 : IF (PSCA.LT.0) THEN 1004 : PSCAGX = - PSCAGX 1005 : PSCAGY = - PSCAGY 1006 : PSCAGZ = - PSCAGZ 1007 : ENDIF 1008 : SURFAGX(KA) = 0.5D0* PSCAGX 1009 : SURFAGY(KA) = 0.5D0* PSCAGY 1010 : SURFAGZ(KA) = 0.5D0* PSCAGZ 1011 : c WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1) 1012 : 1013 : 1014 : ENDIF 1015 : 1016 : IF (KA.EQ.2) THEN 1017 : VAUX(2) = XA - XARG(2,JA) 1018 : VAUY(2) = YA - YARG(2,JA) 1019 : VAUZ(2) = ZA - ZARG(2,JA) 1020 : 1021 : VAUX(3) = XA - XARG(1,JA) 1022 : VAUY(3) = YA - YARG(1,JA) 1023 : VAUZ(3) = ZA - ZARG(1,JA) 1024 : c on est ici 1025 : 1026 : PSCAGX = (VAUY(2)*VAUZ(3)) - 1027 : & (VAUZ(2)*VAUY(3)) 1028 : PSCAGY = (VAUZ(2)*VAUX(3)) - 1029 : & (VAUX(2)*VAUZ(3)) 1030 : PSCAGZ = (VAUX(2)*VAUY(3)) - 1031 : & (VAUY(2)*VAUX(3)) 1032 : 1033 : PSCA = (VECXG(2,JA)* PSCAGX) + (VECYG(2,JA)* PSCAGY) + 1034 : & (VECZG(2,JA)* PSCAGZ) 1035 : IF (PSCA.LT.0) THEN 1036 : PSCAGX = - PSCAGX 1037 : PSCAGY = - PSCAGY 1038 : PSCAGZ = - PSCAGZ 1039 : ENDIF 1040 : SURFAGX(KA) = 0.5D0* PSCAGX 1041 : SURFAGY(KA) = 0.5D0* PSCAGY 1042 : SURFAGZ(KA) = 0.5D0* PSCAGZ 1043 : 1044 : ENDIF 1045 : 1046 : 1047 : IF (KA.EQ.3) THEN 1048 : VAUX(2) = XA - XARG(3,JA) 1049 : VAUY(2) = YA - YARG(3,JA) 1050 : VAUZ(2) = ZA - ZARG(3,JA) 1051 : 1052 : VAUX(3) = XA - XARG(1,JA) 1053 : VAUY(3) = YA - YARG(1,JA) 1054 : VAUZ(3) = ZA - ZARG(1,JA) 1055 : 1056 : PSCAGX = (VAUY(2)*VAUZ(3)) - 1057 : & (VAUZ(2)*VAUY(3)) 1058 : PSCAGY = (VAUZ(2)*VAUX(3)) - 1059 : & (VAUX(2)*VAUZ(3)) 1060 : PSCAGZ = (VAUX(2)*VAUY(3)) - 1061 : & (VAUY(2)*VAUX(3)) 1062 : 1063 : PSCA = (VECXG(3,JA)* PSCAGX) + (VECYG(3,JA)* PSCAGY) + 1064 : & (VECZG(3,JA)* PSCAGZ) 1065 : IF (PSCA.LT.0) THEN 1066 : PSCAGX = - PSCAGX 1067 : PSCAGY = - PSCAGY 1068 : PSCAGZ = - PSCAGZ 1069 : ENDIF 1070 : SURFAGX(KA) = 0.5D0* PSCAGX 1071 : SURFAGY(KA) = 0.5D0* PSCAGY 1072 : SURFAGZ(KA) = 0.5D0* PSCAGZ 1073 : 1074 : ENDIF 1075 : c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS1 1076 : IF (ICHTE.EQ.0) THEN 1077 : PX(KA,JA) = SURFAGX(KA)/(VOLUG(JA)) 1078 : PY(KA,JA) = SURFAGY(KA)/(VOLUG(JA)) 1079 : PZ(KA,JA) = SURFAGZ(KA)/(VOLUG(JA)) 1080 : 1081 : ELSE 1082 : IF (MPOTEN.VPOCHA(/2) .EQ.6) THEN 1083 : C TENSEUR ANISOTROPE 1084 : K11G = MPOTEN.VPOCHA(NLCG,1) 1085 : K22G = MPOTEN.VPOCHA(NLCG,2) 1086 : K33G = MPOTEN.VPOCHA(NLCG,3) 1087 : K21G = MPOTEN.VPOCHA(NLCG,4) 1088 : K31G = MPOTEN.VPOCHA(NLCG,5) 1089 : K32G = MPOTEN.VPOCHA(NLCG,6) 1090 : ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN 1091 : C TENSEUR DIAGONAL 1092 : K11G = MPOTEN.VPOCHA(NLCG,1) 1093 : K22G = K11G 1094 : K33G = K11G 1095 : K21G = 0.0D0 1096 : K31G = 0.0D0 1097 : K32G = 0.0D0 1098 : ELSE 1099 : WRITE(6,*) 'TENSEUR NON PREVU' 1100 : STOP 1101 : ENDIF 1102 : 1103 : PSCAGX = (K11G*SURFAGX(KA)) + (K21G*SURFAGY(KA)) + 1104 : & (K31G*SURFAGZ(KA)) 1105 : PSCAGY = (K21G*SURFAGX(KA)) + (K22G*SURFAGY(KA)) + 1106 : & (K32G*SURFAGZ(KA)) 1107 : PSCAGZ = (K31G*SURFAGX(KA)) + (K32G*SURFAGY(KA)) + 1108 : & (K33G*SURFAGZ(KA)) 1109 : PX(KA,JA) = PSCAGX/(VOLUG(JA)) 1110 : PY(KA,JA) = PSCAGY/(VOLUG(JA)) 1111 : PZ(KA,JA) = PSCAGZ/(VOLUG(JA)) 1112 : ENDIF 1113 : ENDDO 1114 : c WRITE(6,*)'NLCF= ',NLCF 1115 : c WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z 1116 : c WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1) 1117 : c WRITE(6,*)'SURFAG = ',SURFAGX(2),SURFAGY(2),SURFAGZ(2) 1118 : c WRITE(6,*)'SURFAG = ',SURFAGX(3),SURFAGY(3),SURFAGZ(3) 1119 : ENDDO 1120 : 1121 : XPRO = 1.D0/NBNO 1122 : DO JA = 1,NBNO 1123 : 1124 : MARQ = 0 1125 : DO I5 = 1,INDLI.ID(NLS(JA)) 1126 : INDAUX = IND2.NUME(I5,NLS(JA)) 1127 : IF (INDAUX.EQ.NLOCFG(2,JA)) THEN 1128 : IAFF = I5 1129 : IG2 = IAFF 1130 : GOTO 62 1131 : ENDIF 1132 : ENDDO 1133 : 62 CONTINUE 1134 : 1135 : TRG2 = SCMB.MAT(IAFF,NLS(JA)) 1136 : c WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG2 1137 : 1138 : DO I5 = 1,INDLI.ID(NLS(JA)) 1139 : INDAUX = IND2.NUME(I5,NLS(JA)) 1140 : IF (INDAUX.EQ.NLOCFG(3,JA)) THEN 1141 : IAFF = I5 1142 : IG3 = IAFF 1143 : GOTO 629 1144 : ENDIF 1145 : ENDDO 1146 : 629 CONTINUE 1147 : TRG3 = SCMB.MAT(IAFF,NLS(JA)) 1148 : c WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG3 1149 : 1150 : MARQ = 0 1151 : DO I5 = 1,INDLI.ID(NLS(JA)) 1152 : INDAUX = IND2.NUME(I5,NLS(JA)) 1153 : IF (INDAUX.EQ.NGCF) THEN 1154 : IAFF = I5 1155 : IG = IAFF 1156 : GOTO 63 1157 : ENDIF 1158 : ENDDO 1159 : 63 CONTINUE 1160 : TRG = SCMB.MAT(IAFF,NLS(JA)) 1161 : TRGAUX(JA) = TRG 1162 : IGNS(JA) = IAFF 1163 : 1164 : c WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG 1165 : 1166 : VAL = ALPHA*MPOCHP.VPOCHA(NLCG,1) 1167 : VALD = MPOCHP.VPOCHA(NLCD,1) 1168 : c ICI 1169 : 1170 : AUX = (XPRO*( 1171 : & (PX(1,JA) * (-VAL + TRG)) 1172 : & + (PX(2,JA) * (-VAL + TRG2)) 1173 : & + (PX(3,JA) * (-VAL + TRG3)))) 1174 : AUY = (XPRO*( 1175 : & (PY(1,JA) * (-VAL + TRG)) 1176 : & + (PY(2,JA) * (-VAL + TRG2)) 1177 : & + (PY(3,JA) * (-VAL + TRG3)))) 1178 : AUZ = (XPRO*( 1179 : & (PZ(1,JA) * (-VAL + TRG)) 1180 : & + (PZ(2,JA) * (-VAL + TRG2)) 1181 : & + (PZ(3,JA) * (-VAL + TRG3)))) 1182 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) + 1183 : & (AUX*SCN1X) + (AUY*SCN1Y) + 1184 : & (AUZ*SCN1Z) 1185 : 1186 : c IF (NLCF.EQ.791) THEN 1187 : c WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1) 1188 : c WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2) 1189 : c WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3) 1190 : c WRITE(6,*) 'PX= ',PX(1,JA),PX(2,JA),PX(3,JA) 1191 : c WRITE(6,*) 'PY= ',PY(1,JA),PY(2,JA),PY(3,JA) 1192 : c WRITE(6,*) 'PZ= ',PZ(1,JA),PZ(2,JA),PZ(3,JA) 1193 : c WRITE(6,*) 'TR ',TRG,TRG2,TRG3,'VAL',VAL 1194 : c WRITE(6,*) 'NLS= ',NLS(JA), 1195 : c & 'IG= ',IG,'IG2= ',IG2,'IG3= ',IG3 1196 : c WRITE(6,*) 'NGCF= ',NGCF 1197 : c ENDIF 1198 : 1199 : 1200 : ITROUVE = 0 1201 : INDIC = IPO3.POINT33(NLS(JA)) 1202 : SEGACT INDIC *MOD 1203 : MATR1 = IPO2.POINT(NLS(JA)) 1204 : SEGACT MATR1 *MOD 1205 : c NLS1 = NLS(JA) 1206 : c DO IAUX = 1,INDLI.ID(NLS1) 1207 : c DO IAUX2 = 1,TAB.ID(NLS1) 1208 : c WRITE(6,*) 'NLS1= ',NLS1,'IAUX= ',IAUX ,'IAUX2= ', 1209 : c & IAUX2,'VAUX',MATR1.MAT2(IAUX,IAUX2) 1210 : c & ,'IND3= ',INDIC.NU(IAUX,IAUX2) 1211 : c ENDDO 1212 : c ENDDO 1213 : 1214 : DO ICOUR = 1,TAB.ID(NLS(JA)) 1215 : IA = ICOUR 1216 : J1 = INDIC.NU(IG,IA) 1217 : DO IAUX2 = 2,NCON 1218 : J2 = MELEME.NUM(IAUX2,NLCF) 1219 : IF (J1.EQ.J2) THEN 1220 : IAUX = IAUX2 1221 : ITROUVE = 1 1222 : GOTO 5119 1223 : ENDIF 1224 : ENDDO 1225 : C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR 1226 : NCON = NCON + 1 1227 : IAUX = NCON 1228 : 5119 CONTINUE 1229 : 1230 : 1231 : CX = MATR1.MAT2(IG,IA) 1232 : CY = MATR1.MAT2(IG,IA) 1233 : CZ = MATR1.MAT2(IG,IA) 1234 : IF (J1.EQ.NGCG) THEN 1235 : CX = CX - ALPHA 1236 : CY = CY - ALPHA 1237 : CZ = CZ - ALPHA 1238 : INDGA = IAUX 1239 : ENDIF 1240 : IF (J1.EQ.NGCD) THEN 1241 : INDDR = IAUX 1242 : ENDIF 1243 : c MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) - 1244 : c & (XPRO*PX(1,JA)*CX) 1245 : c MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) - 1246 : c & (XPRO*PY(1,JA)*CY) 1247 : c MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) - 1248 : c & (XPRO*PZ(1,JA)*CZ) 1249 : AUX = (XPRO*PX(1,JA)*CX*SCN1X) + 1250 : & (XPRO*PY(1,JA)*CY*SCN1Y) + 1251 : & (XPRO*PZ(1,JA)*CZ*SCN1Z) 1252 : MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) + 1253 : & AUX 1254 : 1255 : INDAUX = INDIC.NU(IG,IA) 1256 : MELEME.NUM(IAUX,NLCF) = INDAUX 1257 : ENDDO 1258 : 1259 : 1260 : ITROUVE = 0 1261 : DO ICOUR = 1,TAB.ID(NLS(JA)) 1262 : IA = ICOUR 1263 : J1 = INDIC.NU(IG2,IA) 1264 : DO IAUX2 = 2,NCON 1265 : J2 = MELEME.NUM(IAUX2,NLCF) 1266 : IF (J1.EQ.J2) THEN 1267 : IAUX = IAUX2 1268 : ITROUVE = 1 1269 : GOTO 511 1270 : ENDIF 1271 : ENDDO 1272 : C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR 1273 : NCON = NCON + 1 1274 : IAUX = NCON 1275 : 511 CONTINUE 1276 : 1277 : CX = MATR1.MAT2(IG2,IA) 1278 : CY = MATR1.MAT2(IG2,IA) 1279 : CZ = MATR1.MAT2(IG2,IA) 1280 : IF (J1.EQ.NGCG) THEN 1281 : CX = CX - ALPHA 1282 : CY = CY - ALPHA 1283 : CZ = CZ - ALPHA 1284 : ENDIF 1285 : c MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) - 1286 : c & (XPRO*PX(2,JA)*CX) 1287 : c MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) - 1288 : c & (XPRO*PY(2,JA)*CY) 1289 : c MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) - 1290 : c & (XPRO*PZ(2,JA)*CZ) 1291 : AUX = (XPRO*PX(2,JA)*CX*SCN1X) + 1292 : & (XPRO*PY(2,JA)*CY*SCN1Y) + 1293 : & (XPRO*PZ(2,JA)*CZ*SCN1Z) 1294 : MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) + 1295 : & AUX 1296 : INDAUX = INDIC.NU(IG2,IA) 1297 : MELEME.NUM(IAUX,NLCF) = INDAUX 1298 : ENDDO 1299 : 1300 : ITROUVE = 0 1301 : DO ICOUR = 1,TAB.ID(NLS(JA)) 1302 : IA = ICOUR 1303 : J1 = INDIC.NU(IG3,IA) 1304 : DO IAUX2 = 2,NCON 1305 : J2 = MELEME.NUM(IAUX2,NLCF) 1306 : IF (J1.EQ.J2) THEN 1307 : IAUX = IAUX2 1308 : ITROUVE = 1 1309 : GOTO 5118 1310 : ENDIF 1311 : ENDDO 1312 : C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR 1313 : NCON = NCON + 1 1314 : IAUX = NCON 1315 : 5118 CONTINUE 1316 : 1317 : CX = MATR1.MAT2(IG3,IA) 1318 : CY = MATR1.MAT2(IG3,IA) 1319 : CZ = MATR1.MAT2(IG3,IA) 1320 : IF (J1.EQ.NGCG) THEN 1321 : CX = CX - ALPHA 1322 : CY = CY - ALPHA 1323 : CZ = CZ - ALPHA 1324 : ENDIF 1325 : c MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) - 1326 : c & (XPRO*PX(3,JA)*CX) 1327 : c MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) - 1328 : c & (XPRO*PY(3,JA)*CY) 1329 : c MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) - 1330 : c & (XPRO*PZ(3,JA)*CZ) 1331 : AUX = (XPRO*PX(3,JA)*CX*SCN1X) + 1332 : & (XPRO*PY(3,JA)*CY*SCN1Y) + 1333 : & (XPRO*PZ(3,JA)*CZ*SCN1Z) 1334 : MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) + 1335 : & AUX 1336 : INDAUX = INDIC.NU(IG3,IA) 1337 : MELEME.NUM(IAUX,NLCF) = INDAUX 1338 : ENDDO 1339 : 1340 : c WRITE(6,*) 'NLCF= ',NLCF,'XPRO= ',XPRO, 1341 : c & 'FLUX=',MPOGRA.VPOCHA(NLCF,1) 1342 : c WRITE(6,*) 'NLCF= ',NLCF,'TRG=',TRG,'TRG2=',TRG2, 1343 : c & 'TRG3=',TRG3 1344 : 1345 : c FIN DE LA BOUCLE SUR LES NOEUDS 1346 : SEGDES MATR1 1347 : SEGDES INDIC 1348 : ENDDO 1349 : 1350 : c MPOGRA.VPOCHA(NLCF,1) = 0.0D0 1351 : c ISUP = NCON 1352 : c DO J= ISUP+1,NBNN 1353 : c DO J= 2,NBNN 1354 : c MELVA1.VELCHE(J,NLCF) = 0.0D0 1355 : c MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF) 1356 : c ENDDO 1357 : ISUP = NCON 1358 : DO J= ISUP+1,NBNN 1359 : MELVA1.VELCHE(J,NLCF) = 0.0D0 1360 : MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF) 1361 : ENDDO 1362 : 1363 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 1364 : C ON RAJOUTE LE CONVECTIF 1365 : 1366 : C CALCUL PLUS PRECIS 1367 : 1368 : 1369 : c IF (NLCD.NE.NLCG) THEN 1370 : c MELVA1.VELCHE(INDDR,NLCF) = - MELVA1.VELCHE(INDGA,NLCF) 1371 : c ELSE 1372 : c DO J= 1,ISUP 1373 : c ICENT = MELEME.NUM(J,NLCF) 1374 : c ICEN = MLECEN.LECT(ICENT) 1375 : c DIFF = MELVA1.VELCHE(J,NLCF) + MELVA1.VELCHE(INDGA,NLCF) 1376 : c DIFF = ABS(DIFF) 1377 : c XX = ABS(MELVA1.VELCHE(INDGA,NLCF)) 1378 : c IF ((ICEN.EQ.0).AND.(DIFF.LT.(1e-5*XX))) THEN 1379 : c MELVA1.VELCHE(J,NLCF) = - MELVA1.VELCHE(INDGA,NLCF) 1380 : c ENDIF 1381 : c ENDDO 1382 : c ENDIF 1383 : 1384 : 1385 : IF (ICHCO.GT.0) THEN 1386 : C BOUCLE POUR CALCUER INDGA,INDDR 1387 : INDFR = 0 1388 : DO J= 1,ISUP 1389 : IF (MELEME.NUM(J,NLCF).EQ.NGCG) INDGA = J 1390 : IF (MELEME.NUM(J,NLCF).EQ.NGCD) INDDR = J 1391 : IF (MELEME.NUM(J,NLCF).EQ.NGCF) INDFR = J 1392 : ENDDO 1393 : 1394 : 1395 : 1396 : c WRITE(6,*) 'NGCF= ',NGCF 1397 : UN = MPOVCO.VPOCHA(NLCF,1) 1398 : c WRITE(6,*) 'UN= ',UN 1399 : C OPTION CENTRE 1400 : IF (IOP.EQ.2) THEN 1401 : IF (NLCD.NE.NLCG) THEN 1402 : VAL = 0.5D0*(MPOCHP.VPOCHA(NLCG,1) + 1403 : & MPOCHP.VPOCHA(NLCD,1))*UN 1404 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1405 : ELSE 1406 : C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION 1407 : 1408 : XPRO = 1.D0/NBNO 1409 : TRACE = 0.0D0 1410 : DO JA = 1,NBNO 1411 : TRACE =TRACE + (XPRO*TRGAUX(JA)) 1412 : ENDDO 1413 : c WRITE(6,*) 'NLCF= ',NLCF,'TRACE= ',TRACE 1414 : VAL = TRACE*UN 1415 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1416 : ENDIF 1417 : 1418 : C ON COMPLETE MELVA1 POUR LE CONVECTIF 1419 : IF (NLCD.NE.NLCG) THEN 1420 : MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) - 1421 : & (0.5D0*UN) 1422 : MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) - 1423 : & (0.5D0*UN) 1424 : C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDENCES DES TRACES 1425 : c POUR LES CONDITIONS MIXTES OU DE NEUMAN 1426 : 1427 : 1428 : ELSE 1429 : 1430 : NLFCL = MLENCL.LECT(NGCF) 1431 : 1432 : C ON RAJOUTE CECI POUR L OPTION GRADGEO 1433 : IF (NLFCL.NE.0) THEN 1434 : MELVA1.VELCHE(NCON+1,NLCF) = - UN 1435 : MELEME.NUM(NCON+1,NLCF) = NGCF 1436 : ENDIF 1437 : 1438 : IF (NLFCL.EQ.0) THEN 1439 : XPRO = 1.D0/NBNO 1440 : DO JA = 1,NBNO 1441 : INDIC = IPO3.POINT33(NLS(JA)) 1442 : SEGACT INDIC *MOD 1443 : MATR1 = IPO2.POINT(NLS(JA)) 1444 : SEGACT MATR1 *MOD 1445 : 1446 : DO ICOUR = 1,TAB.ID(NLS(JA)) 1447 : IA = ICOUR 1448 : J1 = INDIC.NU(IGNS(JA),IA) 1449 : DO IAUX2 = 2,NCON 1450 : J2 = MELEME.NUM(IAUX2,NLCF) 1451 : IF (J1.EQ.J2) THEN 1452 : IAUX = IAUX2 1453 : GOTO 5169 1454 : ENDIF 1455 : ENDDO 1456 : 5169 CONTINUE 1457 : 1458 : 1459 : CX = MATR1.MAT2(IGNS(JA),IA) 1460 : MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) - 1461 : & (UN*CX*XPRO) 1462 : ENDDO 1463 : SEGDES INDIC *MOD 1464 : SEGDES MATR1 *MOD 1465 : ENDDO 1466 : ENDIF 1467 : ENDIF 1468 : 1469 : C OPTION UPWIND 1470 : ELSEIF (IOP.EQ.1) THEN 1471 : IF (NLCD.NE.NLCG) THEN 1472 : IF (UN.GT.0.0D0) THEN 1473 : VAL = (MPOCHP.VPOCHA(NLCG,1)*UN) 1474 : ELSE 1475 : VAL = (MPOCHP.VPOCHA(NLCD,1)*UN) 1476 : ENDIF 1477 : c WRITE(6,*) 'VAL= ',VAL 1478 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1479 : ELSE 1480 : C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION 1481 : c ANCIENNE VERRUE 1482 : IF (UN.GT.0.0D0) THEN 1483 : VAL = (MPOCHP.VPOCHA(NLCG,1)*UN) 1484 : ELSE 1485 : XPRO = 1.D0/NBNO 1486 : TRACE = 0.0D0 1487 : DO JA = 1,NBNO 1488 : TRACE =TRACE + (XPRO*TRGAUX(JA)) 1489 : ENDDO 1490 : 1491 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF 1492 : c WRITE(6,*) 'UN= ',UN,'TRACE=',TRACE 1493 : 1494 : 1495 : VAL = TRACE*UN 1496 : ENDIF 1497 : 1498 : 1499 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1500 : ENDIF 1501 : 1502 : C ON COMPLETE MELVA1 POUR LE CONVECTIF 1503 : IF (NLCD.NE.NLCG) THEN 1504 : c WRITE(6,*) 'UN= ',UN 1505 : IF (UN.GT.0.0D0) THEN 1506 : MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) - 1507 : & (UN) 1508 : ELSE 1509 : MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) - 1510 : & (UN) 1511 : ENDIF 1512 : C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDENCES DES TRACES 1513 : c POUR LES CONDITIONS MIXTES OU DE NEUMAN 1514 : 1515 : ELSE 1516 : c ANCIENNE VERRUE 1517 : IF (UN.GT.0.0D0) THEN 1518 : MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) - 1519 : & (UN) 1520 : ELSE 1521 : 1522 : NLFCL = MLENCL.LECT(NGCF) 1523 : 1524 : C ON RAJOUTE CECI POUR L OPTION GRADGEO 1525 : C IL Y A PROBABLEMENT REDONDANCE 1526 : IF (NLFCL.NE.0) THEN 1527 : MELVA1.VELCHE(NCON+1,NLCF) = - UN 1528 : MELEME.NUM(NCON+1,NLCF) = NGCF 1529 : ENDIF 1530 : * ENDIF 1531 : 1532 : IF (NLFCL.EQ.0) THEN 1533 : XPRO = 1.D0/NBNO 1534 : DO JA = 1,NBNO 1535 : INDIC = IPO3.POINT33(NLS(JA)) 1536 : SEGACT INDIC *MOD 1537 : MATR1 = IPO2.POINT(NLS(JA)) 1538 : SEGACT MATR1 *MOD 1539 : 1540 : DO ICOUR = 1,TAB.ID(NLS(JA)) 1541 : IA = ICOUR 1542 : J1 = INDIC.NU(IGNS(JA),IA) 1543 : DO IAUX2 = 2,NCON 1544 : J2 = MELEME.NUM(IAUX2,NLCF) 1545 : IF (J1.EQ.J2) THEN 1546 : IAUX = IAUX2 1547 : GOTO 5129 1548 : ENDIF 1549 : ENDDO 1550 : 5129 CONTINUE 1551 : 1552 : 1553 : CX = MATR1.MAT2(IGNS(JA),IA) 1554 : MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) - 1555 : & (UN*CX*XPRO) 1556 : ENDDO 1557 : 1558 : SEGDES INDIC *MOD 1559 : SEGDES MATR1 *MOD 1560 : ENDDO 1561 : ENDIF 1562 : ENDIF 1563 : 1564 : 1565 : ENDIF 1566 : 1567 : 1568 : C OPTION UPWICENT 1569 : ELSEIF (IOP.EQ.3) THEN 1570 : IF (NLCD.NE.NLCG) THEN 1571 : c CALCUL DE THETA 1572 : c DANS MELVA1 : INDDR EST LA NUM de NLCD 1573 : C COEFD = MELVA1(INDDR,NLCF) 1574 : COEFDD = MELVA1.VELCHE(INDDR,NLCF) 1575 : 1576 : 1577 : THETA = 0.5D0 1578 : EXPR1 = - (THETA*UN) - COEFDD 1579 : EXPR2 = - ((1.D0 - THETA)*UN) + COEFDD 1580 : c WRITE(6,*) 'EXPR1',EXPR1 1581 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1582 : c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN 1583 : c WRITE(6,*) 'EXPR2',EXPR2 1584 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1585 : c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN 1586 : IF (EXPR1.GT.0.0D0) THEN 1587 : IF (ABS(UN) .GT. 1e-20) THEN 1588 : THETA = - (0.5D0*COEFDD / UN) 1589 : ENDIF 1590 : ENDIF 1591 : IF (EXPR2.LT.0.0D0) THEN 1592 : IF (ABS(UN) .GT. 1e-20) THEN 1593 : THETA = 1.D0 - (0.5D0*COEFDD / UN) 1594 : ENDIF 1595 : ENDIF 1596 : THETA = MIN(1.D0,THETA) 1597 : THETA = MAX(0.D0,THETA) 1598 : 1599 : EXPR1 = (THETA*UN) + COEFDD 1600 : EXPR2 = ((1.D0 - THETA)*UN) - COEFDD 1601 : c IF (EXPR1.LT.0.0D0) THEN 1602 : c WRITE(6,*) 'EXPR1',EXPR1 1603 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1604 : c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN 1605 : c ENDIF 1606 : c IF (EXPR2.GT.0.0D0) THEN 1607 : c WRITE(6,*) 'EXPR2',EXPR2 1608 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1609 : c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN 1610 : c ENDIF 1611 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1612 : c & 'EXPR1= ',EXPR1,'EXPR2= ',EXPR2 1613 : 1614 : 1615 : VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) + 1616 : & (MPOCHP.VPOCHA(NLCD,1)*(1.D0-THETA)*UN) 1617 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1618 : ELSE 1619 : C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION 1620 : IF (INDFR.NE.0) THEN 1621 : COEFDD = MELVA1.VELCHE(INDFR,NLCF) 1622 : ELSE 1623 : COEFDD = 0.0D0 1624 : ENDIF 1625 : C C'EST LE THETA LE MIEUX ADPATE POUR LES CONDITIONS AUX LIMITES 1626 : THETA = 0.0D0 1627 : EXPR1 = - (THETA*UN) - COEFDD 1628 : EXPR2 = - ((1.D0 - THETA)*UN) + COEFDD 1629 : 1630 : IF (EXPR1.GT.0.0D0) THEN 1631 : IF (ABS(UN) .GT. 1e-20) THEN 1632 : THETA = - (0.5D0*COEFDD / UN) 1633 : ENDIF 1634 : ENDIF 1635 : IF (EXPR2.LT.0.0D0) THEN 1636 : IF (ABS(UN) .GT. 1e-20) THEN 1637 : THETA = 1.D0 - (0.5D0*COEFDD / UN) 1638 : ENDIF 1639 : ENDIF 1640 : THETA = MIN(1.D0,THETA) 1641 : THETA = MAX(0.D0,THETA) 1642 : C ANCIENNE VERRUE 1643 : c THETA = 0.0D0 1644 : 1645 : XPRO = 1.D0/NBNO 1646 : TRACE = 0.0D0 1647 : DO JA = 1,NBNO 1648 : TRACE =TRACE + (XPRO*TRGAUX(JA)) 1649 : ENDDO 1650 : VAL = TRACE*UN 1651 : VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) + 1652 : & (TRACE*(1.D0-THETA)*UN) 1653 : MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1654 : 1655 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1656 : c & 'GR1= ',MPOGRA.VPOCHA(NLCF,1),'VAL = ',VAL, 1657 : c & 'TRACE = ',TRACE,'UN= ',UN 1658 : c MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL 1659 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF, 1660 : c & 'GR1= ',MPOGRA.VPOCHA(NLCF,1) 1661 : ENDIF 1662 : 1663 : C ON COMPLETE MELVA1 POUR LE CONVECTIF 1664 : IF (NLCD.NE.NLCG) THEN 1665 : MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) - 1666 : & (THETA*UN) 1667 : MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) - 1668 : & ((1.D0-THETA)*UN) 1669 : C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDANCES DES TRACES 1670 : c POUR LES CONDITIONS MIXTES OU DE NEUMAN 1671 : 1672 : ELSE 1673 : 1674 : MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) - 1675 : & (THETA*UN) 1676 : NLFCL = MLENCL.LECT(NGCF) 1677 : C ON EST ICI : CORRIGER 1678 : C ON RAJOUTE CECI POUR L OPTION GRADGEO 1679 : c IF (NLFCL.NE.0) THEN 1680 : c MELVA1.VELCHE(NCON+1,NLCF) = - UN 1681 : c MELEME.NUM(NCON+1,NLCF) = NGCF 1682 : c ENDIF 1683 : 1684 : c IF (NLFCL.EQ.0) THEN 1685 : XPRO = 1.D0/NBNO 1686 : DO JA = 1,NBNO 1687 : INDIC = IPO3.POINT33(NLS(JA)) 1688 : SEGACT INDIC *MOD 1689 : MATR1 = IPO2.POINT(NLS(JA)) 1690 : SEGACT MATR1 *MOD 1691 : 1692 : DO ICOUR = 1,TAB.ID(NLS(JA)) 1693 : IA = ICOUR 1694 : J1 = INDIC.NU(IGNS(JA),IA) 1695 : DO IAUX2 = 2,NCON 1696 : J2 = MELEME.NUM(IAUX2,NLCF) 1697 : IF (J1.EQ.J2) THEN 1698 : IAUX = IAUX2 1699 : GOTO 5159 1700 : ENDIF 1701 : ENDDO 1702 : 5159 CONTINUE 1703 : 1704 : 1705 : CX = MATR1.MAT2(IGNS(JA),IA) 1706 : MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) - 1707 : & ((1.D0-THETA)*UN*CX*XPRO) 1708 : ENDDO 1709 : 1710 : SEGDES INDIC *MOD 1711 : SEGDES MATR1 *MOD 1712 : ENDDO 1713 : c ENDIF 1714 : ENDIF 1715 : 1716 : ENDIF 1717 : ENDIF 1718 : 1719 : c DO J= 1,NBNN 1720 : c PSCA = (MPOGRA.VPOCHA(NLCF,1)*SCN1X) + 1721 : c & (MPOGRA.VPOCHA(NLCF,2)*SCN1Y) + 1722 : c & (MPOGRA.VPOCHA(NLCF,3)*SCN1Z) 1723 : c MPOGRA.VPOCHA(NLCF,1) = PSCA*SCN1X 1724 : c MPOGRA.VPOCHA(NLCF,2) = PSCA*SCN1Y 1725 : c MPOGRA.VPOCHA(NLCF,3) = PSCA*SCN1Z 1726 : c ENDDO 1727 : c IF (NLCF.EQ.791) THEN 1728 : c WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1) 1729 : c ENDIF 1730 : c WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2) 1731 : c WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3) 1732 : 1733 : 1734 : c DO J= 1,NBNN 1735 : c PSCA = (MELVA1.VELCHE(J,NLCF)*SCN1X) + 1736 : c & (MELVA2.VELCHE(J,NLCF)*SCN1Y) + 1737 : c & (MELVA3.VELCHE(J,NLCF)*SCN1Z) 1738 : c MELVA1.VELCHE(J,NLCF) = PSCA*SCN1X 1739 : c MELVA2.VELCHE(J,NLCF) = PSCA*SCN1Y 1740 : c MELVA3.VELCHE(J,NLCF) = PSCA*SCN1Z 1741 : c ENDDO 1742 : c DO J= 1,NBNN 1743 : c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA1= ', 1744 : c & MELVA1.VELCHE(J,NLCF) 1745 : c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA2= ', 1746 : c & MELVA2.VELCHE(J,NLCF) 1747 : c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA3= ', 1748 : c & MELVA3.VELCHE(J,NLCF) 1749 : c WRITE(6,*) 'MELEME=',MELEME.NUM(J,NLCF) 1750 : c ENDDO 1751 : C IF (1.EQ.0) THEN 1752 : C WRITE(6,*) 'NGCF= ',NGCF 1753 : C WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1) 1754 : C WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2) 1755 : C WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3) 1756 : C VALD = MPOCHP.VPOCHA(NLCD,1) 1757 : C WRITE(6,*) 'NLCF= ',NLCF,'VALD= ',VALD 1758 : C WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL 1759 : C WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRG 1760 : C WRITE(6,*) 'NLCF= ',NLCF,'TRG2= ',TRG2 1761 : C WRITE(6,*) 'NLCF= ',NLCF,'TRG3= ',TRG3 1762 : C WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRGAUX 1763 : C WRite(6,*) 'AG1=',AG1 1764 : C WRite(6,*) 'AG2=',AG2 1765 : C WRite(6,*) 'AD1=',AD1 1766 : C WRite(6,*) 'AD2=',AD2 1767 : C ENDIF 1768 : NAUX2 = MAX(NAUX2,NCON) 1769 : NMOY = NMOY + NCON 1770 : 1771 : c WRITE(6,*) 'INDGA= ',INDGA 1772 : c WRITE(6,*) 'INDDR= ',INDDR 1773 : c DO J= 1,NBNN 1774 : c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA1= ', 1775 : c & MELVA1.VELCHE(J,NLCF) 1776 : c ENDDO 1777 : 1778 : 1779 : ENDDO 1780 : NMOY = NMOY/(NFAC*1.D0) 1781 : 1782 : IF (1.EQ.0) THEN 1783 : DO NLCF = 1, NFAC, 1 1784 : MPOGRA.VPOCHA(NLCF,1) = 0.D0 1785 : SCNX=MPONOR.VPOCHA(NLCF,1) 1786 : SCNY=MPONOR.VPOCHA(NLCF,2) 1787 : SCNZ=MPONOR.VPOCHA(NLCF,3) 1788 : SCN1X = SCNX 1789 : SCN1Y = SCNY 1790 : SCN1Z = SCNZ 1791 : NGCF=MELEFL.NUM(2,NLCF) 1792 : DO IVOI=2,MELEME.NUM(/1) 1793 : ICENT = MELEME.NUM(IVOI,NLCF) 1794 : ICEN = MLECEN.LECT(ICENT) 1795 : VAL = 0.0D0 1796 : IF (ICEN.NE.0) THEN 1797 : c WRITE(6,*) 'INTERIEUR' 1798 : VAL = MPOCHP.VPOCHA(ICEN,1) 1799 : ELSE 1800 : ICENL = MLENCL.LECT(ICENT) 1801 : IF (ICENL.GT.0) THEN 1802 : c WRITE(6,*) 'DIRICHLET' 1803 : VAL = MPOVCL.VPOCHA(ICENL,1) 1804 : ENDIF 1805 : ENDIF 1806 : 1807 : COEF1 = MELVA1.VELCHE(IVOI,NLCF) 1808 : MPOGRA.VPOCHA(NLCF,1)= MPOGRA.VPOCHA(NLCF,1) + 1809 : & (COEF1 * VAL) 1810 : 1811 : c WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL 1812 : c WRITE(6,*) 'IVOI= ',IVOI,'MELEME= ', MELEME.NUM(IVOI,NLCF), 1813 : c & 'COEF1 = ',COEF1,'COEF2= ',COEF2,'COEF3= ',COEF3 1814 : ENDDO 1815 : c DO J= 1,NBNN 1816 : c PSCA = (MPOGRA.VPOCHA(NLCF,1)*SCN1X) + 1817 : c & (MPOGRA.VPOCHA(NLCF,2)*SCN1Y) + 1818 : c & (MPOGRA.VPOCHA(NLCF,3)*SCN1Z) 1819 : c MPOGRA.VPOCHA(NLCF,1) = PSCA*SCN1X 1820 : c MPOGRA.VPOCHA(NLCF,2) = PSCA*SCN1Y 1821 : c MPOGRA.VPOCHA(NLCF,3) = PSCA*SCN1Z 1822 : c ENDDO 1823 : c NGCF=MELEFL.NUM(2,NLCF) 1824 : c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF 1825 : c WRITE(6,*) 'MPOGRA1= ', MPOGRA.VPOCHA(NLCF,1) 1826 : c WRITE(6,*) 'MPOGRA2= ', MPOGRA.VPOCHA(NLCF,2) 1827 : c WRITE(6,*) 'MPOGRA3= ', MPOGRA.VPOCHA(NLCF,3) 1828 : ENDDO 1829 : ENDIF 1830 : 1831 : IF (NBSO.EQ.2) THEN 1832 : SEGDES IPT1 1833 : SEGDES IPT2 1834 : ELSEIF (NBSO.EQ.3) THEN 1835 : SEGDES IPT1 1836 : SEGDES IPT2 1837 : SEGDES IPT3 1838 : ELSEIF (NBSO.EQ.4) THEN 1839 : SEGDES IPT1 1840 : SEGDES IPT2 1841 : SEGDES IPT3 1842 : SEGDES IPT4 1843 : ENDIF 1844 : IF (NBSOF.EQ.2) THEN 1845 : SEGDES IPT5 1846 : SEGDES IPT6 1847 : ENDIF 1848 : 1849 : C ON REJUSTE LE CHAMELEM 1850 : 1851 : 1852 : c WRITE(6,*) 'NAUX2= ',NAUX2 1853 : c WRITE(6,*) 'NESSAI= ',NESSAI 1854 : c WRITE(6,*) 'NMOY2= ',NMOY 1855 : IF (NAUX2.GT.NESSAI) THEN 1856 : WRITE(6,*) 'NAUX2 = ',NAUX2,'NESSAI = ',NESSAI 1857 : WRITE(6,*) 'NESSAI TROP PETIT' 1858 : STOP 1859 : ENDIF 1860 : N1PTEL=NAUX2 1861 : N1EL=NBELEM 1862 : N2PTEL=0 1863 : N2EL=0 1864 : SEGADJ MELVA1 1865 : 1866 : NBNN = NAUX2 1867 : SEGADJ MELEME 1868 : 1869 : K7 = NFAC 1870 : K8 = NAUX2 1871 : SEGINI ITAB 1872 : 1873 : c ON SUPPRIME LES ZEROS INTERIEURS 1874 : IND = 2 1875 : DO NLCF = 1,NFAC 1876 : IND = 2 1877 : NFIN = NAUX2 1878 : C ON CALCULE D4ABORD LE MAXIMUM DE LA LIGNE 1879 : AUXMA = 0 1880 : DO J=2,NFIN 1881 : ICEN = MLECEN.LECT(MELEME.NUM(J,NLCF)) 1882 : 1883 : IF (ICEN.NE.0) THEN 1884 : AUXMA = MAX(ABS(MELVA1.VELCHE(J,NLCF)),AUXMA) 1885 : ENDIF 1886 : ENDDO 1887 : ITAB.XMAX(NLCF) = AUXMA 1888 : 1889 : DO J=IND, NFIN 1890 : ICEN = MLECEN.LECT(MELEME.NUM(J,NLCF)) 1891 : IF (ABS(MELVA1.VELCHE(J,NLCF)).Le.(1e-14*AUXMA) 1892 : & .AND.(ICEN.NE.0) ) THEN 1893 : 1894 : 1895 : DO K=1,NFIN-J 1896 : AUX = MELVA1.VELCHE(J+K,NLCF) 1897 : ICEN = MLECEN.LECT(MELEME.NUM(J+K,NLCF)) 1898 : C ON DECALE DE K CRAN 1899 : IF (ABS(AUX).gt.(1e-14*AUXMA).OR.(ICEN.EQ.0)) THEN 1900 : DO I=J,NFIN - K 1901 : MELVA1.VELCHE(I,NLCF) = MELVA1.VELCHE(I+K,NLCF) 1902 : MELEME.NUM(I,NLCF) = MELEME.NUM(I+K,NLCF) 1903 : ENDDO 1904 : C MISE A ZERO DES TERMES DU BOUT 1905 : DO I=NFIN-K+1,NFIN 1906 : MELVA1.VELCHE(I,NLCF) = 0.0 1907 : ENDDO 1908 : GOTO 2000 1909 : ENDIF 1910 : ENDDO 1911 : 2000 CONTINUE 1912 : ENDIF 1913 : ENDDO 1914 : ENDDO 1915 : 1916 : c IF (1.EQ.0) THEN 1917 : c ON RECONSTUIT UN CHAMELEM EN SUPPRIMANT LES 0 1918 : 1919 : 1920 : 1921 : 1922 : 1923 : c TABLEAU CALCULANT LE NOMBRE DE VOISIN NON NUL POUR CHAQUE FACE 1924 : NMOY = 0 1925 : INF = NAUX2 1926 : DO NLCF = 1,NFAC 1927 : IREC = 3 1928 : DO J=NAUX2,1,-1 1929 : IF (ABS(MELVA1.VELCHE(J,NLCF)).gt. 1930 : & (1e-14*ITAB.XMAX(NLCF))) THEN 1931 : IREC = J 1932 : GOTO 1111 1933 : ENDIF 1934 : ENDDO 1935 : 1111 CONTINUE 1936 : ITAB.TABL(NLCF) = IREC 1937 : NMOY = NMOY + IREC 1938 : ENDDO 1939 : NMOY = NMOY/(NFAC*1.D0) 1940 : c WRITE(6,*) 'NEWMOY2= ',NMOY 1941 : 1942 : 1943 : C TAB1(U) TABLEAU QUI CONTIENT LE NOMBRE DE FACE AYANT U VOISIN 1944 : NMAX = 0 1945 : DO ICOUR = 1,NAUX2 1946 : ITAB.TABL1(ICOUR) = 0 1947 : ENDDO 1948 : 1949 : DO NLCF = 1,NFAC 1950 : ICOUR = ITAB.TABL(NLCF) 1951 : ITAB.TABL1(ICOUR)=ITAB.TABL1(ICOUR) + 1 1952 : ENDDO 1953 : 1954 : C ON COMPTE LE NOMVRE DE SOUS DOMAINE 1955 : NTSOUS = 0 1956 : DO ICOUR = 1,NAUX2 1957 : IF (ITAB.TABL1(ICOUR) .NE.0) NTSOUS = NTSOUS +1 1958 : ENDDO 1959 : C IPOS INDICE DE LA PREMIERE FACE AYANT I VOISIN 1960 : C ICOUR INDICE COURANT INITIALISE A IPOS 1961 : 1962 : 1963 : ITAB.IPOS(1) = 1 1964 : DO I = 2,NAUX2 1965 : ITAB.IPOS(I) = ITAB.IPOS(I-1) + ITAB.TABL1(I-1) 1966 : ITAB.ICOURANT(I) = ITAB.IPOS(I) 1967 : ENDDO 1968 : 1969 : 1970 : c TABL2 TABLEAU QUI RANGE DANS L4ODRES DES SOUS DOMAINES LES FACES NLCF 1971 : 1972 : DO I =1,NFAC 1973 : IHELP = ITAB.TABL(I) 1974 : IAUX = ITAB.ICOURANT(IHELP) 1975 : ITAB.TABL2(IAUX) = I 1976 : IAUX2 = ITAB.TABL(I) 1977 : ITAB.ICOURANT(IAUX2) = ITAB.ICOURANT(IAUX2) + 1 1978 : ENDDO 1979 : 1980 : 1981 : C**** Initialisation du MCHELM 1982 : C 1983 : N1=NTSOUS 1984 : N2=1 1985 : N3=6 1986 : L1=8 1987 : SEGINI MCHEL2 1988 : MCHEL2.TITCHE='Gradient' 1989 : MCHEL2.IFOCHE=IFOUR 1990 : C 1991 : ISOUS=0 1992 : NBSOUS=0 1993 : NBREF=0 1994 : DO I1 = 1, NAUX2, 1 1995 : NBELEM=ITAB.TABL1(I1) 1996 : IF(NBELEM .GT. 0)THEN 1997 : ISOUS=ISOUS+1 1998 : NBNN=I1 1999 : SEGINI IPT8 2000 : C ITYPEL=32 -> 'POLY' 2001 : ITYPEL=32 2002 : MCHEL2.IMACHE(ISOUS)=IPT8 2003 : SEGINI MCHAM2 2004 : MCHEL2.ICHAML(ISOUS)=MCHAM2 2005 : MCHAM2.NOMCHE(1)='SCAL' 2006 : MCHAM2.TYPCHE(1)='REAL*8 ' 2007 : N1PTEL=NBNN 2008 : N1EL=NBELEM 2009 : N2PTEL=0 2010 : N2EL=0 2011 : SEGINI MELVA2 2012 : MCHAM2.IELVAL(1)=MELVA2 2013 : 2014 : DO I2=1,NBELEM,1 2015 : DO I3=1,NBNN,1 2016 : IAUX = ITAB.IPOS(I1) 2017 : IP= ITAB.TABL2(I2 + IAUX - 1) 2018 : c WRITE(6,*) 'IP= ',IP,'I1= ',I1,'I2=',I2,'I3=',I3 2019 : IPT8.NUM(I3,I2)= MELEME.NUM(I3,IP) 2020 : MELVA2.VELCHE(I3,I2)=MELVA1.VELCHE(I3,IP) 2021 : ENDDO 2022 : ENDDO 2023 : C 2024 : SEGDES MCHAM2 2025 : SEGDES IPT8 2026 : SEGDES MELVA2 2027 : ENDIF 2028 : ENDDO 2029 : SEGDES MCHEL2 2030 : SEGDES ITAB 2031 : c ENDIF 2032 : 2033 : 2034 : c SEGDES MCHAML 2035 : c SEGDES MELEME 2036 : c SEGDES MELVA1 2037 : c SEGDES MCHELM 2038 : 2039 : C 3009 2040 : SEGSUP MCHAML 2041 : SEGSUP MELEME 2042 : SEGSUP MELVA1 2043 : SEGSUP MCHELM 2044 : 2045 : 2046 : C SUPRESSION DES SEGMENTS 2047 : K3 = NSOMM 2048 : DO I = 1,K3 2049 : MATR1 = IPO2.POINT(I) 2050 : SEGACT MATR1 2051 : SEGSUP MATR1 2052 : ENDDO 2053 : 2054 : SEGSUP IPO3 2055 : SEGSUP IPO2 2056 : SEGSUP INDLI 2057 : SEGSUP TAB 2058 : SEGSUP IND2 2059 : c SEGSUP IND 2060 : c SEGSUP IND22 2061 : c SEGSUP VAL1 2062 : c SEGSUP VAL2 2063 : SEGSUP SCMB 2064 : C 3009 2065 : SEGSUP NBCOT 2066 : 2067 : 2068 : 2069 : 9999 CONTINUE 2070 : RETURN 2071 : END 2072 : 2073 : 2074 : 2075 : 2076 : 2077 : 2078 : 2079 : 2080 : 2081 : 2082 :
© Cast3M 2003 - All rights reserved.
Disclaimer