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

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