Télécharger coml10.eso

Retour à la liste

Numérotation des lignes :

  1. C COML10 SOURCE BP208322 18/07/13 21:15:00 9880
  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. cbp cas particulier ou IPALB contient un listreel a activer (palier)
  392. do lg1 = 1,nliab
  393. if(ipalb(lg1,1).eq.60) then
  394. if(ipalb(lg1,5).eq.1) then
  395. nlob=ipalb(lg1,6)
  396. do ilob=1,nlob
  397. mlree1=ipalb(lg1,7+ilob)
  398. segact,mlree1
  399. enddo
  400. else
  401. mlree1=ipalb(lg1,7)
  402. segact,mlree1
  403. endif
  404. endif
  405. enddo
  406. cbp fin du cas particulier ou IPALB contient un listreel a activer
  407.  
  408. * MTPHI
  409. segini MTPHI
  410. do lu1 = 1,nsb
  411. do lu2 = 1,nplsb
  412. do lu3 = 1,na2
  413. do lu4 = 1,idimb
  414. jjr = jjr + 1
  415. xphilb(lu1,lu2,lu3,lu4) = prog(jjr)
  416. enddo
  417. enddo
  418. enddo
  419. enddo
  420. do lg1=1,nplb
  421. jje = jje + 1
  422. ibasb(lg1) = lect(jje)
  423. enddo
  424. do lg1=1,nplb
  425. jje = jje + 1
  426. iplsb(lg1) = lect(jje)
  427. enddo
  428. do lg1=1,nsb
  429. jje = jje + 1
  430. inmsb(lg1) = lect(jje)
  431. enddo
  432. do lg1=1,nsb
  433. jje = jje + 1
  434. iorsb(lg1) = lect(jje)
  435. enddo
  436. do lg1=1,nsb
  437. jje = jje + 1
  438. iarota(lg1) = lect(jje)
  439. enddo
  440. * MTFEX
  441. NPFEXA = q1(/1)
  442. NPFEXB = 0
  443. segini MTFEX
  444. do lu1 = 1,nplb
  445. do lu2 = 1,npc1
  446. do lu3 = 1,2
  447. do lu4 = 1,idimb
  448. jjr = jjr + 1
  449. fexpsm(lu1,lu2,lu3,lu4) = prog(jjr)
  450. enddo
  451. enddo
  452. enddo
  453. enddo
  454. do lu1 = 1,npfexa
  455. jjr = jjr + 1
  456. fexa(lu1,1,1) = prog(jjr)
  457. enddo
  458. * LOCLFA
  459. segini loclfa
  460. c do lu1 = 1,na1
  461. c do lu2 = 1,4
  462. c jjr = jjr + 1
  463. c prog(jjr) = ftest(lu1,lu2)
  464. c enddo
  465. c enddo
  466. c do lu1 = 1,na1
  467. c do lu2 = 1,4
  468. c jjr = jjr + 1
  469. c prog(jjr) = ftota0(lu1,lu2)
  470. c enddo
  471. c enddo
  472. *LOCLB1
  473. segini loclb1
  474. do lu1 = 1,nplb
  475. do lu2 = 1,6
  476. jjr = jjr + 1
  477. ftest2(lu1,lu2) = prog(jjr)
  478. enddo
  479. enddo
  480. do lu1 = 1,nplb
  481. do lu2 = 1,6
  482. jjr = jjr + 1
  483. ftotb0(lu1,lu2) = prog(jjr)
  484. enddo
  485. enddo
  486.  
  487. KTRES = MTRES
  488. KPREF = MPREF
  489. SEGINI,MSAM
  490. KSAM=MSAM
  491. DO 100 IP=1,NPLB
  492. JPLIBB(IP)=JPLIB(IP)
  493. 100 CONTINUE
  494. itkm = 0
  495. jtmail = itmail
  496. JTRES = KTRES
  497. JPREF = KPREF
  498. NLIAA = ilpola(/1)
  499. NXPALA = 1
  500. NIPALA=3
  501. NPLAA = 0
  502. NPLA = 0
  503. segini MTLIAA
  504. ktliaa = mtliaa
  505. CALL DYNE17(1,ITKM,jtmail,JTRES,JPREF,NPLAA,NXPALA,KSAM,lmodyn)
  506. IF (IERR.NE.0) RETURN
  507. MSAM=KSAM
  508. SEGSUP,MSAM
  509.  
  510. ELSE
  511. * 1er pas
  512.  
  513. i2MAX = 0
  514. MTQ = ktq
  515. MTPHI = ktphi
  516. do istru=1,nsstru
  517. if(iarota(istru).ne.0) rigide = .true.
  518. enddo
  519. MTLIAB = ktliab
  520. c NSB = XPHILB(/1)
  521. NPLSB = XPHILB(/2)
  522. c NA2 = XPHILB(/3)
  523. c IDIMB = XPHILB(/4)
  524. c NPLB = JPLIB(/1)
  525. NA1 = nndefo
  526. segini loclfa
  527. KOCLFA = loclfa
  528. segini loclb1
  529. KOCLB1 = loclb1
  530. NPAS = 0
  531.  
  532. MTRES = KTRES
  533. ITINIT = 0
  534. REPRIS = .false.
  535. JKCPR = kcpr
  536. NLIAA = ilpola(/1)
  537. NXPALA = 1
  538. NIPALA=3
  539. NPLAA = 0
  540. NPLA = 0
  541. segini MTLIAA
  542. ktliaa = mtliaa
  543. * voir comalo
  544. NTVAR = 6 + 4 * IDIM
  545. * segini mtpas
  546. if (JLIAIB.eq.1) then
  547. segini MTPAS
  548. ktpas = mtpas
  549. else
  550. mtpas = ktpas
  551. endif
  552. JKTPAS = ktpas
  553. NPFEXA = q1(/1)
  554. NPFEXB = 0
  555. SEGINI MTFEX
  556. KTFEX = MTFEX
  557. JKTLIAB = ktliab
  558. JKTQ = ktq
  559. JKTPHI = ktphi
  560. JKTKAM = KTKAM
  561. * kich : permet d'initialiser mais inexact
  562. CALL DEVINI(ITINIT,JKTKAM,JKTQ,KTFEX,JKTPAS,KTNUM,KTLIAA,JKTLIAB,
  563. & JKTPHI,JKCPR,KOCLFA,KOCLB1,REPRIS,RIGIDE,lmodyn)
  564.  
  565. * segsup mtfex
  566. ENDIF
  567.  
  568. IVINIT = 0
  569. * SEGINI MTFEX
  570. KTFEX = MTFEX
  571.  
  572. nliady = nliab + nliaa
  573.  
  574. c NLIAB = IPALB(/1)
  575.  
  576. NPAS = NPAS + 1
  577. NPASF = 1
  578.  
  579. do istru=1,nsstru
  580. if(iarota(istru).ne.0) rigide = .true.
  581. enddo
  582.  
  583. c calculs en 2 demi-pas Runge-Kutta/ initialisation pour 1ere liaison
  584. do kna =1,na1
  585. IF(JLIAIB.eq.1) THEN
  586. *voir devfxa
  587. * fexa(kna,1,1) = q3(kna,2)
  588.  
  589. * q1(kna,3) = q1(kna,2)
  590. q1(kna,2) = (q1(kna,1) + q1(kna,2))* 0.5d0
  591. * q2(kna,3) = q2(kna,2)
  592. ftota(kna,2) = q3(kna,2)
  593. ftota(kna,1) = q3(kna,2)
  594. ENDIF
  595.  
  596. q2(kna,1) = 0.d0
  597. q2(kna,2) = 0.d0
  598. enddo
  599.  
  600. ** voir devpas.eso
  601. DO III = 2,1,-1
  602.  
  603. PDT=XDT(npasf)
  604. T=XTEMPS(npasf)
  605.  
  606. ** Ajout des forces de raideur avant demi-pas
  607. IF(JLIAIB.eq.1) THEN
  608. CALL DEVLK0(Q1,XK,FTOTA,NA1,1,III)
  609. ENDIF
  610. *
  611.  
  612. * forces liaisons base A (modes)
  613.  
  614. IF (NLIAA.NE.0) THEN
  615. CALL DEVLFA(Q1,Q2,FTOTA,NA1,IPALA,IPLIA,XPALA,XVALA,
  616. & NLIAA,PDT,T,npasf,III,FINERT,IVINIT,FTEST,FTOTA0)
  617. ENDIF
  618. *
  619. *
  620. * Ajout des forces de liaison base B matérielle
  621. *
  622. IF (NLIAB.NE.0) THEN
  623. CALL DEVLFB(Q1,FTOTA,NA1,IPALB,IPLIB,XPALB,XVALB,NLIAB,
  624. & XPHILB,JPLIB,NPLB,IDIMB,FTOTB,FTOTBA,XPTB,PDT,T,
  625. & npasf,IBASB,IPLSB,INMSB,IORSB,NSB,NPLSB,NA2,III,
  626. & FEXPSM,NPC1,IERRD,FTEST2,FTOTB0,
  627. & XABSCI,XORDON,NIP,FEXB,RIGIDE,IAROTA,XCHPFB)
  628. IF (IERRD.NE.0) RETURN
  629. ENDIF
  630. IF(JLIAIB.eq.nliady) THEN
  631. if (III.eq.2) then
  632. if (npas.eq.1) then
  633. do jj = 1,na1
  634. ftota(jj,3) = ftota(jj,2)
  635. enddo
  636. endif
  637. CALL DEVEQ2(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT)
  638. else
  639. CALL DEVEQ4(Q2,NA1,XASM,XM,PDT,npasf,FTOTA,FINERT)
  640. endif
  641. ENDIF
  642.  
  643. ENDDO
  644.  
  645. * CALL DYNE16(Q1,Q2,Q3,NA1,FTOTA,XPTB,NPLB,IDIMB,FINERT)
  646. DO 10 I=1,NA1
  647. FINERT(I,3) = FINERT(I,1)
  648. FINERT(I,4) = FINERT(I,2)
  649. FTOTA(I,3) = FTOTA(I,1)
  650. FTOTA(I,4) = FTOTA(I,2)
  651. 10 CONTINUE
  652. DO 20 IP = 1,NPLB
  653. DO 22 ID = 1,IDIMB
  654. XPTB(IP,3,ID) = XPTB(IP,1,ID)
  655. XPTB(IP,4,ID) = XPTB(IP,2,ID)
  656. 22 CONTINUE
  657. 20 CONTINUE
  658. *
  659. * calcul des travaux
  660. * fin devpas.eso
  661.  
  662. *
  663. * production chpoint forces base A (devso2)
  664. *
  665. meleme = itmail
  666. segact meleme
  667. if (lisous(/1).eq.0) then
  668. ipmmod = itmail
  669. ipmsta = 0
  670. else
  671. ipmmod = lisous(1)
  672. ipmsta = lisous(2)
  673. endif
  674.  
  675. NSOUPO = 1
  676. if(ipmmod.gt.0.and.ipmsta.gt.0) nsoupo = 2
  677. NAT=1
  678. SEGINI,MCHPOI
  679. IPCHPO = MCHPOI
  680. MTYPOI = 'FLIAISONS'
  681. IFOPOI = IFOUR
  682. * nature diffuse
  683. JATTRI(1) = 1
  684. nmost0 = 0
  685. KIPCHP = 0
  686.  
  687. icoe1 = 1
  688. ymaxf = 0.d0
  689. if (CMATE.eq.'PO_CE_MO') then
  690. if (i2max.ne.0) then
  691. if (FTOTBA(abs(i2max))*i2max.lt.0.) icoe1 = -1
  692. endif
  693. endif
  694.  
  695. if (ipmmod.gt.0) then
  696. NC = 1
  697. IF(JLIAIB.eq.nliady) NC = 2
  698. SEGINI,MSOUPO
  699. KIPCHP = KIPCHP + 1
  700. IPCHP(KIPCHP) = MSOUPO
  701. NOCOMP(1) = 'FALF'
  702. NOHARM(1) = NIFOUR
  703. if (NC.eq.2) then
  704. NOCOMP(2) = NOCOMP(1)
  705. NOCOMP(2)(1:1) = 'V'
  706. NOHARM(2) = NIFOUR
  707. endif
  708. IGEOC = ipmmod
  709. ipt1 = ipmmod
  710. segact ipt1
  711. N = ipt1.num(/2)
  712. nmost0 = N
  713. SEGINI,MPOVAL
  714. IPOVAL = MPOVAL
  715. *
  716. do ii = 1,N
  717. if (i2max.eq.0) then
  718. if (abs(FTOTBA(ii)).gt.ymaxf) then
  719. ymaxf = abs(FTOTBA(ii))
  720. i2max = ii
  721. if (FTOTBA(ii).lt.0) i2max = -1*i2max
  722. endif
  723. endif
  724. vpocha(ii,1) = -1*icoe1*FTOTBA(ii)
  725. if (NC.eq.2) vpocha(ii,2) = q2(ii,1)
  726. enddo
  727.  
  728. SEGDES,MPOVAL,MSOUPO
  729. endif
  730.  
  731. *kich : extension a tout hasard
  732. if (ipmsta.gt.0) then
  733. NC = 1
  734. IF(JLIAIB.eq.nliady) NC = 2
  735. SEGINI,MSOUPO
  736. KIPCHP = KIPCHP + 1
  737. IPCHP(KIPCHP) = MSOUPO
  738. NOCOMP(1) = 'FBET'
  739. NOHARM(1) = NIFOUR
  740. if (NC.eq.2) then
  741. NOCOMP(2) = NOCOMP(1)
  742. NOCOMP(2)(1:1) = 'V'
  743. NOHARM(2) = NIFOUR
  744. endif
  745. IGEOC = ipmsta
  746. ipt1 = ipmsta
  747. segact ipt1
  748. N = ipt1.num(/2)
  749. SEGINI,MPOVAL
  750. IPOVAL = MPOVAL
  751. *
  752. do ii = 1,N
  753. vpocha(ii,1) = -1*icoe1*FTOTBA(ii + nmost0)
  754. if (NC.eq.2) vpocha(ii,2) = q2(ii,1)
  755. enddo
  756.  
  757. SEGDES,MPOVAL,MSOUPO
  758. endif
  759.  
  760. segdes MCHPOI
  761. varf(1) = IPCHPO
  762. MTRES = KTRES
  763. *
  764. NINS = 1
  765. NRES = XRES(/1)
  766. NCRES = XRES(/2)
  767. NPRES = XRES(/3)
  768. NREP = XREP(/1)
  769. NLSA = XRESLA(/1)
  770. NLSB = XRESLB(/1)
  771. NVES = ICHRES(/1)
  772. NVALA = IPLRLA(/2)
  773. NVALB = IPLRLB(/2)
  774. *
  775. if (npas.eq.1) then
  776. iins2 = 2
  777. else
  778. iins2 = 1
  779. endif
  780. * range les resultats de la bonne liaison
  781. if (jliaib.gt.1) then
  782. do lu3 = 1,ntvar
  783. xvalb(1,1,lu3)=xvalb(jliaib,1,lu3)
  784. enddo
  785. * DO IP=1,NPLB
  786. * DO ID=1,2
  787. * II = II + 1
  788. * XCHPFB(ID,IIL,1,IP) = XCHPFB(ID,jliaib,1,IP)
  789. * ENDDO
  790. * ENDDO
  791. endif
  792.  
  793. * transit resultat
  794. CALL DEVTR1(Q1,Q2,Q3,NA1,IINS2,NINS,FTOTA,XRES,ICHRES,NRES,
  795. & NCRES,NPRES,XREP,NREP,XVALA,INULA,NLIAA,NLSA,
  796. & XRESLA,XVALB,INULB,NLIAB,NLSB,XRESLB,ILIREA,ILIREB,
  797. & NTVAR,XPALB,IPALB,XMREP,IMREP,IDIMB,WEXT,WINT,
  798. & XCHPFB,NPLB)
  799.  
  800. * sauvegarde pour aller plus vite pas suivant
  801. *
  802. JG = 1000
  803. jje = 0
  804. segini MLENTI
  805. jje = jje + 1
  806. lect(jje) = JLIAIB
  807. nchain = 0
  808. mlent3 = ichain
  809. segact mlent3
  810. nchain = mlent3.lect(/1)
  811. jje = jje + 1
  812. lect(jje) = nchain
  813. do lg = 1,nchain
  814. jje = jje + 1
  815. lect(jje)=mlent3.lect(lg)
  816. enddo
  817. jje = jje + 1
  818. lect(jje) = NPAS
  819. jje = jje + 1
  820. lect(jje) = NIPALB
  821. jje = jje + 1
  822. lect(jje) = NXPALB
  823. jje = jje + 1
  824. lect(jje) = NPLBB
  825. jje = jje + 1
  826. lect(jje) = NPLB
  827. jje = jje + 1
  828. lect(jje) = NPLSB
  829. jje = jje + 1
  830. lect(jje) = NIP
  831. jje = jje + 1
  832. lect(jje) = nsstru
  833. jje = jje + 1
  834. lect(jje) = nndefo
  835. jje = jje + 1
  836. lect(jje) = nliab
  837. jje = jje + 1
  838. lect(jje) = nsb
  839. jje = jje + 1
  840. lect(jje) = na2
  841. jje = jje + 1
  842. lect(jje) = idimb
  843. jje = jje + 1
  844. lect(jje) = NTVAR
  845. jje = jje + 1
  846. lect(jje) = NLIAA
  847. jje = jje + 1
  848. lect(jje) = NRES
  849. jje = jje + 1
  850. lect(jje) = NCRES
  851. jje = jje + 1
  852. lect(jje) = NPRES
  853. jje = jje + 1
  854. lect(jje) = NREP
  855. jje = jje + 1
  856. lect(jje) = NLSA
  857. jje = jje + 1
  858. lect(jje) = NVALA
  859. jje = jje + 1
  860. lect(jje) = NLSB
  861. jje = jje + 1
  862. lect(jje) = NVALB
  863. jje = jje + 1
  864. lect(jje) = NVES
  865. jje = jje + 1
  866. lect(jje) = i2MAX
  867.  
  868. * MTRES
  869. do lg1 = 1,NVES
  870. jje = jje + 1
  871. lect(jje) = ichres(lg1)
  872. enddo
  873. do lg1 = 1,NLSA
  874. jje = jje + 1
  875. lect(jje) = ipola(lg1)
  876. enddo
  877. do lg1 = 1,NLSA
  878. jje = jje + 1
  879. lect(jje) = inula(lg1)
  880. enddo
  881. do lg1 = 1,NLSB
  882. jje = jje + 1
  883. lect(jje) = ipolb(lg1)
  884. enddo
  885. do lg1 = 1,NLSB
  886. jje = jje + 1
  887. lect(jje) = inulb(lg1)
  888. enddo
  889. do lg1 = 1,nlsa
  890. do lg2 = 1,ntvar
  891. jje = jje + 1
  892. lect(jje)= ilirea(lg1,lg2)
  893. enddo
  894. enddo
  895. do lg1 = 1,nlsa
  896. do lg2 = 1,ntvar
  897. jje = jje + 1
  898. lect(jje)= ilirna(lg1,lg2)
  899. enddo
  900. enddo
  901. do lg1 = 1,nlsb
  902. do lg2 = 1,ntvar
  903. jje = jje + 1
  904. lect(jje)= ilireb(lg1,lg2)
  905. enddo
  906. enddo
  907. do lg1 = 1,nlsb
  908. do lg2 = 1,ntvar
  909. jje = jje + 1
  910. lect(jje)= ilirnb(lg1,lg2)
  911. enddo
  912. enddo
  913. do lg1 = 1,nliaa
  914. do lg2 = 1,2
  915. jje = jje + 1
  916. lect(jje)= ilpola(lg1,lg2)
  917. enddo
  918. enddo
  919.  
  920. JG = (nplb*4*idimb)+(na1*4)+(nliaa*4*ntvar)+(nliab*4*ntvar)+
  921. &(nplb*2*idim)+(2*nliab*4*nplb)+(2*na1)+(na1*2*2)+
  922. &(nliab*(nxpalb+nip+nip))+(nsb*na2*nplsb*idimb)+
  923. &(nplb*npc1*2*idimb)+ npfexa +(nplb*6*2)
  924. SEGINI MLREEL
  925. jjr = 0
  926. * MTPAS
  927. do lu1 = 1,nplb
  928. do lu2 = 1, 4
  929. do lu3 = 1,idimb
  930. jjr = jjr + 1
  931. prog(jjr) = xptb(lu1,lu2,lu3)
  932. enddo
  933. enddo
  934. enddo
  935. do lu1 = 1,na1
  936. do lu2 = 1,4
  937. jjr = jjr + 1
  938. prog(jjr) = finert(lu1,lu2)
  939. enddo
  940. enddo
  941. do lu1 = 1,nliaa
  942. do lu2 = 1, 4
  943. do lu3 = 1,ntvar
  944. jjr = jjr + 1
  945. prog(jjr) = xvala(lu1,lu2,lu3)
  946. enddo
  947. enddo
  948. enddo
  949. do lu1 = 1,nliab
  950. do lu2 = 1, 4
  951. do lu3 = 1,ntvar
  952. jjr = jjr + 1
  953. prog(jjr) = xvalb(lu1,lu2,lu3)
  954. enddo
  955. enddo
  956. enddo
  957. do lu1 = 1,nplb
  958. do lu2 = 1, 2
  959. do lu3 = 1,idim
  960. jjr = jjr + 1
  961. prog(jjr) = fexb(lu1,lu2,lu3)
  962. enddo
  963. enddo
  964. enddo
  965. do lu1 = 1,2
  966. do lu2 = 1, nliab
  967. do lu3 = 1,4
  968. do lu4 = 1,nplb
  969. jjr = jjr + 1
  970. prog(jjr) = XCHPFB(lu1,lu2,lu3,lu4)
  971. enddo
  972. enddo
  973. enddo
  974. enddo
  975. do lu1 = 1,na1
  976. jjr = jjr + 1
  977. prog(jjr) = ftota(lu1,3)
  978. jjr = jjr + 1
  979. prog(jjr) = ftota(lu1,4)
  980. enddo
  981. * MTQ
  982. do lu1 = 1,na1
  983. do lu2 = 1,2
  984. jjr = jjr + 1
  985. prog(jjr) = wext(lu1,lu2)
  986. enddo
  987. enddo
  988. do lu1 = 1,na1
  989. do lu2 = 1,2
  990. jjr = jjr + 1
  991. prog(jjr) = wint(lu1,lu2)
  992. enddo
  993. enddo
  994. * MTLIAB
  995. do lu1 = 1,nliab
  996. do lu2 = 1,nxpalb
  997. jjr = jjr + 1
  998. prog(jjr) = xpalb(lu1,lu2)
  999. enddo
  1000. enddo
  1001. do lu1 = 1,nliab
  1002. do lu2 = 1,nip
  1003. jjr = jjr + 1
  1004. prog(jjr) = xabsci(lu1,lu2)
  1005. enddo
  1006. enddo
  1007. do lu1 = 1,nliab
  1008. do lu2 = 1,nip
  1009. jjr = jjr + 1
  1010. prog(jjr) = xordon(lu1,lu2)
  1011. enddo
  1012. enddo
  1013. do lg1 = 1,nliab
  1014. do lg2 = 1,nipalb
  1015. jje = jje + 1
  1016. lect(jje)= ipalb(lg1,lg2)
  1017. enddo
  1018. enddo
  1019. do lg1 = 1,nliab
  1020. do lg2 = 1,nplbb
  1021. jje = jje + 1
  1022. lect(jje)= iplib(lg1,lg2)
  1023. enddo
  1024. enddo
  1025. do lg1=1,nplb
  1026. jje = jje + 1
  1027. lect(jje)= jplib(lg1)
  1028. enddo
  1029. * MTPHI
  1030. do lu1 = 1,nsb
  1031. do lu2 = 1,nplsb
  1032. do lu3 = 1,na2
  1033. do lu4 = 1,idimb
  1034. jjr = jjr + 1
  1035. prog(jjr) = xphilb(lu1,lu2,lu3,lu4)
  1036. enddo
  1037. enddo
  1038. enddo
  1039. enddo
  1040. do lg1=1,nplb
  1041. jje = jje + 1
  1042. lect(jje)= ibasb(lg1)
  1043. enddo
  1044. do lg1=1,nplb
  1045. jje = jje + 1
  1046. lect(jje)= iplsb(lg1)
  1047. enddo
  1048. do lg1=1,nsb
  1049. jje = jje + 1
  1050. lect(jje)= inmsb(lg1)
  1051. enddo
  1052. do lg1=1,nsb
  1053. jje = jje + 1
  1054. lect(jje)= iorsb(lg1)
  1055. enddo
  1056. do lg1=1,nsb
  1057. jje = jje + 1
  1058. lect(jje)= iarota(lg1)
  1059. enddo
  1060. * MTFEX
  1061. do lu1 = 1,nplb
  1062. do lu2 = 1,npc1
  1063. do lu3 = 1,2
  1064. do lu4 = 1,idimb
  1065. jjr = jjr + 1
  1066. prog(jjr) = fexpsm(lu1,lu2,lu3,lu4)
  1067. enddo
  1068. enddo
  1069. enddo
  1070. enddo
  1071. do lu1 = 1,npfexa
  1072. jjr = jjr + 1
  1073. prog(jjr) = fexa(lu1,1,1)
  1074. enddo
  1075. * LOCLFA
  1076. c do lu1 = 1,na1
  1077. c do lu2 = 1,4
  1078. c jjr = jjr + 1
  1079. c prog(jjr) = ftest(lu1,lu2)
  1080. c enddo
  1081. c enddo
  1082. c do lu1 = 1,na1
  1083. c do lu2 = 1,4
  1084. c jjr = jjr + 1
  1085. c prog(jjr) = ftota0(lu1,lu2)
  1086. c enddo
  1087. c enddo
  1088. *LOCLB1
  1089. do lu1 = 1,nplb
  1090. do lu2 = 1,6
  1091. jjr = jjr + 1
  1092. prog(jjr) = ftest2(lu1,lu2)
  1093. enddo
  1094. enddo
  1095. do lu1 = 1,nplb
  1096. do lu2 = 1,6
  1097. jjr = jjr + 1
  1098. prog(jjr) = ftotb0(lu1,lu2)
  1099. enddo
  1100. enddo
  1101.  
  1102. JG = jjr
  1103. segadj mlreel
  1104. varf(4) = mlreel
  1105. JG = JJE
  1106. segadj mlenti
  1107. varf(3) = mlenti
  1108. varf(5) = itmail
  1109. segdes mlreel,mlenti
  1110. *
  1111. JKTLIAB= mtliab
  1112. JKTPHI = mtphi
  1113. JKTQ = mtq
  1114. JKTRES = ktres
  1115. JKOCLFA = LOCLFA
  1116. JKOCLB1 = LOCLB1
  1117. JKTNUM = mtnum
  1118. JKTFEX = mtfex
  1119. JKPREF = mpref
  1120. JKTLIAA = 0
  1121. JKTKAM = 0
  1122. JKTPAS = mtpas
  1123. IPMAIL = itmail
  1124. JMAILz = itmail
  1125. REPRIS = .false.
  1126. lmodyn = .true.
  1127. jchain = ichain
  1128.  
  1129. call crtabl(its2)
  1130. ITDYN = its2
  1131. CALL DEVSO5(JKPREF,JKTQ,JKTKAM,JKTPHI,JKTLIAA,JKTLIAB,JKTFEX,
  1132. & JKTPAS,JKTRES,JKTNUM,NINS,JMAILz,REPRIS,JCHAIN,
  1133. & JKOCLFA,JKOCLB1,LMODYN,ITDYN)
  1134. if (ierr.ne.0) return
  1135.  
  1136. if (itdyn.gt.0) varf(2) = itdyn
  1137.  
  1138. IF(JLIAIB.eq.nliady) then
  1139. SEGSUP,MPREF
  1140. segsup,MTQ
  1141. SEGSUP,MTKAM
  1142. SEGSUP,MTPAS
  1143. ENDIF
  1144.  
  1145. SEGSUP MTFEX
  1146. segsup mtnum
  1147. *
  1148. SEGSUP,MTPHI
  1149. SEGSUP,MTLIAB
  1150. SEGSUP,MTLIAA
  1151. SEGSUP,MTRES
  1152. SEGSUP,LOCLFA
  1153. SEGSUP,LOCLB1
  1154. if (npas.eq.1.and.jliaib.lt.nliady) then
  1155. mlent3 = ichain
  1156. segsup mlent3
  1157. endif
  1158.  
  1159. ichain = jchain
  1160.  
  1161. RETURN
  1162. END
  1163.  
  1164.  
  1165.  
  1166.  
  1167.  
  1168.  
  1169.  
  1170.  
  1171.  
  1172.  
  1173.  
  1174.  
  1175.  
  1176.  

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