Télécharger coml2.eso

Retour à la liste

Numérotation des lignes :

  1. C COML2 SOURCE CB215821 18/09/13 21:15:15 9917
  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=19, MFORMT=MFORMC+MFORMU)
  59. CHARACTER*16 LISFOR(MFORMT)
  60. c Liste des formulations simples (cf. MODELI et NOMATE) et combinees
  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 ','MECANIQUE+LIQUID',
  68. & 'METALLURGIE '/
  69.  
  70. * call gibtem (xkt)
  71. * write(ioimp,*) ' entree coml2 ', xkt
  72. c
  73. c active modele
  74. c
  75. mmodel = ipmodl
  76. segact mmodel*nomod
  77. NSOUS = kmodel(/1)
  78. c
  79. c moterr(1:6) = 'COML2 '
  80. c moterr(7:15) = 'MMODEL '
  81. c interr(1) = mmodel
  82. c call erreur(-329)
  83. c
  84. * On cree un nouveau mmodel en deroulant le modele d'entree :
  85. * Important en cas de modele melange !
  86. i100=100
  87. segini limode
  88. c
  89. nlimod = 0
  90. nmomel = 0
  91. do im = 1, NSOUS
  92. imodel = kmodel(im)
  93. segact,imodel*nomod
  94. nlimod = nlimod+1
  95. if (nlimod.gt.i100) then
  96. i100=i100+100
  97. segadj limode
  98. endif
  99. limode(nlimod) = imodel
  100. if (formod(1)(1:8).eq.'MELANGE ') then
  101. nmomel = nmomel + 1
  102. if (matmod(1)(1:6).ne.'SERIE ') then
  103. if (ivamod(/1).ge.1) then
  104. do ivm1 = 1,ivamod(/1)
  105. if (tymode(ivm1).eq.'IMODEL ') then
  106. imode1 = ivamod(ivm1)
  107. segact imode1
  108. nlimod = nlimod+1
  109. if (nlimod.gt.i100) then
  110. i100=i100+100
  111. segadj limode
  112. endif
  113. limode(nlimod) = imode1
  114. endif
  115. enddo
  116. endif
  117. endif
  118. endif
  119. enddo
  120. *pv segdes mmodel
  121. * Ajustement du segment limode (inutile)
  122. *of i100 = nlimod
  123. *of segadj limode
  124. if (nlimod.le.0) then
  125. write(ioimp,*) 'Erreur anormale : MMODEL vide !'
  126. call erreur(5)
  127. return
  128. endif
  129. * write(ioimp,*) ' nlimod ' ,nlimod
  130. * write(ioimp,*) ' limode ',(limode(i),i=1,nlimod)
  131. * Test de non redondance des sous-modeles
  132. N1 = 1
  133. DO 1161 it1 = nlimod, 2, -1
  134. imode1 = limode(it1)
  135. DO it2 = (it1 - 1), 1, -1
  136. imode2 = limode(it2)
  137. if (imode1.EQ.imode2) then
  138. limode(it1) = 0
  139. goto 1161
  140. else if (imode1.imamod.eq.imode2.imamod .and.
  141. & imode1.conmod(1:LCONMO).eq.imode2.conmod(1:LCONMO)) then
  142. limode(it1) = 0
  143. *of segdes,imode1
  144. goto 1161
  145. endif
  146. ENDDO
  147. N1 = N1 + 1
  148. 1161 CONTINUE
  149. * Initialisation du modele de travail (ipmod7)
  150. * => Cas particulier de la formulation MELANGE :
  151. * On met les sous-modeles de formulation MELANGE a la fin du modele
  152. * de travail pour qu'ils soient traites en dernier car ils dependent
  153. * des resultats des autres sous-modeles !
  154. SEGINI,mmodel
  155. it1 = 0
  156. it2 = N1 - nmomel
  157. do im = 1, nlimod
  158. imodel = limode(im)
  159. if (imodel.gt.0) then
  160. if (formod(1)(1:8).NE.'MELANGE ') then
  161. it1 = it1 + 1
  162. kmodel(it1) = imodel
  163. else
  164. it2 = it2 + 1
  165. kmodel(it2) = imodel
  166. endif
  167. endif
  168. enddo
  169. * if (it1.ne.(N1-nmomel) .and. it2.ne.N1) then
  170. * write(ioimp,*) 'Erreur anormale : traitement MELANGE !'
  171. * call erreur(5)
  172. * return
  173. * endif
  174. NSOUS = N1
  175. ipmod7 = mmodel
  176.  
  177. * Cas particulier de la formulation LIAISON :
  178. itruli = 0
  179. struli = 0
  180. iplia = 0
  181. * Test sur la presence de la formulation LIAISON
  182. * On utilise limode pour stocker les modeles elementaires associes
  183. N1 = 0
  184. DO im = 1, NSOUS
  185. imodel = kmodel(im)
  186. if (formod(1)(1:8).EQ.'LIAISON ') then
  187. N1 = N1 + 1
  188. limode(N1) = imodel
  189. endif
  190. ENDDO
  191. * Definition du modele (iplia) associe a la seule formulation LIAISON
  192. if (N1.ne.0) then
  193. segini,mmode1
  194. DO im = 1, N1
  195. mmode1.kmodel(im) = limode(im)
  196. ENDDO
  197. iplia = mmode1
  198. * Initialisation du segment struli
  199. np1 = 0
  200. segini struli
  201. itruli = struli
  202. itlia = iplia
  203. * Remplissage avec les donnees dependant des sous-modeles MODAL / STATIQUE
  204. call comalo(ipmodl,itruli,ipmel)
  205. endif
  206. *
  207. * Destruction du segment limode (devenu inutile)
  208. segsup,limode
  209. *
  210. * Tri prealable sur les pointeurs de maillage
  211. *
  212. lilmel = ipmel
  213. iimel = lilmel(/1)
  214. * write(ioimp,*) 'iou imadec, nomdec condec indec'
  215. deche = lilmel(1)
  216. ijmin = imadec
  217. ijmax = imadec
  218. * write(ioimp,*) 1,imadec,' ',nomdec ,' ', condec,' ',indec
  219. do im = 2, iimel
  220. deche = lilmel(im)
  221. ijmin = min(ijmin,imadec)
  222. ijmax = max(ijmax,imadec)
  223. * write(ioimp,*) im,imadec,' ',nomdec ,' ', condec,' ',indec
  224. enddo
  225. * write(ioimp,*) 'lilmel(/1) ijmin ,ijmax ',iimel,ijmin,ijmax
  226. ijdif = ijmax-ijmin+1
  227. izo = max(1,ijdif/(nsous*40))
  228. * if (izo.gt.11) izo=izo/3
  229. nzo = ijdif / izo + 1
  230. * write(ioimp,*) ' nzo izo ijmax ijmin ',nzo,izo,ijmax,ijmin
  231. segini izozo
  232. do im = 1, iimel
  233. deche = lilmel(im)
  234. ivamad = imadec-ijmin
  235. izu = ivamad/izo + 1
  236. izozo(izu)=izozo(izu) + 1
  237. enddo
  238. ia = izozo(1)
  239. do im = 2 , nzo+1
  240. ia = ia + izozo(im)
  241. izozo(im) = ia
  242. enddo
  243. segini ipozo
  244. do im = 1, iimel
  245. deche = lilmel(im)
  246. ivamad=imadec-ijmin
  247. izu=ivamad/izo+1
  248. ipa=izozo(izu)
  249. ipozo(ipa)=im
  250. izozo(izu)=ipa-1
  251. enddo
  252. * write(ioimp,*) 'izozo' ,izozo(1),izozo(2),izozo(3),izozo(4)
  253. * write(ioimp,*) 'ipozo ',(ipozo(izu),izu=1,20)
  254. c
  255. mmodel = ipmod7
  256. segact,mmodel
  257. NSOUS = kmodel(/1)
  258.  
  259. * On va creer d'office un modele contenant seulement le sous-modele
  260. * elementaire (isous) au cours de la boucle (1000) utile en cas de
  261. * projection et ou de changement de support !
  262. * Attention : Il faut reactiver le sous-modele apres utilisation
  263. * pour la bonne suite du traitement du comportement.
  264. N1 = 1
  265. SEGINI,mmode1
  266. IPMOD1 = mmode1
  267. *
  268. * Idem on cree un mchaml a une sous-zone et une composante qui sera a
  269. * mettre a jour a chaque fois que besoin par le deche en cours
  270. N1 = 1
  271. L1 = 1
  272. N3 = 6
  273. SEGINI,mchelm
  274. titche = ' '
  275. conche(1) = ' '
  276. c* ifoche = 0
  277. c* imache(1) = 0
  278. c* DO i = 1, N3
  279. c* infche(1,i) = 0
  280. c* ENDDO
  281. n2 = 1
  282. SEGINI,mchaml
  283. ichaml(1) = mchaml
  284. nomche(1) = ' '
  285. typche(1) = ' '
  286. c* ielval(1) = 0
  287. IPOI1 = mchelm
  288. c
  289. c
  290. c Boucle (1000) sur les modeles elementaires
  291. c --------------------------------------------
  292. c
  293. ir10=0
  294. DO 1000 isous = 1, NSOUS
  295. *
  296. imodel = kmodel(isous)
  297. segact imodel*nomod
  298. iqmod = imodel
  299.  
  300. mmode1 = IPMOD1
  301. SEGACT,mmode1*MOD
  302. mmode1.kmodel(1) = iqmod
  303. C* SEGDES,mmode1
  304. *
  305. * write(ioimp,*) 'coml2 modele elementaire numero ',im
  306. * write(6,*) 'coml2 formulation ',formod(1),' cons ',conmod
  307. * moterr(1:6) = 'COML2 '
  308. * moterr(7:15) = 'IMODEL '
  309. * interr(1) = im
  310. * call erreur(-329)
  311. c
  312. c Determination de la formulation du modele :
  313. c
  314. nformu = FORMOD(/2)
  315. iform1 = 0
  316. CALL PLACE(LISFOR,MFORMU,iform1,FORMOD(1))
  317. lformu = iform1
  318. IF (nformu.EQ.2) THEN
  319. iform2 = 0
  320. CALL PLACE(LISFOR,MFORMU,iform2,FORMOD(2))
  321. lformu = 0
  322. IF ( (iform1.eq.2 .and. iform2.eq.3) .or.
  323. & (iform1.eq.3 .and. iform2.eq.2) ) lformu = 18
  324. ENDIF
  325. if (lformu.eq.0) then
  326. write(ioimp,*) 'COML2 : formulation non prevue ici'
  327. goto 1000
  328. endif
  329.  
  330. MELE1 =NEFMOD
  331. MELEME=IMAMOD
  332. c
  333. c Indicateur de support
  334. cof : a stocker dans un segment de travail pour la suite ?
  335. c Par defaut, on initialise le support : lesupp = 5
  336. lesupp = 5
  337. * Formulation MECANIQUE+LIQUIDE
  338. * if (lformu.eq.18) lesupp = 5
  339. * Formulation THERMIQUE then
  340. if (lformu.eq.1 .OR. lformu.EQ.19) then
  341. lesupp = 6
  342. * Formulation MECANIQUE ou POREUX ou DIFFUSION ou ELECTROSTATIQUE
  343. * else if (lformu.eq. 2 .OR. lformu.EQ. 5 .OR. lformu.EQ.16 .OR.
  344. * lformu.eq.17) then
  345. * lesupp = 5
  346. else if (lformu.eq.11) then
  347. if (ivamod(/1).gt.0) then
  348. lesupp = 5
  349. else
  350. lesupp = 3
  351. endif
  352. else if (lformu.EQ.14) then
  353. lesupp = 1
  354. endif
  355. c
  356. c cas particulier de la formulation LIAISON
  357. jtruli = 0
  358. if (lformu.EQ.14) jtruli = itruli
  359. c formulation DIFFUSION
  360. if (lformu.eq.17.and.inatuu.lt.5) goto 1000
  361. c____________________________________________________________________
  362. c
  363. c information sur l'element fini
  364. c____________________________________________________________________
  365. info = 0
  366. ipinf = 0
  367. if (infmod(/1).lt.2+lesupp) then
  368. CALL ELQUOI(MELE1,0,lesupp,IPINF,IMODEL)
  369. IF (IERR.NE.0) THEN
  370. SEGDES IMODEL*NOMOD,MMODEL*NOMOD
  371. RETURN
  372. ENDIF
  373. INFO = IPINF
  374. mfr2 = infell(13)
  375. else
  376. mfr2 = infele(13)
  377. endif
  378. *
  379. iinomp=lilmel(/1)
  380. ijnomp=0
  381. segini,linomp,igard
  382. ivamad=imamod-ijmin
  383. izu=ivamad/izo + 1
  384. * write(ioimp,*) ' ijmin izo izu ',ijmin,izo,izu
  385. if (izu.le.nzo+1.and.izu.gt.0) then
  386. ideb=izozo(izu) + 1
  387. ifin=izozo(izu+1)
  388. else
  389. ideb=1
  390. ifin=0
  391. write(ioimp,*) ' coml2 en dehors du zonage '
  392. endif
  393. do iopo=ideb,ifin
  394. idn=ipozo(iopo)
  395. * do idn = 1,lilmel(/1)
  396. deche = lilmel(idn)
  397. ***** segact deche
  398. if (imamod.eq.imadec.and.
  399. & conmod(1:LCONMO).eq.condec(1:LCONMO))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(1:LCONMO).ne.conmod(1:LCONMO)
  630. & .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(1:6).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(1:4).eq.'TEMP'.or.
  728. & nomdec(1:4).eq.'LX '.or.
  729. & nomdec(1:4).eq.'FLX '
  730. if (infdec(6).ne.lesupp.and..not.lome1.and..not.lome2) then
  731. c write(6,*) 'change ', deche, nomdec
  732. iem = indec
  733. * cree un mchaml
  734. mchelm = IPOI1
  735. segact,mchelm*MOD
  736. ifoche=ifodec
  737. conche(1) = condec
  738. imache(1) = imadec
  739. do j = 1,infdec(/1)
  740. infche(1,j) = infdec(j)
  741. enddo
  742. mchaml = ichaml(1)
  743. SEGACT,mchaml*MOD
  744. nomche(1) = nomdec
  745. typche(1) = typdec
  746. ielval(1) = ieldec
  747. c* SEGDES,mchaml,mchelm
  748. * write(6,*) ' changement de support nomdec ',nomdec
  749. call CHASUP(IPMOD1,IPOI1,IPOI2,IRET,lesupp)
  750. if (IRET.NE.0) then
  751. CALL ERREUR(IRET)
  752. return
  753. endif
  754. if (ierr.ne.0) return
  755. mchelm = ipoi2
  756. segact mchelm
  757. n1 = ichaml(/1)
  758. if (n1.ne.1) then
  759. * bizarre , contacter support
  760. moterr(17:24) = 'COML2'
  761. interr(1) = 1
  762. call erreur(943)
  763. return
  764. endif
  765. mchaml = ichaml(1)
  766. segact mchaml
  767. n2 = ielval(/1)
  768. if (n2.ne.1) then
  769. * bizarre , contacter support
  770. moterr(17:24) = 'COML2'
  771. interr(1) = 2
  772. call erreur(943)
  773. return
  774. endif
  775. * creer un deche
  776. n3 = infche(/2)
  777. segini deche
  778. indec = iem
  779. ieldec = ielval(1)
  780. typdec = typche(1)
  781. typree = typdec(1:6).eq.'REAL*8'
  782. nomdec = nomche(1)
  783. imadec = imache(1)
  784. condec = conche(1)
  785. ifodec = ifoche
  786. do in3 = 1, n3
  787. infdec(in3) = infche(1,in3)
  788. enddo
  789. segsup mchaml,mchelm
  790. * mettre dans une pile
  791. ijchan=ijchan+1
  792. if(ijchan.gt.iichan) then
  793. iichan=iichan+100
  794. segadj lichan
  795. endif
  796. lichan(ijchan) = deche
  797. endif
  798. c
  799. c write(6,*) 'lilcon ',deche,nomdec,typdec,condec,imadec,indec
  800. ijlcon=ijlcon+1
  801. if(ijlcon.gt.iilcon) then
  802. iilcon=iilcon+100
  803. segadj lilcon
  804. endif
  805. lilcon(ijlcon) = deche
  806.  
  807. 200 continue
  808. do iou=1,idej
  809. mlenti=icor(iou)
  810. if(mlenti.ne.0)segsup mlenti
  811. enddo
  812. segsup icorre
  813. 201 continue
  814.  
  815. imodel = iqmod
  816. segact imodel*nomod
  817. if (ijchan.ne.iichan) then
  818. iichan = ijchan
  819. segadj lichan
  820. endif
  821. c passe ce qui reste
  822. if (ijlcon.ne.iilcon) then
  823. iilcon=ijlcon
  824. segadj lilcon
  825. endif
  826. if (lilcon(/1).ge.1) then
  827. * call gibtem(xkt)
  828. * write(6,*) ' coml2 : appel a coml6 ', xkt
  829. * do ioup=1,lilcon(/1)
  830. * deche=lilcon(ioup)
  831. * write(6,*)deche,' ',nomdec,' ',imadec,' ',indec,' ',condec
  832. * enddo
  833. call coml6(iqmod,ipcon,ipinf,indeso,lesupp,jtruli,ir10,IRETOU)
  834.  
  835. * call gibtem(xkt)
  836. * write(6,*) ' coml2 : retour de coml6 ',xkt
  837. else
  838. c write(6,*) 'pas de composante pour le sous-model ',imodel
  839. endif
  840. * write(6,*) 'coml2 : ierr ', ierr , 'iretou ', iretou
  841. if (ierr.gt.1) return
  842.  
  843. * complete la pile des deche en sortie / desactive les DECHE et les MELVAL
  844. lilcon = ipcon
  845. ijmel=lilmel(/1)
  846. do 800 ioc =iilcon+1,lilcon(/1)
  847. deche = lilcon(ioc)
  848. ***** segact deche*nomod
  849. if (indec.lt.indeso) then
  850. else if (indec.eq.indeso.and.
  851. & condec(1:LCONMO).eq.conmod(1:LCONMO)) then
  852. * si on a ete coherent on ne peut creer 2 fois le meme deche
  853. * on ne rajoute que les deche crees sur le constituant
  854. * on ne met pas dans lilmel les deches intermediaires
  855. if (ijchan.gt.0) then
  856. do iyf = 1,ijchan
  857. if (lichan(iyf).eq.deche) goto 800
  858. enddo
  859. endif
  860. ijmel=ijmel+1
  861. if(ijmel.gt.iimel) then
  862. iimel=iimel+100
  863. segadj lilmel
  864. endif
  865. lilmel(ijmel) = deche
  866. c melval = ieldec
  867. c segact melval
  868. else
  869. endif
  870. * melval = ieldec
  871. *** segdes melval
  872. c segdes deche
  873. 800 continue
  874. iimel=ijmel
  875. segadj lilmel
  876. segsup lilcon,linomp,igard,ncop
  877.  
  878. * supprime melval intermediaire
  879. if (ijchan.gt.0) then
  880. do iop = 1,ijchan
  881. deche = lichan(iop)
  882. ******* segact deche
  883. c write(6,*) 'deche ', nomdec , indec, ieldec
  884. do il = 1,lilmel(/1)
  885. dec1 = lilmel(il)
  886. c write(6,*) 'de1 ', dec1.nomdec , dec1.indec, dec1.ieldec
  887. if (dec1.indec.eq.indeso.and.dec1.ieldec.eq.ieldec) goto 810
  888. enddo
  889. melval = ieldec
  890. c write(6,*) 'supprime deche ',nomdec,melval,deche
  891. segsup melval
  892. 810 continue
  893. segsup deche
  894. enddo
  895. endif
  896. segsup lichan
  897.  
  898. * supprime les mchaml de caracteristiques
  899. mchel1=ipcarb1
  900. do minde = 1, 2
  901. if (minde.eq.2) mchel1=ipcarb2
  902. if (mchel1.gt.0) then
  903. segact mchel1
  904. do jch1 = 1,mchel1.ichaml(/1)
  905. mchaml = mchel1.ichaml(jch1)
  906. if (mchaml.gt.0) segsup mchaml
  907. enddo
  908. segsup mchel1
  909. endif
  910. enddo
  911. c write(6,*) 'supprime caracteristiques ' , ipcarb1,ipcarb2
  912.  
  913. if (ierr.ne.0) return
  914. if (iretou.ne.0) return
  915. c
  916. c cas traitement non-local MELANGE
  917. c
  918. IF (lformu.EQ.11) THEN
  919. IF (ivamod(/1).gt.0) THEN
  920. c
  921. c rassemble les deche lies aux phases
  922. iilcon=lilmel(/1)
  923. ijlcon=0
  924. segini lilcon
  925. ipcon = lilcon
  926. do 910 ide = 1,iilcon
  927. deche = lilmel(ide)
  928. if (indec.eq.indeso.and.imadec.eq.imamod) then
  929. if (condec(1:LCONMO).eq.conmod(1:LCONMO)) then
  930. ijlcon = ijlcon + 1
  931. lilcon(ijlcon) = deche
  932. else
  933. do im = 1,ivamod(/1)
  934. if (tymode(im).eq.'IMODEL ') then
  935. imode1 = ivamod(im)
  936. segact imode1
  937. if ((condec(1:LCONMO).eq.imode1.conmod(1:LCONMO)).or.
  938. &(nomdec(1:4).eq.imode1.conmod(17:20))) then
  939. ijlcon = ijlcon + 1
  940. lilcon(ijlcon) = deche
  941. endif
  942. endif
  943. enddo
  944. endif
  945. elseif (indec.eq.2.and.imadec.eq.imamod.and.
  946. & condec(1:LCONMO).ne.conmod(1:LCONMO)) then
  947. do im = 1,ivamod(/1)
  948. if (tymode(im).eq.'IMODEL ') then
  949. imode1 = ivamod(im)
  950. segact imode1
  951. if ((condec(1:LCONMO).eq.imode1.conmod(1:LCONMO)).or.
  952. &(nomdec(1:4).eq.imode1.conmod(17:20))) then
  953. ijlcon = ijlcon + 1
  954. lilcon(ijlcon) = deche
  955. endif
  956. endif
  957. enddo
  958. endif
  959. 910 continue
  960. iilcon = ijlcon
  961. segadj lilcon
  962. iilcon0 = iilcon
  963.  
  964. c traite
  965. call coml9(iqmod,ipcon,ipinf,indeso,IRETOU,lesupp)
  966.  
  967. c range
  968. * complete la pile des deche en sortie
  969. lilcon = ipcon
  970. ijmel=lilmel(/1)
  971. iimel=ijmel
  972. do 920 ioc =iilcon0+1,lilcon(/1)
  973. deche = lilcon(ioc)
  974. if (indec.lt.indeso) then
  975. else if (indec.eq.indeso.and.
  976. C condec(1:LCONMO).eq.conmod(1:LCONMO)) then
  977. * si on a ete coherent on ne peut creer 2 fois le meme deche
  978. ijmel=ijmel+1
  979. if(ijmel.gt.iimel) then
  980. iimel=iimel+100
  981. segadj lilmel
  982. endif
  983. lilmel(ijmel) = deche
  984. c melval = ieldec
  985. c segact melval
  986. else
  987. endif
  988. 920 continue
  989. iimel=ijmel
  990. segadj lilmel
  991. c detruit
  992. segsup lilcon
  993.  
  994. c fin traitement non local MELANGE
  995. ENDIF
  996. ENDIF
  997. c
  998. if (info.ne.0) then
  999. segsup info
  1000. info=0
  1001. endif
  1002. c
  1003. *pv segdes meleme
  1004. *pv segdes,imodel
  1005.  
  1006. 1000 CONTINUE
  1007. ir10=0
  1008. c------------------------------------
  1009. c fin boucle modeles elementaires
  1010. c------------------------------------
  1011.  
  1012. c Destruction du segment struli (si utilise)
  1013. if (itruli.ne.0) then
  1014. if (momoda.gt.0) then
  1015. mmode2 = momoda
  1016. segsup mmode2
  1017. endif
  1018. if (mostat.gt.0) then
  1019. mmode2 = mostat
  1020. segsup mmode2
  1021. endif
  1022. if (itbmod.gt.0) then
  1023. mmode2 = itbmod
  1024. segsup mmode2
  1025. endif
  1026. if (itlia.gt.0) then
  1027. mmode2 = itlia
  1028. segsup mmode2
  1029. endif
  1030. if (ichain.gt.0) then
  1031. mlent3 = ichain
  1032. segsup mlent3
  1033. endif
  1034. segsup struli
  1035. endif
  1036. c Destruction modele deroule
  1037. c* mmodel = impod7
  1038. segsup mmodel
  1039. segsup ipozo,izozo
  1040. c Destruction autres segments
  1041. mmode1 = IPMOD1
  1042. segsup mmode1
  1043. mchelm = IPOI1
  1044. segact,mchelm
  1045. mchaml = ichaml(1)
  1046. segsup,mchaml,mchelm
  1047.  
  1048. * call gibtem (xkt)
  1049. * write(ioimp,*) ' sortie coml2 ' , xkt
  1050.  
  1051. RETURN
  1052. END
  1053.  
  1054.  
  1055.  
  1056.  
  1057.  
  1058.  
  1059.  
  1060.  
  1061.  
  1062.  
  1063.  
  1064.  
  1065.  

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