Télécharger coml2.eso

Retour à la liste

Numérotation des lignes :

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

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