1 : C VECTE SOURCE BP208322 12/05/10 21:15:05 7368 2 : C 3 : C------------------------------------------------------------------------- 4 : C 5 : C Opérateur VECTEUR 6 : C ----------------- 7 : C 8 : C VEC1 = VECT | CHPO1 (FLOT1) (| 'DEPL' | 'FORC' |) (COUL1) ; 9 : C | (| LMOT1 |) 10 : C | (| MOT1 MOT2 (MOT3 si 3D) |) 11 : C | 12 : C | CHAM1 (CHAM2) MOD1 (FLOT1) (MOCOMP1) (LISMO1) ; 13 : c | 14 : c | CHAM1 MOD1 (FLOT1) LCOMP1 (LISMO1); 15 : C 16 : C Objet : 17 : C _______ 18 : C 19 : C L'opérateur VECT construit un objet de type VECTEUR à partir : 20 : C - des composantes d'un champ de vecteurs, 21 : C - d'un champ par éléments de contraintes principales, 22 : C - d'un champ par éléments de variables internes. 23 : C 24 : C------------------------------------------------------------------------- 25 : C 26 : C VERIFICATION DE L'EXISTENCE D UN VECTEUR 27 : C VERSION OU ON NE LIT PAS DE MELEME 28 : C 29 : C------------------------------------------------------------------------- 30 : C 31 : C PM, 20/03/2007 : prise en compte de la couleur COUL1 32 : C BP, 04/05/2012 : ajout syntaxe 3 (appel a vecte4) 33 : C 34 : C------------------------------------------------------------------------- 35 : SUBROUTINE VECTE 36 : IMPLICIT INTEGER(I-N) 37 : -INC CCOPTIO 38 : -INC CCGEOME 39 : -INC SMCHPOI 40 : -INC SMVECTE 41 : -INC SMELEME 42 : -INC SMCHAML 43 : -INC CCREEL 44 : -INC SMCOORD 45 : -INC SMLMOTS 46 : CHARACTER*4 MOTVEC(2) 47 : CHARACTER*4 NV(3),NU(3),NOC 48 : CHARACTER*(4) CMOT 49 : REAL*8 AMP,xmin,xmax,ymin,ymax,zmin,zmax,vmin,vmax 50 : LOGICAL LSUPR 51 : DATA MOTVEC/ 'DEPL','FORC'/ 52 : DATA NU/'UX ','UY ','UZ '/ 53 : 54 : MELEME=0 55 : 55 : CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU) 56 : IF(IERR.NE.0) RETURN 57 : 58 : * 59 : * Cas du CHAMELEM 60 : * -------------- 61 : * 62 : IF (IRETOU.EQ.0) THEN 63 : * Lecture d'un CHAMELEM obligatoirement 64 : * de CONTRAINTES PRINCIPALES ou de VARIABLES INTERNES 64 : CALL LIROBJ('MCHAML',MCHA1,1,IRET) 65 : IF (IERR.NE.0) RETURN 66 : MCHELM = MCHA1 67 : SEGACT MCHELM 68 : ICAS = 0 69 : IF (TITCHE.EQ.'CONTRAINTES PRINCIPALES') ICAS = 1 70 : IF (TITCHE.EQ.'VARINTER' .OR. 71 : & TITCHE.EQ.'VARIABLES INTERNES') ICAS = 2 72 : IF (ICAS.EQ.0) THEN 73 : c Lecture obligatoire des composantes a afficher 74 : LMOT0 = 0 74 : CALL LIROBJ('LISTMOTS',LMOT0,1,IRET) 75 : if (IRET.ne.0) then 76 : ICAS = 3 77 : else 78 : write(IOIMP,*)'LES COMPOSANTES SONT OBLIGATOIRES POUR LES', 79 : & 'CHAMPS DE TYPE AUTRES QUE CONTRAINTES PRINCIPALES', 80 : & 'ou VARIABLES INTERNES' 81 : * L'objet de type %m1:8 n'a pas le bon sous-type 82 : MOTERR(1:8) = 'CHAMELEM' 82 : CALL ERREUR(302) 83 : SEGDES MCHELM 84 : RETURN 85 : endif 86 : ENDIF 87 : SEGDES MCHELM 88 : 89 : * Lecture éventuelle d'un CHAMELEM de caractéristiques 90 : MCHA2 = 0 90 : CALL LIROBJ('MCHAML',MCHA2,0,IRET) 91 : IF (IERR.NE.0) RETURN 92 : IF (MCHA2.NE.0) THEN 93 : MCHELM = MCHA2 94 : SEGACT MCHELM 95 : IF (TITCHE.NE.'CARACTERISTIQUES') THEN 96 : * Il manque un champ par élément de sous-type %m1:16 97 : MOTERR(1:16) = 'CARACTERISTIQUES' 97 : CALL ERREUR(565) 98 : SEGDES MCHELM 99 : RETURN 100 : ENDIF 101 : SEGDES MCHELM 102 : ENDIF 103 : 104 : 3 CONTINUE 105 : * Lecture du modèle 105 : CALL LIROBJ('MMODEL',MOD1,1,IRET) 106 : IF (IERR.NE.0) RETURN 107 : 108 : * Lecture du coefficient d'amplification optionnel 109 : AMP=1.D0 109 : CALL LIRREE(AMP,0,IRETOU) 110 : 111 : * Lecture éventuelle de la composante à conserver 112 : IF (ICAS.EQ.1) THEN 113 : CMOT = ' ' 113 : CALL LIRCHA(CMOT,0,IRETOU) 114 : ENDIF 115 : 116 : * Lecture de la liste des couleurs à employer pour chaque composante 117 : LMOT1 = 0 117 : CALL LIROBJ('LISTMOTS',LMOT1,0,IRET) 118 : IF (IERR.NE.0) RETURN 119 : 120 : * Création des vecteurs suivant les cas 121 : IF (ICAS.EQ.1) 121 : & CALL VECTE2(MCHA1,MCHA2,MOD1,AMP,CMOT,LMOT1,MVECTE) 122 : IF (ICAS.EQ.2) 122 : & CALL VECTE3(MCHA1,MCHA2,MOD1,AMP,LMOT1,MVECTE) 123 : IF (ICAS.EQ.3) 123 : & CALL VECTE4(MCHA1,MCHA2,MOD1,AMP,LMOT0,LMOT1,MVECTE) 124 : 125 : IF (IERR.NE.0) RETURN 125 : CALL ECROBJ ('VECTEUR ',MVECTE) 126 : RETURN 127 : ENDIF 128 : * 129 : * Cas du CHPOINT 130 : * -------------- 131 : * 132 : *-- Détermination de MLMOT1, listmots des composantes à prendre en compte 133 : * On essaie de lire les mot clés 'DEPL' 'FORC' 133 : CALL LIRMOT(MOTVEC,2,IMOT,0) 134 : IF (IMOT.NE.0) THEN 134 : CALL IDCOMP(MOTVEC(IMOT),MLMOT1) 135 : IF (IERR.NE.0) RETURN 136 : IRETOU=1 137 : LSUPR=.TRUE. 138 : ELSE 139 : * sinon on cherche un listmots de composantes 139 : CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU) 140 : LSUPR=.FALSE. 141 : ENDIF 142 : 143 : IF (IRETOU.NE.0) THEN 144 : SEGACT MLMOT1 145 : 146 : * Vérification du nombre de composantes 147 : NM=MLMOT1.MOTS(/2) 148 : IF (NM.LT.IDIM) THEN 149 : * routine %m1:8 : On voulait un %m9:16 à %i1 composantes au lieu de %i2 . 150 : MOTERR(1:8)='VECTE ' 151 : MOTERR(9:16)='LISTMOTS' 152 : INTERR(1)=IDIM 153 : INTERR(2)=NM 153 : CALL ERREUR(699) 154 : RETURN 155 : ENDIF 156 : 157 : * Stockage dans la table NV 158 : DO K=1,IDIM 159 : NV(K)=MLMOT1.MOTS(K) 160 : ENDDO 161 : 162 : IF (LSUPR) THEN 163 : SEGSUP MLMOT1 164 : ELSE 165 : SEGDES MLMOT1 166 : ENDIF 167 : ELSE 168 : * Si pas de listmots (implicite ou explicite), 169 : * on lit autant de mots que la dimension 170 : KOK=0 171 : DO 9 K=1,IDIM 171 : CALL LIRCHA(CMOT,0,IRETOU) 172 : IF (IRETOU.NE.0) THEN 173 : KOK=K 174 : NV(K)=CMOT 175 : ENDIF 176 : 9 CONTINUE 177 : 178 : IF (KOK.GT.0 .AND. KOK.LT.IDIM) THEN 179 : * Si le nombre de composantes est insuffisant, c'est qu'elles 180 : * n'étaient en fait pas données. On réécrit les mots lus 181 : * abusivement pour usage ultérieur 182 : DO K=1,KOK 183 : CMOT=NV(K) 183 : CALL ECRCHA(CMOT) 184 : ENDDO 185 : ENDIF 186 : ENDIF 187 : 188 : * Et enfin, si aucune spécification, on prend les composantes par 189 : * défaut dans la table NU. 190 : IF (IRETOU.EQ.0) THEN 191 : DO 8 L=1,IDIM 192 : NV(L)=NU(L) 193 : 8 CONTINUE 194 : ENDIF 195 : IF (IERR.NE.0) RETURN 196 : 197 : *-- Lecture de la couleur (valeur par défaut sinon) 197 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 198 : IF (ICOUL.EQ.0) ICOUL=IDCOUL+1 199 : ICOUL=ICOUL-1 200 : 201 : C VERIFICATION QU'IL Y A NV(K) PARMI LES INCONNUES DU CHPOINT 202 : C SEGACT MCHPOI 203 : C NSOUPO=IPCHP(/1) 204 : C IRAT=1 205 : C IF (NSOUPO.EQ.0) GOTO 13 206 : C DO 10 ISOUPO=1,NSOUPO 207 : C MSOUPO=IPCHP(ISOUPO) 208 : C SEGACT MSOUPO 209 : C NCV=NOCOMP(/2) 210 : C DO 11 I=1,NCV 211 : C NOC=NOCOMP(I) 212 : C DO 12 J=1,IDIM 213 : C IF (NOC.EQ.NV(J)) IRAT=0 214 : C 12 CONTINUE 215 : C 11 CONTINUE 216 : C SEGDES MSOUPO 217 : C 10 CONTINUE 218 : C MOTERR(1:4)=NV(1) 219 : C MOTERR(5:12)=MTYPOI 220 : C SEGDES MCHPOI 221 : C IF (IRAT.EQ.1) THEN 222 : C* La composante %m1:4 n'existe pas pour le champ %m5:8 222 : C CALL ERREUR(77) 223 : C ENDIF 224 : C 13 CONTINUE 225 : AMP=-xgrand 225 : CALL LIRREE(AMP,0,IRETOU) 226 : NVEC=1 227 : ID=IDIM 228 : SEGINI MVECTE 229 : IGEOV(NVEC)=MELEME 230 : ICHPO(NVEC)=MCHPOI 231 : AMPF(NVEC)=AMP 232 : NOCOUL(NVEC)=ICOUL 233 : DO 14 ID=1,IDIM 234 : NOCOVE(NVEC,ID)=NV(ID) 235 : 14 CONTINUE 236 : * Amplification automatique on calcul le coeff 237 : if (iretou.eq.0) then 238 : idimp1 = idim+1 239 : xmin=xgrand 240 : ymin=xgrand 241 : zmin=xgrand 242 : vmax=-xgrand 243 : xmax=-xgrand 244 : ymax=-xgrand 245 : zmax=-xgrand 246 : segact mchpoi 247 : do 50 i=1,ipchp(/1) 248 : msoupo=ipchp(i) 249 : segact msoupo 250 : meleme=igeoc 251 : mpoval=ipoval 252 : segact meleme,mpoval 253 : if (idim.eq.3) then 254 : do j=1,num(/2) 255 : ip=idimp1*(num(1,j)-1) 256 : xmin=min(xcoor(ip+1),xmin) 257 : xmax=max(xcoor(ip+1),xmax) 258 : ymin=min(xcoor(ip+2),ymin) 259 : ymax=max(xcoor(ip+2),ymax) 260 : zmin=min(xcoor(ip+3),zmin) 261 : zmax=max(xcoor(ip+3),zmax) 262 : enddo 263 : else if (idim.eq.2) then 264 : do j=1,num(/2) 265 : ip=idimp1*(num(1,j)-1) 266 : xmin=min(xcoor(ip+1),xmin) 267 : xmax=max(xcoor(ip+1),xmax) 268 : ymin=min(xcoor(ip+2),ymin) 269 : ymax=max(xcoor(ip+2),ymax) 270 : enddo 271 : else 272 : ** else if (idim.eq.1) then 273 : do j=1,num(/2) 274 : ip=idimp1*(num(1,j)-1) 275 : xmin=min(xcoor(ip+1),xmin) 276 : xmax=max(xcoor(ip+1),xmax) 277 : enddo 278 : endif 279 : do 62 ic=1,vpocha(/2) 280 : do 63 iv=1,idim 281 : if (nv(iv).ne.nocomp(ic)) goto 63 282 : do 64 j=1,vpocha(/1) 283 : vmax=max(vmax,abs(vpocha(j,ic))) 284 : 64 continue 285 : 63 continue 286 : 62 continue 287 : segdes meleme,mpoval,msoupo 288 : 50 continue 289 : segdes mchpoi 290 : * if (vmax.le.0.) vmax=1. 291 : if (vmax.le.xpetit) vmax=1.d0 292 : ampf(nvec)=max(ampf(nvec),(xmax-xmin)/(vmax*10)) 293 : if (idim.ge.2) then 294 : ampf(nvec)=max(ampf(nvec),(ymax-ymin)/(vmax*10)) 295 : if (idim.ge.3) 296 : & ampf(nvec)=max(ampf(nvec),(zmax-zmin)/(vmax*10)) 297 : endif 298 : endif 299 : SEGDES MVECTE 299 : CALL ECROBJ ('VECTEUR ',MVECTE) 300 : RETURN 301 : END 302 : 303 : 304 : 305 : 306 :
© Cast3M 2003 - All rights reserved.
Disclaimer