Télécharger la plaquette Cast3M


fr en

Télécharger sym4d3.eso

Retour à la liste

Numérotation des lignes : 

sym4d3

  1. C SYM4D3    SOURCE    CB215821  20/11/25    13:40:34     10792          
  2. C NOR4D3    SOURCE    PV        09/03/12    21:29:31     6325
  3.       SUBROUTINE SYM4D3(
  4.      &            MELEFA,MELEFL,MLECEN,MELEFP,MLESOM,MPONOR,
  5.      &            MPOSUR,MELTFA,MLEFA,MLEFA2,MPOTEN,MPOCHP,MLENCL,
  6.      &            MPOVCL,ICHTE,ICHCL,ICHCO,MPOVCO,IOP,
  7.      &            IPO2,SCMB,INDLI,VAL1,VAL2,IND22,IND2,IND,
  8.      &            IPO3,TAB,MPOGRA,MELVA1,MELVA2,
  9.      &            NSOMM,NBMAX,NBFAC,NBCOT,MCHEL2,MCHAM2)
  10. C
  11. C PROJET            :  CASTEM 2000
  12. C
  13. C NOM               :  NORV4
  14. C
  15. C DESCRIPTION       : Appelle par NORV1
  16. C
  17. C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
  18. C
  19. C AUTEUR            :  C. LE POTIER, DM2S/SFME/MTMS
  20. C
  21. C************************************************************************
  22. C
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8(A-H,O-Z)
  25.  
  26. -INC SMLENTI
  27. -INC SMELEME
  28. -INC SMCHPOI
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMCOORD
  33. -INC SMCHAML
  34. -INC SMLREEL
  35.  
  36.       POINTEUR MELEFL.MELEME, MELEFP.MELEME, MELEFA.MELEME,
  37.      &         MELTFA.MELEME,MELEP2.MELEME
  38.       POINTEUR MPOSUR.MPOVAL, MPONOR.MPOVAL,
  39.      & MPOCHP.MPOVAL, MPOVCL.MPOVAL, MPGSOM.MPOVAL, MPVOSO.MPOVAL,
  40.      & MPOGRA.MPOVAL,MPOTEN.MPOVAL,MPOVCO.MPOVAL
  41.       POINTEUR MLENCL.MLENTI, MLECEN.MLENTI, MLESOM.MLENTI,
  42.      &         MLEFA.MLENTI,MLEFA2.MLENTI
  43.       INTEGER NBNN,NBREF,NBMAX
  44.  
  45. C**** Variable de SMLENTI, SMCHPOI
  46. C
  47.       INTEGER JG, N, NC,  NSOUPO, NAT, NBSOUS, NBNO,NBELEM
  48. C
  49. C**** Les includes
  50. C
  51.       INTEGER I1,ICOMP,ICOMGR,IGEOM
  52.      &     ,IOP1,ICEN,ISOMM,IFAC,IFACEL,IFACEP,INORM
  53.      &     ,ISURF,IMAIL,ICHPO,ICHCL,ICHGRA,ICOEFF
  54.      &     ,NTOT,NSOMM,NCOMP,NFAC,NCEN
  55.      &     ,NLCF,NGCF,NGCF1,NGCF2,NGCG,NGCD,NLCG,NLCD,NGS1,NGS2
  56.      &     ,NLS1,NLS2,NLFCL
  57.      &     ,ISOUS,IELEM,INOEUD,ICELL,NCON,NFIN,INDGA,INDDR
  58.       INTEGER ICEN2
  59.       REAL*8 SCNX,SCNY,SCNZ,SURF,VOL,VAL,VALX,VALY,VALZ,XG,XD,XF,XS1,XS2
  60.      &     ,YG,YD,YF,YS1,YS2,ZG,ZD,ZF,ZS1,ZS2,
  61.      &     PSCA,XNORM,VECX,VECY,PSCAGX,PSCAGY,PSCAGZ,
  62.      &     PSCADX,PSCADY,PSCADZ,K11G,K22G,K21G,K31G,K32G,K33G,
  63.      &     K11D,K22D,K21D,K31D,K32D,K33D,VXG1,VXG2,
  64.      &     VXAU,VYAU,VZAU,VXD1,VXD2,VYG1,VYG2,VYD1,VYD2,VZG1,VZG2,VZD1,VZD2,
  65.      &     TRG1,TRG2,TRG3,
  66.      &     TRD1,TRD2,TRD3,TRG,TRD,AUX,AUY,AUZ,AUXMA,THETA,COEFDD
  67.       REAL*8 XLONG,AG1,AG2,AD1,AD2,PSCAG1,PSCAG2,PSCAD1,PSCAD2,
  68.      & COEF1,COEF2,COEF3,COEF4,SCN1X,SCN1Y,SCN1Z,VX,VY,VZ,COEF1X,COEF2X,
  69.      & COEF1Y,COEF2Y,COEF1Z,COEF2Z,CX,CY,CZ,ANCX,ANCY,ANCZ,
  70.      & DIFFX,DIFFY,DIFFZ,XLONGG,XLONGD
  71.      &  VALD,VALG,COEF,GX,GY,GZ,UN,EXPR1,EXPR2
  72.  
  73. c      REAL*8 VECXG1(2),VECYG1(2)
  74. c      REAL*8 VECXG2(2),VECYG2(2)
  75. c      REAL*8 VECXD1(2),VECYD1(2)
  76. c      REAL*8 VECXD2(2),VECYD2(2)
  77.  
  78.       REAL*8 VECXG(4,4),VECYG(4,4),VECZG(4,4)
  79.       REAL*8 VECXD(4,4),VECYD(4,4),VECZD(4,4)
  80.       REAL*8 VOLUG(4),SURFAGX(4),SURFAGY(4),SURFAGZ(4),COEFG(4)
  81.       REAL*8 VOLUD(4),SURFADX(4),SURFADY(4),SURFADZ(4),COEFD(4)
  82.       REAL*8 PX(3,4),PY(3,4),PZ(3,4),TRGAUX(4)
  83.       REAL*8 XPRO,TRACE
  84.       INTEGER NGS(4),NLS(4)
  85.       INTEGER NLOCFG(4,4),NLOCFD(4,4)
  86.       INTEGER IGNS(4)
  87.       REAL*8 EPS,ALPHA
  88.       REAL*8 XARG(4,4),YARG(4,4),ZARG(4,4),XCOUR,YCOUR,ZCOUR
  89.       REAL*8 XFACG(4,4),YFACG(4,4),ZFACG(4,4),VAX,VAY,VAZ
  90.       REAL*8 XARD(4,4),YARD(4,4),ZARD(4,4),XCO,YCO,ZCO
  91.       REAL*8 XFACD(4,4),YFACD(4,4),ZFACD(4,4)
  92.       REAL*8 XA,YA,ZA,DIST1,DIST2
  93.       REAL*8 VAUX(3),VAUY(3),VAUZ(3)
  94.       REAL*8 PVECX,PVECY,PVECZ
  95.       INTEGER ICRIT
  96.       CHARACTER*(4) NOMCOM(3)
  97.       CHARACTER*8 TYPE
  98. C
  99.       DATA NOMCOM  /'P1DX','P1DY','P1DZ'/
  100.  
  101.       INTEGER NDIM
  102.       SEGMENT MMAT1
  103.       REAL*8 PM(NDIM,NDIM),PM1(NDIM,NDIM),XSOL(NDIM)
  104.       INTEGER IC(NDIM)
  105.       ENDSEGMENT
  106.  
  107.       INTEGER K1,K2
  108.       SEGMENT INDICE
  109.       INTEGER NUME(K1,K2)
  110.       ENDSEGMENT
  111.       POINTEUR IND.INDICE,IND2.INDICE,IND22.INDICE
  112.  
  113.       SEGMENT MATRICE
  114.       REAL*8 MAT(K1,K2)
  115.       ENDSEGMENT
  116.       POINTEUR VAL1.MATRICE,VAL2.MATRICE,SCMB.MATRICE
  117.  
  118.       INTEGER K3
  119.       SEGMENT POINT2
  120.       INTEGER POINT(K3)
  121.       ENDSEGMENT
  122.       POINTEUR IPO2.POINT2
  123.  
  124.       SEGMENT MATRICE2
  125.       REAL*8 MAT2(K1,K2)
  126.       ENDSEGMENT
  127.       POINTEUR MATR1.MATRICE2,MATR2.MATRICE2
  128.  
  129.       SEGMENT POINT3
  130.       INTEGER POINT33(K3)
  131.       ENDSEGMENT
  132.       POINTEUR IPO3.POINT3
  133.  
  134.       SEGMENT INDICE3
  135.       INTEGER NU(K1,K2)
  136.       ENDSEGMENT
  137.       POINTEUR INDIC.INDICE3
  138.  
  139.       SEGMENT REP
  140.       INTEGER  ID(K3)
  141.       ENDSEGMENT
  142.       POINTEUR TAB.REP,INDLI.REP
  143.  
  144.       INTEGER K5
  145.       SEGMENT NBFAC
  146.       INTEGER NBFACEL(K5)
  147.       INTEGER IMELEM(K5)
  148.       ENDSEGMENT
  149.  
  150.       INTEGER K6
  151.       SEGMENT NBCOT
  152.       INTEGER NBCOTE(K6)
  153.       INTEGER IMECOTE(K6)
  154.       ENDSEGMENT
  155.  
  156.       INTEGER K7,K8
  157.       SEGMENT MISZERO
  158.       INTEGER  TABL(K7)
  159.       INTEGER  TABL2(K7)
  160.       INTEGER  TABL1(K8),IPOS(K8),ICOURANT(K8)
  161.       REAL*8 XMAX(K7)
  162.       ENDSEGMENT
  163.       POINTEUR ITAB.MISZERO
  164.  
  165.  
  166.  
  167.  
  168. c       ALPHA = 2.0/3.0
  169.        ALPHA = 2.0/3.0
  170.        NMAI1 = 0
  171.        NMAI2 = 0
  172.        NMAI3 = 0
  173.        NMAI4 = 0
  174.        NBSO = MAX(1,MELTFA.LISOUS(/1))
  175. c       WRITE(6,*) 'NBSO MAILLE= ',NBSO
  176. c       WRITE(6,*) 'MELTFA= ',MELTFA
  177.        IELTFA = MELTFA
  178.        IF (NBSO.EQ.1) THEN
  179.        K5 = MELTFA.NUM(/2)
  180.        ELSEIF (NBSO.EQ.2) THEN
  181.        IPT1 = MELTFA.LISOUS(1)
  182.        SEGACT IPT1
  183.        N1 = IPT1.NUM(/2)
  184.        NMAI1 = N1
  185.        SEGDES IPT1
  186.        IPT2 = MELTFA.LISOUS(2)
  187.        SEGACT IPT2
  188.        N2 = IPT2.NUM(/2)
  189.        NMAI2 = N2
  190.        SEGDES IPT2
  191.        K5 = N1 + N2
  192.        ELSEIF (NBSO.EQ.3) THEN
  193.        IPT1 = MELTFA.LISOUS(1)
  194.        SEGACT IPT1
  195.        N1 = IPT1.NUM(/2)
  196.        NMAI1 = N1
  197.        SEGDES IPT1
  198. c       WRITE(6,*) 'N1= ',N1
  199.        IPT2 = MELTFA.LISOUS(2)
  200.        SEGACT IPT2
  201.        N2 = IPT2.NUM(/2)
  202.        NMAI2 = N2
  203.        SEGDES IPT2
  204. c       WRITE(6,*) 'N2= ',N2
  205.        IPT3 = MELTFA.LISOUS(3)
  206.        SEGACT IPT3
  207.        N3 = IPT3.NUM(/2)
  208.        NMAI3 = N3
  209. c       WRITE(6,*) 'N3= ',N3
  210.        SEGDES IPT3
  211.        K5 = N1 + N2 + N3
  212.        ELSEIF (NBSO.EQ.4) THEN
  213.        IPT1 = MELTFA.LISOUS(1)
  214.        SEGACT IPT1
  215.        N1 = IPT1.NUM(/2)
  216.        NMAI1 = N1
  217.        SEGDES IPT1
  218.        IPT2 = MELTFA.LISOUS(2)
  219.        SEGACT IPT2
  220.        N2 = IPT2.NUM(/2)
  221.        NMAI2 = N2
  222.        SEGDES IPT2
  223.        IPT3 = MELTFA.LISOUS(3)
  224.        SEGACT IPT3
  225.        N3 = IPT3.NUM(/2)
  226.        NMAI3 = N3
  227.        SEGDES IPT3
  228.        IPT4 = MELTFA.LISOUS(4)
  229.        SEGACT IPT4
  230.        N4 = IPT4.NUM(/2)
  231.        NMAI4 = N4
  232.        SEGDES IPT4
  233.        K5 = N1 + N2 + N3 + N4
  234.        ENDIF
  235. c       WRITE(6,*) 'K5= ',K5
  236.  
  237.  
  238.  
  239.        IF (NBSO.EQ.1) THEN
  240.        DO I = 1,K5
  241.            NTYPE = MELTFA.ITYPEL
  242. c           WRITE(6,*) 'NTYPE= ',NTYPE
  243.            IF (NTYPE .EQ. 16) THEN
  244.            NBFACEL(I) = 6
  245.            IMELEM(I) = MELTFA
  246.            ELSEIF (NTYPE .EQ. 25) THEN
  247.            NBFACEL(I) = 5
  248.            IMELEM(I) = MELTFA
  249.            ELSEIF (NTYPE .EQ. 23) THEN
  250.            NBFACEL(I) = 4
  251.            IMELEM(I) = MELTFA
  252.            ELSEIF (NTYPE .EQ. 9) THEN
  253.            NBFACEL(I) = 5
  254.            IMELEM(I) = MELTFA
  255.            ENDIF
  256. c       SEGDES MELTFA
  257.        ENDDO
  258.        ELSEIF (NBSO.EQ.2) THEN
  259.          IPT1 = MELTFA.LISOUS(1)
  260.          SEGACT IPT1
  261.          IPT2 = MELTFA.LISOUS(2)
  262.          SEGACT IPT2
  263.        DO I = 1,K5
  264.          N1 = IPT1.NUM(/2)
  265.          IF (I.LE.N1) THEN
  266.            NTYPE = IPT1.ITYPEL
  267.            IF (NTYPE .EQ. 16) THEN
  268.            NBFACEL(I) = 6
  269.            IMELEM(I) =  IPT1
  270.            ELSEIF (NTYPE .EQ. 25) THEN
  271.            NBFACEL(I) = 5
  272.            IMELEM(I) = IPT1
  273.            ELSEIF (NTYPE .EQ. 23) THEN
  274.            NBFACEL(I) = 4
  275.            IMELEM(I) = IPT1
  276.            ELSEIF (NTYPE .EQ. 9) THEN
  277.            NBFACEL(I) = 5
  278.            IMELEM(I) = IPT1
  279.            ENDIF
  280.          ELSE
  281.            NTYPE = IPT2.ITYPEL
  282.            IF (NTYPE .EQ. 16) THEN
  283.            NBFACEL(I) = 6
  284.            IMELEM(I) =  IPT2
  285.            ELSEIF (NTYPE .EQ. 25) THEN
  286.            NBFACEL(I) = 5
  287.            IMELEM(I) = IPT2
  288.            ELSEIF (NTYPE .EQ. 23) THEN
  289.            NBFACEL(I) = 4
  290.            IMELEM(I) = IPT2
  291.            ELSEIF (NTYPE .EQ. 9) THEN
  292.            NBFACEL(I) = 5
  293.            IMELEM(I) = IPT2
  294.            ENDIF
  295.         ENDIF
  296.       ENDDO
  297.       ELSEIF (NBSO.EQ.3) THEN
  298. c         WRITE(6,*) 'COUCOU'
  299.          IPT1 = MELTFA.LISOUS(1)
  300.          SEGACT IPT1
  301.            NTYPE = IPT1.ITYPEL
  302. c           WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL
  303.          IPT2 = MELTFA.LISOUS(2)
  304.          SEGACT IPT2
  305.            NTYPE = IPT2.ITYPEL
  306. c           WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL
  307.          IPT3 = MELTFA.LISOUS(3)
  308.          SEGACT IPT3
  309.            NTYPE = IPT3.ITYPEL
  310. c           WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL
  311.          N1 = IPT1.NUM(/2)
  312.          N2 = IPT2.NUM(/2)
  313.          N3 = IPT3.NUM(/2)
  314.        DO I = 1,K5
  315.          IF (I.LE.N1) THEN
  316.            NTYPE = IPT1.ITYPEL
  317.            IF (NTYPE .EQ. 16) THEN
  318.            NBFACEL(I) = 6
  319.            IMELEM(I) =  IPT1
  320.            ELSEIF (NTYPE .EQ. 25) THEN
  321.            NBFACEL(I) = 5
  322.            IMELEM(I) = IPT1
  323.            ELSEIF (NTYPE .EQ. 23) THEN
  324.            NBFACEL(I) = 4
  325.            IMELEM(I) = IPT1
  326.            ELSEIF (NTYPE .EQ. 9) THEN
  327.            NBFACEL(I) = 5
  328.            IMELEM(I) = IPT1
  329.            ENDIF
  330.          ELSEIF (I.LE.(N1+N2)) THEN
  331.            NTYPE = IPT2.ITYPEL
  332.            IF (NTYPE .EQ. 16) THEN
  333.            NBFACEL(I) = 6
  334.            IMELEM(I) =  IPT2
  335.            ELSEIF (NTYPE .EQ. 25) THEN
  336.            NBFACEL(I) = 5
  337.            IMELEM(I) = IPT2
  338.            ELSEIF (NTYPE .EQ. 23) THEN
  339.            NBFACEL(I) = 4
  340.            IMELEM(I) = IPT2
  341.            ELSEIF (NTYPE .EQ. 9) THEN
  342.            NBFACEL(I) = 5
  343.            IMELEM(I) = IPT2
  344.            ENDIF
  345.          ELSE
  346.            NTYPE = IPT3.ITYPEL
  347.            IF (NTYPE .EQ. 16) THEN
  348.            NBFACEL(I) = 6
  349.            IMELEM(I) =  IPT3
  350.            ELSEIF (NTYPE .EQ. 25) THEN
  351.            NBFACEL(I) = 5
  352.            IMELEM(I) = IPT3
  353.            ELSEIF (NTYPE .EQ. 23) THEN
  354.            NBFACEL(I) = 4
  355.            IMELEM(I) = IPT3
  356.            ELSEIF (NTYPE .EQ. 9) THEN
  357.            NBFACEL(I) = 5
  358.            IMELEM(I) = IPT3
  359.            ENDIF
  360.          ENDIF
  361.         ENDDO
  362.       ELSEIF (NBSO.EQ.4) THEN
  363.          IPT1 = MELTFA.LISOUS(1)
  364.          SEGACT IPT1
  365.            NTYPE = IPT1.ITYPEL
  366. c           WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL
  367.          IPT2 = MELTFA.LISOUS(2)
  368.          SEGACT IPT2
  369.            NTYPE = IPT2.ITYPEL
  370. c           WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL
  371.          IPT3 = MELTFA.LISOUS(3)
  372.          SEGACT IPT3
  373.            NTYPE = IPT3.ITYPEL
  374. c           WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL
  375.          IPT4 = MELTFA.LISOUS(4)
  376.          SEGACT IPT4
  377.            NTYPE = IPT4.ITYPEL
  378. c           WRITE(6,*) 'NTYPE= ',IPT4.ITYPEL
  379.          N1 = IPT1.NUM(/2)
  380.          N2 = IPT2.NUM(/2)
  381.          N3 = IPT3.NUM(/2)
  382.          N4 = IPT4.NUM(/2)
  383.        DO I = 1,K5
  384.          IF (I.LE.N1) THEN
  385.            NTYPE = IPT1.ITYPEL
  386.            IF (NTYPE .EQ. 16) THEN
  387.            NBFACEL(I) = 6
  388.            IMELEM(I) =  IPT1
  389.            ELSEIF (NTYPE .EQ. 25) THEN
  390.            NBFACEL(I) = 5
  391.            IMELEM(I) = IPT1
  392.            ELSEIF (NTYPE .EQ. 23) THEN
  393.            NBFACEL(I) = 4
  394.            IMELEM(I) = IPT1
  395.            ELSEIF (NTYPE .EQ. 9) THEN
  396.            NBFACEL(I) = 5
  397.            IMELEM(I) = IPT1
  398.            ENDIF
  399.          ELSEIF (I.LE.(N1+N2)) THEN
  400.            NTYPE = IPT2.ITYPEL
  401.            IF (NTYPE .EQ. 16) THEN
  402.            NBFACEL(I) = 6
  403.            IMELEM(I) =  IPT2
  404.            ELSEIF (NTYPE .EQ. 25) THEN
  405.            NBFACEL(I) = 5
  406.            IMELEM(I) = IPT2
  407.            ELSEIF (NTYPE .EQ. 23) THEN
  408.            NBFACEL(I) = 4
  409.            IMELEM(I) = IPT2
  410.            ELSEIF (NTYPE .EQ. 9) THEN
  411.            NBFACEL(I) = 5
  412.            IMELEM(I) = IPT2
  413.            ENDIF
  414.          ELSEIF (I.LE.(N1+N2+N3)) THEN
  415.            NTYPE = IPT3.ITYPEL
  416.            IF (NTYPE .EQ. 16) THEN
  417.            NBFACEL(I) = 6
  418.            IMELEM(I) =  IPT3
  419.            ELSEIF (NTYPE .EQ. 25) THEN
  420.            NBFACEL(I) = 5
  421.            IMELEM(I) = IPT3
  422.            ELSEIF (NTYPE .EQ. 23) THEN
  423.            NBFACEL(I) = 4
  424.            IMELEM(I) = IPT3
  425.            ELSEIF (NTYPE .EQ. 9) THEN
  426.            NBFACEL(I) = 5
  427.            IMELEM(I) = IPT3
  428.            ENDIF
  429.          ELSE
  430.            NTYPE = IPT4.ITYPEL
  431.            IF (NTYPE .EQ. 16) THEN
  432.            NBFACEL(I) = 6
  433.            IMELEM(I) =  IPT4
  434.            ELSEIF (NTYPE .EQ. 25) THEN
  435.            NBFACEL(I) = 5
  436.            IMELEM(I) = IPT4
  437.            ELSEIF (NTYPE .EQ. 23) THEN
  438.            NBFACEL(I) = 4
  439.            IMELEM(I) = IPT4
  440.            ELSEIF (NTYPE .EQ. 9) THEN
  441.            NBFACEL(I) = 5
  442.            IMELEM(I) = IPT4
  443.            ENDIF
  444.          ENDIF
  445.         ENDDO
  446.       ENDIF
  447.  
  448. c CAS OU LES FACES SONT DES TRIANGLES OU DES FACES
  449.        MAUX = MELEFP
  450.        NFAI1 = 0
  451.        NBSOF = MAX(1,MELEFP.LISOUS(/1))
  452. c       WRITE(6,*) 'NBSOF FACE= ',NBSOF
  453.        IELTFA = MELTFA
  454.        IF (NBSOF.EQ.1) THEN
  455.        K6 = MELEFP.NUM(/2)
  456.        ELSEIF (NBSOF.EQ.2) THEN
  457.        IPT5 = MELEFP.LISOUS(1)
  458.        SEGACT IPT5
  459.        N1 = IPT5.NUM(/2)
  460.        NFAI1 = N1
  461.        SEGDES IPT5
  462.        IPT6 = MELEFP.LISOUS(2)
  463.        SEGACT IPT6
  464.        N2 = IPT6.NUM(/2)
  465.        NFAI2 = N2
  466.        SEGDES IPT6
  467.        K6 = N1 + N2
  468.        ENDIF
  469.  
  470. C ON EST ICI
  471.        IF (NBSOF.EQ.1) THEN
  472.        DO I = 1,K6
  473.            NTYPE = MELEFP.ITYPEL
  474. c           WRITE(6,*) 'NTYPE= ',NTYPE
  475.            IF (NTYPE .EQ. 5) THEN
  476.            NBCOTE(I) = 3
  477.            IMECOTE(I) = MELEFP
  478.            ELSE
  479.            NBCOTE(I) = 4
  480.            IMECOTE(I) = MELEFP
  481.            ENDIF
  482. c       SEGDES MELTFA
  483.        ENDDO
  484.        ELSEIF (NBSOF.EQ.2) THEN
  485. c       WRITE(6,*) 'POINT2'
  486.          IPT5 = MELEFP.LISOUS(1)
  487.          SEGACT IPT5
  488.          IPT6 = MELEFP.LISOUS(2)
  489.          SEGACT IPT6
  490. c          WRITE(6,*) 'IPT5= ',IPT5.ITYPEL
  491. c          WRITE(6,*) 'IPT6= ',IPT6.ITYPEL
  492.        DO I = 1,K6
  493.          N1 = IPT5.NUM(/2)
  494. C MISE A JOUR DE MLEFA.LECT
  495.          IF (I.LE.N1) THEN
  496.          N0 = IPT5.NUM(/1)
  497.          NGFAUX = IPT5.NUM(N0,I)
  498.          MLEFA2.LECT(NGFAUX) = I
  499. c           WRITE(6,*)  'NGFAUX = ',NGFAUX,
  500. c     &                 'MLEFA2=',MLEFA2.LECT(NGFAUX)
  501.            IF (IPT5.ITYPEL .EQ. 5) THEN
  502.            NBCOTE(I) = 3
  503.            IMECOTE(I) =  IPT5
  504.            ELSE
  505.            NBCOTE(I) = 4
  506.            IMECOTE(I) = IPT5
  507.            ENDIF
  508. c         SEGDES IPT5
  509.          ELSE
  510.          N0 = IPT6.NUM(/1)
  511.          NGFAUX = IPT6.NUM(N0,I-NFAI1)
  512.          MLEFA2.LECT(NGFAUX) = I
  513.            IF (IPT6.ITYPEL .EQ. 5) THEN
  514.            NBCOTE(I) = 3
  515.            IMECOTE(I) = IPT6
  516.            ELSE
  517.            NBCOTE(I) = 4
  518.            IMECOTE(I) =  IPT6
  519.            ENDIF
  520. c           SEGDES IPT6
  521.         ENDIF
  522.  
  523.         ENDDO
  524.         ENDIF
  525.  
  526.  
  527.  
  528.       NFAC=MELEFL.NUM(/2)
  529.  
  530.  
  531. c ON MAJORE SUPERIEUREMENT NBNN : ON LE REAJUSTERA PAR LA SUITE
  532.          NCON = ((2*NBMAX)) + 1
  533.          NBNN = NCON
  534.          NESSAI = NCON
  535.          NBNN = NESSAI
  536. c         WRITE(6,*) 'NBMAX= ',NBMAX
  537. c         WRITE(6,*) 'NBNN= ',NBNN
  538. c         WRITE(6,*) 'NFAC= ',NFAC
  539.  
  540.  
  541.  
  542. C DEFINITION DES PARAMETRES DU CHAMELEM DES COEFFICIENTS
  543.  
  544. c INITIALISATION DU CHAMELEM
  545.       N1=1
  546.       N2=1
  547. c      WRITE(6,*) 'N2= ',N2
  548.       N3=6
  549.       L1=8
  550.       SEGINI MCHELM
  551.       ICOEFF = MCHELM
  552.       MCHELM.TITCHE='Gradient'
  553.       MCHELM.IFOCHE=IFOUR
  554. C
  555.       ISOUS=0
  556.       NBSOUS=0
  557.       NBREF=0
  558.       NBELEM = NFAC
  559.       ISOUS=ISOUS+1
  560.       SEGINI MELEME
  561. C     ITYPEL=32 -> 'POLY'
  562.       ITYPEL=32
  563.       MCHELM.IMACHE(ISOUS)=MELEME
  564.       SEGINI MCHAML
  565.       MCHELM.ICHAML(ISOUS)=MCHAML
  566.       MCHAML.NOMCHE(1)='SCAL'
  567.       MCHAML.TYPCHE(1)='REAL*8          '
  568.       N1PTEL=NESSAI
  569.       N1EL=NBELEM
  570.       N2PTEL=0
  571.       N2EL=0
  572.       SEGINI MELVA1
  573.       MCHAML.IELVAL(1)=MELVA1
  574.  
  575.  
  576.  
  577.  
  578. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  579. C CALCUL DE LA VITESSE EN CHAQUE FACE
  580.       AA = 0.0
  581.       BB = 0.0
  582. C INDICE QUI COMPTE LES COEFFICIENTS POUR CHAQUE FACE
  583.       NAUX2 = 0
  584.       NMOY = 0
  585.       DO NLCF= 1, NFAC, 1
  586.       NCON = 1
  587.  
  588.          NGCF=MELEFL.NUM(2,NLCF)
  589.          NGCG=MELEFL.NUM(1,NLCF)
  590.          NGCD=MELEFL.NUM(3,NLCF)
  591.          NLCG=MLECEN.LECT(NGCG)
  592.          NLCD=MLECEN.LECT(NGCD)
  593.  
  594.          SCNX=MPONOR.VPOCHA(NLCF,1)
  595.          SCNY=MPONOR.VPOCHA(NLCF,2)
  596.          SCNZ=MPONOR.VPOCHA(NLCF,3)
  597.          SCN1X = SCNX
  598.          SCN1Y = SCNY
  599.          SCN1Z = SCNZ
  600.          SURF=0.5D0*MPOSUR.VPOCHA(NLCF,1)
  601.          SCNX=SCNX*SURF
  602.          SCNY=SCNY*SURF
  603.          SCNZ=SCNZ*SURF
  604.  
  605. C        4=IDIM+1
  606.          ICELL=(4*(NGCG -1))+1
  607.          XG=MCOORD.XCOOR(ICELL)
  608.          YG=MCOORD.XCOOR(ICELL+1)
  609.          ZG=MCOORD.XCOOR(ICELL+2)
  610.          ICELL=(4*(NGCD -1))+1
  611.          XD=MCOORD.XCOOR(ICELL)
  612.          YD=MCOORD.XCOOR(ICELL+1)
  613.          ZD=MCOORD.XCOOR(ICELL+2)
  614.          ICELL=(4*(NGCF -1))+1
  615.          XF=MCOORD.XCOOR(ICELL)
  616.          YF=MCOORD.XCOOR(ICELL+1)
  617.          ZF=MCOORD.XCOOR(ICELL+2)
  618.  
  619.  
  620.          MELEME.NUM(1,NLCF)=NGCF
  621.          MELVA1.VELCHE(1,NLCF)=0.0D0
  622.  
  623.          DO J= 1,NBNN
  624.          MELVA1.VELCHE(J,NLCF) = 0.0D0
  625.          ENDDO
  626.  
  627. C MISE A ZERO DE NLOC
  628.             DO JA=1,4
  629.               DO IA=1,3
  630.               NLOCFG(IA,JA) = 0
  631.               NLOCFD(IA,JA) = 0
  632.               ENDDO
  633.             ENDDO
  634.  
  635.  
  636.          MELTFA =  IMELEM(NLCG)
  637.          NBF = NBFACEL(NLCG)
  638.          IF (NLCG.LE.NMAI1) THEN
  639.          NGAUX = NLCG
  640.          ELSEIF ((NLCG.GT.NMAI1).AND.(NLCG.LE.(NMAI1+NMAI2))) THEN
  641.          NGAUX = NLCG - NMAI1
  642.          ELSEIF ((NLCG.GT.(NMAI1+NMAI2)).AND.
  643.      &                  (NLCG.LE.(NMAI1+NMAI2+NMAI3))) THEN
  644.          NGAUX = NLCG - (NMAI1+NMAI2)
  645.          ELSEIF (NLCG.GT.(NMAI1+NMAI2+NMAI3)) THEN
  646.          NGAUX = NLCG - (NMAI1+NMAI2+NMAI3)
  647.          ENDIF
  648.  
  649.  
  650.  
  651. c ON TIENT COMPTE DU CHANGEMENT DE NUMEROTATION
  652.  
  653.  
  654.  
  655.          NLCF1 = MLEFA2.LECT(NGCF)
  656.          NBNO = NBCOTE(NLCF1)
  657.          MELEFP = IMECOTE(NLCF1)
  658.          IF (NLCF1.GT.NFAI1) THEN
  659.          NLCF1AUX = NLCF1 - NFAI1
  660.          ELSE
  661.          NLCF1AUX = NLCF1
  662.          ENDIF
  663.  
  664.  
  665.            DO IA=1,NBNO
  666.             NGS(IA) = MELEFP.NUM(IA,NLCF1AUX)
  667.             NLS(IA) = MLESOM.LECT(NGS(IA))
  668.             ICELL=(4*(NGS(IA) -1))+1
  669.             ENDDO
  670.  
  671.          DO JA = 1,NBNO
  672.          NGS(JA) = MELEFP.NUM(JA,NLCF1AUX)
  673.              ICELL=(4*(NGS(JA) -1))+1
  674.              XA = MCOORD.XCOOR(ICELL)
  675.              YA = MCOORD.XCOOR(ICELL+1)
  676.              ZA = MCOORD.XCOOR(ICELL+2)
  677.  
  678.  
  679. C ON CALCULE P2 ET P3, VOIR RAPPORT PAGE 17
  680.              DIST2 = -100000000000.
  681. Con CALCULE LE PLUS GRAND
  682.              DO I1 =1,NBNO
  683.              NSOM1 = MELEFP.NUM(I1,NLCF1AUX)
  684.              ICELL=(4*(NSOM1 -1))+1
  685.              XCOUR=MCOORD.XCOOR(ICELL)
  686.              YCOUR=MCOORD.XCOOR(ICELL+1)
  687.              ZCOUR=MCOORD.XCOOR(ICELL+2)
  688.              DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2)
  689.              DIST1 = SQRT( DIST1)
  690.              IF ((DIST1.GT.DIST2)) THEN
  691.                 DIST2 = DIST1
  692.                 ICOURAN = I1
  693.              ENDIF
  694.              ENDDO
  695.  
  696.              IF (JA.EQ.1) ICOURAN=3
  697.              IF (JA.EQ.2) ICOURAN=4
  698.              IF (JA.EQ.3) ICOURAN=1
  699.              IF (JA.EQ.4) ICOURAN=2
  700.  
  701.              IF (NBNO.EQ.3) THEN
  702.              ICOURAN = 0
  703.              ENDIF
  704.  
  705.  
  706.              INDFAC=2
  707. c              WRITE(6,*) 'ICOURAN= ',ICOURAN
  708. c              WRITE(6,*) 'JA= ',JA
  709.              DO I1 =1,NBNO
  710.              NSOM1 = MELEFP.NUM(I1,NLCF1AUX)
  711.              ICELL=(4*(NSOM1 -1))+1
  712.              XCOUR=MCOORD.XCOOR(ICELL)
  713.              YCOUR=MCOORD.XCOOR(ICELL+1)
  714.              ZCOUR=MCOORD.XCOOR(ICELL+2)
  715.  
  716.              IF ((I1.NE.ICOURAN).AND.(I1.NE.JA)) THEN
  717.               XARG(INDFAC,JA) = 0.5D0*(XA+XCOUR)
  718.               YARG(INDFAC,JA) = 0.5D0*(YA+YCOUR)
  719.               ZARG(INDFAC,JA) = 0.5D0*(ZA+ZCOUR)
  720. c              WRITE(6,*) 'X= ',XARG(INDFAC,JA),
  721. c     &       'Y= ',YARG(INDFAC,JA),'Z= ',ZARG(INDFAC,JA)
  722. c              WRITE(6,*) 'XA= ',XA,
  723. c     &       'YA= ',YA,'ZA= ',ZA
  724. c              WRITE(6,*) 'XCOUR= ',XCOUR,
  725. c     &       'YCOUR= ',YCOUR,'ZCOUR= ',ZCOUR
  726.              INDFAC= INDFAC+1
  727.              ENDIF
  728.              ENDDO
  729.  
  730. c              WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA
  731. c              WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ',
  732. c     &        ZARG(2,JA)
  733. c              WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ',
  734. c     &        ZARG(3,JA)
  735. c              WRITE(6,*) 'D', 'X= ',XF,'Y= ',YF,'Z= ',ZF
  736.  
  737.  
  738. c             IF (NLCF.EQ.14) then
  739. c         WRITE(6,*) 'NGAUX= ',NGAUX,'JA= ',JA,'NGS= ',NGS(JA)
  740. c         WRITE(6,*) 'NGCF= ',NGCF,'NLCF= ',NLCF
  741. c          ENDIF
  742.  
  743.          ICOUR = 1
  744.          DO J = 1,NBF
  745.             N1 = MELTFA.NUM(J,NGAUX)
  746.             NL1 = MLEFA2.LECT(N1)
  747.              NBNO2 = NBCOTE(NL1)
  748.              MELEP2 = IMECOTE(NL1)
  749.              IF (NL1.GT.NFAI1) THEN
  750.              NL1AUX = NL1 - NFAI1
  751.              ELSE
  752.              NL1AUX = NL1
  753.              ENDIF
  754. c             IF (NLCF.EQ.14) then
  755. c             WRITE(6,*) 'N1= ',N1,'NL1= ',NL1,'NL1AUX= ',NL1AUX
  756. c             ENDIF
  757.  
  758.  
  759.  
  760.  
  761.  
  762.              DO IA =1,NBNO2
  763.              NSOM1 = MELEP2.NUM(IA,NL1AUX)
  764.  
  765.  
  766.  
  767. c             IF (NLCF.EQ.14) then
  768. c             WRITE(6,*) 'NBNO2= ',NBNO2,'IA= ',IA,'NSOM1= ',NSOM1
  769. c             ENDIF
  770.              IF (NSOM1.EQ.NGS(JA)) THEN
  771.  
  772.              ICELL=(4*(N1 -1))+1
  773.              XF=MCOORD.XCOOR(ICELL)
  774.              YF=MCOORD.XCOOR(ICELL+1)
  775.              ZF=MCOORD.XCOOR(ICELL+2)
  776.  
  777.  
  778.  
  779. C ON CALCULE P1 VOIR RAPPORT p 17
  780.              IF (N1.NE.NGCF) THEN
  781.              ICOUR = ICOUR + 1
  782.              VECXG(ICOUR,JA) = (XF - XG)
  783.              VECYG(ICOUR,JA) = (YF - YG)
  784.              VECZG(ICOUR,JA) = (ZF - ZG)
  785.              NLOCFG(ICOUR,JA) = N1
  786.              XFACG(ICOUR,JA) = XF
  787.              YFACG(ICOUR,JA) = YF
  788.              ZFACG(ICOUR,JA) = ZF
  789.  
  790.              DIST2 = -1.e+15
  791.              DO I1 =1,NBNO2
  792.              NSOM1 = MELEP2.NUM(I1,NL1AUX)
  793.              ICELL=(4*(NSOM1 -1))+1
  794.              XCOUR=MCOORD.XCOOR(ICELL)
  795.              YCOUR=MCOORD.XCOOR(ICELL+1)
  796.              ZCOUR=MCOORD.XCOOR(ICELL+2)
  797.              DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2)
  798.              DIST1 = SQRT( DIST1)
  799.              IF ((DIST1.GT.DIST2)) THEN
  800.                 DIST2 = DIST1
  801.                 ICOURAN = I1
  802.              ENDIF
  803.              ENDDO
  804.              IF (IA.EQ.1) ICOURAN=3
  805.              IF (IA.EQ.2) ICOURAN=4
  806.              IF (IA.EQ.3) ICOURAN=1
  807.              IF (IA.EQ.4) ICOURAN=2
  808.              IF (NBNO2.EQ.3) THEN
  809.              ICOURAN = 0
  810.              ENDIF
  811.  
  812.  
  813.              DO I1 =1,NBNO2
  814.              NSOM1 = MELEP2.NUM(I1,NL1AUX)
  815.              ICELL=(4*(NSOM1 -1))+1
  816.              XCOUR=MCOORD.XCOOR(ICELL)
  817.              YCOUR=MCOORD.XCOOR(ICELL+1)
  818.              ZCOUR=MCOORD.XCOOR(ICELL+2)
  819.              XCO = 0.5D0*(XCOUR + XA)
  820.              YCO = 0.5D0*(YCOUR + YA)
  821.              ZCO = 0.5D0*(ZCOUR + ZA)
  822.              DIST1 = ((XCO-XARG(2,JA))**2) +
  823.      &                ((YCO-YARG(2,JA))**2) +
  824.      &                ((ZCO-ZARG(2,JA))**2)
  825.              DIST1 = SQRT(DIST1)
  826.  
  827.              IF (DIST1.LT.1e-5) THEN
  828.              VAX = XARG(ICOUR,JA)
  829.              VAY = YARG(ICOUR,JA)
  830.              VAZ = ZARG(ICOUR,JA)
  831. C CHANGEMENT INDICE
  832.              XARG(ICOUR,JA) = XCO
  833.              YARG(ICOUR,JA) = YCO
  834.              ZARG(ICOUR,JA) = ZCO
  835.              XARG(2,JA) = VAX
  836.              YARG(2,JA) = VAY
  837.              ZARG(2,JA) = VAZ
  838.              ENDIF
  839.  
  840.  
  841.              DIST2 = ((XCO-XARG(3,JA))**2) +
  842.      &                 ((YCO-YARG(3,JA))**2) +
  843.      &                 ((ZCO-ZARG(3,JA))**2)
  844.              DIST2 = SQRT(DIST2)
  845.              IF (DIST2.LT.1e-5) THEN
  846.              VAX = XARG(ICOUR,JA)
  847.              VAY = YARG(ICOUR,JA)
  848.              VAZ = ZARG(ICOUR,JA)
  849. C CHANGEMENT INDICE
  850.              XARG(ICOUR,JA) = XCO
  851.              YARG(ICOUR,JA) = YCO
  852.              ZARG(ICOUR,JA) = ZCO
  853.              XARG(3,JA) = VAX
  854.              YARG(3,JA) = VAY
  855.              ZARG(3,JA) = VAZ
  856.              ENDIF
  857.  
  858.              INDFAC=1
  859. c ON VERIFIE QUE LE POINT TROUVE EST BIEN DIFFERENT DE P2 ET P3
  860.              IF ((I1.NE.ICOURAN).AND.(I1.NE.IA).AND.
  861.      &           (DIST1.GT.1e-5).AND.(DIST2.GT.1e-5)) THEN
  862.               XARG(INDFAC,JA) = XCO
  863.               YARG(INDFAC,JA) = YCO
  864.               ZARG(INDFAC,JA) = ZCO
  865. c        WRITE(6,*) 'JA = ',JA
  866. c        WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA
  867. c        WRITE(6,*) 'P1', 'X= ',XARG(1,JA),'Y= ',YARG(1,JA),'Z= ',
  868. c     &   ZARG(1,JA)
  869.              ENDIF
  870.              ENDDO
  871.              ENDIF
  872. C ON PERMUTE
  873. C ICI
  874.  
  875.              IF (N1.EQ.NGCF) THEN
  876.              VECXG(1,JA) = (XF - XG)
  877.              VECYG(1,JA) = (YF - YG)
  878.              VECZG(1,JA) = (ZF - ZG)
  879.              XFACG(1,JA) = XF
  880.              YFACG(1,JA) = YF
  881.              ZFACG(1,JA) = ZF
  882.              NLOCFG(1,JA) = N1
  883.              ENDIF
  884.              ENDIF
  885.             ENDDO
  886.          ENDDO
  887. c         IF (NLCF.EQ.14) THEN
  888. c             WRITE(6,*) 'JA= ',JA
  889. c             WRITE(6,*) 'ICOUR= ',ICOUR
  890. c         ENDIF
  891.          ENDDO
  892.  
  893.  
  894.  
  895. C ON REPERE LES VECTEURS PRINCIPAUX DE LA BASE
  896.  
  897.  
  898.  
  899.          MPOGRA.VPOCHA(NLCF,1) = 0.D0
  900.          DO JA = 1,NBNO
  901.  
  902. c CALCUL DU VOLUME : ON SOMME LE VOLUME DES 6 TETRAEDRES
  903.              ICELL=(4*(NGS(JA) -1))+1
  904.              XA = MCOORD.XCOOR(ICELL)
  905.              YA = MCOORD.XCOOR(ICELL+1)
  906.              ZA = MCOORD.XCOOR(ICELL+2)
  907.  
  908. c        WRITE(6,*) 'JA = ',JA
  909. c        WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA
  910. c        WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ',
  911. c     &   ZARG(2,JA)
  912. c        WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ',
  913. c     &   ZARG(3,JA)
  914. c        WRITE(6,*) 'D', 'X= ',XFACG(1,JA),'Y= ',YFACG(1,JA),'Z= ',
  915. c     &   ZFACG(1,JA)
  916. c        WRITE(6,*) 'B', 'X= ',XFACG(2,JA),'Y= ',YFACG(2,JA),'Z= ',
  917. c     &   ZFACG(2,JA)
  918. c        WRITE(6,*) 'C', 'X= ',XFACG(3,JA),'Y= ',YFACG(3,JA),'Z= ',
  919. c     &   ZFACG(3,JA)
  920. c        WRITE(6,*) 'P1', 'X= ',XARG(1,JA),'Y= ',YARG(1,JA),'Z= ',
  921. c     &   ZARG(1,JA)
  922. c        WRITE(6,*) 'A', 'X= ',XD,'Y= ',YD,'Z= ',ZD
  923.  
  924.              VAUX(1) = XA - XARG(1,JA)
  925.              VAUY(1) = YA - YARG(1,JA)
  926.              VAUZ(1) = ZA - ZARG(1,JA)
  927.  
  928.              VAUX(2) = XA -  XARG(2,JA)
  929.              VAUY(2) = YA -  YARG(2,JA)
  930.              VAUZ(2) = ZA -  ZARG(2,JA)
  931.  
  932.              VAUX(3) = XA -  XARG(3,JA)
  933.              VAUY(3) = YA -  YARG(3,JA)
  934.              VAUZ(3) = ZA -  ZARG(3,JA)
  935.  
  936.              PVECX = VAUY(2)*VAUZ(3) - VAUZ(2)*VAUY(3)
  937.              PVECY = VAUZ(2)*VAUX(3) - VAUX(2)*VAUZ(3)
  938.              PVECZ = VAUX(2)*VAUY(3) - VAUY(2)*VAUX(3)
  939.  
  940.              VOL =
  941.      &          1.D0/6.D0*ABS((VAUX(1)*PVECX) + (VAUY(1)*PVECY) +
  942.      &                    (VAUZ(1)*PVECZ))
  943.  
  944. c CALCUL DU PREMIER VOLUME
  945.                 VOLUG(JA) = VOL
  946.  
  947.  
  948.           DO KA = 1,ICOUR
  949. C PRODUIT MIXTES
  950. C        PRODUIT VECTORIEL
  951.  
  952.                 IF (KA.EQ.1) THEN
  953.  
  954.                 VAUX(2) = XA -  XARG(2,JA)
  955.                 VAUY(2) = YA -  YARG(2,JA)
  956.                 VAUZ(2) = ZA -  ZARG(2,JA)
  957.  
  958.                 VAUX(3) = XA -  XARG(3,JA)
  959.                 VAUY(3) = YA -  YARG(3,JA)
  960.                 VAUZ(3) = ZA -  ZARG(3,JA)
  961. c             WRITE(6,*) 'ZA= ',ZA,'ZARG(3)= ',ZARG(3,JA),
  962. c     &       'DIFF',ZA -  ZARG(3,JA),'VAUXZ3',VAUZ(3)
  963.  
  964.  
  965. c             WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA
  966. c             WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ',
  967. c
  968. c     &        ZARG(2,JA)
  969. c
  970. c             WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ',
  971. c     &        ZARG(3,JA)
  972. c             WRITE(6,*) 'D', 'X= ',XFACG(1,JA),'Y= ',YFACG(1,JA),'Z= ',
  973. c     &        ZFACG(1,JA)
  974. c             WRITE(6,*) 'JA = ',JA,'KA=',KA,'VAUX2',VAUX(2),
  975. c     &          'VAUY2',VAUY(2),'VAUZ2',VAUZ(2)
  976. c             WRITE(6,*) 'ZA= ',ZA,'ZARG(3)= ',ZARG(3,JA),
  977. c     &       'DIFF',ZA -  ZARG(3,JA),'VAUXZ3',VAUZ(3)
  978. c             WRITE(6,*) 'JA = ',JA,'KA=',KA,'VAUX3',VAUX(3),
  979. c     &       'VAUY3',VAUY(3),'VAUZ3',VAUZ(3)
  980.                PSCAGX = (VAUY(2)*VAUZ(3)) -
  981.      &         (VAUZ(2)*VAUY(3))
  982.                PSCAGY = (VAUZ(2)*VAUX(3)) -
  983.      &          (VAUX(2)*VAUZ(3))
  984.                PSCAGZ = (VAUX(2)*VAUY(3)) -
  985.      &          (VAUY(2)*VAUX(3))
  986.                PSCA = (VECXG(1,JA)* PSCAGX) + (VECYG(1,JA)* PSCAGY) +
  987.      &              (VECZG(1,JA)* PSCAGZ)
  988.                IF (PSCA.LT.0) THEN
  989.                PSCAGX =  - PSCAGX
  990.                PSCAGY =  - PSCAGY
  991.                PSCAGZ =  - PSCAGZ
  992.                ENDIF
  993.                SURFAGX(KA) = 0.5D0* PSCAGX
  994.                SURFAGY(KA) = 0.5D0* PSCAGY
  995.                SURFAGZ(KA) = 0.5D0* PSCAGZ
  996. c        WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1)
  997.  
  998.  
  999.                ENDIF
  1000.  
  1001.                IF (KA.EQ.2) THEN
  1002.                VAUX(2) = XA -  XARG(2,JA)
  1003.                VAUY(2) = YA -  YARG(2,JA)
  1004.                VAUZ(2) = ZA -  ZARG(2,JA)
  1005.  
  1006.                VAUX(3) = XA -  XARG(1,JA)
  1007.                VAUY(3) = YA -  YARG(1,JA)
  1008.                VAUZ(3) = ZA -  ZARG(1,JA)
  1009. c on est ici
  1010.  
  1011.                PSCAGX = (VAUY(2)*VAUZ(3)) -
  1012.      &         (VAUZ(2)*VAUY(3))
  1013.                 PSCAGY = (VAUZ(2)*VAUX(3)) -
  1014.      &          (VAUX(2)*VAUZ(3))
  1015.                 PSCAGZ = (VAUX(2)*VAUY(3)) -
  1016.      &          (VAUY(2)*VAUX(3))
  1017.  
  1018.                 PSCA = (VECXG(2,JA)* PSCAGX) + (VECYG(2,JA)* PSCAGY) +
  1019.      &              (VECZG(2,JA)* PSCAGZ)
  1020.                 IF (PSCA.LT.0) THEN
  1021.                 PSCAGX =  - PSCAGX
  1022.                 PSCAGY =  - PSCAGY
  1023.                 PSCAGZ =  - PSCAGZ
  1024.                 ENDIF
  1025.                 SURFAGX(KA) = 0.5D0* PSCAGX
  1026.                 SURFAGY(KA) = 0.5D0* PSCAGY
  1027.                 SURFAGZ(KA) = 0.5D0* PSCAGZ
  1028.  
  1029.                 ENDIF
  1030.  
  1031.  
  1032.                 IF (KA.EQ.3) THEN
  1033.                 VAUX(2) = XA -  XARG(3,JA)
  1034.                 VAUY(2) = YA -  YARG(3,JA)
  1035.                 VAUZ(2) = ZA -  ZARG(3,JA)
  1036.  
  1037.                 VAUX(3) = XA -  XARG(1,JA)
  1038.                 VAUY(3) = YA -  YARG(1,JA)
  1039.                 VAUZ(3) = ZA -  ZARG(1,JA)
  1040.  
  1041.                 PSCAGX = (VAUY(2)*VAUZ(3)) -
  1042.      &         (VAUZ(2)*VAUY(3))
  1043.                 PSCAGY = (VAUZ(2)*VAUX(3)) -
  1044.      &          (VAUX(2)*VAUZ(3))
  1045.                 PSCAGZ = (VAUX(2)*VAUY(3)) -
  1046.      &          (VAUY(2)*VAUX(3))
  1047.  
  1048.                 PSCA = (VECXG(3,JA)* PSCAGX) + (VECYG(3,JA)* PSCAGY) +
  1049.      &              (VECZG(3,JA)* PSCAGZ)
  1050.                 IF (PSCA.LT.0) THEN
  1051.                 PSCAGX =  - PSCAGX
  1052.                 PSCAGY =  - PSCAGY
  1053.                 PSCAGZ =  - PSCAGZ
  1054.                 ENDIF
  1055.                 SURFAGX(KA) = 0.5D0* PSCAGX
  1056.                 SURFAGY(KA) = 0.5D0* PSCAGY
  1057.                 SURFAGZ(KA) = 0.5D0* PSCAGZ
  1058.  
  1059.                 ENDIF
  1060. c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS1
  1061.            IF (ICHTE.EQ.0) THEN
  1062.            PX(KA,JA) = SURFAGX(KA)/(VOLUG(JA))
  1063.            PY(KA,JA) = SURFAGY(KA)/(VOLUG(JA))
  1064.            PZ(KA,JA) = SURFAGZ(KA)/(VOLUG(JA))
  1065.  
  1066.            ELSE
  1067.            IF (MPOTEN.VPOCHA(/2) .EQ.6) THEN
  1068. C TENSEUR ANISOTROPE
  1069.            K11G = MPOTEN.VPOCHA(NLCG,1)
  1070.            K22G = MPOTEN.VPOCHA(NLCG,2)
  1071.            K33G = MPOTEN.VPOCHA(NLCG,3)
  1072.            K21G = MPOTEN.VPOCHA(NLCG,4)
  1073.            K31G = MPOTEN.VPOCHA(NLCG,5)
  1074.            K32G = MPOTEN.VPOCHA(NLCG,6)
  1075.            ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN
  1076. C TENSEUR DIAGONAL
  1077.            K11G = MPOTEN.VPOCHA(NLCG,1)
  1078.            K22G = K11G
  1079.            K33G = K11G
  1080.            K21G = 0.0D0
  1081.            K31G = 0.0D0
  1082.            K32G = 0.0D0
  1083.            ELSE
  1084.            WRITE(6,*) 'TENSEUR NON PREVU'
  1085.            STOP
  1086.            ENDIF
  1087.  
  1088.            PSCAGX = (K11G*SURFAGX(KA)) + (K21G*SURFAGY(KA)) +
  1089.      &     (K31G*SURFAGZ(KA))
  1090.            PSCAGY = (K21G*SURFAGX(KA)) + (K22G*SURFAGY(KA)) +
  1091.      &     (K32G*SURFAGZ(KA))
  1092.            PSCAGZ = (K31G*SURFAGX(KA)) + (K32G*SURFAGY(KA)) +
  1093.      &     (K33G*SURFAGZ(KA))
  1094.            PX(KA,JA) = PSCAGX/(VOLUG(JA))
  1095.            PY(KA,JA) = PSCAGY/(VOLUG(JA))
  1096.            PZ(KA,JA) = PSCAGZ/(VOLUG(JA))
  1097.            ENDIF
  1098.            ENDDO
  1099. c         WRITE(6,*)'NLCF= ',NLCF
  1100. c         WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z
  1101. c         WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1)
  1102. c         WRITE(6,*)'SURFAG = ',SURFAGX(2),SURFAGY(2),SURFAGZ(2)
  1103. c         WRITE(6,*)'SURFAG = ',SURFAGX(3),SURFAGY(3),SURFAGZ(3)
  1104.          ENDDO
  1105.  
  1106.           XPRO = 1.D0/NBNO
  1107.           DO JA = 1,NBNO
  1108.  
  1109.                MARQ = 0
  1110.                DO I5 = 1,INDLI.ID(NLS(JA))
  1111.                INDAUX = IND2.NUME(I5,NLS(JA))
  1112.                IF (INDAUX.EQ.NLOCFG(2,JA)) THEN
  1113.                IAFF = I5
  1114.                IG2 = IAFF
  1115.                GOTO 62
  1116.                ENDIF
  1117.                ENDDO
  1118.  62            CONTINUE
  1119.  
  1120.                TRG2 =  SCMB.MAT(IAFF,NLS(JA))
  1121. c               WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG2
  1122.  
  1123.                DO I5 = 1,INDLI.ID(NLS(JA))
  1124.                INDAUX = IND2.NUME(I5,NLS(JA))
  1125.                IF (INDAUX.EQ.NLOCFG(3,JA)) THEN
  1126.                IAFF = I5
  1127.                IG3 = IAFF
  1128.                GOTO 629
  1129.                ENDIF
  1130.                ENDDO
  1131.  629            CONTINUE
  1132.                TRG3 =  SCMB.MAT(IAFF,NLS(JA))
  1133. c               WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG3
  1134.  
  1135.                MARQ = 0
  1136.                DO I5 = 1,INDLI.ID(NLS(JA))
  1137.                INDAUX = IND2.NUME(I5,NLS(JA))
  1138.                IF (INDAUX.EQ.NGCF) THEN
  1139.                IAFF = I5
  1140.                IG = IAFF
  1141.                GOTO 63
  1142.                ENDIF
  1143.                ENDDO
  1144.  63              CONTINUE
  1145.                TRG =  SCMB.MAT(IAFF,NLS(JA))
  1146.                TRGAUX(JA) =  TRG
  1147.                IGNS(JA) = IAFF
  1148.  
  1149. c               WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG
  1150.  
  1151.             VAL = ALPHA*MPOCHP.VPOCHA(NLCG,1)
  1152.             VALD =  MPOCHP.VPOCHA(NLCD,1)
  1153. c ICI
  1154.  
  1155.             AUX =                     (XPRO*(
  1156.      &                               (PX(1,JA) * (-VAL + TRG))
  1157.      &                             + (PX(2,JA) * (-VAL + TRG2))
  1158.      &                             + (PX(3,JA) * (-VAL + TRG3))))
  1159.             AUY =                             (XPRO*(
  1160.      &                               (PY(1,JA) * (-VAL + TRG))
  1161.      &                             + (PY(2,JA) * (-VAL + TRG2))
  1162.      &                             + (PY(3,JA) * (-VAL + TRG3))))
  1163.             AUZ =                             (XPRO*(
  1164.      &                               (PZ(1,JA) * (-VAL + TRG))
  1165.      &                             + (PZ(2,JA) * (-VAL + TRG2))
  1166.      &                             + (PZ(3,JA) * (-VAL + TRG3))))
  1167.             MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) +
  1168.      &                               (AUX*SCN1X) + (AUY*SCN1Y) +
  1169.      &                               (AUZ*SCN1Z)
  1170.  
  1171. c             IF (NLCF.EQ.791) THEN
  1172. c            WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1173. c            WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  1174. c            WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3)
  1175. c            WRITE(6,*) 'PX= ',PX(1,JA),PX(2,JA),PX(3,JA)
  1176. c            WRITE(6,*) 'PY= ',PY(1,JA),PY(2,JA),PY(3,JA)
  1177. c            WRITE(6,*) 'PZ= ',PZ(1,JA),PZ(2,JA),PZ(3,JA)
  1178. c            WRITE(6,*) 'TR ',TRG,TRG2,TRG3,'VAL',VAL
  1179. c            WRITE(6,*) 'NLS=  ',NLS(JA),
  1180. c     &      'IG= ',IG,'IG2= ',IG2,'IG3= ',IG3
  1181. c             WRITE(6,*) 'NGCF= ',NGCF
  1182. c             ENDIF
  1183.  
  1184.  
  1185.           ITROUVE = 0
  1186.           INDIC = IPO3.POINT33(NLS(JA))
  1187.           SEGACT INDIC *MOD
  1188.           MATR1 = IPO2.POINT(NLS(JA))
  1189.           SEGACT MATR1 *MOD
  1190. c          NLS1 = NLS(JA)
  1191. c          DO IAUX = 1,INDLI.ID(NLS1)
  1192. c          DO IAUX2 = 1,TAB.ID(NLS1)
  1193. c         WRITE(6,*) 'NLS1= ',NLS1,'IAUX= ',IAUX ,'IAUX2= ',
  1194. c     &                IAUX2,'VAUX',MATR1.MAT2(IAUX,IAUX2)
  1195. c     &                 ,'IND3= ',INDIC.NU(IAUX,IAUX2)
  1196. c          ENDDO
  1197. c          ENDDO
  1198.  
  1199.           DO ICOUR = 1,TAB.ID(NLS(JA))
  1200.              IA = ICOUR
  1201.                 J1 = INDIC.NU(IG,IA)
  1202.                 DO IAUX2 = 2,NCON
  1203.                 J2 = MELEME.NUM(IAUX2,NLCF)
  1204.                 IF (J1.EQ.J2) THEN
  1205.                 IAUX = IAUX2
  1206.                 ITROUVE = 1
  1207.                 GOTO 5119
  1208.                 ENDIF
  1209.               ENDDO
  1210. C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR
  1211.               NCON = NCON + 1
  1212.               IAUX = NCON
  1213.  5119         CONTINUE
  1214.  
  1215.  
  1216.                   CX = MATR1.MAT2(IG,IA)
  1217.                   CY = MATR1.MAT2(IG,IA)
  1218.                   CZ = MATR1.MAT2(IG,IA)
  1219.                   IF (J1.EQ.NGCG) THEN
  1220.                   CX =  CX - ALPHA
  1221.                   CY =  CY - ALPHA
  1222.                   CZ =  CZ - ALPHA
  1223.                   INDGA = IAUX
  1224.                   ENDIF
  1225.                   IF (J1.EQ.NGCD) THEN
  1226.                   INDDR = IAUX
  1227.                   ENDIF
  1228. c                MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1229. c     &            (XPRO*PX(1,JA)*CX)
  1230. c                MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) -
  1231. c     &            (XPRO*PY(1,JA)*CY)
  1232. c                MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) -
  1233. c     &            (XPRO*PZ(1,JA)*CZ)
  1234.                  AUX = (XPRO*PX(1,JA)*CX*SCN1X) +
  1235.      &                 (XPRO*PY(1,JA)*CY*SCN1Y) +
  1236.      &                 (XPRO*PZ(1,JA)*CZ*SCN1Z)
  1237.                 MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) +
  1238.      &          AUX
  1239.  
  1240.                  INDAUX = INDIC.NU(IG,IA)
  1241.                  MELEME.NUM(IAUX,NLCF)  = INDAUX
  1242.            ENDDO
  1243.  
  1244.  
  1245.           ITROUVE = 0
  1246.           DO ICOUR = 1,TAB.ID(NLS(JA))
  1247.              IA = ICOUR
  1248.                 J1 = INDIC.NU(IG2,IA)
  1249.                 DO IAUX2 = 2,NCON
  1250.                 J2 = MELEME.NUM(IAUX2,NLCF)
  1251.                 IF (J1.EQ.J2) THEN
  1252.                 IAUX = IAUX2
  1253.                 ITROUVE = 1
  1254.                 GOTO 511
  1255.                 ENDIF
  1256.               ENDDO
  1257. C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR
  1258.               NCON = NCON + 1
  1259.               IAUX = NCON
  1260.  511          CONTINUE
  1261.  
  1262.                   CX = MATR1.MAT2(IG2,IA)
  1263.                   CY = MATR1.MAT2(IG2,IA)
  1264.                   CZ = MATR1.MAT2(IG2,IA)
  1265.                   IF (J1.EQ.NGCG) THEN
  1266.                   CX = CX - ALPHA
  1267.                   CY = CY - ALPHA
  1268.                   CZ = CZ - ALPHA
  1269.                   ENDIF
  1270. c                MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1271. c     &            (XPRO*PX(2,JA)*CX)
  1272. c                MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) -
  1273. c     &            (XPRO*PY(2,JA)*CY)
  1274. c                MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) -
  1275. c     &            (XPRO*PZ(2,JA)*CZ)
  1276.                  AUX = (XPRO*PX(2,JA)*CX*SCN1X) +
  1277.      &                 (XPRO*PY(2,JA)*CY*SCN1Y) +
  1278.      &                 (XPRO*PZ(2,JA)*CZ*SCN1Z)
  1279.                 MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) +
  1280.      &          AUX
  1281.                  INDAUX = INDIC.NU(IG2,IA)
  1282.                  MELEME.NUM(IAUX,NLCF)  = INDAUX
  1283.            ENDDO
  1284.  
  1285.           ITROUVE = 0
  1286.           DO ICOUR = 1,TAB.ID(NLS(JA))
  1287.              IA = ICOUR
  1288.                 J1 = INDIC.NU(IG3,IA)
  1289.                 DO IAUX2 = 2,NCON
  1290.                 J2 = MELEME.NUM(IAUX2,NLCF)
  1291.                 IF (J1.EQ.J2) THEN
  1292.                 IAUX = IAUX2
  1293.                 ITROUVE = 1
  1294.                 GOTO 5118
  1295.                 ENDIF
  1296.               ENDDO
  1297. C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR
  1298.               NCON = NCON + 1
  1299.               IAUX = NCON
  1300.  5118          CONTINUE
  1301.  
  1302.                   CX = MATR1.MAT2(IG3,IA)
  1303.                   CY = MATR1.MAT2(IG3,IA)
  1304.                   CZ = MATR1.MAT2(IG3,IA)
  1305.                   IF (J1.EQ.NGCG) THEN
  1306.                   CX = CX - ALPHA
  1307.                   CY = CY - ALPHA
  1308.                   CZ = CZ - ALPHA
  1309.                   ENDIF
  1310. c                MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1311. c     &            (XPRO*PX(3,JA)*CX)
  1312. c                MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) -
  1313. c     &            (XPRO*PY(3,JA)*CY)
  1314. c                MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) -
  1315. c     &            (XPRO*PZ(3,JA)*CZ)
  1316.                  AUX = (XPRO*PX(3,JA)*CX*SCN1X) +
  1317.      &                 (XPRO*PY(3,JA)*CY*SCN1Y) +
  1318.      &                 (XPRO*PZ(3,JA)*CZ*SCN1Z)
  1319.                 MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) +
  1320.      &          AUX
  1321.                  INDAUX = INDIC.NU(IG3,IA)
  1322.                  MELEME.NUM(IAUX,NLCF)  = INDAUX
  1323.            ENDDO
  1324.  
  1325. c           WRITE(6,*) 'NLCF= ',NLCF,'XPRO= ',XPRO,
  1326. c     &                'FLUX=',MPOGRA.VPOCHA(NLCF,1)
  1327. c           WRITE(6,*) 'NLCF= ',NLCF,'TRG=',TRG,'TRG2=',TRG2,
  1328. c     &                 'TRG3=',TRG3
  1329.  
  1330. c FIN DE LA BOUCLE SUR LES NOEUDS
  1331.                  SEGDES MATR1
  1332.                  SEGDES INDIC
  1333.           ENDDO
  1334.  
  1335. c             MPOGRA.VPOCHA(NLCF,1) = 0.0D0
  1336. c             ISUP = NCON
  1337. c            DO J= ISUP+1,NBNN
  1338. c             DO J= 2,NBNN
  1339. c             MELVA1.VELCHE(J,NLCF) = 0.0D0
  1340. c             MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF)
  1341. c             ENDDO
  1342.              ISUP = NCON
  1343.              DO J= ISUP+1,NBNN
  1344.              MELVA1.VELCHE(J,NLCF) = 0.0D0
  1345.              MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF)
  1346.              ENDDO
  1347.  
  1348. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1349. C  ON RAJOUTE LE CONVECTIF
  1350.  
  1351. C CALCUL PLUS PRECIS
  1352.  
  1353.  
  1354. c             IF (NLCD.NE.NLCG) THEN
  1355. c             MELVA1.VELCHE(INDDR,NLCF) = - MELVA1.VELCHE(INDGA,NLCF)
  1356. c             ELSE
  1357. c             DO J= 1,ISUP
  1358. c             ICENT =  MELEME.NUM(J,NLCF)
  1359. c             ICEN = MLECEN.LECT(ICENT)
  1360. c             DIFF = MELVA1.VELCHE(J,NLCF) + MELVA1.VELCHE(INDGA,NLCF)
  1361. c             DIFF = ABS(DIFF)
  1362. c             XX = ABS(MELVA1.VELCHE(INDGA,NLCF))
  1363. c             IF ((ICEN.EQ.0).AND.(DIFF.LT.(1e-5*XX))) THEN
  1364. c              MELVA1.VELCHE(J,NLCF) = - MELVA1.VELCHE(INDGA,NLCF)
  1365. c             ENDIF
  1366. c             ENDDO
  1367. c             ENDIF
  1368.  
  1369.  
  1370.              IF (ICHCO.GT.0) THEN
  1371. C BOUCLE POUR CALCUER INDGA,INDDR
  1372.              INDFR = 0
  1373.              DO J= 1,ISUP
  1374.              IF (MELEME.NUM(J,NLCF).EQ.NGCG) INDGA = J
  1375.              IF (MELEME.NUM(J,NLCF).EQ.NGCD) INDDR = J
  1376.              IF (MELEME.NUM(J,NLCF).EQ.NGCF) INDFR = J
  1377.              ENDDO
  1378.  
  1379.  
  1380.  
  1381. c             WRITE(6,*) 'NGCF= ',NGCF
  1382.              UN = MPOVCO.VPOCHA(NLCF,1)
  1383. c             WRITE(6,*) 'UN= ',UN
  1384. C OPTION CENTRE
  1385.              IF (IOP.EQ.2) THEN
  1386.              IF (NLCD.NE.NLCG) THEN
  1387.              VAL = 0.5D0*(MPOCHP.VPOCHA(NLCG,1) +
  1388.      &                        MPOCHP.VPOCHA(NLCD,1))*UN
  1389.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1390.              ELSE
  1391. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1392.  
  1393.               XPRO = 1.D0/NBNO
  1394.               TRACE = 0.0D0
  1395.               DO JA = 1,NBNO
  1396.               TRACE =TRACE + (XPRO*TRGAUX(JA))
  1397.               ENDDO
  1398. c             WRITE(6,*) 'NLCF= ',NLCF,'TRACE= ',TRACE
  1399.              VAL = TRACE*UN
  1400.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1401.              ENDIF
  1402.  
  1403. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1404.             IF (NLCD.NE.NLCG) THEN
  1405.             MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1406.      &                                  (0.5D0*UN)
  1407.             MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1408.      &                                  (0.5D0*UN)
  1409. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDENCES DES TRACES
  1410. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1411.  
  1412.  
  1413.             ELSE
  1414.  
  1415.             NLFCL = MLENCL.LECT(NGCF)
  1416.  
  1417. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1418.             IF (NLFCL.NE.0) THEN
  1419.             MELVA1.VELCHE(NCON+1,NLCF) =   - UN
  1420.             MELEME.NUM(NCON+1,NLCF) = NGCF
  1421.             ENDIF
  1422.  
  1423.             IF (NLFCL.EQ.0) THEN
  1424.             XPRO = 1.D0/NBNO
  1425.             DO JA = 1,NBNO
  1426.             INDIC = IPO3.POINT33(NLS(JA))
  1427.             SEGACT INDIC *MOD
  1428.             MATR1 = IPO2.POINT(NLS(JA))
  1429.             SEGACT MATR1 *MOD
  1430.  
  1431.             DO ICOUR = 1,TAB.ID(NLS(JA))
  1432.              IA = ICOUR
  1433.                 J1 = INDIC.NU(IGNS(JA),IA)
  1434.                 DO IAUX2 = 2,NCON
  1435.                 J2 = MELEME.NUM(IAUX2,NLCF)
  1436.                 IF (J1.EQ.J2) THEN
  1437.                 IAUX = IAUX2
  1438.                 GOTO 5169
  1439.                 ENDIF
  1440.               ENDDO
  1441.  5169         CONTINUE
  1442.  
  1443.  
  1444.                   CX = MATR1.MAT2(IGNS(JA),IA)
  1445.                 MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1446.      &          (UN*CX*XPRO)
  1447.             ENDDO
  1448.            SEGDES INDIC *MOD
  1449.            SEGDES MATR1 *MOD
  1450.            ENDDO
  1451.            ENDIF
  1452.            ENDIF
  1453.  
  1454. C OPTION UPWIND
  1455.             ELSEIF (IOP.EQ.1) THEN
  1456.              IF (NLCD.NE.NLCG) THEN
  1457.               IF (UN.GT.0.0D0) THEN
  1458.              VAL = (MPOCHP.VPOCHA(NLCG,1)*UN)
  1459.              ELSE
  1460.              VAL = (MPOCHP.VPOCHA(NLCD,1)*UN)
  1461.              ENDIF
  1462. c            WRITE(6,*) 'VAL= ',VAL
  1463.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1464.              ELSE
  1465. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1466. c ANCIENNE VERRUE
  1467.                IF (UN.GT.0.0D0) THEN
  1468.                VAL = (MPOCHP.VPOCHA(NLCG,1)*UN)
  1469.                ELSE
  1470.                XPRO = 1.D0/NBNO
  1471.                TRACE = 0.0D0
  1472.                DO JA = 1,NBNO
  1473.                TRACE =TRACE + (XPRO*TRGAUX(JA))
  1474.                ENDDO
  1475.  
  1476. c            WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF
  1477. c            WRITE(6,*) 'UN= ',UN,'TRACE=',TRACE
  1478.  
  1479.  
  1480.                VAL = TRACE*UN
  1481.                ENDIF
  1482.  
  1483.  
  1484.                MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1485.              ENDIF
  1486.  
  1487. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1488.             IF (NLCD.NE.NLCG) THEN
  1489. c            WRITE(6,*) 'UN= ',UN
  1490.                IF (UN.GT.0.0D0) THEN
  1491.                MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1492.      &                                     (UN)
  1493.                ELSE
  1494.                MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1495.      &                                     (UN)
  1496.                ENDIF
  1497. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDENCES DES TRACES
  1498. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1499.  
  1500.             ELSE
  1501. c ANCIENNE VERRUE
  1502.             IF (UN.GT.0.0D0) THEN
  1503.                MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1504.      &                                     (UN)
  1505.             ELSE
  1506.  
  1507.             NLFCL = MLENCL.LECT(NGCF)
  1508.  
  1509. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1510. C IL Y A PROBABLEMENT REDONDANCE
  1511.             IF (NLFCL.NE.0) THEN
  1512.             MELVA1.VELCHE(NCON+1,NLCF) =   - UN
  1513.             MELEME.NUM(NCON+1,NLCF) = NGCF
  1514.             ENDIF
  1515. * ENDIF
  1516.  
  1517.             IF (NLFCL.EQ.0) THEN
  1518.             XPRO = 1.D0/NBNO
  1519.             DO JA = 1,NBNO
  1520.             INDIC = IPO3.POINT33(NLS(JA))
  1521.             SEGACT INDIC *MOD
  1522.             MATR1 = IPO2.POINT(NLS(JA))
  1523.             SEGACT MATR1 *MOD
  1524.  
  1525.             DO ICOUR = 1,TAB.ID(NLS(JA))
  1526.              IA = ICOUR
  1527.                 J1 = INDIC.NU(IGNS(JA),IA)
  1528.                 DO IAUX2 = 2,NCON
  1529.                 J2 = MELEME.NUM(IAUX2,NLCF)
  1530.                 IF (J1.EQ.J2) THEN
  1531.                 IAUX = IAUX2
  1532.                 GOTO 5129
  1533.                 ENDIF
  1534.               ENDDO
  1535.  5129         CONTINUE
  1536.  
  1537.  
  1538.                   CX = MATR1.MAT2(IGNS(JA),IA)
  1539.                 MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1540.      &          (UN*CX*XPRO)
  1541.             ENDDO
  1542.  
  1543.            SEGDES INDIC *MOD
  1544.            SEGDES MATR1 *MOD
  1545.            ENDDO
  1546.            ENDIF
  1547.            ENDIF
  1548.  
  1549.  
  1550.            ENDIF
  1551.  
  1552.  
  1553. C OPTION UPWICENT
  1554.             ELSEIF (IOP.EQ.3) THEN
  1555.              IF (NLCD.NE.NLCG) THEN
  1556. c CALCUL DE THETA
  1557. c DANS MELVA1 :  INDDR EST LA NUM de NLCD
  1558. C COEFD = MELVA1(INDDR,NLCF)
  1559.              COEFDD =   MELVA1.VELCHE(INDDR,NLCF)
  1560.  
  1561.  
  1562.              THETA = 0.5D0
  1563.              EXPR1 =  - (THETA*UN) - COEFDD
  1564.              EXPR2 =  - ((1.D0 - THETA)*UN) + COEFDD
  1565. c             WRITE(6,*) 'EXPR1',EXPR1
  1566. c             WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1567. c     &       'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1568. c             WRITE(6,*) 'EXPR2',EXPR2
  1569. c             WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1570. c     &       'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1571.              IF (EXPR1.GT.0.0D0) THEN
  1572.                 IF (ABS(UN) .GT. 1e-20) THEN
  1573.                  THETA = - (0.5D0*COEFDD / UN)
  1574.                 ENDIF
  1575.              ENDIF
  1576.              IF (EXPR2.LT.0.0D0) THEN
  1577.                 IF (ABS(UN) .GT. 1e-20) THEN
  1578.                  THETA = 1.D0 - (0.5D0*COEFDD / UN)
  1579.                 ENDIF
  1580.              ENDIF
  1581.              THETA = MIN(1.D0,THETA)
  1582.              THETA = MAX(0.D0,THETA)
  1583.  
  1584.              EXPR1 = (THETA*UN) + COEFDD
  1585.              EXPR2 = ((1.D0 - THETA)*UN) - COEFDD
  1586. c             IF (EXPR1.LT.0.0D0) THEN
  1587. c             WRITE(6,*) 'EXPR1',EXPR1
  1588. c             WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1589. c     &       'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1590. c             ENDIF
  1591. c             IF (EXPR2.GT.0.0D0) THEN
  1592. c             WRITE(6,*) 'EXPR2',EXPR2
  1593. c             WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1594. c     &       'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1595. c             ENDIF
  1596. c             WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1597. c     &       'EXPR1= ',EXPR1,'EXPR2= ',EXPR2
  1598.  
  1599.  
  1600.              VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) +
  1601.      &             (MPOCHP.VPOCHA(NLCD,1)*(1.D0-THETA)*UN)
  1602.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1603.              ELSE
  1604. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1605.              IF (INDFR.NE.0) THEN
  1606.              COEFDD =   MELVA1.VELCHE(INDFR,NLCF)
  1607.              ELSE
  1608.              COEFDD = 0.0D0
  1609.              ENDIF
  1610. C C'EST LE THETA LE MIEUX ADPATE POUR LES CONDITIONS AUX LIMITES
  1611.              THETA = 0.0D0
  1612.              EXPR1 =  - (THETA*UN) - COEFDD
  1613.              EXPR2 =  - ((1.D0 - THETA)*UN) + COEFDD
  1614.  
  1615.              IF (EXPR1.GT.0.0D0) THEN
  1616.                 IF (ABS(UN) .GT. 1e-20) THEN
  1617.                  THETA = - (0.5D0*COEFDD / UN)
  1618.                 ENDIF
  1619.              ENDIF
  1620.              IF (EXPR2.LT.0.0D0) THEN
  1621.                 IF (ABS(UN) .GT. 1e-20) THEN
  1622.                  THETA = 1.D0 - (0.5D0*COEFDD / UN)
  1623.                 ENDIF
  1624.              ENDIF
  1625.              THETA = MIN(1.D0,THETA)
  1626.              THETA = MAX(0.D0,THETA)
  1627. C ANCIENNE VERRUE
  1628. c             THETA = 0.0D0
  1629.  
  1630.               XPRO = 1.D0/NBNO
  1631.               TRACE = 0.0D0
  1632.               DO JA = 1,NBNO
  1633.               TRACE =TRACE + (XPRO*TRGAUX(JA))
  1634.               ENDDO
  1635.               VAL = TRACE*UN
  1636.              VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) +
  1637.      &             (TRACE*(1.D0-THETA)*UN)
  1638.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1639.  
  1640. c            WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1641. c     &       'GR1= ',MPOGRA.VPOCHA(NLCF,1),'VAL = ',VAL,
  1642. c     &         'TRACE = ',TRACE,'UN= ',UN
  1643. c              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1644. c            WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1645. c     &       'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1646.              ENDIF
  1647.  
  1648. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1649.             IF (NLCD.NE.NLCG) THEN
  1650.               MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1651.      &                                    (THETA*UN)
  1652.               MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1653.      &                                    ((1.D0-THETA)*UN)
  1654. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDANCES DES TRACES
  1655. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1656.  
  1657.             ELSE
  1658.  
  1659.              MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1660.      &                                    (THETA*UN)
  1661.             NLFCL = MLENCL.LECT(NGCF)
  1662. C ON EST ICI : CORRIGER
  1663. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1664. c            IF (NLFCL.NE.0) THEN
  1665. c            MELVA1.VELCHE(NCON+1,NLCF) =   - UN
  1666. c            MELEME.NUM(NCON+1,NLCF) = NGCF
  1667. c            ENDIF
  1668.  
  1669. c            IF (NLFCL.EQ.0) THEN
  1670.             XPRO = 1.D0/NBNO
  1671.             DO JA = 1,NBNO
  1672.             INDIC = IPO3.POINT33(NLS(JA))
  1673.             SEGACT INDIC *MOD
  1674.             MATR1 = IPO2.POINT(NLS(JA))
  1675.             SEGACT MATR1 *MOD
  1676.  
  1677.             DO ICOUR = 1,TAB.ID(NLS(JA))
  1678.              IA = ICOUR
  1679.                 J1 = INDIC.NU(IGNS(JA),IA)
  1680.                 DO IAUX2 = 2,NCON
  1681.                 J2 = MELEME.NUM(IAUX2,NLCF)
  1682.                 IF (J1.EQ.J2) THEN
  1683.                 IAUX = IAUX2
  1684.                 GOTO 5159
  1685.                 ENDIF
  1686.               ENDDO
  1687.  5159         CONTINUE
  1688.  
  1689.  
  1690.                   CX = MATR1.MAT2(IGNS(JA),IA)
  1691.                 MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1692.      &          ((1.D0-THETA)*UN*CX*XPRO)
  1693.             ENDDO
  1694.  
  1695.            SEGDES INDIC *MOD
  1696.            SEGDES MATR1 *MOD
  1697.            ENDDO
  1698. c           ENDIF
  1699.            ENDIF
  1700.  
  1701.            ENDIF
  1702.            ENDIF
  1703.  
  1704. c            DO J= 1,NBNN
  1705. c             PSCA = (MPOGRA.VPOCHA(NLCF,1)*SCN1X) +
  1706. c     &              (MPOGRA.VPOCHA(NLCF,2)*SCN1Y) +
  1707. c     &              (MPOGRA.VPOCHA(NLCF,3)*SCN1Z)
  1708. c             MPOGRA.VPOCHA(NLCF,1) = PSCA*SCN1X
  1709. c             MPOGRA.VPOCHA(NLCF,2) = PSCA*SCN1Y
  1710. c             MPOGRA.VPOCHA(NLCF,3) = PSCA*SCN1Z
  1711. c             ENDDO
  1712. c            IF (NLCF.EQ.791) THEN
  1713. c            WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1714. c            ENDIF
  1715. c            WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  1716. c            WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3)
  1717.  
  1718.  
  1719. c             DO J= 1,NBNN
  1720. c             PSCA = (MELVA1.VELCHE(J,NLCF)*SCN1X) +
  1721. c     &              (MELVA2.VELCHE(J,NLCF)*SCN1Y) +
  1722. c     &              (MELVA3.VELCHE(J,NLCF)*SCN1Z)
  1723. c             MELVA1.VELCHE(J,NLCF) = PSCA*SCN1X
  1724. c             MELVA2.VELCHE(J,NLCF) = PSCA*SCN1Y
  1725. c             MELVA3.VELCHE(J,NLCF) = PSCA*SCN1Z
  1726. c             ENDDO
  1727. c             DO J= 1,NBNN
  1728. c            WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA1= ',
  1729. c     &     MELVA1.VELCHE(J,NLCF)
  1730. c            WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA2= ',
  1731. c     &     MELVA2.VELCHE(J,NLCF)
  1732. c            WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA3= ',
  1733. c     &     MELVA3.VELCHE(J,NLCF)
  1734. c              WRITE(6,*) 'MELEME=',MELEME.NUM(J,NLCF)
  1735. c             ENDDO
  1736. C            IF (1.EQ.0) THEN
  1737. C            WRITE(6,*) 'NGCF= ',NGCF
  1738. C            WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1739. C            WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  1740. C            WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3)
  1741. C            VALD = MPOCHP.VPOCHA(NLCD,1)
  1742. C            WRITE(6,*) 'NLCF= ',NLCF,'VALD= ',VALD
  1743. C            WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL
  1744. C            WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRG
  1745. C            WRITE(6,*) 'NLCF= ',NLCF,'TRG2= ',TRG2
  1746. C            WRITE(6,*) 'NLCF= ',NLCF,'TRG3= ',TRG3
  1747. C            WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRGAUX
  1748. C            WRite(6,*) 'AG1=',AG1
  1749. C            WRite(6,*) 'AG2=',AG2
  1750. C            WRite(6,*) 'AD1=',AD1
  1751. C            WRite(6,*) 'AD2=',AD2
  1752. C            ENDIF
  1753.             NAUX2 = MAX(NAUX2,NCON)
  1754.             NMOY = NMOY + NCON
  1755.  
  1756. c             WRITE(6,*) 'INDGA= ',INDGA
  1757. c             WRITE(6,*) 'INDDR= ',INDDR
  1758. c             DO J= 1,NBNN
  1759. c             WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA1= ',
  1760. c     &       MELVA1.VELCHE(J,NLCF)
  1761. c             ENDDO
  1762.  
  1763.  
  1764.          ENDDO
  1765.          NMOY = NMOY/(NFAC*1.D0)
  1766.  
  1767.          IF (1.EQ.0) THEN
  1768.          DO NLCF = 1, NFAC, 1
  1769.          MPOGRA.VPOCHA(NLCF,1) = 0.D0
  1770.          SCNX=MPONOR.VPOCHA(NLCF,1)
  1771.          SCNY=MPONOR.VPOCHA(NLCF,2)
  1772.          SCNZ=MPONOR.VPOCHA(NLCF,3)
  1773.          SCN1X = SCNX
  1774.          SCN1Y = SCNY
  1775.          SCN1Z = SCNZ
  1776.             NGCF=MELEFL.NUM(2,NLCF)
  1777.              DO IVOI=2,MELEME.NUM(/1)
  1778.              ICENT =  MELEME.NUM(IVOI,NLCF)
  1779.              ICEN = MLECEN.LECT(ICENT)
  1780.              VAL = 0.0D0
  1781.              IF (ICEN.NE.0) THEN
  1782. c             WRITE(6,*) 'INTERIEUR'
  1783.              VAL = MPOCHP.VPOCHA(ICEN,1)
  1784.              ELSE
  1785.              ICENL = MLENCL.LECT(ICENT)
  1786.              IF (ICENL.GT.0) THEN
  1787. c              WRITE(6,*) 'DIRICHLET'
  1788.              VAL = MPOVCL.VPOCHA(ICENL,1)
  1789.              ENDIF
  1790.              ENDIF
  1791.  
  1792.              COEF1 =  MELVA1.VELCHE(IVOI,NLCF)
  1793.              MPOGRA.VPOCHA(NLCF,1)= MPOGRA.VPOCHA(NLCF,1) +
  1794.      &       (COEF1 * VAL)
  1795.  
  1796. c            WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL
  1797. c            WRITE(6,*) 'IVOI= ',IVOI,'MELEME= ', MELEME.NUM(IVOI,NLCF),
  1798. c     &                 'COEF1 = ',COEF1,'COEF2= ',COEF2,'COEF3= ',COEF3
  1799.              ENDDO
  1800. c             DO J= 1,NBNN
  1801. c             PSCA = (MPOGRA.VPOCHA(NLCF,1)*SCN1X) +
  1802. c     &              (MPOGRA.VPOCHA(NLCF,2)*SCN1Y) +
  1803. c     &              (MPOGRA.VPOCHA(NLCF,3)*SCN1Z)
  1804. c             MPOGRA.VPOCHA(NLCF,1) = PSCA*SCN1X
  1805. c             MPOGRA.VPOCHA(NLCF,2) = PSCA*SCN1Y
  1806. c             MPOGRA.VPOCHA(NLCF,3) = PSCA*SCN1Z
  1807. c             ENDDO
  1808. c            NGCF=MELEFL.NUM(2,NLCF)
  1809. c            WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF
  1810. c            WRITE(6,*) 'MPOGRA1= ', MPOGRA.VPOCHA(NLCF,1)
  1811. c            WRITE(6,*) 'MPOGRA2= ', MPOGRA.VPOCHA(NLCF,2)
  1812. c            WRITE(6,*) 'MPOGRA3= ', MPOGRA.VPOCHA(NLCF,3)
  1813.          ENDDO
  1814.              ENDIF
  1815.  
  1816.       IF (NBSO.EQ.2) THEN
  1817.       SEGDES  IPT1
  1818.       SEGDES IPT2
  1819.       ELSEIF (NBSO.EQ.3) THEN
  1820.       SEGDES IPT1
  1821.       SEGDES IPT2
  1822.       SEGDES IPT3
  1823.       ELSEIF (NBSO.EQ.4) THEN
  1824.       SEGDES IPT1
  1825.       SEGDES IPT2
  1826.       SEGDES IPT3
  1827.       SEGDES IPT4
  1828.       ENDIF
  1829.       IF (NBSOF.EQ.2) THEN
  1830.       SEGDES IPT5
  1831.       SEGDES IPT6
  1832.       ENDIF
  1833.  
  1834. C ON REJUSTE LE CHAMELEM
  1835.  
  1836.  
  1837. c         WRITE(6,*) 'NAUX2= ',NAUX2
  1838. c         WRITE(6,*) 'NESSAI= ',NESSAI
  1839. c         WRITE(6,*) 'NMOY2= ',NMOY
  1840.          IF (NAUX2.GT.NESSAI) THEN
  1841.          WRITE(6,*) 'NAUX2 = ',NAUX2,'NESSAI = ',NESSAI
  1842.          WRITE(6,*) 'NESSAI TROP PETIT'
  1843.          STOP
  1844.          ENDIF
  1845.          N1PTEL=NAUX2
  1846.          N1EL=NBELEM
  1847.          N2PTEL=0
  1848.          N2EL=0
  1849.          SEGADJ MELVA1
  1850.  
  1851.          NBNN = NAUX2
  1852.          SEGADJ MELEME
  1853.  
  1854.          K7 = NFAC
  1855.          K8 = NAUX2
  1856.          SEGINI ITAB
  1857.  
  1858. c ON SUPPRIME LES ZEROS INTERIEURS
  1859.          IND = 2
  1860.          DO NLCF = 1,NFAC
  1861.             IND = 2
  1862.             NFIN = NAUX2
  1863. C ON CALCULE D4ABORD LE MAXIMUM DE LA LIGNE
  1864.             AUXMA = 0
  1865.             DO J=2,NFIN
  1866.             ICEN = MLECEN.LECT(MELEME.NUM(J,NLCF))
  1867.  
  1868.             IF (ICEN.NE.0) THEN
  1869.             AUXMA = MAX(ABS(MELVA1.VELCHE(J,NLCF)),AUXMA)
  1870.             ENDIF
  1871.             ENDDO
  1872.             ITAB.XMAX(NLCF) = AUXMA
  1873.  
  1874.             DO  J=IND, NFIN
  1875.             ICEN = MLECEN.LECT(MELEME.NUM(J,NLCF))
  1876.             IF (ABS(MELVA1.VELCHE(J,NLCF)).Le.(1e-14*AUXMA)
  1877.      &          .AND.(ICEN.NE.0) ) THEN
  1878.  
  1879.  
  1880.                  DO K=1,NFIN-J
  1881.                  AUX = MELVA1.VELCHE(J+K,NLCF)
  1882.                  ICEN = MLECEN.LECT(MELEME.NUM(J+K,NLCF))
  1883. C ON DECALE DE K CRAN
  1884.                  IF (ABS(AUX).gt.(1e-14*AUXMA).OR.(ICEN.EQ.0)) THEN
  1885.                   DO I=J,NFIN - K
  1886.                    MELVA1.VELCHE(I,NLCF) = MELVA1.VELCHE(I+K,NLCF)
  1887.                    MELEME.NUM(I,NLCF) = MELEME.NUM(I+K,NLCF)
  1888.                   ENDDO
  1889. C MISE A ZERO DES TERMES DU BOUT
  1890.                   DO I=NFIN-K+1,NFIN
  1891.                    MELVA1.VELCHE(I,NLCF) = 0.0
  1892.                   ENDDO
  1893.                  GOTO 2000
  1894.                  ENDIF
  1895.                  ENDDO
  1896. 2000        CONTINUE
  1897.             ENDIF
  1898.             ENDDO
  1899.          ENDDO
  1900.  
  1901. c         IF (1.EQ.0) THEN
  1902. c ON RECONSTUIT UN CHAMELEM EN SUPPRIMANT LES 0
  1903.  
  1904.  
  1905.  
  1906.  
  1907.  
  1908. c TABLEAU CALCULANT LE NOMBRE DE VOISIN NON NUL POUR CHAQUE FACE
  1909.          NMOY = 0
  1910.          INF = NAUX2
  1911.          DO NLCF = 1,NFAC
  1912.            IREC = 3
  1913.            DO J=NAUX2,1,-1
  1914.            IF (ABS(MELVA1.VELCHE(J,NLCF)).gt.
  1915.      &        (1e-14*ITAB.XMAX(NLCF))) THEN
  1916.            IREC = J
  1917.            GOTO 1111
  1918.            ENDIF
  1919.            ENDDO
  1920. 1111     CONTINUE
  1921.            ITAB.TABL(NLCF) = IREC
  1922.            NMOY = NMOY + IREC
  1923.         ENDDO
  1924.          NMOY = NMOY/(NFAC*1.D0)
  1925. c         WRITE(6,*) 'NEWMOY2= ',NMOY
  1926.  
  1927.  
  1928. C   TAB1(U) TABLEAU QUI CONTIENT LE NOMBRE DE FACE AYANT U VOISIN
  1929.           NMAX = 0
  1930.           DO ICOUR = 1,NAUX2
  1931.           ITAB.TABL1(ICOUR) = 0
  1932.           ENDDO
  1933.  
  1934.           DO NLCF = 1,NFAC
  1935.           ICOUR =  ITAB.TABL(NLCF)
  1936.           ITAB.TABL1(ICOUR)=ITAB.TABL1(ICOUR) + 1
  1937.           ENDDO
  1938.  
  1939. C ON COMPTE LE NOMVRE DE SOUS DOMAINE
  1940.           NTSOUS = 0
  1941.           DO ICOUR = 1,NAUX2
  1942.           IF (ITAB.TABL1(ICOUR) .NE.0) NTSOUS = NTSOUS +1
  1943.           ENDDO
  1944. C IPOS INDICE DE LA PREMIERE FACE AYANT I VOISIN
  1945. C ICOUR INDICE COURANT INITIALISE A IPOS
  1946.  
  1947.  
  1948.           ITAB.IPOS(1) = 1
  1949.           DO I = 2,NAUX2
  1950.           ITAB.IPOS(I) = ITAB.IPOS(I-1) + ITAB.TABL1(I-1)
  1951.           ITAB.ICOURANT(I) = ITAB.IPOS(I)
  1952.           ENDDO
  1953.  
  1954.  
  1955. c TABL2 TABLEAU QUI RANGE DANS L4ODRES DES SOUS DOMAINES LES FACES NLCF
  1956.  
  1957.            DO I =1,NFAC
  1958.            IHELP = ITAB.TABL(I)
  1959.            IAUX = ITAB.ICOURANT(IHELP)
  1960.            ITAB.TABL2(IAUX) = I
  1961.            IAUX2 = ITAB.TABL(I)
  1962.            ITAB.ICOURANT(IAUX2) = ITAB.ICOURANT(IAUX2) + 1
  1963.            ENDDO
  1964.  
  1965.  
  1966. C**** Initialisation du MCHELM
  1967. C
  1968.       N1=NTSOUS
  1969.       N2=1
  1970.       N3=6
  1971.       L1=8
  1972.       SEGINI MCHEL2
  1973.       MCHEL2.TITCHE='Gradient'
  1974.       MCHEL2.IFOCHE=IFOUR
  1975. C
  1976.       ISOUS=0
  1977.       NBSOUS=0
  1978.       NBREF=0
  1979.       DO I1 = 1, NAUX2, 1
  1980.          NBELEM=ITAB.TABL1(I1)
  1981.          IF(NBELEM .GT. 0)THEN
  1982.             ISOUS=ISOUS+1
  1983.             NBNN=I1
  1984.             SEGINI IPT8
  1985. C           ITYPEL=32 -> 'POLY'
  1986.             ITYPEL=32
  1987.             MCHEL2.IMACHE(ISOUS)=IPT8
  1988.             SEGINI MCHAM2
  1989.             MCHEL2.ICHAML(ISOUS)=MCHAM2
  1990.             MCHAM2.NOMCHE(1)='SCAL'
  1991.             MCHAM2.TYPCHE(1)='REAL*8          '
  1992.             N1PTEL=NBNN
  1993.             N1EL=NBELEM
  1994.             N2PTEL=0
  1995.             N2EL=0
  1996.             SEGINI MELVA2
  1997.             MCHAM2.IELVAL(1)=MELVA2
  1998.  
  1999.             DO I2=1,NBELEM,1
  2000.                DO I3=1,NBNN,1
  2001.                   IAUX = ITAB.IPOS(I1)
  2002.                   IP= ITAB.TABL2(I2 + IAUX - 1)
  2003. c             WRITE(6,*) 'IP= ',IP,'I1= ',I1,'I2=',I2,'I3=',I3
  2004.                   IPT8.NUM(I3,I2)= MELEME.NUM(I3,IP)
  2005.                   MELVA2.VELCHE(I3,I2)=MELVA1.VELCHE(I3,IP)
  2006.                ENDDO
  2007.             ENDDO
  2008. C
  2009.             SEGDES MCHAM2
  2010.             SEGDES IPT8
  2011.             SEGDES MELVA2
  2012.          ENDIF
  2013.       ENDDO
  2014.          SEGDES MCHEL2
  2015.          SEGDES ITAB
  2016. c        ENDIF
  2017.  
  2018.  
  2019. c         SEGDES MCHAML
  2020. c         SEGDES MELEME
  2021. c         SEGDES MELVA1
  2022. c         SEGDES MCHELM
  2023.  
  2024. C 3009
  2025.          SEGSUP MCHAML
  2026.          SEGSUP MELEME
  2027.          SEGSUP MELVA1
  2028.          SEGSUP MCHELM
  2029.  
  2030.  
  2031. C SUPRESSION DES SEGMENTS
  2032.          K3 = NSOMM
  2033.          DO I = 1,K3
  2034.          MATR1 = IPO2.POINT(I)
  2035.          SEGACT MATR1
  2036.          SEGSUP  MATR1
  2037.          ENDDO
  2038.  
  2039.          SEGSUP IPO3
  2040.          SEGSUP IPO2
  2041.          SEGSUP INDLI
  2042.          SEGSUP TAB
  2043.          SEGSUP IND2
  2044. c         SEGSUP IND
  2045. c         SEGSUP IND22
  2046. c         SEGSUP VAL1
  2047. c         SEGSUP VAL2
  2048.          SEGSUP SCMB
  2049. C 3009
  2050.          SEGSUP NBCOT
  2051.  
  2052.       RETURN
  2053.       END
  2054.  
  2055.  
  2056.  
  2057.  
  2058.  
  2059.  
  2060.  
  2061.  
  2062.  
  2063.  
  2064.  
  2065.  
  2066.  
  2067.  
  2068.  

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