Télécharger envvol.eso

Retour à la liste

Numérotation des lignes :

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

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