1 : C EXELCH SOURCE PV 09/03/12 21:21:56 6325 2 : SUBROUTINE EXELCH(IPCHEL,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL) 3 : * 4 : * EXTRAIRE LE OU LES ELEMENTS SUPPORTS DU MAXI OU DU MINI DES VALEURS 5 : * COMPOSANTES D'UN CHAMP/ELEMENT 6 : * 7 : ************************************************************************ 8 : * ENTREES : 9 : * 10 : * IPCHEL =POINTEUR SUR UN MCHAML 11 : * IMM = 1 MAXI , 2 MINI , 3 A 8 LES AUTRES 12 : * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES 13 : * IAV = 1 LES NOMS DE LA LISTMOTS SONT CONSIDERES ,2 ILS SONT EXC 14 : * IPLIS = POINTEUR SUR UN LISTMOTS 15 : * VALREF = VALEUR POUR FAIRE LES COMPARAISONS 16 : * VALRE2 = IDEM POUR OPTION 'COMPRIS' 17 : * 18 : * SORTIES : 19 : * 20 : * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES ELEMENTS 21 : * SUPPORTS DU MAXI OU DU MINI OU SATISFAISANT LES TESTS 22 : * PAR RAPPORT A VALREF 23 : * 24 : * P DOWLATYARI OCT 91 25 : ************************************************************************ 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8(A-H,O-Z) 28 : * 29 : -INC CCOPTIO 30 : -INC SMCHAML 31 : -INC SMELEME 32 : -INC SMCOORD 33 : -INC SMLMOTS 34 : * 35 : logical ltelq 36 : SEGMENT QUELCO 37 : INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS) 38 : ENDSEGMENT 39 : SEGMENT QQQQ 40 : INTEGER ICC(NBEL1) 41 : ENDSEGMENT 42 : * 43 : SEGMENT MESH 44 : INTEGER IMA(NSOUS),IMB(NSOUS) 45 : ENDSEGMENT 46 : * 47 : CHARACTER*4 MOCOMP 48 : * 49 : * INITIALISATIONS 50 : * 51 : IF(IAB.EQ.0)THEN 52 : IF(IMM.EQ.1)THEN 53 : XEXT=-1.D35 54 : ELSE 55 : XEXT=1.D35 56 : ENDIF 57 : ELSE 58 : IF(IMM.EQ.1)THEN 59 : XEXT=0.D0 60 : ELSE 61 : XEXT=1.D35 62 : ENDIF 63 : ENDIF 64 : * 65 : IF(IPLIS.NE.0)THEN 66 : MLMOTS=IPLIS 67 : SEGACT MLMOTS 68 : NC=MOTS(/2) 69 : ENDIF 70 : C 71 : C ON RECUPERE LE CHAMELEM 72 : C 73 : MCHELM=IPCHEL 74 : SEGACT MCHELM 75 : NSOUS=IMACHE(/1) 76 : 77 : * 78 : * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES 79 : * 80 : NCOMX = 0 81 : DO 10 ISOUS=1,NSOUS 82 : MCHAML=ICHAML(ISOUS) 83 : SEGACT MCHAML 84 : NCOMX=MAX(NCOMX,NOMCHE(/2)) 85 : 10 CONTINUE 86 : * 87 : IF(IPLIS.NE.0)SEGINI QUELCO 88 : * 89 : * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI 90 : * 91 : DO 500 ISOUS=1,NSOUS 92 : * 93 : MCHAML=ICHAML(ISOUS) 94 : NCOMP=NOMCHE(/2) 95 : IF(IPLIS.NE.0)THEN 96 : NCO=0 97 : DO 20 ICOMP=1,NCOMP 98 : MOCOMP=NOMCHE(ICOMP) 98 : CALL PLACE(MOTS,NC,IX,MOCOMP) 99 : IF(IAV.EQ.1)THEN 100 : IF(IX.NE.0)THEN 101 : ICO(ISOUS,ICOMP)=1 102 : NCO=NCO+1 103 : ELSE 104 : ICO(ISOUS,ICOMP)=0 105 : ENDIF 106 : ELSE 107 : IF(IX.EQ.0)THEN 108 : ICO(ISOUS,ICOMP)=1 109 : NCO=NCO+1 110 : ELSE 111 : ICO(ISOUS,ICOMP)=0 112 : ENDIF 113 : ENDIF 114 : 20 CONTINUE 115 : NNCO(ISOUS)=NCO 116 : ENDIF 117 : * 118 : * RECHERCHE DU MAXI OU MINI ( IMM = 1 OU 2 ) 119 : * 120 : IF(IMM.LE.2) THEN 121 : * 122 : IF(IPLIS.EQ.0)THEN 123 : DO 100 ICOMP=1,NCOMP 124 : MELVAL=IELVAL(ICOMP) 125 : SEGACT MELVAL 126 : NEL=VELCHE(/2) 127 : NBPTEL=VELCHE(/1) 128 : DO 200 IB=1,NEL 129 : DO 200 IGAU=1,NBPTEL 130 : XX=VELCHE(IGAU,IB) 131 : IF(IAB.EQ.1)XX=ABS(XX) 132 : IF(IMM.EQ.1) THEN 133 : XEXT=MAX(XX,XEXT) 134 : ELSE 135 : XEXT=MIN(XX,XEXT) 136 : ENDIF 137 : 200 CONTINUE 138 : SEGDES MELVAL 139 : 100 CONTINUE 140 : ELSEIF(NCO.NE.0)THEN 141 : DO 110 ICOMP=1,NCOMP 142 : IF(ICO(ISOUS,ICOMP).EQ.1)THEN 143 : MELVAL=IELVAL(ICOMP) 144 : SEGACT MELVAL 145 : NEL=VELCHE(/2) 146 : NBPTEL=VELCHE(/1) 147 : DO 210 IB=1,NEL 148 : DO 210 IGAU=1,NBPTEL 149 : XX=VELCHE(IGAU,IB) 150 : IF(IAB.EQ.1)XX=ABS(XX) 151 : IF(IMM.EQ.1) THEN 152 : XEXT=MAX(XX,XEXT) 153 : ELSE 154 : XEXT=MIN(XX,XEXT) 155 : ENDIF 156 : 210 CONTINUE 157 : SEGDES MELVAL 158 : ENDIF 159 : 110 CONTINUE 160 : ENDIF 161 : * 162 : ENDIF 163 : SEGDES MCHAML 164 : 500 CONTINUE 165 : * 166 : IF(IPLIS.NE.0)THEN 167 : SEGDES MLMOTS 168 : NZERO=0 169 : DO 510 ISOUS=1,NSOUS 170 : IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1 171 : 510 CONTINUE 172 : IF(NZERO.EQ.NSOUS)THEN 172 : CALL ERREUR(280) 173 : SEGDES MCHELM 174 : SEGSUP QUELCO 175 : IPMAIL=0 176 : RETURN 177 : ENDIF 178 : ENDIF 179 : * 180 : * 181 : * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS 182 : * 183 : SEGINI MESH 184 : DO 600 ISOUS=1,NSOUS 185 : * 186 : MCHAML=ICHAML(ISOUS) 187 : SEGACT MCHAML 188 : NCOMP=NOMCHE(/2) 189 : IPT1=IMACHE(ISOUS) 190 : SEGACT IPT1 191 : NBNN1=IPT1.NUM(/1) 192 : NBEL1=IPT1.NUM(/2) 193 : NBNN=NBNN1 194 : NBELEM=0 195 : NBSOUS=0 196 : NBREF=0 197 : segini QQQQ 198 : SEGINI MELEME 199 : ITYPEL=IPT1.ITYPEL 200 : IF(IPLIS.EQ.0)THEN 201 : DO 300 ICOMP=1,NCOMP 202 : MELVAL=IELVAL(ICOMP) 203 : SEGACT MELVAL 204 : NBPTEL=VELCHE(/1) 205 : NEL=VELCHE(/2) 206 : DO 400 IB=1,NBEL1 207 : IBMN=MIN(IB,NEL) 208 : DO 401 IGAU=1,NBPTEL 209 : XX=VELCHE(IGAU,IBMN) 210 : IF(IAB.EQ.1)XX=ABS(XX) 211 : * 212 : * TRI SELON LA VALEUR DE IMM 213 : * 214 : GO TO (21,21,23,24,25,26,27,28,29),IMM 215 : * 215 : CALL ERREUR(280) 216 : SEGDES MELVAL 217 : SEGDES MCHELM 218 : SEGSUP QUELCO 219 : IPMAIL=0 220 : RETURN 221 : * 222 : * MAXI OU MINI 223 : 21 IF(XX.EQ.XEXT) GO TO 403 224 : GO TO 401 225 : * 226 : * SUPE 227 : 23 IF(XX.GT.VALREF) GO TO 403 228 : GO TO 401 229 : * 230 : * EGSUPE 231 : 24 IF(XX.GE.VALREF) GO TO 403 232 : GO TO 401 233 : * 234 : * EGAL 235 : 25 IF(XX.EQ.VALREF) GO TO 403 236 : GO TO 401 237 : * 238 : * EGINFE 239 : 26 IF(XX.LE.VALREF) GO TO 403 240 : GO TO 401 241 : * 242 : * INFE 243 : 27 IF(XX.LT.VALREF) GO TO 403 244 : GO TO 401 245 : * 246 : * DIFF 247 : 28 IF(XX.NE.VALREF) GO TO 403 248 : GO TO 401 249 : * 250 : * COMP 251 : 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 403 252 : GO TO 401 253 : * 254 : 401 CONTINUE 255 : GO TO 400 256 : * 257 : 403 CONTINUE 258 : if (ICC(IB).eq.0) then 259 : icc(ib) = 1 260 : NBELEM=NBELEM+1 261 : SEGADJ MELEME 262 : DO 405 INO=1,NBNN 263 : NUM(INO,NBELEM)=IPT1.NUM(INO,IB) 264 : 405 CONTINUE 265 : ICOLOR(NBELEM)=IPT1.ICOLOR(IB) 266 : endif 267 : * 268 : 400 CONTINUE 269 : SEGDES MELVAL 270 : 300 CONTINUE 271 : * 272 : ELSEIF(NNCO(ISOUS).NE.0)THEN 273 : 274 : DO 310 ICOMP=1,NCOMP 275 : IF(ICO(ISOUS,ICOMP).EQ.1)THEN 276 : MELVAL=IELVAL(ICOMP) 277 : SEGACT MELVAL 278 : NBPTEL=VELCHE(/1) 279 : NEL=VELCHE(/2) 280 : DO 410 IB=1,NBEL1 281 : IBMN=MIN(IB,NEL) 282 : DO 411 IGAU=1,NBPTEL 283 : XX=VELCHE(IGAU,IBMN) 284 : IF(IAB.EQ.1)XX=ABS(XX) 285 : * 286 : * TRI SELON LA VALEUR DE IMM 287 : * 288 : GO TO (31,31,33,34,35,36,37,38,39),IMM 289 : * 289 : CALL ERREUR(280) 290 : SEGDES MELVAL 291 : SEGDES MCHELM 292 : SEGSUP QUELCO 293 : IPMAIL=0 294 : RETURN 295 : * 296 : * MAXI OU MINI 297 : 31 IF(XX.EQ.XEXT) GO TO 413 298 : GO TO 411 299 : * 300 : * SUPE 301 : 33 IF(XX.GT.VALREF) GO TO 413 302 : GO TO 411 303 : * 304 : * EGSUPE 305 : 34 IF(XX.GE.VALREF) GO TO 413 306 : GO TO 411 307 : * 308 : * EGAL 309 : 35 IF(XX.EQ.VALREF) GO TO 413 310 : GO TO 411 311 : * 312 : * EGINFE 313 : 36 IF(XX.LE.VALREF) GO TO 413 314 : GO TO 411 315 : * 316 : * INFE 317 : 37 IF(XX.LT.VALREF) GO TO 413 318 : GO TO 411 319 : * 320 : * DIFF 321 : 38 IF(XX.NE.VALREF) GO TO 413 322 : GO TO 411 323 : * 324 : * COMP 325 : 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 413 326 : GO TO 411 327 : * 328 : 411 CONTINUE 329 : GO TO 410 330 : * 331 : 413 CONTINUE 332 : if (ICC(IB).eq.0) then 333 : icc(ib) = 1 334 : NBELEM=NBELEM+1 335 : SEGADJ MELEME 336 : DO 406 INO=1,NBNN 337 : NUM(INO,NBELEM)=IPT1.NUM(INO,IB) 338 : 406 CONTINUE 339 : ICOLOR(NBELEM)=IPT1.ICOLOR(IB) 340 : endif 341 : * 342 : 410 CONTINUE 343 : SEGDES MELVAL 344 : ENDIF 345 : 310 CONTINUE 346 : 347 : * 348 : ENDIF 349 : 350 : SEGDES,MCHAML,IPT1 351 : 352 : IF(NBELEM.EQ.0)THEN 353 : SEGSUP MELEME 354 : IMA(ISOUS)=0 355 : ELSE 356 : SEGDES MELEME 357 : IMA(ISOUS)=MELEME 358 : IMB(ISOUS)=MELEME 359 : ENDIF 360 : segsup QQQQ 361 : 600 CONTINUE 362 : * 363 : NMAIL=0 364 : DO 610 ISOUS=1,NSOUS 365 : IF(IMA(ISOUS).NE.0)THEN 366 : NMAIL=NMAIL+1 367 : ISOU1=ISOUS 368 : ENDIF 369 : 610 CONTINUE 370 : * 371 : IF(NMAIL.EQ.1)THEN 372 : IPMAIL=IMA(ISOU1) 373 : ELSE 374 : NBSOUS=NMAIL 375 : NBREF=0 376 : NBNN=0 377 : NBELEM=0 378 : SEGINI MELEME 379 : 380 : DO ISOUS = 1,NSOUS 381 : IF(IMA(ISOUS).NE.0) THEN 382 : IPP1 = IMA(ISOUS) 383 : ima(isous) = 0 384 : GOTO 618 385 : ENDIF 386 : ENDDO 387 : * 388 : 618 CONTINUE 389 : DO 620 ISOUS=2,NSOUS 390 : IF(IMA(ISOUS).NE.0) THEN 391 : IPP2= IMA(ISOUS) 392 : ltelq=.false. 392 : CALL FUSE(IPP1,IPP2,MELEME,ltelq) 393 : ipt1 = ipp1 394 : segdes ipt1 395 : IPP1 = MELEME 396 : ENDIF 397 : 620 CONTINUE 398 : SEGACT MELEME 399 : DO ISOUS = 1,NSOUS 400 : IPT1 = IMB(ISOUS) 401 : DO IZ = 1,NBSOUS 402 : IF(IPT1.EQ.LISOUS(IZ)) GOTO 621 403 : ENDDO 404 : SEGSUP IPT1 405 : 621 CONTINUE 406 : ENDDO 407 : 408 : SEGDES MELEME 409 : IPMAIL=MELEME 410 : ENDIF 411 : SEGDES MCHELM 412 : IF(IPLIS.NE.0)SEGSUP QUELCO 413 : SEGSUP MESH 414 : RETURN 415 : END 416 : 417 : 418 : 419 : 420 : 421 :
© Cast3M 2003 - All rights reserved.
Disclaimer