Télécharger c20227.eso

Retour à la liste

Numérotation des lignes :

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

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