1 : C AVISO SOURCE FANDEUR 13/01/29 21:15:08 7683 2 : C 3 : SUBROUTINE AVISO(MELEME,MCHPOI,MCHAM,IPMO1, 4 : > VCPCHA,VCHC,NISO,NCOUMA,VCHMIN,VCHMAX,MLREEL,MCARA, 5 : > NCOMP,LCOMP,COMPCH,choico) 6 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 7 : C 8 : C Préparation du tracé des isovaleurs d un objet 9 : c de type CHPOINT ou CHAMELEM 10 : C 11 : C Création 12 : C AOUT 85 13 : C 14 : C Modifications : 15 : C PM 09/11/2007 : 16 : C . ne conserve que le nb d'isovaleurs admissibles 17 : C si liste d'isovaleurs imposées 18 : C . accepte une liste d'isovaleurs non croissante 19 : C 20 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 21 : C 22 : IMPLICIT INTEGER(I-N) 23 : SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1)) 24 : -INC CCOPTIO 25 : -INC SMELEME 26 : -INC SMMODEL 27 : -INC SMCHPOI 28 : -INC SMCOORD 29 : -INC SMLREEL 30 : -INC SMCHAML 31 : -INC SMLMOTS 32 : REAL VCHC 33 : DIMENSION VCHC(*) 34 : c BP : indesou doit etre capable d'accueillir tous les nbsous modeles 35 : SEGMENT indesou(nbinde) 36 : * tableau des noms de composantes (chamelem) 37 : CHARACTER*(*) COMPCH(*) 38 : CHARACTER*8 CHOISI 39 : CHARACTER*4 CHOICO 40 : C 41 : * kich : modif ncomp etait deja initialise dans prtrac 42 : * NCOMP=0 43 : 44 : DO I=1,VCPCHA(/1) 45 : VCPCHA(I)=0 46 : ENDDO 47 : 48 : * Cas du MCHAML 49 : * ============= 50 : IF (MCHAM.NE.0) THEN 51 : * Si ce sont des contraintes, on rajoute le Von Mises 52 : MCHELM=MCHAM 53 : SEGACT MCHELM 54 : IUN=1 55 : DO IU=1,ICHAML(/1) 56 : MCHAML=ICHAML(IU) 57 : SEGACT MCHAML 58 : IF(IELVAL(/1).NE.1) IUN=0 59 : ENDDO 60 : IF (TITCHE.EQ.'CONTRAINTES'.AND.IUN.NE.1) THEN 61 : C Petit traitement pour retirer JOI1 du calcul de VMIS 62 : MMODEL=IPMO1 63 : SEGACT,MMODEL 64 : N1=KMODEL(/1) 65 : SEGINI,MMODE1 66 : NN1=0 67 : DO 3 IMO=1,N1 68 : IMODEL=KMODEL(IMO) 69 : SEGACT,IMODEL 70 : IF(INFELE(13).EQ.75) GOTO 3 71 : NN1=NN1+1 72 : MMODE1.KMODEL(NN1)=IMODEL 73 : SEGDES,IMODEL 74 : 3 CONTINUE 75 : IF(NN1.EQ.0) THEN 76 : SEGSUP,MMODE1 77 : SEGDES,MMODEL 78 : ELSE 79 : N1=NN1 80 : SEGADJ,MMODE1 81 : SEGDES,MMODEL,MMODE1 82 : IPMO1=MMODE1 82 : CALL VMISPO(IPMO1,MCHELM,MCARA,ICONV,MCHEL1,IRET) 83 : IF (IERR.NE.0) RETURN 84 : SEGACT MCHEL1 85 : DO 5 ISOUS=1,MCHEL1.IMACHE(/1) 86 : MCHAML=MCHEL1.ICHAML(ISOUS) 87 : SEGACT MCHAML*MOD 88 : NOMCHE(1)='VONMISES' 89 : 5 CONTINUE 89 : CALL FUSCHL(MCHEL1,MCHELM,MCHELO) 90 : MCHELM=MCHELO 91 : ENDIF 92 : ENDIF 93 : 94 : * On cree le MELEME a tracer 95 : * On stocke les MELVAL dans LISREF (très astucieux) 96 : SEGACT MCHELM 97 : NBSOUS=IMACHE(/1) 98 : NBREF=NBSOUS 99 : NBNN=0 100 : NBELEM=0 101 : SEGINI MELEME 102 : ITYPEL=0 103 : DO ISOUS=1,NBSOUS 104 : LISOUS(ISOUS)=IMACHE(ISOUS) 105 : ENDDO 106 : nbinde=NBSOUS 107 : segini,indesou 108 : * kich : pour des modeles heterogenes (ex massif + poutre) pb de trace 109 : ksou = 0 110 : DO ISOUS=1,NBSOUS 111 : IF (INFCHE(ISOUS,2).EQ.1.AND.INFCHE(ISOUS,6).NE.1) THEN 112 : * pas un chamelem aux noeuds 112 : CALL ERREUR(609) 113 : RETURN 114 : ENDIF 115 : MCHAML=ICHAML(ISOUS) 116 : SEGACT MCHAML 117 : 118 : * Constitution de la liste des noms de composantes COMPCH 119 : * kich : modif on crée une liste pour l ensemble du MCHELM 120 : * NCOMP=0 121 : CHOISI=' ' 122 : IF (LCOMP.NE.0) CHOISI=COMPCH(LCOMP) 123 : IF (LCOMP.EQ.0) LCOMP=1 124 : DO 25 ICOMP=1,TYPCHE(/2) 125 : IF (TYPCHE(1).NE.'REAL*8') GOTO 25 126 : DO JCOMP=1,NCOMP 127 : IF (COMPCH(JCOMP).EQ.NOMCHE(ICOMP)) GOTO 25 128 : ENDDO 129 : * COMPCH dimensionné à 10 dans PRTRAC 130 : IF (NCOMP.EQ.10) GOTO 25 131 : NCOMP=NCOMP+1 132 : COMPCH(NCOMP)=NOMCHE(ICOMP) 133 : IF (CHOISI.EQ.' ') CHOISI=NOMCHE(ICOMP) 134 : 25 CONTINUE 135 : IF (NCOMP.EQ.0) THEN 136 : * Il faut spécifier un champ par élément avec une seule composante 136 : CALL ERREUR(320) 137 : RETURN 138 : ENDIF 139 : * provisoirement 140 : * DO JCOMP=1,NCOMP 141 : * kich : c est nomche qu il faut tester 142 : DO ICOMP=1,TYPCHE(/2) 143 : * IF (COMPCH(JCOMP).EQ.CHOISI) LISREF(ISOUS)=IELVAL(JCOMP) 144 : IF (CHOISI.EQ.NOMCHE(ICOMP)) THEN 145 : LISREF(ISOUS)=IELVAL(ICOMP) 146 : ksou = ksou + 1 147 : indesou(ksou ) = isous 148 : ENDIF 149 : ENDDO 150 : IF (IERR.NE.0) RETURN 151 : SEGDES MCHAML 152 : ENDDO 153 : SEGDES MCHELM 154 : 155 : * verifie le meleme 156 : do jso = 1 ,ksou 157 : jsous = indesou(jso) 158 : lisous(jso) = lisous(jsous) 159 : lisref(jso) = lisref(jsous) 159 : if (lisref(jso).eq.0) call erreur(5) 160 : c write(6,*) 'verif', jso, lisous(jso),lisref(jso),lcomp 161 : enddo 162 : NBSOUS = ksou 163 : NBREF = NBSOUS 164 : segadj MELEME 165 : segsup,indesou 166 : 167 : * Calcul des extrema 168 : DO ISOUS=1,NBSOUS 169 : MELVAL=LISREF(ISOUS) 170 : IF (MELVAL.NE.0) THEN 171 : SEGACT MELVAL 172 : DO INN=1,VELCHE(/1) 173 : DO IEL=1,VELCHE(/2) 174 : VCHMIN=MIN(VCHMIN,REAL(VELCHE(INN,IEL))) 175 : VCHMAX=MAX(VCHMAX,REAL(VELCHE(INN,IEL))) 176 : ENDDO 177 : ENDDO 178 : ENDIF 179 : ENDDO 180 : ENDIF 181 : 182 : * Cas du CHPOINT 183 : * ============== 184 : IF (MCHAM.EQ.0) THEN 185 : * Récupération des valeurs du champ à tracer 186 : SEGACT MELEME 187 : SEGACT MCHPOI 188 : NSOUPO=IPCHP(/1) 189 : if(lcomp.eq.0) then 190 : nomp=0 191 : do isoupo=1,nsoupo 192 : msoupo=ipchp(isoupo) 193 : segact msoupo 194 : do nbpp=1,nocomp(/2) 195 : do ncbb=1,ncomp 196 : if( compch(ncbb).eq.nocomp(nbpp)) go to 43 197 : enddo 198 : * COMPCH dimensionné à 10 dans PRTRAC 199 : IF (NCOMP.EQ.10) GOTO 43 200 : ncomp=ncomp+1 201 : compch(ncomp)=nocomp(nbpp) 202 : 43 continue 203 : enddo 204 : enddo 205 : lcomp=1 206 : if( (compch(1).eq.'LX '. or . compch (1).eq.'FLX ' ) 207 : $ .and. ncomp.ge.2) lcomp=2 208 : endif 209 : choisi=compch(lcomp) 210 : DO ISOUPO=1,NSOUPO 211 : MSOUPO=IPCHP(ISOUPO) 212 : SEGACT MSOUPO 213 : MPOVAL=IPOVAL 214 : SEGACT MPOVAL 215 : IPT2=IGEOC 216 : SEGACT IPT2 217 : ncomp=0 218 : NCC=NOCOMP(/2) 219 : do ic=1,ncc 220 : if( choisi.eq.nocomp(ic)) go to 44 221 : enddo 222 : go to 45 223 : 44 continue 224 : DO IEL=1,IPT2.NUM(/2) 225 : IFOI=IPT2.NUM(1,IEL) 226 : VCPCHA(IFOI)=VPOCHA(IEL,IC) 227 : ENDDO 228 : 45 continue 229 : SEGDES IPT2,MPOVAL,MSOUPO 230 : ENDDO 231 : 232 : * Calcul des extrema 233 : IPT1=MELEME 234 : DO I=1,MAX(1,LISOUS(/1)) 235 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(I) 236 : SEGACT IPT1 237 : DO J=1,IPT1.NUM(/1) 238 : DO K=1,IPT1.NUM(/2) 239 : IPOIT=IPT1.NUM(J,K) 240 : VCHMIN=MIN(VCHMIN,REAL(VCPCHA(IPOIT))) 241 : VCHMAX=MAX(VCHMAX,REAL(VCPCHA(IPOIT))) 242 : ENDDO 243 : ENDDO 244 : IF (LISOUS(/1).NE.0) SEGDES IPT1 245 : ENDDO 246 : SEGDES MELEME 247 : SEGDES MCHPOI 248 : ENDIF 249 : C 250 : * Détermination de la liste d'isovaleurs 251 : * ====================================== 252 : **-- par défaut 253 : NISO=NCOUMA 254 : IF (ISOTYP.GT.0) NISO=NISO-1 255 : *-- d'après un LISTREEL en entrée 255 : IF (MLREEL.EQ.0) CALL LIROBJ ('LISTREEL',MLREEL,0,IRETOU) 256 : IF (MLREEL.EQ.0) GOTO 9800 257 : 258 : *PM On s'assure d'avoir une liste croissante 259 : SEGINI,MLREE1=MLREEL 259 : CALL ORDO01(MLREE1.PROG,MLREE1.PROG(/1),.TRUE.) 260 : SEGACT MLREEL 261 : * 262 : NISO=PROG(/1) 263 : IF (ISOTYP.GT.0) NISO=NISO+1 264 : *PM Limitation du nb d'isovaleurs au nombre de couleurs admissibles 265 : IF(NISO.GT.NCOUMA) THEN 266 : * write(IOIMP,*) 'ajustement à ',ncouma,' réels' 267 : JG=NCOUMA 268 : SEGADJ, MLREE1 269 : * on picore les valeurs parmi la liste entrée 270 : IDI = PROG(/1) / JG 271 : DO I=1,JG 272 : MLREE1.PROG(I)=PROG(1+((I-1)*IDI)) 273 : ENDDO 274 : NISO=NCOUMA 274 : * CALL ERREUR(201) 275 : * GOTO 9099 276 : ENDIF 277 : SEGDES, MLREEL 278 : 279 : *PM PET=-1E30 280 : DO I=1,MLREE1.PROG(/1) 281 : VCHC(I)=MLREE1.PROG(I) 282 : *PM IF (VCHC(I).LE.PET) THEN 283 : *PM* Valeurs non croissantes dans la table 283 : *PM CALL ERREUR(211) 284 : *PM RETURN 285 : *PM ELSE 286 : *PM PET=MAX(PET,VCHC(I)) 287 : *PM ENDIF 288 : ENDDO 289 : * Pas nécessaire ? 290 : *goo IF (ISOTYP.GT.0) VCHC(NISO)=VCHMAX 291 : SEGSUP MLREE1 292 : GOTO 9099 293 : 294 : *-- d'après un ENTIER en entrée 294 : 9800 CALL LIRENT(NIZO,0,IRETOU) 295 : IF (IRETOU.NE.0) NISO=MIN(NIZO,NISO) 296 : NISO=MAX(1,NISO) 297 : 298 : *-- Progression arithmétique entre les extrêmes 299 : 9900 CONTINUE 300 : C Si la valeur max est egal au min on ne prend qu'une couleur 301 : IF (VCHMIN.EQ.VCHMAX) NISO=1 302 : C 303 : DO I=1,NISO+1 304 : VCHC(I)=VCHMIN+(I-1)*(VCHMAX-VCHMIN)/NISO 305 : ENDDO 306 : C On essaie de repérer s'il y a des NaNQ 307 : IF (.NOT.(VCHC(1).EQ.VCHC(1))) THEN 308 : NISO=1 309 : DO I=1,NISO+1 310 : VCHC(I)=VCHMIN+(I-1)*(VCHMAX-VCHMIN)/NISO 311 : ENDDO 312 : ENDIF 313 : 314 : IT=0 315 : DO II=1,NISO 316 : IT=IT+1 317 : VCHC(IT)=(VCHC(II)+VCHC(II+1))/2 318 : ENDDO 319 : *gounand 320 : IF (ISOTYP.GT.0) NISO=NISO+1 321 : * Sortie 322 : * ====== 323 : 9099 CONTINUE 324 : SEGDES MELEME 325 : 326 : RETURN 327 : END 328 : 329 : 330 : 331 : 332 : 333 : 334 : 335 : 336 : 337 : 338 : 339 : 340 : 341 : 342 : 343 : 344 : 345 : 346 : 347 : 348 : 349 : 350 : 351 :
© Cast3M 2003 - All rights reserved.
Disclaimer