Télécharger coml2.eso

Retour à la liste

Numérotation des lignes :

  1. C COML2 SOURCE BP208322 17/03/01 21:16:17 9325
  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. DO 1000 isous = 1, NSOUS
  296. *
  297. imodel = kmodel(isous)
  298. segact imodel*nomod
  299. iqmod = imodel
  300.  
  301. mmode1 = IPMOD1
  302. SEGACT,mmode1*MOD
  303. mmode1.kmodel(1) = iqmod
  304. C* SEGDES,mmode1
  305. *
  306. * write(ioimp,*) 'coml2 modele elementaire numero ',im
  307. * write(6,*) 'coml2 formulation ',formod(1),' cons ',conmod
  308. * moterr(1:6) = 'COML2 '
  309. * moterr(7:15) = 'IMODEL '
  310. * interr(1) = im
  311. * call erreur(-329)
  312. c
  313. c Determination de la formulation du modele :
  314. c
  315. nformu = FORMOD(/2)
  316. iform1 = 0
  317. CALL PLACE(LISFOR,MFORMU,iform1,FORMOD(1))
  318. lformu = iform1
  319. IF (nformu.EQ.2) THEN
  320. iform2 = 0
  321. CALL PLACE(LISFOR,MFORMU,iform2,FORMOD(2))
  322. lformu = 0
  323. IF ( (iform1.eq.2 .and. iform2.eq.3) .or.
  324. & (iform1.eq.3 .and. iform2.eq.2) ) lformu = 18
  325. ENDIF
  326. if (lformu.eq.0) then
  327. write(ioimp,*) 'COML2 : formulation non prevue ici'
  328. goto 1000
  329. endif
  330.  
  331. MELE1 =NEFMOD
  332. MELEME=IMAMOD
  333. c
  334. c Indicateur de support
  335. cof : a stocker dans un segment de travail pour la suite ?
  336. c Par defaut, on initialise le support : lesupp = 5
  337. lesupp = 5
  338. * Formulation MECANIQUE+LIQUIDE
  339. * if (lformu.eq.18) lesupp = 5
  340. * Formulation THERMIQUE then
  341. if (lformu.eq.1) then
  342. lesupp = 6
  343. * Formulation MECANIQUE ou POREUX ou DIFFUSION ou ELECTROSTATIQUE
  344. * else if (lformu.eq. 2 .OR. lformu.EQ. 5 .OR. lformu.EQ.16 .OR.
  345. * lformu.eq.17) then
  346. * lesupp = 5
  347. else if (lformu.eq.11) then
  348. if (ivamod(/1).gt.0) then
  349. lesupp = 5
  350. else
  351. lesupp = 3
  352. endif
  353. else if (lformu.EQ.14) then
  354. lesupp = 1
  355. endif
  356. c
  357. c cas particulier de la formulation LIAISON
  358. jtruli = 0
  359. if (lformu.EQ.14) jtruli = itruli
  360. c formulation DIFFUSION
  361. if (lformu.eq.17.and.inatuu.lt.5) goto 1000
  362. c____________________________________________________________________
  363. c
  364. c information sur l'element fini
  365. c____________________________________________________________________
  366. info = 0
  367. ipinf = 0
  368. if (infmod(/1).lt.2+lesupp) then
  369. CALL ELQUOI(MELE1,0,lesupp,IPINF,IMODEL)
  370. IF (IERR.NE.0) THEN
  371. SEGDES IMODEL*NOMOD,MMODEL*NOMOD
  372. RETURN
  373. ENDIF
  374. INFO = IPINF
  375. mfr2 = infell(13)
  376. else
  377. mfr2 = infele(13)
  378. endif
  379. *
  380. iinomp=lilmel(/1)
  381. ijnomp=0
  382. segini,linomp,igard
  383. ivamad=imamod-ijmin
  384. izu=ivamad/izo + 1
  385. * write(ioimp,*) ' ijmin izo izu ',ijmin,izo,izu
  386. if (izu.le.nzo+1.and.izu.gt.0) then
  387. ideb=izozo(izu) + 1
  388. ifin=izozo(izu+1)
  389. else
  390. ideb=1
  391. ifin=0
  392. write(ioimp,*) ' coml2 en dehors du zonage '
  393. endif
  394. do iopo=ideb,ifin
  395. idn=ipozo(iopo)
  396. * do idn = 1,lilmel(/1)
  397. deche = lilmel(idn)
  398. ***** segact deche
  399. if (imamod.eq.imadec.and.conmod.eq.condec) then
  400. ijnomp=ijnomp+1
  401. igard(idn)=1
  402. linomp(ijnomp) = deche
  403. endif
  404. enddo
  405. * write(ioimp,*) ' ijnomp ' , ijnomp
  406. ncopj=ijnomp
  407. segini ncop
  408. * inop=1
  409. * deche=linomp(1)
  410. * ncopi(1)=nomdec
  411. do 648 idn=1,ijnomp
  412. deche=linomp(idn)
  413. * do iyu=1,inop
  414. * if(nomdec.eq.ncopi(iyu)) go to 648
  415. * enddo
  416. ncopi(idn)=nomdec
  417. 648 continue
  418. * write(ioimp,*) ' premier passage ijnomp ',ijnomp,ideb,ifin
  419. *
  420. * on met maintenant tous les champs qui sont sur le bon imamod
  421. * et qui n ont pas le bon constituant
  422. ncopjj=ncopj
  423. do 650 iopo=ideb,ifin
  424. idn=ipozo(iopo)
  425. if(igard(idn).eq.1) go to 650
  426. deche=lilmel(idn)
  427. if(imadec.ne.imamod) go to 650
  428. do iou=1,ncopjj
  429. if(ncopi(iou).eq.nomdec) go to 650
  430. enddo
  431. * write(6,*) ' composante ajoutée ' , nomdec
  432. ncopj=ncopJ+1
  433. segadj ncop
  434. ijnomp=ijnomp+1
  435. linomp(ijnomp)=deche
  436. igard(idn)=1
  437. ncopi(ncopj)=nomdec
  438. 650 continue
  439. * write(6,*) ' apres deuxielme passage ijnomp ' ,ijnomp
  440. iinomp=ijnomp
  441. segadj linomp
  442. * write(6,*) 'linomp ', linomp(/1)
  443. * do iou=1,linomp(/1)
  444. * deche=linomp(iou)
  445. * write(6,*)'condec nomdec indec ',condec,' ', nomdec,' ',indec
  446. * enddo
  447. * on met à -1 les deche que l'on peut sauter
  448. do 649 idn=1,lilmel(/1)
  449. deche= lilmel(idn)
  450. if(igard(idn).eq.1) go to 649
  451. do iyu=1,iinomp
  452. if (nomdec.eq.ncopi(iyu)) then
  453. igard(idn)=-1
  454. go to 649
  455. endif
  456. enddo
  457. 649 continue
  458.  
  459. * write(6,*) ' ijnomp ',ijnomp
  460.  
  461. c composantes des caracteristiques geometriques
  462. if(lnomid(7).ne.0) then
  463. lsupca=.false.
  464. mocomp=lnomid(7)
  465. nomid = mocomp
  466. segact nomid
  467. nobl=lesobl(/2)
  468. nfac=lesfac(/2)
  469. else
  470. lsupca=.true.
  471. CALL IDCARB(MELE1,IFOUR,MOCOMP,NOBL,NFAC)
  472. nomid = mocomp
  473. segact nomid
  474. endif
  475. ncarb = nobl + nfac
  476. * cherche les deche correspondants aux caracteristiques geometriques a t1 et t2
  477. ipcarb1 = 0
  478. ipcarb2 = 0
  479. * write(6,*) ' linomp(/1) nobl,nfac',linomp(/1),ncarb,nobl,nfac
  480. if (ncarb.gt.0) then
  481. iicarb=linomp(/1)
  482. segini licarb
  483. do minde = 1,2
  484. ijcarb=0
  485. n3=0
  486. do le = 1,linomp(/1)
  487. deche = linomp(le)
  488. ***** segact deche
  489. * write(ioimp,*)' le deche nomdec nindec',le,deche,nomdec,indec
  490. if (indec.eq.minde) then
  491. do jd = 1,nobl
  492. if (nomdec.eq.lesobl(jd)) then
  493. ijcarb=ijcarb+1
  494. licarb(ijcarb) = deche
  495. n3 = max (n3,infdec(/1))
  496. endif
  497. enddo
  498. do jd = 1,nfac
  499. if (nomdec.eq.lesfac(jd)) then
  500. ijcarb=ijcarb+1
  501. licarb(ijcarb) = deche
  502. n3 = max (n3,infdec(/1))
  503. endif
  504. enddo
  505. endif
  506. ***** segdes deche
  507. enddo
  508.  
  509. if (ijcarb.gt.0) then
  510. c cree un mchelm de caracteristiques
  511. * write(6,*) ' ijcarb ', ijcarb
  512. n1=ijcarb
  513. l1 = 13
  514. segini mchelm
  515. n2 = 1
  516. TITCHE = 'CARACTERISTIQUES'
  517. do 108 iga=1,ijcarb
  518. deche = licarb(iga)
  519. segini mchaml
  520. CONCHE(iga)=condec
  521. IMACHE(iga)=imadec
  522. ICHAML(iga)=mchaml
  523. IFOCHE = ifodec
  524. do in3=1,infdec(/1)
  525. infche(iga,in3) = infdec(in3)
  526. enddo
  527. NOMCHE(1)=nomdec
  528. TYPCHE(1)=typdec
  529. IELVAL(1)=ieldec
  530. *pv segdes MCHAML
  531. 108 continue
  532. *pv segdes mchelm
  533. if (minde.eq.1) ipcarb1 = mchelm
  534. if (minde.eq.2) ipcarb2 = mchelm
  535. endif
  536. enddo
  537. segsup licarb
  538. endif
  539. if(lsupca)segsup nomid
  540. c write(6,*) 'carac',ipcarb1,ipcarb2
  541.  
  542. c segment pour changer les supports d integration et geometrique
  543. iichan=lilmel(/1)
  544. ijchan=0
  545. segini lichan
  546. c segment des composantes qui correspondent au support : on les protege
  547. *
  548. * trie les composantes concernees
  549. * on cherche a descendre le plus d informations possible ... mais
  550. * il faut certaines fois etre raisonnable
  551. * on raisonne selon le type d element, le constituant et le support des pg
  552. iilcon=iinomp
  553. ijlcon=0
  554. segini lilcon
  555. ipcon = lilcon
  556. c*
  557. c pour gagner du temps
  558. c --- on vise les etudes d ingenierie donc la selection est faite sur
  559. c la formulation --- on ne passe dans coml6 que les deche qui correspondent
  560. c au support. ce n est pas bien parce que la philosophie de COMP
  561. c est justement de faire descendre le maximum d info. o tristesse.kich (05/01)
  562. * write(6,*) 'mfr2', mfr2,conmod
  563. if (((mfr2.ge.11.or.mfr2.eq.7).and.mfr2.ne.33) .or.
  564. & lformu.eq.14) then
  565. do ldn=1,linomp(/1)
  566. lilcon(ldn) = linomp(ldn)
  567. enddo
  568. ijlcon=iinomp
  569. goto 201
  570. endif
  571. c
  572. * write(6,*) ' passage a la cloche mfr2 ', mfr2,lilmel(/1)
  573. nmel1=50
  574. segini icorre
  575. do 200 iol=1,lilmel(/1)
  576. segact imodel*nomod
  577. deche = lilmel(iol)
  578. if(igard(iol).eq.1) go to 170
  579. if(igard(iol).eq.-1) go to 200
  580. ***** segact deche
  581. * moterr(1:6) = nomdec
  582. * moterr(7:22) = condec
  583. * interr(1) = deche
  584. * call erreur(-329)
  585. c write(6,*) 'compo ', nomdec,condec,indec,imadec ,meleme
  586. *tc do ldn = 1,linomp(/1)
  587. * parmi les composantes protegees on privilegie celles qui ont le bon
  588. * constituant
  589. *tc if (deche.eq.linomp(ldn).and.condec.eq.conmod) goto 170
  590. *tc enddo
  591. *tc
  592. *tc if (formod(1).ne.'MELANGE'.and.matmod(1).ne.'PARALLELE') then
  593. *tc do ldn = 1,linomp(/1)
  594. * on evite de garder les composantes qui n ont pas le bon constituant
  595. * pour lesquelles la composante avec le bon constituant existe
  596. * sauf pour le melange parallele (kich 01/05)
  597. *tc dec1 = linomp(ldn)
  598. *tc if (nomdec.eq.dec1.nomdec.and.dec1.condec.eq.conmod)
  599. *tc & goto 200
  600. *tc enddo
  601. *tc endif
  602. *
  603. * traite les composantes qui n existent pas sur le bon support :
  604. * celui du modele ... on va chercher a projeter
  605. if (meleme.ne.imadec) then
  606. * write(6,*) ' coml2 passage meleme.ne.imadec', nomdec
  607. ipt1 = imadec
  608. segact meleme,ipt1
  609. * si le type des elements est le meme on cree un melval
  610. if (itypel.eq.ipt1.itypel) then
  611. * concretement pour les elments qui ne sont pas massifs ou coque on passe
  612. * au deche suivant (kich 05/01)
  613. ielin = ieldec
  614. * write(6,*) ' appel à comail '
  615. call comail(meleme,ipt1,ielin,ielout,icorre)
  616. if (ielout.eq.0)go to 200
  617. * qu on range dans un deche que l on cree
  618. segini,dec1=deche
  619. dec1.ieldec= ielout
  620. dec1.imadec = meleme
  621. ***** segdes meleme,ipt1,deche
  622. deche = dec1
  623. ijchan=ijchan+1
  624. if(ijchan.gt.iichan) then
  625. iichan=iichan+100
  626. segadj lichan
  627. endif
  628. lichan(ijchan) = deche
  629. else if (condec.ne.conmod.and.itypel.ne.ipt1.itypel
  630. & .and.infdec(6).eq.1) then
  631. * sinon si le constituant n est pas le meme on projette aux pts rigidite
  632. c!!! pour l instant ne marche que pour les mchaml aux noeuds !!!
  633. **** segdes meleme,ipt1
  634. iem = indec
  635. if (iem.eq.1.and.ncarb.gt.0.and.ipcarb1.eq.0) goto 200
  636. if (iem.gt.1.and.ncarb.gt.0.and.ipcarb2.eq.0) goto 200
  637.  
  638. * cree un mchaml
  639. mchelm = IPOI1
  640. segact,mchelm*MOD
  641. ifoche=ifodec
  642. conche(1) = condec
  643. imache(1) = imadec
  644. do j = 1,infdec(/1)
  645. infche(1,j) = infdec(j)
  646. enddo
  647. mchaml = ichaml(1)
  648. SEGACT,mchaml*MOD
  649. nomche(1) = nomdec
  650. typche(1) = typdec
  651. ielval(1) = ieldec
  652. c* SEGDES,mchaml,mchelm
  653. call ecrcha('RIGIDITE')
  654. call ecrobj('MCHAML ',IPOI1)
  655. if (indec.eq.1.and.ipcarb1.ne.0) then
  656. call ecrobj('MCHAML ',ipcarb1)
  657. elseif (indec.gt.1.and.ipcarb2.ne.0) then
  658. call ecrobj('MCHAML ',ipcarb2)
  659. else
  660. endif
  661. call ecrobj('MMODEL ',IPMOD1)
  662. call PROIET
  663. IF(IERR.NE.0) RETURN
  664. call lirobj('MCHAML',IPCHE,0,IRE2)
  665. IF(IERR.NE.0) RETURN
  666. mchelm = ipche
  667. segact mchelm
  668. n1 = ichaml(/1)
  669. * pas de champ projete passe au suivant
  670. if (n1.eq.0) goto 200
  671. if (n1.ne.1) then
  672. * bizarre , contacter support
  673. moterr(1:6) = 'COML2'
  674. interr(1) = 11
  675. call erreur(943)
  676. return
  677. endif
  678. mchaml = ichaml(1)
  679. segact mchaml
  680. n2 = ielval(/1)
  681. * pas de champ projete passe au suivant
  682. if (n2.eq.0) goto 200
  683. if (n2.ne.1) then
  684. * bizarre , contacter support
  685. moterr(17:24) = 'COML2'
  686. interr(1) = 12
  687. call erreur(943)
  688. return
  689. endif
  690. * creer un deche
  691. n3 = infche(/2)
  692. segini deche
  693. indec = iem
  694. ieldec = ielval(1)
  695. typdec = typche(1)
  696. nomdec = nomche(1)
  697. imadec = imache(1)
  698. condec = conche(1)
  699. ifodec = ifoche
  700. do in3 = 1, n3
  701. infdec(in3) = infche(1,in3)
  702. enddo
  703. * mettre dans une pile
  704. ijchan=ijchan+1
  705. if(ijchan.gt.iichan) then
  706. iichan=iichan+ 100
  707. segadj lichan
  708. endif
  709. lichan(ijchan) = deche
  710. segsup mchaml,mchelm
  711. c
  712. else
  713. * sinon on passe au deche suivant
  714. **** segdes meleme,ipt1
  715. goto 200
  716. endif
  717. endif
  718.  
  719. 170 continue
  720. * on change eventuellement sur les points d integration
  721. * convenables ... ce qui suppose en fait que l information
  722. * fournie a COMP n est pas redondante
  723. * en mecanique on utilise directement les champs fournis aux pgauss rigidite
  724. lome1 = infdec(6).eq.3.and.lesupp.eq.5
  725. lome2 = nomdec.eq.'TEMP'.or.nomdec.eq.'LX'.or.nomdec.eq.'FLX'
  726. if (infdec(6).ne.lesupp.and..not.lome1.and..not.lome2) then
  727. c write(6,*) 'change ', deche, nomdec
  728. iem = indec
  729. * cree un mchaml
  730. mchelm = IPOI1
  731. segact,mchelm*MOD
  732. ifoche=ifodec
  733. conche(1) = condec
  734. imache(1) = imadec
  735. do j = 1,infdec(/1)
  736. infche(1,j) = infdec(j)
  737. enddo
  738. mchaml = ichaml(1)
  739. SEGACT,mchaml*MOD
  740. nomche(1) = nomdec
  741. typche(1) = typdec
  742. ielval(1) = ieldec
  743. c* SEGDES,mchaml,mchelm
  744. * write(6,*) ' changement de support nomdec ',nomdec
  745. call CHASUP(IPMOD1,IPOI1,IPOI2,IRET,lesupp)
  746. if (IRET.NE.0) then
  747. CALL ERREUR(IRET)
  748. return
  749. endif
  750. if (ierr.ne.0) return
  751. mchelm = ipoi2
  752. segact mchelm
  753. n1 = ichaml(/1)
  754. if (n1.ne.1) then
  755. * bizarre , contacter support
  756. moterr(17:24) = 'COML2'
  757. interr(1) = 1
  758. call erreur(943)
  759. return
  760. endif
  761. mchaml = ichaml(1)
  762. segact mchaml
  763. n2 = ielval(/1)
  764. if (n2.ne.1) then
  765. * bizarre , contacter support
  766. moterr(17:24) = 'COML2'
  767. interr(1) = 2
  768. call erreur(943)
  769. return
  770. endif
  771. * creer un deche
  772. n3 = infche(/2)
  773. segini deche
  774. indec = iem
  775. ieldec = ielval(1)
  776. typdec = typche(1)
  777. nomdec = nomche(1)
  778. imadec = imache(1)
  779. condec = conche(1)
  780. ifodec = ifoche
  781. do in3 = 1, n3
  782. infdec(in3) = infche(1,in3)
  783. enddo
  784. segsup mchaml,mchelm
  785. * mettre dans une pile
  786. ijchan=ijchan+1
  787. if(ijchan.gt.iichan) then
  788. iichan=iichan+100
  789. segadj lichan
  790. endif
  791. lichan(ijchan) = deche
  792. endif
  793. c
  794. c write(6,*) 'lilcon ',deche,nomdec,typdec,condec,imadec,indec
  795. ijlcon=ijlcon+1
  796. if(ijlcon.gt.iilcon) then
  797. iilcon=iilcon+100
  798. segadj lilcon
  799. endif
  800. lilcon(ijlcon) = deche
  801.  
  802. 200 continue
  803. do iou=1,idej
  804. mlenti=icor(iou)
  805. if(mlenti.ne.0)segsup mlenti
  806. enddo
  807. segsup icorre
  808. 201 continue
  809.  
  810. imodel = iqmod
  811. segact imodel*nomod
  812. if (ijchan.ne.iichan) then
  813. iichan = ijchan
  814. segadj lichan
  815. endif
  816. c passe ce qui reste
  817. if (ijlcon.ne.iilcon) then
  818. iilcon=ijlcon
  819. segadj lilcon
  820. endif
  821. if (lilcon(/1).ge.1) then
  822. * call gibtem(xkt)
  823. * write(6,*) ' coml2 : appel a coml6 ', xkt
  824. * do ioup=1,lilcon(/1)
  825. * deche=lilcon(ioup)
  826. * write(6,*)deche,' ',nomdec,' ',imadec,' ',indec,' ',condec
  827. * enddo
  828. call coml6(iqmod,ipcon,ipinf,indeso,lesupp,jtruli,IRETOU)
  829.  
  830. * call gibtem(xkt)
  831. * write(6,*) ' coml2 : retour de coml6 ',xkt
  832. else
  833. c write(6,*) 'pas de composante pour le sous-model ',imodel
  834. endif
  835. * write(6,*) 'coml2 : ierr ', ierr , 'iretou ', iretou
  836. if (ierr.gt.1) return
  837.  
  838. * complete la pile des deche en sortie / desactive les DECHE et les MELVAL
  839. lilcon = ipcon
  840. ijmel=lilmel(/1)
  841. do 800 ioc =iilcon+1,lilcon(/1)
  842. deche = lilcon(ioc)
  843. ***** segact deche*nomod
  844. if (indec.lt.indeso) then
  845. else if (indec.eq.indeso.and.condec.eq.conmod) then
  846. * si on a ete coherent on ne peut creer 2 fois le meme deche
  847. * on ne rajoute que les deche crees sur le constituant
  848. * on ne met pas dans lilmel les deches intermediaires
  849. if (ijchan.gt.0) then
  850. do iyf = 1,ijchan
  851. if (lichan(iyf).eq.deche) goto 800
  852. enddo
  853. endif
  854. ijmel=ijmel+1
  855. if(ijmel.gt.iimel) then
  856. iimel=iimel+100
  857. segadj lilmel
  858. endif
  859. lilmel(ijmel) = deche
  860. c melval = ieldec
  861. c segact melval
  862. else
  863. endif
  864. * melval = ieldec
  865. *** segdes melval
  866. c segdes deche
  867. 800 continue
  868. iimel=ijmel
  869. segadj lilmel
  870. segsup lilcon,linomp,igard,ncop
  871.  
  872. * supprime melval intermediaire
  873. if (ijchan.gt.0) then
  874. do iop = 1,ijchan
  875. deche = lichan(iop)
  876. ******* segact deche
  877. c write(6,*) 'deche ', nomdec , indec, ieldec
  878. do il = 1,lilmel(/1)
  879. dec1 = lilmel(il)
  880. c write(6,*) 'de1 ', dec1.nomdec , dec1.indec, dec1.ieldec
  881. if (dec1.indec.eq.indeso.and.dec1.ieldec.eq.ieldec) goto 810
  882. enddo
  883. melval = ieldec
  884. c write(6,*) 'supprime deche ',nomdec,melval,deche
  885. segsup melval
  886. 810 continue
  887. segsup deche
  888. enddo
  889. endif
  890. segsup lichan
  891.  
  892. * supprime les mchaml de caracteristiques
  893. mchel1=ipcarb1
  894. do minde = 1, 2
  895. if (minde.eq.2) mchel1=ipcarb2
  896. if (mchel1.gt.0) then
  897. segact mchel1
  898. do jch1 = 1,mchel1.ichaml(/1)
  899. mchaml = mchel1.ichaml(jch1)
  900. if (mchaml.gt.0) segsup mchaml
  901. enddo
  902. segsup mchel1
  903. endif
  904. enddo
  905. c write(6,*) 'supprime caracteristiques ' , ipcarb1,ipcarb2
  906.  
  907. if (ierr.ne.0) return
  908. if (iretou.ne.0) return
  909. c
  910. c cas traitement non-local MELANGE
  911. c
  912. IF (lformu.EQ.11) THEN
  913. IF (ivamod(/1).gt.0) THEN
  914. c
  915. c rassemble les deche lies aux phases
  916. iilcon=lilmel(/1)
  917. ijlcon=0
  918. segini lilcon
  919. ipcon = lilcon
  920. do 910 ide = 1,iilcon
  921. deche = lilmel(ide)
  922. if (indec.eq.indeso.and.imadec.eq.imamod) then
  923. if (condec.eq.conmod) then
  924. ijlcon = ijlcon + 1
  925. lilcon(ijlcon) = deche
  926. else
  927. do im = 1,ivamod(/1)
  928. if (tymode(im).eq.'IMODEL') then
  929. imode1 = ivamod(im)
  930. segact imode1
  931. if ((condec.eq.imode1.conmod).or.
  932. &(nomdec(1:4).eq.imode1.conmod(17:20))) then
  933. ijlcon = ijlcon + 1
  934. lilcon(ijlcon) = deche
  935. endif
  936. endif
  937. enddo
  938. endif
  939. elseif (indec.eq.2.and.imadec.eq.imamod.and.condec.ne.conmod)
  940. &then
  941. do im = 1,ivamod(/1)
  942. if (tymode(im).eq.'IMODEL') then
  943. imode1 = ivamod(im)
  944. segact imode1
  945. if ((condec.eq.imode1.conmod).or.
  946. &(nomdec(1:4).eq.imode1.conmod(17:20))) then
  947. ijlcon = ijlcon + 1
  948. lilcon(ijlcon) = deche
  949. endif
  950. endif
  951. enddo
  952. endif
  953. 910 continue
  954. iilcon = ijlcon
  955. segadj lilcon
  956. iilcon0 = iilcon
  957.  
  958. c traite
  959. call coml9(iqmod,ipcon,ipinf,indeso,IRETOU,lesupp)
  960.  
  961. c range
  962. * complete la pile des deche en sortie
  963. lilcon = ipcon
  964. ijmel=lilmel(/1)
  965. iimel=ijmel
  966. do 920 ioc =iilcon0+1,lilcon(/1)
  967. deche = lilcon(ioc)
  968. if (indec.lt.indeso) then
  969. else if (indec.eq.indeso.and.condec.eq.conmod) then
  970. * si on a ete coherent on ne peut creer 2 fois le meme deche
  971. ijmel=ijmel+1
  972. if(ijmel.gt.iimel) then
  973. iimel=iimel+100
  974. segadj lilmel
  975. endif
  976. lilmel(ijmel) = deche
  977. c melval = ieldec
  978. c segact melval
  979. else
  980. endif
  981. 920 continue
  982. iimel=ijmel
  983. segadj lilmel
  984. c detruit
  985. segsup lilcon
  986.  
  987. c fin traitement non local MELANGE
  988. ENDIF
  989. ENDIF
  990. c
  991. if (info.ne.0) then
  992. segsup info
  993. info=0
  994. endif
  995. c
  996. *pv segdes meleme
  997. *pv segdes,imodel
  998.  
  999. 1000 CONTINUE
  1000. c------------------------------------
  1001. c fin boucle modeles elementaires
  1002. c------------------------------------
  1003.  
  1004. c Destruction du segment struli (si utilise)
  1005. if (itruli.ne.0) then
  1006. if (momoda.gt.0) then
  1007. mmode2 = momoda
  1008. segsup mmode2
  1009. endif
  1010. if (mostat.gt.0) then
  1011. mmode2 = mostat
  1012. segsup mmode2
  1013. endif
  1014. if (itbmod.gt.0) then
  1015. mmode2 = itbmod
  1016. segsup mmode2
  1017. endif
  1018. if (itlia.gt.0) then
  1019. mmode2 = itlia
  1020. segsup mmode2
  1021. endif
  1022. if (ichain.gt.0) then
  1023. mlent3 = ichain
  1024. segsup mlent3
  1025. endif
  1026. segsup struli
  1027. endif
  1028. c Destruction modele deroule
  1029. c* mmodel = impod7
  1030. segsup mmodel
  1031. segsup ipozo,izozo
  1032. c Destruction autres segments
  1033. mmode1 = IPMOD1
  1034. segsup mmode1
  1035. mchelm = IPOI1
  1036. segact,mchelm
  1037. mchaml = ichaml(1)
  1038. segsup,mchaml,mchelm
  1039.  
  1040. * call gibtem (xkt)
  1041. * write(ioimp,*) ' sortie coml2 ' , xkt
  1042.  
  1043. RETURN
  1044. END
  1045.  
  1046.  
  1047.  
  1048.  
  1049.  
  1050.  
  1051.  
  1052.  
  1053.  

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