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

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