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