Télécharger devalo.eso

Retour à la liste

Numérotation des lignes :

  1. C DEVALO SOURCE BP208322 18/01/30 21:15:12 9719
  2. SUBROUTINE DEVALO(ITBAS,ITKM,ITA,ITLIA,ITCHAR,ITINIT,NP,PDT,NINS,
  3. & ITSORT,ITREDU,KPREF,KTQ,KTKAM,KTPHI,KTLIAA,
  4. & KTLIAB,KTFEX,KTPAS,KTRES,KTNUM,IPMAIL,REPRIS,
  5. & ICHAIN,KOCLFA,KOCLB1,ITCARA,LMODYN)
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8(A-H,O-Z)
  8. *--------------------------------------------------------------------*
  9. * *
  10. * Operateur DYNE : algorithme de Fu - de Vogelaere *
  11. * ________________________________________________ *
  12. * *
  13. * Dimensionnement des tableaux de travail ( allocation de la *
  14. * memoire ). *
  15. * *
  16. * Parametres: *
  17. * *
  18. * e ITBAS Table representant une base modale *
  19. * e ITKM Table contenant les matrices XK et XM *
  20. * e ITA Table contenant la matrice XASM *
  21. * e ITLIA Table rassemblant la description des liaisons *
  22. * e ITCHAR Table contenant les chargements *
  23. * e ITINIT Table donnant les conditions initiales *
  24. * e NP Nombre de pas de calcul *
  25. * e PDT Valeur du pas de temps *
  26. * e NINS On veut une sortie tous les NINS pas de calcul *
  27. * e ITSORT Table definissant les resultats attendus *
  28. * e ITREDU Table contenant les noms d'inconnues de la base B *
  29. * auxquelles on se restreint *
  30. * e KPREF Segment des points de reference *
  31. * s MTQ Segment contenant les variables generalisees *
  32. * (et les travaux)
  33. * s MTKAM Segment contenant les vecteurs XK, XASM et XM *
  34. * s MTPHI Segment contenant les deformees modales *
  35. * s MTLIAA Segment descriptif des liaisons en base A *
  36. * s MTLIAB Segment descriptif des liaisons en base B *
  37. * s MTFEX Segment contenant les chargements libres *
  38. * s MTPAS Segment des variables au cours d'un pas de temps *
  39. * s MTRES Segment de sauvegarde des resultats *
  40. * s MTNUM Segment contenant les parametres temporels *
  41. * s IPMAIL Maillage de reference pour les CHPOINTs resultats *
  42. * s REPRIS Vrai si reprise de calcul, faux sinon *
  43. * s ICHAIN Segment MLENTI (ACTIF) contenant les adresses des *
  44. * chaines dans la pile des mots de CCNOYAU *
  45. * s KOCLFA Segment contenant les tableaux locaux de la subroutine *
  46. * DEVLFA *
  47. * s KOCLB1 Segment contenant les tableaux locaux de la subroutine *
  48. * DEVLB1 *
  49. * *
  50. * Auteur, date de creation: *
  51. * *
  52. * Denis ROBERT-MOUGIN, le 25 mai 1989. *
  53. * NTRA passe a 10000 le 28/1/93 par D. R. *
  54. *--------------------------------------------------------------------*
  55. -INC CCOPTIO
  56. -INC SMCOORD
  57. -INC SMMODEL
  58. -INC SMELEME
  59. -INC SMCHAML
  60. -INC SMLENTI
  61. *
  62. * Segment des variables generalisees:
  63. *
  64. SEGMENT,MTQ
  65. REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4)
  66. REAL*8 WEXT(NA1,2),WINT(NA1,2)
  67. ENDSEGMENT
  68. *
  69. * Segment contenant les matrices XK, XASM et XM:
  70. *
  71. SEGMENT,MTKAM
  72. REAL*8 XK(NA1,NB1K),XASM(NA1,NB1C),XM(NA1,NB1M)
  73. REAL*8 XOPER(NB1,NB1,NOPER)
  74. ENDSEGMENT
  75. *
  76. * Segment des deformees modales:
  77. *
  78. SEGMENT,MTPHI
  79. INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
  80. INTEGER IAROTA(NSB)
  81. REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
  82. ENDSEGMENT
  83. *
  84. * Segment descriptif des liaisons en base A:
  85. *
  86. SEGMENT,MTLIAA
  87. INTEGER IPALA(NLIAA,NIPALA),IPLIA(NLIAA,NPLAA),JPLIA(NPLA)
  88. REAL*8 XPALA(NLIAA,NXPALA)
  89. ENDSEGMENT
  90. *
  91. * Segment descriptif des liaisons en base B:
  92. *
  93. SEGMENT MTLIAB
  94. INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
  95. REAL*8 XPALB(NLIAB,NXPALB)
  96. REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
  97. ENDSEGMENT
  98. *
  99. * Segment representant les chargements libres:
  100. *
  101. SEGMENT,MTFEX
  102. REAL*8 FEXA(NPFEXA,NPC1,2)
  103. REAL*8 FEXPSM(NPLB,NPC1,2,IDIMB)
  104. REAL*8 FTEXB(NPLB,NPC1,2,IDIM)
  105. INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
  106. ENDSEGMENT
  107. *
  108. * Segment contenant les variables au cours d'un pas de temps:
  109. *
  110. SEGMENT,MTPAS
  111. REAL*8 FTOTA(NA1,4),FTOTB(NPLB,IDIMB),FTOTBA(NA1)
  112. REAL*8 XPTB(NPLB,4,IDIMB),FINERT(NA1,4)
  113. REAL*8 XVALA(NLIAA,4,NTVAR),XVALB(NLIAB,4,NTVAR)
  114. REAL*8 FEXB(NPLB,2,IDIM),XCHPFB(2,NLIAB,4,NPLB)
  115. ENDSEGMENT
  116. *
  117. * Segment de sauvegarde des resultats (active dans DYNE15) :
  118. *
  119. SEGMENT,MTRES
  120. REAL*8 XRES(NRES,NCRES,NPRES),XREP(NREP,NCRES)
  121. REAL*8 XRESLA(NLSA,NPRES,NVALA),XRESLB(NLSB,NPRES,NVALB)
  122. REAL*8 XMREP(NLIAB,4,IDIMB)
  123. INTEGER ICHRES(NVES),IPORES(NRESPO,NPRES),IPOREP(NREP)
  124. INTEGER ILIRES(NRESLI,NCRES)
  125. INTEGER IPOLA(NLSA),INULA(NLSA),IPLRLA(NLSA,NVALA)
  126. INTEGER IPOLB(NLSB),INULB(NLSB),IPLRLB(NLSB,NVALB)
  127. INTEGER ILIREA(NLSA,NTVAR),ILIREB(NLSB,NTVAR)
  128. INTEGER ILIRNA(NLSA,NTVAR),ILIRNB(NLSB,NTVAR)
  129. INTEGER IPOLR(1),IMREP(NLIAB,2),IPPREP(NLIAB,4)
  130. INTEGER ILPOLA(NLIAA,2)
  131. ENDSEGMENT
  132. *
  133. * Segment contenant les parametres temporels:
  134. *
  135. SEGMENT,MTNUM
  136. REAL*8 XDT(NPC1),XTEMPS(NPC1)
  137. ENDSEGMENT
  138. *
  139. * Segment des points de reference:
  140. *
  141. SEGMENT,MPREF
  142. INTEGER IPOREF(NPREF)
  143. ENDSEGMENT
  144. *
  145. * Segment de points
  146. *
  147. SEGMENT,NCPR(XCOOR(/1)/(IDIM+1))
  148. *
  149. * Segment de travail pour reprise force POLYNOMIALE base A
  150. *
  151. SEGMENT,MTRA
  152. INTEGER IPLA(NTRA)
  153. ENDSEGMENT
  154. *
  155. * Segment "local" pour DEVLFA ...
  156. SEGMENT,LOCLFA
  157. REAL*8 FTEST(NA1,4),FTOTA0(NA1,4)
  158. ENDSEGMENT
  159. * Segment "local" pour DEVLB1 ...
  160. SEGMENT,LOCLB1
  161. REAL*8 FTEST2(NPLB,6),FTOTB0(NPLB,6)
  162. ENDSEGMENT
  163. * Segment pour Champoints
  164. SEGMENT,MSAM
  165. integer jplibb(NPLB)
  166. ENDSEGMENT
  167. * segment chapeau modeles liaisons
  168. SEGMENT MOLIAI
  169. integer modtla,modtlb
  170. ENDSEGMENT
  171. *
  172. segment mwinit
  173. integer jpdep,jpvit,jrepr
  174. endsegment
  175. segment mtbas
  176. integer itbmod,lsstru(np1),nsstru
  177. endsegment
  178. segment icma(0)
  179. segment icnna2(0)
  180. LOGICAL L0,L1,REPRIS,LMODYN
  181. CHARACTER*6 MO2
  182. CHARACTER*8 TYPRET,CHARRE
  183. CHARACTER*10 MO1
  184. CHARACTER*40 MONMOT
  185. *
  186. ITREP = 0
  187. MTQ = 0
  188. MTKAM = 0
  189. MTPHI = 0
  190. MTLIAA = 0
  191. MTLIAB = 0
  192. MTFEX = 0
  193. MTPAS = 0
  194. MTRES = 0
  195. MTNUM = 0
  196. MTRA = 0
  197. XTINI = 0.D0
  198. ITLA = 0
  199. ITLB = 0
  200. REPRIS = .FALSE.
  201. *
  202. ************************************************************************
  203. * On recupere le cas echeant, le temps de reprise:
  204. ************************************************************************
  205. *
  206. IF (ITINIT.NE.0) THEN
  207. if (lmodyn) then
  208. mwinit = itinit
  209. segact mwinit
  210. if (jrepr.gt.0) then
  211. itrep = jrepr
  212. REPRIS = .TRUE.
  213. CALL ACCTAB(ITREP,'MOT',I0,X0,'TEMPS_DE_REPRISE',L0,IP0,
  214. & 'FLOTTANT',I1,XTINI,CHARRE,L1,IP1)
  215. IF (IERR.NE.0) RETURN
  216. endif
  217. else
  218. TYPRET = ' '
  219. CALL ACCTAB(ITINIT,'MOT',I0,X0,'REPRISE',L0,IP0,
  220. & TYPRET,I1,X1,CHARRE,L1,ITREP)
  221. IF (IERR.NE.0) RETURN
  222. IF (ITREP.NE.0) THEN
  223. IF (TYPRET.EQ.'TABLE ') THEN
  224. REPRIS = .TRUE.
  225. CALL ACCTAB(ITREP,'MOT',I0,X0,'TEMPS_DE_REPRISE',L0,IP0,
  226. & 'FLOTTANT',I1,XTINI,CHARRE,L1,IP1)
  227. IF (IERR.NE.0) RETURN
  228. ELSE
  229. CALL ERREUR(487)
  230. RETURN
  231. ENDIF
  232. ENDIF
  233. endif
  234. ENDIF
  235. IF (IIMPI.EQ.333) write(ioimp,*)'devalo: TEMPS_DE_REPRISE=',XTINI
  236. *
  237. ************************************************************************
  238. * Parametres temporels: pas de temps constant
  239. ************************************************************************
  240. *
  241. NPC1 = NP + 1
  242. SEGINI,MTNUM
  243. KTNUM = MTNUM
  244. XDT(1) = PDT
  245. XTEMPS(1) = XTINI
  246. DO 10 I = 2,NPC1
  247. XDT(I) = PDT
  248. XTEMPS(I) = XTEMPS(I-1) + PDT
  249. 10 CONTINUE
  250. * end do
  251. *
  252. ************************************************************************
  253. * Recherche du nombre de modes: autant que de points de reference
  254. ************************************************************************
  255. *
  256. MPREF = KPREF
  257. NA1 = IPOREF(/1)
  258. c on intialise NB1 a 1; le segment sera eventuellement ajuste
  259. c lors du remplissage par DEVTRA (OU D2VTRA)
  260. NB1 = 1
  261. NB1K = 1
  262. NB1C = 1
  263. NB1M = 1
  264. NOPER=0
  265. SEGINI,MTQ,MTKAM
  266. SEGINI,LOCLFA
  267. KOCLFA = LOCLFA
  268. KTQ = MTQ
  269. KTKAM = MTKAM
  270. *
  271. ************************************************************************
  272. * Gestion des segments descriptifs des liaisons
  273. ************************************************************************
  274. *
  275. NLIAA = 0
  276. NIPALA = 0
  277. NXPALA = 0
  278. NPLAA = 0
  279. NPLA = 0
  280. NLIAB = 0
  281. NIPALB = 0
  282. NXPALB = 0
  283. NIP = 0
  284. NPLBB = 0
  285. NPLB = 0
  286. NPLSB = 0
  287. IDIMB = 0
  288. NA2 = 0
  289. NSB = 0
  290. KCPR = 0
  291. NTVAR = 6 + 4 * IDIM
  292. *
  293. * MTRA indiquera la presence de liaisons POLYNOMIALEs
  294. * (on suppose un maximum de 100 liaisons en base A)
  295. *+* passe a 10000 le 28/1/93
  296. NTRA = 10000
  297. SEGINI,MTRA
  298. *
  299. IF (ITLIA.NE.0) THEN
  300. if (lmodyn) then
  301. mtbas = itbas
  302. ipbmod = itbmod
  303. call ecrcha('MAIL')
  304. call ecrobj('MMODEL',ipbmod)
  305. call extrai
  306. call lirobj('MAILLAGE',ipt1,0,iret)
  307. if (ierr.ne.0) return
  308. if (iret.ne.1) then
  309. write(6,*) 'pb developpement devalo'
  310. return
  311. endif
  312. itmail = ipt1
  313. segact ipt1
  314. segini ncpr
  315. do ie = 1,ipt1.num(/2)
  316. ncpr(ipt1.num(1,ie)) = 1
  317. enddo
  318.  
  319. mmodel = itlia
  320. segact mmodel
  321. n1 = kmodel(/1)
  322. segini mmode1,mmode2
  323. klia = 0
  324. klib = 0
  325. do ik = 1,kmodel(/1)
  326. imodel = kmodel(ik)
  327. segact imodel
  328. meleme = imamod
  329. segact meleme
  330.  
  331. if (ncpr(num(1,1)).gt.0) then
  332. klia = klia + 1
  333. mmode1.kmodel(klia) = imodel
  334. else
  335. klib = klib + 1
  336. mmode2.kmodel(klib) = imodel
  337. endif
  338.  
  339. enddo
  340. segdes mmodel
  341. n1 = klia
  342. itla = mmode1
  343. segadj mmode1
  344. n1 = klib
  345. segadj mmode2
  346. itlb = mmode2
  347. segsup ncpr
  348. segini moliai
  349. modtla = itla
  350. if (klia.eq.0) modtla = 0
  351. modtlb = itlb
  352. if (klib.eq.0) modtlb = 0
  353. * distingue liasons A et B
  354. ITLIA = MOLIAI
  355. *
  356. else
  357. *
  358. TYPRET = ' '
  359. CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_A',L0,IP0,
  360. & TYPRET,I1,X1,CHARRE,L1,ITLA)
  361. IF (IERR.NE.0) RETURN
  362. *
  363. * Liaisons sur la base A : determination des parametres
  364. *
  365. IF (ITLA.NE.0.and.(.not.lmodyn)) THEN
  366. IF (TYPRET.EQ.'TABLE ') THEN
  367. CALL DYNE21(ITLA,PDT,MTRA,KLIAA,KXPALA,KPLAA,KIPALA)
  368. IF (IERR.NE.0) RETURN
  369. NLIAA = KLIAA
  370. NIPALA = KIPALA
  371. NXPALA = KXPALA
  372. NPLAA = KPLAA
  373. NPLA = NA1
  374. ELSE
  375. CALL ERREUR(492)
  376. RETURN
  377. ENDIF
  378. ENDIF
  379. *
  380. * Liaisons sur la base B : determination des parametres
  381. *
  382. TYPRET = ' '
  383. CALL ACCTAB(ITLIA,'MOT',I0,X0,'LIAISON_B',L0,IP0,
  384. & TYPRET,I1,X1,CHARRE,L1,ITLB)
  385. IF (IERR.NE.0) RETURN
  386. IF (ITLB.NE.0.and.(.not.lmodyn)) THEN
  387. IF (TYPRET.EQ.'TABLE ') THEN
  388. CALL DYNE22(ITLB,KLIAB,KXPALB,KPLBB,KPLB,KDIMB,KCPR,
  389. & KIPALB,KNIP)
  390. IF (IERR.NE.0) RETURN
  391. NLIAB = KLIAB
  392. NIPALB = KIPALB
  393. NXPALB = KXPALB
  394. NPLBB = KPLBB
  395. NPLB = KPLB
  396. IDIMB = KDIMB
  397. NIP = KNIP
  398. ELSE
  399. CALL ERREUR(493)
  400. RETURN
  401. ENDIF
  402. ENDIF
  403. *
  404. endif
  405. *
  406. if (lmodyn.and.klia.gt.0) then
  407. CALL DYNE71(ITLA,PDT,MTRA,KLIAA,KXPALA,KPLAA,KIPALA)
  408. IF (IERR.NE.0) RETURN
  409. NLIAA = KLIAA
  410. NIPALA = KIPALA
  411. NXPALA = KXPALA
  412. NPLAA = KPLAA
  413. NPLA = NA1
  414. endif
  415. if (lmodyn.and.klib.gt.0) then
  416. CALL DYNE72(ITLB,KLIAB,KXPALB,KPLBB,KPLB,KDIMB,KCPR,
  417. & KIPALB,KNIP,ITCARA)
  418. IF (IERR.NE.0) RETURN
  419. NLIAB = KLIAB
  420. NIPALB = KIPALB
  421. NXPALB = KXPALB
  422. NPLBB = KPLBB
  423. NPLB = KPLB
  424. IDIMB = KDIMB
  425. NIP = KNIP
  426. endif
  427. ENDIF
  428. SEGINI,LOCLB1
  429. KOCLB1 = LOCLB1
  430. *
  431. * Les segments seront remplis dans le s-p DEVLIA:
  432. *
  433. SEGINI,MTLIAA
  434. SEGINI,MTLIAB
  435. KTLIAA = MTLIAA
  436. KTLIAB = MTLIAB
  437. IF (NLIAB.NE.0) THEN
  438. NCPR = KCPR
  439. LCPR = XCOOR(/1) / (IDIM + 1)
  440. IN = 0
  441. DO 20 I = 1,LCPR
  442. IF (NCPR(I).NE.0) THEN
  443. IN = IN + 1
  444. JPLIB(IN) = I
  445. ENDIF
  446. 20 CONTINUE
  447. * en do
  448. SEGSUP,NCPR
  449. ENDIF
  450. *
  451. ************************************************************************
  452. * Segment des deformees modales:
  453. ************************************************************************
  454.  
  455. ***** Cas table BASE_MODALE et RAIDEUR_ET_MASSE *****
  456.  
  457. IF (ITKM.GT.0) THEN
  458. TYPRET = ' '
  459. CALL ACCTAB(ITKM,'MOT',I0,X0,'BASE_MODALE',L0,IP0,
  460. & TYPRET,I1,X1,CHARRE,L1,ITBAS2)
  461. ELSE
  462. ITBAS2=ITBAS
  463. ENDIF
  464.  
  465. c IF (ITBAS.NE.0.and.(.not.lmodyn)) THEN
  466. IF (ITBAS2.NE.0.and.(.not.lmodyn)) THEN
  467.  
  468. CALL ACCTAB(ITBAS2,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
  469. & 'MOT',I1,X1,MONMOT,L1,IP1)
  470. IF (IERR.NE.0) RETURN
  471. IF (IIMPI.EQ.333) write(ioimp,*) ITBAS2,'de SOUSTYPE',MONMOT
  472. *
  473. * -Cas ou la base est unique
  474. IF (MONMOT(1:11).EQ.'BASE_MODALE') THEN
  475. NSB = 1
  476. NA2 = NA1
  477. * changement de dimension en cas de corps rigide
  478. CALL ACCTAB(ITBAS2,'MOT',I0,X0,'MODES',L0,IP0,
  479. & 'TABLE',I1,X1,' ',L1,IBAS)
  480. IP = 0
  481. 22 CONTINUE
  482. IP = IP + 1
  483. TYPRET = ' '
  484. CALL ACCTAB(IBAS,'ENTIER',IP,X0,' ',L0,IP0,
  485. & TYPRET,I1,X1,CHARRE,L1,ITP1)
  486. IF (IERR.NE.0) RETURN
  487. IF (TYPRET.NE.'TABLE') GOTO 23
  488. IF (ITP1.LE.0) GOTO 23
  489. TYPRET = ' '
  490. CALL ACCTAB(ITP1,'MOT',I0,X0,'CORPS_RIGIDE',L0,IP0,
  491. & TYPRET,I1,X1,MONMOT,L1,IP1)
  492. IF (IERR.NE.0) RETURN
  493. IF (TYPRET.EQ.'MOT') THEN
  494. IF (MONMOT(1:4).EQ.'VRAI') THEN
  495. if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  496. if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  497. GOTO 23
  498. ENDIF
  499. ENDIF
  500. GOTO 22
  501. 23 CONTINUE
  502.  
  503. * -Cas ou la base est un ensemble de bases
  504. ELSE
  505. IB = 0
  506. NA2 = 0
  507. * changement de dimension en cas de corps rigide
  508. IR = 0
  509. 30 CONTINUE
  510. IB = IB + 1
  511. c write(ioimp,*) IB,'ieme base de l ensemble'
  512. TYPRET = ' '
  513. CALL ACCTAB(ITBAS2,'ENTIER',IB,X0,' ',L0,IP0,
  514. & TYPRET,I1,X1,CHARRE,L1,ITBB)
  515. IF (IERR.NE.0) RETURN
  516. c --cas lecture table de la IB ieme base modale ok
  517. IF (ITBB.NE.0) THEN
  518. IF (TYPRET.EQ.'TABLE ') THEN
  519. CALL ACCTAB(ITBB,'MOT',I0,X0,'MODES',L0,IP0,
  520. & 'TABLE',I1,X1,' ',L1,IBAS)
  521. IF (IERR.NE.0) RETURN
  522. NNA2 = 0
  523. IP = 0
  524. 32 CONTINUE
  525. IP = IP + 1
  526. c write(ioimp,*) ' +',IP,'ieme mode de la ',IB,'ieme base'
  527. TYPRET = ' '
  528. CALL ACCTAB(IBAS,'ENTIER',IP,X0,' ',L0,IP0,
  529. & TYPRET,I1,X1,CHARRE,L1,ITPP)
  530. IF (IERR.NE.0) RETURN
  531. c --cas lecture table du IP ieme mode ok
  532. IF (ITPP.NE.0) THEN
  533. IF (TYPRET.EQ.'TABLE ') THEN
  534. * changement de dimension en cas de corps rigide
  535. IF (IR.GT.1) GOTO 24
  536. TYPRET = ' '
  537. CALL ACCTAB(ITPP,'MOT',I0,X0,'CORPS_RIGIDE',L0,IP0,
  538. & TYPRET,I1,X1,MONMOT,L1,IP1)
  539. IF (IERR.NE.0) RETURN
  540. IF (TYPRET.EQ.'MOT') THEN
  541. IF (MONMOT(1:4).EQ.'VRAI') THEN
  542. if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  543. if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  544. ENDIF
  545. ENDIF
  546. 24 CONTINUE
  547. NNA2 = NNA2 + 1
  548. GOTO 32
  549. c --fin du cas lecture table du IP ieme mode ok
  550. ELSE
  551. CALL ERREUR(491)
  552. RETURN
  553. ENDIF
  554. ENDIF
  555. c --fin du cas lecture table du IP ieme mode non ok
  556. NA2 = MAX(NNA2,NA2)
  557. GOTO 30
  558. c --fin du cas lecture table de la IB ieme base modale ok
  559. ELSE
  560. CALL ERREUR(491)
  561. RETURN
  562. ENDIF
  563. ENDIF
  564. c --fin du cas lecture table de la IB ieme base modale non ok
  565. NSB = IB - 1
  566. ENDIF
  567. * -fin distinction base modale simple / ensemble de bases
  568. NPLSB = NPLB
  569.  
  570.  
  571. ***** Cas table PASAPAS *****
  572.  
  573. ELSEIF (LMODYN) THEN
  574.  
  575. mchelm = itcara
  576. segact mchelm
  577. n1 = imache(/1)
  578. segini icma,icnna2
  579. mtbas = ITBAS
  580. MMODEL = ITBMOD
  581. segact MMODEL
  582. kstru = 0
  583. do im = 1,kmodel(/1)
  584. imodel = kmodel(im)
  585. segact imodel
  586. * recherche sommaire nombre de sous-structures independantes
  587. do 46 in = 1,n1
  588. meleme = imache(in)
  589. if (meleme.ne.imamod) goto 46
  590. if (conche(in).ne.conmod) goto 46
  591. segact meleme
  592. mchaml = ichaml(in)
  593. segact mchaml
  594. n2 = ielval(/1)
  595.  
  596. do io = 1,n2
  597. if (nomche(io)(1:4).eq.'CGRA') then
  598. * recherche corps rigide
  599. if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3
  600. if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6
  601. else if (nomche(io)(1:4).eq.'DEFO') then
  602. melval = ielval(io)
  603. segact melval
  604. * assume que le maillage modèle se réduit au point support
  605. icdef1 = ielche(1,1)
  606. call ecrcha('NOMU')
  607. call ecrcha('MAIL')
  608. call ecrobj('CHPOINT ',icdef1)
  609. call extrai
  610. call lirobj('MAILLAGE', icmaio,1,iret)
  611. if (ierr.ne.0) return
  612. if (kstru.eq.0) then
  613. kstru = 1
  614. icma(**)=icmaio
  615. icnna2(**)=1
  616. lsstru(im) = kstru
  617. endif
  618. if (in.gt.1) then
  619. ipt5 = icmaio
  620. do ic = 1,kstru
  621. icmic = icma(ic)
  622. CALL INTERB(icmaio,icmic,IRETIB,icinte)
  623. if (iretib.eq.0) then
  624. ipt6 = icinte
  625. segact ipt6,ipt5
  626. if (ipt5.num(/2).eq.ipt6.num(/2)) then
  627. segsup ipt6
  628. icnna2(ic) = icnna2(ic) + 1
  629. lsstru(im) = ic
  630. goto 47
  631. endif
  632. segsup ipt6
  633. endif
  634. enddo
  635. kstru = kstru + 1
  636. icma(**) = icmaio
  637. icnna2(**) = 1
  638. lsstru(im) = kstru
  639. endif
  640. goto 47
  641. endif
  642. enddo
  643. 46 continue
  644. 47 continue
  645. segdes imodel
  646. enddo
  647. NSB = icma(/1)
  648. NA2 = icnna2(1)
  649. do ic = 1,icnna2(/1)
  650. na2 = MAX(icnna2(ic),NA2)
  651. enddo
  652. nsstru = kstru
  653. segsup icma,icnna2
  654. segdes mmodel
  655. *
  656. ENDIF
  657. *
  658. * on met NPLSB a 1 car le calcul actuel est debile
  659. * on ajuste la dimension dans dyne26
  660. *
  661. * MP
  662. *
  663. NPLSB=1
  664. SEGINI,MTPHI
  665. KTPHI = MTPHI
  666. *
  667. ************************************************************************
  668. * Variables au cours d'un pas de temps:
  669. ************************************************************************
  670. *
  671. SEGINI,MTPAS
  672. KTPAS = MTPAS
  673. *
  674. ************************************************************************
  675. * Initialisation du segment representant les chargements ( bases A
  676. * et B ), il sera rempli dans le s-p DEVFX0:
  677. ************************************************************************
  678. *
  679. NPFEXA = NA1
  680. NPFEXB = 0
  681. SEGINI,MTFEX
  682. KTFEX = MTFEX
  683. *
  684. ************************************************************************
  685. * Gestion de la table definissant les resultats attendus:
  686. * ( par la suite, on s'occupera de TREDU )
  687. ************************************************************************
  688. *
  689. CALL DYNE15(ITSORT,KPREF,NA1,NP,NINS,ITLIA,KTRES,IPMAIL,REPRIS,
  690. & ICHAIN,NTVAR,NLIAA,NLIAB,NPLB,IDIMB,MTRA,ITCARA,lmodyn,
  691. & na1)
  692. IF (IERR.NE.0) RETURN
  693. MTRES = KTRES
  694. *
  695. ************************************************************************
  696. * Creation des objets resultats :
  697. ************************************************************************
  698. *
  699. SEGINI,MSAM
  700. KSAM=MSAM
  701. DO 100 IP=1,NPLB
  702. JPLIBB(IP)=JPLIB(IP)
  703. 100 CONTINUE
  704. CALL DYNE17(ITBAS,ITKM,IPMAIL,KTRES,KPREF,NPLAA,NXPALA,KSAM,
  705. & lmodyn)
  706. IF (IERR.NE.0) RETURN
  707. MSAM=KSAM
  708. SEGSUP,MSAM
  709. *
  710. ************************************************************************
  711. * Impressions :
  712. ************************************************************************
  713.  
  714. IF (IIMPI.EQ.333) THEN
  715. WRITE(IOIMP,*)'DEVALO : nombre de pas de temps ',NP
  716. WRITE(IOIMP,*)'DEVALO : temps de reprise ',XTINI
  717. *
  718. WRITE(IOIMP,*)' segment MTLIAB'
  719. WRITE(IOIMP,*)' NLIAB =',IPALB(/1)
  720. WRITE(IOIMP,*)' NIPALB =',IPALB(/2)
  721. WRITE(IOIMP,*)' NXPALB =',XPALB(/2)
  722. WRITE(IOIMP,*)' NPLBB =',IPLIB(/2)
  723. WRITE(IOIMP,*)' NPLB =',JPLIB(/1)
  724. WRITE(IOIMP,*)' NIP =',XABSCI(/2)
  725. *
  726. WRITE(IOIMP,*)' segment MTLIAA'
  727. WRITE(IOIMP,*)' NLIAA =',IPALA(/1)
  728. WRITE(IOIMP,*)' NIPALA =',IPALA(/2)
  729. WRITE(IOIMP,*)' NXPALA =',XPALA(/2)
  730. WRITE(IOIMP,*)' NPLAA =',IPLIA(/2)
  731. WRITE(IOIMP,*)' NPLA =',JPLIA(/1)
  732. *
  733. WRITE(IOIMP,*)' segment MTRES'
  734. WRITE(IOIMP,*)' NLSA =',XRESLA(/1)
  735. WRITE(IOIMP,*)' NVALA =',XRESLA(/3)
  736. WRITE(IOIMP,*)' NLSB =',XRESLB(/1)
  737. WRITE(IOIMP,*)' NVALB =',XRESLB(/3)
  738. WRITE(IOIMP,*)' NRES =',XRES(/1)
  739. WRITE(IOIMP,*)' NCRES =',XRES(/2)
  740. WRITE(IOIMP,*)' NPRES =',XRES(/3)
  741. WRITE(IOIMP,*)' NREP =',XREP(/1)
  742. WRITE(IOIMP,*)' NTVAR =',ILIREB(/2)
  743. WRITE(IOIMP,*)' NLIAB =',XMREP(/1)
  744. WRITE(IOIMP,*)' IDIMB =',XMREP(/3)
  745. WRITE(IOIMP,*)' NLIAA =',ILPOLA(/1)
  746. *
  747. WRITE(IOIMP,*)' segment MTFEX'
  748. WRITE(IOIMP,*)' NPC1 =',FEXA(/2)
  749. WRITE(IOIMP,*)' NPLB =',FEXPSM(/1)
  750. WRITE(IOIMP,*)' IDIMB =',FEXPSM(/4)
  751. WRITE(IOIMP,*)' NPFEXA =',IFEXA(/1)
  752. WRITE(IOIMP,*)' NPFEXB =',IFEXB(/1)
  753. *
  754. DO 1000 IP = 1,NPLB
  755. WRITE(IOIMP,*)'DEVALO : JPLIB(',IP,') =',JPLIB(IP)
  756. 1000 CONTINUE
  757. ENDIF
  758. *
  759. RETURN
  760. END
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  

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