Télécharger pron.eso

Retour à la liste

Numérotation des lignes :

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

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