Télécharger coml10.eso

Retour à la liste

Numérotation des lignes :

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

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