Télécharger la plaquette Cast3M


fr en

Télécharger regle.eso

Retour à la liste

Numérotation des lignes : 

regle

  1. C REGLE     SOURCE    CB215821  21/12/14    21:15:19     11220          
  2. C    CONSTRUIT LA SURFACE REGLE ENTRE DEUX LIGNES DE MEME LONGUEUR
  3. C
  4.       SUBROUTINE REGLE
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC CCGEOME
  11. -INC SMCOORD
  12. -INC SMELEME
  13. -INC CCREEL
  14.  
  15.       SEGMENT TABPAR(NCOUCH)
  16.       SEGMENT ICPR(2,NBELEC)
  17.       SEGMENT JCPR(NBPTS)
  18.  
  19.       logical ltelq
  20. c * DIMENSION ITEST(0:NBCOUL-1) - NBCOUL stocke dans CCGEOME =16 dans bdata
  21. c       DIMENSION ITEST(0:30)
  22.       CHARACTER*(4) MLU
  23.  
  24.       IDIMP1 = IDIM+1
  25.       IMPOI=0
  26.       IMPOF=0
  27.       DEN1=0.
  28.       DEN2=0.
  29. C  Y A T IL UN DECOUPAGE IMPOSE
  30.       INBR=0
  31.       CALL LIRENT(INBR,0,IRETOU)
  32. *     IF (IRETOU.EQ.1) INBR=MAX(1,INBR)
  33. *  SI INBR NEGATIF ALORS DECOUPAGE IMPOSE AVEC PROGRESSION D'APRES
  34. *  LES DENSITES
  35. C  Y A T-IL DES DENSITES IMPOSEES
  36.   80  CALL LIRCHA(MLU,0,IRETOU)
  37.       IF (IRETOU.EQ.0) GOTO 83
  38.       IF (MLU.NE.'DINI') GOTO 81
  39.       CALL LIRREE(XXX,1,IRETOU)
  40.       DEN1=XXX
  41.       IF (IERR.NE.0) RETURN
  42.       IMPOI=1
  43.       IF (IMPOF.EQ.1) GOTO 83
  44.       CALL LIRCHA(MLU,0,IRETOU)
  45.       IF (IRETOU.EQ.0) GOTO 83
  46.   81  IF (MLU.NE.'DFIN') GOTO 82
  47.       CALL LIRREE(XXX,1,IRETOU)
  48.       DEN2=XXX
  49.       IF (IERR.NE.0) RETURN
  50.       IMPOF=1
  51.       IF (IMPOI.EQ.0) GOTO 80
  52.       GOTO 83
  53.   82  CALL REFUS
  54.   83  CONTINUE
  55.       IF (KSURF(ILCOUR).EQ.0) CALL ERREUR(16)
  56.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  57.       IF (IERR.NE.0) RETURN
  58.       CALL EXTRLI(IPT1,3,IRET,-1)
  59.       IF (IERR.NE.0) RETURN
  60.       IFUSE1=0
  61.       IF (IPT1.NE.IRET) IFUSE1=IPT1
  62.       IPT1=IRET
  63.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  64.       IF (IERR.NE.0) RETURN
  65.       CALL EXTRLI(IPT2,1,IRET,1)
  66.       IF (IERR.NE.0) RETURN
  67.       IFUSE2=0
  68.       IF (IPT2.NE.IRET) IFUSE2=IPT2
  69.       IPT2=IRET
  70.       SEGACT IPT1,IPT2
  71.       IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) CALL ERREUR(16)
  72.       NBELEM=IPT1.NUM(/2)
  73.       IF (NBELEM.NE.IPT2.NUM(/2)) CALL ERREUR(33)
  74.       IF (IERR.EQ.0) GOTO 2
  75.    1  SEGDES IPT1,IPT2
  76.       RETURN
  77.    2  CONTINUE
  78. c c calcul de la couleur de melange via ITABM:
  79. c c fait ici, on va moyenner sur tous les elements
  80. c       DO 90 I=0,(NBCOUL-1)
  81. c  90   ITEST(I)=0
  82. c        DO 91 I=1,IPT1.NUM(/2)
  83. c               ITEST(IPT1.ICOLOR(I))=1
  84. c   91   CONTINUE
  85. c        DO 92 I=1,IPT2.NUM(/2)
  86. c               ITEST(IPT2.ICOLOR(I))=1
  87. c   92   CONTINUE
  88. c       ICHCOL=-1
  89. c       DO 93 I=0,(NBCOUL-1)
  90. c        IF (ITEST(I).EQ.1) THEN
  91. c         IF (ICHCOL.EQ.-1) THEN
  92. c               ICHCOL=I
  93. c         ELSE
  94. c               ICHCOL=ITABM(ICHCOL,I)
  95. c         ENDIF
  96. c        ENDIF
  97. c  93   CONTINUE
  98.       SEGACT MCOORD*mod
  99.       NBNN=IPT1.NUM(/1)
  100.       ZG1=0.
  101.       ZG2=0.
  102.       DLONG=XPETIT
  103.       IBOUCL=0
  104.       IF (IPT1.NUM(1,1).EQ.IPT1.NUM(NBNN,NBELEM)) IBOUCL=1
  105.       IF (IBOUCL.EQ.1.AND.IPT2.NUM(1,1).NE.IPT2.NUM(NBNN,
  106.      #NBELEM)) THEN
  107.         CALL ERREUR(33)
  108.         GOTO 1
  109.       ENDIF
  110.       DEN1AU=DEN1
  111.       DEN2AU=DEN2
  112.       DO 10 I=1,NBNN
  113.       DO 10 J=1,NBELEM
  114.         IREF1=IPT1.NUM(I,J)*IDIMP1-IDIM
  115.         XG1=XCOOR(IREF1)
  116.         YG1=XCOOR(IREF1+1)
  117.         IF (IDIM.GE.3) ZG1=XCOOR(IREF1+2)
  118.         DEN1=XCOOR(IREF1+IDIM)+DEN1
  119.         IREF2=IPT2.NUM(I,J)*IDIMP1-IDIM
  120.         XG2=XCOOR(IREF2)
  121.         YG2=XCOOR(IREF2+1)
  122.         IF (IDIM.GE.3) ZG2=XCOOR(IREF2+2)
  123.         DEN2=XCOOR(IREF2+IDIM)+DEN2
  124.         XDIS=XG2-XG1
  125.         YDIS=YG2-YG1
  126.         ZDIS=ZG2-ZG1
  127.         DLONG=SQRT(XDIS*XDIS+YDIS*YDIS+ZDIS*ZDIS)+DLONG
  128.   10  CONTINUE
  129.  
  130.       NBTOT=NBNN*NBELEM
  131.       DEN1=DEN1/NBTOT
  132.       DEN2=DEN2/NBTOT
  133.       DLONG=DLONG/NBTOT
  134.       DLONG=MAX(XPETIT,DLONG)
  135.       IF (IMPOI.EQ.1) DEN1=DEN1AU
  136.       IF (IMPOF.EQ.1) DEN2=DEN2AU
  137.       DEN1A=DEN1
  138.       DEN1B=DEN1
  139.       DEN2A=DEN2
  140.       DEN2B=DEN2
  141.       DEN1=DEN1/DLONG
  142.       DEN2=DEN2/DLONG
  143.       DENI = 0.
  144.       DECA = 0.
  145.       CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG)
  146.       NX=NCOUCH-1
  147.       IF(DENI.EQ. 0.D0)   DENI = DLONG / NCOUCH
  148.       IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NCOUCH,APROG
  149.  1000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5)
  150.       NBNN  =4
  151.       NBELEM=IPT1.NUM(/2)*NCOUCH
  152.       NBSOUS=0
  153.       NBREF =4
  154.       SEGINI MELEME
  155.       SEGINI TABPAR
  156.       ITYPEL=8
  157.       INCR=IPT1.ITYPEL-1
  158.       IL=1
  159.       NBELEC=IPT1.NUM(/2)
  160.       SEGINI ICPR
  161.       CALL INVERS(IPT2,IPT4)
  162.       SEGDES IPT4
  163.       LISREF(3)=IPT4
  164. C     ON REMPLIT LE TABLEAU ICPR DES PTS EFFECTIFS
  165.       IDEB=nbpts+1
  166.  
  167.       SEGINI,JCPR
  168.       DO 510 J=1,NBELEC
  169.         DO 511 I=1,2
  170.           I1=IPT1.NUM((I-1)*INCR+1,J)
  171.           IF(JCPR(I1) .EQ. 0)THEN
  172.             JCPR(I1)=J
  173.           ENDIF
  174.  511    CONTINUE
  175.  510  CONTINUE
  176.  
  177.  
  178. C     LCPR=0
  179.       DO 51 J=1,NBELEC
  180.       DO 51 I=1,2
  181.         I1=IPT1.NUM((I-1)*INCR+1,J)
  182. C       LCPR=LCPR+1
  183. C        DO 52 JJ=1,J
  184.         JJ =JCPR(I1)
  185.         DO 52 II=1,2
  186.           I2=IPT1.NUM((II-1)*INCR+1,JJ)
  187.           IF (I2.NE.I1) GOTO 52
  188.  
  189.           IF (II.NE.I ) GOTO 53
  190.           IF (JJ.EQ.J ) GOTO 51
  191.   53      ICPR(I,J)=II+(JJ-1)*2
  192. C         LCPR=LCPR-1
  193.           IF (J.EQ.NBELEC.AND.I.EQ.2) GOTO 55
  194.           GOTO 51
  195.   55      IF (IBOUCL.EQ.1) GOTO 51
  196.           ICPR(I,J)=0
  197.           ICPR(II,JJ)=I+(J-1)*2
  198.           GOTO 51
  199.   52    CONTINUE
  200.   51  CONTINUE
  201.  
  202.       SEGSUP,JCPR
  203.  
  204. C   ON NE S'OCCUPE QUE DE FABRIQUER DES RECTANGLES A 4 NOEUDS POUR
  205. C    LE MOMENT   D'ABORD LES POINTS DU BAS QUI NE SONT PAS A FABRIQUER
  206.       DIN=DEN1
  207.       DO 60 I=1,IPT1.NUM(/2)
  208.        NUM(1,I)=IPT1.NUM(1,I)
  209.        NUM(2,I)=IPT1.NUM(1+INCR,I)
  210. c      on crée la couleur moyenne par quadrangle
  211.        ICOL1 = IPT1.ICOLOR(I)
  212.        ICOL2 = IPT2.ICOLOR(I)
  213.        ICOLOR(I)=ITABM(ICOL1,ICOL2)
  214.   60  CONTINUE
  215.       ILASI=IDEB-1
  216.       ILASJ=ILASI+(INCR*NX)+INCR-1
  217.       IF (IBOUCL.EQ.1) ILASJ=ILASI
  218.       ILAS=ILASJ+INCR*NX+INCR
  219.       DO 62 ICOUCH=1,NCOUCH
  220.       DIN=DIN*APROG
  221.       TABPAR(ICOUCH)=DIN
  222.       IF (NCOUCH.EQ.ICOUCH) GOTO 61
  223.       ILASI=ILASI+INCR
  224.       ILASJ=ILASJ+INCR
  225.       INI=(ICOUCH-1)*IPT1.NUM(/2)
  226.       NUM(1,1+INI+NBELEC)=ILASI
  227.       NUM(4,1+INI)=ILASI
  228.       NUM(2,INI+2*NBELEC)=ILASJ
  229.       NUM(3,INI+NBELEC)=ILASJ
  230.       INI=(ICOUCH-1)*IPT1.NUM(/2)
  231.       DO 62 J=1,IPT1.NUM(/2)
  232.       ICOLOR(J+INI+NBELEC)=ICOLOR(J)
  233.       DO 62 I=1,2
  234.       ILL=ILAS
  235.       IF (I.EQ.1.AND.J.EQ.1) ILL=ILASI
  236.       IF (I.EQ.2.AND.J.EQ.NBELEC) ILL=ILASJ
  237.       IF (ICPR(I,J).NE.0) ILL=NUM(MOD(ICPR(I,J)-1,2)+1,
  238.      # (ICPR(I,J)-1)/2+1+INI+NBELEC)
  239.       NUM(I,J+INI+NBELEC)=ILL
  240.       NUM(5-I,J+INI)=ILL
  241.       IF (I.EQ.1.AND.J.EQ.1) GOTO 62
  242.       IF (I.EQ.2.AND.J.EQ.NBELEC) GOTO 62
  243.       IF (ICPR(I,J).NE.0) GOTO 62
  244.       ILAS=ILL+1
  245.   62  CONTINUE
  246.       TABPAR(NCOUCH)=DIN*APROG
  247.   61  CONTINUE
  248.       INI=(NCOUCH-1)*IPT1.NUM(/2)
  249.       DO 63 I=1,NBELEC
  250.       NUM(4,INI+I)=IPT2.NUM(1,I)
  251.       NUM(3,INI+I)=IPT2.NUM(1+INCR,I)
  252.   63  CONTINUE
  253.       LISREF(1)=IPT1
  254. C   CREATION DES BORDS LATERAUX PAR LIGNE (DROITE)
  255. C   IMPOSONS ILCOUR POUR CETTE MANIP   (LES BORDS LATERAUX DOIVENT ETRE
  256. C    CONSISTANT AVEC LES AUTRES  )
  257.       ILSAUV=ILCOUR
  258.       ILCOUR=IPT1.ITYPEL
  259.       ITYPL=1
  260.       LP2=IPT2.NUM(1,1)
  261.       CALL ECROBJ('POINT ',LP2)
  262.       LP1=IPT1.NUM(1,1)
  263.       CALL ECROBJ('POINT ',LP1)
  264. C  CORRECTION POUR TENIR COMPTE DE LA DIFFERENCE DE LONGUEUR ENTRE
  265. C  LE BORD ET LE MILIEU
  266.       IREF1=(LP1-1)*IDIMP1
  267.       IREF2=(LP2-1)*IDIMP1
  268.       DL=0.
  269.       DO 67 I=1,IDIM
  270.       DL=DL+(XCOOR(IREF1+I)-XCOOR(IREF2+I))**2
  271.   67  CONTINUE
  272.       DL=SQRT(DL)
  273.       DEN1A=DEN1A*DL/DLONG
  274.       DEN2A=DEN2A*DL/DLONG
  275.       CALL LIGNE(ITYPL,0,DEN1A,DEN2A,INBR)
  276.       IF (IERR.NE.0) GOTO 100
  277.       CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  278.       SEGACT IPT3
  279.       CALL INVERS(IPT3,IPT4)
  280.       LISREF(4)=IPT4
  281.       SEGDES IPT4
  282.       IF (IBOUCL.EQ.0) GOTO 66
  283.       LISREF(2)=IPT3
  284.       SEGDES IPT3
  285.       GOTO 65
  286.   66  CONTINUE
  287.       SEGSUP IPT3
  288.       LP2=IPT2.NUM(IPT2.NUM(/1),IPT2.NUM(/2))
  289.       CALL ECROBJ('POINT ',LP2)
  290.       LP1=IPT1.NUM(IPT1.NUM(/1),IPT1.NUM(/2))
  291.       CALL ECROBJ('POINT ',LP1)
  292.       IREF1=(LP1-1)*IDIMP1
  293.       IREF2=(LP2-1)*IDIMP1
  294.       DL=0.
  295.       DO 68 I=1,IDIM
  296.       DL=DL+(XCOOR(IREF1+I)-XCOOR(IREF2+I))**2
  297.   68  CONTINUE
  298.       DL=SQRT(DL)
  299.       DEN1B=DEN1B*DL/DLONG
  300.       DEN2B=DEN2B*DL/DLONG
  301.       CALL LIGNE(ITYPL,0,DEN1B,DEN2B,INBR)
  302.       CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
  303.       IF (IERR.NE.0) GOTO 100
  304.       SEGDES IPT3
  305.       LISREF(2)=IPT3
  306.   65  CONTINUE
  307. C   ON RESTAURE ILCOUR
  308.  100  CONTINUE
  309.       ILCOUR=ILSAUV
  310.       IF (IERR.NE.0) RETURN
  311. C    CREATION DES POINTS  (PAS LES POINTS MILIEUX QUI SERONT FABRIQUES
  312. C     EVENTUELLEMENT LORS DE LA CONVERSION DES ELEMENTS)
  313.       DPAR=0.
  314.       SEGACT MCOORD*mod
  315.       IADR=nbpts
  316.       IF (NCOUCH.EQ.1) GOTO 70
  317.       NBPTS=IADR+(NCOUCH-1)*IPT1.NUM(/2)*2
  318.       SEGADJ MCOORD
  319.       DO 71 I=2,NCOUCH
  320.       DIN=TABPAR(I-1)
  321.       DPAR=DPAR+DIN
  322.       IF (IPT1.NUM(/2).EQ.1) GOTO 70
  323.       UMDPAR=1.-DPAR
  324.       DINA=DENI+DECA*DPAR
  325.       DO 72 J=1,IPT1.NUM(/2)
  326.       DO 72 K=1,2
  327.       IF (K.EQ.1.AND.J.EQ.1) GOTO 72
  328.       IF (K.EQ.2.AND.J.EQ.NBELEC) GOTO 72
  329.       IF (ICPR(K,J).NE.0) GOTO 72
  330.       IREF1=IDIMP1*IPT1.NUM((K-1)*INCR+1,J)-IDIM
  331.       IREF2=IDIMP1*IPT2.NUM((K-1)*INCR+1,J)-IDIM
  332.       IREFA=IADR*IDIMP1
  333.       XCOOR(IREFA+1)=UMDPAR*XCOOR(IREF1)  +DPAR*XCOOR(IREF2)
  334.       XCOOR(IREFA+2)=UMDPAR*XCOOR(IREF1+1)+DPAR*XCOOR(IREF2+1)
  335.       IF(IDIM.NE.2)
  336.      #XCOOR(IREFA+3)=UMDPAR*XCOOR(IREF1+2)+DPAR*XCOOR(IREF2+2)
  337.       XCOOR(IREFA+IDIMP1)=DINA
  338.       IADR=IADR+1
  339.   72  CONTINUE
  340.   71  CONTINUE
  341.   70  CONTINUE
  342.       NBPTS=IADR
  343.       SEGADJ MCOORD
  344.       IPT7=IPT1
  345.       IPT8=IPT2
  346.       IF (KSURF(ILCOUR).EQ.8) GOTO 101
  347.       IF (KSURF(ILCOUR).NE.4) GOTO 102
  348.       NBNN=3
  349.       NBELEM=2*NUM(/2)
  350.       NBREF=4
  351.       NBSOUS=0
  352.       SEGINI IPT1
  353.       IPT1.ITYPEL=4
  354.       IPT1.LISREF(1)=LISREF(1)
  355.       IPT1.LISREF(2)=LISREF(2)
  356.       IPT1.LISREF(3)=LISREF(3)
  357.       IPT1.LISREF(4)=LISREF(4)
  358.       DO 103 I=1,NUM(/2),2
  359.       J=2*I-1
  360.       IPT1.NUM(1,J)=NUM(1,I)
  361.       IPT1.NUM(2,J)=NUM(2,I)
  362.       IPT1.NUM(3,J)=NUM(3,I)
  363.       IPT1.ICOLOR(J) = ICOLOR(I)
  364.       J=J+1
  365.       IPT1.NUM(1,J)=NUM(1,I)
  366.       IPT1.NUM(2,J)=NUM(3,I)
  367.       IPT1.NUM(3,J)=NUM(4,I)
  368.       IPT1.ICOLOR(J) = ICOLOR(I)
  369.       J=J+1
  370.       IF (J.GT.IPT1.NUM(/2)) GOTO 103
  371.       IPT1.NUM(1,J)=NUM(1,I+1)
  372.       IPT1.NUM(2,J)=NUM(2,I+1)
  373.       IPT1.NUM(3,J)=NUM(4,I+1)
  374.       IPT1.ICOLOR(J) = ICOLOR(I)
  375.       J=J+1
  376.       IPT1.NUM(1,J)=NUM(2,I+1)
  377.       IPT1.NUM(2,J)=NUM(3,I+1)
  378.       IPT1.NUM(3,J)=NUM(4,I+1)
  379.       IPT1.ICOLOR(J) = ICOLOR(I)
  380.  103  CONTINUE
  381.       SEGSUP MELEME
  382.       MELEME=IPT1
  383.       GOTO 101
  384.  102  CONTINUE
  385. *     write (6,*) ' ilcour ksurf ',ilcour,ksurf(ilcour)
  386.  
  387.       IF (KSURF(ILCOUR).NE.10.AND.KSURF(ILCOUR).NE.6) GOTO 104
  388.       if (ipt7.itypel.ne.3) goto 104
  389. C    ON FAIT DES QUA8 OU DES TRI6
  390.       NBNN=8
  391.       NBELEM=NUM(/2)
  392.       NBREF=4
  393.       NBSOUS=0
  394.       SEGINI IPT5
  395.       IPT5.ITYPEL=10
  396.       IPT1=LISREF(1)
  397.       IPT2=LISREF(2)
  398.       IPT3=LISREF(3)
  399.       IPT4=LISREF(4)
  400.       IPT5.LISREF(1)=IPT1
  401.       IPT5.LISREF(2)=IPT2
  402.       IPT5.LISREF(3)=IPT3
  403.       IPT5.LISREF(4)=IPT4
  404.       SEGACT IPT1,IPT2,IPT3,IPT4
  405.       DO 105 J=1,NUM(/1)
  406.       JJ=2*J-1
  407.       DO 105 I=1,NBELEM
  408.       IPT5.NUM(JJ,I)=NUM(J,I)
  409.  105  CONTINUE
  410.       NLIG=IPT1.NUM(/2)
  411.       DO 106 I=1,NLIG
  412.       IPT5.NUM(2,I)=IPT7.NUM(2,I)
  413.       IPT5.NUM(6,NBELEM-NLIG+I)=IPT8.NUM(2,I)
  414.       IPT5.ICOLOR(I) = IPT1.ICOLOR(I)
  415.  106  CONTINUE
  416.       DPAR=0.
  417.       NBPTS=IADR+NCOUCH*3*NLIG
  418.       SEGADJ MCOORD
  419.       DO 107 I=1,NCOUCH
  420.       IPT5.NUM(8,NLIG*(I-1)+1)=IPT4.NUM(2,NCOUCH+1-I)
  421.       IPT5.NUM(4,NLIG*I)=IPT2.NUM(2,I)
  422. C  ON FAIT D'ABORD LES NOEUDS 2 DU HAUT (6 DU BAS)
  423. C  CREATION DES NOEUDS
  424.       DIN=TABPAR(I)
  425.       DPAR=DPAR+DIN
  426.       IF (I.EQ.NCOUCH) GOTO 108
  427.       UMDPAR=1.-DPAR
  428.       DINA=DENI+DECA*DPAR
  429.       DO 109 J=1,NLIG
  430.       IREF1=IDIMP1*(IPT7.NUM(2,J)-1)
  431.       IREF2=IDIMP1*(IPT8.NUM(2,J)-1)
  432.       IREFA=IADR*IDIMP1
  433.       XCOOR(IREFA+1)=UMDPAR*XCOOR(IREF1+1)+DPAR*XCOOR(IREF2+1)
  434.       XCOOR(IREFA+2)=UMDPAR*XCOOR(IREF1+2)+DPAR*XCOOR(IREF2+2)
  435.       IF(IDIM.GE.3)
  436.      #XCOOR(IREFA+3)=UMDPAR*XCOOR(IREF1+3)+DPAR*XCOOR(IREF2+3)
  437.       XCOOR(IREFA+IDIMP1)=DINA
  438.       IADR=IADR+1
  439. C  ON MET LE NOEUD DANS LES ELEMENTS
  440.       IPT5.NUM(6,(I-1)*NLIG+J)=IADR
  441.       IPT5.NUM(2,I*NLIG+J)=IADR
  442.       IPT5.ICOLOR(I*NLIG+J) = IPT1.ICOLOR(J)
  443.  109  CONTINUE
  444.  108  CONTINUE
  445.       IF (NLIG.EQ.1) GOTO 113
  446. C  ON MET LES NOEUDS 4 DE GAUCHE ET 8 DE DROITE
  447. C  CREATION DES NOEUDS
  448.       EPAR=DPAR-TABPAR(I)*0.5
  449.       UMEPAR=1.-EPAR
  450.       DINA=DEN1+DECA*EPAR
  451.       DO 115 J=1,NLIG
  452.       DO 115 K=1,2
  453.       IF (K.EQ.1.AND.J.EQ.1) GOTO 115
  454.       IF (K.EQ.2.AND.J.EQ.NLIG) GOTO 115
  455.       IF (ICPR(K,J).NE.0) GOTO 116
  456.       IREF1=(IPT7.NUM(2*K-1,J)-1)*IDIMP1
  457.       IREF2=(IPT8.NUM(2*K-1,J)-1)*IDIMP1
  458.       IREFA=IADR*IDIMP1
  459.       XCOOR(IREFA+1)=UMEPAR*XCOOR(IREF1+1)+EPAR*XCOOR(IREF2+1)
  460.       XCOOR(IREFA+2)=UMEPAR*XCOOR(IREF1+2)+EPAR*XCOOR(IREF2+2)
  461.       IF(IDIM.GE.3)
  462.      #XCOOR(IREFA+3)=UMEPAR*XCOOR(IREF1+3)+EPAR*XCOOR(IREF2+3)
  463.       XCOOR(IREFA+IDIMP1)=DINA
  464.       IADR=IADR+1
  465.  116  CONTINUE
  466. C  NOEUDS DES ELEM
  467.       IF (ICPR(K,J).NE.0) GOTO 119
  468.       IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IADR
  469.       GOTO 115
  470.  119  CONTINUE
  471.       IPT5.NUM(4*(3-K),(I-1)*NLIG+J)=IPT5.NUM(4*(2-MOD(ICPR(K,J)-1,2)),
  472.      # (ICPR(K,J)+1)/2+(I-1)*NLIG)
  473.  115  CONTINUE
  474.  113  CONTINUE
  475.  107  CONTINUE
  476.       NBPTS=IADR
  477.       SEGADJ MCOORD
  478.       SEGSUP MELEME
  479.       MELEME=IPT5
  480.       SEGDES IPT1,IPT2,IPT3,IPT4,IPT7,IPT8
  481.       IF (KSURF(ILCOUR).NE.6) GOTO 101
  482. C  ON FAIT DES TRI6
  483.       NBNN=6
  484.       NBELEM=2*NUM(/2)
  485.       NBREF=4
  486.       NBSOUS=0
  487.       SEGINI IPT1
  488.       IPT1.ITYPEL=6
  489.       IPT1.LISREF(1)=LISREF(1)
  490.       IPT1.LISREF(2)=LISREF(2)
  491.       IPT1.LISREF(3)=LISREF(3)
  492.       IPT1.LISREF(4)=LISREF(4)
  493.       IALT=1
  494.       NBPTS=IADR+NCOUCH*NLIG
  495.       SEGADJ  MCOORD
  496.       DO 120 I=1,NCOUCH
  497.       DO 120 J=1,NLIG
  498.       INU=(I-1)*NLIG+J
  499.       IALT=3-IALT
  500. C  CREATION DU POINT SUPPLEMENTAIRE
  501.       IREF1=(NUM(2,INU)-1)*IDIMP1
  502.       IREF2=(NUM(6,INU)-1)*IDIMP1
  503.       IREFA=IADR*IDIMP1
  504.       XCOOR(IREFA+1)=(XCOOR(IREF1+1)+XCOOR(IREF2+1))*0.5
  505.       XCOOR(IREFA+2)=(XCOOR(IREF1+2)+XCOOR(IREF2+2))*0.5
  506.       IF (IDIM.GE.3)
  507.      #XCOOR(IREFA+3)=(XCOOR(IREF1+3)+XCOOR(IREF2+3))*0.5
  508.       XCOOR(IREFA+IDIMP1)=
  509.      #   (XCOOR(IREF1+IDIMP1)+XCOOR(IREF2+IDIMP1))*0.5
  510.       IADR=IADR+1
  511.       ITR1=2*INU-1
  512.       ITR2=2*INU
  513.       GOTO (124,125),IALT
  514. C  CREATION DES TRIANGLES
  515.  124  IPT1.NUM(1,ITR1)=NUM(1,INU)
  516.       IPT1.NUM(2,ITR1)=NUM(2,INU)
  517.       IPT1.NUM(3,ITR1)=NUM(3,INU)
  518.       IPT1.NUM(5,ITR1)=NUM(7,INU)
  519.       IPT1.NUM(6,ITR1)=NUM(8,INU)
  520.       IPT1.NUM(4,ITR1)=IADR
  521.       IPT1.NUM(1,ITR2)=NUM(3,INU)
  522.       IPT1.NUM(2,ITR2)=NUM(4,INU)
  523.       IPT1.NUM(3,ITR2)=NUM(5,INU)
  524.       IPT1.NUM(4,ITR2)=NUM(6,INU)
  525.       IPT1.NUM(5,ITR2)=NUM(7,INU)
  526.       IPT1.NUM(6,ITR2)=IADR
  527.       IPT1.ICOLOR(ITR1) = ICOLOR(INU)
  528.       IPT1.ICOLOR(ITR2) = ICOLOR(INU)
  529.       GOTO 126
  530.  125  IPT1.NUM(1,ITR1)=NUM(1,INU)
  531.       IPT1.NUM(2,ITR1)=NUM(2,INU)
  532.       IPT1.NUM(3,ITR1)=NUM(3,INU)
  533.       IPT1.NUM(4,ITR1)=NUM(4,INU)
  534.       IPT1.NUM(5,ITR1)=NUM(5,INU)
  535.       IPT1.NUM(6,ITR1)=IADR
  536.       IPT1.NUM(1,ITR2)=NUM(5,INU)
  537.       IPT1.NUM(2,ITR2)=NUM(6,INU)
  538.       IPT1.NUM(3,ITR2)=NUM(7,INU)
  539.       IPT1.NUM(4,ITR2)=NUM(8,INU)
  540.       IPT1.NUM(5,ITR2)=NUM(1,INU)
  541.       IPT1.NUM(6,ITR2)=IADR
  542.       IPT1.ICOLOR(ITR1) = ICOLOR(INU)
  543.       IPT1.ICOLOR(ITR2) = ICOLOR(INU)
  544.       GOTO 126
  545.  126  CONTINUE
  546.  120  CONTINUE
  547.       SEGSUP MELEME
  548.       MELEME=IPT1
  549.       GOTO 101
  550.  104  CONTINUE
  551.  101  CONTINUE
  552.       SEGSUP TABPAR,ICPR
  553. c c attribution de la couleur "moyenne"
  554. c       DO 152 I=1,NUM(/2)
  555. c  152  ICOLOR(I)=ICHCOL
  556.       IF (IFUSE1.EQ.0) GOTO 150
  557.       IPT5=IFUSE1
  558.       SEGACT IPT5
  559.       ltelq=.false.
  560.       CALL FUSE(IPT5,MELEME,IRET,ltelq)
  561.       SEGDES IPT5,MELEME
  562.       MELEME=IRET
  563.  150  CONTINUE
  564.       IF (IFUSE2.EQ.0) GOTO 151
  565.       IPT5=IFUSE2
  566.       SEGACT IPT5
  567.       ltelq=.false.
  568.       CALL FUSE(MELEME,IPT5,IRET,ltelq)
  569.       SEGDES IPT5,MELEME
  570.       MELEME=IRET
  571.  151  CONTINUE
  572.       CALL ECROBJ('MAILLAGE',MELEME)
  573.       SEGDES MELEME
  574.       RETURN
  575.       END
  576.  
  577.  
  578.  
  579.  
  580.  
  581.  
  582.  
  583.  
  584.  
  585.  
  586.  

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