1 : C VECTE4 SOURCE BP208322 13/06/27 21:15:17 7782 2 : C 3 : SUBROUTINE VECTE4(MCHA1,MCHA2,MOD1,AMP,LMOT0,LMOT1,MVECT0) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : *---------------------------------------------------------------* 7 : * Creation d'un MVECTE a partir d'un MCHAML en vue * 8 : * d'un trace avec des petites fleches * 9 : * Largement inspiré de VECTE2 * 10 : * * 11 : * MCHA1 MCHAML * 12 : * MCHA2 MCHAML de CARACTERISTIQUES (coques epaisses) * 13 : * MOD1 MMODEL * 14 : * AMP coefficient d'amplification (FLOTTANT) * 15 : * LMOT0 liste des composantes a visualiser * 16 : * LMOT1 liste des couleurs affectees aux composantes * 17 : * MVECT0 pointeur sur MVECTE resultat * 18 : * * 19 : * CREATION , MODIFICATIONS : * 20 : * + Benoit Prabel, 01/03/2012 * 21 : * + Benoit Prabel, 19/06/2013 : on remplace les "ISUP.EQ.5"* 22 : * par des "ISUP.GE.5" ... * 23 : *---------------------------------------------------------------* 24 : -INC CCOPTIO 25 : -INC CCGEOME 26 : -INC SMCHPOI 27 : -INC SMCHAML 28 : -INC SMMODEL 29 : -INC SMVECTE 30 : -INC SMELEME 31 : -INC SMINTE 32 : -INC SMCOORD 33 : -INC SMLMOTS 34 : * 35 : SEGMENT NOTYPE 36 : CHARACTER*16 TYPE(NBTYPE) 37 : ENDSEGMENT 38 : SEGMENT MPTVAL 39 : INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU) 40 : CHARACTER*16 TYVAL(NCOSOU) 41 : ENDSEGMENT 42 : SEGMENT INFO 43 : INTEGER INFELL(JG) 44 : ENDSEGMENT 45 : SEGMENT IPPO(NPPO) 46 : SEGMENT MWRK1 47 : REAL*8 XEL(3,NBN1) 48 : ENDSEGMENT 49 : SEGMENT MWRK2 50 : REAL*8 TXR(3,3,NBN1),TH(NBN1) 51 : ENDSEGMENT 52 : * 53 : PARAMETER (NINF = 3) 54 : INTEGER INFOS(NINF) 55 : DIMENSION XIGAU(3),MOCOMP(3) 56 : CHARACTER*(NCONCH) CONM 57 : CHARACTER*8 CMATE 58 : CHARACTER*4 NOMVEC(6) 59 : PARAMETER (LTIT=72) 60 : CHARACTER*(LTIT) TITCH1 61 : DATA NOMVEC/'VEC1','VEC2','VEC3','VEC4','VEC5','VEC6'/ 62 : c CHARACTER*4 NOMVEC(3) 63 : c DATA NOMVEC/'SI11','SI22','SI33'/ 64 : 65 : 66 : ************************************************************************ 67 : * Preliminaires 68 : ************************************************************************ 69 : 70 : MVECT0 = 0 71 : SMAX = 0.D0 72 : * 73 : MCHELM = MCHA1 74 : SEGACT MCHELM 75 : * 76 : * Verification du support : noeuds ou pdi ? 77 : * 78 : ISUP = INFCHE(1,6) 79 : NSC = INFCHE(/1) 80 : DO 50 ISC=2,NSC 81 : ISUP1 = INFCHE(ISC,6) 82 : IF (ISUP1.NE.ISUP) ISUP = 0 83 : 50 CONTINUE 84 : * si ISUP = 1 : MCHAML aux noeuds 85 : * si ISUP = 5 : MCHAML aux point d integration 86 : * si ISUP = 6 : MCHAML aux point d integration de T 87 : IF (ISUP.NE.1.AND.ISUP.NE.5.AND.ISUP.NE.6) THEN 88 : write(6,*) 'vecte4: Support ISUP=',ISUP 88 : call erreur(609) 89 : SEGDES MCHELM 90 : RETURN 91 : ENDIF 92 : c on recupere TITCH1 dimensionné à 72 comme MOCHDE du SMCHPOI 93 : LTIT1 = min(LTIT,TITCHE(/1)) 94 : TITCH1(1:LTIT1) = TITCHE(1:LTIT1) 95 : SEGDES MCHELM 96 : 97 : * liste des composantes 98 : NMO0 = 0 99 : IF (LMOT0.NE.0) THEN 100 : MLMOT4 = LMOT0 101 : SEGACT MLMOT4 102 : NMO4 = MLMOT4.MOTS(/2) 103 : ENDIF 104 : NLIST = NMO4/idim 105 : * creation des NLIST nomid correspondants (meme role que IDVEC2) 106 : c NBROBL = idim+1 107 : NBROBL = idim 108 : NBRFAC = 0 109 : imo4=0 110 : do ilist=1,NLIST 111 : SEGINI NOMID 112 : MOCOMP(ilist)=NOMID 113 : c LESOBL(1) = NOMVEC(ilist) 114 : c do iobl=2,NBROBL 115 : do iobl=1,NBROBL 116 : imo4=imo4+1 117 : LESOBL(iobl)=MLMOT4.MOTS(imo4) 118 : enddo 119 : c write(6,*)'ilist,LESOBL=',ilist,' ',(LESOBL(iou),iou=1,NBROBL) 120 : SEGDES NOMID 121 : enddo 122 : NCOMP=NBROBL 123 : 124 : * liste des couleurs 125 : NMO = 0 126 : IF (LMOT1.NE.0) THEN 127 : MLMOTS = LMOT1 128 : SEGACT MLMOTS 129 : NMO = MOTS(/2) 130 : if (NMO.ne.NLIST) then 131 : write(ioimp,*) 'Incoherence dans la dimension de la liste', 132 : & 'des couleurs fournies : On l oublie.' 133 : segdes,MLMOTS 134 : MLMOTS=0 135 : LMOT1=0 136 : NMO=0 137 : endif 138 : ENDIF 139 : * 140 : MMODEL = MOD1 141 : SEGACT MMODEL 142 : NSOUS = KMODEL(/1) 143 : 144 : 145 : ************************************************************************ 146 : * Boucle sur les zones du MCHAML 147 : ************************************************************************ 148 : 149 : DO 100 ISOU = 1,NSOUS 150 : 151 : IVACOM = 0 152 : IVAEP = 0 153 : IMODEL = KMODEL(ISOU) 154 : SEGACT IMODEL 155 : IPMAIL = IMAMOD 156 : CONM = CONMOD 157 : MELE = NEFMOD 158 : MELEME = IMAMOD 159 : NFOR = FORMOD(/2) 160 : NMAT = MATMOD(/2) 161 : * 161 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) 162 : * 163 : if(infmod(/1).lt.7) then 163 : CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 164 : IF (IERR.NE.0) THEN 165 : SEGDES IMODEL,MMODEL 166 : RETURN 167 : ENDIF 168 : INFO = IPINF 169 : NBGS = INFELL(4) 170 : MFR = INFELL(13) 171 : MINTE = INFELL(11) 172 : MINTE1 = INFELL(12) 173 : segsup info 174 : else 175 : NBGS = INFELE(4) 176 : MFR = INFELE(13) 177 : MINTE=INFMOD(7) 178 : MINTE1 = INFMOD(8) 179 : endif 180 : * 181 : IPMINT = MINTE 182 : IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN 183 : MOTERR(1:16) = 'CARACTERISTIQUES' 183 : CALL ERREUR(565) 184 : SEGDES IMODEL,MMODEL 185 : RETURN 186 : ENDIF 187 : IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT MINTE1 188 : * 188 : CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET) 189 : IF (IRET.EQ.0) GOTO 900 190 : * 191 : SEGACT MINTE 192 : NBPGAU = POIGAU(/1) 193 : SEGACT MELEME 194 : NBN1 = NUM(/1) 195 : NBELE1 = NUM(/2) 196 : IF (ISUP.EQ.1) NIPO = NBN1 197 : IF (ISUP.GE.5) NIPO = NBPGAU 198 : SEGINI MWRK1 199 : NPPO = NIPO * NBELE1 200 : IF (ISUP.GE.5) SEGINI IPPO 201 : IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2 202 : * 203 : * Listes de composantes attendues 204 : * 204 : c CALL IDVEC2(IMODEL,1,IDIM,0,CMOT,MOCOMP,NCOMP, 205 : c & NLIST,IER1) 206 : c IF (IER1.NE.0) THEN 206 : c IF (IER1.EQ.1) call erreur(19) 207 : c IF (IER1.EQ.2) THEN 208 : c moterr(1:4) = CMOT 208 : c call erreur(197) 209 : c ENDIF 210 : c SEGDES IMODEL,MMODEL 211 : c RETURN 212 : c ENDIF 213 : * 214 : IF (NMO.NE.0) THEN 215 : IF (LMOT1.NE.0.AND.NLIST.NE.NMO) GOTO 900 216 : ENDIF 217 : * 218 : c NVEC = NLIST * 2 219 : NVEC = NLIST 220 : ID = 1 221 : SEGINI MVECTE 222 : * 223 : *======================================================================= 224 : * Boucle sur les listes de composantes 225 : * 226 : DO 150 IC = 1,NLIST 227 : c write(6,*) ' ' 228 : c write(6,*) '============ ISOU,IC=',ISOU,IC,' ============' 229 : 230 : NOMID = MOCOMP(IC) 231 : SEGACT NOMID 232 : IC2=IC 233 : c on ecrit pas le noms des composantes, mais de la liste de composante... 234 : NOCOVE(IC,1) = NOMVEC(IC) 235 : IF (LMOT1.EQ.0) THEN 236 : NOCOUL(IC) = IC+1 237 : ELSE 238 : ICOUL=IDCOUL+1 238 : CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC)) 239 : NOCOUL(IC) = ICOUL-1 240 : ENDIF 241 : c write(6,*) 'NOCOUL=',(NOCOUL(iou),iou=1,NLIST) 242 : IGEOV(IC) = 0 243 : * 244 : * Creation du MCHPOI puis du MSOUPO et du MPOVAL 245 : * 246 : NAT = 2 247 : NSOUPO = 1 248 : SEGINI MCHPOI 249 : ICHPO(IC) = MCHPOI 250 : MTYPOI = 'VECTEUR ' 251 : MOCHDE(1:LTIT1) = TITCH1(1:LTIT1) 252 : IFOPOI = IFOUR 253 : JATTRI(1) = 2 254 : JATTRI(2) = 0 255 : NC = IDIM 256 : SEGINI MSOUPO 257 : IPCHP(1) = MSOUPO 258 : NOCOMP(1) = 'VECX' 259 : NOCOMP(2) = 'VECY' 260 : IF (IDIM.EQ.3) NOCOMP(3) = 'VECZ' 261 : * 262 : N = NIPO * NBELE1 263 : SEGINI MPOVAL 264 : IPOVAL = MPOVAL 265 : * 266 : NBNN = 1 267 : NBELEM = N 268 : NBSOUS = 0 269 : NBREF = 0 270 : SEGINI IPT1 271 : IGEOC = IPT1 272 : IPT1.ITYPEL = 1 273 : * 274 : NBTYPE = 1 275 : SEGINI NOTYPE 276 : MOTYPE = NOTYPE 277 : TYPE(1) = 'REAL*8' 277 : CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC), 278 : & MOTYPE,1,INFOS,3,IVACOM) 279 : SEGSUP NOTYPE 280 : IF (IERR.NE.0) GOTO 900 281 : * 282 : * Cas des coques epaisses : epaisseur (excentrement) 283 : * 284 : IF (ISUP.GE.5.AND.MFR.EQ.5) THEN 285 : NBROBL = 1 286 : NBRFAC = 0 287 : SEGINI NOMID 288 : MOEP = NOMID 289 : LESOBL(1) = 'EPAI' 290 : NVEC = NBROBL + NBRFAC 291 : NBTYPE = 1 292 : SEGINI NOTYPE 293 : MOTYPE = NOTYPE 294 : TYPE(1) = 'REAL*8' 294 : CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP, 295 : & MOTYPE,1,INFOS,3,IVAEP) 296 : SEGSUP NOTYPE 297 : ENDIF 298 : * 299 : IPO = 0 300 : * 301 : *---------- Boucle sur les elements ------------------------------ 302 : * 303 : DO 200 IEL = 1,NBELE1 304 : * 305 : * cas general 305 : CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL) 306 : * 307 : * coques epaisses 308 : IF (ISUP.GE.5.AND.MFR.EQ.5) THEN 309 : MPTVAL = IVAEP 310 : MELVAL=IVAL(1) 311 : DO 201 IP = 1,NBN1 312 : IPMN=MIN(IP ,VELCHE(/1)) 313 : IEMN=MIN(IEL,VELCHE(/2)) 314 : TH(IP)=VELCHE(IPMN,IEMN) 315 : 201 CONTINUE 315 : CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR) 316 : ENDIF 317 : * 318 : *............. Boucle sur les points supports ............. 319 : * 320 : DO 300 IPSU = 1,NIPO 321 : IPO = IPO + 1 322 : * 323 : MPTVAL = IVACOM 324 : * 325 : DO 350 I1 = 1,IDIM 326 : MELVAL = IVAL(I1) 327 : IPMN = MIN(IPSU,VELCHE(/1)) 328 : IEMN = MIN(IEL ,VELCHE(/2)) 329 : COS1 = VELCHE(IPMN,IEMN) 330 : VPOCHA(IPO,I1) = COS1 331 : 350 CONTINUE 332 : * 333 : IF (ISUP.GE.5) THEN 334 : * 1er passage : on calcule les coord du pt d integration 335 : IF (IC.EQ.1) THEN 336 : IF (ISUP.GE.5.AND.MFR.EQ.5) THEN 337 : Z = DZEGAU(IPSU) 338 : DO 400 I2 = 1,IDIM 339 : XIGAU(I2) = 0.D0 340 : DO 400 IL = 1,NBN1 341 : XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)* 342 : & XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL)) 343 : 400 CONTINUE 344 : ELSE 345 : DO 410 I2 = 1,IDIM 346 : XIGAU(I2) = 0.D0 347 : DO 410 IL = 1,NBN1 348 : XIGAU(I2) = XIGAU(I2) + 349 : & (SHPTOT(1,IL,IPSU)*XEL(I2,IL)) 350 : 410 CONTINUE 351 : ENDIF 352 : * 353 : * Le pdi est reference dans MCOORD (PROVISOIRE) 354 : NBPTS = XCOOR(/1)/(IDIM+1)+1 355 : SEGADJ MCOORD 356 : XCOOR((NBPTS-1)*(IDIM+1)+1) = XIGAU(1) 357 : XCOOR((NBPTS-1)*(IDIM+1)+2) = XIGAU(2) 358 : IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=XIGAU(3) 359 : XCOOR(NBPTS*(IDIM+1)) = 0.D0 360 : IPT1.NUM(1,IPO) = NBPTS 361 : IPPO(IPO) = NBPTS 362 : * passage suivant : on recupere les coord du pdi 363 : ELSE 364 : IPT1.NUM(1,IPO) = IPPO(IPO) 365 : ENDIF 366 : ELSE 367 : IPT1.NUM(1,IPO) = NUM(IPSU,IEL) 368 : ENDIF 369 : 300 CONTINUE 370 : *............. fin de Boucle sur les points supports .......... 371 : 200 CONTINUE 372 : *---------- Fin de Boucle sur les elements ----------------------- 373 : SEGDES MPOVAL,MSOUPO,MCHPOI,IPT1 374 : 151 SEGDES NOMID 375 : 150 CONTINUE 376 : 377 : * Fin de Boucle sur les composantes 378 : *======================================================================= 379 : 380 : 381 : c IC1 = 0 382 : c DO 500 IC2 = NLIST+1,NLIST*2 383 : c IC1 = IC1 + 1 384 : c NOCOVE(IC2,1) = NOMVEC(IC1) 385 : c IF (LMOT1.EQ.0) THEN 386 : c NOCOUL(IC2) = IC1 + 1 387 : c ELSE 388 : c ICOUL=IDCOUL+1 388 : c CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1)) 389 : c NOCOUL(IC2) = ICOUL-1 390 : c ENDIF 391 : c IGEOV(IC2) = 0 392 : c MCHPOI = ICHPO(IC1) 392 : c CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1) 393 : c ICHPO(IC2) = ICHP2 394 : c 500 CONTINUE 395 : * 396 : * Desactivation des segments de la zone ISOU 397 : * 398 : SEGDES IMODEL,MINTE,MELEME 399 : IF (MFR.EQ.5) SEGDES MINTE1 400 : DO 105 I0 = 1,NCOMP 401 : IF (IVAL(I0).NE.0) THEN 402 : MELVAL = IVAL(I0) 403 : SEGDES,MELVAL 404 : ENDIF 405 : 105 CONTINUE 406 : SEGSUP MPTVAL,MWRK1 407 : IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2 408 : IF (ISUP.GE.5) SEGSUP IPPO 409 : c NCX = NLIST * 2 410 : NCX = NLIST 411 : c IF (CMOT.NE.' ') NCX = 2 412 : DO 101 IMX = 1,NCX 413 : AMPF(IMX) = AMP 414 : 101 CONTINUE 415 : SEGDES MVECTE 416 : * 417 : IF (MVECT0.EQ.0) THEN 418 : MVECT0 = MVECTE 419 : ELSE 419 : CALL FUSVEC(MVECT0,MVECTE,MVECT1) 420 : MVECT0 = MVECT1 421 : ENDIF 422 : * 423 : 100 CONTINUE 424 : SEGDES MMODEL 425 : IF (LMOT1.NE.0) SEGDES MLMOTS 426 : RETURN 427 : * 428 : 900 CONTINUE 429 : * 430 : RETURN 431 : END 432 : 433 : 434 : 435 : 436 : 437 : 438 : 439 : 440 : 441 : 442 : 443 : 444 : 445 : 446 : 447 : 448 : 449 :
© Cast3M 2003 - All rights reserved.
Disclaimer