1 : C MASCHE SOURCE PV 09/03/12 21:27:50 6325 2 : SUBROUTINE MASCHE( X1, MCH,ICLE,IPCHMA,ISOM,IRET) 3 : *********************************************************************** 4 : * OPERATEUR MASQ (APPELE PAR MASQ) 5 : * 6 : * ENTREES : 7 : * --------- 8 : * X1 :NB AVEC LEQUEL SONT COMPAREES LES VALEURS DU MCHAML 9 : * MCH :POINTEUR SUR UN MCHAML 10 : * ICLE :ENTIER CARACTERISANT LE TYPE DE COMPARAISON 11 : * ISOM =1 SI L ON VEUT LA SOMME 12 : * 0 SINON 13 : * 14 : * 15 : * SORTIES : 16 : * --------- 17 : * IPCHMA :- POINTEUR SUR UN MCHALM RESULTAT SI ISOM=0 18 : * - SOMME DES 1 ET DES 0 SI OPTION ISOM=1 19 : * IRET =1 OU 0 SUIVANT SUCCES OU PAS 20 : * 21 : * 22 : * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91 23 : * 24 : *********************************************************************** 25 : IMPLICIT INTEGER(I-N) 26 : REAL*8 X1 27 : * 28 : -INC CCOPTIO 29 : -INC SMCHAML 30 : -INC SMLREEL 31 : -INC SMCOORD 32 : * 33 : IRET=1 34 : IPCHAM=1 35 : IF(ISOM.EQ.0) THEN 36 : MCHEL1 = MCH 37 : SEGINI,MCHELM=MCHEL1 38 : ELSE 39 : MCHELM = MCH 40 : SEGACT MCHELM 41 : IPCHMA=0 42 : ENDIF 43 : * 44 : DO 1 ISOUS=1,ICHAML(/1) 45 : IF(ISOM.EQ.0) THEN 46 : MCHAM1=ICHAML(ISOUS) 47 : SEGINI,MCHAML=MCHAM1 48 : ICHAML(ISOUS)=MCHAML 49 : ELSE 50 : MCHAML=ICHAML(ISOUS) 51 : SEGACT MCHAML 52 : ENDIF 53 : * 54 : NCOMP=IELVAL(/1) 55 : * 56 : DO 30 ICOMP=1,NCOMP 57 : MELVAL=IELVAL(ICOMP) 58 : IF (TYPCHE(ICOMP).EQ.'REAL*8') THEN 59 : ICOD=1 60 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN 61 : ICOD=2 62 : ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN 63 : ICOD=3 64 : ELSE 65 : MOTERR(1:4)=NOMCHE(ICOMP) 65 : CALL ERREUR(197) 66 : IRET=0 67 : IF (ISOM.EQ.0) THEN 68 : SEGSUP MCHAML,MCHELM 69 : ELSE 70 : SEGDES MCHAML,MCHELM 71 : ENDIF 72 : RETURN 73 : ENDIF 74 : * 75 : SEGACT MELVAL 76 : N1PTEL=VELCHE(/1) 77 : N1EL =VELCHE(/2) 78 : N2PTEL=IELCHE(/1) 79 : N2EL =IELCHE(/2) 80 : * 81 : IF(ISOM.EQ.1) GOTO 10 82 : * 83 : SEGINI MELVA1 84 : IELVAL(ICOMP)=MELVA1 85 : * 86 : * 87 : IF(ICLE.EQ.1) THEN 88 : IF (ICOD.EQ.1) THEN 89 : DO 21 J=1,N1EL 90 : DO 21 L=1,N1PTEL 91 : IF (VELCHE(L,J).GT.X1) MELVA1.VELCHE(L,J)=1.D0 92 : 21 CONTINUE 93 : ELSE IF (ICOD.EQ.2) THEN 94 : DO 22 J=1,N2EL 95 : DO 22 L=1,N2PTEL 96 : MLREEL=IELCHE(L,J) 97 : SEGACT MLREEL 98 : JG=PROG(/1) 99 : SEGINI MLREE1 100 : DO 211 IPROG=1,JG 101 : IF (PROG(IPROG).GT.X1) MLREE1.PROG(IPROG)=1.D0 102 : 211 CONTINUE 103 : MELVA1.IELCHE(L,J)=MLREE1 104 : SEGDES MLREEL,MLREE1 105 : 22 CONTINUE 106 : ELSE IF (ICOD.EQ.3) THEN 107 : DO 23 J=1,N2EL 108 : DO 23 L=1,N2PTEL 109 : IP=IELCHE(L,J) 110 : IREF=(IP-1)*(IDIM+1) 111 : * 112 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 113 : * 114 : SEGACT MCOORD 115 : NBNO=XCOOR(/1)/(IDIM+1) 116 : NBNOI=NBNO 117 : NBPTS=NBNO+1 118 : SEGADJ MCOORD 119 : * 120 : DO 231 IC=1,IDIM 121 : IF (XCOOR(IREF+IC).GT.X1) THEN 122 : XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 123 : ELSE 124 : XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 125 : ENDIF 126 : 231 CONTINUE 127 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 128 : IELCHE(L,J)=NBPTS 129 : 23 CONTINUE 130 : ENDIF 131 : ELSE IF ( ICLE.EQ.2) THEN 132 : IF (ICOD.EQ.1) THEN 133 : DO 31 J=1,N1EL 134 : DO 31 L=1,N1PTEL 135 : IF (VELCHE(L,J).GE.X1) MELVA1.VELCHE(L,J)=1.D0 136 : 31 CONTINUE 137 : ELSE IF (ICOD.EQ.2) THEN 138 : DO 32 J=1,N2EL 139 : DO 32 L=1,N2PTEL 140 : MLREEL=IELCHE(L,J) 141 : SEGACT MLREEL 142 : JG=PROG(/1) 143 : SEGINI MLREE1 144 : DO 311 IPROG=1,JG 145 : IF (PROG(IPROG).GE.X1) MLREE1.PROG(IPROG)=1.D0 146 : 311 CONTINUE 147 : MELVA1.IELCHE(L,J)=MLREE1 148 : SEGDES MLREEL,MLREE1 149 : 32 CONTINUE 150 : ELSE IF (ICOD.EQ.3) THEN 151 : DO 33 J=1,N2EL 152 : DO 33 L=1,N2PTEL 153 : IP=IELCHE(L,J) 154 : IREF=(IP-1)*(IDIM+1) 155 : * 156 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 157 : * 158 : SEGACT MCOORD 159 : NBNO=XCOOR(/1)/(IDIM+1) 160 : NBNOI=NBNO 161 : NBPTS=NBNO+1 162 : SEGADJ MCOORD 163 : * 164 : DO 331 IC=1,IDIM 165 : IF (XCOOR(IREF+IC).GE.X1) THEN 166 : XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 167 : ELSE 168 : XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 169 : ENDIF 170 : 331 CONTINUE 171 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 172 : IELCHE(L,J)=NBPTS 173 : 33 CONTINUE 174 : ENDIF 175 : ELSE IF ( ICLE.EQ.3) THEN 176 : IF (ICOD.EQ.1) THEN 177 : DO 41 J=1,N1EL 178 : DO 41 L=1,N1PTEL 179 : IF (VELCHE(L,J).EQ.X1) MELVA1.VELCHE(L,J)=1.D0 180 : 41 CONTINUE 181 : ELSE IF (ICOD.EQ.2) THEN 182 : DO 42 J=1,N2EL 183 : DO 42 L=1,N2PTEL 184 : MLREEL=IELCHE(L,J) 185 : SEGACT MLREEL 186 : JG=PROG(/1) 187 : SEGINI MLREE1 188 : DO 411 IPROG=1,JG 189 : IF (PROG(IPROG).EQ.X1) MLREE1.PROG(IPROG)=1.D0 190 : 411 CONTINUE 191 : MELVA1.IELCHE(L,J)=MLREE1 192 : SEGDES MLREEL,MLREE1 193 : 42 CONTINUE 194 : ELSE IF (ICOD.EQ.3) THEN 195 : DO 43 J=1,N2EL 196 : DO 43 L=1,N2PTEL 197 : IP=IELCHE(L,J) 198 : IREF=(IP-1)*(IDIM+1) 199 : * 200 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 201 : * 202 : SEGACT MCOORD 203 : NBNO=XCOOR(/1)/(IDIM+1) 204 : NBNOI=NBNO 205 : NBPTS=NBNO+1 206 : SEGADJ MCOORD 207 : * 208 : DO 431 IC=1,IDIM 209 : IF (XCOOR(IREF+IC).EQ.X1) THEN 210 : XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 211 : ELSE 212 : XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 213 : ENDIF 214 : 431 CONTINUE 215 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 216 : IELCHE(L,J)=NBPTS 217 : 43 CONTINUE 218 : ENDIF 219 : ELSE IF ( ICLE.EQ.4) THEN 220 : IF (ICOD.EQ.1) THEN 221 : DO 51 J=1,N1EL 222 : DO 51 L=1,N1PTEL 223 : IF (VELCHE(L,J).LE.X1) MELVA1.VELCHE(L,J)=1.D0 224 : 51 CONTINUE 225 : ELSE IF (ICOD.EQ.2) THEN 226 : DO 52 J=1,N2EL 227 : DO 52 L=1,N2PTEL 228 : MLREEL=IELCHE(L,J) 229 : SEGACT MLREEL 230 : JG=PROG(/1) 231 : SEGINI MLREE1 232 : DO 511 IPROG=1,JG 233 : IF (PROG(IPROG).LE.X1) MLREE1.PROG(IPROG)=1.D0 234 : 511 CONTINUE 235 : MELVA1.IELCHE(L,J)=MLREE1 236 : SEGDES MLREEL,MLREE1 237 : 52 CONTINUE 238 : ELSE IF (ICOD.EQ.3) THEN 239 : DO 53 J=1,N2EL 240 : DO 53 L=1,N2PTEL 241 : IP=IELCHE(L,J) 242 : IREF=(IP-1)*(IDIM+1) 243 : * 244 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 245 : * 246 : SEGACT MCOORD 247 : NBNO=XCOOR(/1)/(IDIM+1) 248 : NBNOI=NBNO 249 : NBPTS=NBNO+1 250 : SEGADJ MCOORD 251 : * 252 : DO 531 IC=1,IDIM 253 : IF (XCOOR(IREF+IC).LE.X1) THEN 254 : XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 255 : ELSE 256 : XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 257 : ENDIF 258 : 531 CONTINUE 259 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 260 : IELCHE(L,J)=NBPTS 261 : 53 CONTINUE 262 : ENDIF 263 : ELSE IF ( ICLE.EQ.5) THEN 264 : IF (ICOD.EQ.1) THEN 265 : DO 61 J=1,N1EL 266 : DO 61 L=1,N1PTEL 267 : IF (VELCHE(L,J).LT.X1) MELVA1.VELCHE(L,J)=1.D0 268 : 61 CONTINUE 269 : ELSE IF (ICOD.EQ.2) THEN 270 : DO 62 J=1,N2EL 271 : DO 62 L=1,N2PTEL 272 : MLREEL=IELCHE(L,J) 273 : SEGACT MLREEL 274 : JG=PROG(/1) 275 : SEGINI MLREE1 276 : DO 611 IPROG=1,JG 277 : IF (PROG(IPROG).LT.X1) MLREE1.PROG(IPROG)=1.D0 278 : 611 CONTINUE 279 : MELVA1.IELCHE(L,J)=MLREE1 280 : SEGDES MLREEL,MLREE1 281 : 62 CONTINUE 282 : ELSE IF (ICOD.EQ.3) THEN 283 : DO 63 J=1,N2EL 284 : DO 63 L=1,N2PTEL 285 : IP=IELCHE(L,J) 286 : IREF=(IP-1)*(IDIM+1) 287 : * 288 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 289 : * 290 : SEGACT MCOORD 291 : NBNO=XCOOR(/1)/(IDIM+1) 292 : NBNOI=NBNO 293 : NBPTS=NBNO+1 294 : SEGADJ MCOORD 295 : * 296 : DO 631 IC=1,IDIM 297 : IF (XCOOR(IREF+IC).LT.X1) THEN 298 : XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 299 : ELSE 300 : XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 301 : ENDIF 302 : 631 CONTINUE 303 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 304 : IELCHE(L,J)=NBPTS 305 : 63 CONTINUE 306 : ENDIF 307 : ELSE IF ( ICLE.EQ.6) THEN 308 : IF (ICOD.EQ.1) THEN 309 : DO 71 J=1,N1EL 310 : DO 71 L=1,N1PTEL 311 : IF (VELCHE(L,J).NE.X1) MELVA1.VELCHE(L,J)=1.D0 312 : 71 CONTINUE 313 : ELSE IF (ICOD.EQ.2) THEN 314 : DO 72 J=1,N2EL 315 : DO 72 L=1,N2PTEL 316 : MLREEL=IELCHE(L,J) 317 : SEGACT MLREEL 318 : JG=PROG(/1) 319 : SEGINI MLREE1 320 : DO 711 IPROG=1,JG 321 : IF (PROG(IPROG).NE.X1) MLREE1.PROG(IPROG)=1.D0 322 : 711 CONTINUE 323 : MELVA1.IELCHE(L,J)=MLREE1 324 : SEGDES MLREEL,MLREE1 325 : 72 CONTINUE 326 : ELSE IF (ICOD.EQ.3) THEN 327 : DO 73 J=1,N2EL 328 : DO 73 L=1,N2PTEL 329 : IP=IELCHE(L,J) 330 : IREF=(IP-1)*(IDIM+1) 331 : * 332 : * ON CREE UN NVX POINTS :NOEUD NBNO+1 333 : * 334 : SEGACT MCOORD 335 : NBNO=XCOOR(/1)/(IDIM+1) 336 : NBNOI=NBNO 337 : NBPTS=NBNO+1 338 : SEGADJ MCOORD 339 : * 340 : DO 731 IC=1,IDIM 341 : IF (XCOOR(IREF+IC).NE.X1) THEN 342 : XCOOR(NBNOI*(IDIM+1)+IC)=1.D0 343 : ELSE 344 : XCOOR(NBNOI*(IDIM+1)+IC)=0.D0 345 : ENDIF 346 : 731 CONTINUE 347 : XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) 348 : IELCHE(L,J)=NBPTS 349 : 73 CONTINUE 350 : ENDIF 351 : ENDIF 352 : SEGDES MELVA1 353 : GO TO 20 354 : * 355 : 10 CONTINUE 356 : * 357 : IF(ICLE.EQ.1) THEN 358 : IF (ICOD.EQ.1) THEN 359 : DO 121 J=1,N1EL 360 : DO 121 L=1,N1PTEL 361 : IF (VELCHE(L,J).GT.X1) IPCHMA=IPCHMA+1 362 : 121 CONTINUE 363 : ELSE IF (ICOD.EQ.2) THEN 364 : DO 122 J=1,N2EL 365 : DO 122 L=1,N2PTEL 366 : MLREEL=IELCHE(L,J) 367 : SEGACT MLREEL 368 : JG=PROG(/1) 369 : DO 1122 IPROG=1,JG 370 : IF (PROG(IPROG).GT.X1) IPCHMA=IPCHAM+1 371 : 1122 CONTINUE 372 : SEGDES MLREEL 373 : 122 CONTINUE 374 : ELSE IF (ICOD.EQ.3) THEN 375 : DO 123 J=1,N2EL 376 : DO 123 L=1,N2PTEL 377 : IP=IELCHE(L,J) 378 : IREF=(IP-1)*(IDIM+1) 379 : * 380 : DO 1123 IC=1,IDIM 381 : IF (XCOOR(IREF+IC).GT.X1) IPCHMA=IPCHAM+1 382 : 1123 CONTINUE 383 : 123 CONTINUE 384 : ENDIF 385 : ELSE IF ( ICLE.EQ.2) THEN 386 : IF (ICOD.EQ.1) THEN 387 : DO 131 J=1,N1EL 388 : DO 131 L=1,N1PTEL 389 : IF (VELCHE(L,J).GE.X1) IPCHMA=IPCHMA+1 390 : 131 CONTINUE 391 : ELSE IF (ICOD.EQ.2) THEN 392 : DO 132 J=1,N2EL 393 : DO 132 L=1,N2PTEL 394 : MLREEL=IELCHE(L,J) 395 : SEGACT MLREEL 396 : JG=PROG(/1) 397 : DO 1132 IPROG=1,JG 398 : IF (PROG(IPROG).GE.X1) IPCHMA=IPCHMA+1 399 : 1132 CONTINUE 400 : SEGDES MLREEL 401 : 132 CONTINUE 402 : ELSE IF (ICOD.EQ.3) THEN 403 : DO 133 J=1,N2EL 404 : DO 133 L=1,N2PTEL 405 : IP=IELCHE(L,J) 406 : IREF=(IP-1)*(IDIM+1) 407 : * 408 : DO 1133 IC=1,IDIM 409 : IF (XCOOR(IREF+IC).GE.X1) IPCHMA=IPCHMA+1 410 : 1133 CONTINUE 411 : 133 CONTINUE 412 : ENDIF 413 : ELSE IF ( ICLE.EQ.3) THEN 414 : IF (ICOD.EQ.1) THEN 415 : DO 141 J=1,N1EL 416 : DO 141 L=1,N1PTEL 417 : IF (VELCHE(L,J).EQ.X1) IPCHMA=IPCHMA+1 418 : 141 CONTINUE 419 : ELSE IF (ICOD.EQ.2) THEN 420 : DO 142 J=1,N2EL 421 : DO 142 L=1,N2PTEL 422 : MLREEL=IELCHE(L,J) 423 : SEGACT MLREEL 424 : JG=PROG(/1) 425 : DO 1142 IPROG=1,JG 426 : IF (PROG(IPROG).EQ.X1) IPCHMA=IPCHMA+1 427 : 1142 CONTINUE 428 : SEGDES MLREEL 429 : 142 CONTINUE 430 : ELSE IF (ICOD.EQ.3) THEN 431 : DO 143 J=1,N2EL 432 : DO 143 L=1,N2PTEL 433 : IP=IELCHE(L,J) 434 : IREF=(IP-1)*(IDIM+1) 435 : * 436 : DO 1143 IC=1,IDIM 437 : IF (XCOOR(IREF+IC).EQ.X1) IPCHMA=IPCHMA+1 438 : 1143 CONTINUE 439 : 143 CONTINUE 440 : ENDIF 441 : ELSE IF ( ICLE.EQ.4) THEN 442 : IF (ICOD.EQ.1) THEN 443 : DO 151 J=1,N1EL 444 : DO 151 L=1,N1PTEL 445 : IF (VELCHE(L,J).LE.X1) IPCHMA=IPCHMA+1 446 : 151 CONTINUE 447 : ELSE IF (ICOD.EQ.2) THEN 448 : DO 152 J=1,N2EL 449 : DO 152 L=1,N2PTEL 450 : MLREEL=IELCHE(L,J) 451 : SEGACT MLREEL 452 : JG=PROG(/1) 453 : DO 1152 IPROG=1,JG 454 : IF (PROG(IPROG).LE.X1) IPCHMA=IPCHMA+1 455 : 1152 CONTINUE 456 : SEGDES MLREEL 457 : 152 CONTINUE 458 : ELSE IF (ICOD.EQ.3) THEN 459 : DO 153 J=1,N2EL 460 : DO 153 L=1,N2PTEL 461 : IP=IELCHE(L,J) 462 : IREF=(IP-1)*(IDIM+1) 463 : * 464 : DO 1153 IC=1,IDIM 465 : IF (XCOOR(IREF+IC).LE.X1) IPCHMA=IPCHMA+1 466 : 1153 CONTINUE 467 : 153 CONTINUE 468 : ENDIF 469 : ELSE IF ( ICLE.EQ.5) THEN 470 : IF (ICOD.EQ.1) THEN 471 : DO 161 J=1,N1EL 472 : DO 161 L=1,N1PTEL 473 : IF (VELCHE(L,J).LT.X1) IPCHMA=IPCHMA+1 474 : 161 CONTINUE 475 : ELSE IF (ICOD.EQ.2) THEN 476 : DO 162 J=1,N2EL 477 : DO 162 L=1,N2PTEL 478 : MLREEL=IELCHE(L,J) 479 : SEGACT MLREEL 480 : JG=PROG(/1) 481 : DO 1162 IPROG=1,JG 482 : IF (PROG(IPROG).LT.X1) IPCHMA=IPCHMA+1 483 : 1162 CONTINUE 484 : SEGDES MLREEL 485 : 162 CONTINUE 486 : ELSE IF (ICOD.EQ.3) THEN 487 : DO 163 J=1,N2EL 488 : DO 163 L=1,N2PTEL 489 : IP=IELCHE(L,J) 490 : IREF=(IP-1)*(IDIM+1) 491 : * 492 : DO 1163 IC=1,IDIM 493 : IF (XCOOR(IREF+IC).LT.X1) IPCHMA=IPCHMA+1 494 : 1163 CONTINUE 495 : 163 CONTINUE 496 : ENDIF 497 : ELSE IF ( ICLE.EQ.6) THEN 498 : IF (ICOD.EQ.1) THEN 499 : DO 171 J=1,N1EL 500 : DO 171 L=1,N1PTEL 501 : IF (VELCHE(L,J).NE.X1) IPCHMA=IPCHMA+1 502 : 171 CONTINUE 503 : ELSE IF (ICOD.EQ.2) THEN 504 : DO 172 J=1,N2EL 505 : DO 172 L=1,N2PTEL 506 : MLREEL=IELCHE(L,J) 507 : SEGACT MLREEL 508 : JG=PROG(/1) 509 : DO 1172 IPROG=1,JG 510 : IF (PROG(IPROG).NE.X1) IPCHMA=IPCHMA+1 511 : 1172 CONTINUE 512 : SEGDES MLREEL 513 : 172 CONTINUE 514 : ELSE IF (ICOD.EQ.3) THEN 515 : DO 173 J=1,N2EL 516 : DO 173 L=1,N2PTEL 517 : IP=IELCHE(L,J) 518 : IREF=(IP-1)*(IDIM+1) 519 : * 520 : DO 1173 IC=1,IDIM 521 : IF (XCOOR(IREF+IC).NE.X1) IPCHMA=IPCHMA+1 522 : 1173 CONTINUE 523 : 173 CONTINUE 524 : ENDIF 525 : ENDIF 526 : 20 CONTINUE 527 : SEGDES MELVAL 528 : 30 CONTINUE 529 : SEGDES MCHAML 530 : 1 CONTINUE 531 : IF(ISOM.EQ.0) THEN 532 : SEGDES MCHELM 533 : IPCHMA=MCHELM 534 : ENDIF 535 : SEGDES MCHELM 536 : RETURN 537 : END 538 : 539 : 540 :
© Cast3M 2003 - All rights reserved.
Disclaimer