1 : C COML10 SOURCE KICH 12/08/06 21:15:05 7460 2 : 3 : SUBROUTINE COML10(iqmod,wrk52,wrk53,ib,igau,itruli,iretou) 4 : 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : 8 : -INC CCOPTIO 9 : -INC CCGEOME 10 : -INC CCHAMP 11 : * segment deroulant le mcheml 12 : -INC DECHE 13 : -INC SMCHPOI 14 : -INC SMELEME 15 : -INC SMLENTI 16 : -INC SMLREEL 17 : *------------------------------------------------------------- 18 : * CF DEVPAS et autres s-p de DYNE 19 : ** calcul des vitesses correct pour dernière liaison (JLIAIB.eq.NLIADY) 20 : *------------------------------------------------------------- 21 : 22 : ** segment sous-structures dynamiques 23 : segment struli 24 : integer itlia,itbmod,momoda, mostat,itmail,molia 25 : integer ldefo(np1),lcgra(np1),lsstru(np1) 26 : integer nsstru,nndefo,nliab,nsb,na2,idimb 27 : integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas 28 : INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib 29 : * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0) 30 : INTEGER ICHAIN 31 : endsegment 32 : * 33 : * Segment contenant les variables au cours d'un pas de temps: 34 : * 35 : SEGMENT,MTPAS 36 : REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1) 37 : REAL*8 XPTB(NPLB,4,IDIMB),FINERT(NA1,4) 38 : REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR) 39 : REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB) 40 : ENDSEGMENT 41 : * 42 : SEGMENT,MTKAM 43 : REAL*8 XK(NA1),XASM(NA1),XM(NA1) 44 : ENDSEGMENT 45 : * 46 : SEGMENT,MTQ 47 : REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4) 48 : REAL*8 WEXT(NA1,2),WINT(NA1,2) 49 : ENDSEGMENT 50 : * 51 : SEGMENT MTLIAB 52 : INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB) 53 : REAL*8 XPALB(NLIAB,NXPALB) 54 : REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP) 55 : ENDSEGMENT 56 : * 57 : SEGMENT,MTLIAA 58 : INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA) 59 : REAL*8 XPALA(NLIAA,NXPALA) 60 : ENDSEGMENT 61 : * 62 : SEGMENT,MTPHI 63 : INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB) 64 : INTEGER IAROTA(NSB) 65 : REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB) 66 : ENDSEGMENT 67 : 68 : SEGMENT,MTRES 69 : REAL*8 XRES(NRES,NCRES,NPRES),XREP(NREP,NCRES) 70 : REAL*8 XRESLA(NLSA,NPRES,NVALA),XRESLB(NLSB,NPRES,NVALB) 71 : REAL*8 XMREP(NLIAB,4,IDIMB) 72 : INTEGER ICHRES(NVES),IPORES(NRES,NPRES),IPOREP(NREP) 73 : INTEGER IPOLA(NLSA),INULA(NLSA),IPLRLA(NLSA,NVALA) 74 : INTEGER IPOLB(NLSB),INULB(NLSB),IPLRLB(NLSB,NVALB) 75 : INTEGER ILIREA(NLSA,NTVAR),ILIREB(NLSB,NTVAR) 76 : INTEGER ILIRNA(NLSA,NTVAR),ILIRNB(NLSB,NTVAR) 77 : INTEGER IPOLR(1),IMREP(NLIAB,2),IPPREP(NLIAB,4) 78 : INTEGER ILPOLA(NLIAA,2) 79 : ENDSEGMENT 80 : 81 : SEGMENT,MPREF 82 : INTEGER IPOREF(NPREF) 83 : ENDSEGMENT 84 : * 85 : SEGMENT,MTFEX 86 : REAL*8 FEXA(NPFEXA,NPC1,2) 87 : REAL*8 FEXPSM(NPLB,NPC1,2,IDIMB) 88 : REAL*8 FTEXB(NPLB,NPC1,2,IDIM) 89 : INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB) 90 : ENDSEGMENT 91 : SEGMENT,MTNUM 92 : REAL*8 XDT(NPC1),XTEMPS(NPC1) 93 : ENDSEGMENT 94 : c Segment "local" pour DEVLFA ... 95 : SEGMENT,LOCLFA 96 : REAL*8 FTEST(NA1,4),FTOTA0(NA1,4) 97 : ENDSEGMENT 98 : * Segment "local" pour DEVLB1 ... 99 : SEGMENT,LOCLB1 100 : REAL*8 FTEST2(NPLB,6),FTOTB0(NPLB,6) 101 : ENDSEGMENT 102 : 103 : * Segment pour Champoints 104 : SEGMENT,MSAM 105 : integer jplibb(NPLB) 106 : ENDSEGMENT 107 : * 108 : SEGMENT,ICPR(XCOOR(/1)/(IDIM + 1)) 109 : * 110 : PARAMETER ( ZERO=0.D0 ) 111 : LOGICAL RIGIDE,REPRIS,LMODYN 112 : * 113 : IERRD = 0 114 : 115 : struli = itruli 116 : lmodyn = .true. 117 : MTKAM = ktkam 118 : MPREF = KPREF 119 : NPREF = iporef(/1) 120 : rigide = .false. 121 : 122 : * npc1 = 1 plante dans devso4 : pv 123 : npc1 = 2 124 : SEGINI,MTNUM 125 : KTNUM = MTNUM 126 : xdt(1) = tempf - temp0 127 : xtemps(1) = temp0 128 : 129 : IF (var0(3).gt.0.and.var0(4).gt.0) THEN 130 : *--------------------------------------------------------------------* 131 : * suite d un calcul avec variables internes de preconditionnement 132 : * VAEN , VARE, pour modeles liaisons herites de DYNE de_vogelaere 133 : *--------------------------------------------------------------------* 134 : * its2 = int(var0(2)) 135 : mlreel = int(var0(4)) 136 : segact mlreel 137 : mlenti = int(var0(3)) 138 : segact mlenti 139 : itmail = int(var0(5)) 140 : jjr = 0 141 : jje = 0 142 : 143 : jje = jje + 1 144 : JLIAIB = lect(jje) 145 : 146 : jje = jje + 1 147 : nchain = lect(jje) 148 : if (ichain.eq.0) then 149 : jg = nchain 150 : segini,mlent3 151 : ichain = mlent3 152 : else 153 : mlent3 = ichain 154 : jg = mlent3.lect(/1) 155 : if (nchain.ne.jg) then 156 : write(6,*) 'pb developpement coml10' 157 : ierr = 2 158 : return 159 : endif 160 : endif 161 : do lg = 1,nchain 162 : jje = jje + 1 163 : if (JLIAIB.eq.1) mlent3.lect(lg)= lect(jje) 164 : enddo 165 : jje = jje + 1 166 : NPAS = lect(jje) 167 : jje = jje + 1 168 : NIPALB = lect(jje) 169 : jje = jje + 1 170 : NXPALB = lect(jje) 171 : jje = jje + 1 172 : NPLBB = lect(jje) 173 : jje = jje + 1 174 : NPLB = lect(jje) 175 : jje = jje + 1 176 : NPLSB = lect(jje) 177 : jje = jje + 1 178 : NIP = lect(jje) 179 : jje = jje + 1 180 : nsstru = lect(jje) 181 : jje = jje + 1 182 : nndefo = lect(jje) 183 : MTQ = KTQ 184 : NA1 = q1(/1) 185 : jje = jje + 1 186 : nliab = lect(jje) 187 : jje = jje + 1 188 : nsb = lect(jje) 189 : jje = jje + 1 190 : na2 = lect(jje) 191 : jje = jje + 1 192 : idimb = lect(jje) 193 : jje = jje + 1 194 : NTVAR = lect(jje) 195 : jje = jje + 1 196 : NLIAA = lect(jje) 197 : jje = jje + 1 198 : NRES = lect(jje) 199 : jje = jje + 1 200 : NCRES = lect(jje) 201 : jje = jje + 1 202 : NPRES = lect(jje) 203 : jje = jje + 1 204 : NREP = lect(jje) 205 : jje = jje + 1 206 : NLSA = lect(jje) 207 : jje = jje + 1 208 : NVALA = lect(jje) 209 : jje = jje + 1 210 : NLSB = lect(jje) 211 : jje = jje + 1 212 : NVALB = lect(jje) 213 : jje = jje + 1 214 : NVES = lect(jje) 215 : jje = jje + 1 216 : i2MAX = lect(jje) 217 : 218 : 219 : NPRES = 1 220 : segini MTRES 221 : 222 : * MTRES 223 : do lg1 = 1,NVES 224 : jje = jje + 1 225 : ichres(lg1) = lect(jje) 226 : enddo 227 : do lg1 = 1,NLSA 228 : jje = jje + 1 229 : ipola(lg1) = lect(jje) 230 : enddo 231 : do lg1 = 1,NLSA 232 : jje = jje + 1 233 : inula(lg1) = lect(jje) 234 : enddo 235 : do lg1 = 1,NLSB 236 : jje = jje + 1 237 : ipolb(lg1) = lect(jje) 238 : enddo 239 : do lg1 = 1,NLSB 240 : jje = jje + 1 241 : inulb(lg1) = lect(jje) 242 : enddo 243 : do lg1 = 1,nlsa 244 : do lg2 = 1,ntvar 245 : jje = jje + 1 246 : ilirea(lg1,lg2) = lect(jje) 247 : enddo 248 : enddo 249 : do lg1 = 1,nlsa 250 : do lg2 = 1,ntvar 251 : jje = jje + 1 252 : ilirna(lg1,lg2) = lect(jje) 253 : enddo 254 : enddo 255 : do lg1 = 1,nlsb 256 : do lg2 = 1,ntvar 257 : jje = jje + 1 258 : ilireb(lg1,lg2) = lect(jje) 259 : enddo 260 : enddo 261 : do lg1 = 1,nlsb 262 : do lg2 = 1,ntvar 263 : jje = jje + 1 264 : ilirnb(lg1,lg2) = lect(jje) 265 : enddo 266 : enddo 267 : do lg1 = 1,nliaa 268 : do lg2 = 1,2 269 : jje = jje + 1 270 : ilpola(lg1,lg2) = lect(jje) 271 : enddo 272 : enddo 273 : 274 : * MTPAS 275 : if (JLIAIB.eq.1) then 276 : segini MTPAS 277 : ktpas = mtpas 278 : else 279 : mtpas = ktpas 280 : endif 281 : do lu1 = 1,nplb 282 : do lu2 = 1, 4 283 : do lu3 = 1,idimb 284 : jjr = jjr + 1 285 : xptb(lu1,lu2,lu3) = prog(jjr) 286 : enddo 287 : enddo 288 : enddo 289 : do lu1 = 1,na1 290 : do lu2 = 1,4 291 : jjr = jjr + 1 292 : finert(lu1,lu2) = prog(jjr) 293 : enddo 294 : enddo 295 : do lu1 = 1,nliaa 296 : do lu2 = 1, 4 297 : do lu3 = 1,ntvar 298 : jjr = jjr + 1 299 : xvala(lu1,lu2,lu3) = prog(jjr) 300 : enddo 301 : enddo 302 : enddo 303 : do lu1 = 1,nliab 304 : do lu2 = 1, 4 305 : do lu3 = 1,ntvar 306 : jjr = jjr + 1 307 : xvalb(lu1,lu2,lu3) = prog(jjr) 308 : enddo 309 : enddo 310 : enddo 311 : do lu1 = 1,nplb 312 : do lu2 = 1, 2 313 : do lu3 = 1,idim 314 : jjr = jjr + 1 315 : fexb(lu1,lu2,lu3) = prog(jjr) 316 : enddo 317 : enddo 318 : enddo 319 : do lu1 = 1,2 320 : do lu2 = 1, nliab 321 : do lu3 = 1,4 322 : do lu4 = 1,nplb 323 : jjr = jjr + 1 324 : XCHPFB(lu1,lu2,lu3,lu4) = prog(jjr) 325 : enddo 326 : enddo 327 : enddo 328 : enddo 329 : do lu1 = 1,na1 330 : jjr = jjr + 1 331 : ftota(lu1,3) = prog(jjr) 332 : jjr = jjr + 1 333 : ftota(lu1,4) = prog(jjr) 334 : enddo 335 : * MTQ 336 : MTQ = KTQ 337 : do lu1 = 1,na1 338 : do lu2 = 1,2 339 : jjr = jjr + 1 340 : wext(lu1,lu2) = prog(jjr) 341 : enddo 342 : enddo 343 : do lu1 = 1,na1 344 : do lu2 = 1,2 345 : jjr = jjr + 1 346 : wint(lu1,lu2) = prog(jjr) 347 : enddo 348 : enddo 349 : * MTLIAB 350 : segini MTLIAB 351 : do lu1 = 1,nliab 352 : do lu2 = 1,nxpalb 353 : jjr = jjr + 1 354 : xpalb(lu1,lu2) = prog(jjr) 355 : enddo 356 : enddo 357 : do lu1 = 1,nliab 358 : do lu2 = 1,nip 359 : jjr = jjr + 1 360 : xabsci(lu1,lu2) = prog(jjr) 361 : enddo 362 : enddo 363 : do lu1 = 1,nliab 364 : do lu2 = 1,nip 365 : jjr = jjr + 1 366 : xordon(lu1,lu2) = prog(jjr) 367 : enddo 368 : enddo 369 : do lg1 = 1,nliab 370 : do lg2 = 1,nipalb 371 : jje = jje + 1 372 : ipalb(lg1,lg2) = lect(jje) 373 : enddo 374 : enddo 375 : do lg1 = 1,nliab 376 : do lg2 = 1,nplbb 377 : jje = jje + 1 378 : iplib(lg1,lg2) = lect(jje) 379 : enddo 380 : enddo 381 : do lg1=1,nplb 382 : jje = jje + 1 383 : jplib(lg1) = lect(jje) 384 : enddo 385 : * MTPHI 386 : segini MTPHI 387 : do lu1 = 1,nsb 388 : do lu2 = 1,nplsb 389 : do lu3 = 1,na2 390 : do lu4 = 1,idimb 391 : jjr = jjr + 1 392 : xphilb(lu1,lu2,lu3,lu4) = prog(jjr) 393 : enddo 394 : enddo 395 : enddo 396 : enddo 397 : do lg1=1,nplb 398 : jje = jje + 1 399 : ibasb(lg1) = lect(jje) 400 : enddo 401 : do lg1=1,nplb 402 : jje = jje + 1 403 : iplsb(lg1) = lect(jje) 404 : enddo 405 : do lg1=1,nsb 406 : jje = jje + 1 407 : inmsb(lg1) = lect(jje) 408 : enddo 409 : do lg1=1,nsb 410 : jje = jje + 1 411 : iorsb(lg1) = lect(jje) 412 : enddo 413 : do lg1=1,nsb 414 : jje = jje + 1 415 : iarota(lg1) = lect(jje) 416 : enddo 417 : * MTFEX 418 : NPFEXA = q1(/1) 419 : NPFEXB = 0 420 : segini MTFEX 421 : do lu1 = 1,nplb 422 : do lu2 = 1,npc1 423 : do lu3 = 1,2 424 : do lu4 = 1,idimb 425 : jjr = jjr + 1 426 : fexpsm(lu1,lu2,lu3,lu4) = prog(jjr) 427 : enddo 428 : enddo 429 : enddo 430 : enddo 431 : do lu1 = 1,npfexa 432 : jjr = jjr + 1 433 : fexa(lu1,1,1) = prog(jjr) 434 : enddo 435 : * LOCLFA 436 : segini loclfa 437 : c do lu1 = 1,na1 438 : c do lu2 = 1,4 439 : c jjr = jjr + 1 440 : c prog(jjr) = ftest(lu1,lu2) 441 : c enddo 442 : c enddo 443 : c do lu1 = 1,na1 444 : c do lu2 = 1,4 445 : c jjr = jjr + 1 446 : c prog(jjr) = ftota0(lu1,lu2) 447 : c enddo 448 : c enddo 449 : *LOCLB1 450 : segini loclb1 451 : do lu1 = 1,nplb 452 : do lu2 = 1,6 453 : jjr = jjr + 1 454 : ftest2(lu1,lu2) = prog(jjr) 455 : enddo 456 : enddo 457 : do lu1 = 1,nplb 458 : do lu2 = 1,6 459 : jjr = jjr + 1 460 : ftotb0(lu1,lu2) = prog(jjr) 461 : enddo 462 : enddo 463 : 464 : KTRES = MTRES 465 : KPREF = MPREF 466 : SEGINI,MSAM 467 : KSAM=MSAM 468 : DO 100 IP=1,NPLB 469 : JPLIBB(IP)=JPLIB(IP) 470 : 100 CONTINUE 471 : itkm = 0 472 : jtmail = itmail 473 : JTRES = KTRES 474 : JPREF = KPREF 475 : NLIAA = ilpola(/1) 476 : NXPALA = 1 477 : NIPALA=3 478 : NPLAA = 0 479 : NPLA = 0 480 : segini MTLIAA 481 : ktliaa = mtliaa 481 : CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn) 482 : IF (IERR.NE.0) RETURN 483 : MSAM=KSAM 484 : SEGSUP,MSAM 485 : 486 : ELSE 487 : * 1er pas 488 : 489 : i2MAX = 0 490 : MTQ = ktq 491 : MTPHI = ktphi 492 : do istru=1,nsstru 493 : if(iarota(istru).ne.0) rigide = .true. 494 : enddo 495 : MTLIAB = ktliab 496 : c NSB = XPHILB(/1) 497 : NPLSB = XPHILB(/2) 498 : c NA2 = XPHILB(/3) 499 : c IDIMB = XPHILB(/4) 500 : c NPLB = JPLIB(/1) 501 : NA1 = nndefo 502 : segini loclfa 503 : KOCLFA = loclfa 504 : segini loclb1 505 : KOCLB1 = loclb1 506 : NPAS = 0 507 : 508 : MTRES = KTRES 509 : ITINIT = 0 510 : REPRIS = .false. 511 : JKCPR = kcpr 512 : NLIAA = ilpola(/1) 513 : NXPALA = 1 514 : NIPALA=3 515 : NPLAA = 0 516 : NPLA = 0 517 : segini MTLIAA 518 : ktliaa = mtliaa 519 : * voir comalo 520 : NTVAR = 6 + 4 * IDIM 521 : * segini mtpas 522 : if (JLIAIB.eq.1) then 523 : segini MTPAS 524 : ktpas = mtpas 525 : else 526 : mtpas = ktpas 527 : endif 528 : JKTPAS = ktpas 529 : NPFEXA = q1(/1) 530 : NPFEXB = 0 531 : SEGINI MTFEX 532 : KTFEX = MTFEX 533 : JKTLIAB = ktliab 534 : JKTQ = ktq 535 : JKTPHI = ktphi 536 : JKTKAM = KTKAM 537 : * kich : permet d'initialiser mais inexact 537 : CALL DEVINI(ITINIT,JKTKAM,JKTQ,KTFEX,JKTPAS,KTNUM,KTLIAA,JKTLIAB, 538 : & JKTPHI,JKCPR,KOCLFA,KOCLB1,REPRIS,RIGIDE,lmodyn) 539 : 540 : * segsup mtfex 541 : ENDIF 542 : 543 : IVINIT = 0 544 : * SEGINI MTFEX 545 : KTFEX = MTFEX 546 : 547 : nliady = nliab + nliaa 548 : 549 : c NLIAB = IPALB(/1) 550 : 551 : NPAS = NPAS + 1 552 : NPASF = 1 553 : 554 : do istru=1,nsstru 555 : if(iarota(istru).ne.0) rigide = .true. 556 : enddo 557 : 558 : c calculs en 2 demi-pas Runge-Kutta/ initialisation pour 1ere liaison 559 : do kna =1,na1 560 : IF(JLIAIB.eq.1) THEN 561 : *voir devfxa 562 : * fexa(kna,1,1) = q3(kna,2) 563 : 564 : * q1(kna,3) = q1(kna,2) 565 : q1(kna,2) = (q1(kna,1) + q1(kna,2))* 0.5d0 566 : * q2(kna,3) = q2(kna,2) 567 : ftota(kna,2) = q3(kna,2) 568 : ftota(kna,1) = q3(kna,2) 569 : ENDIF 570 : 571 : q2(kna,1) = 0.d0 572 : q2(kna,2) = 0.d0 573 : enddo 574 : 575 : ** voir devpas.eso 576 : DO III = 2,1,-1 577 : 578 : ** Ajout des forces de raideur avant demi-pas 579 : IF(JLIAIB.eq.1) THEN 579 : CALL DEVLK0(Q1,XK,XM,FTOTA,NA1,NPAS,III) 580 : ENDIF 581 : * 582 : 583 : * forces liaisons base A (modes) 584 : 585 : IF (NLIAA.NE.0) THEN 585 : CALL DEVLFA(Q1,Q2,FTOTA,XM,NA1,IPALA,IPLIA,XPALA,XVALA, 586 : & NLIAA,XDT,npasf,III,FINERT,IVINIT,FTEST,FTOTA0) 587 : ENDIF 588 : * 589 : * 590 : * Ajout des forces de liaison base B matérielle 591 : * 592 : IF (NLIAB.NE.0) THEN 592 : CALL DEVLFB(Q1,FTOTA,XM,NA1,IPALB,IPLIB,XPALB,XVALB,NLIAB, 593 : & XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB,XDT, 594 : & npasf,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,III, 595 : & FEXPSM,NPC1,IERRD,FTEST2,FTOTB0, 596 : & XABSCI,XORDON,NIP,FEXB,RIGIDE,IAROTA,XCHPFB) 597 : IF (IERRD.NE.0) RETURN 598 : ENDIF 599 : IF(JLIAIB.eq.nliady) THEN 600 : if (III.eq.2) then 601 : if (npas.eq.1) then 602 : do jj = 1,na1 603 : ftota(jj,3) = ftota(jj,2) 604 : enddo 605 : endif 605 : CALL DEVEQ2(Q2,NA1,XK,XASM,XM,XDT,npasf,FTOTA,FINERT) 606 : else 606 : CALL DEVEQ4(Q2,NA1,XK,XASM,XM,XDT,npasf,FTOTA,FINERT) 607 : endif 608 : ENDIF 609 : 610 : ENDDO 611 : 611 : * CALL DYNE16(Q1,Q2,Q3,NA1,FTOTA,XPTB,NPLB,IDIMB,FINERT) 612 : DO 10 I=1,NA1 613 : FINERT(I,3) = FINERT(I,1) 614 : FINERT(I,4) = FINERT(I,2) 615 : FTOTA(I,3) = FTOTA(I,1) 616 : FTOTA(I,4) = FTOTA(I,2) 617 : 10 CONTINUE 618 : DO 20 IP = 1,NPLB 619 : DO 22 ID = 1,IDIMB 620 : XPTB(IP,3,ID) = XPTB(IP,1,ID) 621 : XPTB(IP,4,ID) = XPTB(IP,2,ID) 622 : 22 CONTINUE 623 : 20 CONTINUE 624 : * 625 : * calcul des travaux 626 : * fin devpas.eso 627 : 628 : * 629 : * production chpoint forces base A (devso2) 630 : * 631 : meleme = itmail 632 : segact meleme 633 : if (lisous(/1).eq.0) then 634 : ipmmod = itmail 635 : ipmsta = 0 636 : else 637 : ipmmod = lisous(1) 638 : ipmsta = lisous(2) 639 : endif 640 : 641 : NSOUPO = 1 642 : if(ipmmod.gt.0.and.ipmsta.gt.0) nsoupo = 2 643 : NAT=1 644 : SEGINI,MCHPOI 645 : IPCHPO = MCHPOI 646 : MTYPOI = 'FLIAISONS' 647 : IFOPOI = IFOUR 648 : * nature diffuse 649 : JATTRI(1) = 1 650 : nmost0 = 0 651 : KIPCHP = 0 652 : 653 : icoe1 = 1 654 : ymaxf = 0.d0 655 : if (CMATE.eq.'PO_CE_MO') then 656 : if (i2max.ne.0) then 657 : if (FTOTBA(abs(i2max))*i2max.lt.0.) icoe1 = -1 658 : endif 659 : endif 660 : 661 : if (ipmmod.gt.0) then 662 : NC = 1 663 : IF(JLIAIB.eq.nliady) NC = 2 664 : SEGINI,MSOUPO 665 : KIPCHP = KIPCHP + 1 666 : IPCHP(KIPCHP) = MSOUPO 667 : NOCOMP(1) = 'FALF' 668 : NOHARM(1) = NIFOUR 669 : if (NC.eq.2) then 670 : NOCOMP(2) = NOCOMP(1) 671 : NOCOMP(2)(1:1) = 'V' 672 : NOHARM(2) = NIFOUR 673 : endif 674 : IGEOC = ipmmod 675 : ipt1 = ipmmod 676 : segact ipt1 677 : N = ipt1.num(/2) 678 : nmost0 = N 679 : SEGINI,MPOVAL 680 : IPOVAL = MPOVAL 681 : * 682 : do ii = 1,N 683 : if (i2max.eq.0) then 684 : if (abs(FTOTBA(ii)).gt.ymaxf) then 685 : ymaxf = abs(FTOTBA(ii)) 686 : i2max = ii 687 : if (FTOTBA(ii).lt.0) i2max = -1*i2max 688 : endif 689 : endif 690 : vpocha(ii,1) = -1*icoe1*FTOTBA(ii) 691 : if (NC.eq.2) vpocha(ii,2) = q2(ii,1) 692 : enddo 693 : 694 : SEGDES,MPOVAL,MSOUPO 695 : endif 696 : 697 : *kich : extension a tout hasard 698 : if (ipmsta.gt.0) then 699 : NC = 1 700 : IF(JLIAIB.eq.nliady) NC = 2 701 : SEGINI,MSOUPO 702 : KIPCHP = KIPCHP + 1 703 : IPCHP(KIPCHP) = MSOUPO 704 : NOCOMP(1) = 'FBET' 705 : NOHARM(1) = NIFOUR 706 : if (NC.eq.2) then 707 : NOCOMP(2) = NOCOMP(1) 708 : NOCOMP(2)(1:1) = 'V' 709 : NOHARM(2) = NIFOUR 710 : endif 711 : IGEOC = ipmsta 712 : ipt1 = ipmsta 713 : segact ipt1 714 : N = ipt1.num(/2) 715 : SEGINI,MPOVAL 716 : IPOVAL = MPOVAL 717 : * 718 : do ii = 1,N 719 : vpocha(ii,1) = -1*icoe1*FTOTBA(ii + nmost0) 720 : if (NC.eq.2) vpocha(ii,2) = q2(ii,1) 721 : enddo 722 : 723 : SEGDES,MPOVAL,MSOUPO 724 : endif 725 : 726 : segdes MCHPOI 727 : varf(1) = IPCHPO 728 : MTRES = KTRES 729 : * 730 : NINS = 1 731 : NRES = XRES(/1) 732 : NCRES = XRES(/2) 733 : NPRES = XRES(/3) 734 : NREP = XREP(/1) 735 : NLSA = XRESLA(/1) 736 : NLSB = XRESLB(/1) 737 : NVES = ICHRES(/1) 738 : NVALA = IPLRLA(/2) 739 : NVALB = IPLRLB(/2) 740 : * 741 : if (npas.eq.1) then 742 : iins2 = 2 743 : else 744 : iins2 = 1 745 : endif 746 : * range les resultats de la bonne liaison 747 : if (jliaib.gt.1) then 748 : do lu3 = 1,ntvar 749 : xvalb(1,1,lu3)=xvalb(jliaib,1,lu3) 750 : enddo 751 : * DO IP=1,NPLB 752 : * DO ID=1,2 753 : * II = II + 1 754 : * XCHPFB(ID,IIL,1,IP) = XCHPFB(ID,jliaib,1,IP) 755 : * ENDDO 756 : * ENDDO 757 : endif 758 : 759 : * transit resultat 759 : CALL DEVTR1(Q1,Q2,Q3,NA1,IINS2,NINS,FTOTA,XRES,ICHRES,NRES, 760 : & NCRES,NPRES,XREP,NREP,XVALA,INULA,NLIAA,NLSA, 761 : & XRESLA,XVALB,INULB,NLIAB,NLSB,XRESLB,ILIREA,ILIREB, 762 : & NTVAR,XPALB,IPALB,XMREP,IMREP,IDIMB,WEXT,WINT, 763 : & XCHPFB,NPLB) 764 : 765 : * sauvegarde pour aller plus vite pas suivant 766 : * 767 : JG = 1000 768 : jje = 0 769 : segini MLENTI 770 : jje = jje + 1 771 : lect(jje) = JLIAIB 772 : nchain = 0 773 : mlent3 = ichain 774 : segact mlent3 775 : nchain = mlent3.lect(/1) 776 : jje = jje + 1 777 : lect(jje) = nchain 778 : do lg = 1,nchain 779 : jje = jje + 1 780 : lect(jje)=mlent3.lect(lg) 781 : enddo 782 : jje = jje + 1 783 : lect(jje) = NPAS 784 : jje = jje + 1 785 : lect(jje) = NIPALB 786 : jje = jje + 1 787 : lect(jje) = NXPALB 788 : jje = jje + 1 789 : lect(jje) = NPLBB 790 : jje = jje + 1 791 : lect(jje) = NPLB 792 : jje = jje + 1 793 : lect(jje) = NPLSB 794 : jje = jje + 1 795 : lect(jje) = NIP 796 : jje = jje + 1 797 : lect(jje) = nsstru 798 : jje = jje + 1 799 : lect(jje) = nndefo 800 : jje = jje + 1 801 : lect(jje) = nliab 802 : jje = jje + 1 803 : lect(jje) = nsb 804 : jje = jje + 1 805 : lect(jje) = na2 806 : jje = jje + 1 807 : lect(jje) = idimb 808 : jje = jje + 1 809 : lect(jje) = NTVAR 810 : jje = jje + 1 811 : lect(jje) = NLIAA 812 : jje = jje + 1 813 : lect(jje) = NRES 814 : jje = jje + 1 815 : lect(jje) = NCRES 816 : jje = jje + 1 817 : lect(jje) = NPRES 818 : jje = jje + 1 819 : lect(jje) = NREP 820 : jje = jje + 1 821 : lect(jje) = NLSA 822 : jje = jje + 1 823 : lect(jje) = NVALA 824 : jje = jje + 1 825 : lect(jje) = NLSB 826 : jje = jje + 1 827 : lect(jje) = NVALB 828 : jje = jje + 1 829 : lect(jje) = NVES 830 : jje = jje + 1 831 : lect(jje) = i2MAX 832 : 833 : * MTRES 834 : do lg1 = 1,NVES 835 : jje = jje + 1 836 : lect(jje) = ichres(lg1) 837 : enddo 838 : do lg1 = 1,NLSA 839 : jje = jje + 1 840 : lect(jje) = ipola(lg1) 841 : enddo 842 : do lg1 = 1,NLSA 843 : jje = jje + 1 844 : lect(jje) = inula(lg1) 845 : enddo 846 : do lg1 = 1,NLSB 847 : jje = jje + 1 848 : lect(jje) = ipolb(lg1) 849 : enddo 850 : do lg1 = 1,NLSB 851 : jje = jje + 1 852 : lect(jje) = inulb(lg1) 853 : enddo 854 : do lg1 = 1,nlsa 855 : do lg2 = 1,ntvar 856 : jje = jje + 1 857 : lect(jje)= ilirea(lg1,lg2) 858 : enddo 859 : enddo 860 : do lg1 = 1,nlsa 861 : do lg2 = 1,ntvar 862 : jje = jje + 1 863 : lect(jje)= ilirna(lg1,lg2) 864 : enddo 865 : enddo 866 : do lg1 = 1,nlsb 867 : do lg2 = 1,ntvar 868 : jje = jje + 1 869 : lect(jje)= ilireb(lg1,lg2) 870 : enddo 871 : enddo 872 : do lg1 = 1,nlsb 873 : do lg2 = 1,ntvar 874 : jje = jje + 1 875 : lect(jje)= ilirnb(lg1,lg2) 876 : enddo 877 : enddo 878 : do lg1 = 1,nliaa 879 : do lg2 = 1,2 880 : jje = jje + 1 881 : lect(jje)= ilpola(lg1,lg2) 882 : enddo 883 : enddo 884 : 885 : JG = (nplb*4*idimb)+(na1*4)+(nliaa*4*ntvar)+(nliab*4*ntvar)+ 886 : &(nplb*2*idim)+(2*nliab*4*nplb)+(2*na1)+(na1*2*2)+ 887 : &(nliab*(nxpalb+nip+nip))+(nsb*na2*nplsb*idimb)+ 888 : &(nplb*npc1*2*idimb)+ npfexa +(nplb*6*2) 889 : SEGINI MLREEL 890 : jjr = 0 891 : * MTPAS 892 : do lu1 = 1,nplb 893 : do lu2 = 1, 4 894 : do lu3 = 1,idimb 895 : jjr = jjr + 1 896 : prog(jjr) = xptb(lu1,lu2,lu3) 897 : enddo 898 : enddo 899 : enddo 900 : do lu1 = 1,na1 901 : do lu2 = 1,4 902 : jjr = jjr + 1 903 : prog(jjr) = finert(lu1,lu2) 904 : enddo 905 : enddo 906 : do lu1 = 1,nliaa 907 : do lu2 = 1, 4 908 : do lu3 = 1,ntvar 909 : jjr = jjr + 1 910 : prog(jjr) = xvala(lu1,lu2,lu3) 911 : enddo 912 : enddo 913 : enddo 914 : do lu1 = 1,nliab 915 : do lu2 = 1, 4 916 : do lu3 = 1,ntvar 917 : jjr = jjr + 1 918 : prog(jjr) = xvalb(lu1,lu2,lu3) 919 : enddo 920 : enddo 921 : enddo 922 : do lu1 = 1,nplb 923 : do lu2 = 1, 2 924 : do lu3 = 1,idim 925 : jjr = jjr + 1 926 : prog(jjr) = fexb(lu1,lu2,lu3) 927 : enddo 928 : enddo 929 : enddo 930 : do lu1 = 1,2 931 : do lu2 = 1, nliab 932 : do lu3 = 1,4 933 : do lu4 = 1,nplb 934 : jjr = jjr + 1 935 : prog(jjr) = XCHPFB(lu1,lu2,lu3,lu4) 936 : enddo 937 : enddo 938 : enddo 939 : enddo 940 : do lu1 = 1,na1 941 : jjr = jjr + 1 942 : prog(jjr) = ftota(lu1,3) 943 : jjr = jjr + 1 944 : prog(jjr) = ftota(lu1,4) 945 : enddo 946 : * MTQ 947 : do lu1 = 1,na1 948 : do lu2 = 1,2 949 : jjr = jjr + 1 950 : prog(jjr) = wext(lu1,lu2) 951 : enddo 952 : enddo 953 : do lu1 = 1,na1 954 : do lu2 = 1,2 955 : jjr = jjr + 1 956 : prog(jjr) = wint(lu1,lu2) 957 : enddo 958 : enddo 959 : * MTLIAB 960 : do lu1 = 1,nliab 961 : do lu2 = 1,nxpalb 962 : jjr = jjr + 1 963 : prog(jjr) = xpalb(lu1,lu2) 964 : enddo 965 : enddo 966 : do lu1 = 1,nliab 967 : do lu2 = 1,nip 968 : jjr = jjr + 1 969 : prog(jjr) = xabsci(lu1,lu2) 970 : enddo 971 : enddo 972 : do lu1 = 1,nliab 973 : do lu2 = 1,nip 974 : jjr = jjr + 1 975 : prog(jjr) = xordon(lu1,lu2) 976 : enddo 977 : enddo 978 : do lg1 = 1,nliab 979 : do lg2 = 1,nipalb 980 : jje = jje + 1 981 : lect(jje)= ipalb(lg1,lg2) 982 : enddo 983 : enddo 984 : do lg1 = 1,nliab 985 : do lg2 = 1,nplbb 986 : jje = jje + 1 987 : lect(jje)= iplib(lg1,lg2) 988 : enddo 989 : enddo 990 : do lg1=1,nplb 991 : jje = jje + 1 992 : lect(jje)= jplib(lg1) 993 : enddo 994 : * MTPHI 995 : do lu1 = 1,nsb 996 : do lu2 = 1,nplsb 997 : do lu3 = 1,na2 998 : do lu4 = 1,idimb 999 : jjr = jjr + 1 1000 : prog(jjr) = xphilb(lu1,lu2,lu3,lu4) 1001 : enddo 1002 : enddo 1003 : enddo 1004 : enddo 1005 : do lg1=1,nplb 1006 : jje = jje + 1 1007 : lect(jje)= ibasb(lg1) 1008 : enddo 1009 : do lg1=1,nplb 1010 : jje = jje + 1 1011 : lect(jje)= iplsb(lg1) 1012 : enddo 1013 : do lg1=1,nsb 1014 : jje = jje + 1 1015 : lect(jje)= inmsb(lg1) 1016 : enddo 1017 : do lg1=1,nsb 1018 : jje = jje + 1 1019 : lect(jje)= iorsb(lg1) 1020 : enddo 1021 : do lg1=1,nsb 1022 : jje = jje + 1 1023 : lect(jje)= iarota(lg1) 1024 : enddo 1025 : * MTFEX 1026 : do lu1 = 1,nplb 1027 : do lu2 = 1,npc1 1028 : do lu3 = 1,2 1029 : do lu4 = 1,idimb 1030 : jjr = jjr + 1 1031 : prog(jjr) = fexpsm(lu1,lu2,lu3,lu4) 1032 : enddo 1033 : enddo 1034 : enddo 1035 : enddo 1036 : do lu1 = 1,npfexa 1037 : jjr = jjr + 1 1038 : prog(jjr) = fexa(lu1,1,1) 1039 : enddo 1040 : * LOCLFA 1041 : c do lu1 = 1,na1 1042 : c do lu2 = 1,4 1043 : c jjr = jjr + 1 1044 : c prog(jjr) = ftest(lu1,lu2) 1045 : c enddo 1046 : c enddo 1047 : c do lu1 = 1,na1 1048 : c do lu2 = 1,4 1049 : c jjr = jjr + 1 1050 : c prog(jjr) = ftota0(lu1,lu2) 1051 : c enddo 1052 : c enddo 1053 : *LOCLB1 1054 : do lu1 = 1,nplb 1055 : do lu2 = 1,6 1056 : jjr = jjr + 1 1057 : prog(jjr) = ftest2(lu1,lu2) 1058 : enddo 1059 : enddo 1060 : do lu1 = 1,nplb 1061 : do lu2 = 1,6 1062 : jjr = jjr + 1 1063 : prog(jjr) = ftotb0(lu1,lu2) 1064 : enddo 1065 : enddo 1066 : 1067 : JG = jjr 1068 : segadj mlreel 1069 : varf(4) = mlreel 1070 : JG = JJE 1071 : segadj mlenti 1072 : varf(3) = mlenti 1073 : varf(5) = itmail 1074 : segdes mlreel,mlenti 1075 : * 1076 : JKTLIAB= mtliab 1077 : JKTPHI = mtphi 1078 : JKTQ = mtq 1079 : JKTRES = ktres 1080 : JKOCLFA = LOCLFA 1081 : JKOCLB1 = LOCLB1 1082 : JKTNUM = mtnum 1083 : JKTFEX = mtfex 1084 : JKPREF = mpref 1085 : JKTLIAA = 0 1086 : JKTKAM = 0 1087 : JKTPAS = mtpas 1088 : IPMAIL = itmail 1089 : JMAILz = itmail 1090 : REPRIS = .false. 1091 : lmodyn = .true. 1092 : jchain = ichain 1093 : 1093 : call crtabl(its2) 1094 : ITDYN = its2 1094 : CALL DEVSO5(JKPREF,JKTQ,JKTKAM,JKTPHI,JKTLIAA,JKTLIAB,JKTFEX, 1095 : & JKTPAS,JKTRES,JKTNUM,NINS,JMAILz,REPRIS,JCHAIN, 1096 : & JKOCLFA,JKOCLB1,LMODYN,ITDYN) 1097 : if (ierr.ne.0) return 1098 : 1099 : if (itdyn.gt.0) varf(2) = itdyn 1100 : 1101 : IF(JLIAIB.eq.nliady) then 1102 : SEGSUP,MPREF 1103 : segsup,MTQ 1104 : SEGSUP,MTKAM 1105 : SEGSUP,MTPAS 1106 : ENDIF 1107 : 1108 : SEGSUP MTFEX 1109 : segsup mtnum 1110 : * 1111 : SEGSUP,MTPHI 1112 : SEGSUP,MTLIAB 1113 : SEGSUP,MTLIAA 1114 : SEGSUP,MTRES 1115 : SEGSUP,LOCLFA 1116 : SEGSUP,LOCLB1 1117 : if (npas.eq.1.and.jliaib.lt.nliady) then 1118 : mlent3 = ichain 1119 : segsup mlent3 1120 : endif 1121 : 1122 : ichain = jchain 1123 : 1124 : RETURN 1125 : END 1126 : 1127 : 1128 :
© Cast3M 2003 - All rights reserved.
Disclaimer