Télécharger cmacro.eso

Retour à la liste

Numérotation des lignes :

  1. C CMACRO SOURCE CHAT 05/01/12 22:09:05 5004
  2. SUBROUTINE CMACRO
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C************************************************************************
  6. C Ce sp transforme des elemnts quadratique d'un type pris
  7. C dans la liste ci-dessous
  8. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  9. C 3 6 10 15 17 24 26
  10. C
  11. C en les éléments correspondant MACRO (iso p2 ou q2) de la liste
  12. C ci-dessous
  13. C
  14. C SEG3 TRI6 QUA9 CU27 PR18 TE10 PY14
  15. C 3 6 11 33 40 24 ??
  16. C************************************************************************
  17. -INC SMELEME
  18. -INC SMCOORD
  19. -INC CCOPTIO
  20. -INC SMLENTI
  21. SEGMENT TRAV
  22. INTEGER IFAC4(4,NBFTM)
  23. ENDSEGMENT
  24. SEGMENT TRAV1
  25. INTEGER NUMF4(9,NBFTM)
  26. ENDSEGMENT
  27. SEGMENT SITAB
  28. INTEGER ITAB(NPA,NBATM)
  29. ENDSEGMENT
  30. SEGMENT SITAC
  31. INTEGER ITAC(NBMAX,NNMAX)
  32. ENDSEGMENT
  33. SEGMENT SITAF
  34. INTEGER ITAF(NBFAX,MMMAX)
  35. ENDSEGMENT
  36. SEGMENT TRAV2
  37. INTEGER NUF(6,NBELT)
  38. ENDSEGMENT
  39. SEGMENT CARA
  40. INTEGER KM(6,NBSOU1)
  41. ENDSEGMENT
  42.  
  43. DIMENSION IAR(3,35),IFR(4,20)
  44. DATA IAR /1,2,3,3,4,5,5,6,7,7,8,1,
  45. & 1,9,13,3,10,15,5,11,17,7,12,19,
  46. & 13,14,15,15,16,17,17,18,19,19,20,13,
  47. & 1,2,3,3,4,5,5,6,1,1,7,10,3,8,12,5,9,14,
  48. & 10,11,12,12,13,14,14,15,10,
  49. & 1,2,3,3,4,5,5,6,1,1,7,10,3,8,10,5,9,10,
  50. & 1,2,3,3,4,5,5,6,7,7,8,1,1,9,13,3,10,13,
  51. & 5,11,13,7,12,13/
  52.  
  53. DATA IFR /1,6,9,5, 2,7,10,6, 3,8,11,7, 4,5,12,8,
  54. & 1,2,3,4, 9,10,11,12,
  55. & 1,5,7,4, 2,6,8,5, 3,4,9,6, 1,2,3,0, 7,8,9,0,
  56. & 1,2,3,0, 1,5,4,0, 2,6,5,0, 3,6,4,0,
  57. & 1,2,3,4, 1,6,5,0, 2,7,6,0, 3,8,7,0, 4,5,8,0/
  58.  
  59. C Nb de pts par face par type elt
  60. DIMENSION KNPF(6,7)
  61. DATA KNPF/1,1,0,0,0,0,
  62. & 3,3,3,0,0,0,
  63. & 3,3,3,3,0,0,
  64. & 8,8,8,8,8,8,
  65. & 8,8,8,6,6,0,
  66. & 6,6,6,6,0,0,
  67. & 8,6,6,6,6,0/
  68.  
  69. C Nb d'arretes par face par type elt
  70. DIMENSION KNAF(6,7)
  71. DATA KNAF/0,0,0,0,0,0,
  72. & 0,0,0,0,0,0,
  73. & 0,0,0,0,0,0,
  74. & 4,4,4,4,4,4,
  75. & 4,4,4,3,3,0,
  76. & 3,3,3,3,0,0,
  77. & 4,3,3,3,3,0/
  78.  
  79. DIMENSION INF(8,20)
  80. C CU20
  81. DATA INF/1,2,3,10,15,14,13,9, 3,4,5,11,17,16,15,10,
  82. & 5,6,7,12,19,18,17,11, 7,8,1,9,13,20,19,12,
  83. & 1,2,3,4,5,6,7,8, 13,14,15,16,17,18,19,20,
  84. C PR15
  85. & 1,2,3,8 ,12,11,10,7, 3,4,5,9 ,14,13,12,8 ,
  86. & 5,6,1,7,10,15,14,9 , 1,2,3,4,5,6,0,0,
  87. & 10,11,12,13,14,15,0,0,
  88. C TE10
  89. & 1,2,3,4,5,6,0,0, 1,2,3,8,10,7,0,0, 3,4,5,9,10,8,0,0,
  90. & 1,6,5,9,10,7,0,0,
  91. C PY15
  92. & 1,2,3,4,5,6,7,8, 1,2,3,10,13,9,0,0, 3,4,5,11,13,10,0,0,
  93. & 5,6,7,12,13,11,0,0, 7,8,1,9,13,12,0,0/
  94.  
  95.  
  96. DIMENSION NUA(12),NUMA(4),XA(3,21),KTA(7,9)
  97. DATA KTA/3,6,10,15,17,24,26,
  98. & 3,6,11,33,40,24,00,
  99. C nb de faces 5? 4? 5?
  100. & 2,3,4 ,6 ,3 ,0 ,1 ,
  101. C nb d'arretes
  102. & 0,3,4 ,12,9 ,6 ,8,
  103. C Idec
  104. & 0,0,0 ,0 ,12,21,27,
  105. C Idc3
  106. & 0,0,0 ,0 ,6 ,11,15,
  107. C Nbnn
  108. & 3,6,9 ,27,18,15,14,
  109. C NP
  110. & 3,6,8 ,20,15,10,13,
  111. C IDF
  112. & 0,0,0 ,0 ,6 ,11,15/
  113.  
  114. C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13
  115. C 3 6 10 15 17 24 26
  116. C SEG3 TRI6 QUA9 CU27 PR18 TE10 PY14
  117. C 3 6 11 33 40 24 ??
  118.  
  119. C*************************************************************
  120.  
  121. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  122. IF(IRET.EQ.0)RETURN
  123.  
  124. SEGACT MELEME
  125. NBSOU1=LISOUS(/1)
  126. IF(NBSOU1.EQ.0)NBSOU1=1
  127. C write(6,*)' SUB CMACRO '
  128.  
  129. C On vérifie qu'il y a quelque chose à faire
  130.  
  131. DO 12 L=1,NBSOU1
  132. IPT1=MELEME
  133. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  134. SEGACT IPT1
  135. ITYP=IPT1.ITYPEL
  136. IKR=0
  137. DO 112 I=1,7
  138. IF(ITYP.EQ.KTA(I,2))IKR=I
  139. 112 CONTINUE
  140. IF(IKR.EQ.0)GO TO 212
  141. SEGDES IPT1
  142. 12 CONTINUE
  143. SEGDES MELEME
  144. CALL ECROBJ('MAILLAGE',MELEME)
  145. C write(6,*)'CMACRO il n y a rien a faire '
  146.  
  147. RETURN
  148.  
  149. 212 CONTINUE
  150.  
  151. SEGINI CARA
  152.  
  153. NBELT=0
  154. NBELC=0
  155. DO 11 L=1,NBSOU1
  156. IPT1=MELEME
  157. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  158. SEGACT IPT1
  159. ITYP=IPT1.ITYPEL
  160. IK=0
  161. DO 111 I=1,7
  162. IF(ITYP.EQ.KTA(I,1))IK=I
  163. 111 CONTINUE
  164.  
  165. IF(IK.EQ.0)THEN
  166. CALL ERREUR(29)
  167. RETURN
  168. ENDIF
  169.  
  170.  
  171. NP =IPT1.NUM(/1)
  172. NBELEM=IPT1.NUM(/2)
  173. IF(IK.EQ.3.OR.IK.EQ.4)THEN
  174. NBELC=NBELC+NBELEM
  175. ENDIF
  176. IF(IK.GT.1)THEN
  177. NBELT=NBELT+NBELEM
  178. ENDIF
  179. KM(1,L)=NBELEM
  180. KM(2,L)=IPT1
  181.  
  182. KM(3,L)=IK
  183. C nb d'aretes par element
  184. KM(4,L)=KTA(IK,4)
  185. C nb de faces
  186. KM(5,L)=KTA(IK,3)
  187. SEGDES IPT1
  188. 11 CONTINUE
  189.  
  190. NBPT=XCOOR(/1)/(IDIM+1)
  191. JG=NBPT
  192. SEGINI MLENTI,MLENT1
  193.  
  194. NPA=3
  195. NBATM=5*NBELT+500
  196. SEGINI SITAB
  197.  
  198. NBMAX=4+1
  199. NNMAX=3*NBELT+300
  200. NBFAX=4+1
  201. MMMAX=3*NBELT+300
  202. SEGINI SITAF,SITAC
  203.  
  204. NBFTM=5*NBELT+500
  205. SEGINI TRAV,TRAV1,TRAV2
  206.  
  207. SEGACT MELEME
  208.  
  209. NBFT4=0
  210. NBAT=0
  211. NN=0
  212. MM=0
  213.  
  214. NK=0
  215. DO 1 L=1,NBSOU1
  216. IK=KM(3,L)
  217.  
  218. IPT1=MELEME
  219. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  220. SEGACT IPT1
  221. NBELEM=IPT1.NUM(/2)
  222. NP =IPT1.NUM(/1)
  223. C write(6,*)' ITYP,NBELEM=',ITYP,NBELEM
  224.  
  225. IF(IK.NE.4.AND.IK.NE.5.AND.IK.NE.7)GO TO 1
  226.  
  227. IDEC=KTA(IK,5)
  228. IDC3=KTA(IK,6)
  229. IDF =KTA(IK,9)
  230. NBA=KTA(IK,4)
  231. NBF=KTA(IK,3)
  232. C write(6,*)' NBA,NBF,NPF=',NBA,NBF
  233.  
  234. DO 2 K=1,NBELEM
  235. NK=NK+1
  236.  
  237. DO 5 NA=1,NBA
  238. N1=IPT1.NUM(IAR(1,NA+IDEC),K)
  239. N2=IPT1.NUM(IAR(3,NA+IDEC),K)
  240. IF(N1.GT.N2)THEN
  241. NM=N2
  242. N2=N1
  243. N1=NM
  244. ENDIF
  245. NM=IPT1.NUM(IAR(2,NA+IDEC),K)
  246.  
  247. IF(LECT(N1).EQ.0)THEN
  248. C le sommet n'a pas encore été touché
  249. NBAT=NBAT+1
  250. IF(NBAT.GT.NBATM)THEN
  251. C write(6,*)' Taille ITAB 2ème dime insuffisante NBATM=',NBATM
  252. NBATM=NBATM+NBELEM
  253. C write(6,*)' NBATM=',nbatm,' NPA=',npa,nbat
  254. SEGADJ SITAB
  255. ENDIF
  256.  
  257. NN=NN+1
  258.  
  259. IF(NN.GT.NNMAX)THEN
  260. C write(6,*)' Taille ITAC 2eme dime insuffisante NN=',NN
  261. NNMAX=NNMAX+NBELEM
  262. SEGADJ SITAC
  263. ENDIF
  264.  
  265. LECT(N1)=NN
  266. ITAC(1,NN)=1
  267. ITAC(1+1,NN)=NBAT
  268. C write(6,*)' NBAT=',nbat,' nn=',nn,' NB=',ITAC(1,NN),nbat
  269. NUA(NA)=NBAT
  270. ITAB(1,NBAT)=N1
  271. ITAB(2,NBAT)=NM
  272. ITAB(3,NBAT)=N2
  273. GO TO 5
  274. ENDIF
  275.  
  276. C On cherche si l'arrete existe deja dans la table ITAC
  277. NN1=LECT(N1)
  278. NB=ITAC(1,NN1)
  279. DO 31 II=1,NB
  280. I=ITAC(II+1,NN1)
  281. IF(N2.EQ.ITAB(3,I).AND.NM.EQ.ITAB(2,I))THEN
  282. NUA(NA)=I
  283. GO TO 5
  284. ENDIF
  285. 31 CONTINUE
  286.  
  287. IF(NB.LT.(NBMAX-1))THEN
  288. C l'arrete n existe pas dans la table ITAC qui n'est pas pleine
  289. C On peut donc considerer que l'arrete est nouvelle
  290. NBAT=NBAT+1
  291. ITAC(1,NN1)=NB+1
  292. ITAC(NB+2,NN1)=NBAT
  293. C write(6,*)' NBAT=',nbat,' nn1=',nn1,' NB=',ITAC(1,NN1),nbat
  294. NUA(NA)=NBAT
  295. ITAB(1,NBAT)=N1
  296. ITAB(2,NBAT)=NM
  297. ITAB(3,NBAT)=N2
  298. GO TO 5
  299. ENDIF
  300.  
  301. C write(6,*)' Taille ITAC 1ere dime insuffisante NB=',NB
  302. NBMAX=NBMAX+2
  303. SEGADJ SITAC
  304. C On fait une recherche parmis toutes les arretes existantes
  305.  
  306. DO 3 I=1,NBAT
  307. IF(N2.EQ.ITAB(3,I).AND.NM.EQ.ITAB(2,I))THEN
  308. NUA(NA)=I
  309. GO TO 5
  310. ENDIF
  311. 3 CONTINUE
  312.  
  313. NBAT=NBAT+1
  314. ITAC(1,NN1)=NB+1
  315. ITAC(NB+2,NN1)=NBAT
  316. NUA(NA)=NBAT
  317. ITAB(1,NBAT)=N1
  318. ITAB(2,NBAT)=NM
  319. ITAB(3,NBAT)=N2
  320.  
  321. 5 CONTINUE
  322.  
  323. C write(6,*)' BCL 6 NBF=',nbf
  324. DO 6 NF=1,NBF
  325. C nb de pts par faces
  326. NPF=KNPF(NF,IK)
  327. C write(6,*)' NPF=',npf
  328. IF(NPF.NE.8)GO TO 6
  329. C nb d'arretes par faces
  330. NAF=KNAF(NF,IK)
  331.  
  332. DO 61 NFA=1,NAF
  333. NUMA(NFA)=NUA(IFR(NFA,NF+IDF))
  334. 61 CONTINUE
  335.  
  336. CALL ORDOTA(NUMA,NAF)
  337. IF(MLENT1.LECT(NUMA(1)).EQ.0)THEN
  338. C l'arrete n'a pas encore été touché
  339. NBFT4=NBFT4+1
  340.  
  341. IF(NBFT4.GT.NBFTM)THEN
  342. C write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
  343. NBFTM=NBFTM+NBELEM
  344. SEGADJ TRAV,TRAV1
  345. ENDIF
  346.  
  347. NUMF4(9,NBFT4)=NPF
  348. DO 621 I=1,NPF
  349. NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
  350. 621 CONTINUE
  351. MM=MM+1
  352.  
  353. IF(MM.GT.MMMAX)THEN
  354. C write(6,*)' Taille ITAF 2eme dime insuffisante MM=',MM
  355. MMMAX=MMMAX+NBELEM
  356. SEGADJ SITAF
  357. ENDIF
  358.  
  359. MLENT1.LECT(NUMA(1))=MM
  360. ITAF(1,MM)=1
  361. ITAF(1+1,MM)=NBFT4
  362. C write(6,*)' NBFT4=',nbft4,' mm=',mm,' NB=',ITAF(1,mm)
  363. C write(6,*)' NUF(NF,NK)=',NBFT4,' NF=',nf,'nk=',nk
  364. NUF(NF,NK)=NBFT4
  365. CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
  366. GO TO 6
  367. ENDIF
  368.  
  369. C On cherche si la face existe déja dans la table ITAF
  370. MM1=MLENT1.LECT(NUMA(1))
  371. NB=ITAF(1,MM1)
  372. DO 631 II=1,NB
  373. I=ITAF(II+1,MM1)
  374. IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I)
  375. & .AND.NUMA(1).EQ.IFAC4(1,I))THEN
  376. NUF(NF,NK)=I
  377. C write(6,*)' i NUF(NF,NK)=',i,' NF=',nf,'nk=',nk
  378. GO TO 6
  379. ENDIF
  380. 631 CONTINUE
  381.  
  382. IF(NB.LT.(NBFAX-1))THEN
  383. C la face n'existe pas dans la table ITAF qui n'est pas pleine
  384. C On peut donc considerer que la face est nouvelle
  385. NBFT4=NBFT4+1
  386.  
  387. IF(NBFT4.GT.NBFTM)THEN
  388. C write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
  389. NBFTM=NBFTM+NBELEM
  390. C write(6,*)' NBFTM=',NBFTM,NBELEM
  391. SEGADJ TRAV,TRAV1
  392. ENDIF
  393.  
  394. NUMF4(9,NBFT4)=NPF
  395. DO 622 I=1,NPF
  396. NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
  397. 622 CONTINUE
  398. ITAF(1,MM1)=NB+1
  399. ITAF(NB+2,MM1)=NBFT4
  400. C write(6,*)' NBFT4=',NBFT4,' mm1=',mm1,' NB=',ITAF(1,mm1)
  401. NUF(NF,NK)=NBFT4
  402. C write(6,*)' 2 NUF(NF,NK)=',nbft4,' NF=',nf,'nk=',nk
  403. CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
  404. GO TO 6
  405. ENDIF
  406.  
  407. C write(6,*)' Taille ITAF 1ere dime insuffisante NB=',NB
  408. NBFAX=NBFAX+2
  409. SEGADJ SITAF
  410. C On fait une recherche parmis toutes les faces existantes
  411.  
  412.  
  413. IF(NAF.EQ.4)THEN
  414. DO 7 I=1,NBFT4
  415. IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I)
  416. & .AND.NUMA(1).EQ.IFAC4(1,I))THEN
  417. C write(6,*)' 3 NUF(NF,NK)=',i,' NF=',nf,'nk=',nk
  418. NUF(NF,NK)=I
  419. GO TO 6
  420. ENDIF
  421. 7 CONTINUE
  422. ELSEIF(NAF.EQ.3)THEN
  423. DO 71 I=1,NBFT4
  424. IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I))THEN
  425. C write(6,*)' 4 NUF(NF,NK)=',i,' NF=',nf,'nk=',nk
  426. NUF(NF,NK)=I
  427. GO TO 6
  428. ENDIF
  429. 71 CONTINUE
  430. ENDIF
  431.  
  432.  
  433. 64 CONTINUE
  434. NBFT4=NBFT4+1
  435.  
  436. IF(NBFT4.GT.NBFTM)THEN
  437. C write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4
  438. NBFTM=NBFTM+NBELEM
  439. SEGADJ TRAV,TRAV1
  440. ENDIF
  441.  
  442. ITAF(1,MM1)=NB+1
  443. ITAF(NB+2,MM1)=NBFT4
  444. NUMF4(9,NBFT4)=NPF
  445. DO 623 I=1,NPF
  446. NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K)
  447. 623 CONTINUE
  448. NUF(NF,NK)=NBFT4
  449. C write(6,*)' 5 NUF(NF,NK)=',NBFT4,' NF=',nf,'nk=',nk
  450. CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF)
  451.  
  452. 6 CONTINUE
  453. 2 CONTINUE
  454. 1 CONTINUE
  455.  
  456. C write(6,*)' Fin bcl 1 '
  457. C**********************************************************
  458.  
  459. SEGSUP SITAB,SITAC,SITAF,MLENTI,MLENT1,TRAV
  460.  
  461. C**********************************************************
  462.  
  463. SEGACT MELEME
  464.  
  465. NK=0
  466. NC=0
  467. DO 80 L=1,NBSOU1
  468. IK=KM(3,L)
  469. NBF=KTA(IK,3)
  470.  
  471. IF(IK.EQ.1.OR.IK.EQ.2.OR.IK.EQ.6)GO TO 80
  472.  
  473. IPT1=MELEME
  474. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  475. SEGACT IPT1
  476.  
  477. NBELEM=KM(1,L)
  478. NBNN =KTA(IK,7)
  479. NP =KTA(IK,8)
  480.  
  481. NBSOUS=0
  482. NBREF=0
  483. SEGINI IPT2
  484. KM(2,L)=IPT2
  485. IPT2.ITYPEL=KTA(IK,2)
  486. C write(6,*)' IPT2=',ipt2,
  487. C & ' L=',l,' nbnn=',nbnn,' nbelem=',nbelem,' IK=',ik
  488.  
  489. IF(IK.GE.4)THEN
  490. C CU27 & PR18 & PY14
  491. IDC3=KTA(IK,6)
  492.  
  493. DO 83 K=1,NBELEM
  494. NK=NK+1
  495. DO 8 I=1,NP
  496. IPT2.NUM(I,K)=IPT1.NUM(I,K)
  497. 8 CONTINUE
  498. C write(6,*)' 81 ::: nbf=',nbf,' np=',np,nbelc
  499. DO 81 I=1,NBF
  500. IPT2.NUM(I+NP,K)=NBPT+NBELC+NUF(I,NK)
  501. 81 CONTINUE
  502. IF(IK.EQ.4)THEN
  503. NC=NC+1
  504. IPT2.NUM(NBNN,K)=NBPT+NC
  505. ENDIF
  506. 83 CONTINUE
  507.  
  508. ELSEIF(IK.EQ.3)THEN
  509. NP=NBNN-1
  510. DO 84 K=1,NBELEM
  511. NC=NC+1
  512. DO 88 I=1,NP
  513. IPT2.NUM(I,K)=IPT1.NUM(I,K)
  514. 88 CONTINUE
  515. IPT2.NUM(9,K)=NBPT+NC
  516. 84 CONTINUE
  517.  
  518. ENDIF
  519.  
  520. SEGDES IPT1,IPT2
  521. 80 CONTINUE
  522.  
  523. C write(6,*)' NUF '
  524. C DO 783 K=1,NBELC
  525. C write(6,1011)K,(NUF(i,k),i=1,6)
  526. C783 continue
  527.  
  528. C do 784 k=1,nbft4
  529. C write(6,1011)K,(NUMF4(i,k),i=1,9)
  530. C784 continue
  531.  
  532. C write(6,*)' NBPT=',nbpt
  533. C write(6,*)' NBAT=',nbat
  534. C write(6,*)' NBELT=',NBELT,' NBFT4=',nbft4
  535. C write(6,*)' NBELC=',NBELC
  536.  
  537. NBPTS=NBPT+NBELC+NBFT4
  538. IF(NBPTS.GT.NBPT)SEGADJ MCOORD
  539.  
  540. C************** On calcule les coordonnées des points ***********
  541. C write(6,*)' NBPT=',nbpt,(NBPT+NBELC)
  542.  
  543.  
  544. IF(NBFT4.NE.0)THEN
  545.  
  546. C write(6,*)' NBFT4=',nbft4,' NBELC=',nbelc
  547. C write(6,*)' NUMF4 ='
  548. DO 23 J=1,NBFT4
  549.  
  550. C write(6,1001)' NUMF4 =',j,(numf4(ii,j),ii=1,9)
  551. NPF=NUMF4(9,J)
  552. C write(6,*)' NPF=',npf
  553. DO 21 I=1,NPF
  554. N1=NUMF4(I,J)
  555. DO 21 M=1,IDIM
  556. XA(M,I)=XCOOR((N1-1)*(IDIM+1) +M)
  557. 21 CONTINUE
  558.  
  559. CALL FFFACE(XA,NPF)
  560.  
  561. N9=NBPT+NBELC+J
  562. C write(6,*)' N9=',n9,(XA(M,NPF+1),m=1,idim)
  563. DO 22 M=1,IDIM
  564. XCOOR((N9-1)*(IDIM+1) +M)=XA(M,NPF+1)
  565. 22 CONTINUE
  566. 23 CONTINUE
  567. ENDIF
  568.  
  569.  
  570. IF(NBELC.NE.0)THEN
  571. C write(6,*)' On calcule les coordonnées du pt centre ',NBELC
  572. SEGACT MELEME
  573. NC=0
  574. DO 90 L=1,NBSOU1
  575.  
  576. IK=KM(3,L)
  577. IF(IK.EQ.1)GO TO 90
  578. IF(IK.NE.3.AND.IK.NE.4)GO TO 90
  579. IPT1=MELEME
  580. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  581. SEGACT IPT1
  582.  
  583. NBELEM=KM(1,L)
  584. NBNN =KTA(IK,7)
  585. NP =KTA(IK,8)
  586.  
  587. IPT2=KM(2,L)
  588.  
  589. DO 24 K=1,NBELEM
  590. NC=NC+1
  591. CALL INITD(XA(1,21),IDIM,0.D0)
  592. DO 25 I=1,NP
  593. N1=IPT1.NUM(I,K)
  594. DO 25 M=1,IDIM
  595. XA(M,I)=XCOOR((N1-1)*(IDIM+1) +M)
  596. XA(M,21)=XA(M,21)+XA(M,I)
  597. 25 CONTINUE
  598.  
  599. N18=NBPT+NC
  600. C write(6,*)' *** NK=',nk,NBELT,L,' N18=',n18
  601. C write(6,1001)(xa(m,21),m=1,3)
  602. DO 26 M=1,IDIM
  603. XCOOR((N18-1)*(IDIM+1) +M)=XA(M,21)/FLOAT(NP)
  604. 26 CONTINUE
  605. 24 CONTINUE
  606.  
  607. 90 CONTINUE
  608.  
  609. ENDIF
  610.  
  611.  
  612. C write(6,*)' NBPT=',nbpt
  613. C write(6,*)' NBAT=',nbat
  614. C do 116 l=1,nbat
  615. C write(6,1011)L,(itab(i,l),i=1,3)
  616. C116 continue
  617.  
  618. C write(6,*)' LECT '
  619. C write(6,1001)(lect(ii),ii=1,nbpt)
  620.  
  621. C write(6,*)' ITAC NN=',NN
  622. C do 118 l=1,NN
  623. C nb=itac(1,l)
  624. C write(6,1011)L,itac(1,l),(itac(i+1,l),i=1,nb)
  625. C118 continue
  626.  
  627. C write(6,*)' NBFT4=',nbft4
  628.  
  629. C do 117 l=1,nbft4
  630. C write(6,1011)L,(ifac4(i,l),i=1,4)
  631. C117 continue
  632.  
  633. C write(6,*)' MLENT1.LECT '
  634. C write(6,1001)(mlent1.lect(ii),ii=1,nbpt)
  635.  
  636. C write(6,*)' ITAF MM=',MM
  637. C do 119 l=1,MM
  638. C nb=itaf(1,l)
  639. C write(6,1011)L,itaf(1,l),(itaf(i+1,l),i=1,nb)
  640. C119 continue
  641.  
  642. SEGSUP TRAV1
  643. IF(NBSOU1.EQ.1)THEN
  644. IPT3=KM(2,1)
  645. ELSE
  646. C write(6,*)' NBSOU1=',nbsou1
  647. NBSOUS=NBSOU1
  648. NBELEM=0
  649. NBNN=0
  650. NBREF=0
  651. SEGINI IPT3
  652. DO 785 L=1,NBSOU1
  653. IPT3.LISOUS(L)=KM(2,L)
  654. C write(6,*)' IPT3 L=',l,KM(2,L)
  655. C ipt2=KM(2,L)
  656. C segact ipt2
  657. C nbelem=ipt2.num(/2)
  658. C write(6,*)' couleur',nbelem
  659. C write(6,1001)(ipt2.icolor(ii),ii=1,nbelem)
  660. 785 CONTINUE
  661. ENDIF
  662.  
  663. SEGDES IPT3
  664.  
  665. CALL ECROBJ('MAILLAGE',IPT3)
  666.  
  667. SEGSUP CARA,TRAV2
  668.  
  669. RETURN
  670. 1011 FORMAT('L=',I3,4X,15(1X,I5))
  671. 1001 FORMAT(20(1X,I5))
  672. 1002 FORMAT(10(1X,1PE11.4))
  673. END
  674.  
  675.  
  676.  

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