Esope source files

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