Télécharger ccubic.eso

Retour à la liste

Numérotation des lignes :

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

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