Télécharger envvol.eso

Retour à la liste

Numérotation des lignes :

  1. C ENVVOL SOURCE GOUNAND 17/12/05 21:16:07 9645
  2. SUBROUTINE ENVVOL
  3.  
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7. -INC CCOPTIO
  8. -INC SMELEME
  9. -INC CCGEOME
  10. -INC SMCOORD
  11.  
  12. SEGMENT IFAC3(4,NFAC3)
  13. SEGMENT IFAC4(5,NFAC4)
  14. SEGMENT IFAC6(7,NFAC6)
  15. SEGMENT IFAC8(9,NFAC8)
  16. SEGMENT IPPOL(NTPOL)
  17. SEGMENT NTFAC(NFAC)
  18. SEGMENT KFAK(NFAC)
  19. SEGMENT NAUX(max(2,NFAC))
  20. SEGMENT XCENT(3,NBELEM)
  21. character*4 lnoid(1)
  22.  
  23. c==== LECTURE D UN MOT CLE ORIE pour ORIENTER L ENVELOPPE =============
  24. PARAMETER (LCLE = 1)
  25. CHARACTER*4 MCLE(LCLE)
  26. *dbg PARAMETER (LOPT=1)
  27. *dbg CHARACTER*4 MOPT(LOPT)
  28. *dbg DATA MOPT/'OLD '/
  29. DATA MCLE/'ORIE'/
  30. data lnoid/'NOID'/
  31. *dbg IOPT=0
  32. *dbg CALL LIRMOT(MOPT,LOPT,IOPT,0)
  33. ICLE=0
  34. CALL LIRMOT(MCLE,LCLE,ICLE,0)
  35. *dbg IF (IOPT.EQ.0.AND.ICLE.EQ.0) THEN
  36. IF (ICLE.EQ.0) THEN
  37. CALL ENVVO2(0)
  38. RETURN
  39. ENDIF
  40. call lirmot(lnoid,1,inoid,0)
  41.  
  42. c==== LECTURE ET OUVERTURE DU MELEME ==================================
  43. c et eventuelle boucle 10 sur les ojbets meleme elementaires
  44. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  45. IF (IERR.NE.0) RETURN
  46. SEGACT MELEME
  47. c on compte le nombre d elements dont les faces possedent 3,4,6 ou 8
  48. c noeuds => NFAC3,4,6,8
  49. NFAC3=0
  50. NFAC4=0
  51. NFAC6=0
  52. NFAC8=0
  53. NTPOL = 0
  54. IPT1=MELEME
  55. SEGACT MELEME
  56. DO 10 IOB=1,MAX(1,LISOUS(/1))
  57. IF (LISOUS(/1).NE.0) THEN
  58. IPT1=LISOUS(IOB)
  59. SEGACT IPT1
  60. ENDIF
  61. NBELEM=IPT1.NUM(/2)
  62. c LTEL,LDEL LFAC de CCGEOME remplis par bdata
  63. ILTEL=LTEL(1,IPT1.ITYPEL)
  64. IF (ILTEL.EQ.0) GOTO 12
  65. ILTAD=LTEL(2,IPT1.ITYPEL)
  66. c --- boucle sur les faces de chaque elements ---
  67. DO 13 IF=1,ILTEL
  68. IFT=LDEL(1,ILTAD+IF-1)
  69. GOTO (21,22,23,24,25,26),IFT
  70. 21 NFAC3=NFAC3+NBELEM
  71. GOTO 30
  72. 22 NFAC4=NFAC4+NBELEM
  73. GOTO 30
  74. 23 NFAC6=NFAC6+NBELEM
  75. GOTO 30
  76. 24 NFAC8=NFAC8+NBELEM
  77. GOTO 30
  78. 25 GOTO 30
  79. 26 NTPOL = NTPOL+1
  80. GOTO 30
  81. 30 CONTINUE
  82. 13 CONTINUE
  83. c --- fin de boucle sur les faces de chaque elements ---
  84. 12 CONTINUE
  85. 10 CONTINUE
  86. c write(6,*) 'dimension de NFAC3,4,6,8=',NFAC3,NFAC4,NFAC6,NFAC8
  87.  
  88. c==== CREATION DES FACES ==============================================
  89. c IFAC3,4,6,8(i,j)=noeuds de la jieme face
  90. SEGINI IFAC3,IFAC4,IFAC6,IFAC8,IPPOL
  91. NFAC3=0
  92. NFAC4=0
  93. NFAC6=0
  94. NFAC8=0
  95. NTPOL=0
  96. c eventuelle boucle 50 sur les ojbets meleme elementaires
  97. DO 50 IOB=1,MAX(1,LISOUS(/1))
  98. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB)
  99. segact ipt1
  100. NBELEM=IPT1.NUM(/2)
  101. C calcul du centre des noeuds des elements
  102. if (ICLE.eq.1) then
  103. segini,XCENT
  104. NBNN=IPT1.NUM(/1)
  105. IDIM1 = IDIM+1
  106. do iel=1,NBELEM
  107. XG = 0.D0
  108. YG = 0.D0
  109. ZG = 0.D0
  110. do inode=1,NBNN
  111. IP1 = IPT1.NUM(inode,iel) - 1
  112. XG = XG + XCOOR(IP1*IDIM1+1)
  113. YG = YG + XCOOR(IP1*IDIM1+2)
  114. ZG = ZG + XCOOR(IP1*IDIM1+3)
  115. enddo
  116. XCENT(1,iel)=XG/NBNN
  117. XCENT(2,iel)=YG/NBNN
  118. XCENT(3,iel)=ZG/NBNN
  119. enddo
  120. c write(6,*) 'XCENT=',(XCENT(1,iou),iou=1,min(4,NBELEM))
  121. c write(6,*) ' ',(XCENT(2,iou),iou=1,min(4,NBELEM))
  122. c write(6,*) ' ',(XCENT(3,iou),iou=1,min(4,NBELEM))
  123. endif
  124. ILTEL=LTEL(1,IPT1.ITYPEL)
  125. IF (ILTEL.EQ.0) GOTO 52
  126. ILTAD=LTEL(2,IPT1.ITYPEL)
  127. c --- boucle 60 sur faces d'1 type d'element ------------------
  128. DO 60 IF=1,ILTEL
  129. ITYP=LDEL(1,ILTAD+IF-1)
  130. IAD=LDEL(2,ILTAD+IF-1)
  131. c --- boucle 66 sur elements ---------------------------------
  132. DO 66 IEL=1,NBELEM
  133. GOTO (61,62,63,64,65,65),ITYP
  134. 61 NFAC3=NFAC3+1
  135. IFAC3(1,NFAC3)=IPT1.NUM(LFAC(IAD),IEL)
  136. IFAC3(2,NFAC3)=IPT1.NUM(LFAC(IAD+1),IEL)
  137. IFAC3(3,NFAC3)=IPT1.NUM(LFAC(IAD+2),IEL)
  138. IFAC3(4,NFAC3)=IPT1.ICOLOR(IEL)
  139. if(ICLE.eq.1) call envori(IFAC3,0,0,0,NFAC3,XCENT,IEL)
  140. GOTO 65
  141. 62 NFAC4=NFAC4+1
  142. IFAC4(1,NFAC4)=IPT1.NUM(LFAC(IAD),IEL)
  143. IFAC4(2,NFAC4)=IPT1.NUM(LFAC(IAD+1),IEL)
  144. IFAC4(3,NFAC4)=IPT1.NUM(LFAC(IAD+2),IEL)
  145. IFAC4(4,NFAC4)=IPT1.NUM(LFAC(IAD+3),IEL)
  146. IFAC4(5,NFAC4)=IPT1.ICOLOR(IEL)
  147. if(ICLE.eq.1) call envori(0,IFAC4,0,0,NFAC4,XCENT,IEL)
  148. GOTO 65
  149. 63 NFAC6=NFAC6+1
  150. IFAC6(1,NFAC6)=IPT1.NUM(LFAC(IAD) ,IEL)
  151. IFAC6(2,NFAC6)=IPT1.NUM(LFAC(IAD+1),IEL)
  152. IFAC6(3,NFAC6)=IPT1.NUM(LFAC(IAD+2),IEL)
  153. IFAC6(4,NFAC6)=IPT1.NUM(LFAC(IAD+3),IEL)
  154. IFAC6(5,NFAC6)=IPT1.NUM(LFAC(IAD+4),IEL)
  155. IFAC6(6,NFAC6)=IPT1.NUM(LFAC(IAD+5),IEL)
  156. IFAC6(7,NFAC6)=IPT1.ICOLOR(IEL)
  157. if(ICLE.eq.1) call envori(0,0,IFAC6,0,NFAC6,XCENT,IEL)
  158. GOTO 65
  159. 64 CONTINUE
  160. NFAC8=NFAC8+1
  161. IFAC8(1,NFAC8)=IPT1.NUM(LFAC(IAD) ,IEL)
  162. IFAC8(2,NFAC8)=IPT1.NUM(LFAC(IAD+1),IEL)
  163. IFAC8(3,NFAC8)=IPT1.NUM(LFAC(IAD+2),IEL)
  164. IFAC8(4,NFAC8)=IPT1.NUM(LFAC(IAD+3),IEL)
  165. IFAC8(5,NFAC8)=IPT1.NUM(LFAC(IAD+4),IEL)
  166. IFAC8(6,NFAC8)=IPT1.NUM(LFAC(IAD+5),IEL)
  167. IFAC8(7,NFAC8)=IPT1.NUM(LFAC(IAD+6),IEL)
  168. IFAC8(8,NFAC8)=IPT1.NUM(LFAC(IAD+7),IEL)
  169. IFAC8(9,NFAC8)=IPT1.ICOLOR(IEL)
  170. if(ICLE.eq.1) call envori(0,0,0,IFAC8,NFAC8,XCENT,IEL)
  171. GOTO 65
  172. 65 CONTINUE
  173. 66 CONTINUE
  174. c --- fin de boucle 66 sur elements ---------------------------------
  175. 60 CONTINUE
  176. c --- fin de boucle 60 sur faces d'1 type d'element ------------------
  177. 52 CONTINUE
  178. IF (ITYP.EQ.6) THEN
  179. C Polygone
  180. NTPOL = NTPOL+1
  181. IPPOL(NTPOL)= IPT1
  182. ELSE
  183. IF (LISOUS(/1).NE.0) SEGDES IPT1
  184. ENDIF
  185. 50 CONTINUE
  186. SEGDES MELEME
  187. if (ICLE.eq.1) segsup,XCENT
  188.  
  189. C ======================================================================
  190. C IL FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  191. C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  192. NFAC=NFAC3+NFAC4+NFAC6+NFAC8
  193. SEGINI NTFAC,KFAK
  194. IF (NFAC3.EQ.0) GOTO 101
  195. DO 102 I=1,NFAC3
  196. NTFAC(I)=IFAC3(1,I)+IFAC3(2,I)+IFAC3(3,I)
  197. KFAK(I)=I
  198. 102 CONTINUE
  199. 101 CONTINUE
  200. IF (NFAC4.EQ.0) GOTO 103
  201. DO 104 I=1,NFAC4
  202. NTFAC(I+NFAC3)=IFAC4(1,I)+IFAC4(2,I)+IFAC4(3,I)+IFAC4(4,I)
  203. KFAK(I+NFAC3)=I
  204. 104 CONTINUE
  205. 103 CONTINUE
  206. IF (NFAC6.EQ.0) GOTO 105
  207. DO 106 I=1,NFAC6
  208. NTFAC(I+NFAC3+NFAC4)=IFAC6(1,I)+IFAC6(2,I)+IFAC6(3,I)
  209. #+IFAC6(4,I)+IFAC6(5,I)+IFAC6(6,I)
  210. KFAK(I+NFAC3+NFAC4)=I
  211. 106 CONTINUE
  212. 105 CONTINUE
  213. IF (NFAC8.EQ.0) GOTO 107
  214. DO 108 I=1,NFAC8
  215. NTFAC(I+NFAC3+NFAC4+NFAC6)=IFAC8(1,I)+IFAC8(2,I)+IFAC8(3,I)
  216. #+IFAC8(4,I)+IFAC8(5,I)+IFAC8(6,I)+IFAC8(7,I)+IFAC8(8,I)
  217. KFAK(I+NFAC3+NFAC4+NFAC6)=I
  218. 108 CONTINUE
  219. 107 CONTINUE
  220. C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT NTFAC
  221. SEGINI NAUX
  222. DO 300 ITYP=1,4
  223. GOTO (301,302,303,304),ITYP
  224. 301 CONTINUE
  225. IF (NFAC3.LE.1) GOTO 300
  226. NAUX(1)=1
  227. NAUX(2)=NFAC3
  228. GOTO 310
  229. 302 CONTINUE
  230. IF (NFAC4.LE.1) GOTO 300
  231. NAUX(1)=NFAC3+1
  232. NAUX(2)=NFAC3+NFAC4
  233. GOTO 310
  234. 303 CONTINUE
  235. IF (NFAC6.LE.1) GOTO 300
  236. NAUX(1)=NFAC3+NFAC4+1
  237. NAUX(2)=NFAC3+NFAC4+NFAC6
  238. GOTO 310
  239. 304 CONTINUE
  240. IF (NFAC8.LE.1) GOTO 300
  241. NAUX(1)=NFAC3+NFAC4+NFAC6+1
  242. NAUX(2)=NFAC
  243. GOTO 310
  244. 310 CONTINUE
  245. IZ=2
  246. 208 IZ=IZ-1
  247. IF (IZ.LE.0) GOTO 209
  248. IPB=NAUX(IZ*2-1)
  249. IPH=NAUX(IZ*2)
  250. IF(IPB.GE.IPH) GOTO 208
  251. JPB=IPB-1
  252. JPH=IPH+1
  253. C CALCUL DU PIVOT
  254. NPV=0
  255. * DO 207 J=IPB,IPH
  256. * NPV=NPV+NTFAC(J)
  257. * 207 CONTINUE
  258. * NPV=NPV/(IPH-IPB+1)
  259. NPV=(NTFAC(IPB)+NTFAC(IPH))/2
  260. 242 JPB=JPB+1
  261. IF (JPH.EQ.JPB) GOTO 245
  262. IF (NTFAC(JPB).LE.NPV) GOTO 243
  263. GOTO 242
  264. 243 JPH=JPH-1
  265. IF (JPH.EQ.JPB) GOTO 245
  266. IF (NTFAC(JPH).GE.NPV) GOTO 244
  267. GOTO 243
  268. 244 IAUX=KFAK(JPB)
  269. KFAK(JPB)=KFAK(JPH)
  270. KFAK(JPH)=IAUX
  271. NTAUX=NTFAC(JPB)
  272. NTFAC(JPB)=NTFAC(JPH)
  273. NTFAC(JPH)=NTAUX
  274. GOTO 242
  275. 245 IF (JPB.GE.IPB) GOTO 247
  276. JPB=JPB+1
  277. JPH=JPH+2
  278. GOTO 248
  279. 247 IF (JPH.LE.IPH) GOTO 249
  280. JPB=JPB-2
  281. JPH=JPH-1
  282. GOTO 248
  283. 249 IF (NTFAC(JPB).LE.NPV) GOTO 250
  284. IF (JPH.EQ.IPH) GOTO 251
  285. 252 JPH=JPH+1
  286. GOTO 248
  287. 250 IF (JPB.EQ.IPB) GOTO 252
  288. 251 JPB=JPB-1
  289. 248 IF (JPB.EQ.IPB) GOTO 253
  290. NAUX(2*IZ)=JPB
  291. IZ=IZ+1
  292. 253 IF (JPH.EQ.IPH) GOTO 208
  293. NAUX(2*IZ)=IPH
  294. NAUX(2*IZ-1)=JPH
  295. IZ=IZ+1
  296. GOTO 208
  297. 209 CONTINUE
  298. 300 CONTINUE
  299.  
  300. C ======================================================================
  301. C LES FACES SONT CLASSEES DANS KFAK IL FAUT ELIMINER LES FACES EN DOUBL
  302. C ELLES SONT PAR TYPE LES UNES DERRIERES LES AUTRES LES PLUS HAUTES
  303. C DEVANT
  304. IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC)
  305. 9111 FORMAT(5(2X,2I6))
  306. DO 400 ITYP=1,4
  307. GOTO (401,402,403,404),ITYP
  308. 401 IF (NFAC3.LE.1) GOTO 400
  309. IDEB=1
  310. IFIN=NFAC3
  311. GOTO 410
  312. 402 IF (NFAC4.LE.1) GOTO 400
  313. IDEB=NFAC3+1
  314. IFIN=NFAC3+NFAC4
  315. GOTO 410
  316. 403 IF (NFAC6.LE.1) GOTO 400
  317. IDEB=NFAC3+NFAC4+1
  318. IFIN=NFAC3+NFAC4+NFAC6
  319. GOTO 410
  320. 404 IF (NFAC8.LE.1) GOTO 400
  321. IDEB=NFAC3+NFAC4+NFAC6+1
  322. IFIN=NFAC
  323. GOTO 410
  324. 410 CONTINUE
  325. IFINM=IFIN-1
  326. DO 450 I1=IDEB,IFINM
  327. NTI1=NTFAC(I1)
  328. IF (NTI1.EQ.0) GOTO 450
  329. IDEB1=I1+1
  330. DO 460 I2=IDEB1,IFIN
  331. NTI2=NTFAC(I2)
  332. IF (NTI2.EQ.0) GOTO 460
  333. IF (NTI2.NE.NTI1) GOTO 450
  334. IR1=KFAK(I1)
  335. IR2=KFAK(I2)
  336. GOTO (470,480,490,500),ITYP
  337. 470 CONTINUE
  338. DO 471 J1=1,3
  339. INU=IFAC3(J1,IR1)
  340. DO 472 J2=1,3
  341. IF (INU.EQ.IFAC3(J2,IR2)) GOTO 471
  342. 472 CONTINUE
  343. GOTO 520
  344. 471 CONTINUE
  345. GOTO 510
  346. 480 CONTINUE
  347. DO 481 J1=1,4
  348. INU=IFAC4(J1,IR1)
  349. DO 482 J2=1,4
  350. IF (INU.EQ.IFAC4(J2,IR2)) GOTO 481
  351. 482 CONTINUE
  352. GOTO 520
  353. 481 CONTINUE
  354. GOTO 510
  355. 490 CONTINUE
  356. DO 491 J1=1,6
  357. INU=IFAC6(J1,IR1)
  358. DO 492 J2=1,6
  359. IF (INU.EQ.IFAC6(J2,IR2)) GOTO 491
  360. 492 CONTINUE
  361. GOTO 520
  362. 491 CONTINUE
  363. GOTO 510
  364. 500 CONTINUE
  365. DO 501 J1=1,8
  366. INU=IFAC8(J1,IR1)
  367. DO 502 J2=1,8
  368. IF (INU.EQ.IFAC8(J2,IR2)) GOTO 501
  369. 502 CONTINUE
  370. GOTO 520
  371. 501 CONTINUE
  372. GOTO 510
  373. 520 CONTINUE
  374. GOTO 460
  375. 510 CONTINUE
  376. C DEUX FACES EGALES ON LES SUPPRIMENT
  377. NTFAC(I1)=0
  378. NTFAC(I2)=0
  379. GOTO 450
  380. 460 CONTINUE
  381. 450 CONTINUE
  382. 400 CONTINUE
  383. IPT1=0
  384. IPT2=0
  385. IPT3=0
  386. IPT4=0
  387. NBSOUS=0
  388. NBREF=0
  389. NBSOU2=0
  390. DO 600 ITY=1,4
  391. GOTO (610,620,630,640),ITY
  392. 610 CONTINUE
  393. IF (NFAC3.EQ.0) GOTO 600
  394. IDEB=1
  395. IFIN=NFAC3
  396. NBELEM=0
  397. DO 611 I=IDEB,IFIN
  398. IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
  399. 611 CONTINUE
  400. IF (NBELEM.EQ.0) GOTO 600
  401. NBSOU2=NBSOU2+1
  402. NBNN=3
  403. SEGINI IPT1
  404. IPT1.ITYPEL=4
  405. JAUX=0
  406. DO 612 J=IDEB,IFIN
  407. IF (NTFAC(J).EQ.0) GOTO 612
  408. JAUX=JAUX+1
  409. IPT1.ICOLOR(JAUX)=IFAC3(4,KFAK(J))
  410. DO 613 I=1,NBNN
  411. IPT1.NUM(I,JAUX)=IFAC3(I,KFAK(J))
  412. 613 CONTINUE
  413. 612 CONTINUE
  414. SEGDES IPT1
  415. GOTO 600
  416. 620 CONTINUE
  417. IF (NFAC4.EQ.0) GOTO 600
  418. IDEB=NFAC3+1
  419. IFIN=NFAC3+NFAC4
  420. NBELEM=0
  421. DO 621 I=IDEB,IFIN
  422. IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
  423. 621 CONTINUE
  424. IF (NBELEM.EQ.0) GOTO 600
  425. NBSOU2=NBSOU2+1
  426. NBNN=4
  427. SEGINI IPT2
  428. IPT2.ITYPEL=8
  429. JAUX=0
  430. DO 622 J=IDEB,IFIN
  431. IF (NTFAC(J).EQ.0) GOTO 622
  432. JAUX=JAUX+1
  433. IPT2.ICOLOR(JAUX)=IFAC4(5,KFAK(J))
  434. DO 623 I=1,NBNN
  435. IPT2.NUM(I,JAUX)=IFAC4(I,KFAK(J))
  436. 623 CONTINUE
  437. 622 CONTINUE
  438. SEGDES IPT2
  439. GOTO 600
  440. 630 CONTINUE
  441. IF (NFAC6.EQ.0) GOTO 600
  442. IDEB=NFAC3+NFAC4+1
  443. IFIN=NFAC3+NFAC4+NFAC6
  444. NBELEM=0
  445. DO 631 I=IDEB,IFIN
  446. IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
  447. 631 CONTINUE
  448. IF (NBELEM.EQ.0) GOTO 600
  449. NBSOU2=NBSOU2+1
  450. NBNN=6
  451. SEGINI IPT3
  452. IPT3.ITYPEL=6
  453. JAUX=0
  454. DO 632 J=IDEB,IFIN
  455. IF (NTFAC(J).EQ.0) GOTO 632
  456. JAUX=JAUX+1
  457. IPT3.ICOLOR(JAUX)=IFAC6(7,KFAK(J))
  458. DO 633 I=1,NBNN
  459. IPT3.NUM(I,JAUX)=IFAC6(I,KFAK(J))
  460. 633 CONTINUE
  461. 632 CONTINUE
  462. SEGDES IPT3
  463. GOTO 600
  464. 640 CONTINUE
  465. IF (NFAC8.EQ.0) GOTO 600
  466. IDEB=NFAC3+NFAC4+NFAC6+1
  467. IFIN=NFAC
  468. NBELEM=0
  469. DO 641 I=IDEB,IFIN
  470. IF (NTFAC(I).NE.0) NBELEM=NBELEM+1
  471. 641 CONTINUE
  472. IF (NBELEM.EQ.0) GOTO 600
  473. NBSOU2=NBSOU2+1
  474. NBNN=8
  475. SEGINI IPT4
  476. IPT4.ITYPEL=10
  477. JAUX=0
  478. DO 642 J=IDEB,IFIN
  479. IF (NTFAC(J).EQ.0) GOTO 642
  480. JAUX=JAUX+1
  481. IPT4.ICOLOR(JAUX)=IFAC8(9,KFAK(J))
  482. DO 643 I=1,NBNN
  483. IPT4.NUM(I,JAUX)=IFAC8(I,KFAK(J))
  484. 643 CONTINUE
  485. 642 CONTINUE
  486. SEGDES IPT4
  487. GOTO 600
  488. 600 CONTINUE
  489.  
  490. * on rajoute les points et les segments qui pouvaient etre dans le
  491. * maillage initial
  492. ipt5=0
  493. segact meleme
  494. ipt6=meleme
  495. do 710 io=1,max(1,lisous(/1))
  496. if (lisous(/1).ne.0) ipt6=lisous(io)
  497. segact ipt6
  498. if (ipt6.itypel.le.3) then
  499. nbsou2=nbsou2+1
  500. ipt5=ipt6
  501. endif
  502. segdes ipt6
  503. 710 continue
  504. segdes meleme
  505. IF (NBSOU2.EQ.0.AND.NTPOL.EQ.0.AND.inoid.eq.0) CALL ERREUR(26)
  506. IF (NBSOU2.NE.1.OR.NTPOL.GE.0) GOTO 700
  507. CALL ECROBJ('MAILLAGE',IPT1+IPT2+IPT3+IPT4+ipt5)
  508. SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX
  509. RETURN
  510. 700 CONTINUE
  511. NBREF=0
  512. NBSOUS=NBSOU2+NTPOL
  513. NBNN=0
  514. NBELEM=0
  515. SEGINI IPT5
  516. I=0
  517. IF (IPT1.EQ.0) GOTO 701
  518. I=I+1
  519. IPT5.LISOUS(I)=IPT1
  520. 701 CONTINUE
  521. IF (IPT2.EQ.0) GOTO 702
  522. I=I+1
  523. IPT5.LISOUS(I)=IPT2
  524. 702 CONTINUE
  525. IF (IPT3.EQ.0) GOTO 703
  526. I=I+1
  527. IPT5.LISOUS(I)=IPT3
  528. 703 CONTINUE
  529. IF (IPT4.EQ.0) GOTO 704
  530. I=I+1
  531. IPT5.LISOUS(I)=IPT4
  532. 704 CONTINUE
  533. segact meleme
  534. ipt1=meleme
  535. do 711 io=1,max(1,lisous(/1))
  536. if (lisous(/1).ne.0) ipt1=lisous(io)
  537. segact ipt1
  538. if (ipt1.itypel.le.3) then
  539. I=I+1
  540. IPT5.LISOUS(I)=IPT1
  541. endif
  542. segdes ipt1
  543. 711 continue
  544. DO 720, IO = 1, NTPOL
  545. I = I+1
  546. IPT5.LISOUS(I)=IPPOL(IO)
  547. 720 CONTINUE
  548. if (ipt5.lisous(/1).eq.1) then
  549. ipt6=ipt5
  550. ipt5=ipt6.lisous(1)
  551. segsup ipt6
  552. endif
  553. segdes meleme
  554. SEGDES IPT5
  555. CALL ECROBJ('MAILLAGE',IPT5)
  556. SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX,IPPOL
  557. RETURN
  558. END
  559.  
  560.  
  561.  
  562.  
  563.  
  564.  
  565.  
  566.  
  567.  
  568.  
  569.  
  570.  
  571.  
  572.  
  573.  
  574.  
  575.  

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