1 : C CYNE20 SOURCE FANDEUR 13/01/29 21:15:20 7683 2 : SUBROUTINE CYNE20(ILIB,IWRK52,itruli) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *--------------------------------------------------------------------* 6 : * voir dyne20.eso * 7 : * Op�rateur DYNE : algorithme de Fu - de Vogelaere * 8 : * ________________________________________________ * 9 : * * 10 : * Remplissage des tableaux de description des liaisons sur * 11 : * la base @ partir des informations contenues dans la * 12 : * table ILIB. * 13 : * * 14 : * Param�tres: * 15 : * * 16 : * e ILIB Table rassemblant la description des liaisons * 17 : * es KTLIAB Segment descriptif des liaisons sur la base B. * 18 : * * 19 : * * 20 : * Param�tres de dimensionnement pour une liaison sur base: * 21 : * * 22 : * NIPALB : nombre de param�tres pour d�finir le type des * 23 : * liaisons (NIPALB est fix� � 3). * 24 : * NXPALB : nombre maxi de param�tres internes d�finissant les * 25 : * liaisons. * 26 : * NPLBB : nombre maxi de points intervenant dans une liaison. * 27 : * * 28 : * NPLB : nombre total de points. * 29 : * NLIAB : nombre total de liaisons. * 30 : * * 31 : * * 32 : * Tableaux fortran pour les liaisons sur base B : * 33 : * * 34 : * XPALB(NLIAB,NXPALB) : param�tres de la liaison. * 35 : * IPALB(NLIAB,NIPALB) : renseigne sur le type de liaison. * 36 : * et les eventuelles conditions * 37 : * XABSCI Tableau contenant les abscisses de la loi plastique * 38 : * pour les liaisons point-point- ... -plastique * 39 : * XORDON Tableau contenant les ordonnees de la loi plastique * 40 : * pour les liaisons point-point- ... -plastique * 41 : * * 42 : * JPLIB(NPLB) : num�ro global des points. * 43 : * IPLIB(NLIAB,NPLBB) : num�ros locaux des points concern�s par * 44 : * la liaison. * 45 : * * 46 : * Icorres Pour garder le numero du pointeur des tables de * 47 : * liaison * 48 : * * 49 : * * 50 : * Auteur, date de cr�ation: * 51 : * * 52 : * Lionel VIVAN, le 21 Septembre 1989. * 53 : * E de LANGRE 08/94 laisns conditionnelles * 54 : * I. Pinto 05/97, liaisons ligne_cercle,appels a dyn207 * 55 : * * 56 : *--------------------------------------------------------------------* 57 : * ** voir DYNE20.ESO remplissage segment MTPHI 58 : *--------------------------------------------------------------------* 59 : -INC CCOPTIO 60 : -INC SMCOORD 61 : -INC SMEVOLL 62 : -INC SMLREEL 63 : -INC SMMODEL 64 : -INC SMCHAML 65 : -INC SMELEME 66 : -INC SMCHPOI 67 : -INC DECHE 68 : -INC SMTABLE 69 : ** segment sous-structures dynamiques 70 : segment struli 71 : integer itlia,itbmod,momoda, mostat,itmail,molia 72 : integer ldefo(np1),lcgra(np1),lsstru(np1) 73 : integer nsstru,nndefo,nliab,nsb,na2,idimb 74 : integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas 75 : INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib 76 : * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0) 77 : INTEGER ICHAIN 78 : endsegment 79 : * 80 : SEGMENT,NCPR(XCOOR(/1)/(IDIM+1)) 81 : * segment dimensionnement pour LIAISONS 82 : * 83 : SEGMENT MTLIAB 84 : INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) 85 : REAL*8 XPALB(NLIAB,NXPALB) 86 : REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) 87 : ENDSEGMENT 88 : * 89 : SEGMENT MLIGNE 90 : INTEGER KPLIB(NPLB) 91 : ENDSEGMENT 92 : * 93 : SEGMENT,MTPHI 94 : INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) 95 : INTEGER IAROTA(NSB) 96 : REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) 97 : ENDSEGMENT 98 : * Segment pour Champoints 99 : SEGMENT,MSAM 100 : integer jplibb(NPLB) 101 : ENDSEGMENT 102 : 103 : SEGMENT,MTRA 104 : INTEGER IPLA(NTRA) 105 : ENDSEGMENT 106 : 107 : SEGMENT MOLIAI 108 : integer modtla,modtlb 109 : ENDSEGMENT 110 : * 111 : * 112 : LOGICAL Lo1,L0,log1,lvar,lmodyn,lva1 113 : LOGICAL LPERM,LINTER,LECRO,LELAS,REPRIS 114 : CHARACTER*40 CMOT,MONMOT,CMOT1 ,MONECR,CMOT2 115 : CHARACTER*8 MONAMO,MONSEUIL,CHARRE,CHARRE2,TYPRET,MARAID,MONPER 116 : CHARACTER*8 TYPREG,MONREC,MONJEU,MONSYM,MONELA,MONINTER 117 : CHARACTER*8 MONESC,MONRAY,MONCAL,MONINV 118 : CHARACTER*4 NOMTRI(6),NOMAXI(6),NOMPLA(3) 119 : REAL*8 XAXROT(3),XROTA(2,3) 120 : DATA NOMAXI/'UR ','UT ','UZ ','RR ','RT ','RZ '/ 121 : DATA NOMPLA/'UX ','UY ','RZ '/ 122 : DATA NOMTRI/'UX ','UY ','UZ ','RX ','RY ','RZ '/ 123 : 124 : struli = itruli 125 : 126 : wrk52 = iwrk52 127 : 128 : imodel = ilib 129 : segact imodel 130 : * fabrique la table de sortie 131 : * 131 : call crtabl(its1) 132 : itsort = its1 133 : 134 : L1 = 1 135 : N1 = 1 136 : n3 = 6 137 : segini mchelm 138 : itcara = mchelm 139 : 140 : * kich : reconstruit un mchaml ad hoc : ne pas oublier qu il s agit 141 : * de reutilisation . 142 : n2 = valmat(/1) 143 : segini mchaml 144 : ichaml(1) = mchaml 145 : imache(1) = imamod 146 : conche(1) = conmod 147 : do jn2 = 1,n2 148 : nomche(jn2) = commat(jn2) 149 : typche(jn2) = tyval(jn2) 150 : ielval(jn2) = ivalma(jn2) 151 : if(nomche(jn2).eq.'SORT') then 152 : if (ielval(jn2).eq.0) then 152 : call crtabl(ipsort) 153 : else 154 : melval = ielval(jn2) 155 : * segact melval 156 : ipsort = ielche(1,1) 157 : if (typche(jn2).ne.'POINTEURTABLE') then 158 : MOTERR(1:16) = typche(jn2) 159 : MOTERR(17:20) = nomche(jn2) 160 : MOTERR(21:36) = ' utile ' 160 : CALL ERREUR(552) 161 : return 162 : endif 163 : endif 164 : c* mtab1 = ipsort 165 : c* segact mtab1 165 : call ecrobj('TABLE',ipsort) 165 : call indeta 165 : call lirobj('TABLE ',ITAC,1,IRETOU) 165 : CALL DIMEN7 (ITAC,IDIMEN) 166 : INDICE = 0 167 : 5100 CONTINUE 168 : INDICE = INDICE + 1 169 : TYPRET = ' ' 169 : CALL ACCTAB(ITAC,'ENTIER',INDICE,X0,' ',L0,IP0, 170 : & TYPRET,I1,X1,CHARRE,LVA1,ITTL) 171 : IF (TYPRET.EQ.'MMODEL ' .AND. ITTL.NE.0) THEN 172 : mmode1 = ittl 173 : ipttl = ittl 174 : segact mmode1 175 : * on attend une liaison elementaire 176 : imode1 = mmode1.kmodel(1) 177 : segact imode1 178 : if (imode1.conmod.eq.conmod.or.imode1.imamod.eq.imamod) then 179 : TYPRET = ' ' 179 : CALL ACCTAB(IPSORT,'MMODEL ',I0,X0,' ',L0,ITTL, 180 : & TYPRET,I1,X1,CHARRE,LVAR,ITVAR) 181 : 181 : CALL ECCTAB(ITS1,'MMODEL',0,0.D0,' ',.TRUE.,ittl, 182 : & TYPRET,I1,X1,CHARRE,LVAR,ITVAR) 183 : 184 : goto 5010 185 : endif 186 : ENDIF 187 : IF(INDICE.LE.IDIMEN) GOTO 5100 188 : endif 189 : 190 : 191 : 5010 continue 192 : 193 : enddo 194 : 195 : NTVAR = 6 + 4 * IDIM 196 : * 197 : * MTRA indiquera la presence de liaisons POLYNOMIALEs 198 : * (on suppose un maximum de 100 liaisons en base A) 199 : *+* passe a 10000 le 28/1/93 200 : NTRA = 10000 201 : SEGINI,MTRA 202 : 203 : lmodyn = .true. 204 : np = 1 205 : nins = 1 206 : repris = .false. 207 : idimb1 = idimb 208 : nplb1 = nplb 209 : moliai = molia 210 : imolia = moliai 211 : segact moliai 212 : klia = 0 213 : klib = 0 214 : if (modtla.ne.0) then 215 : mmode1 = modtla 216 : segact mmode1 217 : klia = mmode1.kmodel(/1) 218 : endif 219 : if (modtlb.ne.0) then 220 : mmode1 = modtlb 221 : segact mmode1 222 : klib = mmode1.kmodel(/1) 223 : endif 224 : na1 = 0 225 : nmost0 = 0 226 : if (momoda.gt.0) then 227 : mmode2 = momoda 228 : segact mmode2 229 : nmost0 = mmode2.kmodel(/1) 230 : na1 = nmost0 231 : endif 232 : if (mostat.gt.0) then 233 : mmode2 = mostat 234 : segact mmode2 235 : na1 = na1 + mmode2.kmodel(/1) 236 : endif 237 : * 238 : nliab = klib 239 : SEGINI,MTLIAB 240 : KTLIAB = MTLIAB 241 : IF (NLIAB.NE.0) THEN 242 : NCPR = kcpr 243 : LCPR = XCOOR(/1) / (IDIM + 1) 244 : IN = 0 245 : DO 18 I = 1,LCPR 246 : IF (NCPR(I).NE.0) THEN 247 : IN = IN + 1 248 : JPLIB(IN) = I 249 : ENDIF 250 : 18 CONTINUE 251 : * segement ncpr detruit dans devini 252 : ENDIF 253 : * 254 : * Gestion de la table definissant les resultats attendus: 255 : * ( par la suite, on s'occupera de TREDU ) 256 : * 257 : 258 : jchain = ichain 259 : ikpref = kpref 260 : * if (klia.le.0) klia = 1 260 : CALL DYNE15(ITS1,iKPREF,NA1,NP,NINS,IMOLIA,iktres,jtmail,REPRIS, 261 : & JCHAIN,NTVAR,klia,nliab,nplb1,idimb1,MTRA,ITCARA, 262 : &lmodyn,nmost0) 263 : 264 : IF (IERR.NE.0) RETURN 265 : KTRES = iktres 266 : itmail = jtmail 267 : ichain = jchain 268 : 269 : * Creation des objets resultats : 270 : * 271 : SEGINI,MSAM 272 : KSAM=MSAM 273 : DO 100 IP=1,NPLB 274 : JPLIBB(IP)=JPLIB(IP) 275 : 100 CONTINUE 276 : itkm = 0 277 : jtmail = itmail 278 : JTRES = KTRES 279 : JPREF = KPREF 280 : lmodyn = .true. 281 : NPLAA = 0 282 : NXPALA= 0 282 : CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn) 283 : IF (IERR.NE.0) RETURN 284 : MSAM=KSAM 285 : SEGSUP,MSAM 286 : 287 : * 288 : mchelm = itcara 289 : segact mchelm 290 : do im3 = 1,ichaml(/1) 291 : mchaml = ichaml(im3) 292 : segsup mchaml 293 : enddo 294 : segsup mchelm 295 : 296 : * 297 : * model élémentaire 298 : * 299 : II = 0 300 : * 301 : imodel = ilib 302 : segact imodel 303 : ipt8 = imamod 304 : segact ipt8 305 : imod = ipt8.num(1,1) 306 : inoa = ipt8.num(1,1) 307 : isup = ipt8.num(1,1) 308 : 309 : I = jliaib 310 : 311 : 51 continue 312 : TYPRET = ' ' 313 : MONSEUIL = ' ' 314 : if (cmatee.eq.'PO_PL_FL') then 315 : ITYP = 7 316 : IPOI = int(valmat(1)) 317 : XINER = valmat(2) 318 : XCONV = valmat(3) 319 : XVISC = valmat(4) 320 : XPCEL = valmat(5) 321 : XPCRA = valmat(6) 322 : XJEU = valmat(7) 323 : 324 : IPALB(I,1) = ITYP 325 : IPALB(I,3) = IDIM 326 : XPALB(I,1) = XINER 327 : XPALB(I,2) = XCONV 328 : XPALB(I,3) = XVISC 329 : XPALB(I,4) = XPCEL 330 : XPALB(I,5) = XPCRA 331 : XPALB(I,6) = XJEU 332 : * 333 : IPNV = (IDIM + 1) * (IPOI - 1) 334 : PS = 0.D0 335 : DO 70 ID = 1,IDIM 336 : XC = XCOOR(IPNV + ID) 337 : PS = PS + XC * XC 338 : 70 CONTINUE 339 : * end do 340 : IF (PS.LE.0.D0) THEN 340 : CALL ERREUR(162) 341 : RETURN 342 : ENDIF 343 : ID1 = 6 344 : DO 72 ID = 1,IDIM 345 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 346 : 72 CONTINUE 347 : * end do 347 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 348 : IPLIB(I,1) = IPLAC 349 : * 350 : else if(cmatee.eq.'PO_PL_FR') then 351 : ITYP = 3 352 : MARAID = ' ' 353 : TYPRET = ' ' 354 : MONAMO = ' ' 355 : 356 : IPOI = int(valmat(1)) 357 : if (valmat(2).gt.0.) then 358 : xrain = valmat(2) 359 : MARAID = 'FLOTTANT' 360 : endif 361 : XJEU = valmat(3) 362 : XGLIS = valmat(4) 363 : XADHE = valmat(5) 364 : XRAIT = valmat(6) 365 : XAMOT = valmat(7) 366 : 367 : if (valmat(/1).gt.7) then 368 : if (valmat(8).gt.0.) then 369 : xamon = valmat(8) 370 : MONAMO = 'FLOTTANT' 371 : endif 372 : if (tyval(9)(9:16).eq.'EVOLUTIO') then 373 : ipevo = int(valmat(9)) 374 : TYPRET = 'EVOLUTIO' 375 : endif 376 : endif 377 : 378 : IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN 378 : CALL ERREUR(891) 379 : RETURN 380 : ENDIF 381 : IF (TYPRET.EQ.'EVOLUTIO') THEN 382 : ITYP = 103 383 : XRAIN = 0.d0 384 : ENDIF 385 : IPALB(I,1) = ITYP 386 : IPALB(I,3) = IDIM 387 : XPALB(I,1) = XRAIN 388 : XPALB(I,2) = XJEU 389 : XPALB(I,3) = XGLIS 390 : XPALB(I,4) = XADHE 391 : XPALB(I,5) = XRAIT 392 : XPALB(I,6) = XAMOT 393 : IF (MONAMO.EQ.'FLOTTANT') THEN 394 : XPALB(I,7) = XAMON 395 : ELSE 396 : XPALB(I,7) = 0.D0 397 : ENDIF 398 : * 399 : IPNV = (IDIM + 1) * (IPOI - 1) 400 : PS = 0.D0 401 : DO 20 ID = 1,IDIM 402 : XC = XCOOR(IPNV + ID) 403 : PS = PS + XC * XC 404 : 20 CONTINUE 405 : * end do 406 : IF (PS.LE.0.D0) THEN 406 : CALL ERREUR(162) 407 : RETURN 408 : ENDIF 409 : ID1 = 7 410 : DO 22 ID = 1,IDIM 411 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 412 : 22 CONTINUE 413 : * end do 414 : 415 : IF (IPALB(I,1) .EQ. 103) THEN 416 : MEVOLL = IPEVO 417 : * 418 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 419 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans 420 : * des tableaux xabsci et xordon 421 : * 422 : SEGACT MEVOLL 423 : KEVOLL = IEVOLL(1) 424 : SEGACT KEVOLL 425 : MLREE1 = IPROGX 426 : MLREE2 = IPROGY 427 : SEGACT MLREE1 428 : SEGACT MLREE2 429 : NIP = XABSCI(/2) 430 : * 431 : DO 26 MM=1,NIP 432 : XABSCI (I,MM) = MLREE1.PROG(MM) 433 : XORDON (I,MM) = MLREE2.PROG(MM) 434 : 26 CONTINUE 435 : SEGDES MLREE1 436 : SEGDES MLREE2 437 : SEGDES KEVOLL 438 : SEGDES MEVOLL 439 : ENDIF 440 : * 440 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 441 : IPLIB(I,1) = IPLAC 442 : * 443 : else if(cmatee.eq.'PO_PL') then 444 : ITYP = 1 445 : IPERM = 0 446 : XPALB(I,3) = 0.D0 447 : MONSEUIL =' ' 448 : TYPRET= ' ' 449 : IPOI = int(valmat(1)) 450 : xraid = valmat(2) 451 : xjeu = valmat(3) 452 : if (ivalma(6).gt.0) then 453 : MONSEUIL ='FLOTTANT' 454 : xseuil = valmat(6) 455 : endif 456 : xamon = valmat(7) 457 : XPALB(I,3) = XAMON 458 : if (ivalma(4).gt.0) then 459 : ipevo = int(valmat(4)) 460 : TYPRET = 'EVOLUTIO' 461 : endif 462 : *? 463 : if (valmat(5).ne.0) IPERM = 1 464 : 465 : 466 : IPALB(I,1) = ITYP 467 : IPALB(I,3) = IDIM 468 : IPALB(I,4) = IPERM 469 : XPALB(I,1) = XRAID 470 : XPALB(I,2) = XJEU 471 : * 472 : IPNV = (IDIM + 1) * (IPOI - 1) 473 : PS = 0.D0 474 : DO 17 ID = 1,IDIM 475 : XC = XCOOR(IPNV + ID) 476 : PS = PS + XC * XC 477 : 17 CONTINUE 478 : * 479 : IF (PS.LE.0.D0) THEN 479 : CALL ERREUR(162) 480 : RETURN 481 : ENDIF 482 : ID1 = 3 483 : 484 : IF (MONSEUIL .EQ.'FLOTTANT') THEN 485 : IF (TYPRET .EQ. 'EVOLUTIO') THEN 486 : IPALB(I,1) = 101 487 : ELSE 488 : IPALB(I,1) = 100 489 : ENDIF 490 : ID1 = 4 491 : XPALB(I,ID1) = XSEUIL 492 : ELSE 493 : IF (TYPRET .EQ. 'EVOLUTIO') THEN 494 : IPALB(I,1) = 102 495 : ENDIF 496 : ENDIF 497 : 498 : * 499 : DO 12 ID = 1,IDIM 500 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 501 : 12 CONTINUE 502 : * 503 : IF (IPALB(I,1) .EQ. 101 .OR. IPALB(I,1) .EQ. 102) THEN 504 : MEVOLL = IPEVO 505 : * 506 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 507 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans 508 : * des tableaux xabsci et xordon 509 : * 510 : SEGACT MEVOLL 511 : KEVOLL = IEVOLL(1) 512 : SEGACT KEVOLL 513 : MLREE1 = IPROGX 514 : MLREE2 = IPROGY 515 : SEGACT MLREE1 516 : SEGACT MLREE2 517 : NIP = XABSCI(/2) 518 : * 519 : DO 16 MM=1,NIP 520 : XABSCI (I,MM) = MLREE1.PROG(MM) 521 : XORDON (I,MM) = MLREE2.PROG(MM) 522 : 16 CONTINUE 523 : * 524 : SEGDES MLREE1 525 : SEGDES MLREE2 526 : SEGDES KEVOLL 527 : SEGDES MEVOLL 528 : ENDIF 529 : * 530 : c IMOD = num(1,1) 530 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 531 : IPLIB(I,1) = IPLAC 532 : * 533 : else if (cmatee.eq.'PO_PO_FR') then 534 : ITYP = 13 535 : MARAID = ' ' 536 : MONPER = ' ' 537 : MONAMO = ' ' 538 : TYPRET = ' ' 539 : TYPREG = ' ' 540 : CHARRE = ' ' 541 : igibe = 0 542 : IPOI = int(valmat(1)) 543 : xraid = valmat(2) 544 : xjeu = valmat(3) 545 : INOB = int(valmat(4)) 546 : xadhe = valmat(5) 547 : xrait = valmat(6) 548 : xamot = valmat(7) 549 : xglis = valmat(8) 550 : if (valmat(/1).gt.8) then 551 : if (tyval(10)(9:16).eq.'EVOLUTIO') then 552 : ipevo = int(valmat(10)) 553 : TYPRET = 'EVOLUTIO' 554 : endif 555 : if (tyval(11)(1:6).eq.'ENTIER') then 556 : igibe = int(valmat(11)) 557 : TYPREG = 'MOT' 558 : if (igibe.eq.1) CHARRE = 'GIBERT' 559 : endif 560 : if (tyval(9)(1:6).eq.'REAL*8') then 561 : xamon = valmat(9) 562 : MONAMO='FLOTTANT' 563 : endif 564 : endif 565 : 566 : 567 : IF (IERR.NE.0) RETURN 568 : ** dans quel cas monamo est il entier? PV 569 : ** IF (MONAMO .EQ. 'ENTIER ') THEN 570 : ** XAMON = 1.D0*I0 571 : ** MONAMO = 'FLOTTANT' 572 : ** ENDIF 573 : IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN 573 : CALL ERREUR(891) 574 : RETURN 575 : ENDIF 576 : IF (TYPRET.EQ.'EVOLUTIO') THEN 577 : ITYP = 113 578 : XRAID = 0.d0 579 : ENDIF 580 : * 581 : IPALB(I,1) = ITYP 582 : IPALB(I,3) = IDIM 583 : XPALB(I,1) = XRAID 584 : XPALB(I,2) = XJEU 585 : XPALB(I,3) = XGLIS 586 : XPALB(I,4) = XADHE 587 : XPALB(I,5) = XRAIT 588 : XPALB(I,6) = XAMOT 589 : IF (MONAMO.EQ.'FLOTTANT') THEN 590 : XPALB(I,7) = XAMON 591 : ELSE 592 : XPALB(I,7) = 0.D0 593 : ENDIF 594 : 595 : * cas particulier pas tres orthodoxe pour Gibert 596 : * on passe a ityp = -13 et on modifie et ajoute 597 : * devlb2, devlb1-->devfb2--->dgcha4--->dgchfr--->dgchgl, devso4 598 : IF (TYPREG.EQ.'MOT') THEN 599 : IF (CHARRE.EQ.'GIBERT') THEN 600 : IPALB(I,1) = -13 601 : ELSE 601 : CALL ERREUR(891) 602 : RETURN 603 : ENDIF 604 : ELSEIF (IGIBE.NE.0) THEN 604 : CALL ERREUR(891) 605 : RETURN 606 : ENDIF 607 : 608 : * 609 : * normalisation de la normale 610 : * 611 : IPNV = (IDIM + 1) * (IPOI - 1) 612 : PS = 0.D0 613 : DO 420 ID = 1,IDIM 614 : XC = XCOOR(IPNV + ID) 615 : PS = PS + XC * XC 616 : 420 CONTINUE 617 : * end do 618 : IF (PS.LE.0.D0) THEN 618 : CALL ERREUR(162) 619 : RETURN 620 : ENDIF 621 : DO 422 ID = 1,IDIM 622 : ID2 = 7 + ID 623 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 624 : 422 CONTINUE 625 : * end do 626 : * 627 : IF (IPALB(I,1) .EQ. 113) THEN 628 : MEVOLL = IPEVO 629 : * 630 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 631 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans 632 : * des tableaux xabsci et xordon 633 : * 634 : SEGACT MEVOLL 635 : KEVOLL = IEVOLL(1) 636 : SEGACT KEVOLL 637 : MLREE1 = IPROGX 638 : MLREE2 = IPROGY 639 : SEGACT MLREE1 640 : SEGACT MLREE2 641 : NIP = XABSCI(/2) 642 : * 643 : DO 424 MM=1,NIP 644 : XABSCI (I,MM) = MLREE1.PROG(MM) 645 : XORDON (I,MM) = MLREE2.PROG(MM) 646 : 424 CONTINUE 647 : * 648 : SEGDES MLREE1 649 : SEGDES MLREE2 650 : SEGDES KEVOLL 651 : SEGDES MEVOLL 652 : ENDIF 653 : * 653 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) 654 : IPLIB(I,1) = IPLAC 654 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) 655 : IPLIB(I,2) = IPLAC 656 : 657 : * 658 : else if(cmatee.eq.'PO_PO_DP') then 659 : ITYP = 16 660 : MARAID = ' ' 661 : MONPER = ' ' 662 : LPERM = .false. 663 : IPERM = 0 664 : MONAMO = ' ' 665 : TYPRET = ' ' 666 : 667 : IPOI = int(valmat(1)) 668 : IECRO = int(valmat(2)) 669 : * IECRO = 1 <= isotrope , IECRO = 2 <= cinematique 670 : LECRO = .true. 671 : if (iecro.eq.1) monecr = 'ISOTROPE' 672 : if (iecro.eq.2) monecr = 'CINEMATIQUE' 673 : xjeu = valmat(3) 674 : inob = int(valmat(4)) 675 : * IPERM = 2 <= isotrope , IPERM = 3 <= cinematique 676 : if (valmat(5).gt.0) LPERM = .true. 677 : IPERM = int(valmat(5)) 678 : IPEVO = int(valmat(6)) 679 : if (tyval(10)(9:16).eq.'EVOLUTIO') then 680 : TYPRET = 'EVOLUTIO' 681 : endif 682 : if (valmat(/1).gt.6) then 683 : xamon = valmat(7) 684 : MONAMO='FLOTTANT' 685 : endif 686 : 687 : IF (IERR.NE.0) RETURN 688 : 689 : IF (LPERM) THEN 690 : IF (.NOT.(XJEU.EQ.0.D0)) THEN 691 : * WRITE (*,*) 'Liaison permanente, mise a zero du jeu.' 692 : XJEU = 0.D0 693 : ENDIF 694 : 695 : IF (IPERM.ne.3.and.IPERM.ne.2) THEN 695 : call erreur(21) 696 : RETURN 697 : ENDIF 698 : ENDIF 699 : * 700 : MEVOLL = IPEVO 701 : * 702 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 703 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans 704 : * des tableaux xabsci et xordon 705 : * 706 : SEGACT MEVOLL 707 : KEVOLL = IEVOLL(1) 708 : SEGACT KEVOLL 709 : MLREE1 = IPROGX 710 : MLREE2 = IPROGY 711 : SEGACT MLREE1 712 : SEGACT MLREE2 713 : NIP = XABSCI(/2) 714 : * 715 : DO 426 MM=1,NIP 716 : XABSCI (I,MM) = MLREE1.PROG(MM) 717 : XORDON (I,MM) = MLREE2.PROG(MM) 718 : 426 CONTINUE 719 : * 720 : SEGDES MLREE1 721 : SEGDES MLREE2 722 : SEGDES KEVOLL 723 : SEGDES MEVOLL 724 : * 725 : IPALB(I,1) = ITYP 726 : IPALB(I,3) = IDIM 727 : XPALB(I,1) = XJEU 728 : IPALB(I,5) = IPERM 729 : * 730 : * normalisation de la normale 731 : * 732 : IPNV = (IDIM + 1) * (IPOI - 1) 733 : PS = 0.D0 734 : DO 30 ID = 1,IDIM 735 : XC = XCOOR(IPNV + ID) 736 : PS = PS + XC * XC 737 : 30 CONTINUE 738 : * end do 739 : IF (PS.LE.0.D0) THEN 739 : CALL ERREUR(162) 740 : RETURN 741 : ENDIF 742 : IF (MONAMO.EQ.'FLOTTANT') THEN 743 : IPALB(I,1) = 17 744 : XPALB(I,2) = XAMON 745 : DO 32 ID = 1,IDIM 746 : ID2 = 2 + ID 747 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 748 : 32 CONTINUE 749 : * end do 750 : ELSE 751 : DO 34 ID = 1,IDIM 752 : ID2 = 1 + ID 753 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 754 : 34 CONTINUE 755 : * end do 756 : ENDIF 757 : * 757 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) 758 : IPLIB(I,1) = IPLAC 758 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) 759 : IPLIB(I,2) = IPLAC 760 : * 761 : else if(cmatee.eq.'PO_PO_RP') then 762 : ITYP = 50 763 : MARAID = ' ' 764 : MONPER = ' ' 765 : MONELA = ' ' 766 : LPERM = .FALSE. 767 : LELAS = .FALSE. 768 : LECRO = .FALSE. 769 : IPERM = 0 770 : MONAMO = ' ' 771 : TYPRET = ' ' 772 : 773 : IPOI = int(valmat(1)) 774 : IECRO = int(valmat(2)) 775 : * IECRO = 1 <= isotrope , IECRO = 2 <= cinematique 776 : LECRO = .true. 777 : if (iecro.eq.1) monecr = 'ISOTROPE' 778 : if (iecro.eq.2) monecr = 'CINEMATIQUE' 779 : xjeu = valmat(3) 780 : inob = int(valmat(4)) 781 : * iperm = -2 : liaison elastique permanente 782 : * iperm = -1 : choc elastique 783 : * iperm = 0 : donnees incoherentes ou insuffisantes 784 : * iperm = 1 : choc plastique 785 : * iperm = 2 : liaison plastique isotrope 786 : * iperm = 3 : liaison plastique cinematique 787 : if (valmat(5).gt.0) LPERM = .true. 788 : IPERM = int(valmat(5)) 789 : IPEVO = int(valmat(6)) 790 : if (tyval(10)(9:16).eq.'EVOLUTIO') then 791 : TYPRET = 'EVOLUTIO' 792 : endif 793 : if (valmat(/1).gt.6) then 794 : xamon = valmat(7) 795 : if (valmat(7).gt.0) MONAMO='FLOTTANT' 796 : if (valmat(8).gt.0) LELAS = .true. 797 : endif 798 : 799 : IF (IERR.NE.0) RETURN 800 : 801 : IF (LPERM) THEN 802 : IF (LELAS.AND.(.NOT.LECRO)) IPERM = -2 803 : IF (MONECR.EQ.'ISOTROPE'.AND.(.NOT.LELAS)) IPERM = 2 804 : IF (MONECR.EQ.'CINEMATIQUE'.AND.(.NOT.LELAS)) IPERM = 3 805 : IF (.NOT.(XJEU.EQ.0.)) THEN 806 : * WRITE(*,*) 'Liaison permanente, mise a zero du jeu.' 807 : XJEU = 0.D0 808 : ENDIF 809 : ELSE 810 : IF (.NOT.LECRO) THEN 811 : IF (LELAS) THEN 812 : IPERM = -1 813 : ELSE 814 : IPERM = 1 815 : ENDIF 816 : ENDIF 817 : ENDIF 818 : IF (IPERM.EQ.0) THEN 818 : CALL ERREUR(905) 819 : RETURN 820 : ENDIF 821 : * 822 : MEVOLL = IPEVO 823 : * 824 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 825 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans 826 : * des tableaux xabsci et xordon 827 : * 828 : SEGACT MEVOLL 829 : KEVOLL = IEVOLL(1) 830 : SEGACT KEVOLL 831 : MLREE1 = IPROGX 832 : MLREE2 = IPROGY 833 : SEGACT MLREE1 834 : SEGACT MLREE2 835 : * NIP = MLREE1.PROG(/1) 836 : NIP = XABSCI(/2) 837 : * 838 : DO 110 MM=1,NIP 839 : XABSCI (I,MM) = MLREE1.PROG(MM) 840 : XORDON (I,MM) = MLREE2.PROG(MM) 841 : 110 CONTINUE 842 : * 843 : SEGDES MLREE1 844 : SEGDES MLREE2 845 : SEGDES KEVOLL 846 : SEGDES MEVOLL 847 : * 848 : IPALB(I,1) = ITYP 849 : IPALB(I,3) = IDIM 850 : IPALB(I,5) = IPERM 851 : XPALB(I,1) = XJEU 852 : * 853 : * normalisation de l'axe de rotation 854 : * 855 : IPNV = (IDIM + 1) * (IPOI - 1) 856 : PS = 0.D0 857 : DO 120 ID = 1,IDIM 858 : XC = XCOOR(IPNV + ID) 859 : PS = PS + XC * XC 860 : 120 CONTINUE 861 : * end do 862 : IF (PS.LE.0.D0) THEN 862 : CALL ERREUR(162) 863 : RETURN 864 : ENDIF 865 : IF (MONAMO.EQ.'FLOTTANT') THEN 866 : IPALB(I,1) = 51 867 : XPALB(I,2) = XAMON 868 : DO 122 ID = 1,IDIM 869 : ID2 = 2 + ID 870 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 871 : 122 CONTINUE 872 : * end do 873 : ELSE 874 : DO 124 ID = 1,IDIM 875 : ID2 = 1 + ID 876 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 877 : 124 CONTINUE 878 : * end do 879 : ENDIF 880 : * 880 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) 881 : IPLIB(I,1) = IPLAC 881 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) 882 : IPLIB(I,2) = IPLAC 883 : * 884 : * 885 : else if(cmatee.eq.'PO_PO') then 886 : ITYP = 11 887 : MARAID = ' ' 888 : MONPER = ' ' 889 : LPERM = .FALSE. 890 : IPERM = 0 891 : MONAMO = ' ' 892 : TYPRET = ' ' 893 : IPOI = int(valmat(1)) 894 : XRAID = valmat(2) 895 : if (valmat(2).gt.0) MARAID = 'FLOTTANT' 896 : XJEU = valmat(3) 897 : INOB = int(valmat(4)) 898 : IPERM = int(valmat(5)) 899 : if (IPERM.gt.0) LPERM = .true. 900 : if (valmat(/1).gt.5) then 901 : xamon = valmat(6) 902 : if (valmat(6).gt.0) MONAMO='FLOTTANT' 903 : IPEVO = int(valmat(7)) 904 : if (tyval(7)(9:16).eq.'EVOLUTIO') then 905 : TYPRET = 'EVOLUTIO' 906 : endif 907 : 908 : endif 909 : 910 : IF (IERR.NE.0) RETURN 911 : 912 : IF (MARAID.EQ.'FLOTTANT' .EQV. TYPRET.EQ.'EVOLUTIO') THEN 912 : CALL ERREUR(891) 913 : RETURN 914 : ENDIF 915 : * 916 : IF (TYPRET.EQ.'EVOLUTIO') THEN 917 : ITYP = 111 918 : XRAID = 0.d0 919 : ENDIF 920 : 921 : IPALB(I,1) = ITYP 922 : IPALB(I,3) = IDIM 923 : IPALB(I,4) = IPERM 924 : XPALB(I,1) = XRAID 925 : XPALB(I,2) = XJEU 926 : * 927 : * normalisation de la normale 928 : * 929 : IPNV = (IDIM + 1) * (IPOI - 1) 930 : PS = 0.D0 931 : DO 111 ID = 1,IDIM 932 : XC = XCOOR(IPNV + ID) 933 : PS = PS + XC * XC 934 : 111 CONTINUE 935 : * end do 936 : IF (PS.LE.0.D0) THEN 936 : CALL ERREUR(162) 937 : RETURN 938 : ENDIF 939 : IF (MONAMO.EQ.'FLOTTANT') THEN 940 : XPALB(I,3) = XAMON 941 : ELSE 942 : XPALB(I,3) = 0.d0 943 : ENDIF 944 : DO 112 ID = 1,IDIM 945 : ID2 = 3 + ID 946 : XPALB(I,ID2) = XCOOR(IPNV + ID) / SQRT(PS) 947 : 112 CONTINUE 948 : * end do 949 : * 950 : IF (IPALB(I,1) .EQ. 111) THEN 951 : MEVOLL = IPEVO 952 : * 953 : * si IEVOLL(/1) different de 1 => probleme (on veut une seule courbe) 954 : * Ici, on recupere les abscisses et les ordonnees de l'evolution dans 955 : * des tableaux xabsci et xordon 956 : * 957 : SEGACT MEVOLL 958 : KEVOLL = IEVOLL(1) 959 : SEGACT KEVOLL 960 : MLREE1 = IPROGX 961 : MLREE2 = IPROGY 962 : SEGACT MLREE1 963 : SEGACT MLREE2 964 : NIP = XABSCI(/2) 965 : * 966 : DO 116 MM=1,NIP 967 : XABSCI (I,MM) = MLREE1.PROG(MM) 968 : XORDON (I,MM) = MLREE2.PROG(MM) 969 : 116 CONTINUE 970 : * 971 : SEGDES MLREE1 972 : SEGDES MLREE2 973 : SEGDES KEVOLL 974 : SEGDES MEVOLL 975 : ENDIF 976 : * 976 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) 977 : IPLIB(I,1) = IPLAC 977 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) 978 : IPLIB(I,2) = IPLAC 979 : * 980 : else if(cmatee.eq.'PO_CE_MO') then 981 : ITYP = 33 982 : MONAMO = ' ' 983 : MARAID = ' ' 984 : MONINTER = ' ' 985 : LINTER = .true. 986 : IPOI = int(valmat(1)) 987 : xraid = valmat(2) 988 : if (valmat(2).gt.0) MARAID = 'FLOTTANT' 989 : INOB = int(valmat(3)) 990 : XRAYO = valmat(4) 991 : XGLIS = valmat(5) 992 : XADHE = valmat(6) 993 : XRAIT = valmat(7) 994 : XAMOT = valmat(8) 995 : if (valmat(/1).gt.8) then 996 : xamon = valmat(10) 997 : if(valmat(10).gt.0) MONAMO = 'FLOTTANT' 998 : xinter = valmat(9) 999 : if(valmat(9).gt.0) LINTER = .FALSE. 1000 : endif 1001 : 1002 : IF (IERR.NE.0) RETURN 1003 : IPALB(I,1) = ITYP 1004 : IPALB(I,3) = IDIM 1005 : IPALB(I,4) = 1 1006 : IF (.NOT.LINTER) THEN 1007 : IPALB(I,4) = 0 1008 : ENDIF 1009 : XPALB(I,1) = XRAID 1010 : XPALB(I,2) = XRAYO 1011 : XPALB(I,3) = XGLIS 1012 : XPALB(I,4) = XADHE 1013 : XPALB(I,5) = XRAIT 1014 : XPALB(I,6) = XAMOT 1015 : * 1016 : * normalisation de la normale 1017 : * 1018 : IPNV = (IDIM + 1) * (IPOI - 1) 1019 : IPNOA = (IDIM + 1) * (INOA - 1) 1020 : IPNOB = (IDIM + 1) * (INOB - 1) 1021 : PS = 0.D0 1022 : DO 202 ID = 1,IDIM 1023 : XC = XCOOR(IPNV + ID) 1024 : PS = PS + XC * XC 1025 : 202 CONTINUE 1026 : *** 1027 : IF (PS.LE.0.D0) THEN 1027 : CALL ERREUR(162) 1028 : RETURN 1029 : ENDIF 1030 : IF (MONAMO.EQ.'FLOTTANT') THEN 1031 : IPALB(I,1) = 34 1032 : XPALB(I,7) = XAMON 1033 : ID1 = 7 1034 : ELSE 1035 : ID1 = 6 1036 : ENDIF 1037 : ID2 = ID1 + IDIM 1038 : DO 222 ID = 1,IDIM 1039 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 1040 : XPALB(I,ID2+ID) = XCOOR(IPNOB+ID) - XCOOR(IPNOA+ID) 1041 : 222 CONTINUE 1041 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOA) 1042 : IPLIB(I,1) = IPLAC 1042 : CALL PLACE2(JPLIB,NPLB,IPLAC,INOB) 1043 : IPLIB(I,2) = IPLAC 1044 : * 1045 : else if(cmatee.eq.'PO_CE_FR') then 1046 : ITYP = 23 1047 : MONAMO = ' ' 1048 : MARAID = ' ' 1049 : MONINTER = ' ' 1050 : LINTER = .true. 1051 : IPOI = int(valmat(1)) 1052 : XRAIN = valmat(2) 1053 : if (valmat(2).gt.0) MARAID = 'FLOTTANT' 1054 : IEXC = int(valmat(3)) 1055 : XRAYO = valmat(4) 1056 : XGLIS = valmat(5) 1057 : XADHE = valmat(6) 1058 : XRAIT = valmat(7) 1059 : XAMOT = valmat(8) 1060 : if (valmat(/1).gt.8) then 1061 : xamon = valmat(10) 1062 : if(valmat(10).gt.0) MONAMO = 'FLOTTANT' 1063 : xinter = valmat(9) 1064 : if(valmat(9).gt.0) LINTER = .FALSE. 1065 : endif 1066 : 1067 : IF (IERR.NE.0) RETURN 1068 : * 1069 : IPALB(I,1) = ITYP 1070 : IPALB(I,3) = IDIM 1071 : IPALB(I,4) = 1 1072 : IF (.NOT.LINTER) THEN 1073 : IPALB(I,4) = 0 1074 : ENDIF 1075 : XPALB(I,1) = XRAIN 1076 : XPALB(I,2) = XRAYO 1077 : XPALB(I,3) = XGLIS 1078 : XPALB(I,4) = XADHE 1079 : XPALB(I,5) = XRAIT 1080 : XPALB(I,6) = XAMOT 1081 : * 1082 : * normalisation de la normale 1083 : * 1084 : IPNV = (IDIM + 1) * (IPOI - 1) 1085 : IPEX = (IDIM + 1) * (IEXC - 1) 1086 : PS = 0.D0 1087 : DO 320 ID = 1,IDIM 1088 : XC = XCOOR(IPNV + ID) 1089 : PS = PS + XC * XC 1090 : 320 CONTINUE 1091 : *** 1092 : * end do 1093 : IF (PS.LE.0.D0) THEN 1093 : CALL ERREUR(162) 1094 : RETURN 1095 : ENDIF 1096 : IF (MONAMO.EQ.'FLOTTANT') THEN 1097 : IPALB(I,1) = 24 1098 : XPALB(I,7) = XAMON 1099 : ID1 = 7 1100 : ELSE 1101 : ID1 = 6 1102 : ENDIF 1103 : ID2 = ID1 + IDIM 1104 : DO 322 ID = 1,IDIM 1105 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 1106 : XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 1107 : 322 CONTINUE 1108 : * end do 1108 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 1109 : IPLIB(I,1) = IPLAC 1110 : * 1111 : else if(cmatee.eq.'PO_CE') then 1112 : ITYP = 21 1113 : MARAID = ' ' 1114 : MONPER = ' ' 1115 : MONAMO = ' ' 1116 : TYPRET = ' ' 1117 : IPOI = int(valmat(1)) 1118 : XRAID = valmat(2) 1119 : if (valmat(2).gt.0) MARAID = 'FLOTTANT' 1120 : IEXC = int(valmat(3)) 1121 : XRAYO = valmat(4) 1122 : if (valmat(/1).gt.4) then 1123 : xamon = valmat(5) 1124 : if(valmat(5).gt.0) MONAMO = 'FLOTTANT' 1125 : endif 1126 : 1127 : IF (IERR.NE.0) RETURN 1128 : IPALB(I,1) = ITYP 1129 : IPALB(I,3) = IDIM 1130 : XPALB(I,1) = XRAID 1131 : XPALB(I,2) = XRAYO 1132 : * 1133 : * normalisation de la normale 1134 : * 1135 : IPNV = (IDIM + 1) * (IPOI - 1) 1136 : IPEX = (IDIM + 1) * (IEXC - 1) 1137 : PS = 0.D0 1138 : DO 210 ID = 1,IDIM 1139 : XC = XCOOR(IPNV + ID) 1140 : PS = PS + XC * XC 1141 : 210 CONTINUE 1142 : IF (PS.LE.0.D0) THEN 1142 : CALL ERREUR(162) 1143 : RETURN 1144 : ENDIF 1145 : IF (MONAMO.EQ.'FLOTTANT') THEN 1146 : IPALB(I,1) = 22 1147 : XPALB(I,3) = XAMON 1148 : ID1 = 3 1149 : ELSE 1150 : ID1 = 2 1151 : ENDIF 1152 : ID2 = ID1 + IDIM 1153 : DO 212 ID = 1,IDIM 1154 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 1155 : XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 1156 : 212 CONTINUE 1157 : * end do 1157 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 1158 : IPLIB(I,1) = IPLAC 1159 : * 1160 : else if(cmatee.eq.'CE_PL_FR') then 1161 : ITYP = 5 1162 : MONAMO = ' ' 1163 : IPOI = int(valmat(1)) 1164 : xrain = valmat(2) 1165 : XJEU = valmat(3) 1166 : MARAID = 'FLOTTANT' 1167 : XRAYP = valmat(4) 1168 : XGLIS = valmat(5) 1169 : XADHE = valmat(6) 1170 : XRAIT = valmat(7) 1171 : XAMOT = valmat(8) 1172 : xamon = valmat(9) 1173 : if (xamon.ne.0.d0) MONAMO = 'FLOTTANT' 1174 : 1175 : IPALB(I,1) = ITYP 1176 : IPALB(I,3) = IDIM 1177 : XPALB(I,1) = XRAIN 1178 : XPALB(I,2) = XJEU 1179 : XPALB(I,3) = XGLIS 1180 : XPALB(I,4) = XADHE 1181 : XPALB(I,5) = XRAIT 1182 : XPALB(I,6) = XAMOT 1183 : * 1184 : IPNV = (IDIM + 1) * (IPOI - 1) 1185 : PS = 0.D0 1186 : DO 230 ID = 1,IDIM 1187 : XC = XCOOR(IPNV + ID) 1188 : PS = PS + XC * XC 1189 : 230 CONTINUE 1190 : * end do 1191 : IF (PS.LE.0.D0) THEN 1191 : CALL ERREUR(162) 1192 : RETURN 1193 : ENDIF 1194 : IF (MONAMO.EQ.'FLOTTANT') THEN 1195 : IPALB(I,1) = 6 1196 : XPALB(I,7) = XAMON 1197 : ID1 = 7 1198 : ELSE 1199 : ID1 = 6 1200 : ENDIF 1201 : ID8 = ID1 + 7*IDIM 1202 : XPALB(I,ID8+1) = XRAYP 1203 : DO 232 ID = 1,IDIM 1204 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 1205 : 232 CONTINUE 1206 : * end do 1206 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 1207 : IPLIB(I,1) = IPLAC 1208 : * 1209 : else if(cmatee.eq.'CE_CE_FR') then 1210 : ITYP = 25 1211 : MONAMO = ' ' 1212 : MARAID = ' ' 1213 : MONINTER = ' ' 1214 : LINTER = .true. 1215 : IPOI = int(valmat(1)) 1216 : xrain = valmat(2) 1217 : if(valmat(2).gt.0) MARAID = 'FLOTTANT' 1218 : IEXC = int(valmat(3)) 1219 : XRAYP = valmat(4) 1220 : XGLIS = valmat(5) 1221 : XADHE = valmat(6) 1222 : XRAIT = valmat(7) 1223 : XAMOT = valmat(8) 1224 : XRAYB = valmat(9) 1225 : if(valmat(10).gt.0) then 1226 : xamon = valmat(10) 1227 : if (valmat(10).gt.0) MONAMO = 'FLOTTANT' 1228 : xinter = valmat(11) 1229 : if (valmat(11).gt.0) LINTER = .false. 1230 : endif 1231 : 1232 : IF (IERR.NE.0) RETURN 1233 : * 1234 : IPALB(I,1) = ITYP 1235 : IPALB(I,3) = IDIM 1236 : IPALB(I,4) = 1 1237 : IF (.NOT.LINTER) THEN 1238 : IPALB(I,4) = 0 1239 : ENDIF 1240 : XPALB(I,1) = XRAIN 1241 : XPALB(I,2) = XRAYB 1242 : XPALB(I,3) = XGLIS 1243 : XPALB(I,4) = XADHE 1244 : XPALB(I,5) = XRAIT 1245 : XPALB(I,6) = XAMOT 1246 : * 1247 : * normalisation de la normale 1248 : * 1249 : IPNV = (IDIM + 1) * (IPOI - 1) 1250 : IPEX = (IDIM + 1) * (IEXC - 1) 1251 : PS = 0.D0 1252 : DO 330 ID = 1,IDIM 1253 : XC = XCOOR(IPNV + ID) 1254 : PS = PS + XC * XC 1255 : 330 CONTINUE 1256 : * end do 1257 : *** 1258 : IF (PS.LE.0.D0) THEN 1258 : CALL ERREUR(162) 1259 : RETURN 1260 : ENDIF 1261 : IF (MONAMO.EQ.'FLOTTANT') THEN 1262 : ID1 = 7 1263 : IPALB(I,1) = 26 1264 : XPALB(I,7) = XAMON 1265 : ELSE 1266 : ID1 = 6 1267 : ENDIF 1268 : ID10 = ID1 + 9*IDIM 1269 : XPALB(I,ID10+1) = XRAYP 1270 : ID2 = ID1 + IDIM 1271 : ID3 = ID1 + 2*IDIM 1272 : DO 332 ID = 1,IDIM 1273 : XPALB(I,ID1+ID) = XCOOR(IPNV + ID) / SQRT(PS) 1274 : XPALB(I,ID2+ID) = XCOOR(IPEX + ID) 1275 : 332 CONTINUE 1276 : * end do 1276 : CALL PLACE2(JPLIB,NPLB,IPLAC,IMOD) 1277 : IPLIB(I,1) = IPLAC 1278 : * 1279 : else if(cmatee.eq.'PR_PR_IN'.OR.cmatee.eq.'PR_PR_EX') then 1280 : if(cmatee.eq.'PR_PR_IN') ityp = 31 1281 : IF(cmatee.eq.'PR_PR_EX') ITYP = 32 1282 : 1283 : INOR = int(valmat(1)) 1284 : xraid = valmat(2) 1285 : MARAID = 'FLOTTANT' 1286 : IMA1 = int(valmat(3)) 1287 : IMA2 = int(valmat(4)) 1288 : xpuis = valmat(5) 1289 : 1290 : IF (IERR.NE.0) RETURN 1291 : * 1292 : IPALB(I,1) = ITYP 1293 : IPALB(I,3) = IDIM 1294 : XPALB(I,1) = XRAID 1295 : XPALB(I,3) = XPUIS 1296 : ID1 = 3 1297 : IP1 = 5 1298 : * 1299 : * le maillage IMA1 est en {l{ment de type POI1 1300 : MELEME = IMA1 1301 : SEGACT MELEME 1302 : NOMBN1 = NUM(/2) 1303 : IPALB(I,4) = NOMBN1 1304 : IDP = ID1 + 5*IDIM 1305 : DO 512 IE = 1,NOMBN1 1306 : IPT = NUM(1,IE) 1307 : INPT = ( IDIM + 1 ) * ( IPT - 1 ) 1308 : DO 514 ID = 1,IDIM 1309 : XPALB(I,IDP+ID) = XCOOR(INPT + ID) 1310 : 514 CONTINUE 1311 : * end do 1312 : IDP = IDP + IDIM 1313 : 512 CONTINUE 1314 : * end do 1315 : SEGDES MELEME 1316 : * 1317 : * le maillage IMA2 est en {l{ment de type POI1 1318 : MELEME = IMA2 1319 : SEGACT MELEME 1320 : NOMBN2 = NUM(/2) 1321 : IPALB(I,5) = NOMBN2 1322 : DO 516 IE = 1,NOMBN2 1323 : IPT = NUM(1,IE) 1324 : INPT = ( IDIM + 1 ) * ( IPT - 1 ) 1325 : DO 518 ID = 1,IDIM 1326 : XPALB(I,IDP+ID) = XCOOR(INPT + ID) 1327 : 518 CONTINUE 1328 : * end do 1329 : IDP = IDP + IDIM 1330 : 516 CONTINUE 1331 : * end do 1332 : SEGDES MELEME 1332 : CALL PLACE2(JPLIB,NPLB,IPLAC,ISUP) 1333 : IPLIB(I,1) = IPLAC 1334 : * 1335 : * cr{ation d'un rep}re orthonorm{ dans le plan des maillages 1336 : * le point origine est le premier point de IMA1 1336 : CALL DYNE28(INOR,ISUP,XPALB,NLIAB,I,ID1) 1337 : IF (IERR.NE.0) RETURN 1338 : * 1339 : * coefficient des droites form{es par les {l{ments de IMA1 1339 : CALL DYNE29(IPALB,XPALB,NLIAB,NOMBN1,NOMBN2,I,ID1,IP1) 1340 : * 1341 : * position initiale de IMA2 par rapport @ IMA1 1341 : CALL DYNE30(IPALB,XPALB,NLIAB,NOMBN1,NOMBN2,I,ID1,IP1) 1342 : * 1343 : * calcul de la section du profil mobile 1343 : CALL DYNE33(XPALB,IPALB,NLIAB,I,ID1,XSECT) 1344 : XPALB(I,2) = XSECT 1345 : * 1346 : * 1347 : else if(cmatee.eq.'LI_LI_FR') then 1348 : ITYP = 35 1349 : MONJEU = ' ' 1350 : MONAMO = ' ' 1351 : MARAID = ' ' 1352 : CMOT = ' ' 1353 : MONESC = ' ' 1354 : MONSYM = ' ' 1355 : MONREC = ' ' 1356 : INOR = 0 1357 : SEGINI MLIGNE 1358 : 1359 : * 1360 : INOR = int(valmat(1)) 1361 : IMAI = int(valmat(2)) 1362 : MONESC = tyval(3)(9:16) 1363 : IESC = int(valmat(3)) 1364 : MELEME = IESC 1365 : SEGACT MELEME 1366 : if (num(/2).eq.1) then 1367 : MONESC = 'POINT' 1368 : IESC = num(1,1) 1369 : segdes meleme 1370 : endif 1371 : if (valmat(4).gt.0) then 1372 : if (tyval(4)(1:8).eq.'POINTEUR') then 1373 : IRAIES = int(valmat(4)) 1374 : MARAID = 'CHPOINT' 1375 : else 1376 : xraide = valmat(4) 1377 : MARAID = 'FLOTTANT' 1378 : endif 1379 : endif 1380 : IPALB(I,1) = ITYP 1381 : IPALB(I,3) = IDIM 1382 : c XPALB(I,3) = XGLIS 1383 : c XPALB(I,4) = XADHE 1384 : c XPALB(I,5) = XRAIT 1385 : c XPALB(I,6) = XAMOT 1386 : XPALB(I,3) = valmat(5) 1387 : XPALB(I,4) = valmat(6) 1388 : XPALB(I,5) = valmat(7) 1389 : XPALB(I,6) = valmat(8) 1390 : xjeu = valmat(9) 1391 : if (xjeu.gt.0.) MONJEU = 'FLOTTANT' 1392 : if (valmat(10).gt.0) then 1393 : if (tyval(10)(1:8).eq.'POINTEUR') then 1394 : typret=tyval(10)(9:16) 1395 : iamoes = int(valmat(10)) 1396 : MONAMO = 'CHPOINT' 1397 : else 1398 : XAMO = valmat(10) 1399 : MONAMO = 'FLOTTANT' 1400 : endif 1401 : endif 1402 : irchec = int(valmat(11)) 1403 : if (irchec.gt.0) MONREC = 'MOT' 1404 : if (irchec.eq.1) CMOT(1:7)= 'GLOBALE' 1405 : isyme = int(valmat(12)) 1406 : if (isyme.gt.0) MONSYM = 'MOT' 1407 : if (isyme.eq.1) CMOT1(1:7)='LOCALE' 1408 : if (isyme.eq.2) CMOT1(1:4)='VRAI' 1409 : if (isyme.eq.3) CMOT1(1:7)='GLOBALE' 1410 : 1411 : * 1412 : IF (MONAMO.EQ.'CHPOINT') THEN 1413 : IPALB(I,1) = 36 1414 : ID1 = 7 1415 : ELSE 1416 : ID1 = 6 1417 : ENDIF 1418 : * Normale au plan 1419 : IF (IDIM.EQ.3) THEN 1419 : if (inor.eq.0) call erreur(26) 1420 : IPNO = (IDIM + 1) * (INOR - 1) 1421 : PS = 0.D0 1422 : DO 80 ID = 1,IDIM 1423 : XC = XCOOR(IPNO + ID) 1424 : PS = PS + XC * XC 1425 : 80 CONTINUE 1426 : * end do 1427 : IF (PS.LE.0.D0) THEN 1427 : CALL ERREUR(162) 1428 : RETURN 1429 : ENDIF 1430 : DO 81 ID=1,IDIM 1431 : XPALB(I,ID1+ID) = XCOOR(IPNO + ID) / SQRT(PS) 1432 : 81 CONTINUE 1433 : ELSE 1434 : DO 82 ID=1,IDIM 1435 : XPALB(I,ID1+ID) = 0.D0 1436 : 82 CONTINUE 1437 : ENDIF 1438 : IF (MONJEU.EQ.'FLOTTANT') THEN 1439 : XPALB(I,2) = XJEU 1440 : ELSE 1441 : XPALB(I,2) = 0.D0 1442 : ENDIF 1443 : * La recherche s'effectue par d�faut localement 1444 : IF (MONREC.EQ.'MOT') THEN 1445 : IF (CMOT(1:7).EQ.'GLOBALE') THEN 1446 : IPALB(I,23) = 1 1447 : ELSE 1448 : IPALB(I,23) = 0 1449 : ENDIF 1450 : ELSE 1451 : IPALB(I,23) = 0 1452 : ENDIF 1453 : * Coordonn�es du maillage_maitre 1454 : MELEME = IMAI 1455 : SEGACT MELEME 1456 : * Pour savoir si le contour est ferm� 1457 : NELEMA = NUM(/2) 1458 : IF (NUM(1,1).EQ.NUM(2,NELEMA)) THEN 1459 : NNOEMA = NELEMA 1460 : IFERMA = 1 1461 : ELSE 1462 : NNOEMA = NELEMA +1 1463 : IFERMA = 0 1464 : ENDIF 1465 : IPALB(I,21) = NNOEMA 1466 : IPALB(I,24) = IFERMA 1467 : ID2 = ID1 + 4*IDIM 1468 : IPT = NUM(1,1) 1469 : INPT = (IDIM+1)*(IPT-1) 1469 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1470 : IPLIB(I,1) = IPLAC 1471 : KPLIB(1) = IPT 1472 : DO 84 ID=1,IDIM 1473 : XPALB(I,ID2+ID) = XCOOR(INPT+ID) 1474 : 84 CONTINUE 1475 : DO 85 IE=1,(NNOEMA-1) 1476 : IPT = NUM(2,IE) 1477 : INPT = (IDIM+1)*(IPT-1) 1477 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1478 : IPLIB(I,IE+1) = IPLAC 1479 : KPLIB(IE+1) = IPT 1480 : IDIE = ID2 + IE*IDIM 1481 : DO 86 ID=1,IDIM 1482 : XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 1483 : 86 CONTINUE 1484 : 85 CONTINUE 1485 : SEGDES MELEME 1486 : * Maillage_esclave 1487 : ID3 = ID2 + NNOEMA*IDIM 1488 : IF (MONESC.EQ.'POINT') THEN 1489 : * La ligne esclave est un point 1490 : NNOEES=1 1491 : IFERES=0 1492 : ISYMET=-1 1493 : * Lecture des coordonn�es 1494 : IPESC = (IDIM+1)*(IESC-1) 1494 : CALL PLACE2(JPLIB,NPLB,IPLAC,IESC) 1495 : IPLIB(I,NNOEMA+1) = IPLAC 1496 : KPLIB(NNOEMA+1) = IESC 1497 : DO 90 ID = 1,IDIM 1498 : XPALB(I,ID3+ID) = XCOOR(IPESC+ID) 1499 : 90 CONTINUE 1500 : * 1501 : IPALB(I,22) = NNOEES 1502 : IPALB(I,25) = IFERES 1503 : IPALB(I,26) = ISYMET 1504 : ELSE 1505 : IF (MONESC.EQ.'MAILLAGE') THEN 1506 : * La ligne esclave est un maillage 1507 : MELEME = IESC 1508 : SEGACT MELEME 1509 : * Pour savoir si le contour est ferm� 1510 : NELEES = NUM(/2) 1511 : IF (NUM(1,1).EQ.NUM(2,NELEES)) THEN 1512 : NNOEES = NELEES 1513 : IFERES = 1 1514 : ELSE 1515 : NNOEES = NELEES +1 1516 : IFERES = 0 1517 : ENDIF 1518 : IPALB(I,22) = NNOEES 1519 : IPALB(I,25) = IFERES 1520 : * Coordonn�es du maillage_esclave 1521 : IPT = NUM(1,1) 1522 : INPT = (IDIM+1)*(IPT-1) 1522 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1523 : IPLIB(I,NNOEMA+1) = IPLAC 1524 : KPLIB(NNOEMA+1) = IPT 1525 : DO 94 ID=1,IDIM 1526 : XPALB(I,ID3+ID) = XCOOR(INPT+ID) 1527 : 94 CONTINUE 1528 : DO 95 IE=1,(NNOEES-1) 1529 : IPT = NUM(2,IE) 1530 : INPT = (IDIM+1)*(IPT-1) 1530 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1531 : IPLIB(I,NNOEMA+IE+1) = IPLAC 1532 : KPLIB(NNOEMA+IE+1) = IPT 1533 : IDIE = ID3 + IE*IDIM 1534 : DO 96 ID=1,IDIM 1535 : XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 1536 : 96 CONTINUE 1537 : 95 CONTINUE 1538 : SEGDES MELEME 1539 : * Le traitement sym�trique par d�faut ne s'effectue pas 1540 : IF (MONSYM.EQ.'MOT') THEN 1541 : IF (CMOT1(1:7).EQ.'LOCALE') THEN 1542 : IPALB(I,26) = 1 1543 : ELSE 1544 : IF (CMOT1(1:4).EQ.'VRAI'.OR. 1545 : & CMOT1(1:7).EQ.'GLOBALE') THEN 1546 : IPALB(I,26) = 0 1547 : ELSE 1548 : IPALB(I,26) = -1 1549 : ENDIF 1550 : ENDIF 1551 : ELSE 1552 : IPALB(I,26) = -1 1553 : ENDIF 1554 : ELSE 1555 : * La ligne esclave n'est ni un point ni un maillage 1555 : * CALL ERREUR(...) 1556 : RETURN 1557 : ENDIF 1558 : ENDIF 1559 : * Lecture des chpoints de raideur et d amortissement 1560 : * Raideurs des noeuds esclaves et maitres 1561 : ID4=ID1+(2*(NNOEMA+NNOEES)+4)*IDIM 1562 : MCHPOI=IRAIES 1563 : SEGACT,MCHPOI 1564 : NSOUP=IPCHP(/1) 1565 : DO 700 IPC=1,NSOUP 1566 : MSOUPO=IPCHP(IPC) 1567 : SEGACT,MSOUPO 1568 : MELEME = IGEOC 1569 : SEGACT,MELEME 1570 : MPOVAL = IPOVAL 1571 : SEGACT,MPOVAL 1572 : NNN = NUM(/2) 1573 : DO 711 INN=1,NNN 1574 : IPT = NUM(1,INN) 1574 : CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) 1575 : IF (IPLAC.NE.0) THEN 1576 : XPALB(I,ID4+IPLAC)=VPOCHA(INN,1) 1577 : ENDIF 1578 : 711 CONTINUE 1579 : SEGDES,MPOVAL,MELEME 1580 : SEGDES MSOUPO 1581 : 700 CONTINUE 1582 : SEGDES,MCHPOI 1583 : * Amortissement des noeuds esclaves et maitres 1584 : ID5=ID4+NNOEMA+NNOEES 1585 : IF (IPALB(I,1).EQ.36) THEN 1586 : MCHPOI=IAMOES 1587 : SEGACT,MCHPOI 1588 : NSOUP = IPCHP(/1) 1589 : DO 121 IPC=1,NSOUP 1590 : MSOUPO=IPCHP(IPC) 1591 : SEGACT,MSOUPO 1592 : MELEME = IGEOC 1593 : SEGACT,MELEME 1594 : MPOVAL = IPOVAL 1595 : SEGACT,MPOVAL 1596 : NNN=NUM(/2) 1597 : DO 130 INN=1,NNN 1598 : IPT = NUM(1,INN) 1598 : CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) 1599 : IF (IPLAC.NE.0) THEN 1600 : XPALB(I,ID5+IPLAC)=VPOCHA(INN,1) 1601 : ENDIF 1602 : 130 CONTINUE 1603 : SEGDES MPOVAL,MELEME 1604 : SEGDES MSOUPO 1605 : 121 CONTINUE 1606 : SEGDES MCHPOI 1607 : ENDIF 1608 : SEGSUP MLIGNE 1609 : 1610 : else if(cmatee.eq.'LI_CE_FR') then 1611 : * 1612 : * --- choc élémentaire LIGNE_CERCLE_FROTTEMENT 1613 : * avec ou sans amortissement 1614 : * 1615 : ITYP = 37 1616 : MONJEU = ' ' 1617 : MONAMO = ' ' 1618 : MARAID = ' ' 1619 : CMOT = ' ' 1620 : MONESC = ' ' 1621 : MONSYM = ' ' 1622 : MONREC = ' ' 1623 : INOR = 0 1624 : SEGINI MLIGNE 1625 : 1626 : IMAI = int(valmat(2)) 1627 : MONESC = tyval(3)(9:16) 1628 : IESC = int(valmat(3)) 1629 : MELEME = IESC 1630 : SEGACT MELEME 1631 : if (num(/2).eq.1) then 1632 : MONESC = 'POINT' 1633 : IESC = num(1,1) 1634 : segdes meleme 1635 : endif 1636 : IRAIES = int(valmat(4)) 1637 : XGLIS = valmat(5) 1638 : XADHE = valmat(6) 1639 : XRAIT = valmat(7) 1640 : XAMOT = valmat(8) 1641 : * 1642 : if (valmat(/1).gt.8) MONAMO = tyval(9)(9:16) 1643 : IAMOES = int(valmat(9)) 1644 : * 1645 : if (valmat(/1).gt.8) MONREC = tyval(10) 1646 : iorec = int(valmat(10)) 1647 : if (iorec.eq.1) CMOT='VRAI' 1648 : * 1649 : if (valmat(/1).gt.8) MONRAY = tyval(11) 1650 : XRAY = valmat(11) 1651 : 1652 : if (valmat(/1).gt.8) MONCAL = tyval(12) 1653 : iotnor = int(valmat(12)) 1654 : if (iotnor.eq.1) CMOT2='VRAI' 1655 : * 1656 : IPALB(I,1) = ITYP 1657 : IPALB(I,3) = IDIM 1658 : XPALB(I,3) = XGLIS 1659 : XPALB(I,4) = XADHE 1660 : XPALB(I,5) = XRAIT 1661 : XPALB(I,6) = XAMOT 1662 : * 1663 : IF (MONCAL.EQ.'ENTIER') THEN 1664 : IF (CMOT2(1:4).EQ.'VRAI') THEN 1665 : IPALB(I,1)=39 1666 : ENDIF 1667 : ENDIF 1668 : 1669 : 1670 : IF (MONAMO.EQ.'CHPOINT') THEN 1671 : IPALB(I,1) = IPALB(I,1)+1 1672 : ID1 = 7 1673 : ELSE 1674 : ID1 = 6 1675 : ENDIF 1676 : 1677 : 1678 : * Normale aux butees ou au cylindre enveloppant le segment 1679 : IF (IDIM.EQ.3) THEN 1680 : INOR = int(valmat(1)) 1681 : IF (IERR.NE.0) RETURN 1682 : IPNO = (IDIM + 1) * (INOR - 1) 1683 : PS = 0.D0 1684 : DO 3780 ID = 1,IDIM 1685 : XC = XCOOR(IPNO + ID) 1686 : PS = PS + XC * XC 1687 : 3780 CONTINUE 1688 : * end do 1689 : IF (PS.LE.0.D0) THEN 1689 : CALL ERREUR(162) 1690 : RETURN 1691 : ENDIF 1692 : DO 3781 ID=1,IDIM 1693 : XPALB(I,ID1+ID) = XCOOR(IPNO + ID) / SQRT(PS) 1694 : 3781 CONTINUE 1695 : ELSE 1696 : DO 3782 ID=1,IDIM 1697 : XPALB(I,ID1+ID) = 0.D0 1698 : 3782 CONTINUE 1699 : ENDIF 1700 : IF (MONRAY.EQ.'FLOTTANT') THEN 1701 : XPALB(I,2) = XRAY 1702 : ELSE 1703 : XPALB(I,2) = 0.D0 1704 : ENDIF 1705 : * La recherche s'effectue par défaut localement 1706 : IF (MONREC.EQ.'MOT') THEN 1707 : IF (CMOT(1:7).EQ.'GLOBALE') THEN 1708 : IPALB(I,23) = 1 1709 : ELSE 1710 : IPALB(I,23) = 0 1711 : ENDIF 1712 : ELSE 1713 : IPALB(I,23) = 0 1714 : ENDIF 1715 : * 1716 : * Coordonnées du maillage_maitre 1717 : MELEME = IMAI 1718 : 1719 : SEGACT MELEME 1720 : 1721 : 1722 : * Pour savoir si le contour est fermé 1723 : NELEMA = NUM(/2) 1724 : IF (NUM(1,1).EQ.NUM(2,NELEMA)) THEN 1725 : NNOEMA = NELEMA 1726 : IFERMA = 1 1727 : ELSE 1728 : NNOEMA = NELEMA +1 1729 : IFERMA = 0 1730 : ENDIF 1731 : IPALB(I,21) = NNOEMA 1732 : IPALB(I,24) = IFERMA 1733 : ID2 = ID1 + 4*IDIM 1734 : IPT = NUM(1,1) 1735 : INPT = (IDIM+1)*(IPT-1) 1735 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1736 : IPLIB(I,1) = IPLAC 1737 : KPLIB(1) = IPT 1738 : DO 3784 ID=1,IDIM 1739 : XPALB(I,ID2+ID) = XCOOR(INPT+ID) 1740 : 3784 CONTINUE 1741 : DO 3785 IE=1,(NNOEMA-1) 1742 : IPT = NUM(2,IE) 1743 : INPT = (IDIM+1)*(IPT-1) 1743 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1744 : IPLIB(I,IE+1) = IPLAC 1745 : KPLIB(IE+1) = IPT 1746 : IDIE = ID2 + IE*IDIM 1747 : DO 3786 ID=1,IDIM 1748 : XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 1749 : 3786 CONTINUE 1750 : 3785 CONTINUE 1751 : SEGDES MELEME 1752 : * 1753 : * Maillage_esclave 1754 : ID3 = ID2 + NNOEMA*IDIM 1755 : IF (MONESC.EQ.'POINT') THEN 1756 : * La ligne esclave est un point 1757 : NNOEES=1 1758 : IFERES=0 1759 : ISYMET=-1 1760 : * Lecture des coordonnées 1761 : IPESC = (IDIM+1)*(IESC-1) 1761 : CALL PLACE2(JPLIB,NPLB,IPLAC,IESC) 1762 : IPLIB(I,NNOEMA+1) = IPLAC 1763 : KPLIB(NNOEMA+1) = IESC 1764 : DO 3790 ID = 1,IDIM 1765 : XPALB(I,ID3+ID) = XCOOR(IPESC+ID) 1766 : 3790 CONTINUE 1767 : * 1768 : IPALB(I,22) = NNOEES 1769 : IPALB(I,25) = IFERES 1770 : IPALB(I,26) = ISYMET 1771 : ELSE 1772 : IF (MONESC.EQ.'MAILLAGE') THEN 1773 : * La ligne esclave est un maillage 1774 : MELEME = IESC 1775 : SEGACT MELEME 1776 : * Pour savoir si le contour est fermé 1777 : NELEES = NUM(/2) 1778 : IF (NUM(1,1).EQ.NUM(2,NELEES)) THEN 1779 : NNOEES = NELEES 1780 : IFERES = 1 1781 : ELSE 1782 : NNOEES = NELEES +1 1783 : IFERES = 0 1784 : ENDIF 1785 : IPALB(I,22) = NNOEES 1786 : IPALB(I,25) = IFERES 1787 : * Coordonnées du maillage_esclave 1788 : IPT = NUM(1,1) 1789 : INPT = (IDIM+1)*(IPT-1) 1789 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1790 : IPLIB(I,NNOEMA+1) = IPLAC 1791 : KPLIB(NNOEMA+1) = IPT 1792 : DO 3794 ID=1,IDIM 1793 : XPALB(I,ID3+ID) = XCOOR(INPT+ID) 1794 : 3794 CONTINUE 1795 : DO 3795 IE=1,(NNOEES-1) 1796 : IPT = NUM(2,IE) 1797 : INPT = (IDIM+1)*(IPT-1) 1797 : CALL PLACE2(JPLIB,NPLB,IPLAC,IPT) 1798 : IPLIB(I,NNOEMA+IE+1) = IPLAC 1799 : KPLIB(NNOEMA+IE+1) = IPT 1800 : IDIE = ID3 + IE*IDIM 1801 : DO 3796 ID=1,IDIM 1802 : XPALB(I,IDIE+ID) = XCOOR(INPT+ID) 1803 : 3796 CONTINUE 1804 : 3795 CONTINUE 1805 : SEGDES MELEME 1806 : MONINV=' ' 1807 : if (valmat(/1).gt.8) then 1808 : if (valmat(13).gt.0) then 1809 : MONINV = 'LOGIQUE' 1810 : Lo1 = .true. 1811 : endif 1812 : else 1813 : endif 1814 : * Le traitement symétrique ne s'effectue pas PAR DÉFAUT 1815 : 1816 : IF (MONINV.EQ.'LOGIQUE') THEN 1817 : IF (.NOT.Lo1) THEN 1818 : IPALB(I,26) = -1 1819 : ELSE 1820 : IPALB(I,26) = 0 1821 : ENDIF 1822 : ELSE 1823 : IPALB(I,26) = -1 1824 : ENDIF 1825 : 1826 : ELSE 1827 : * La ligne esclave n'est ni un point ni un maillage 1827 : * CALL ERREUR(...) 1828 : RETURN 1829 : ENDIF 1830 : ENDIF 1831 : * Lecture des chpoints de raideur et d amortissement 1832 : * Raideurs des noeuds esclaves et maitres 1833 : ID4=ID1+(2*(NNOEMA+NNOEES)+4)*IDIM 1834 : MCHPOI=IRAIES 1835 : SEGACT,MCHPOI 1836 : NSOUP=IPCHP(/1) 1837 : DO 37100 IPC=1,NSOUP 1838 : MSOUPO=IPCHP(IPC) 1839 : SEGACT,MSOUPO 1840 : MELEME = IGEOC 1841 : SEGACT,MELEME 1842 : MPOVAL = IPOVAL 1843 : SEGACT,MPOVAL 1844 : NNN = NUM(/2) 1845 : DO 37110 INN=1,NNN 1846 : IPT = NUM(1,INN) 1846 : CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) 1847 : IF (IPLAC.NE.0) THEN 1848 : XPALB(I,ID4+IPLAC)=VPOCHA(INN,1) 1849 : ENDIF 1850 : 37110 CONTINUE 1851 : SEGDES,MPOVAL,MELEME 1852 : SEGDES MSOUPO 1853 : 37100 CONTINUE 1854 : SEGDES,MCHPOI 1855 : * Amortissement des noeuds esclaves et maitres 1856 : ID5=ID4+NNOEMA+NNOEES 1857 : IF (IPALB(I,1).EQ.38 .OR. IPALB(I,1).EQ.40) THEN 1858 : MCHPOI=IAMOES 1859 : SEGACT,MCHPOI 1860 : NSOUP = IPCHP(/1) 1861 : DO 37120 IPC=1,NSOUP 1862 : MSOUPO=IPCHP(IPC) 1863 : SEGACT,MSOUPO 1864 : MELEME = IGEOC 1865 : SEGACT,MELEME 1866 : MPOVAL = IPOVAL 1867 : SEGACT,MPOVAL 1868 : NNN=NUM(/2) 1869 : DO 37130 INN=1,NNN 1870 : IPT = NUM(1,INN) 1870 : CALL PLACE2(KPLIB,NPLB,IPLAC,IPT) 1871 : IF (IPLAC.NE.0) THEN 1872 : XPALB(I,ID5+IPLAC)=VPOCHA(INN,1) 1873 : ENDIF 1874 : 37130 CONTINUE 1875 : SEGDES MPOVAL,MELEME 1876 : SEGDES MSOUPO 1877 : 37120 CONTINUE 1878 : SEGDES MCHPOI 1879 : ENDIF 1880 : SEGSUP MLIGNE 1881 : * 1882 : 1883 : else if(cmatee.eq.'PA_FL_RO') then 1884 : ITYP = 60 1885 : MONMOT='RODELI' 1886 : MTLIAB = KTLIAB 1887 : * 1888 : NUML = I 1889 : IP1 = imod 1890 : IF (IERR.NE.0) RETURN 1890 : CALL PLACE2(JPLIB,NPLB,IPLAC,IP1) 1891 : IPLIB(NUML,1) = IPLAC 1892 : * 1893 : * Valeurs de IPALB et XPALB communes à tous les types de 1894 : * paliers fluides : 1895 : * 1896 : IPALB(NUML,1) = ITYP 1897 : IPALB(NUML,2) = 0 1898 : IPALB(NUML,3) = 3 1899 : IPALB(NUML,4) = 0 1900 : * 1901 : XPALB(NUML,4) = valmat(1) 1902 : XPALB(NUML,6) = valmat(2) 1903 : XPALB(NUML,1) = valmat(3) 1904 : XPALB(NUML,2) = valmat(4) 1905 : XPALB(NUML,3) = valmat(5) 1906 : XPALB(NUML,7) = valmat(6) 1907 : XPALB(NUML,8) = valmat(7) 1908 : XPALB(NUML,9) = valmat(8) 1909 : XPALB(NUML,5) = valmat(9) 1910 : itgeom = int(valmat(10)) 1911 : 1912 : * 1913 : IF (MONMOT.EQ.'RODELI'.and.itgeom.gt.0) THEN 1914 : * ----- Cas du palier cylindrique ou à lobes, avec modèle de Rhode et Li 1915 : * 1916 : IPALB(NUML,5) = 1 1916 : CALL ACCTAB(ITGEOM,'MOT',I0,X0,'NOMBRE_LOBES',L0,IP0, 1917 : & 'ENTIER',NLOB,X1,' ',Lo1,IP1) 1918 : 1919 : IF (IERR.NE.0) RETURN 1920 : IPALB(NUML,6) = NLOB 1921 : 1922 : C Nombre de parametres reels : 1923 : NBPR = 6 1924 : IPALB(NUML,7) = NBPR 1925 : 1925 : CALL ACCTAB(ITGEOM,'MOT',I0,X0,'CRITERE_ARRET',L0,IP0, 1926 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1927 : XPALB(NUML,10) = X1 1928 : 1929 : IF (IERR.NE.0) RETURN 1930 : DO 610 ILOB = 1, NLOB 1931 : * 1931 : CALL ACCTAB(ITGEOM,'ENTIER',ILOB,X0,MONMOT,L0,IP0, 1932 : & 'TABLE',I1,X1,' ',Lo1,ITLOB) 1933 : 1934 : IF (IERR.NE.0) RETURN 1934 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'NB_MAILLES',L0,IP0, 1935 : & 'ENTIER',I1,X1,' ',Lo1,IP1) 1936 : IPALB(NUML,7+ILOB) = I1 1937 : 1938 : IF (IERR.NE.0) RETURN 1938 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'JEU_USINAGE',L0,IP0, 1939 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1940 : XPALB(NUML,11+NBPR*(ILOB-1)) = X1 1941 : 1942 : IF (IERR.NE.0) RETURN 1942 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'ASYMETRIE',L0,IP0, 1943 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1944 : XPALB(NUML,12+NBPR*(ILOB-1)) = X1 1945 : 1946 : IF (IERR.NE.0) RETURN 1946 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'PRECHARGE',L0,IP0, 1947 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1948 : XPALB(NUML,13+NBPR*(ILOB-1)) = X1 1949 : 1950 : IF (IERR.NE.0) RETURN 1950 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'ANGLE_DEBUT',L0,IP0, 1951 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1952 : XPALB(NUML,14+NBPR*(ILOB-1)) = X1 1953 : 1954 : IF (IERR.NE.0) RETURN 1954 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'AMPL_ANGLE',L0,IP0, 1955 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1956 : XPALB(NUML,15+NBPR*(ILOB-1)) = X1 1957 : 1958 : IF (IERR.NE.0) RETURN 1958 : CALL ACCTAB(ITLOB,'MOT',I0,X0,'COEF_SUR',L0,IP0, 1959 : & 'FLOTTANT',I1,X1,MONMOT,Lo1,IP1) 1960 : XPALB(NUML,16+NBPR*(ILOB-1)) = X1 1961 : 1962 : IF (IERR.NE.0) RETURN 1963 : 610 CONTINUE 1964 : ENDIF 1965 : * 1966 : else 1967 : c write(6,*) 'verifier nom liaison', cmatee 1967 : call erreur(5) 1968 : return 1969 : endif 1970 : 1971 : * 1972 : * traiter liaisons conditionnelles 1973 : * 1974 : if (.false.) then 1975 : DO I = 1,kmodel(/1) 1976 : ksi = 0 1977 : imodel = kmodel(I) 1978 : segact imodel 1979 : if (tymode(/2).gt.0) then 1980 : do 722 ilc = 1,tymode(/2) 1981 : do j =1,kmodel(/1) 1982 : if (kmodel(j).eq.ivamod(ilc)) then 1983 : ksi = ksi + 1 1984 : ipalb(i,4) = 1 1985 : IF (tymode(ilc).EQ.'CONDINFE' ) THEN 1986 : ipalb (i,4+ksi) = j 1987 : ELSE IF (tymode(ilc).EQ.'CONDSUPE' ) THEN 1988 : ipalb (i,4+ksi) = -1 * j 1989 : ENDIF 1990 : endif 1991 : goto 722 1992 : enddo 1993 : 722 continue 1994 : endif 1995 : 723 continue 1996 : ENDDO 1997 : endif 1998 : 1999 : * ranger 2000 : segdes ipt8 2001 : * 2002 : 10 CONTINUE 2003 : * 2004 : * 2005 : * ----- liaisons conditionnelles ? 2006 : * 2007 : IF (IIMPI.EQ.333) THEN 2008 : c NLIAB = IPALB(/1) 2009 : c NIPALB = IPALB(/2) 2010 : c NXPALB = XPALB(/2) 2011 : c NPLBB = IPLIB(/2) 2012 : c NPLB = JPLIB(/1) 2013 : DO 1000 IN = 1,NLIAB 2014 : DO 1002 II = 1,NIPALB 2015 : WRITE(IOIMP,*)'cYNE20 : IPALB(',IN,',',II,') =',IPALB(IN,II) 2016 : 1002 CONTINUE 2017 : DO 1004 IX = 1,NXPALB 2018 : WRITE(IOIMP,*)'cYNE20 : XPALB(',IN,',',IX,') =',XPALB(IN,IX) 2019 : 1004 CONTINUE 2020 : DO 1006 IP = 1,NPLBB 2021 : WRITE(IOIMP,*)'cYNE20 : IPLIB(',IN,',',IP,') =',IPLIB(IN,IP) 2022 : 1006 CONTINUE 2023 : 1000 CONTINUE 2024 : DO 1008 IP = 1,NPLB 2025 : WRITE(IOIMP,*)'cYNE20 : JPLIB(',IP,') =',JPLIB(IP) 2026 : 1008 CONTINUE 2027 : ENDIF 2028 : * 2029 : * remplissage MTPHI 2030 : * 2031 : NPLSB=1 2032 : SEGINI,MTPHI 2033 : KTPHI = MTPHI 2034 : MTLIAB = KTLIAB 2035 : * 2036 : c NLIAB = IPALB(/1) 2037 : c NPLB = JPLIB(/1) 2038 : c NSB = XPHILB(/1) 2039 : c NPLSB = XPHILB(/2) 2040 : c NA2 = XPHILB(/3) 2041 : c IDIMB = XPHILB(/4) 2042 : IA1 = 0 2043 : 2044 : do IB = 1,nsstru 2045 : * 2046 : * de DYNE26.ESO 2047 : * 2048 : IORSB(IB) = IA1 + 1 2049 : IAROTA(IB) = 0 2050 : IROT = 0 2051 : IN = 0 2052 : 2053 : do 41 ik =1,ldefo(/1) 2054 : 2055 : if (lsstru(ik).ne.ib) goto 41 2056 : IN = IN + 1 2057 : 2058 : IA1 = IA1 + 1 2059 : 2060 : icdm = ldefo(ik) 2061 : 2062 : ** 2063 : * Prise en compte d'un mode de rotation de corps rigide 2064 : if (lcgra(ik).gt.0) then 2065 : ICDG = lcgra(ik) 2066 : IAROTA(IB)=IA1 2067 : IROT = IN 2068 : endif 2069 : * 2070 : * 2071 : IF (NLIAB.NE.0) THEN 2072 : DO 42 ID = 1,IDIMB 2073 : IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN 2074 : CMOT = NOMAXI(ID) 2075 : ELSE 2076 : IF (IFOMOD.EQ.-1) THEN 2077 : CMOT = NOMPLA(ID) 2078 : ELSE 2079 : CMOT = NOMTRI(ID) 2080 : ENDIF 2081 : ENDIF 2082 : IF (IIMPI.EQ.333) THEN 2083 : WRITE(IOIMP,*)'DYNE26 : composante @ extraire :',CMOT 2084 : ENDIF 2085 : ICOMP = 0 2086 : DO 44 IP = 1,NPLB 2087 : IPOINT = JPLIB(IP) 2088 : * 2089 : * On extrait du chpoint ICDM au point IPOINT de composante CMOT 2090 : * 2090 : CALL EXTRA9(ICDM,IPOINT,CMOT,KEREU,XVAL) 2091 : ICOMP = ICOMP + 1 2092 : * 2093 : * on ajuste la taille si necessaire 2094 : * MP 2095 : IF(ICOMP.GT.NPLSB) THEN 2096 : NPLSB=ICOMP 2097 : SEGADJ MTPHI 2098 : ENDIF 2099 : IPLSB(IP) = ICOMP 2100 : * suite ? la modif dans extra9, car on attribue une valeur meme 2101 : * si le point n'existe pas dans le chpoint 2102 : IF (XVAL.NE.0.) THEN 2103 : IF ((IBASB(IP).NE.0).AND.(IBASB(IP).NE.IB)) THEN 2103 : call erreur (783) 2104 : RETURN 2105 : ENDIF 2106 : IBASB(IP) = IB 2107 : ELSE 2108 : IF ((IB.EQ.NSB).AND.(IBASB(IP).EQ.0)) IBASB(IP) = IB 2109 : ENDIF 2110 : * 2111 : XPHILB(IB,ICOMP,IN,ID) = XVAL 2112 : IF (IIMPI.EQ.333) THEN 2113 : WRITE(IOIMP,*)'cyne20 : IPLSB(',IP,') =',IPLSB(IP) 2114 : WRITE(IOIMP,*)'cyne20 : IBASB(',IP,') =',IBASB(IP) 2115 : XVA2 = XPHILB(IB,ICOMP,IN,ID) 2116 : WRITE(IOIMP,*)'cyne20 : XPHILB(',IB,ICOMP,IN,ID,') =',XVA2 2117 : ENDIF 2118 : 2119 : 44 CONTINUE 2120 : * end do 2121 : 42 CONTINUE 2122 : * end do 2123 : ENDIF 2124 : * 2125 : 2126 : 41 continue 2127 : INMSB(IB) = IN 2128 : IN = IN + 1 2129 : 2130 : ** 2131 : * Remplissage des fausses d?form?es modales de rotations 2132 : ** 2133 : 50 continue 2134 : IF (IAROTA(IB).NE.0) THEN 2135 : ** RIGIDE = .TRUE. 2136 : MERR = 0 2137 : NPLUS = IN + 1 2138 : IF (NPLUS.GT.NA2) THEN 2139 : * On r?ajuste le dimension NA2 de XPHILB 2140 : NA2 = NPLUS 2141 : SEGADJ MTPHI 2142 : ENDIF 2143 : DO 118 IP=1,NPLB 2144 : IPOINT=JPLIB(IP) 2145 : IPOS=IPLSB(IP) 2146 : IBBAS= IBASB(IP) 2147 : IF (IBBAS.EQ.IB) THEN 2148 : DO 220 ID=(IDIM+1),IDIMB 2149 : XAXROT(ID-IDIM) = XPHILB(IB,IPOS,IROT,ID) 2150 : 220 CONTINUE 2151 : * En tridimensionnel l'axe de rotation est le vecteur propre de rotation 2152 : * On norme l axe du plan de rotation 2152 : CALL DYNE41(XAXROT,MERR,IDIM) 2153 : * En bidimensionnel l'axe de rotation est fixe 2154 : * Calcul des fausses d?form?es modales de rotation 2154 : CALL DYNE42(XROTA,XAXROT,IPOINT,ICDG,IDIMB,MERR) 2155 : DO 622 ID =1,IDIMB 2156 : XPHILB(IB,IPOS,IN,ID) = XROTA(1,ID) 2157 : XPHILB(IB,IPOS,IN+1,ID)= XROTA(2,ID) 2158 : 622 CONTINUE 2159 : ENDIF 2160 : 118 CONTINUE 2161 : ENDIF 2162 : IF (IIMPI.EQ.333) THEN 2163 : WRITE(IOIMP,*)'DYNE26 : INMSB(',IB,') =',INMSB(IB) 2164 : WRITE(IOIMP,*)'DYNE26 : IORSB(',IB,') =',IORSB(IB) 2165 : WRITE(IOIMP,*)'DYNE26 : IAROTA(',IB,') =',IAROTA(IB) 2166 : ENDIF 2167 : * 2168 : IF (IERR.NE.0) RETURN 2169 : * fin boucle sousstructure 2170 : enddo 2171 : 2172 : RETURN 2173 : END 2174 : 2175 :
© Cast3M 2003 - All rights reserved.
Disclaimer