Télécharger pron.eso

Retour à la liste

Numérotation des lignes :

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

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