Télécharger pron.eso

Retour à la liste

Numérotation des lignes :

  1. C PRON SOURCE GG250959 18/01/09 21:15:18 9688
  2.  
  3. SUBROUTINE PRON(IPMODE,IPCHE,IPCHT,ISUP,IPOUT)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. *-------------------------------------------------------------------- *
  9. * *
  10. * Sous-programme appelé par l'opérateur PROI *
  11. * *
  12. * Projection d'un chamelem aux noeuds ou aux points d'integration *
  13. * des elements support du modele *
  14. * Evaluation faite au point courant par utilisation des fonctions *
  15. * de formes du modele associe au champ d origine (lu en option *
  16. * dans PRO2) ou par defaut a partir des fonctions geometriques *
  17. * associées à l'élément d origine *
  18. * *
  19. * __________________________________________________________________*
  20. * *
  21. * ENTREE : *
  22. * IPMODE modele sur lequel on va projeter *
  23. * IPCHE MCHAML de caracteristiques (si le modele comprend *
  24. * des coques) *
  25. * IPCHT MCHAML a projeter (obligatoirement defini aux noeuds)
  26. * ISUP support du resultat 1 noeuds *
  27. * 2 pts d integration contraintes*
  28. * SORTIE : *
  29. * IPOUT MCHAML resultat *
  30. * *
  31. * Projection d'un chamelem sur le support d un modele *
  32. * *
  33. *---------------------------------------------------------------------*
  34. *
  35. -INC CCOPTIO
  36. -INC CCREEL
  37. *
  38. -INC SMCOORD
  39. -INC SMMODEL
  40. -INC SMCHAML
  41. -INC SMELEME
  42. -INC SMCHPOI
  43. -INC SMLCHPO
  44. -INC SMLMOTS
  45. -INC TMTRAV
  46. -INC SMINTE
  47. character*4 nomm
  48. segment snomip
  49. character*4 nomip(0)
  50. endsegment
  51. segment ipcb(nsschp)
  52. segment icpr(2,xcoor(/1)/idim+1)
  53. C
  54. segment info
  55. integer infell(JG)
  56. endsegment
  57. C
  58. segment sicoq
  59. integer icocoq(nbsous),imfr(nbsous),iiele(nbsous)
  60. integer iminte(nbsous),imint1(nbsous),ibnap(nbsous)
  61. integer inbg(nbsous),ibbas(nbsous)
  62. endsegment
  63. C
  64. SEGMENT WRK4
  65. REAL*8 BPSS(3,3),XEL(3,NBN1) ,XU(3),SHP(6,NBN1),S(6)
  66. REAL*8 TXR(3,3,NBN1),XE(3,NBG),XEG(3,NBG3)
  67. ENDSEGMENT
  68.  
  69. SEGMENT VECT
  70. REAL*8 VEC1(IDIM)
  71. REAL*8 VEC2(IDIM)
  72. REAL*8 VECN(IDIM,NBN1*2)
  73. ENDSEGMENT
  74.  
  75. segment phachm
  76. integer iphach(nsouz)
  77. integer mphach(nsouz)
  78. endsegment
  79. LOGICAL logach
  80.  
  81. c Compteur du nombre de sous modeles de sure
  82. ISURE = 0
  83.  
  84. IPOUT = 0
  85.  
  86. MMODEL=IPMODE
  87. SEGACT,MMODEL
  88. NSOUS=KMODEL(/1)
  89. *
  90. if(IPCHE.NE.0) THEN
  91. MCHELM=IPCHE
  92. SEGACT,MCHELM
  93. NCHAM=ICHAML(/1)
  94. endif
  95. *
  96. NBNOE = XCOOR(/1)/(IDIM+1)
  97. *
  98. * Création du maillage provisoire support pour interpolation
  99. *
  100. C ipt2 contiendra les super couche au point de gauss
  101. NBSOUS = NSOUS
  102. NBREF = 0
  103. NBELEM = 0
  104. NBNN = 0
  105. SEGINI IPT2
  106. SEGINI SICOQ
  107. c listmots des phases
  108. ilphmo = -1
  109. jgn = 8
  110. jgm = nsous
  111. segini mlmots
  112. ilphmo = mlmots
  113. jgm = 1
  114. *
  115. * Boucle sur l'ensemble des sous zones du modeles sur lequel on va
  116. * projetter pour initialisations
  117. nponou=0
  118. npcoq =0
  119. *
  120. DO 30 ISOUS = 1, NSOUS
  121. *
  122. IMODEL = KMODEL(ISOUS)
  123. SEGACT,IMODEL
  124. *
  125. MELE = NEFMOD
  126. MELEME = IMAMOD
  127. SEGACT MELEME
  128. NBELE1= NUM(/2)
  129. NBN1 = NUM(/1)
  130. IF(INFMOD(/1).NE.0)THEN
  131. IF(INFMOD(1).NE.0)THEN
  132. NPINT=INFMOD(1)
  133. IBNAP(isous) =NPINT
  134. ELSE
  135. NPINT=0
  136. ibnap(isous)=1
  137. ENDIF
  138. ELSE
  139. NPINT=0
  140. ibnap(isous)=1
  141. ENDIF
  142. C
  143. if(INFMOD(/1).lt.2+isup) then
  144. call elquoi(mele,npint,isup,ipinf,imodel)
  145. if (ierr.ne.0) then
  146. segdes imodel,mmodel
  147. return
  148. endif
  149. info=ipinf
  150. mfr =infell(13)
  151. iele =infell(14)
  152. minte=infell(11)
  153. minte1=infELL(12)
  154. nbg=nbn1
  155. if(isup.eq.2) then
  156. segact minte
  157. nbg=shptot(/3)
  158. segdes minte
  159. elseif(isup.eq.3) then
  160. nbg=infell(6)
  161. elseif(isup.eq.4) then
  162. nbg=infell(3)
  163. elseif(isup.eq.5) then
  164. nbg=infell(4)
  165. endif
  166. segsup info
  167. else
  168. mfr =infele(13)
  169. iele =infele(14)
  170. minte=infmod(2+isup)
  171. minte1=infmod(8)
  172. nbg=nbn1
  173. if(isup.eq.2) then
  174. segact minte
  175. nbg=shptot(/3)
  176. segdes minte
  177. elseif(isup.eq.3) then
  178. nbg=infele(6)
  179. elseif(isup.eq.4) then
  180. nbg=infele(3)
  181. elseif(isup.eq.5) then
  182. nbg=infele(4)
  183. endif
  184. endif
  185. C
  186. imfr(isous)=mfr
  187. iiele(isous)=iele
  188. iminte(isous)=minte
  189. imint1(isous)=minte1
  190. inbg(isous)=nbg
  191. NBSOUS = 0
  192. NBREF = 0
  193. NBELEM = NBELE1
  194. IF (mfr.EQ.3.OR.mfr.EQ.5.OR.mfr.EQ.9) THEN
  195. C
  196. if(IPCHE.eq.0) then
  197. call erreur(404)
  198. segdes meleme ,imodel,mmodel
  199. return
  200. endif
  201. C
  202. C----------------------------coque ---------------------
  203. icocoq(isous) = 1
  204. npcoq = npcoq + 1
  205. C nombre de points par nappes
  206. if(isup.GT.2) then
  207. if(mfr.eq.5) then
  208. C ----------------- cas des coques epaisses
  209. if(nbg.eq.8.or.nbg.eq.6) then
  210. IBNAP(isous)=2
  211. ibbas(isous)=nbg/2
  212. else
  213. IBNAP(isous)=nbg/nbn1*2
  214. endif
  215. else
  216. ibbas(isous) = nbg/ibnap(isous)
  217. endif
  218. elseif(isup.eq.1) then
  219. ibnap(isous)=1
  220. ibbas(isous) = nbn1
  221. elseif(isup.eq.2) then
  222. ibnap(isous)= 1
  223. ibbas(isous) = 1
  224. endif
  225. *
  226. * write(6,*) 'nombre de noeuds par nappe ',
  227. * & ibbas(isous),' nappes ',ibnap(isous)
  228. *
  229. * création du maillage des points supports pour cette sz
  230. *
  231. NBNN = ibbas(isous)*ibnap(isous)
  232. nponou = nponou + nbnn*nbele1
  233. SEGINI IPT1
  234. IPT1.ITYPEL = 28
  235. ipt2.lisous(isous) = ipt1
  236. *write(6,*) 'sz ',isous ,'nbnn nbelem ipt1' ,nbnn,nbelem,ipt1
  237. segdes ipt1
  238. ELSE
  239. C-----------------------------massif ------------------------
  240. if(isup.GT.2) then
  241. NBNN = NBG
  242. elseif(isup.eq.2) then
  243. NBNN=1
  244. else
  245. NBNN= nbn1
  246. endif
  247. C
  248. SEGINI IPT1
  249. if(isup.eq.2) then
  250. else
  251. IPT1.ITYPEL = 28
  252. endif
  253. ipt2.lisous(isous) = ipt1
  254. segdes ipt1
  255. nponou=nponou+nbnn*nbele1
  256. C
  257. ENDIF
  258.  
  259. if (isous.eq.1) then
  260. mots(1) = conmod(17:24)
  261. else
  262. do ipl = 1,jgm
  263. if (mots(ipl).eq.conmod(17:24)) goto 27
  264. enddo
  265. jgm = jgm + 1
  266. mots(jgm) = conmod(17:24)
  267. 27 continue
  268. endif
  269. C
  270. segdes meleme,imodel
  271. * segsup info
  272. 30 CONTINUE
  273.  
  274. segadj mlmots
  275. C-----------------------------------------------------------
  276. C
  277. C si il y a des coques ou si l'on veut le champ aux points
  278. C d integration, on va fabriquer des points support provisoires
  279. C
  280. C----------------------------------------------------------
  281. C write(6,*) ' nombre de points crees ' ,nponou
  282. C (fdp) ajustement de MCOORD pour les noeuds provisoires
  283. C il sera remis a sa taille initiale a la fin du programme
  284. NBPTS = NBNOE + nponou
  285. SEGADJ MCOORD
  286. *-----------------------------------------------------------
  287. * Boucle sur l'ensemble des sous zones du modeles
  288. *------------------------------------------------------------
  289. inupo =NBNOE
  290. DO 100 ISOUS = 1,NSOUS
  291. IMODEL = KMODEL(ISOUS)
  292. segact imodel
  293. MELEME = IMAMOD
  294. segact meleme
  295. IF (itypel.eq.48) then
  296. ISURE = ISURE+1
  297. goto 100
  298. ENDIF
  299. nbele1= num(/2)
  300. nbn1 = num(/1)
  301. ipt1=ipt2.lisous(isous)
  302. segact ipt1*mod
  303. NNB = ibbas(isous)
  304. NBG =inbg(isous)
  305. NBG3=NBG*3
  306. SEGINI WRK4
  307. SEGINI VECT
  308. IF(ICOCOQ(ISOUS).NE.0) THEN
  309. C-----------------------------------------------------------
  310. C -------------------------------LA SZ EST UNE COQUE ------
  311. C-----------------------------------------------------------
  312. NUCHA = 0
  313. DO 15, NUCH = 1, NCHAM
  314. *
  315. IF ( CONCHE(NUCH).EQ.CONMOD.AND.
  316. & IMACHE(NUCH).EQ.IMAMOD) NUCHA = NUCH
  317. *
  318. 15 CONTINUE
  319. *
  320. IF (NUCHA.NE.0) THEN
  321. MCHAML=ICHAML(NUCHA)
  322. SEGACT,MCHAML
  323. *
  324. MELVA1 = 0
  325. MELVA2 = 0
  326. NCOMP = IELVAL(/1)
  327. DO 20, I = 1, NCOMP
  328. IF (NOMCHE(I)(1:4).EQ.'EPAI') THEN
  329. MELVA1 = IELVAL(I)
  330. SEGACT, MELVA1
  331. ELSEIF (NOMCHE(I)(1:4).EQ.'EXCE') THEN
  332. MELVA2 = IELVAL(I)
  333. SEGACT, MELVA2
  334. ENDIF
  335. 20 CONTINUE
  336. ENDIF
  337. C
  338. MELE = NEFMOD
  339. c coque integree ou pas ?
  340. if(infmod(/1).ne.0)then
  341. npint=infmod(1)
  342. else
  343. npint=0
  344. endif
  345. nbnap=ibnap(isous)
  346. mfr =imfr(isous)
  347. iele =iiele(isous)
  348. minte=iminte(isous)
  349. minte1=imint1(isous)
  350. nbg = inbg(isous)
  351. C
  352. segact minte
  353. if(mfr.eq.5) segact minte1
  354.  
  355. nnb = ibbas(isous)
  356. *-------------------------------------------------------------------
  357. * Boucle sur les elements de la sous zone du modele (c est une coque)
  358. *-------------------------------------------------------------------
  359. DO 95 iel=1, NBELE1
  360. ipo=0
  361. call doxe(xcoor,idim,nbn1,num,iel,xel)
  362. * write(6,*) ' coordonnees des noeuds '
  363. * write(6,2000) ((xel(ik,jk),ik=1,idim),jk=1,nbn1)
  364. * write(6,*) '-------------------- '
  365. 2000 format(3E12.5)
  366. * on veut les coordonnees aux point d integration et normales
  367. *
  368. IF(ISUP.GT.1) THEN
  369. C --- projection des points d'integration sur la surface moyenne--
  370. DO 601 ip=1,nnb
  371. do 600 ik=1,idim
  372. xe(ik,ip)=0.D0
  373. DO 602 jk = 1,NBN1
  374. XE(Ik,ip) = XE(Ik,ip) + SHPTOT(1,JK,ip)*(XEL(IK,jk))
  375. 602 CONTINUE
  376. 600 CONTINUE
  377. 601 CONTINUE
  378. do i=1,nnb
  379. do j=1,idim
  380. xeg(j,i)=xe(j,i)
  381. enddo
  382. enddo
  383. C ELSEIF(isup.eq.2) THEN
  384. C---------------------------- on travaille aux CDG
  385. C do ik=1,idim
  386. C xeg(ik,1)=0.D0
  387. C do ip=1,nbg
  388. C DO jk = 1,NBN1
  389. C XEG(Ik,1) = XEG(Ik,jk) + SHPTOT(1,JK,ip)*(XEL(IK,jk))
  390. C enddo
  391. C enddo
  392. C enddo
  393. ELSE
  394. C ------- on travaille aux noeuds
  395. do i=1,nbn1
  396. do j=1,idim
  397. xeg(j,i)=xel(j,i)
  398. enddo
  399. enddo
  400. ENDIF
  401. C write(6,*) ' coordonnes des points de base '
  402. C write(6,2576) (ip,(xeg(il,ip),il=1,3),ip=1,nnb)
  403. C write(6,*) ' ----------------- '
  404. 2576 format(I4,2X,3E12.5)
  405.  
  406. C----------- les normales aux points ad hoc ------------------
  407. C
  408. *--------------- coque minces 3 noeuds ---------------
  409. if(iele.eq.4) then
  410. C --------coq3 dkt dst ----------------
  411. do 98 i=1,idim
  412. VEC1(i)=xel(i,2)-xel(i,1)
  413. 98 VEC2(i)=xel(i,3)-xel(i,1)
  414. vecn(1,1) = vec1(2)*vec2(3)-vec1(3)*vec2(2)
  415. vecn(2,1) = vec1(3)*vec2(1)-vec1(1)*vec2(3)
  416. vecn(3,1) = vec1(1)*vec2(2)-vec1(2)*vec2(1)
  417. vnor =sqrt(vecn(1,1)*vecn(1,1)+vecn(2,1)*vecn(2,1)
  418. & +vecn(3,1)*vecn(3,1))
  419. do 91 i=1,idim
  420. 91 vecn(i,1)=vecn(i,1)/vnor
  421. do 99 j=2,nbn1
  422. do 99 i=1,idim
  423. 99 vecn(i,j)=vecn(i,1)
  424. C petite rectif necessaire pour le tri3
  425. if(isup.eq.2) then
  426. do j=1,idim
  427. xeg(j,1) = XZERO
  428. do ip=1,3
  429. xeg(j,1) = xeg(j,1) + xel(j,ip)
  430. enddo
  431. xeg(j,1)=xeg(j,1)/3.D0
  432. enddo
  433. endif
  434. elseif (iele.eq.8) then
  435. C --------------- coq4 ----------------
  436. call cq4loc(xel,xe,BPSS,irrt,1)
  437. C ici c est une estimation du plan moyen
  438. * write(6,fmt='(3E12.5)') ((bpss(i,j),i=1,3),j=1,3)
  439. do ip=1,ibbas(isous)
  440. do i=1,3
  441. vecn(i,ip)=bpss(3,i)
  442. enddo
  443. enddo
  444. elseif (iele.eq.2) then
  445. C ---------------- coq2 --------------
  446. vnor=0.D0
  447. do 92 i=1,idim
  448. VEC1(i)=xel(i,2)-xel(i,1)
  449. 92 vnor=vnor + vec1(i)*vec1(i)
  450. vnor = sqrt(vnor)
  451. vecn(1,1)=-vec1(2)/vnor
  452. vecn(2,1)=vec1(1)/vnor
  453. vecn(1,2)=vecn(1,1)
  454. vecn(2,2)=vecn(2,1)
  455. C
  456. elseif (iele.eq.5.or.iele.eq.10) then
  457. *----------- coques epaisses coq8 coq6
  458. if(isup.eq.1) then
  459. call cq8loc(xel,nbn1,MINTE1.SHPTOT,TXR,irr)
  460. else
  461. call cq8loc(xel,nbn1,SHPTOT,TXR,irr)
  462. endif
  463.  
  464. C write(6,*) ' normales aux points ad hoc coques epaisses'
  465. do i=1,nbn1
  466. do k=1,3
  467. vecn(k,i)=txr(k,3,i)
  468. enddo
  469. enddo
  470. 2222 format(I4,3E12.5)
  471. 2001 format(3E10.3)
  472. endif
  473. C--------------------------------------------------
  474. * write(6,*) ' normales a l element '
  475. * write(6,fmt='(3E12.5)') ((vecn(l,ip),l=1,3),ip=1,nbn1)
  476. C--------------------------------------------------
  477. C
  478. do 603 ipoi=1,nnb
  479. if(melva1.ne.0) then
  480. ibmn =MIN(iel,melva1.velche(/2))
  481. igmn =MIN(ipoi,melva1.velche(/1))
  482. epai = melva1.velche(igmn,ibmn)
  483. else
  484. epai=0.D0
  485. endif
  486. C
  487. if(melva2.ne.0) then
  488. ibmn =MIN(iel,melva2.velche(/2))
  489. igmn =MIN(ipoi,melva2.velche(/1))
  490. exce = melva2.velche(igmn,ibmn)
  491. else
  492. exce =0.D0
  493. endif
  494. C si on projette aux points d integration calcul des coordonnes
  495. C sur l element reel
  496. * on range les points sur les normales et non pas par nappes
  497. * pour ne pas chercher n fois exce et epai attention au MCHAML
  498. *
  499. do 603 inap =1,ibnap(isous)
  500. ipo=ipo+1
  501. inupo = inupo+1
  502. if(ibnap(isous).gt.1) then
  503. C if(npint.ne.0.or.mfr.eq.5) then
  504. igau=(inap-1)*inbg(isous)/ibnap(isous)+1
  505. zzz = dzegau(igau)
  506. else
  507. C zzz = (1.D0*inap-2.D0)
  508. zzz = XZERO
  509. endif
  510. dnor=exce+epai*zzz/2.D0
  511. ipt1.num(ipo,iel) =inupo
  512. do 97 i=1,idim
  513. 97 XCOOR((inupo-1)*(IDIM+1)+i) = xeg(i,ipoi)+vecn(i,ipoi)*dnor
  514. C write(6,2003) iel,ipoi,inupo-nbnoe,
  515. C & ( XCOOR((inupo-1)*(IDIM+1)+i),i=1,3),dnor,igau
  516. 603 continue
  517. C write(6,*) 'ipt1 iel ipo nbp crees ' ,
  518. C & ipt1,iel,inap,(inupo-nbnoe)
  519.  
  520. 95 CONTINUE
  521. segdes minte
  522. if(mfr.eq.5) segdes minte1
  523. 2003 format(3I4,2X,4e12.5,I4)
  524. SEGDES,MCHAML
  525. if (melva1.ne.0) segdes melva1
  526. if (melva2.ne.0) segdes melva2
  527. C
  528. C
  529. ELSEIF(ICOCOQ(ISOUS).EQ.0) THEN
  530. C---------------------------------------------------------
  531. C ---------------------------- LA SZ EST UN MASSIF ------
  532. C---------------------------------------------------------
  533. IF(ISUP.GT.1) THEN
  534. C ---------------- on travaille aux points d integration
  535. minte=iminte(isous)
  536. segact minte
  537. 2234 format(6e12.5)
  538. C
  539. DO 195 iel=1,nbele1
  540. call doxe(xcoor,idim,nbn1,num,iel,xel)
  541. C ------ PROJECTION
  542. DO 700 ip=1,shptot(/3)
  543. DO ik=1,idim
  544. XU(ik)=0.D0
  545. DO jk = 1,NBN1
  546. XU(Ik) = XU(Ik) + SHPTOT(1,JK,ip)*(XEL(IK,jk))
  547. ENDDO
  548. ENDDO
  549. inupo=inupo+1
  550. ipt1.num(ip,iel) = inupo
  551. do i=1,idim
  552. XCOOR((inupo-1)*(IDIM+1)+i) = xu(i)
  553. enddo
  554. C write(6,2223) inupo,(xu(i),i=1,idim)
  555. 700 CONTINUE
  556. 195 CONTINUE
  557. segdes minte
  558. 2223 format(I6,2X,3E12.5)
  559. ELSE
  560. C on travaille aux noeuds
  561. do 197 iel=1,nbele1
  562. call doxe(xcoor,idim,nbn1,num,iel,xel)
  563. do j=1,nbn1
  564. inupo=inupo+1
  565. ipt1.num(j,iel) = inupo
  566. do i=1,idim
  567. XCOOR((inupo-1)*(IDIM+1)+i) = xel(i,j)
  568. enddo
  569. enddo
  570. 197 continue
  571. ENDIF
  572. C fin de l'alternative coques ou massifs
  573. ENDIF
  574. C--------------------------------
  575. segdes meleme,imodel
  576. segdes ipt1
  577. SEGSUP WRK4,VECT
  578. * segsup info
  579. *
  580. 100 CONTINUE
  581. C fin de creation des noeuds supports provisoires
  582. C ENDIF
  583. * segdes ipt2
  584. C--------------//////////////////////////////////------------------
  585. C maintenant il faut un meleme poi1 de tous les points sur lesquels
  586. C on doit interpoler une valeur
  587. segini,ipt4=ipt2
  588. ipgeom=ipt4
  589. if( isup.ne.2) then
  590. call change(ipgeom,1)
  591. segsup ipt4
  592. endif
  593. C call ecrobj('MAILLAGE',ipgeom)
  594. C----------------------------------------------------------------
  595. C----------------------------------------------------------------
  596. *-------------on est pret a faire l interpolation sur ipgeom ----
  597. C
  598. *write(6,*) ' maillage apres changer poi1 ' ,ipgeom
  599. C call ecmail(ipgeom)
  600. isort=0
  601.  
  602. * write(6,*) ' dans pron appel a pro2'
  603. CALL PRO2(IPGEOM,IPCHT,isort,IPOUT,ilphmo)
  604. * write(6,*) ' dans pron sortie de pro2',nsous,ilphmo
  605. if (ierr.ne.0) return
  606. C----------------------------------------------------------------
  607. C----------------------------------------------------------------
  608. C----------------------------------------------------------------
  609. C --- il faut maintenant reconstituer les MCHAML
  610. C --- a partir du chpo construit sur ipgeom ----------------
  611. C------------ INITIALISATION du MCHAML RESULTAT ------------------
  612. mlchpo = ipout
  613. segact mlchpo
  614. nsouz = nsous
  615. segini phachm
  616. N1=NSOUS - ISURE
  617. L1=12
  618. N3=6
  619. SEGINI MCHEL1
  620. MCHEL1.TITCHE='SCALAIRE'
  621. MCHEL1.IFOCHE=IFOUR
  622.  
  623. * boucle phases modele
  624. DO 7000 IPHAS = 1,JGM
  625. * write(6,*) 'iphas ',jgm,iphas, ' mots ',mots(iphas),ichpoi(/1)
  626. segini icpr,snomip
  627. * mdata=isort
  628. * segact mdata
  629. mchpoi=ichpoi(iphas)
  630. if (mchpoi.le.0) goto 7000
  631. segact mchpoi
  632. nsschp=ipchp(/1)
  633. segini ipcb
  634. C
  635. do i=1,nsschp
  636. * mchpoi=ipca(i)
  637. C call ecchpo( mchpoi)
  638. * segact mchpoi
  639. msoupo=ipchp(i)
  640. ipcb(i)=msoupo
  641. C write(6,*) i,ipca(i),msoupo
  642. segact msoupo
  643. mpoval=ipoval
  644. segact mpoval
  645. nc = nocomp(/2)
  646. C
  647. C tableau des general des composantes
  648. do ic = 1,nc
  649. nomm= nocomp(ic)
  650. if(nomip(/2).eq.0) then
  651. nomip(**)=nomm
  652. else
  653. do k=1,nomip(/2)
  654. if(nomm.eq.nomip(k)) goto 4322
  655. enddo
  656. nomip(**)=nomm
  657. 4322 continue
  658. endif
  659. enddo
  660. * write(6,*) (nomip(l),l=1,nomip(/2))
  661. * reperage de la position ses points dans le chpo
  662. ipt5=igeoc
  663. segact ipt5
  664. do j=1,ipt5.num(/2)
  665. icpr(1,ipt5.num(1,j))=j
  666. icpr(2,ipt5.num(1,j))= i
  667. enddo
  668. enddo
  669. C i=icpr(2,k) point k venant du msoupo du msoupo i dans ipcb
  670.  
  671. kphach = 0
  672. inupo=0
  673. DO 2100 isous = 1,nsous
  674. imodel= KMODEL(isous)
  675. segact imodel
  676. if (conmod(17:24).ne.mots(iphas)) goto 2100
  677. meleme = imamod
  678. segact meleme
  679. if (itypel.eq.48) goto 2100;
  680. C
  681. ipt5=ipt2.lisous(isous)
  682. segact ipt5
  683. N2 = nomip(/2)
  684. mfr=imfr(isous)
  685. * pour une phase donnée ne cree le mchaml qu une fois par maillage
  686. * distinct
  687.  
  688. if (kphach.gt.0) then
  689. do kpha = 1,kphach
  690. if (imamod.eq.iphach(kpha)) then
  691. mchaml = mphach(kpha)
  692. logach = .true.
  693. goto 2105
  694. endif
  695. enddo
  696. * création du nouveau segment MCHAML
  697. SEGINI MCHAML
  698. kphach = kphach + 1
  699. iphach(kphach) = imamod
  700. mphach(kphach) = mchaml
  701. logach = .false.
  702. else
  703. * création du nouveau segment MCHAML
  704. SEGINI MCHAML
  705. kphach = kphach + 1
  706. iphach(kphach) = imamod
  707. mphach(kphach) = mchaml
  708. logach = .false.
  709. endif
  710.  
  711. 2105 MCHEL1.IMACHE(isous)=MELEME
  712. MCHEL1.ICHAML(isous)=MCHAML
  713. MCHEL1.CONCHE(isous)=CONMOD
  714. MCHEL1.INFCHE(isous,1)=0
  715. MCHEL1.INFCHE(isous,2)=0
  716. MCHEL1.INFCHE(isous,3)=NIFOUR
  717. IF(isup.eq.1) then
  718. MCHEL1.INFCHE(isous,4)=0
  719. MCHEL1.INFCHE(isous,5)=0
  720. MCHEL1.INFCHE(isous,6)=1
  721. ELSE
  722. MCHEL1.INFCHE(isous,4)=iminte(isous)
  723. MCHEL1.INFCHE(isous,5)=0
  724. MCHEL1.INFCHE(isous,6)=isup
  725. ENDIF
  726. *
  727. if (logach) goto 2100
  728.  
  729. N1EL=NUM(/2)
  730. N2PTEL=0
  731. N2EL=0
  732. C
  733. IF(ICOCOQ(ISOUS).EQ.1) THEN
  734. C--------------------------------------------------------
  735. C boucle sur les composantes et c est une coque
  736. C--------------------------------------------------------
  737. inocom=0
  738. DO 2200 icomp=1,nomip(/2)
  739. inocom=inocom+1
  740. *write(6,*) 'composante ', nomip(icomp)
  741. idebco = inupo
  742.  
  743. C N1PTEL= NUM(/1)*nbnap
  744. N1PTEL= nnb*nbnap
  745. SEGINI MELVAL
  746. IELVAL(inocom)= MELVAL
  747. NOMCHE(inocom)= NOCOMP(icomp)
  748. TYPCHE(inocom)= 'REAL*8'
  749. C
  750. DO 162 NUEL=1,num(/2)
  751. DO 162 NUPT=1,nnb
  752. DO 172 IPOS = 1,nbnap
  753. ipop = (ipos-1)*nnb+nupt
  754. inupo = ipt5.num(ipop,nuel)
  755. jh=icpr (1,inupo)
  756. ipa=icpr(2,inupo)
  757. if(jh.eq.0) go to 172
  758. C il faut verifier si vpocha existe pour ce point
  759. msoupo = ipcb(ipa)
  760. mpoval=ipoval
  761. do l=1,nocomp(/2)
  762. if(nocomp(l).eq.nomip(icomp)) then
  763. vvv=vpocha(jh,icomp)
  764. goto 4557
  765. endif
  766. enddo
  767. vvv=XZERO
  768. 4557 continue
  769. C write(6,2004) NUEL,inupo,jh,ipop,
  770. C & ( XCOOR((inupo+nbnoe-1)*(IDIM+1)+i),i=1,3),vvv
  771. VELCHE(ipop,NUEL) = vvv
  772. 172 CONTINUE
  773. 162 CONTINUE
  774.  
  775. if(icomp.lt.nocomp(/2)) inupo =idebco
  776. 2200 continue
  777.  
  778. ELSE
  779. C--------------------------------------------------------
  780. C boucle sur les composantes et c est un massif
  781. C--------------------------------------------------------
  782.  
  783. if(isup.eq.1) then
  784. N1PTEL=NUM(/1)
  785. elseif(isup.eq.2) then
  786. N1PTEL=1
  787. else
  788. N1PTEL= inbg(isous)
  789. endif
  790. C
  791. DO 2220 icomp=1,NOMIP(/2)
  792. * write(6,*) 'composante ', nomip(icomp)
  793. idebco = inupo
  794. C
  795.  
  796. SEGINI MELVAL
  797. NOMCHE(icomp)=nomip(icomp)
  798. TYPCHE(icomp)='REAL*8'
  799. IELVAL(icomp)=MELVAL
  800. C
  801. DO 163 NUEL=1,N1EL
  802. DO 163 NUPT=1,N1PTEL
  803. inupo=ipt5.num(nupt,nuel)
  804. jh=icpr(1,inupo)
  805. ipa=icpr(2,inupo)
  806. if(jh.eq.0) go to 163
  807. C il faut verifier si vpocha existe pour ce point
  808. msoupo = ipcb(ipa)
  809. mpoval=ipoval
  810. do l=1,nocomp(/2)
  811. if(nocomp(l).eq.nomip(icomp)) then
  812. vvv=vpocha(jh,icomp)
  813. goto 4558
  814. endif
  815. enddo
  816. vvv=XZERO
  817. 4558 continue
  818.  
  819. C write(6,2003) NUEL,inupo,jh,
  820. C & ( XCOOR((inupo+nbnoe-1)*(IDIM+1)+i),i=1,3),vvv
  821. VELCHE(NUPT,NUEL) = vvv
  822. 163 CONTINUE
  823. ipcham= mchaml
  824. ipc1 = melval
  825. call comred(ipc1)
  826. melval = ipc1
  827. segdes melval
  828. if(icomp.lt.nocomp(/2)) inupo =idebco
  829. C ---- fin de la boucle sur les composantes
  830. 2220 continue
  831. segdes mchaml,meleme
  832.  
  833. C---------------- fin du traitement des massifs
  834. ENDIF
  835. segdes imodel,meleme
  836. segsup ipt5
  837. C fin de la boucle sur les sous zones du modele
  838. 2100 continue
  839. C destruction des chpo intermediaires
  840. do i=1,ipcb(/1)
  841. msoupo=ipcb(i)
  842. cgf ipt5= igeoc (correction 7284)
  843. mpoval= ipoval
  844. * mchpoi=ipca(i)
  845. segsup mpoval,msoupo
  846. cgf segsup ipt5 (correction 7284)
  847. enddo
  848. segsup mchpoi
  849. segsup ipcb,snomip
  850. segsup icpr
  851. 7000 CONTINUE
  852. C (fdp) re-ajustement de MCOORD a sa taille initiale
  853. NBPTS = NBNOE
  854. SEGADJ MCOORD
  855. C retrait des maillages temporaires du pre-conditionnement
  856. c (leurs numero de noeuds depasse la taille de MCOOR)
  857. call crech1b
  858. C (fdp) suppression du maillage temporaire IPT1
  859. ipt1=ipgeom
  860. segsup ipt1
  861. segsup ipt2
  862. segsup phachm
  863. segdes mchel1,mmodel
  864. if(ipche.ne.0) then
  865. mchelm=ipche
  866. segdes mchelm
  867. endif
  868. IPOUT=MCHEL1
  869. segsup sicoq
  870.  
  871. return
  872. END
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879.  

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