1 : C CORIO1 SOURCE BP208322 11/09/14 21:15:04 7130 2 : SUBROUTINE CORIO1 (IPMODL,IPCHE1,IPROTA,NUMLI1,NUMLI2, IPRIG) 3 : 4 : *_______________________________________________________________________ 5 : * 6 : * appelé par CORIOL ( opérateur CORIOLIS ) 7 : * 8 : * Creation d'une matrice d'amortissement de couplage gyroscopique 9 : * dans le repère tournant (éléments BARR,POUT,TIMO,TUYAU,COQUES 3D) 10 : * 11 : * entrees : 12 : * ======== 13 : * ipmodl pointeur sur un mmodel 14 : * ipche1 pointeur sur un mchaml de caracteristique 15 : * iprota point = vecteur vitesse de rotation 16 : * 17 : * sorties : 18 : * ========= 19 : * iprig pointeur sur la matrice construite 20 : * = 0 en cas d'erreur (IERR non nul aussi) 21 : * 22 : * Didier COMBESCURE mars 2003 23 : *_______________________________________________________________________ 24 : 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8(A-H,O-Z) 27 : 28 : -INC CCOPTIO 29 : -INC CCHAMP 30 : -INC CCGEOME 31 : -INC CCREEL 32 : 33 : -INC SMRIGID 34 : -INC SMCHAML 35 : -INC SMELEME 36 : -INC SMCOORD 37 : -INC SMINTE 38 : -INC SMMODEL 39 : 40 : INTEGER oooval 41 : 42 : SEGMENT NOTYPE 43 : CHARACTER*16 TYPE(NBTYPE) 44 : ENDSEGMENT 45 : C 46 : SEGMENT MPTVAL 47 : INTEGER IPOS(NS),NSOF(NS) 48 : INTEGER IVAL(NCOSOU) 49 : CHARACTER*16 TYVAL(NCOSOU) 50 : ENDSEGMENT 51 : C 52 : CHARACTER*8 CMATE 53 : CHARACTER*(NCONCH) CONM 54 : PARAMETER (NINF=3) 55 : INTEGER INFOS(NINF) 56 : DIMENSION VROT(3) 57 : LOGICAL lsupfo,lsupde 58 : C 59 : IPRIG = 0 60 : C 61 : c_______________________________________________________________________ 62 : c 63 : c initialisation du chapeau de l objet rigidite 64 : c_______________________________________________________________________ 65 : NRIGEL = 0 66 : SEGINI,MRIGID 67 : IFORIG = IFOMOD 68 : c* IFORIG = IFOUR 69 : ICHOLE = 0 70 : IMGEO1 = 0 71 : IMGEO2 = 0 72 : ISUPEQ = 0 73 : IF (NUMLI2.EQ.0) THEN 74 : MTYMAT = 'AMOR' 75 : ELSE 76 : MTYMAT = 'MASSE' 77 : ENDIF 78 : 79 : C____________________________________________________________________ 80 : C 81 : C LECTURE DU VECTEUR ROTATION ET MULTIPLICATION PAR 2 (pour Coriolis) 82 : C____________________________________________________________________ 83 : C 84 : IF (IPROTA.EQ.0) THEN 85 : VROT(1) =0. 86 : VROT(2) = 0. 87 : VROT(3) = 2.D0 88 : ELSE IF (IFOUR.NE.1) THEN 89 : VROT(1) = 2.D0 * XCOOR((4*IPROTA) - 3) 90 : VROT(2) = 2.D0 * XCOOR((4*IPROTA) - 2) 91 : VROT(3) = 2.D0 * XCOOR((4*IPROTA) - 1) 92 : ELSE 93 : VROT(1) = 0.D0 94 : VROT(2) = 2.D0*XCOOR((3*IPROTA) - 1) 95 : VROT(3) = 0.D0 96 : ENDIF 97 : 98 : C----------------------------------------------------------------------- 99 : C ACTIVATION DU MODELE 100 : C----------------------------------------------------------------------- 101 : MMODEL = IPMODL 102 : SEGACT,MMODEL 103 : NSOUS = KMODEL(/1) 104 : C 105 : C----------------------------------------------------------------------- 106 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES 107 : C----------------------------------------------------------------------- 108 : DO 500 ISOUS = 1, NSOUS 109 : C 110 : IMODEL = KMODEL(ISOUS) 111 : SEGACT,IMODEL 112 : 113 : C- Quelques initialisations 114 : IPMINT = 0 115 : 116 : MOMATR = 0 117 : MOCARA = 0 118 : MOTYPM = 0 119 : MOTYPC = 0 120 : ISUPM = 0 121 : ISUPC = 0 122 : 123 : MODEPL = 0 124 : MOFORC = 0 125 : lsupde = .false. 126 : lsupfo = .false. 127 : 128 : IDESCR = 0 129 : 130 : C- Recuperation d'informations sur le maillage elementaire 131 : IPT1 = IMAMOD 132 : SEGACT,IPT1 133 : NBNOE1 = IPT1.NUM(/1) 134 : NBELE1 = IPT1.NUM(/2) 135 : 136 : C- Quelques informations sur le modele 137 : IIPDPG = IPDPGE 138 : CONM = CONMOD 139 : CMATE = CMATEE 140 : MATE = IMATEE 141 : c* INAT = INATUU 142 : c- Tableau infos 143 : iret = 1 143 : CALL IDENT(IPT1,CONM,IPCHE1,0, INFOS,iret) 144 : IF (iret.EQ.0) GOTO 599 145 : 146 : C- Recuperation d'informations sur l'element fini 147 : MELE = NEFMOD 148 : 149 : NPINT = 1 150 : IF (INFMOD(/1).NE.0) NPINT = INFMOD(1) 151 : C support des champs 152 : IPLAZ = 4 153 : IF (NPINT.EQ.12345) IPLAZ = 1 154 : 155 : MFR =INFELE(13) 156 : LRE = INFELE(9) 157 : NDDL = INFELE(15) 158 : IF (IFOUR.EQ.1) THEN 159 : LRE = 2*LRE 160 : NDDL = 2*NDDL 161 : ENDIF 162 : LW = INFELE(7) 163 : LHOOK = INFELE(10) 164 : IELE = INFELE(14) 165 : IPMINT = INFMOD(2+IPLAZ) 166 : C* IPMINT = INFELE(11) 167 : IPMIN1 = INFMOD(8) 168 : C* ICARA = INFELE(5) 169 : IPPORE = 0 170 : IF (MFR.EQ.33) IPPORE = NBNOE1 171 : C 172 : C INITIALISATION DE MINTE 173 : MINTE = IPMINT 174 : SEGACT,MINTE 175 : NBPGAU = POIGAU(/1) 176 : * 177 : C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX 178 : C----------------------------------------------------------------------- 179 : if (lnomid(1).ne.0) then 180 : MODEPL = lnomid(1) 181 : else 182 : lsupde=.true. 182 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,NDUM) 183 : endif 184 : nomid = MODEPL 185 : SEGACT,nomid 186 : ndepl = lesobl(/2) 187 : c* ndum=lesfac(/2) 188 : 189 : if (lnomid(2).ne.0) then 190 : MOFORC = lnomid(2) 191 : else 191 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NDUM) 192 : lsupfo=.true. 193 : endif 194 : nomid = MOFORC 195 : SEGACT,nomid 196 : nforc=lesobl(/2) 197 : c* ndum=lesfac(/2) 198 : C 199 : IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN 199 : CALL ERREUR(5) 200 : GOTO 598 201 : ENDIF 202 : C 203 : C REMPLISSAGE DU SEGMENT DESCRIPTEUR 204 : C------------------------------------- 205 : NLIGRP = LRE 206 : NLIGRD = LRE 207 : SEGINI,DESCR 208 : IDESCR = DESCR 209 : C 210 : NCOMP = NDEPL 211 : IF (MFR.EQ.33) NCOMP = NDEPL-1 212 : NBNNS = NBNOE1 213 : IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS = NBNOE1/2 214 : 215 : IDDL=1 216 : DO 1004 inoe =1, NBNNS 217 : DO 1005 ICOMP=1,NCOMP 218 : IF (IFOUR.NE.1) THEN 219 : NOMID=MODEPL 220 : LISINC(IDDL)=LESOBL(ICOMP) 221 : NOMID=MOFORC 222 : LISDUA(IDDL)=LESOBL(ICOMP) 223 : NOELEP(IDDL) = inoe 224 : NOELED(IDDL) = inoe 225 : ELSE 226 : NOMID=MODEPL 227 : I = 2*IDDL 228 : LISINC(I-1)=LESOBL(ICOMP) 229 : IF (LESOBL(ICOMP).EQ.'UR ') THEN 230 : LISINC(I)='IUR ' 231 : ELSEIF (LESOBL(ICOMP).EQ.'UZ ') THEN 232 : LISINC(I)='IUZ ' 233 : ELSEIF (LESOBL(ICOMP).EQ.'UT ') THEN 234 : LISINC(I)='IUT ' 235 : ELSEIF (LESOBL(ICOMP).EQ.'RT ') THEN 236 : LISINC(I)='IRT ' 237 : ENDIF 238 : NOMID=MOFORC 239 : LISDUA(I-1)=LESOBL(ICOMP) 240 : IF (LESOBL(ICOMP).EQ.'FR ') THEN 241 : LISDUA(I)='IFR ' 242 : ELSEIF (LESOBL(ICOMP).EQ.'FZ ') THEN 243 : LISDUA(I)='IFZ ' 244 : ELSEIF (LESOBL(ICOMP).EQ.'FT ') THEN 245 : LISDUA(I)='IFT ' 246 : ELSEIF (LESOBL(ICOMP).EQ.'MT ') THEN 247 : LISDUA(I)='IMT ' 248 : ENDIF 249 : NOELEP(I-1) = inoe 250 : NOELED(I-1) = inoe 251 : NOELEP(I) = inoe 252 : NOELED(I) = inoe 253 : ENDIF 254 : IDDL=IDDL+1 255 : 1005 CONTINUE 256 : 1004 CONTINUE 257 : 258 : SEGDES,DESCR 259 : IDESCR = DESCR 260 : C 261 : C- Recuperation des composantes MATERIAU 262 : C----------------------------------------------------------------------- 263 : NBROBL = 0 264 : NBRFAC = 0 265 : nomid = 0 266 : notype = 0 267 : LHOTRA = 0 268 : * 269 : * rho dans les cas poutre,tuyau, massif, coque 270 : * 271 : IF (MFR.EQ.1.OR.MFR.EQ.27.OR.MFR.EQ.7.OR.MFR.EQ.13.OR. 272 : & MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN 273 : * 274 : IF (CMATE.NE.'SECTION') THEN 275 : NBROBL = 1 276 : SEGINI,nomid 277 : LESOBL(1)='RHO ' 278 : NBTYPE = 1 279 : SEGINI NOTYPE 280 : TYPE(1)='REAL*8' 281 : ELSE 282 : LHOTRA=LHOOK 283 : NBROBL=2 284 : SEGINI,nomid 285 : LESOBL(1)='MODS' 286 : LESOBL(2)='MATS' 287 : NBTYPE=2 288 : SEGINI NOTYPE 289 : TYPE(1) = 'POINTEURMMODEL' 290 : TYPE(2) = 'POINTEURMCHAML' 291 : ENDIF 292 : ENDIF 293 : C 294 : MOMATR = nomid 295 : MOTYPM = notype 296 : NMATR = NBROBL 297 : NMATF = NBRFAC 298 : NMATT = NMATR+NMATF 299 : * 300 : * verification du support des composantes recherchees 301 : * 302 : IF (MOMATR.NE.0) THEN 302 : CALL QUESUQ(IMODEL,IPCHE1,4,0,MOMATR,IPLAZ,ISUPM,iret) 303 : IF (ISUPM.GT.1) GOTO 597 304 : ENDIF 305 : * 306 : C- Recuperation des composantes CARACTERISTIQUES 307 : C----------------------------------------------------------------------- 308 : NBROBL = 0 309 : NBRFAC = 0 310 : nomid = 0 311 : notype = 0 312 : IVECT = 0 313 : * 314 : * caracteristiques pour les poutres 315 : IF (MFR.EQ.7 ) THEN 316 : IF (CMATE.EQ.'SECTION') THEN 317 : NBRFAC=2 318 : SEGINI NOMID 319 : LESFAC(1)='OMEG' 320 : LESFAC(2)='VECT' 321 : IVECT=1 322 : * 323 : NBTYPE=2 324 : SEGINI NOTYPE 325 : TYPE(1)='REAL*8' 326 : TYPE(2)='POINTEURPOINT ' 327 : * 328 : ELSE 329 : NBROBL=4 330 : NBRFAC=4 331 : SEGINI NOMID 332 : LESOBL(1)='TORS' 333 : LESOBL(2)='INRY' 334 : LESOBL(3)='INRZ' 335 : LESOBL(4)='SECT' 336 : LESFAC(1)='SECY' 337 : LESFAC(2)='SECZ' 338 : LESFAC(3)='OMEG' 339 : LESFAC(4)='VECT' 340 : IVECT=1 341 : * 342 : NBTYPE=8 343 : SEGINI NOTYPE 344 : TYPE(1)='REAL*8' 345 : TYPE(2)='REAL*8' 346 : TYPE(3)='REAL*8' 347 : TYPE(4)='REAL*8' 348 : TYPE(5)='REAL*8' 349 : TYPE(6)='REAL*8' 350 : TYPE(7)='REAL*8' 351 : TYPE(8)='POINTEURPOINT ' 352 : ENDIF 353 : * 354 : * caracteristiques pour les tuyaux 355 : ELSE IF (MFR.EQ.13) THEN 356 : NBROBL=2 357 : NBRFAC=3 358 : SEGINI NOMID 359 : LESOBL(1)='EPAI' 360 : LESOBL(2)='RAYO' 361 : LESFAC(1)='RACO' 362 : LESFAC(2)='OMEG' 363 : LESFAC(3)='VECT' 364 : IVECT=1 365 : * 366 : NBTYPE=5 367 : SEGINI NOTYPE 368 : TYPE(1)='REAL*8' 369 : TYPE(2)='REAL*8' 370 : TYPE(3)='REAL*8' 371 : TYPE(4)='REAL*8' 372 : TYPE(5)='POINTEURPOINT ' 373 : * 374 : * caracteristiques pour les barres 375 : ELSE IF (MFR.EQ.27) THEN 376 : NBROBL=1 377 : SEGINI NOMID 378 : LESOBL(1)='SECT' 379 : * 380 : NBTYPE=1 381 : SEGINI NOTYPE 382 : TYPE(1)='REAL*8' 383 : * 384 : * epaisseur et excentrement dans le cas des coques 385 : ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN 386 : NBROBL=1 387 : NBRFAC=1 388 : SEGINI NOMID 389 : LESOBL(1)='EPAI' 390 : LESFAC(1)='EXCE' 391 : * 392 : NBTYPE=1 393 : SEGINI NOTYPE 394 : TYPE(1)='REAL*8' 395 : * 396 : ENDIF 397 : * 398 : MOCARA = nomid 399 : MOTYPC = notype 400 : NCARA = NBROBL 401 : NCARF = NBRFAC 402 : NCARR = NCARA+NCARF 403 : 404 : * verification du support des composantes recherchees 405 : * 406 : IF (MOCARA.NE.0)THEN 406 : CALL QUESUQ(IMODEL,IPCHE1,4,0,MOCARA,IPLAZ,ISUPC,iret) 407 : IF (ISUPC.GT.1) GOTO 597 408 : ENDIF 409 : 410 : C- Partionnement si necessaire de la matrice de coriolis 411 : C- determinant ainsi le nombre d'objets elementaires de MRIGID 412 : C----------------------------------------------------------------------- 413 : LTRK = oooval(1,4) 414 : IF (LTRK.EQ.0) LTRK = oooval(1,1) 415 : * Ajout a la taille en mots de la matrice des infos du segment 416 : LSEG = LRE*LRE*NBELE1 + 16 417 : NBLPRT = (LSEG-1)/LTRK + 1 418 : NBLMAX = (NBELE1-1)/NBLPRT + 1 419 : NBLPRT = (NBELE1-1)/NBLMAX + 1 420 : * write(ioimp,*) ' corio1 : nblprt nblmax = ',nblprt,nblmax,nbele1 421 : 422 : C Ajout de la matrice de CORIOLIS a la matrice globale 423 : C----------------------------------------------------------------------- 424 : NRIGE0 = IRIGEL(/2) 425 : NRIGEL = NRIGE0 + NBLPRT 426 : SEGADJ,MRIGID 427 : 428 : descr = IDESCR 429 : meleme = IPT1 430 : nbnn = NBNOE1 431 : nbelem = NBELE1 432 : nbsous = 0 433 : nbref = 0 434 : * 435 : * Boucle sur les PARTITIONS elementaires de la matrice 436 : ************************************************************************ 437 : DO 5000 irige = 1, NBLPRT 438 : 439 : IF (NBLPRT.GT.1) THEN 440 : C- Partitionnement du maillage support de la matrice elementaire 441 : C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !) 442 : SEGACT,IPT1 443 : ielem = (irige-1)*NBLMAX 444 : nbelem = MIN(NBLMAX,NBELE1-ielem) 445 : * write(ioimp,*) ' creation segment ',nbnn,nbelem 446 : SEGINI,meleme 447 : itypel = IPT1.itypel 448 : DO ielt = 1, nbelem 449 : jelt = ielt + ielem 450 : DO inoe = 1, nbnn 451 : num(inoe,ielt) = IPT1.NUM(inoe,jelt) 452 : ENDDO 453 : icolor(ielt) = IPT1.ICOLOR(jelt) 454 : ENDDO 455 : C- Recopie du descripteur 456 : des1 = IDESCR 457 : SEGINI,descr=des1 458 : SEGDES,descr 459 : ENDIF 460 : 461 : ipmail = meleme 462 : ipdesc = descr 463 : 464 : C- Initialisation de la matrice de rigidite elementaire (xmatri) 465 : NELRIG = nbelem 466 : SEGINI,xmatri 467 : ipmatr = xmatri 468 : 469 : C- Recuperation des valeurs des proprietes materiau et geometriques 470 : IVAMAT = 0 471 : IVACAR = 0 472 : 473 : IF (MOMATR.NE.0) THEN 473 : CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,INFOS,3, 474 : & IVAMAT) 475 : IF (IERR.NE.0) GOTO 5100 476 : IF (ISUPM.EQ.1) THEN 476 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE) 477 : IF (IERR.NE.0)THEN 478 : ISUPM = 0 479 : GOTO 5100 480 : ENDIF 481 : ENDIF 482 : ENDIF 483 : C 484 : IF (MOCARA.NE.0) THEN 484 : CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,INFOS,3, 485 : & IVACAR) 486 : IF (IERR.NE.0) GOTO 5100 487 : IF (ISUPC.EQ.1)THEN 487 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) 488 : IF (IERR.NE.0)THEN 489 : ISUPC = 0 490 : GOTO 5100 491 : ENDIF 492 : ENDIF 493 : ENDIF 494 : 495 : C----------------------------------------------------------------------- 496 : C NUMERO DES ETIQUETTES : 497 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 498 : C LES ELEMENTS SONT GROUPES COMME SUIT : 499 : C - MASSIF,LIQUIDE 'SURFACE LIBRE' ----------------------> CORIO3 500 : C - COQ3/POUTRE,DKT,COQ4,COQ8,DST ------------------> CORIO2 501 : C ET POUTRE DE TIMOSCHENKO 502 : C______________________________________________________________________ 503 : * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 504 : GOTO ( 99, 99, 99, 11, 99, 11, 99, 11, 99, 11, 99 505 : * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT 506 : & , 99, 99, 11, 11, 11, 11, 99, 99, 99, 99, 99 507 : * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 508 : & , 11, 11, 11, 11, 21, 21, 21, 99, 99, 99, 99 509 : * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 510 : & , 99, 99, 99, 99, 99, 99, 99, 21, 21, 99, 21 511 : * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO 512 : & , 99, 21, 99, 99, 21, 99, 99, 99, 99, 99, 99 513 : * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 514 : & , 21, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 515 : * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 516 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 517 : * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 518 : & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99 519 : * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 520 : & , 99, 99, 99, 99, 21, 99, 99, 99, 99, 99, 99 521 : * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 522 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 523 : * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 524 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 525 : * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 526 : & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99 527 : * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 528 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 529 : * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 530 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 531 : * TE56 PY91 TRH6 532 : & , 99, 99, 99),MELE 533 : C 534 : 99 CONTINUE 535 : MOTERR(1: 4) = NOMTP(MELE) 536 : MOTERR(5:12) = 'CORI1' 536 : CALL ERREUR(86) 537 : GOTO 5100 538 : 539 : C_______________________________________________________________________ 540 : C 541 : C MASSIF 542 : C_______________________________________________________________________ 543 : C 544 : 11 CONTINUE 544 : CALL CORIO3(ipmail,NDDL,LRE,NBPGAU,IPMINT,MELE,MFR,IVAMAT, 545 : & IVACAR,NMATT,ipmatr,VROT,NUMLI1,IIPDPG) 546 : C 547 : GOTO 5100 548 : C_______________________________________________________________________ 549 : C 550 : C POUTRE, POUTRE DE TIMOSCHENKO, COQUE, BARRE 551 : C_______________________________________________________________________ 552 : C 553 : 21 CONTINUE 553 : CALL CORIO2(ipmail,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,NCARR, 554 : & IVECT,isous,NBPGAU,IPMINT,IPMIN1,NDDL,MATE, 555 : & CMATE,LHOTRA,ipmatr,VROT,NUMLI1,IIPDPG) 556 : GOTO 5100 557 : C_______________________________________________________________________ 558 : C 559 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA 560 : C_______________________________________________________________________ 561 : 5100 CONTINUE 562 : C 563 : IF (ISUPM.EQ.1 .OR. NBLPRT.GT.1) THEN 563 : CALL DTMVAL(IVAMAT,3) 564 : ELSE 564 : CALL DTMVAL(IVAMAT,1) 565 : ENDIF 566 : C 567 : IF (ISUPC.EQ.1 .OR. NBLPRT.GT.1) THEN 567 : CALL DTMVAL(IVACAR,3) 568 : ELSE 568 : CALL DTMVAL(IVACAR,1) 569 : ENDIF 570 : xmatri = ipmatr 571 : SEGDES,xmatri 572 : IF (NBLPRT.GT.1) THEN 573 : meleme = ipmail 574 : SEGDES,meleme 575 : ENDIF 576 : 577 : C- Sortie prematuree en cas d'erreur 578 : IF (IERR.NE.0) GOTO 597 579 : 580 : C- Stockage de la matrice 581 : jrige = NRIGE0 + irige 582 : COERIG(jrige) = 1. 583 : IRIGEL(1,jrige) = ipmail 584 : IRIGEL(2,jrige) = 0 585 : IRIGEL(3,jrige) = ipdesc 586 : IRIGEL(4,jrige) = ipmatr 587 : IRIGEL(5,jrige) = NIFOUR 588 : IRIGEL(6,jrige) = 0 589 : C- Matrice antisymetrique si non 'HARM' 590 : IF (NUMLI1.EQ.0) THEN 591 : IRIGEL(7,jrige) = 1 592 : ELSE 593 : IRIGEL(7,jrige) = 0 594 : ENDIF 595 : IRIGEL(8,jrige) = 0 596 : 597 : 5000 CONTINUE 598 : C- Fin de la boucle sur les partitions 599 : 600 : 597 CONTINUE 601 : IF (MOMATR.NE.0) THEN 602 : nomid = MOMATR 603 : SEGSUP,NOMID 604 : c notype = NOTYPM 605 : notype = MOTYPM 606 : SEGSUP,notype 607 : ENDIF 608 : IF (MOCARA.NE.0) THEN 609 : nomid = MOCARA 610 : SEGSUP,NOMID 611 : c notype = NOTYPC 612 : notype = MOTYPC 613 : SEGSUP,notype 614 : ENDIF 615 : 598 CONTINUE 616 : IF (MODEPL.NE.0) THEN 617 : nomid = MODEPL 618 : SEGDES,nomid 619 : IF (lsupde) SEGSUP,nomid 620 : ENDIF 621 : IF (MOFORC.NE.0) THEN 622 : nomid = MOFORC 623 : SEGDES,nomid 624 : IF (lsupfo) SEGSUP,nomid 625 : ENDIF 626 : c* MINTE = IPMINT 627 : SEGDES,MINTE 628 : 599 CONTINUE 629 : c* IPT1 = IMAMOD 630 : SEGDES,IPT1 631 : SEGDES,IMODEL 632 : 633 : C- En cas d'erreur 634 : IF (IERR.NE.0) GOTO 999 635 : 636 : 500 CONTINUE 637 : C* Fin de la boucle sur les modeles elementaires 638 : 639 : 999 CONTINUE 640 : IF (IERR.NE.0) THEN 641 : SEGSUP,MRIGID 642 : IPRIG = 0 643 : ELSE 644 : SEGDES,MRIGID 645 : IPRIG = MRIGID 646 : ENDIF 647 : 648 : SEGDES,MMODEL 649 : 650 : RETURN 651 : END 652 : 653 : 654 :
© Cast3M 2003 - All rights reserved.
Disclaimer