Télécharger la plaquette Cast3M


fr en

Télécharger envvol.eso

Retour à la liste

Numérotation des lignes : 

envvol

  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