Télécharger coml10.eso

Retour à la liste

Numérotation des lignes :

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

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