Télécharger coml2.eso

Retour à la liste

Numérotation des lignes :

  1. C COML2 SOURCE PV 17/12/08 21:16:38 9660
  2.  
  3. SUBROUTINE COML2(IPMODL,IPMEL,INDESO,IRETOU)
  4.  
  5. *---------------------------------------------------------------------
  6. * coml2 : trie et boucle sur les modeles elementaires
  7. * selectionne les composantes de meme support
  8. * passe a coml6
  9. * complete les deche resultats
  10. *----------------------------------------------------------------
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8(A-H,O-Z)
  13.  
  14. -INC CCOPTIO
  15. -INC CCGEOME
  16. -INC CCHAMP
  17. -INC SMCHAML
  18. -INC SMELEME
  19. -INC SMCOORD
  20. -INC SMMODEL
  21. -INC SMINTE
  22. -INC SMLENTI
  23. * segment deroulant le mcheml
  24. -INC DECHE
  25. SEGMENT icorre
  26. integer mel2(nmel1),icor(nmel1),idej
  27. ENDSEGMENT
  28. SEGMENT INFO
  29. INTEGER INFELL(16)
  30. ENDSEGMENT
  31. segment igard(lilmel(/1))
  32. segment izozo(nzo+1)
  33. segment ipozo(lilmel(/1))
  34. segment ncop
  35. character*8 ncopi(ncopj)
  36. endsegment
  37. ** pile des deche contruits pour changer de support
  38. segment lichan(iichan)
  39. ** pile des deche pour construire le champ de caracteristiques geometriques
  40. segment licarb(iicarb)
  41. ** pile des noms de composantes a proteger
  42. segment linomp(iinomp)
  43. ** pile modeles elementaires
  44. segment limode(i100)
  45. ** segment sous-structures dynamiques
  46. segment struli
  47. integer itlia,itbmod,momoda, mostat,itmail,molia
  48. integer ldefo(np1),lcgra(np1),lsstru(np1)
  49. integer nsstru,nndefo,nliab,nsb,na2,idimb
  50. integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas
  51. INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib
  52. * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0)
  53. INTEGER ICHAIN
  54. endsegment
  55. c
  56. logical lome1,lome2,lsupca
  57.  
  58. PARAMETER (MFORMC=1, MFORMU=17, MFORMT=MFORMC+MFORMU)
  59. CHARACTER*16 LISFOR(MFORMT)
  60. c Liste des formulations simples (cf. MODELI et NOMATE)
  61. DATA (LISFOR(i), i=1,MFORMU)
  62. & / 'THERMIQUE ','MECANIQUE ','LIQUIDE ',
  63. & 'CONVECTION ','POREUX ','DARCY ',
  64. & 'FROTTEMENT ','RAYONNEMENT ','MAGNETODYNAMIQUE',
  65. & 'NAVIER_STOKES ','MELANGE ','EULER ',
  66. & 'FISSURE ','LIAISON ','THERMOHYDRIQUE ',
  67. & 'ELECTROSTATIQUE ','DIFFUSION ' /
  68. c Liste des formulations "combinees"
  69. DATA (LISFOR(i), i=MFORMU+1,MFORMT)
  70. & / 'MECANIQUE+LIQUID' /
  71.  
  72. * call gibtem (xkt)
  73. * write(ioimp,*) ' entree coml2 ', xkt
  74. c
  75. c active modele
  76. c
  77. mmodel = ipmodl
  78. segact mmodel*nomod
  79. NSOUS = kmodel(/1)
  80. c
  81. c moterr(1:6) = 'COML2 '
  82. c moterr(7:15) = 'MMODEL '
  83. c interr(1) = mmodel
  84. c call erreur(-329)
  85. c
  86. * On cree un nouveau mmodel en deroulant le modele d'entree :
  87. * Important en cas de modele melange !
  88. i100=100
  89. segini limode
  90. c
  91. nlimod = 0
  92. nmomel = 0
  93. do im = 1, NSOUS
  94. imodel = kmodel(im)
  95. segact,imodel*nomod
  96. nlimod = nlimod+1
  97. if (nlimod.gt.i100) then
  98. i100=i100+100
  99. segadj limode
  100. endif
  101. limode(nlimod) = imodel
  102. if (formod(1).eq.'MELANGE') then
  103. nmomel = nmomel + 1
  104. if (matmod(1).ne.'SERIE') then
  105. if (ivamod(/1).ge.1) then
  106. do ivm1 = 1,ivamod(/1)
  107. if (tymode(ivm1).eq.'IMODEL') then
  108. imode1 = ivamod(ivm1)
  109. segact imode1
  110. nlimod = nlimod+1
  111. if (nlimod.gt.i100) then
  112. i100=i100+100
  113. segadj limode
  114. endif
  115. limode(nlimod) = imode1
  116. endif
  117. enddo
  118. endif
  119. endif
  120. endif
  121. enddo
  122. *pv segdes mmodel
  123. * Ajustement du segment limode (inutile)
  124. *of i100 = nlimod
  125. *of segadj limode
  126. if (nlimod.le.0) then
  127. write(ioimp,*) 'Erreur anormale : MMODEL vide !'
  128. call erreur(5)
  129. return
  130. endif
  131. * write(ioimp,*) ' nlimod ' ,nlimod
  132. * write(ioimp,*) ' limode ',(limode(i),i=1,nlimod)
  133. * Test de non redondance des sous-modeles
  134. N1 = 1
  135. DO 1161 it1 = nlimod, 2, -1
  136. imode1 = limode(it1)
  137. DO it2 = (it1 - 1), 1, -1
  138. imode2 = limode(it2)
  139. if (imode1.EQ.imode2) then
  140. limode(it1) = 0
  141. goto 1161
  142. else if (imode1.imamod.eq.imode2.imamod .and.
  143. & imode1.conmod.eq.imode2.conmod) then
  144. limode(it1) = 0
  145. *of segdes,imode1
  146. goto 1161
  147. endif
  148. ENDDO
  149. N1 = N1 + 1
  150. 1161 CONTINUE
  151. * Initialisation du modele de travail (ipmod7)
  152. * => Cas particulier de la formulation MELANGE :
  153. * On met les sous-modeles de formulation MELANGE a la fin du modele
  154. * de travail pour qu'ils soient traites en dernier car ils dependent
  155. * des resultats des autres sous-modeles !
  156. SEGINI,mmodel
  157. it1 = 0
  158. it2 = N1 - nmomel
  159. do im = 1, nlimod
  160. imodel = limode(im)
  161. if (imodel.gt.0) then
  162. if (formod(1).NE.'MELANGE') then
  163. it1 = it1 + 1
  164. kmodel(it1) = imodel
  165. else
  166. it2 = it2 + 1
  167. kmodel(it2) = imodel
  168. endif
  169. endif
  170. enddo
  171. * if (it1.ne.(N1-nmomel) .and. it2.ne.N1) then
  172. * write(ioimp,*) 'Erreur anormale : traitement MELANGE !'
  173. * call erreur(5)
  174. * return
  175. * endif
  176. NSOUS = N1
  177. ipmod7 = mmodel
  178.  
  179. * Cas particulier de la formulation LIAISON :
  180. itruli = 0
  181. struli = 0
  182. iplia = 0
  183. * Test sur la presence de la formulation LIAISON
  184. * On utilise limode pour stocker les modeles elementaires associes
  185. N1 = 0
  186. DO im = 1, NSOUS
  187. imodel = kmodel(im)
  188. if (formod(1).EQ.'LIAISON') then
  189. N1 = N1 + 1
  190. limode(N1) = imodel
  191. endif
  192. ENDDO
  193. * Definition du modele (iplia) associe a la seule formulation LIAISON
  194. if (N1.ne.0) then
  195. segini,mmode1
  196. DO im = 1, N1
  197. mmode1.kmodel(im) = limode(im)
  198. ENDDO
  199. iplia = mmode1
  200. * Initialisation du segment struli
  201. np1 = 0
  202. segini struli
  203. itruli = struli
  204. itlia = iplia
  205. * Remplissage avec les donnees dependant des sous-modeles MODAL / STATIQUE
  206. call comalo(ipmodl,itruli,ipmel)
  207. endif
  208. *
  209. * Destruction du segment limode (devenu inutile)
  210. segsup,limode
  211. *
  212. * Tri prealable sur les pointeurs de maillage
  213. *
  214. lilmel = ipmel
  215. iimel = lilmel(/1)
  216. * write(ioimp,*) 'iou imadec, nomdec condec indec'
  217. deche = lilmel(1)
  218. ijmin = imadec
  219. ijmax = imadec
  220. * write(ioimp,*) 1,imadec,' ',nomdec ,' ', condec,' ',indec
  221. do im = 2, iimel
  222. deche = lilmel(im)
  223. ijmin = min(ijmin,imadec)
  224. ijmax = max(ijmax,imadec)
  225. * write(ioimp,*) im,imadec,' ',nomdec ,' ', condec,' ',indec
  226. enddo
  227. * write(ioimp,*) 'lilmel(/1) ijmin ,ijmax ',iimel,ijmin,ijmax
  228. ijdif = ijmax-ijmin+1
  229. izo = max(1,ijdif/(nsous*40))
  230. * if (izo.gt.11) izo=izo/3
  231. nzo = ijdif / izo + 1
  232. * write(ioimp,*) ' nzo izo ijmax ijmin ',nzo,izo,ijmax,ijmin
  233. segini izozo
  234. do im = 1, iimel
  235. deche = lilmel(im)
  236. ivamad = imadec-ijmin
  237. izu = ivamad/izo + 1
  238. izozo(izu)=izozo(izu) + 1
  239. enddo
  240. ia = izozo(1)
  241. do im = 2 , nzo+1
  242. ia = ia + izozo(im)
  243. izozo(im) = ia
  244. enddo
  245. segini ipozo
  246. do im = 1, iimel
  247. deche = lilmel(im)
  248. ivamad=imadec-ijmin
  249. izu=ivamad/izo+1
  250. ipa=izozo(izu)
  251. ipozo(ipa)=im
  252. izozo(izu)=ipa-1
  253. enddo
  254. * write(ioimp,*) 'izozo' ,izozo(1),izozo(2),izozo(3),izozo(4)
  255. * write(ioimp,*) 'ipozo ',(ipozo(izu),izu=1,20)
  256. c
  257. mmodel = ipmod7
  258. segact,mmodel
  259. NSOUS = kmodel(/1)
  260.  
  261. * On va creer d'office un modele contenant seulement le sous-modele
  262. * elementaire (isous) au cours de la boucle (1000) utile en cas de
  263. * projection et ou de changement de support !
  264. * Attention : Il faut reactiver le sous-modele apres utilisation
  265. * pour la bonne suite du traitement du comportement.
  266. N1 = 1
  267. SEGINI,mmode1
  268. IPMOD1 = mmode1
  269. *
  270. * Idem on cree un mchaml a une sous-zone et une composante qui sera a
  271. * mettre a jour a chaque fois que besoin par le deche en cours
  272. N1 = 1
  273. L1 = 1
  274. N3 = 6
  275. SEGINI,mchelm
  276. titche = ' '
  277. conche(1) = ' '
  278. c* ifoche = 0
  279. c* imache(1) = 0
  280. c* DO i = 1, N3
  281. c* infche(1,i) = 0
  282. c* ENDDO
  283. n2 = 1
  284. SEGINI,mchaml
  285. ichaml(1) = mchaml
  286. nomche(1) = ' '
  287. typche(1) = ' '
  288. c* ielval(1) = 0
  289. IPOI1 = mchelm
  290. c
  291. c
  292. c Boucle (1000) sur les modeles elementaires
  293. c --------------------------------------------
  294. c
  295. ir10=0
  296. DO 1000 isous = 1, NSOUS
  297. *
  298. imodel = kmodel(isous)
  299. segact imodel*nomod
  300. iqmod = imodel
  301.  
  302. mmode1 = IPMOD1
  303. SEGACT,mmode1*MOD
  304. mmode1.kmodel(1) = iqmod
  305. C* SEGDES,mmode1
  306. *
  307. * write(ioimp,*) 'coml2 modele elementaire numero ',im
  308. * write(6,*) 'coml2 formulation ',formod(1),' cons ',conmod
  309. * moterr(1:6) = 'COML2 '
  310. * moterr(7:15) = 'IMODEL '
  311. * interr(1) = im
  312. * call erreur(-329)
  313. c
  314. c Determination de la formulation du modele :
  315. c
  316. nformu = FORMOD(/2)
  317. iform1 = 0
  318. CALL PLACE(LISFOR,MFORMU,iform1,FORMOD(1))
  319. lformu = iform1
  320. IF (nformu.EQ.2) THEN
  321. iform2 = 0
  322. CALL PLACE(LISFOR,MFORMU,iform2,FORMOD(2))
  323. lformu = 0
  324. IF ( (iform1.eq.2 .and. iform2.eq.3) .or.
  325. & (iform1.eq.3 .and. iform2.eq.2) ) lformu = 18
  326. ENDIF
  327. if (lformu.eq.0) then
  328. write(ioimp,*) 'COML2 : formulation non prevue ici'
  329. goto 1000
  330. endif
  331.  
  332. MELE1 =NEFMOD
  333. MELEME=IMAMOD
  334. c
  335. c Indicateur de support
  336. cof : a stocker dans un segment de travail pour la suite ?
  337. c Par defaut, on initialise le support : lesupp = 5
  338. lesupp = 5
  339. * Formulation MECANIQUE+LIQUIDE
  340. * if (lformu.eq.18) lesupp = 5
  341. * Formulation THERMIQUE then
  342. if (lformu.eq.1) then
  343. lesupp = 6
  344. * Formulation MECANIQUE ou POREUX ou DIFFUSION ou ELECTROSTATIQUE
  345. * else if (lformu.eq. 2 .OR. lformu.EQ. 5 .OR. lformu.EQ.16 .OR.
  346. * lformu.eq.17) then
  347. * lesupp = 5
  348. else if (lformu.eq.11) then
  349. if (ivamod(/1).gt.0) then
  350. lesupp = 5
  351. else
  352. lesupp = 3
  353. endif
  354. else if (lformu.EQ.14) then
  355. lesupp = 1
  356. endif
  357. c
  358. c cas particulier de la formulation LIAISON
  359. jtruli = 0
  360. if (lformu.EQ.14) jtruli = itruli
  361. c formulation DIFFUSION
  362. if (lformu.eq.17.and.inatuu.lt.5) goto 1000
  363. c____________________________________________________________________
  364. c
  365. c information sur l'element fini
  366. c____________________________________________________________________
  367. info = 0
  368. ipinf = 0
  369. if (infmod(/1).lt.2+lesupp) then
  370. CALL ELQUOI(MELE1,0,lesupp,IPINF,IMODEL)
  371. IF (IERR.NE.0) THEN
  372. SEGDES IMODEL*NOMOD,MMODEL*NOMOD
  373. RETURN
  374. ENDIF
  375. INFO = IPINF
  376. mfr2 = infell(13)
  377. else
  378. mfr2 = infele(13)
  379. endif
  380. *
  381. iinomp=lilmel(/1)
  382. ijnomp=0
  383. segini,linomp,igard
  384. ivamad=imamod-ijmin
  385. izu=ivamad/izo + 1
  386. * write(ioimp,*) ' ijmin izo izu ',ijmin,izo,izu
  387. if (izu.le.nzo+1.and.izu.gt.0) then
  388. ideb=izozo(izu) + 1
  389. ifin=izozo(izu+1)
  390. else
  391. ideb=1
  392. ifin=0
  393. write(ioimp,*) ' coml2 en dehors du zonage '
  394. endif
  395. do iopo=ideb,ifin
  396. idn=ipozo(iopo)
  397. * do idn = 1,lilmel(/1)
  398. deche = lilmel(idn)
  399. ***** segact deche
  400. if (imamod.eq.imadec.and.conmod.eq.condec) then
  401. ijnomp=ijnomp+1
  402. igard(idn)=1
  403. linomp(ijnomp) = deche
  404. endif
  405. enddo
  406. * write(ioimp,*) ' ijnomp ' , ijnomp
  407. ncopj=ijnomp
  408. segini ncop
  409. * inop=1
  410. * deche=linomp(1)
  411. * ncopi(1)=nomdec
  412. do 648 idn=1,ijnomp
  413. deche=linomp(idn)
  414. * do iyu=1,inop
  415. * if(nomdec.eq.ncopi(iyu)) go to 648
  416. * enddo
  417. ncopi(idn)=nomdec
  418. 648 continue
  419. * write(ioimp,*) ' premier passage ijnomp ',ijnomp,ideb,ifin
  420. *
  421. * on met maintenant tous les champs qui sont sur le bon imamod
  422. * et qui n ont pas le bon constituant
  423. ncopjj=ncopj
  424. do 650 iopo=ideb,ifin
  425. idn=ipozo(iopo)
  426. if(igard(idn).eq.1) go to 650
  427. deche=lilmel(idn)
  428. if(imadec.ne.imamod) go to 650
  429. do iou=1,ncopjj
  430. if(ncopi(iou).eq.nomdec) go to 650
  431. enddo
  432. * write(6,*) ' composante ajoutée ' , nomdec
  433. ncopj=ncopJ+1
  434. segadj ncop
  435. ijnomp=ijnomp+1
  436. linomp(ijnomp)=deche
  437. igard(idn)=1
  438. ncopi(ncopj)=nomdec
  439. 650 continue
  440. * write(6,*) ' apres deuxielme passage ijnomp ' ,ijnomp
  441. iinomp=ijnomp
  442. segadj linomp
  443. * write(6,*) 'linomp ', linomp(/1)
  444. * do iou=1,linomp(/1)
  445. * deche=linomp(iou)
  446. * write(6,*)'condec nomdec indec ',condec,' ', nomdec,' ',indec
  447. * enddo
  448. * on met à -1 les deche que l'on peut sauter
  449. do 649 idn=1,lilmel(/1)
  450. deche= lilmel(idn)
  451. if(igard(idn).eq.1) go to 649
  452. do iyu=1,iinomp
  453. if (nomdec.eq.ncopi(iyu)) then
  454. igard(idn)=-1
  455. go to 649
  456. endif
  457. enddo
  458. 649 continue
  459.  
  460. * write(6,*) ' ijnomp ',ijnomp
  461.  
  462. c composantes des caracteristiques geometriques
  463. if(lnomid(7).ne.0) then
  464. lsupca=.false.
  465. mocomp=lnomid(7)
  466. nomid = mocomp
  467. segact nomid
  468. nobl=lesobl(/2)
  469. nfac=lesfac(/2)
  470. else
  471. lsupca=.true.
  472. CALL IDCARB(MELE1,IFOUR,MOCOMP,NOBL,NFAC)
  473. nomid = mocomp
  474. segact nomid
  475. endif
  476. ncarb = nobl + nfac
  477. * cherche les deche correspondants aux caracteristiques geometriques a t1 et t2
  478. ipcarb1 = 0
  479. ipcarb2 = 0
  480. * write(6,*) ' linomp(/1) nobl,nfac',linomp(/1),ncarb,nobl,nfac
  481. if (ncarb.gt.0) then
  482. iicarb=linomp(/1)
  483. segini licarb
  484. do minde = 1,2
  485. ijcarb=0
  486. n3=0
  487. do le = 1,linomp(/1)
  488. deche = linomp(le)
  489. ***** segact deche
  490. * write(ioimp,*)' le deche nomdec nindec',le,deche,nomdec,indec
  491. if (indec.eq.minde) then
  492. do jd = 1,nobl
  493. if (nomdec.eq.lesobl(jd)) then
  494. ijcarb=ijcarb+1
  495. licarb(ijcarb) = deche
  496. n3 = max (n3,infdec(/1))
  497. endif
  498. enddo
  499. do jd = 1,nfac
  500. if (nomdec.eq.lesfac(jd)) then
  501. ijcarb=ijcarb+1
  502. licarb(ijcarb) = deche
  503. n3 = max (n3,infdec(/1))
  504. endif
  505. enddo
  506. endif
  507. ***** segdes deche
  508. enddo
  509.  
  510. if (ijcarb.gt.0) then
  511. c cree un mchelm de caracteristiques
  512. * write(6,*) ' ijcarb ', ijcarb
  513. n1=ijcarb
  514. l1 = 13
  515. segini mchelm
  516. n2 = 1
  517. TITCHE = 'CARACTERISTIQUES'
  518. do 108 iga=1,ijcarb
  519. deche = licarb(iga)
  520. segini mchaml
  521. CONCHE(iga)=condec
  522. IMACHE(iga)=imadec
  523. ICHAML(iga)=mchaml
  524. IFOCHE = ifodec
  525. do in3=1,infdec(/1)
  526. infche(iga,in3) = infdec(in3)
  527. enddo
  528. NOMCHE(1)=nomdec
  529. TYPCHE(1)=typdec
  530. IELVAL(1)=ieldec
  531. *pv segdes MCHAML
  532. 108 continue
  533. *pv segdes mchelm
  534. if (minde.eq.1) ipcarb1 = mchelm
  535. if (minde.eq.2) ipcarb2 = mchelm
  536. endif
  537. enddo
  538. segsup licarb
  539. endif
  540. if(lsupca)segsup nomid
  541. c write(6,*) 'carac',ipcarb1,ipcarb2
  542.  
  543. c segment pour changer les supports d integration et geometrique
  544. iichan=lilmel(/1)
  545. ijchan=0
  546. segini lichan
  547. c segment des composantes qui correspondent au support : on les protege
  548. *
  549. * trie les composantes concernees
  550. * on cherche a descendre le plus d informations possible ... mais
  551. * il faut certaines fois etre raisonnable
  552. * on raisonne selon le type d element, le constituant et le support des pg
  553. iilcon=iinomp
  554. ijlcon=0
  555. segini lilcon
  556. ipcon = lilcon
  557. c*
  558. c pour gagner du temps
  559. c --- on vise les etudes d ingenierie donc la selection est faite sur
  560. c la formulation --- on ne passe dans coml6 que les deche qui correspondent
  561. c au support. ce n est pas bien parce que la philosophie de COMP
  562. c est justement de faire descendre le maximum d info. o tristesse.kich (05/01)
  563. * write(6,*) 'mfr2', mfr2,conmod
  564. if (((mfr2.ge.11.or.mfr2.eq.7).and.mfr2.ne.33) .or.
  565. & lformu.eq.14) then
  566. do ldn=1,linomp(/1)
  567. lilcon(ldn) = linomp(ldn)
  568. enddo
  569. ijlcon=iinomp
  570. goto 201
  571. endif
  572. c
  573. * write(6,*) ' passage a la cloche mfr2 ', mfr2,lilmel(/1)
  574. nmel1=50
  575. segini icorre
  576. do 200 iol=1,lilmel(/1)
  577. segact imodel*nomod
  578. deche = lilmel(iol)
  579. if(igard(iol).eq.1) go to 170
  580. if(igard(iol).eq.-1) go to 200
  581. ***** segact deche
  582. * moterr(1:6) = nomdec
  583. * moterr(7:22) = condec
  584. * interr(1) = deche
  585. * call erreur(-329)
  586. c write(6,*) 'compo ', nomdec,condec,indec,imadec ,meleme
  587. *tc do ldn = 1,linomp(/1)
  588. * parmi les composantes protegees on privilegie celles qui ont le bon
  589. * constituant
  590. *tc if (deche.eq.linomp(ldn).and.condec.eq.conmod) goto 170
  591. *tc enddo
  592. *tc
  593. *tc if (formod(1).ne.'MELANGE'.and.matmod(1).ne.'PARALLELE') then
  594. *tc do ldn = 1,linomp(/1)
  595. * on evite de garder les composantes qui n ont pas le bon constituant
  596. * pour lesquelles la composante avec le bon constituant existe
  597. * sauf pour le melange parallele (kich 01/05)
  598. *tc dec1 = linomp(ldn)
  599. *tc if (nomdec.eq.dec1.nomdec.and.dec1.condec.eq.conmod)
  600. *tc & goto 200
  601. *tc enddo
  602. *tc endif
  603. *
  604. * traite les composantes qui n existent pas sur le bon support :
  605. * celui du modele ... on va chercher a projeter
  606. if (meleme.ne.imadec) then
  607. * write(6,*) ' coml2 passage meleme.ne.imadec', nomdec
  608. ipt1 = imadec
  609. segact meleme,ipt1
  610. * si le type des elements est le meme on cree un melval
  611. if (itypel.eq.ipt1.itypel) then
  612. * concretement pour les elments qui ne sont pas massifs ou coque on passe
  613. * au deche suivant (kich 05/01)
  614. ielin = ieldec
  615. * write(6,*) ' appel à comail '
  616. call comail(meleme,ipt1,ielin,ielout,icorre)
  617. if (ielout.eq.0)go to 200
  618. * qu on range dans un deche que l on cree
  619. segini,dec1=deche
  620. dec1.ieldec= ielout
  621. dec1.imadec = meleme
  622. ***** segdes meleme,ipt1,deche
  623. deche = dec1
  624. ijchan=ijchan+1
  625. if(ijchan.gt.iichan) then
  626. iichan=iichan+100
  627. segadj lichan
  628. endif
  629. lichan(ijchan) = deche
  630. else if (condec.ne.conmod.and.itypel.ne.ipt1.itypel
  631. & .and.infdec(6).eq.1) then
  632. * sinon si le constituant n est pas le meme on projette aux pts rigidite
  633. c!!! pour l instant ne marche que pour les mchaml aux noeuds !!!
  634. **** segdes meleme,ipt1
  635. iem = indec
  636. if (iem.eq.1.and.ncarb.gt.0.and.ipcarb1.eq.0) goto 200
  637. if (iem.gt.1.and.ncarb.gt.0.and.ipcarb2.eq.0) goto 200
  638.  
  639. * cree un mchaml
  640. mchelm = IPOI1
  641. segact,mchelm*MOD
  642. ifoche=ifodec
  643. conche(1) = condec
  644. imache(1) = imadec
  645. do j = 1,infdec(/1)
  646. infche(1,j) = infdec(j)
  647. enddo
  648. mchaml = ichaml(1)
  649. SEGACT,mchaml*MOD
  650. nomche(1) = nomdec
  651. typche(1) = typdec
  652. ielval(1) = ieldec
  653. c* SEGDES,mchaml,mchelm
  654. call ecrcha('RIGIDITE')
  655. call ecrobj('MCHAML ',IPOI1)
  656. if (indec.eq.1.and.ipcarb1.ne.0) then
  657. call ecrobj('MCHAML ',ipcarb1)
  658. elseif (indec.gt.1.and.ipcarb2.ne.0) then
  659. call ecrobj('MCHAML ',ipcarb2)
  660. else
  661. endif
  662. call ecrobj('MMODEL ',IPMOD1)
  663. call PROIET
  664. IF(IERR.NE.0) RETURN
  665. call lirobj('MCHAML',IPCHE,0,IRE2)
  666. IF(IERR.NE.0) RETURN
  667. mchelm = ipche
  668. segact mchelm
  669. n1 = ichaml(/1)
  670. * pas de champ projete passe au suivant
  671. if (n1.eq.0) goto 200
  672. if (n1.ne.1) then
  673. * bizarre , contacter support
  674. moterr(1:6) = 'COML2'
  675. interr(1) = 11
  676. call erreur(943)
  677. return
  678. endif
  679. mchaml = ichaml(1)
  680. segact mchaml
  681. n2 = ielval(/1)
  682. * pas de champ projete passe au suivant
  683. if (n2.eq.0) goto 200
  684. if (n2.ne.1) then
  685. * bizarre , contacter support
  686. moterr(17:24) = 'COML2'
  687. interr(1) = 12
  688. call erreur(943)
  689. return
  690. endif
  691. * creer un deche
  692. n3 = infche(/2)
  693. segini deche
  694. indec = iem
  695. ieldec = ielval(1)
  696. typdec = typche(1)
  697. typree = typdec.eq.'REAL*8'
  698. nomdec = nomche(1)
  699. imadec = imache(1)
  700. condec = conche(1)
  701. ifodec = ifoche
  702. do in3 = 1, n3
  703. infdec(in3) = infche(1,in3)
  704. enddo
  705. * mettre dans une pile
  706. ijchan=ijchan+1
  707. if(ijchan.gt.iichan) then
  708. iichan=iichan+ 100
  709. segadj lichan
  710. endif
  711. lichan(ijchan) = deche
  712. segsup mchaml,mchelm
  713. c
  714. else
  715. * sinon on passe au deche suivant
  716. **** segdes meleme,ipt1
  717. goto 200
  718. endif
  719. endif
  720.  
  721. 170 continue
  722. * on change eventuellement sur les points d integration
  723. * convenables ... ce qui suppose en fait que l information
  724. * fournie a COMP n est pas redondante
  725. * en mecanique on utilise directement les champs fournis aux pgauss rigidite
  726. lome1 = infdec(6).eq.3.and.lesupp.eq.5
  727. lome2 = nomdec.eq.'TEMP'.or.nomdec.eq.'LX'.or.nomdec.eq.'FLX'
  728. if (infdec(6).ne.lesupp.and..not.lome1.and..not.lome2) then
  729. c write(6,*) 'change ', deche, nomdec
  730. iem = indec
  731. * cree un mchaml
  732. mchelm = IPOI1
  733. segact,mchelm*MOD
  734. ifoche=ifodec
  735. conche(1) = condec
  736. imache(1) = imadec
  737. do j = 1,infdec(/1)
  738. infche(1,j) = infdec(j)
  739. enddo
  740. mchaml = ichaml(1)
  741. SEGACT,mchaml*MOD
  742. nomche(1) = nomdec
  743. typche(1) = typdec
  744. ielval(1) = ieldec
  745. c* SEGDES,mchaml,mchelm
  746. * write(6,*) ' changement de support nomdec ',nomdec
  747. call CHASUP(IPMOD1,IPOI1,IPOI2,IRET,lesupp)
  748. if (IRET.NE.0) then
  749. CALL ERREUR(IRET)
  750. return
  751. endif
  752. if (ierr.ne.0) return
  753. mchelm = ipoi2
  754. segact mchelm
  755. n1 = ichaml(/1)
  756. if (n1.ne.1) then
  757. * bizarre , contacter support
  758. moterr(17:24) = 'COML2'
  759. interr(1) = 1
  760. call erreur(943)
  761. return
  762. endif
  763. mchaml = ichaml(1)
  764. segact mchaml
  765. n2 = ielval(/1)
  766. if (n2.ne.1) then
  767. * bizarre , contacter support
  768. moterr(17:24) = 'COML2'
  769. interr(1) = 2
  770. call erreur(943)
  771. return
  772. endif
  773. * creer un deche
  774. n3 = infche(/2)
  775. segini deche
  776. indec = iem
  777. ieldec = ielval(1)
  778. typdec = typche(1)
  779. typree = typdec.eq.'REAL*8'
  780. nomdec = nomche(1)
  781. imadec = imache(1)
  782. condec = conche(1)
  783. ifodec = ifoche
  784. do in3 = 1, n3
  785. infdec(in3) = infche(1,in3)
  786. enddo
  787. segsup mchaml,mchelm
  788. * mettre dans une pile
  789. ijchan=ijchan+1
  790. if(ijchan.gt.iichan) then
  791. iichan=iichan+100
  792. segadj lichan
  793. endif
  794. lichan(ijchan) = deche
  795. endif
  796. c
  797. c write(6,*) 'lilcon ',deche,nomdec,typdec,condec,imadec,indec
  798. ijlcon=ijlcon+1
  799. if(ijlcon.gt.iilcon) then
  800. iilcon=iilcon+100
  801. segadj lilcon
  802. endif
  803. lilcon(ijlcon) = deche
  804.  
  805. 200 continue
  806. do iou=1,idej
  807. mlenti=icor(iou)
  808. if(mlenti.ne.0)segsup mlenti
  809. enddo
  810. segsup icorre
  811. 201 continue
  812.  
  813. imodel = iqmod
  814. segact imodel*nomod
  815. if (ijchan.ne.iichan) then
  816. iichan = ijchan
  817. segadj lichan
  818. endif
  819. c passe ce qui reste
  820. if (ijlcon.ne.iilcon) then
  821. iilcon=ijlcon
  822. segadj lilcon
  823. endif
  824. if (lilcon(/1).ge.1) then
  825. * call gibtem(xkt)
  826. * write(6,*) ' coml2 : appel a coml6 ', xkt
  827. * do ioup=1,lilcon(/1)
  828. * deche=lilcon(ioup)
  829. * write(6,*)deche,' ',nomdec,' ',imadec,' ',indec,' ',condec
  830. * enddo
  831. call coml6(iqmod,ipcon,ipinf,indeso,lesupp,jtruli,ir10,IRETOU)
  832.  
  833. * call gibtem(xkt)
  834. * write(6,*) ' coml2 : retour de coml6 ',xkt
  835. else
  836. c write(6,*) 'pas de composante pour le sous-model ',imodel
  837. endif
  838. * write(6,*) 'coml2 : ierr ', ierr , 'iretou ', iretou
  839. if (ierr.gt.1) return
  840.  
  841. * complete la pile des deche en sortie / desactive les DECHE et les MELVAL
  842. lilcon = ipcon
  843. ijmel=lilmel(/1)
  844. do 800 ioc =iilcon+1,lilcon(/1)
  845. deche = lilcon(ioc)
  846. ***** segact deche*nomod
  847. if (indec.lt.indeso) then
  848. else if (indec.eq.indeso.and.condec.eq.conmod) then
  849. * si on a ete coherent on ne peut creer 2 fois le meme deche
  850. * on ne rajoute que les deche crees sur le constituant
  851. * on ne met pas dans lilmel les deches intermediaires
  852. if (ijchan.gt.0) then
  853. do iyf = 1,ijchan
  854. if (lichan(iyf).eq.deche) goto 800
  855. enddo
  856. endif
  857. ijmel=ijmel+1
  858. if(ijmel.gt.iimel) then
  859. iimel=iimel+100
  860. segadj lilmel
  861. endif
  862. lilmel(ijmel) = deche
  863. c melval = ieldec
  864. c segact melval
  865. else
  866. endif
  867. * melval = ieldec
  868. *** segdes melval
  869. c segdes deche
  870. 800 continue
  871. iimel=ijmel
  872. segadj lilmel
  873. segsup lilcon,linomp,igard,ncop
  874.  
  875. * supprime melval intermediaire
  876. if (ijchan.gt.0) then
  877. do iop = 1,ijchan
  878. deche = lichan(iop)
  879. ******* segact deche
  880. c write(6,*) 'deche ', nomdec , indec, ieldec
  881. do il = 1,lilmel(/1)
  882. dec1 = lilmel(il)
  883. c write(6,*) 'de1 ', dec1.nomdec , dec1.indec, dec1.ieldec
  884. if (dec1.indec.eq.indeso.and.dec1.ieldec.eq.ieldec) goto 810
  885. enddo
  886. melval = ieldec
  887. c write(6,*) 'supprime deche ',nomdec,melval,deche
  888. segsup melval
  889. 810 continue
  890. segsup deche
  891. enddo
  892. endif
  893. segsup lichan
  894.  
  895. * supprime les mchaml de caracteristiques
  896. mchel1=ipcarb1
  897. do minde = 1, 2
  898. if (minde.eq.2) mchel1=ipcarb2
  899. if (mchel1.gt.0) then
  900. segact mchel1
  901. do jch1 = 1,mchel1.ichaml(/1)
  902. mchaml = mchel1.ichaml(jch1)
  903. if (mchaml.gt.0) segsup mchaml
  904. enddo
  905. segsup mchel1
  906. endif
  907. enddo
  908. c write(6,*) 'supprime caracteristiques ' , ipcarb1,ipcarb2
  909.  
  910. if (ierr.ne.0) return
  911. if (iretou.ne.0) return
  912. c
  913. c cas traitement non-local MELANGE
  914. c
  915. IF (lformu.EQ.11) THEN
  916. IF (ivamod(/1).gt.0) THEN
  917. c
  918. c rassemble les deche lies aux phases
  919. iilcon=lilmel(/1)
  920. ijlcon=0
  921. segini lilcon
  922. ipcon = lilcon
  923. do 910 ide = 1,iilcon
  924. deche = lilmel(ide)
  925. if (indec.eq.indeso.and.imadec.eq.imamod) then
  926. if (condec.eq.conmod) then
  927. ijlcon = ijlcon + 1
  928. lilcon(ijlcon) = deche
  929. else
  930. do im = 1,ivamod(/1)
  931. if (tymode(im).eq.'IMODEL') then
  932. imode1 = ivamod(im)
  933. segact imode1
  934. if ((condec.eq.imode1.conmod).or.
  935. &(nomdec(1:4).eq.imode1.conmod(17:20))) then
  936. ijlcon = ijlcon + 1
  937. lilcon(ijlcon) = deche
  938. endif
  939. endif
  940. enddo
  941. endif
  942. elseif (indec.eq.2.and.imadec.eq.imamod.and.condec.ne.conmod)
  943. &then
  944. do im = 1,ivamod(/1)
  945. if (tymode(im).eq.'IMODEL') then
  946. imode1 = ivamod(im)
  947. segact imode1
  948. if ((condec.eq.imode1.conmod).or.
  949. &(nomdec(1:4).eq.imode1.conmod(17:20))) then
  950. ijlcon = ijlcon + 1
  951. lilcon(ijlcon) = deche
  952. endif
  953. endif
  954. enddo
  955. endif
  956. 910 continue
  957. iilcon = ijlcon
  958. segadj lilcon
  959. iilcon0 = iilcon
  960.  
  961. c traite
  962. call coml9(iqmod,ipcon,ipinf,indeso,IRETOU,lesupp)
  963.  
  964. c range
  965. * complete la pile des deche en sortie
  966. lilcon = ipcon
  967. ijmel=lilmel(/1)
  968. iimel=ijmel
  969. do 920 ioc =iilcon0+1,lilcon(/1)
  970. deche = lilcon(ioc)
  971. if (indec.lt.indeso) then
  972. else if (indec.eq.indeso.and.condec.eq.conmod) then
  973. * si on a ete coherent on ne peut creer 2 fois le meme deche
  974. ijmel=ijmel+1
  975. if(ijmel.gt.iimel) then
  976. iimel=iimel+100
  977. segadj lilmel
  978. endif
  979. lilmel(ijmel) = deche
  980. c melval = ieldec
  981. c segact melval
  982. else
  983. endif
  984. 920 continue
  985. iimel=ijmel
  986. segadj lilmel
  987. c detruit
  988. segsup lilcon
  989.  
  990. c fin traitement non local MELANGE
  991. ENDIF
  992. ENDIF
  993. c
  994. if (info.ne.0) then
  995. segsup info
  996. info=0
  997. endif
  998. c
  999. *pv segdes meleme
  1000. *pv segdes,imodel
  1001.  
  1002. 1000 CONTINUE
  1003. ir10=0
  1004. c------------------------------------
  1005. c fin boucle modeles elementaires
  1006. c------------------------------------
  1007.  
  1008. c Destruction du segment struli (si utilise)
  1009. if (itruli.ne.0) then
  1010. if (momoda.gt.0) then
  1011. mmode2 = momoda
  1012. segsup mmode2
  1013. endif
  1014. if (mostat.gt.0) then
  1015. mmode2 = mostat
  1016. segsup mmode2
  1017. endif
  1018. if (itbmod.gt.0) then
  1019. mmode2 = itbmod
  1020. segsup mmode2
  1021. endif
  1022. if (itlia.gt.0) then
  1023. mmode2 = itlia
  1024. segsup mmode2
  1025. endif
  1026. if (ichain.gt.0) then
  1027. mlent3 = ichain
  1028. segsup mlent3
  1029. endif
  1030. segsup struli
  1031. endif
  1032. c Destruction modele deroule
  1033. c* mmodel = impod7
  1034. segsup mmodel
  1035. segsup ipozo,izozo
  1036. c Destruction autres segments
  1037. mmode1 = IPMOD1
  1038. segsup mmode1
  1039. mchelm = IPOI1
  1040. segact,mchelm
  1041. mchaml = ichaml(1)
  1042. segsup,mchaml,mchelm
  1043.  
  1044. * call gibtem (xkt)
  1045. * write(ioimp,*) ' sortie coml2 ' , xkt
  1046.  
  1047. RETURN
  1048. END
  1049.  
  1050.  
  1051.  
  1052.  
  1053.  
  1054.  
  1055.  
  1056.  
  1057.  
  1058.  
  1059.  

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