Télécharger coml10.eso

Retour à la liste

Numérotation des lignes :

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales