1 : C VECTE3 SOURCE CHAT 11/03/16 21:33:28 6902 2 : SUBROUTINE VECTE3(MCHA1,MCHA2,MOD1,AMP,LMOT1,MVECT0) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *---------------------------------------------------------------* 6 : * Creation d'un MVECTE a partir d'un MCHAML en vue * 7 : * d'un trace avec des petites fleches * 8 : * * 9 : * MCHA1 MCHAML de VARIables INTERnes * 10 : * MCHA2 MCHAML de CARACTERISTIQUES (coques epaisses) * 11 : * MOD1 MMODEL * 12 : * AMP coefficient d'amplification (FLOTTANT) * 13 : * LMOT1 liste des couleurs affectees aux composantes * 14 : * MVECT0 pointeur sur MVECTE resultat * 15 : * * 16 : * D. R.-M. mai & juin 1994 * 17 : * D. R.-M. juillet 1995 --> massifs isotropes 3D * 18 : * coques 2D et 3D * 19 : *---------------------------------------------------------------* 20 : -INC CCOPTIO 21 : -INC CCGEOME 22 : -INC SMCHPOI 23 : -INC SMCHAML 24 : -INC SMMODEL 25 : -INC SMVECTE 26 : -INC SMELEME 27 : -INC SMINTE 28 : -INC SMCOORD 29 : -INC SMLMOTS 30 : * 31 : SEGMENT NOTYPE 32 : CHARACTER*16 TYPE(NBTYPE) 33 : ENDSEGMENT 34 : SEGMENT MPTVAL 35 : INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU) 36 : CHARACTER*16 TYVAL(NCOSOU) 37 : ENDSEGMENT 38 : SEGMENT INFO 39 : INTEGER INFELL(JG) 40 : ENDSEGMENT 41 : SEGMENT IPPO(NPPO) 42 : SEGMENT MWRK1 43 : REAL*8 XEL(3,NBN1),XEL2(3,NBN1) 44 : ENDSEGMENT 45 : SEGMENT MWRK2 46 : REAL*8 TXR(3,3,NBN1),TH(NBN1) 47 : ENDSEGMENT 48 : * NOMFIS 49 : PARAMETER (NINF = 3, XEPS = 1.D-6) 50 : INTEGER INFOS(NINF) 51 : DIMENSION XIGAU(3),MOCOMP(3),BPSS(3,3),APSS(3,3) 52 : DIMENSION U1(3),U2(3),U3(3),W1(3),W2(3) 53 : CHARACTER*(NCONCH) CONM 54 : CHARACTER*8 CMATE 55 : CHARACTER*4 CMOT,NOMFIS(3) 56 : DATA NOMFIS(1),NOMFIS(2),NOMFIS(3) 57 : &/'FIS1','FIS2','FIS3'/ 58 : * 59 : MVECT0 = 0 60 : * 61 : MCHELM = MCHA1 62 : SEGACT MCHELM 63 : * 64 : * Verification du support : noeuds ou pdi ? 65 : * 66 : ISUP = INFCHE(1,6) 67 : NSC = INFCHE(/1) 68 : DO 50 ISC=2,NSC 69 : ISUP1 = INFCHE(ISC,6) 70 : IF (ISUP1.NE.ISUP) ISUP = 0 71 : 50 CONTINUE 72 : * si ISUP = 1 : MCHAML aux noeuds 73 : * si ISUP = 5 : MCHAML aux pdi 74 : IF (ISUP.NE.1.AND.ISUP.NE.5) THEN 74 : call erreur(609) 75 : SEGDES MCHELM 76 : RETURN 77 : ENDIF 78 : SEGDES MCHELM 79 : * 80 : NMO = 0 81 : IF (LMOT1.NE.0) THEN 82 : MLMOTS = LMOT1 83 : SEGACT MLMOTS 84 : NMO = MOTS(/2) 85 : ENDIF 86 : * 87 : MMODEL = MOD1 88 : SEGACT MMODEL 89 : NSOUS = KMODEL(/1) 90 : * 91 : * Boucle sur les zones du MCHAML 92 : * 93 : DO 100 ISOU = 1,NSOUS 94 : IVACOM = 0 95 : IVAEP = 0 96 : IMODEL = KMODEL(ISOU) 97 : SEGACT IMODEL 98 : IPMAIL = IMAMOD 99 : CONM = CONMOD 100 : MELE = NEFMOD 101 : MELEME = IMAMOD 102 : NFOR = FORMOD(/2) 103 : NMAT = MATMOD(/2) 104 : * 104 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) 105 : * 106 : if(infmod(/1).lt.7) then 106 : CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 107 : IF (IERR.NE.0) THEN 108 : SEGDES IMODEL,MMODEL 109 : RETURN 110 : ENDIF 111 : INFO = IPINF 112 : NBGS = INFELL(4) 113 : MFR = INFELL(13) 114 : MINTE = INFELL(11) 115 : MINTE1 = INFELL(12) 116 : segsup info 117 : else 118 : NBGS = INFELE(4) 119 : MFR = INFELE(13) 120 : MINTE=INFMOD(7) 121 : MINTE1 = INFMOD(8) 122 : endif 123 : IPMINT = MINTE 124 : 125 : * 126 : 127 : IF3 = 0 128 : IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN 129 : IF3 = 1 130 : ELSE IF (MFR.EQ.1) THEN 131 : IF (IDIM.EQ.3) IF3 = 2 132 : IF (IDIM.EQ.2) IF3 = 3 133 : 134 : 135 : ELSE 135 : call erreur(19) 136 : SEGDES IMODEL,MMODEL 137 : RETURN 138 : ENDIF 139 : * 140 : IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN 141 : MOTERR(1:16) = 'CARACTERISTIQUES' 141 : CALL ERREUR(565) 142 : SEGDES IMODEL,MMODEL 143 : RETURN 144 : ENDIF 145 : IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGACT MINTE1 146 : * 146 : CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET) 147 : IF (IRET.EQ.0) GOTO 900 148 : * 149 : SEGACT MINTE 150 : NBPGAU = POIGAU(/1) 151 : SEGACT MELEME 152 : NBN1 = NUM(/1) 153 : NBELE1 = NUM(/2) 154 : IF (ISUP.EQ.1) NIPO = NBN1 155 : IF (ISUP.EQ.5) NIPO = NBPGAU 156 : SEGINI MWRK1 157 : NPPO = NIPO * NBELE1 158 : IF (ISUP.EQ.5) SEGINI IPPO 159 : IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGINI MWRK2 160 : * 161 : * Listes de composantes attendues -> NORMALE a la fissure 162 : * 163 : CMOT = ' ' 163 : CALL IDVEC2(IMODEL,2,IDIM,IF3,CMOT,MOCOMP,NCOMP, 164 : & NLIST,IER1) 165 : 166 : IF (IER1.NE.0) THEN 166 : call erreur(19) 167 : IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGDES MINTE1 168 : SEGDES IMODEL,MMODEL 169 : SEGDES MINTE,MELEME 170 : SEGSUP MWRK1 171 : RETURN 172 : ENDIF 173 : * 174 : IF (NMO.NE.0.AND.NLIST.NE.NMO) GOTO 900 175 : * 176 : NVEC = NLIST * 2 177 : ID = 1 178 : SEGINI MVECTE 179 : * 180 : * Boucle sur les composantes 181 : * 182 : DO 150 IC = 1,NLIST 183 : NOMID = MOCOMP(IC) 184 : SEGACT NOMID 185 : 186 : NOCOVE(IC,1) = NOMFIS(IC) 187 : IF (LMOT1.EQ.0) THEN 188 : NOCOUL(IC) = IC+1 189 : ELSE 190 : ICOUL=IDCOUL+1 190 : CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC)) 191 : NOCOUL(IC) = ICOUL-1 192 : ENDIF 193 : IGEOV(IC) = 0 194 : * 195 : * Creation du MCHPOI puis du MSOUPO et du MPOVAL 196 : * 197 : NAT = 2 198 : NSOUPO = 1 199 : SEGINI MCHPOI 200 : ICHPO(IC) = MCHPOI 201 : MTYPOI = 'VECTEUR ' 202 : MOCHDE = 'CONTRAINTES PRINCIPALES' 203 : IFOPOI = IFOUR 204 : JATTRI(1) = 2 205 : JATTRI(2) = 0 206 : NC = IDIM 207 : SEGINI MSOUPO 208 : IPCHP(1) = MSOUPO 209 : NOCOMP(1) = 'FISX' 210 : NOCOMP(2) = 'FISY' 211 : IF (IDIM.EQ.3) NOCOMP(3) = 'FISZ' 212 : * 213 : * IF (IF3.EQ.2) THEN 214 : * SEGINI MCHPO1 215 : * ICHPO(IC+NLIST) = MCHPO1 216 : * MCHPO1.MTYPOI = 'VECTEUR ' 217 : * MCHPO1.MOCHDE = 'CONTRAINTES PRINCIPALES' 218 : * MCHPO1.IFOPOI = IFOUR 219 : * MCHPO1.JATTRI(1) = 2 220 : * MCHPO1.JATTRI(2) = 0 221 : ** SEGINI MSOUP1 222 : * MCHPO1.IPCHP(1) = MSOUP1 223 : * MSOUP1.NOCOMP(1) = 'FISX' 224 : * MSOUP1.NOCOMP(2) = 'FISY' 225 : * MSOUP1.NOCOMP(3) = 'FISZ' 226 : * ENDIF 227 : 228 : * 229 : N = NIPO * NBELE1 230 : SEGINI MPOVAL 231 : IPOVAL = MPOVAL 232 : * IF (IF3.EQ.2) THEN 233 : * SEGINI MPOVA1 234 : * MSOUP1.IPOVAL = MPOVA1 235 : * ENDIF 236 : * 237 : NBNN = 1 238 : NBELEM = N 239 : NBSOUS = 0 240 : NBREF = 0 241 : SEGINI IPT1 242 : IGEOC = IPT1 243 : * IF (IF3.EQ.2) MSOUP1.IGEOC = IPT1 244 : IPT1.ITYPEL = 1 245 : * 246 : NBTYPE = 1 247 : SEGINI NOTYPE 248 : MOTYPE = NOTYPE 249 : TYPE(1) = 'REAL*8' 249 : CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC), 250 : & MOTYPE,1,INFOS,3,IVACOM) 251 : IF (IERR.NE.0) GOTO 900 252 : * AM 23/9/98 ON REACTIVE LE MELEME DESACTIVE PAR KOMCHA 253 : SEGACT MELEME 254 : MPTVAL = IVACOM 255 : NS7 = IVAL(/1) 256 : J7 = 1 257 : DO 7 I7=1,NS7 258 : IF (IVAL(I7).EQ.0) J7 = 0 259 : 7 CONTINUE 260 : SEGSUP NOTYPE 261 : IF (J7.EQ.0) GOTO 151 262 : * 263 : * Cas des coques epaisses : epaisseur (excentrement) 264 : * 265 : IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN 266 : NBROBL = 1 267 : NBRFAC = 0 268 : SEGINI NOMID 269 : MOEP = NOMID 270 : LESOBL(1) = 'EPAI' 271 : NVEC = NBROBL + NBRFAC 272 : NBTYPE = 1 273 : SEGINI NOTYPE 274 : MOTYPE = NOTYPE 275 : TYPE(1) = 'REAL*8' 275 : CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP, 276 : & MOTYPE,1,INFOS,3,IVAEP) 277 : * AM 23/9/98 ON REACTIVE LE MELEME DESACTIVE PAR KOMCHA 278 : SEGACT MELEME 279 : SEGSUP NOTYPE 280 : ENDIF 281 : * 282 : IPO = 0 283 : * 284 : * Boucle sur les elements 285 : * 286 : DO 200 IEL = 1,NBELE1 287 : * cas general 287 : CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL) 288 : * coques epaisses 289 : IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN 290 : MPTVAL = IVAEP 291 : MELVAL=IVAL(1) 292 : DO 201 IP = 1,NBN1 293 : IPMN=MIN(IP ,VELCHE(/1)) 294 : IEMN=MIN(IEL,VELCHE(/2)) 295 : TH(IP)=VELCHE(IPMN,IEMN) 296 : 201 CONTINUE 296 : CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR) 297 : ENDIF 298 : IF (MELE.EQ.49) THEN 298 : CALL CQ4LOC (XEL,XEL2,BPSS,IRRT,0) 299 : ELSE IF (MELE.EQ.93.OR.MFR.EQ.3) THEN 299 : CALL VPAST(XEL,BPSS) 300 : ENDIF 301 : * 302 : * Boucle sur les points supports 303 : * 304 : DO 300 IPSU = 1,NIPO 305 : IPO = IPO + 1 306 : MPTVAL = IVACOM 307 : XFISS = 1.D0 308 : MELVAL = IVAL(1) 309 : IPMN = MIN(IPSU,VELCHE(/1)) 310 : IEMN = MIN(IEL ,VELCHE(/2)) 311 : U3(1) = VELCHE(IPMN,IEMN) 312 : MELVAL = IVAL(2) 313 : IPMN = MIN(IPSU,VELCHE(/1)) 314 : IEMN = MIN(IEL ,VELCHE(/2)) 315 : U3(2) = VELCHE(IPMN,IEMN) 316 : IF (IF3.EQ.2) THEN 317 : MELVAL = IVAL(3) 318 : IPMN = MIN(IPSU,VELCHE(/1)) 319 : IEMN = MIN(IEL ,VELCHE(/2)) 320 : U3(3) = VELCHE(IPMN,IEMN) 321 : ELSE 322 : U3(3) = 0.D0 323 : ENDIF 324 : * 324 : CALL NORME(U3,XU3) 325 : IF (XU3.LT.XEPS) THEN 326 : UV11 = 0.D0 327 : UV12 = 0.D0 328 : UV13 = 0.D0 329 : GOTO 123 330 : ENDIF 331 : * a verifier dans le cas des coques 332 : IF (IF3.EQ.1) THEN 333 : VF1X = -1.D0 * XFISS * U3(2) 334 : VF1Y = XFISS * U3(1) 335 : APSS(1,1)=BPSS(2,2)*BPSS(3,3)-BPSS(3,2)*BPSS(2,3) 336 : APSS(2,1)=BPSS(3,1)*BPSS(2,3)-BPSS(2,1)*BPSS(3,3) 337 : APSS(3,1)=BPSS(2,1)*BPSS(3,2)-BPSS(3,1)*BPSS(2,2) 338 : APSS(1,2)=BPSS(3,2)*BPSS(1,3)-BPSS(1,2)*BPSS(3,3) 339 : APSS(2,2)=BPSS(1,1)*BPSS(3,3)-BPSS(3,1)*BPSS(1,3) 340 : APSS(3,2)=BPSS(3,1)*BPSS(1,2)-BPSS(1,1)*BPSS(3,2) 341 : UV11=APSS(1,1)*VF1X+APSS(1,2)*VF1Y 342 : UV12=APSS(2,1)*VF1X+APSS(2,2)*VF1Y 343 : UV13=APSS(3,1)*VF1X+APSS(3,2)*VF1Y 344 : ELSE IF (IF3.EQ.3) THEN 345 : IF (ABS(U3(2)).LT.XEPS) THEN 346 : VF1X = 0.D0 347 : VF1Y = 1.D0 * XFISS 348 : ELSE IF (ABS(U3(1)).LT.XEPS) THEN 349 : VF1X = 1.D0 * XFISS 350 : VF1Y = 0.D0 351 : ELSE 352 : VF1X = -1.D0 * XFISS * U3(2) 353 : VF1Y = XFISS * U3(1) 354 : ENDIF 355 : UV11 = VF1X 356 : UV12 = VF1Y 357 : ELSE IF (IF3.EQ.2) THEN 358 : * U1(1) = 1.D0 359 : * U1(2) = 0.D0 360 : * U1(3) = 0.D0 361 : * U2(1) = 0.D0 362 : * U2(2) = 1.D0 363 : * U2(3) = 0.D0 363 : * CALL PROVEC(U3,U1,W1) 363 : * CALL NORME(W1,XW1) 363 : * IF (XW1.LT.XEPS) CALL PROVEC(U3,U2,W1) 363 : * CALL PROVEC(U3,W1,W2) 363 : * CALL NORMER(W1) 363 : * CALL NORMER(W2) 364 : UV11 = U3(1) 365 : UV12 = U3(2) 366 : UV13 = U3(3) 367 : ENDIF 368 : 123 CONTINUE 369 : * 370 : VPOCHA(IPO,1) = UV11 371 : VPOCHA(IPO,2) = UV12 372 : IF (IF3.EQ.1.OR.IF3.EQ.2) VPOCHA(IPO,3) = UV13 373 : * 374 : * IF (IF3.EQ.2) THEN 375 : * DO 124 II3 = 1,IDIM 376 : * MPOVA1.VPOCHA(IPO,II3) = W2(II3) 377 : * 124 CONTINUE 378 : * ENDIF 379 : * 380 : IF (ISUP.EQ.5) THEN 381 : IF (IC.EQ.1) THEN 382 : IF (ISUP.EQ.5.AND.MFR.EQ.5) THEN 383 : Z = DZEGAU(IPSU) 384 : DO 400 I2 = 1,IDIM 385 : XIGAU(I2) = 0.D0 386 : DO 400 IL = 1,NBN1 387 : XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)* 388 : & XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL)) 389 : 400 CONTINUE 390 : ELSE 391 : DO 410 I2 = 1,IDIM 392 : XIGAU(I2) = 0.D0 393 : DO 410 IL = 1,NBN1 394 : XIGAU(I2) = XIGAU(I2) + 395 : & (SHPTOT(1,IL,IPSU)*XEL(I2,IL)) 396 : 410 CONTINUE 397 : ENDIF 398 : * 399 : * Le pdi est reference dans MCOORD (PROVISOIRE) 400 : * 401 : NBPTS = XCOOR(/1)/(IDIM+1)+1 402 : SEGADJ MCOORD 403 : XCOOR((NBPTS-1)*(IDIM+1)+1) = XIGAU(1) 404 : XCOOR((NBPTS-1)*(IDIM+1)+2) = XIGAU(2) 405 : IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=XIGAU(3) 406 : XCOOR(NBPTS*(IDIM+1)) = 0.D0 407 : IPT1.NUM(1,IPO) = NBPTS 408 : IPPO(IPO) = NBPTS 409 : ELSE 410 : IPT1.NUM(1,IPO) = IPPO(IPO) 411 : ENDIF 412 : ELSE 413 : IPT1.NUM(1,IPO) = NUM(IPSU,IEL) 414 : ENDIF 415 : 300 CONTINUE 416 : 200 CONTINUE 417 : 151 SEGDES MPOVAL,MSOUPO,MCHPOI,IPT1,NOMID 418 : * IF (IF3.EQ.2) SEGDES MPOVA1,MSOUP1,MCHPO1 419 : 150 CONTINUE 420 : * 421 : IC1 = 0 422 : DO 500 IC2 = NLIST+1,NLIST*2 423 : IC1 = IC1 + 1 424 : NOCOVE(IC2,1) = NOMFIS(IC1) 425 : IF (LMOT1.EQ.0) THEN 426 : NOCOUL(IC2) = IC1 + 1 427 : ELSE 428 : ICOUL=IDCOUL+1 428 : CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1)) 429 : NOCOUL(IC2) = ICOUL-1 430 : ENDIF 431 : IGEOV(IC2) = 0 432 : * IF (IF3.NE.2) THEN 433 : MCHPOI = ICHPO(IC1) 433 : CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1) 434 : ICHPO(IC2) = ICHP2 435 : * ENDIF 436 : 500 CONTINUE 437 : * 438 : * Desactivation des segments de la zone ISOU 439 : * 440 : SEGDES IMODEL,MINTE,MELEME 441 : IF (MFR.EQ.5) SEGDES MINTE1 442 : DO 105 I0 = 1,NCOMP 443 : IF (IVAL(I0).NE.0) THEN 444 : MELVAL = IVAL(I0) 445 : SEGDES,MELVAL 446 : ENDIF 447 : 105 CONTINUE 448 : SEGSUP MPTVAL,MWRK1 449 : IF (ISUP.EQ.5.AND.MFR.EQ.5) SEGSUP MWRK2 450 : IF (ISUP.EQ.5) SEGSUP IPPO 451 : NCX = NLIST * 2 452 : DO 101 IMX = 1,NCX 453 : AMPF(IMX) = AMP 454 : 101 CONTINUE 455 : SEGDES MVECTE 456 : * 457 : 458 : IF (MVECT0.EQ.0) THEN 459 : MVECT0 = MVECTE 460 : ELSE 460 : CALL FUSVEC(MVECT0,MVECTE,MVECT1) 461 : MVECT0 = MVECT1 462 : ENDIF 463 : * 464 : 100 CONTINUE 465 : SEGDES MMODEL 466 : IF (LMOT1.NE.0) SEGDES MLMOTS 467 : RETURN 468 : 900 CONTINUE 469 : * 470 : RETURN 471 : END 472 : 473 : 474 : 475 : 476 : 477 : 478 : 479 : 480 : 481 : 482 : 483 : 484 : 485 : 486 : 487 : 488 : 489 : 490 : 491 : 492 : 493 : 494 :
© Cast3M 2003 - All rights reserved.
Disclaimer