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

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