1 : C EXPCHP SOURCE CHAT 05/01/12 23:51:20 5004 2 : SUBROUTINE EXPCHP(IPCHPO,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/POINT 6 : * 7 : ************************************************************************ 8 : * ENTREES : 9 : * 10 : * IPCHPO =POINTEUR SUR UN CHPOINT 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 OU AUTRES 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 SMCHPOI 30 : -INC SMELEME 31 : -INC SMCOORD 32 : -INC SMLMOTS 33 : * 34 : SEGMENT QUELCO 35 : INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS) 36 : ENDSEGMENT 37 : * SEGMENT ICPR(xcoor(/1)/(IDIM+1)) 38 : CHARACTER*4 MOCOMP 39 : DIMENSION XE(3,1) 40 : * 41 : * INITIALISATIONS 42 : * 43 : IF(IAB.EQ.0)THEN 44 : IF(IMM.EQ.1)THEN 45 : XEXT=-1.D35 46 : ELSE 47 : XEXT=1.D35 48 : ENDIF 49 : ELSE 50 : IF(IMM.EQ.1)THEN 51 : XEXT=0.D0 52 : ELSE 53 : XEXT=1.D35 54 : ENDIF 55 : ENDIF 56 : * 57 : IF(IPLIS.NE.0)THEN 58 : MLMOTS=IPLIS 59 : SEGACT MLMOTS 60 : NC=MOTS(/2) 61 : ENDIF 62 : * 63 : * ON RECUPERE LE CHPOINT 64 : * 65 : MCHPOI=IPCHPO 66 : SEGACT MCHPOI 67 : NSOUS = IPCHP(/1) 68 : 69 : * 70 : * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES 71 : * 72 : NCOMX = 0 73 : DO 10 ISOUS=1,NSOUS 74 : MSOUPO=IPCHP(ISOUS) 75 : SEGACT MSOUPO 76 : NCOMX=MAX(NCOMX,NOCOMP(/2)) 77 : 10 CONTINUE 78 : * 79 : IF(IPLIS.NE.0)SEGINI QUELCO 80 : 81 : * 82 : * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI 83 : * SI IMM = 1 OU 2 84 : * 85 : DO 500 ISOUS=1,NSOUS 86 : * 87 : MSOUPO=IPCHP(ISOUS) 88 : NCOMP=NOCOMP(/2) 89 : IF(IPLIS.NE.0)THEN 90 : NCO=0 91 : DO 20 ICOMP=1,NCOMP 92 : MOCOMP=NOCOMP(ICOMP) 92 : CALL PLACE(MOTS,NC,IX,MOCOMP) 93 : IF(IAV.EQ.1)THEN 94 : IF(IX.NE.0)THEN 95 : ICO(ISOUS,ICOMP)=1 96 : NCO=NCO+1 97 : ELSE 98 : ICO(ISOUS,ICOMP)=0 99 : ENDIF 100 : ELSE 101 : IF(IX.EQ.0)THEN 102 : ICO(ISOUS,ICOMP)=1 103 : NCO=NCO+1 104 : ELSE 105 : ICO(ISOUS,ICOMP)=0 106 : ENDIF 107 : ENDIF 108 : 20 CONTINUE 109 : NNCO(ISOUS)=NCO 110 : ENDIF 111 : * 112 : IF(IMM.LE.2) THEN 113 : * 114 : IF(IPLIS.EQ.0)THEN 115 : MPOVAL=IPOVAL 116 : SEGACT MPOVAL 117 : N=VPOCHA(/1) 118 : DO 100 ICOMP=1,NCOMP 119 : DO 100 IB=1,N 120 : XX=VPOCHA(IB,ICOMP) 121 : IF(IAB.EQ.1) XX=ABS(XX) 122 : IF(IMM.EQ.1)THEN 123 : XEXT=MAX(XX,XEXT) 124 : ELSE 125 : XEXT=MIN(XX,XEXT) 126 : ENDIF 127 : 100 CONTINUE 128 : SEGDES MPOVAL 129 : ELSEIF(NCO.NE.0)THEN 130 : MPOVAL=IPOVAL 131 : SEGACT MPOVAL 132 : N=VPOCHA(/1) 133 : DO 110 ICOMP=1,NCOMP 134 : IF(ICO(ISOUS,ICOMP).EQ.1)THEN 135 : DO 210 IB=1,N 136 : XX=VPOCHA(IB,ICOMP) 137 : IF(IAB.EQ.1) XX=ABS(XX) 138 : IF(IMM.EQ.1)THEN 139 : XEXT=MAX(XX,XEXT) 140 : ELSE 141 : XEXT=MIN(XX,XEXT) 142 : ENDIF 143 : 210 CONTINUE 144 : ENDIF 145 : 110 CONTINUE 146 : SEGDES MPOVAL 147 : ENDIF 148 : ENDIF 149 : * 150 : SEGDES MSOUPO 151 : 500 CONTINUE 152 : IF(IPLIS.NE.0)THEN 153 : SEGDES MLMOTS 154 : NZERO=0 155 : DO 510 ISOUS=1,NSOUS 156 : IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1 157 : 510 CONTINUE 158 : IF(NZERO.EQ.NSOUS)THEN 158 : CALL ERREUR(280) 159 : SEGDES MCHPOI 160 : SEGSUP QUELCO 161 : IPMAIL=0 162 : RETURN 163 : ENDIF 164 : ENDIF 165 : * 166 : * CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS 167 : * 168 : NBNN=1 169 : NBELEM=XCOOR(/1)/(IDIM+1) 170 : NBSOUS=0 171 : NBREF=0 172 : SEGINI MELEME 173 : IPMAIL=MELEME 174 : ITYPEL=1 175 : NBELEM=0 176 : * 177 : * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS 178 : * 179 : DO 600 ISOUS=1,NSOUS 180 : * 181 : MSOUPO=IPCHP(ISOUS) 182 : SEGACT MSOUPO 183 : NCOMP=NOCOMP(/2) 184 : IPT1=IGEOC 185 : SEGACT IPT1 186 : IF(IPLIS.EQ.0)THEN 187 : MPOVAL=IPOVAL 188 : SEGACT MPOVAL 189 : N=VPOCHA(/1) 190 : DO 300 ICOMP=1,NCOMP 191 : DO 300 IB=1,N 192 : XX=VPOCHA(IB,ICOMP) 193 : IF(IAB.EQ.1)XX=ABS(XX) 194 : * 195 : * TRI SELON LA VALEUR DE IMM 196 : * 197 : GO TO (21,21,23,24,25,26,27,28,29),IMM 198 : * 198 : CALL ERREUR(280) 199 : SEGDES MCHPOI 200 : SEGSUP QUELCO 201 : IPMAIL=0 202 : RETURN 203 : * 204 : * MAXI OU MINI 205 : 21 IF(XX.EQ.XEXT) GO TO 303 206 : GO TO 300 207 : * 208 : * SUPE 209 : 23 IF(XX.GT.VALREF) GO TO 303 210 : GO TO 300 211 : * 212 : * EGSUPE 213 : 24 IF(XX.GE.VALREF) GO TO 303 214 : GO TO 300 215 : * 216 : * EGAL 217 : 25 IF(XX.EQ.VALREF) GO TO 303 218 : GO TO 300 219 : * 220 : * EGINFE 221 : 26 IF(XX.LE.VALREF) GO TO 303 222 : GO TO 300 223 : * 224 : * INFE 225 : 27 IF(XX.LT.VALREF) GO TO 303 226 : GO TO 300 227 : * 228 : * DIFF 229 : 28 IF(XX.NE.VALREF) GO TO 303 230 : GO TO 300 231 : * 232 : * COMP 233 : 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 303 234 : GO TO 300 235 : * 236 : 303 CONTINUE 237 : NBELEM=NBELEM+1 238 : * SEGADJ MELEME 239 : NUM(1,NBELEM)=IPT1.NUM(1,IB) 240 : * 241 : 300 CONTINUE 242 : SEGDES MPOVAL 243 : * 244 : ELSEIF(NNCO(ISOUS).NE.0)THEN 245 : MPOVAL=IPOVAL 246 : SEGACT MPOVAL 247 : N=VPOCHA(/1) 248 : DO 310 ICOMP=1,NCOMP 249 : IF(ICO(ISOUS,ICOMP).EQ.1)THEN 250 : DO 410 IB=1,N 251 : XX=VPOCHA(IB,ICOMP) 252 : IF(IAB.EQ.1)XX=ABS(XX) 253 : * 254 : * 255 : * TRI SELON LA VALEUR DE IMM 256 : * 257 : GO TO (31,31,33,34,35,36,37,38,39),IMM 258 : * 258 : CALL ERREUR(280) 259 : SEGDES MCHPOI 260 : SEGSUP QUELCO 261 : IPMAIL=0 262 : RETURN 263 : * 264 : * MAXI OU MINI 265 : 31 IF(XX.EQ.XEXT) GO TO 413 266 : GO TO 410 267 : * 268 : * SUPE 269 : 33 IF(XX.GT.VALREF) GO TO 413 270 : GO TO 410 271 : * 272 : * EGSUPE 273 : 34 IF(XX.GE.VALREF) GO TO 413 274 : GO TO 410 275 : * 276 : * EGAL 277 : 35 IF(XX.EQ.VALREF) GO TO 413 278 : GO TO 410 279 : * 280 : * EGINFE 281 : 36 IF(XX.LE.VALREF) GO TO 413 282 : GO TO 410 283 : * 284 : * INFE 285 : 37 IF(XX.LT.VALREF) GO TO 413 286 : GO TO 410 287 : * 288 : * DIFF 289 : 38 IF(XX.NE.VALREF) GO TO 413 290 : GO TO 410 291 : * 292 : * COMP 293 : 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 413 294 : GO TO 410 295 : * 296 : 413 CONTINUE 297 : NBELEM=NBELEM+1 298 : * SEGADJ MELEME 299 : NUM(1,NBELEM)=IPT1.NUM(1,IB) 300 : 410 CONTINUE 301 : * 302 : ENDIF 303 : 310 CONTINUE 304 : SEGDES MPOVAL 305 : ENDIF 306 : SEGDES MSOUPO,IPT1 307 : * 308 : 600 CONTINUE 309 : SEGADJ MELEME 310 : SEGDES MCHPOI,MELEME 311 : IF(IPLIS.NE.0)SEGSUP QUELCO 312 : RETURN 313 : END 314 : 315 :
© Cast3M 2003 - All rights reserved.
Disclaimer