Télécharger la plaquette Cast3M


fr en

Télécharger norv4.eso

Retour à la liste

Numérotation des lignes : 

norv4

  1. C NORV4     SOURCE    OF166741  24/10/03    21:15:27     12022          
  2.       SUBROUTINE NORV4(MELEFA,MELEFL,MLECEN,MELEFP,MLESOM,MPONOR,
  3.      &            MPOSUR,MELTFA,MLEFA,MPOTEN,MPOCHP,MLENCL,
  4.      &            MPOVCL,ICHTE,ICHCL,ICHCO,MPOVCO,IOP,
  5.      &            IPO2,SCMB,INDLI,VAL1,VAL2,IND22,IND2,IND,
  6.      &            IPO3,VAUX,TAB,MELEME,MPOGRA,MELVA1,MELVA2,
  7.      &            NBNN,NBFAC,MCHEL2,MCHAM2)
  8. C************************************************************************
  9. C
  10. C PROJET            :  CASTEM 2000
  11. C
  12. C NOM               :  NORV4
  13. C
  14. C DESCRIPTION       : Appelle par NORV1
  15. C
  16. C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
  17. C
  18. C AUTEUR            :  C. LE POTIER, DM2S/SFME/MTMS
  19. C
  20. C************************************************************************
  21. C
  22.       IMPLICIT INTEGER(I-N)
  23.       IMPLICIT REAL*8(A-H,O-Z)
  24.  
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC SMLENTI
  29. -INC SMELEME
  30. -INC SMCHPOI
  31. -INC SMCOORD
  32. -INC SMLREEL
  33. -INC SMCHAML
  34.  
  35.       POINTEUR MELEFL.MELEME, MELEFP.MELEME, MELEFA.MELEME,
  36.      &         MELTFA.MELEME
  37.       POINTEUR MPOSUR.MPOVAL, MPONOR.MPOVAL,
  38.      & MPOCHP.MPOVAL, MPOVCL.MPOVAL, MPGSOM.MPOVAL, MPVOSO.MPOVAL,
  39.      & MPOGRA.MPOVAL,MPOTEN.MPOVAL,MPOVCO.MPOVAL
  40.       POINTEUR MLENCL.MLENTI, MLECEN.MLENTI, MLESOM.MLENTI,
  41.      &         MLEFA.MLENTI
  42.       INTEGER NBNN,NBREF
  43.  
  44. C**** Variable de SMLENTI, SMCHPOI
  45. C
  46.       INTEGER JG, N, NC,  NSOUPO, NAT, NBSOUS, NBNO,NBELEM
  47. C
  48. C**** Les includes
  49. C
  50.       INTEGER I1,ICOMP,ICOMGR,IGEOM
  51.      &     ,IOP1,ICEN,ISOMM,IFAC,IFACEL,IFACEP,INORM
  52.      &     ,ISURF,IMAIL,ICHPO,ICHCL,ICHGRA
  53.      &     ,NTOT,NSOMM,NCOMP,NFAC,NCEN
  54.      &     ,NLCF,NGCF,NGCF1,NGCF2,NGCG,NGCD,NLCG,NLCD,NGS1,NGS2
  55.      &     ,NLS1,NLS2,NLFCL
  56.      &     ,ISOUS,IELEM,INOEUD,ICELL,NCON,NFIN,INDGA,INDDR
  57.       INTEGER ICEN2
  58.       REAL*8 SCNX,SCNY,SURF,VOL,VAL,VALX,VALY,XG,XD,XF,XS1,XS2
  59.      &     ,YG,YD,YF,YS1,YS2,PSCA,XNORM,VECX,VECY,PSCAGX,PSCAGY,
  60.      &     PSCADX,PSCADY,K11G,K22G,K21G,
  61. C     &     K11D,K22D,K21D,
  62.      &     VXG1,VXG2,
  63.      &     VXAU,VYAU,VXD1,VXD2,VYG1,VYG2,TRG1,TRG2,
  64.      &     TRD1,TRD2,TRG,TRD,AUX,AUY,UN,TRGNS1,TRGNS2,EXPR1,EXPR2,COEFD
  65.       REAL*8 XLONG,AG1,AG2,AD1,AD2,PSCAG1,PSCAG2,PSCAD1,PSCAD2,
  66.      & COEF1,COEF2,COEF3,COEF4,SCN1X,SCN1Y,VX,VY,COEF1X,COEF2X,
  67.      & COEF1Y,COEF2Y,CX,CY,ANCX,ANCY,DIFFX,DIFFY,XLONGG,XLONGD
  68.      &  VALD,COEF,GX,GY,XMINK11,XMAXK11,XMINK22,XMAXK22,THETA,
  69.      &  AUXRE,AUXMA
  70.  
  71.       REAL*8 VECXG1(2),VECYG1(2)
  72.       REAL*8 VECXG2(2),VECYG2(2)
  73.       REAL*8 VECXD1(2),VECYD1(2)
  74.       REAL*8 VECXD2(2),VECYD2(2)
  75.       REAL*8 EPS,TRACE
  76.       INTEGER ICRIT
  77.       CHARACTER*8 TYPE
  78. C
  79.       INTEGER NDIM
  80.       SEGMENT MMAT1
  81.       REAL*8 PM(NDIM,NDIM),PM1(NDIM,NDIM),XSOL(NDIM)
  82.       INTEGER IC(NDIM)
  83.       ENDSEGMENT
  84.  
  85.       INTEGER K1,K2
  86.       SEGMENT INDICE
  87.       INTEGER NUME(K1,K2)
  88.       ENDSEGMENT
  89.       POINTEUR IND.INDICE,IND2.INDICE,IND22.INDICE
  90.  
  91.       SEGMENT MATRICE
  92.       REAL*8 MAT(K1,K2)
  93.       ENDSEGMENT
  94.       POINTEUR VAL1.MATRICE,VAL2.MATRICE,SCMB.MATRICE
  95.  
  96.       INTEGER K3
  97.       SEGMENT POINT2
  98.       INTEGER POINT(K3)
  99.       ENDSEGMENT
  100.       POINTEUR IPO2.POINT2
  101.  
  102.       SEGMENT MATRICE2
  103.       REAL*8 MAT2(K1,K2)
  104.       ENDSEGMENT
  105.       POINTEUR MATR1.MATRICE2,MATR2.MATRICE2
  106.  
  107.       SEGMENT POINT3
  108.       INTEGER POINT33(K3)
  109.       ENDSEGMENT
  110.       POINTEUR IPO3.POINT3
  111.  
  112.       SEGMENT INDICE3
  113.       INTEGER NU(K1,K2)
  114.       ENDSEGMENT
  115.       POINTEUR INDIC.INDICE3,INDIC2.INDICE3
  116.  
  117.       SEGMENT REP
  118.       INTEGER  ID(K3)
  119.       ENDSEGMENT
  120.       POINTEUR TAB.REP,INDLI.REP
  121.  
  122.       INTEGER K5
  123.       SEGMENT NBFAC
  124.       INTEGER NBFACEL(K5)
  125.       INTEGER IMELEM(K5)
  126.       ENDSEGMENT
  127.  
  128.       INTEGER K7,K8
  129.       SEGMENT MISZERO
  130.       INTEGER  TABL(K7)
  131.       INTEGER  TABL2(K7)
  132.       INTEGER  TABL1(K8),IPOS(K8),ICOURANT(K8)
  133.       REAL*8 XMAX(K7)
  134.       ENDSEGMENT
  135.       POINTEUR ITAB.MISZERO
  136.  
  137.        NMAI1 = 0
  138.        NBSO = MAX(1,MELTFA.LISOUS(/1))
  139.        IF (NBSO.EQ.1) THEN
  140.        K5 = MELTFA.NUM(/2)
  141.        ELSEIF (NBSO.EQ.2) THEN
  142.        IPT1 = MELTFA.LISOUS(1)
  143.        SEGACT IPT1
  144.        N1 = IPT1.NUM(/2)
  145.        NMAI1 = N1
  146.        SEGDES IPT1
  147.        IPT2 = MELTFA.LISOUS(2)
  148.        SEGACT IPT2
  149.        N2 = IPT2.NUM(/2)
  150.        SEGDES IPT2
  151.        K5 = N1 + N2
  152.        ENDIF
  153.  
  154.        IF (NBSO.EQ.1) THEN
  155.        DO I = 1,K5
  156.            NTYPE = MELTFA.ITYPEL
  157.            IF (NTYPE .EQ. 4) THEN
  158.            NBFACEL(I) = 3
  159.            IMELEM(I) = MELTFA
  160.            ELSE
  161.            NBFACEL(I) = 4
  162.            IMELEM(I) = MELTFA
  163.            ENDIF
  164. c       SEGDES MELTFA
  165.        ENDDO
  166.        ELSEIF (NBSO.EQ.2) THEN
  167.          IPT1 = MELTFA.LISOUS(1)
  168.          SEGACT IPT1
  169.          IPT2 = MELTFA.LISOUS(2)
  170.          SEGACT IPT2
  171.        DO I = 1,K5
  172.          N1 = IPT1.NUM(/2)
  173.          IF (I.LE.N1) THEN
  174.            IF (IPT1.ITYPEL .EQ. 4) THEN
  175.            NBFACEL(I) = 3
  176.            IMELEM(I) =  IPT1
  177.            ELSE
  178.            NBFACEL(I) = 4
  179.            IMELEM(I) = IPT1
  180.            ENDIF
  181. c         SEGDES IPT1
  182.          ELSE
  183.            IF (IPT2.ITYPEL .EQ. 4) THEN
  184.            NBFACEL(I) = 3
  185.            IMELEM(I) = IPT2
  186.            ELSE
  187.            NBFACEL(I) = 4
  188.            IMELEM(I) =  IPT2
  189.            ENDIF
  190. c           SEGDES IPT2
  191.         ENDIF
  192.         ENDDO
  193.         ENDIF
  194.  
  195.  
  196.       NFAC=MELEFL.NUM(/2)
  197.  
  198. C EVALUATION DE NBNN
  199.       NCON = 0
  200.       DO NLCF= 1, NFAC, 1
  201.  
  202.          NGCF=MELEFL.NUM(2,NLCF)
  203.          NGCF1=MELEFA.NUM(1,NLCF)
  204.          NGCF2=MELEFP.NUM(3,NLCF)
  205.          IF((NGCF.NE.NGCF1) .OR. (NGCF.NE.NGCF2))THEN
  206.             WRITE(IOIMP,*)
  207.      &           'Il ne faut pas jouer avec la table domaine!'
  208.             CALL ERREUR(5)
  209.             GOTO 9999
  210.          ENDIF
  211.  
  212.          NGCG=MELEFL.NUM(1,NLCF)
  213.          NGCD=MELEFL.NUM(3,NLCF)
  214.          NLCG=MLECEN.LECT(NGCG)
  215.          NLCD=MLECEN.LECT(NGCD)
  216.  
  217.          NGS1=MELEFP.NUM(1,NLCF)
  218.          NGS2=MELEFP.NUM(2,NLCF)
  219.          NLS1=MLESOM.LECT(NGS1)
  220.          NLS2=MLESOM.LECT(NGS2)
  221.  
  222.  
  223.  
  224.              DO I5 = 1,INDLI.ID(NLS1)
  225.              INDAUX = IND2.NUME(I5,NLS1)
  226.              IF (INDAUX.EQ.NGCF) THEN
  227.              IAFF = I5
  228.              IG = IAFF
  229.              GOTO 6399
  230.              ENDIF
  231.              ENDDO
  232.  6399        CONTINUE
  233.  
  234.  
  235.           INDIC = IPO3.POINT33(NLS1)
  236.           SEGACT INDIC *MOD
  237.           INDIC2 = IPO3.POINT33(NLS2)
  238.           SEGACT INDIC2 *MOD
  239.           ICON = TAB.ID(NLS1)
  240.           DO JAUX = 1,TAB.ID(NLS2)
  241.                J1 = INDIC2.NU(IG,JAUX)
  242. c       WRITE(6,*) 'IG= ',IG,'JAUX= ',JAUX,'NLS2= ',NLS2,'J1= ',J1
  243.                DO IAUX2 = 1,TAB.ID(NLS1)
  244.                J2 = INDIC.NU(IG,IAUX2)
  245. c       WRITE(6,*) 'IG= ',IG,'IAUX2= ',IAUX2,'NLS1= ',NLS1,'J2= ',J2
  246.                IF ((J1.EQ.J2).OR.(J1.EQ.0).OR.(J2.EQ.0)) THEN
  247.                GOTO 5999
  248.                ENDIF
  249.                ENDDO
  250.                ICON = ICON +1
  251.  5999          CONTINUE
  252.  
  253.          ENDDO
  254.           SEGDES INDIC *MOD
  255.           SEGDES INDIC2 *MOD
  256.          NCON = MAX(NCON,ICON)
  257. c         WRITE(6,*) 'NCON= ',NCON
  258.  
  259.          ENDDO
  260.          NCON = NCON + 1
  261.          NBNN = NCON
  262.  
  263.  
  264. C DEFINITION DES PARAMETRES DU CHAMELEM DES COEFFICIENTS
  265.  
  266. c INITIALISATION DU CHAMELEM
  267.       N1=1
  268.       N2=1
  269.       N3=6
  270.       L1=8
  271.       SEGINI MCHELM
  272.       MCHELM.TITCHE='Gradient'
  273.       MCHELM.IFOCHE=IFOUR
  274. C
  275.       ISOUS=0
  276.       NBSOUS=0
  277.       NBREF=0
  278.       NBELEM = NFAC
  279.       ISOUS=ISOUS+1
  280.       SEGINI MELEME
  281. C     ITYPEL=32 -> 'POLY'
  282.       ITYPEL=32
  283.       MCHELM.IMACHE(ISOUS)=MELEME
  284.       MCHELM.CONCHE(ISOUS)='    '
  285.       MCHELM.INFCHE(ISOUS,6)=1
  286.       SEGINI MCHAML
  287.       MCHELM.ICHAML(ISOUS)=MCHAML
  288.       MCHAML.NOMCHE(1)='SCAL'
  289.       MCHAML.TYPCHE(1)='REAL*8          '
  290.       N1PTEL=NCON
  291.       N1EL=NBELEM
  292.       N2PTEL=0
  293.       N2EL=0
  294.       SEGINI MELVA1
  295.       MCHAML.IELVAL(1)=MELVA1
  296.  
  297. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  298. C CALCUL DE LA VITESSE EN CHAQUE FACE
  299. C      AA = 0.0
  300. C      BB = 0.0
  301.  
  302. C INDICE QUI COMPTE LES COEFFICIENTS POUR CHAQUE FACE
  303.       NAUX2 = 0
  304.       NMOY = 0
  305.       DO NLCF= 1, NFAC, 1
  306.  
  307.  
  308.          NGCF=MELEFL.NUM(2,NLCF)
  309.          NGCF1=MELEFA.NUM(1,NLCF)
  310.          NGCF2=MELEFP.NUM(3,NLCF)
  311.          IF((NGCF.NE.NGCF1) .OR. (NGCF.NE.NGCF2))THEN
  312.             WRITE(IOIMP,*)
  313.      &           'Il ne faut pas jouer avec la table domaine!'
  314.             CALL ERREUR(5)
  315.             GOTO 9999
  316.          ENDIF
  317.  
  318.          MELEME.NUM(1,NLCF)=NGCF
  319.          MELVA1.VELCHE(1,NLCF)=0.0D0
  320.  
  321.          NGCG=MELEFL.NUM(1,NLCF)
  322.          NGCD=MELEFL.NUM(3,NLCF)
  323.          NLCG=MLECEN.LECT(NGCG)
  324.          NLCD=MLECEN.LECT(NGCD)
  325.  
  326.          NGS1=MELEFP.NUM(1,NLCF)
  327.          NGS2=MELEFP.NUM(2,NLCF)
  328.          NLS1=MLESOM.LECT(NGS1)
  329.          NLS2=MLESOM.LECT(NGS2)
  330.          SCNX=MPONOR.VPOCHA(NLCF,1)
  331.          SCNY=MPONOR.VPOCHA(NLCF,2)
  332.          SCN1X = SCNX
  333.          SCN1Y = SCNY
  334.          SURF=0.5D0*MPOSUR.VPOCHA(NLCF,1)
  335.          SCNX=SCNX*SURF
  336.          SCNY=SCNY*SURF
  337.  
  338.  
  339. C        3=IDIM+1
  340.          ICELL=(3*(NGCG -1))+1
  341.          XG=MCOORD.XCOOR(ICELL)
  342.          YG=MCOORD.XCOOR(ICELL+1)
  343.          ICELL=(3*(NGCD -1))+1
  344.          XD=MCOORD.XCOOR(ICELL)
  345.          YD=MCOORD.XCOOR(ICELL+1)
  346.          ICELL=(3*(NGCF -1))+1
  347.          XF=MCOORD.XCOOR(ICELL)
  348.          YF=MCOORD.XCOOR(ICELL+1)
  349.          ICELL=(3*(NGS1 -1))+1
  350.          XS1=MCOORD.XCOOR(ICELL)
  351.          YS1=MCOORD.XCOOR(ICELL+1)
  352.          ICELL=(3*(NGS2 -1))+1
  353.          XS2=MCOORD.XCOOR(ICELL)
  354.          YS2=MCOORD.XCOOR(ICELL+1)
  355.  
  356.           XLONG = (((XS1-XS2)**2) + ((YS1-YS2)**2))
  357.           XLONG = SQRT(XLONG)
  358.  
  359.          IG1 = 1
  360.          ID1 = 1
  361.          IG2 = 1
  362.          ID2 = 1
  363.          MELTFA =  IMELEM(NLCG)
  364.          NBF = NBFACEL(NLCG)
  365.          IF (NLCG.GT.NMAI1) THEN
  366.          NGAUX = NLCG - NMAI1
  367.          ELSE
  368.          NGAUX = NLCG
  369.          ENDIF
  370.  
  371.          DO J = 1,NBF
  372.          N1 = MELTFA.NUM(J,NGAUX)
  373.          NL1 = MLEFA.LECT(N1)
  374.  
  375.          NSOM1 = MELEFP.NUM(1,NL1)
  376.          NSOM2 = MELEFP.NUM(2,NL1)
  377.  
  378.          IF ((NSOM1.EQ.NGS1).OR.(NSOM2.EQ.NGS1)) THEN
  379.  
  380.          ICELL=(3*(N1 -1))+1
  381.          XF=MCOORD.XCOOR(ICELL)
  382.          YF=MCOORD.XCOOR(ICELL+1)
  383.          ICELL=(3*(NGS1 -1))+1
  384.          XS1=MCOORD.XCOOR(ICELL)
  385.          YS1=MCOORD.XCOOR(ICELL+1)
  386.  
  387.  
  388.          VECXG1(IG1) = -(YF - YG)
  389.          VECYG1(IG1) = (XF - XG)
  390.          VX = (XG - XS1)
  391.          VY = (YG - YS1)
  392.          PSCA = (VX*VECXG1(IG1)) + (VY*VECYG1(IG1))
  393.          IF (PSCA.LT.0.0D0) THEN
  394.          VECXG1(IG1) = +(YF - YG)
  395.          VECYG1(IG1) = -(XF - XG)
  396.          ENDIF
  397.  
  398. c ON REPERE l'INDICE
  399.              IF ((NSOM2.NE.NGS2).AND.(NSOM1.NE.NGS2)) THEN
  400.              INDG1 = IG1
  401.              NG1 = N1
  402.              ENDIF
  403.  
  404.  
  405.           IG1 = IG1 + 1
  406.  
  407.           ENDIF
  408.          IF ((NSOM1.EQ.NGS2).OR.(NSOM2.EQ.NGS2)) THEN
  409.  
  410.          ICELL=(3*(N1 -1))+1
  411.          XF=MCOORD.XCOOR(ICELL)
  412.          YF=MCOORD.XCOOR(ICELL+1)
  413.          ICELL=(3*(NGS2 -1))+1
  414.          XS2=MCOORD.XCOOR(ICELL)
  415.          YS2=MCOORD.XCOOR(ICELL+1)
  416.  
  417.  
  418.          VECXG2(IG2) = -(YF - YG)
  419.          VECYG2(IG2) = (XF - XG)
  420.          VX = (XG - XS2)
  421.          VY = (YG - YS2)
  422.          PSCA = (VX*VECXG2(IG2)) + (VY*VECYG2(IG2))
  423.          IF (PSCA.LT.0.0D0) THEN
  424.          VECXG2(IG2) = +(YF - YG)
  425.          VECYG2(IG2) = -(XF - XG)
  426.          ENDIF
  427.  
  428.              IF ((NSOM2.NE.NGS1).AND.(NSOM1.NE.NGS1)) THEN
  429.              INDG2 = IG2
  430.              NG2 = N1
  431.              ENDIF
  432.           IG2 = IG2 + 1
  433.  
  434.           ENDIF
  435.         ENDDO
  436.  
  437.  
  438.          MELTFA =  IMELEM(NLCD)
  439.          NBF = NBFACEL(NLCD)
  440.          IF (NLCD.GT.NMAI1) THEN
  441.          NDAUX = NLCD -NMAI1
  442.          ELSE
  443.          NDAUX = NLCD
  444.          ENDIF
  445.  
  446.          DO J = 1,NBF
  447.          N1 = MELTFA.NUM(J,NDAUX)
  448.          NL1 = MLEFA.LECT(N1)
  449.  
  450.          NSOM1 = MELEFP.NUM(1,NL1)
  451.          NSOM2 = MELEFP.NUM(2,NL1)
  452.  
  453.          IF ((NSOM1.EQ.NGS1).OR.(NSOM2.EQ.NGS1)) THEN
  454.  
  455.          ICELL=(3*(N1 -1))+1
  456.          XF=MCOORD.XCOOR(ICELL)
  457.          YF=MCOORD.XCOOR(ICELL+1)
  458.          ICELL=(3*(NGS1 -1))+1
  459.          XS1=MCOORD.XCOOR(ICELL)
  460.          YS1=MCOORD.XCOOR(ICELL+1)
  461.  
  462.  
  463.          VECXD1(ID1) = - (YF - YD)
  464.          VECYD1(ID1) = (XF - XD)
  465.          VX = (XD - XS1)
  466.          VY = (YD - YS1)
  467.          PSCA = (VX*VECXD1(ID1)) + (VY*VECYD1(ID1))
  468.          IF (PSCA.LT.0.0D0) THEN
  469.          VECXD1(ID1) = +(YF - YD)
  470.          VECYD1(ID1) = -(XF - XD)
  471.          ENDIF
  472.  
  473. C             IF ((NSOM2.NE.NGS2).AND.(NSOM1.NE.NGS2)) THEN
  474. C             INDD1 = ID1
  475. C             ENDIF
  476.  
  477.           ID1 = ID1 + 1
  478.  
  479.           ENDIF
  480.          IF ((NSOM1.EQ.NGS2).OR.(NSOM2.EQ.NGS2)) THEN
  481.  
  482.          ICELL=(3*(N1 -1))+1
  483.          XF=MCOORD.XCOOR(ICELL)
  484.          YF=MCOORD.XCOOR(ICELL+1)
  485.          ICELL=(3*(NGS2 -1))+1
  486.          XS2=MCOORD.XCOOR(ICELL)
  487.          YS2=MCOORD.XCOOR(ICELL+1)
  488.  
  489.  
  490.          VECXD2(ID2) = - (YF - YD)
  491.          VECYD2(ID2) = (XF - XD)
  492.          VX = (XD - XS2)
  493.          VY = (YD - YS2)
  494.          PSCA = (VX*VECXD2(ID2)) + (VY*VECYD2(ID2))
  495.          IF (PSCA.LT.0.0D0) THEN
  496.          VECXD2(ID2) = +(YF - YD)
  497.          VECYD2(ID2) = -(XF - XD)
  498.          ENDIF
  499.  
  500. C             IF ((NSOM2.NE.NGS1).AND.(NSOM1.NE.NGS1)) THEN
  501. C             INDD2 = ID2
  502. C             ENDIF
  503.           ID2 = ID2 + 1
  504.  
  505.           ENDIF
  506.         ENDDO
  507.         AG1=ABS(  ( (VECXG1(1)*VECYG1(2)) -
  508.      &             (VECYG1(1))*VECXG1(2)) )
  509.  
  510.          AG2=ABS(  ( (VECXG2(1)*VECYG2(2)) -
  511.      &              (VECYG2(1))*VECXG2(2)) )
  512.  
  513.          AD1=ABS(  ( (VECXD1(1)*VECYD1(2)) -
  514.      &            (VECYD1(1))*VECXD1(2)) )
  515.  
  516.          AD2=ABS(  ( (VECXD2(1)*VECYD2(2)) -
  517.      &             (VECYD2(1))*VECXD2(2)) )
  518.  
  519. c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS1
  520. C           COEF1 = ( (VECXG1(INDG1)*SCNX) + (VECYG1(INDG1)*SCNY) )
  521. C     &              / AG1
  522. C           IAUX = 3 - INDG1
  523. C           COEF2 = ( (VECXG1(IAUX)*SCNX) + (VECYG1(IAUX)*SCNY) )
  524. C     &              / AG1
  525. C
  526. C           COEF3 = ( (VECXD1(INDD1)*SCNX) + (VECYD1(INDD1)*SCNY) )
  527. C     &              / AD1
  528. C           IAUX = 3 - INDD1
  529. C           COEF4 = ( (VECXD1(IAUX)*SCNX) + (VECYD1(IAUX)*SCNY) )
  530. C     &              / AD1
  531.  
  532.  
  533.                DO I5 = 1,INDLI.ID(NLS1)
  534.                INDAUX = IND2.NUME(I5,NLS1)
  535.                IF (INDAUX.EQ.NG1) THEN
  536.                IAFF = I5
  537.                IG1 = IAFF
  538.                GOTO 62
  539.                ENDIF
  540.                ENDDO
  541.  62              CONTINUE
  542.  
  543.            TRG1 =  SCMB.MAT(IAFF,NLS1)
  544.  
  545.                DO I5 = 1,INDLI.ID(NLS1)
  546.                INDAUX = IND2.NUME(I5,NLS1)
  547.                IF (INDAUX.EQ.NGCF) THEN
  548.                IAFF = I5
  549.                IG = IAFF
  550.                IGNS1 = IAFF
  551.                GOTO 63
  552.                ENDIF
  553.                ENDDO
  554.  63              CONTINUE
  555.            TRG =  SCMB.MAT(IAFF,NLS1)
  556.            TRGAUX =  TRG
  557.            TRGNS1 = TRG
  558.  
  559.             IAUX = 3 - INDG1
  560.             VXG1 = VECXG1(INDG1)/AG1
  561.             VXAU = VECXG1(IAUX)/AG1
  562.             VYG1 = VECYG1(INDG1)/AG1
  563.             VYAU = VECYG1(IAUX)/AG1
  564.  
  565.            IF (ICHTE.GT.0) THEN
  566.             IF (MPOTEN.VPOCHA(/2) .EQ.3) THEN
  567. c LE TENSEUR EST ANISOTROPE
  568.             K11G = MPOTEN.VPOCHA(NLCG,1)
  569.             K22G = MPOTEN.VPOCHA(NLCG,2)
  570.             K21G = MPOTEN.VPOCHA(NLCG,3)
  571.  
  572.             K11D = MPOTEN.VPOCHA(NLCD,1)
  573. C            K22D = MPOTEN.VPOCHA(NLCD,2)
  574. C            K21D = MPOTEN.VPOCHA(NLCD,3)
  575.             ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN
  576.             K11G = MPOTEN.VPOCHA(NLCG,1)
  577.             K22G = K11G
  578.             K21G = 0.0D0
  579.             K11D = MPOTEN.VPOCHA(NLCD,1)
  580. C            K22D = K11D
  581. C            K21D = 0.0D0
  582.             ELSE
  583.             WRITE(6,*) 'TENSEUR NON PREVU'
  584.             ENDIF
  585.  
  586. c           NLCG2 = MLECEN2.LECT(NGCG)
  587. c           NLCD2 = MLECEN2.LECT(NGCD)
  588. c           K11G = MPOTEN.VPOCHA(NLCG2,1)
  589. c           K22G = MPOTEN.VPOCHA(NLCG2,2)
  590. c           K21G = MPOTEN.VPOCHA(NLCG2,3)
  591.  
  592. c           K11D = MPOTEN.VPOCHA(NLCD2,1)
  593. c           K22D = MPOTEN.VPOCHA(NLCD2,2)
  594. c           K21D = MPOTEN.VPOCHA(NLCD2,3)
  595. c PRODUIT TENSEUR VECTEUR
  596.          VXG1 = ((VECXG1(INDG1)/AG1)*K11G) + ((VECYG1(INDG1)/AG1)*K21G)
  597.          VYG1 = ((VECXG1(INDG1)/AG1)*K21G) + ((VECYG1(INDG1)/AG1)*K22G)
  598.  
  599.          IAUX = 3 - INDG1
  600.          VXAU = ((VECXG1(IAUX)/AG1)*K11G) + ((VECYG1(IAUX)/AG1)*K21G)
  601.          VYAU = ((VECXG1(IAUX)/AG1)*K21G) + ((VECYG1(IAUX)/AG1)*K22G)
  602. c           WRite(6,*) 'K11G=',K11G,'K22G= ',K22G,'K21G=',K21G
  603. c           WRite(6,*) 'K11D=',K11D,'K22D= ',K22D,'K21D=',K21D
  604. c            WRITE(6,*) 'NLCF= ',NLCF,'VECXG1= ',VXG1
  605. c            IAUX = 3 - INDG1
  606. c            WRITE(6,*) 'NLCF= ',NLCF,'VXAU= ',VXAU
  607. c            WRITE(6,*) 'NLCF= ',NLCF,'VECYG1= ',VYG1
  608. c            IAUX = 3 - INDG1
  609. c            WRITE(6,*) 'NLCF= ',NLCF,'VYAU= ',VYAU
  610. c            WRITE(6,*) 'NLCF= ',NLCF,'VALD= ',VALD
  611. c            WRITE(6,*) 'NLCF= ',NLCF,'VECXG1= ',VECXG1(INDG1)
  612. c            IAUX = 3 - INDG1
  613. c            WRITE(6,*) 'NLCF= ',NLCF,'VXAU= ',VECXG1(IAUX)
  614. c            WRITE(6,*) 'NLCF= ',NLCF,'VECYG1= ',VECYG1(INDG1)
  615. c            IAUX = 3 - INDG1
  616. c            WRITE(6,*) 'NLCF= ',NLCF,'VYAU= ',VECYG1(IAUX)
  617. c            WRITE(6,*) 'NLCF= ',NLCF,'VALD= ',VALD
  618.             ENDIF
  619.  
  620.             VAL = MPOCHP.VPOCHA(NLCG,1)
  621. C            VALG = VAL
  622.           COEF1X = VXG1
  623.           COEF2X = VXAU
  624.           COEF1Y = VYG1
  625.           COEF2Y = VYAU
  626.  
  627.          AUX = SCN1X* ( (COEF1X * (TRG - VAL)) +
  628.      &                   (COEF2X * (TRG1 - VAL))  )
  629.          AUY = SCN1Y* ( (COEF1Y * (TRG - VAL)) +
  630.      &                  (COEF2Y * (TRG1 - VAL))  )
  631.             MPOGRA.VPOCHA(NLCF,1) = AUX + AUY
  632.  
  633.  
  634. c          WRITE(6,*) 'NLCF= ',NLCF
  635. c          WRITE(6,*) 'COEF1X= ',COEF1X
  636. c          WRITE(6,*) 'COEF2X= ',COEF2X
  637. c          WRITE(6,*) 'COEF1Y= ',COEF1Y
  638. c          WRITE(6,*) 'COEF2Y= ',COEF2Y
  639.  
  640.  
  641.           INDIC = IPO3.POINT33(NLS1)
  642.           SEGACT INDIC *MOD
  643.           MATR1 = IPO2.POINT(NLS1)
  644.           SEGACT MATR1 *MOD
  645.  
  646.           DO JAUX = 1,TAB.ID(NLS1)
  647.              CX = MATR1.MAT2(IG,JAUX)
  648.              CY = MATR1.MAT2(IG,JAUX)
  649.              INDAUX = INDIC.NU(IG,JAUX)
  650.              MELEME.NUM(JAUX+1,NLCF)  = INDAUX
  651.              IF (INDAUX.EQ.NGCG) THEN
  652.              CX = CX - 1.D0
  653.              CY = CY - 1.D0
  654.              INDGA = JAUX +1
  655.              ENDIF
  656.              IF (INDAUX.EQ.NGCD) THEN
  657.              INDDR = JAUX + 1
  658.              ENDIF
  659.  
  660.              MELVA1.VELCHE(JAUX+1,NLCF) =
  661.      &       (COEF1X*CX*SCN1X) + (COEF1Y*CY*SCN1Y)
  662.           ENDDO
  663.  
  664.  
  665.       ITROUVE = 0
  666.       DO ICOUR = 1,TAB.ID(NLS1)
  667.       IA = ICOUR
  668.          J1 = INDIC.NU(IG1,IA)
  669.          DO IAUX2 = 2,TAB.ID(NLS1)+1
  670.          J2 = MELEME.NUM(IAUX2,NLCF)
  671.          IF (J1.EQ.J2) THEN
  672.          IAUX = IAUX2
  673.          ITROUVE = 1
  674.          GOTO 511
  675.          ENDIF
  676.          ENDDO
  677.  511     CONTINUE
  678.       IF (ITROUVE.EQ.0) THEN
  679.       WRITE(6,*) 'PROBLEME ALGO1'
  680.           WRITE(6,*) 'INDIC= ',INDIC
  681.           DO IAUX2 = 1,TAB.ID(NLS1)+1
  682.           J2 = MELEME.NUM(IAUX2,NLCF)
  683.           WRITE(6,*) 'NLCF= ',NLCF,'IAUX2=',IAUX2,'MELEME= ',J2
  684.           WRITE(6,*) 'IG= ',IG,'IAUX2=',IAUX2,
  685.      &    'NLS1= ',NLS1,'INDIC=',INDIC.NU(IG,IAUX2)
  686.           WRITE(6,*) 'IG1= ',IG1,'IAUX2=',IAUX2,
  687.      &    'NLS1= ',NLS1,'INDIC= ',INDIC.NU(IG1,IAUX2)
  688.           ENDDO
  689.       CALL ERREUR(5)
  690.       ENDIF
  691.  
  692.              CX = MATR1.MAT2(IG1,IA)
  693.              CY = MATR1.MAT2(IG1,IA)
  694.              IF (J1.EQ.NGCG) THEN
  695.              CX = CX - 1.D0
  696.              CY = CY - 1.D0
  697.              ENDIF
  698.              MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) +
  699.      &       (COEF2X*CX*SCN1X)  +   (COEF2Y*CY*SCN1Y)
  700.       ENDDO
  701.  
  702. c          DO IAUX2 = 2,TAB.ID(NLS1)+1
  703. c          J1 = MELEME.NUM(IAUX2,NLCF)
  704. c          WRITE(6,*) 'NLCF= ',NLCF,'IAUX2= ',IAUX2
  705. c          WRITE(6,*) 'MELEME2= ',J1
  706. c          COEF1 = MELVA1.VELCHE(IAUX2,NLCF)
  707. c          COEF2 = MELVA2.VELCHE(IAUX2,NLCF)
  708. c          WRITE(6,*) 'COEF1= ',COEF1,'COEF2= ',COEF2
  709. c          ENDDO
  710.  
  711.  
  712.  
  713. * POUR NLS1
  714. c          DO IAUX2 = 1,INDLI.ID(NLS1)
  715. c          WRITE(6,*) 'NLS1= ',NLS1,'INDIC= ',INDIC(ID,IAUX2)
  716. c          WRITE(6,*) 'NLS1= ',NLS1,'INDIC= ',INDIC(ID1,IAUX2)
  717. c          ENDDO
  718.  
  719. c          DO IAUX2 = 2,TAB.ID(NLS1)+1
  720. c          J1 = MELEME.NUM(IAUX2,NLCF)
  721. c          WRITE(6,*) 'NLCF= ',NLCF,'IAUX2= ',IAUX2
  722. c          WRITE(6,*) 'MELEME3= ',J1
  723. c          COEF1 = MELVA1.VELCHE(IAUX2,NLCF)
  724. c          COEF2 = MELVA2.VELCHE(IAUX2,NLCF)
  725. c          WRITE(6,*) 'COEF1= ',COEF1,'COEF2= ',COEF2
  726. c          ENDDO
  727.  
  728.           SEGDES INDIC *MOD
  729.           SEGDES MATR1 *MOD
  730.  
  731.           INDIC = IPO3.POINT33(NLS2)
  732.           SEGACT INDIC *MOD
  733.           MATR1 = IPO2.POINT(NLS2)
  734.           SEGACT MATR1 *MOD
  735. c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS2
  736.  
  737. C           COEF1 = ( (VECXG2(INDG2)*SCNX) + (VECYG2(INDG2)*SCNY) )
  738. C     &              / AG2
  739. C           IAUX = 3 - INDG2
  740. C           COEF2 = ( (VECXG2(IAUX)*SCNX) + (VECYG2(IAUX)*SCNY) )
  741. C     &              / AG2
  742. C
  743. C           COEF3 = ( (VECXD2(INDD2)*SCNX) + (VECYD2(INDD2)*SCNY) )
  744. C     &              / AD2
  745. C           IAUX = 3 - INDD2
  746. C           COEF4 = ( (VECXD2(IAUX)*SCNX) + (VECYD2(IAUX)*SCNY) )
  747. C     &              / AD2
  748.  
  749.                DO I5 = 1,INDLI.ID(NLS2)
  750.                INDAUX = IND2.NUME(I5,NLS2)
  751.                IF (INDAUX.EQ.NG2) THEN
  752.                IAFF = I5
  753.                IG2 = IAFF
  754.                GOTO 411
  755.                ENDIF
  756.                ENDDO
  757.  411              CONTINUE
  758.  
  759.            TRG2 =  SCMB.MAT(IAFF,NLS2)
  760.  
  761.                DO I5 = 1,INDLI.ID(NLS2)
  762.                INDAUX = IND2.NUME(I5,NLS2)
  763.                IF (INDAUX.EQ.NGCF) THEN
  764.                IAFF = I5
  765.                IG = IAFF
  766.                IGNS2 = IAFF
  767.                GOTO 635
  768.                ENDIF
  769.                ENDDO
  770.  635              CONTINUE
  771.  
  772.            TRG =  SCMB.MAT(IAFF,NLS2)
  773.            TRGNS2 = TRG
  774.  
  775.             IAUX = 3 - INDG2
  776.             VXG2 = VECXG2(INDG2)/AG2
  777.             VXAU = VECXG2(IAUX)/AG2
  778.             VYG2 = VECYG2(INDG2)/AG2
  779.             VYAU = VECYG2(IAUX)/AG2
  780.  
  781. c            WRITE(6,*) 'NLCF= ',NLCF,'VECXG2= ',VECXG2(INDG2)
  782. c            IAUX = 3 - INDG2
  783. c            WRITE(6,*) 'NLCF= ',NLCF,'VXAU= ',VECXG2(IAUX)
  784. c            WRITE(6,*) 'NLCF= ',NLCF,'VECYG2= ',VECYG2(INDG2)
  785. c            IAUX = 3 - INDG2
  786. c            WRITE(6,*) 'NLCF= ',NLCF,'VYAU= ',VECYG2(IAUX)
  787.  
  788.            IF (ICHTE.GT.0) THEN
  789.  
  790.             IF (MPOTEN.VPOCHA(/2) .EQ.3) THEN
  791. c LE TENSEUR EST ANISOTROPE
  792.             K11G = MPOTEN.VPOCHA(NLCG,1)
  793.             K22G = MPOTEN.VPOCHA(NLCG,2)
  794.             K21G = MPOTEN.VPOCHA(NLCG,3)
  795.  
  796. C            K11D = MPOTEN.VPOCHA(NLCD,1)
  797. C            K22D = MPOTEN.VPOCHA(NLCD,2)
  798. C            K21D = MPOTEN.VPOCHA(NLCD,3)
  799.             ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN
  800.             K11G = MPOTEN.VPOCHA(NLCG,1)
  801.             K22G = K11G
  802.             K21G = 0.0D0
  803. C            K11D = MPOTEN.VPOCHA(NLCD,1)
  804. C            K22D = K11D
  805. C            K21D = 0.0D0
  806.             ELSE
  807.             WRITE(6,*) 'TENSEUR NON PREVU'
  808.             ENDIF
  809.  
  810. c           NLCG2 = MLECEN2.LECT(NGCG)
  811. c           NLCD2 = MLECEN2.LECT(NGCD)
  812. c           K11G = MPOTEN.VPOCHA(NLCG2,1)
  813. c           K22G = MPOTEN.VPOCHA(NLCG2,2)
  814. c           K21G = MPOTEN.VPOCHA(NLCG2,3)
  815. c
  816. c           K11D = MPOTEN.VPOCHA(NLCD2,1)
  817. c           K22D = MPOTEN.VPOCHA(NLCD2,2)
  818. c           K21D = MPOTEN.VPOCHA(NLCD2,3)
  819. c PRODUIT TENSEUR VECTEUR
  820.        VXG2 = ((VECXG2(INDG2)/AG2)*K11G) + ((VECYG2(INDG2)/AG2)*K21G)
  821.        VYG2 = ((VECXG2(INDG2)/AG2)*K21G) + ((VECYG2(INDG2)/AG2)*K22G)
  822.  
  823.        IAUX = 3 - INDG2
  824.        VXAU = ((VECXG2(IAUX)/AG2)*K11G) + ((VECYG2(IAUX)/AG2)*K21G)
  825.        VYAU = ((VECXG2(IAUX)/AG2)*K21G) + ((VECYG2(IAUX)/AG2)*K22G)
  826. c           WRite(6,*) 'K11G=',K11G,'K22G= ',K22G,'K21G=',K21G
  827. c           WRite(6,*) 'K11D=',K11D,'K22D= ',K22D,'K21D=',K21D
  828. c            WRITE(6,*) 'NLCF= ',NLCF,'VECXG2= ',VXG2
  829. c            IAUX = 3 - INDG2
  830. c            WRITE(6,*) 'NLCF= ',NLCF,'VXAU= ',VXAU
  831. c            WRITE(6,*) 'NLCF= ',NLCF,'VECYG2= ',VYG2
  832. c            IAUX = 3 - INDG2
  833. c            WRITE(6,*) 'NLCF= ',NLCF,'VYAU= ',VYAU
  834.            ENDIF
  835.           COEF1X = VXG2
  836.           COEF2X = VXAU
  837.           COEF1Y = VYG2
  838.           COEF2Y = VYAU
  839.  
  840.          AUX = SCN1X* ( (COEF1X * (TRG - VAL)) +
  841.      &                   (COEF2X * (TRG2 - VAL))  )
  842.          AUY = SCN1Y* ( (COEF1Y * (TRG - VAL)) +
  843.      &                  (COEF2Y * (TRG2 - VAL))  )
  844.             MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) +
  845.      &                                AUX + AUY
  846.  
  847.  
  848. C            ANCX = MPOGRA.VPOCHA(NLCF,1)
  849. C POUR NLS2
  850.  
  851. c          WRITE(6,*) 'COEF1X= ',COEF1X
  852. c          WRITE(6,*) 'COEF2X= ',COEF2X
  853. c          WRITE(6,*) 'COEF1Y= ',COEF1Y
  854. c          WRITE(6,*) 'COEF2Y= ',COEF2Y
  855.           ICON = TAB.ID(NLS1)+1
  856.           DO JAUX = 1,TAB.ID(NLS2)
  857.                J1 = INDIC.NU(IG,JAUX)
  858.                DO IAUX2 = 2,ICON
  859.                J2 = MELEME.NUM(IAUX2,NLCF)
  860.                IF (J1.EQ.J2) THEN
  861.                IAUX = IAUX2
  862.                GOTO 59
  863.                ENDIF
  864.                ENDDO
  865.                ICON = ICON +1
  866.                IAUX = ICON
  867.             IF (IAUX.GT.NBNN) THEN
  868.             WRITE(6,*) 'NBNN TROP PETIT'
  869.             CALL ERREUR(5)
  870.              ENDIF
  871.  59          CONTINUE
  872.  
  873.              CX = MATR1.MAT2(IG,JAUX)
  874.              CY = MATR1.MAT2(IG,JAUX)
  875.              INDAUX = INDIC.NU(IG,JAUX)
  876.              MELEME.NUM(IAUX,NLCF)  = INDAUX
  877.              IF (INDAUX.EQ.NGCG) THEN
  878.              CX = CX - 1.0D0
  879.              CY = CY - 1.0D0
  880.              ENDIF
  881.  
  882.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) +
  883.      &      (COEF1X*CX*SCN1X) + (COEF1Y*CY*SCN1Y)
  884.           ENDDO
  885. c          DO IAUX2 = 2,ICON
  886. c          J1 = MELEME.NUM(IAUX2,NLCF)
  887. c          WRITE(6,*) 'NLCF= ',NLCF,'IAUX2= ',IAUX2
  888. c          WRITE(6,*) 'MELEME4= ',J1
  889. c          COEF1 = MELVA1.VELCHE(IAUX2,NLCF)
  890. c          COEF2 = MELVA2.VELCHE(IAUX2,NLCF)
  891. c          WRITE(6,*) 'COEF1= ',COEF1,'COEF2= ',COEF2
  892. c          ENDDO
  893.  
  894.             ITROUVE = 0
  895.             DO ICOUR = 1,TAB.ID(NLS2)
  896.             IA = ICOUR
  897.             J1 = INDIC.NU(IG2,IA)
  898.             DO IAUX2 = 2,ICON
  899.             J2 = MELEME.NUM(IAUX2,NLCF)
  900.             IF (J1.EQ.J2) THEN
  901.             IAUX = IAUX2
  902.             ITROUVE = 1
  903.             GOTO 577
  904.             ENDIF
  905.             ENDDO
  906.  577     CONTINUE
  907.             IF (ITROUVE.EQ.0) THEN
  908.             WRITE(6,*) 'PROBLEME ALGO3'
  909.           WRITE(6,*) 'INDIC= ',INDIC
  910.           DO IAUX2 = 2,ICON
  911.           J1 = MELEME.NUM(IAUX2,NLCF)
  912.           WRITE(6,*) 'NLCF= ',NLCF,'IAUX2=',IAUX2,'MELEME= ',J1
  913.           WRITE(6,*) 'IG= ',IG,'IAUX2=',IAUX2,'INDIC=',
  914.      &    'NLS2= ',NLS2,INDIC.NU(IG,IAUX2)
  915.           WRITE(6,*) 'IG2= ',IG2,'IAUX2=',IAUX2,'INDIC= ',
  916.      &    'NLS2= ',NLS2,INDIC.NU(IG2,IAUX2)
  917.           ENDDO
  918.             CALL ERREUR(5)
  919.             ENDIF
  920.  
  921.              CX = MATR1.MAT2(IG2,IA)
  922.              CY = MATR1.MAT2(IG2,IA)
  923.              IF (J1.EQ.NGCG) THEN
  924.              CX = CX - 1.0D0
  925.              CY = CY - 1.D0
  926.              ENDIF
  927.              MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) +
  928.      &       (COEF2X*CX*SCN1X)  +  (COEF2Y*CY*SCN1Y)
  929.             ENDDO
  930.  
  931.  
  932.              MPOGRA.VPOCHA(NLCF,1) = (-0.5D0)* MPOGRA.VPOCHA(NLCF,1)
  933.  
  934.              ISUP = ICON
  935.              DO J= ISUP+1,NBNN
  936.              MELVA1.VELCHE(J,NLCF) = 0.0D0
  937.              MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF)
  938.              ENDDO
  939.              DO J= 1,NBNN
  940.              MELVA1.VELCHE(J,NLCF) = (-0.5D0*MELVA1.VELCHE(J,NLCF))
  941.              ENDDO
  942.  
  943. C  ON RAJOUTE LE CONVECTIF
  944.              IF (ICHCO.GT.0) THEN
  945.  
  946. C BOUCLE POUR CALCUER INDGA,INDDR
  947.              INDFR = 0
  948.              DO J= 1,ISUP
  949.              IF (MELEME.NUM(J,NLCF).EQ.NGCG) INDGA = J
  950.              IF (MELEME.NUM(J,NLCF).EQ.NGCD) INDDR = J
  951.              IF (MELEME.NUM(J,NLCF).EQ.NGCF) INDFR = J
  952.              ENDDO
  953.              UN =  MPOVCO.VPOCHA(NLCF,1)
  954. c             WRITE(6,*) 'UN= ',UN
  955. C OPTION CENTRE
  956.              IF (IOP.EQ.2) THEN
  957.              IF (NLCD.NE.NLCG) THEN
  958.              VAL = 0.5D0*(MPOCHP.VPOCHA(NLCG,1) +
  959.      &                        MPOCHP.VPOCHA(NLCD,1))*UN
  960.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  961.              ELSE
  962. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  963.              TRACE = 0.5*(TRGNS1+TRGNS2)
  964. c             WRITE(6,*) 'NLCF= ',NLCF,'TRACE= ',TRACE
  965.              VAL = TRACE*UN
  966.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  967.              ENDIF
  968.  
  969. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  970.             IF (NLCD.NE.NLCG) THEN
  971.             MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  972.      &                                  (0.5D0*UN)
  973.             MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  974.      &                                  (0.5D0*UN)
  975. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDANCES DES TRACES
  976. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  977.  
  978.             ELSE
  979.  
  980.             NLFCL = MLENCL.LECT(NGCF)
  981.  
  982. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  983.             IF (NLFCL.NE.0) THEN
  984.             MELVA1.VELCHE(ICON+1,NLCF) =   - UN
  985.             MELEME.NUM(ICON+1,NLCF) = NGCF
  986.             ENDIF
  987.  
  988.             IF (NLFCL.EQ.0) THEN
  989.             INDIC = IPO3.POINT33(NLS1)
  990.             SEGACT INDIC *MOD
  991.             MATR1 = IPO2.POINT(NLS1)
  992.             SEGACT MATR1 *MOD
  993.              DO JAUX = 1,TAB.ID(NLS1)
  994.                J1 = INDIC.NU(IGNS1,JAUX)
  995.                DO IAUX2 = 2,ICON
  996.                J2 = MELEME.NUM(IAUX2,NLCF)
  997.                IF (J1.EQ.J2) THEN
  998.                IAUX = IAUX2
  999.                GOTO 5459
  1000.                ENDIF
  1001.                ENDDO
  1002.  5459          CONTINUE
  1003.  
  1004.              CX = MATR1.MAT2(IGNS1,JAUX)
  1005.  
  1006.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF)
  1007.      &      - (UN*CX*0.5D0)
  1008.              ENDDO
  1009.  
  1010.             SEGDES INDIC *MOD
  1011.             SEGDES MATR1 *MOD
  1012.  
  1013.             INDIC = IPO3.POINT33(NLS2)
  1014.             SEGACT INDIC *MOD
  1015.             MATR1 = IPO2.POINT(NLS2)
  1016.             SEGACT MATR1 *MOD
  1017.              DO JAUX = 1,TAB.ID(NLS2)
  1018.                J1 = INDIC.NU(IGNS2,JAUX)
  1019.                DO IAUX2 = 2,ICON
  1020.                J2 = MELEME.NUM(IAUX2,NLCF)
  1021.                IF (J1.EQ.J2) THEN
  1022.                IAUX = IAUX2
  1023.                GOTO 5988
  1024.                ENDIF
  1025.                ENDDO
  1026.  5988          CONTINUE
  1027.  
  1028.              CX = MATR1.MAT2(IGNS2,JAUX)
  1029. c             WRITE(6,*) 'NLCF= ',NLCF,'CX= ',CX
  1030.  
  1031.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF)
  1032.      &      - (UN*CX*0.5D0)
  1033.              ENDDO
  1034.             SEGDES INDIC *MOD
  1035.             SEGDES MATR1 *MOD
  1036.             ENDIF
  1037.  
  1038.             ENDIF
  1039.  
  1040.  
  1041. C OPTION UPWIND
  1042.             ELSEIF (IOP.EQ.1) THEN
  1043.              IF (NLCD.NE.NLCG) THEN
  1044.               IF (UN.GT.0.0D0) THEN
  1045.              VAL = (MPOCHP.VPOCHA(NLCG,1)*UN)
  1046.              ELSE
  1047.              VAL = (MPOCHP.VPOCHA(NLCD,1)*UN)
  1048.              ENDIF
  1049.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1050.              ELSE
  1051. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1052. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1053.                IF (UN.GT.0.0D0) THEN
  1054.                VAL = (MPOCHP.VPOCHA(NLCG,1)*UN)
  1055.                ELSE
  1056.                TRACE = 0.5*(TRGNS1+TRGNS2)
  1057.                 VAL = TRACE*UN
  1058.                ENDIF
  1059.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1060.              ENDIF
  1061.  
  1062. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1063.             IF (NLCD.NE.NLCG) THEN
  1064.                IF (UN.GT.0.0D0) THEN
  1065.                MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1066.      &                                     (UN)
  1067.                ELSE
  1068.                MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1069.      &                                     (UN)
  1070.                ENDIF
  1071. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDANCES DES TRACES
  1072. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1073.  
  1074.             ELSE
  1075.             IF (UN.GT.0.0D0) THEN
  1076.                MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1077.      &                                     (UN)
  1078.  
  1079.             ELSE
  1080.             NLFCL = MLENCL.LECT(NGCF)
  1081.  
  1082. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1083.             IF (NLFCL.NE.0) THEN
  1084.             MELVA1.VELCHE(ICON+1,NLCF) =   - UN
  1085.             MELEME.NUM(ICON+1,NLCF) = NGCF
  1086.             ENDIF
  1087.  
  1088. c            IF (1.EQ.0) THEN
  1089.             IF (NLFCL.EQ.0) THEN
  1090.             INDIC = IPO3.POINT33(NLS1)
  1091.             SEGACT INDIC *MOD
  1092.             MATR1 = IPO2.POINT(NLS1)
  1093.             SEGACT MATR1 *MOD
  1094.              DO JAUX = 1,TAB.ID(NLS1)
  1095.                J1 = INDIC.NU(IGNS1,JAUX)
  1096.                DO IAUX2 = 2,ICON
  1097.                J2 = MELEME.NUM(IAUX2,NLCF)
  1098.                IF (J1.EQ.J2) THEN
  1099.                IAUX = IAUX2
  1100.                GOTO 5449
  1101.                ENDIF
  1102.                ENDDO
  1103.  5449          CONTINUE
  1104.  
  1105.              CX = MATR1.MAT2(IGNS1,JAUX)
  1106.  
  1107.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF)
  1108.      &      - (UN*CX*0.5D0)
  1109.              ENDDO
  1110.             SEGDES INDIC *MOD
  1111.             SEGDES MATR1 *MOD
  1112.  
  1113.             INDIC = IPO3.POINT33(NLS2)
  1114.             SEGACT INDIC *MOD
  1115.             MATR1 = IPO2.POINT(NLS2)
  1116.             SEGACT MATR1 *MOD
  1117.              DO JAUX = 1,TAB.ID(NLS2)
  1118.                J1 = INDIC.NU(IGNS2,JAUX)
  1119.                DO IAUX2 = 2,ICON
  1120.                J2 = MELEME.NUM(IAUX2,NLCF)
  1121.                IF (J1.EQ.J2) THEN
  1122.                IAUX = IAUX2
  1123.                GOTO 5989
  1124.                ENDIF
  1125.                ENDDO
  1126.  5989          CONTINUE
  1127.  
  1128.              CX = MATR1.MAT2(IGNS2,JAUX)
  1129.  
  1130.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF)
  1131.      &      - (UN*CX*0.5D0)
  1132.              ENDDO
  1133.             SEGDES INDIC *MOD
  1134.             SEGDES MATR1 *MOD
  1135. c            ENDIF
  1136.  
  1137.             ENDIF
  1138.             ENDIF
  1139.             ENDIF
  1140.  
  1141. C OPTION UPWICENT
  1142.             ELSEIF (IOP.EQ.3) THEN
  1143.              IF (NLCD.NE.NLCG) THEN
  1144.  
  1145.  
  1146. c CALCUL DE THETA
  1147. c DANS MELVA1 :  INDDR EST LA NUM de NLCD
  1148. C COEFD = MELVA1(INDDR,NLCF)
  1149.              COEFD =   MELVA1.VELCHE(INDDR,NLCF)
  1150.  
  1151.              THETA = 0.5D0
  1152.              EXPR1 = (THETA*UN) + COEFD
  1153.              EXPR2 = ((1.D0 - THETA)*UN) - COEFD
  1154.              IF (EXPR1.LT.0.0D0) THEN
  1155.                 IF (ABS(UN) .GT. 1e-20) THEN
  1156.                  THETA = - (0.5*COEFD / UN)
  1157.                 ENDIF
  1158.              ENDIF
  1159.              IF (EXPR2.GT.0.0D0) THEN
  1160.                 IF (ABS(UN) .GT. 1e-20) THEN
  1161.                  THETA = 1.D0 - (0.5*COEFD / UN)
  1162.                 ENDIF
  1163.              ENDIF
  1164.              THETA = MIN(1.D0,THETA)
  1165.              THETA = MAX(0.D0,THETA)
  1166. c             WRITE(6,*) 'THETA= ',THETA
  1167. c             WRITE(6,*) 'COEFD= ',COEFD
  1168. c             WRITE(6,*) 'UN= ',UN
  1169. c             WRITE(6,*) 'EXPR1= ',EXPR1
  1170. c             WRITE(6,*) 'EXPR2= ',EXPR2
  1171.              VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) +
  1172.      &             (MPOCHP.VPOCHA(NLCD,1)*(1.D0-THETA)*UN)
  1173.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1174.             ELSE
  1175. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1176.  
  1177.             IF (INDFR.NE.0) THEN
  1178.              COEFD =   MELVA1.VELCHE(INDFR,NLCF)
  1179.              ELSE
  1180.              COEFD = 0.0D0
  1181.             ENDIF
  1182.  
  1183.  
  1184. C C'EST LE THETA LE MIEUX ADPATE POUR LES CONDITIONS AUX LIMITES
  1185.              THETA = 0.0D0
  1186.              EXPR1 = (THETA*UN) + COEFD
  1187.              EXPR2 = ((1.D0 - THETA)*UN) - COEFD
  1188.              IF (EXPR1.LT.0.0D0) THEN
  1189.                 IF (ABS(UN) .GT. 1e-20) THEN
  1190.                  THETA = - (0.5*COEFD / UN)
  1191.                 ENDIF
  1192.              ENDIF
  1193.              IF (EXPR2.GT.0.0D0) THEN
  1194.                 IF (ABS(UN) .GT. 1e-20) THEN
  1195.                  THETA = 1.D0 - (0.5*COEFD / UN)
  1196.                 ENDIF
  1197.              ENDIF
  1198.              THETA = MIN(1.D0,THETA)
  1199.              THETA = MAX(0.D0,THETA)
  1200.  
  1201.             TRACE = 0.5*(TRGNS1+TRGNS2)
  1202.  
  1203.  
  1204.              VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) +
  1205.      &             (TRACE*(1.D0-THETA)*UN)
  1206.              MPOGRA.VPOCHA(NLCF,1) =  MPOGRA.VPOCHA(NLCF,1) - VAL
  1207.  
  1208.              ENDIF
  1209.  
  1210.  
  1211.  
  1212. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1213.             IF (NLCD.NE.NLCG) THEN
  1214.             MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1215.      &                                  (THETA*UN)
  1216.             MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1217.      &                                  ((1.D0-THETA)*UN)
  1218. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDANCES DES TRACES
  1219. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1220.  
  1221.             ELSE
  1222.  
  1223.             MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1224.      &                                    (THETA*UN)
  1225.  
  1226.             NLFCL = MLENCL.LECT(NGCF)
  1227.  
  1228. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1229. c            IF (NLFCL.NE.0) THEN
  1230. c            MELVA1.VELCHE(ICON+1,NLCF) =   - UN
  1231. c            MELEME.NUM(ICON+1,NLCF) = NGCF
  1232. c            ENDIF
  1233.  
  1234. c            IF (1.EQ.0) THEN
  1235. c            IF (NLFCL.EQ.0) THEN
  1236.             INDIC = IPO3.POINT33(NLS1)
  1237.             SEGACT INDIC *MOD
  1238.             MATR1 = IPO2.POINT(NLS1)
  1239.             SEGACT MATR1 *MOD
  1240.              DO JAUX = 1,TAB.ID(NLS1)
  1241.                J1 = INDIC.NU(IGNS1,JAUX)
  1242.                DO IAUX2 = 2,ICON
  1243.                J2 = MELEME.NUM(IAUX2,NLCF)
  1244.                IF (J1.EQ.J2) THEN
  1245.                IAUX = IAUX2
  1246.                GOTO 5549
  1247.                ENDIF
  1248.                ENDDO
  1249.  5549          CONTINUE
  1250.  
  1251.              CX = MATR1.MAT2(IGNS1,JAUX)
  1252.  
  1253.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF)
  1254.      &      - ((1.D0-THETA)*UN*CX*0.5D0)
  1255.              ENDDO
  1256.             SEGDES INDIC *MOD
  1257.             SEGDES MATR1 *MOD
  1258.  
  1259.             INDIC = IPO3.POINT33(NLS2)
  1260.             SEGACT INDIC *MOD
  1261.             MATR1 = IPO2.POINT(NLS2)
  1262.             SEGACT MATR1 *MOD
  1263.              DO JAUX = 1,TAB.ID(NLS2)
  1264.                J1 = INDIC.NU(IGNS2,JAUX)
  1265.                DO IAUX2 = 2,ICON
  1266.                J2 = MELEME.NUM(IAUX2,NLCF)
  1267.                IF (J1.EQ.J2) THEN
  1268.                IAUX = IAUX2
  1269.                GOTO 5289
  1270.                ENDIF
  1271.                ENDDO
  1272.  5289          CONTINUE
  1273.  
  1274.              CX = MATR1.MAT2(IGNS2,JAUX)
  1275.  
  1276.             MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF)
  1277.      &      - ((1.D0-THETA)*UN*CX*0.5D0)
  1278.              ENDDO
  1279.             SEGDES INDIC *MOD
  1280.             SEGDES MATR1 *MOD
  1281. c            ENDIF
  1282. c            ENDIF
  1283.             ENDIF
  1284.  
  1285.  
  1286.             ENDIF
  1287.             ENDIF
  1288.  
  1289.  
  1290.  
  1291.  
  1292.  
  1293.  
  1294. c          DO IAUX2 = 2,ICON
  1295. c          J1 = MELEME.NUM(IAUX2,NLCF)
  1296. c          WRITE(6,*) 'NLCF= ',NLCF,'IAUX2= ',IAUX2
  1297. c          WRITE(6,*) 'MELEME6= ',J1
  1298. c          COEF1 = MELVA1.VELCHE(IAUX2,NLCF)
  1299. c          WRITE(6,*) 'COEF1= ',COEF1
  1300. c          ENDDO
  1301. c          WRITE(6,*) 'MPOGRA= ',MPOGRA.VPOCHA(NLCF,1)
  1302. c            IF (ICHTE.GT.0) THEN
  1303. c            IAUX = 3 - INDD1
  1304. c            XLONGD = (VECXD1(IAUX)*VECXD1(IAUX)) +
  1305. c     &               (VECYD1(IAUX)*VECYD1(IAUX))
  1306. c            XLONGD = XLONGD**0.5
  1307. c            IAUX = 3 - INDG1
  1308. c            XLONGG = (VECXG1(IAUX)*VECXG1(IAUX)) +
  1309. c     &               (VECYG1(IAUX)*VECYG1(IAUX))
  1310. c            XLONGG = XLONGG**0.5
  1311. c            ANCX = ((K11G/XLONGG)*VALG) + ((K11D/XLONGD)*VALD)
  1312. c            ANCX = ANCX/((K11G/XLONGG) + (K11D/XLONGD))
  1313. c            ANCX = (VALD - VALG) /
  1314. c     &       ( (XLONGG/K11G) + (XLONGD/K11D))
  1315. c            ANCX = (VALD - VALG) /
  1316. c     &       ( (XLONGG) + (XLONGD))
  1317. c             MPOGRA.VPOCHA(NLCF,1) = SCN1X*ANCX
  1318. c             MPOGRA.VPOCHA(NLCF,2) = SCN1Y*ANCX
  1319. c            ENDIF
  1320. c             IF (NGCG.NE.NGCD) THEN
  1321. c             AA  = MPOGRA.VPOCHA(NLCF,1) + AA
  1322. c             BB  = MPOGRA.VPOCHA(NLCF,2) +  BB
  1323. c             ENDIF
  1324.  
  1325.  
  1326.             IF (1.EQ.0) THEN
  1327.             WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1328.             WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  1329.             WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRGAUX
  1330.             WRITE(6,*) 'NLCF= ',NLCF,'TRG1= ',TRG1
  1331.             WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRG
  1332.             WRITE(6,*) 'NLCF= ',NLCF,'TRG2= ',TRG2
  1333.             WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL
  1334.             VALD = MPOCHP.VPOCHA(NLCD,1)
  1335.             WRITE(6,*) 'NLCF= ',NLCF,'VALD= ',VALD
  1336.             WRITE(6,*) 'NLCF= ',NLCF,'VECXG1= ',VECXG1(INDG1)
  1337.             IAUX = 3 - INDG1
  1338.             WRITE(6,*) 'NLCF= ',NLCF,'VECXG1= ',VECXG1(IAUX)
  1339.             WRITE(6,*) 'NLCF= ',NLCF,'VECYG1= ',VECYG1(INDG1)
  1340.             IAUX = 3 - INDG1
  1341.             WRITE(6,*) 'NLCF= ',NLCF,'VECYG1= ',VECYG1(IAUX)
  1342.             WRITE(6,*) 'NLCF= ',NLCF,'VECXG2= ',VECXG2(INDG2)
  1343.             IAUX = 3 - INDG2
  1344.             WRITE(6,*) 'NLCF= ',NLCF,'VECXG2= ',VECXG2(IAUX)
  1345.             WRITE(6,*) 'NLCF= ',NLCF,'VECYG2= ',VECYG2(INDG2)
  1346.             IAUX = 3 - INDG2
  1347.             WRITE(6,*) 'NLCF= ',NLCF,'VECYG2= ',VECYG2(IAUX)
  1348.             WRite(6,*) 'AG1=',AG1
  1349.             WRite(6,*) 'AG2=',AG2
  1350.             WRite(6,*) 'AD1=',AD1
  1351.             WRite(6,*) 'AD2=',AD2
  1352.             ENDIF
  1353. c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS2
  1354.             NAUX2 = MAX(NAUX2,ICON)
  1355.             NMOY = NMOY + ICON
  1356.  
  1357.           SEGDES INDIC *MOD
  1358.           SEGDES MATR1 *MOD
  1359.  
  1360.          ENDDO
  1361.          NMOY = NMOY/(NFAC*1.D0)
  1362.  
  1363. c         WRITE(6,*) 'NAUX2= ',NAUX2
  1364. c         WRITE(6,*) 'NMOY2= ',NMOY
  1365.       IF (NBSO.EQ.2) THEN
  1366.         SEGDES IPT1
  1367.         SEGDES IPT2
  1368.       ENDIF
  1369.  
  1370.  
  1371.          K7 = NFAC
  1372.          K8 = NAUX2
  1373.          SEGINI ITAB
  1374.  
  1375. c ON SUPPRIME LES ZEROS INTERIEURS
  1376.          IREP = 2
  1377.          DO NLCF = 1,NFAC
  1378.             IREP = 2
  1379.             NFIN = NAUX2
  1380. C ON CALCULE D4ABORD LE MAXIMUM DE LA LIGNE
  1381.             AUXMA = 0.0
  1382.             DO J=2,NFIN
  1383.             AUXRE = ABS(MELVA1.VELCHE(J,NLCF))
  1384.             AUXMA = MAX(AUXRE,AUXMA)
  1385.             ENDDO
  1386.             ITAB.XMAX(NLCF) = AUXMA
  1387.  
  1388.             DO  J=IREP, NFIN
  1389.             IF (ABS(MELVA1.VELCHE(J,NLCF)).Le.(1e-14*AUXMA)) THEN
  1390.  
  1391.  
  1392.                  DO K=1,NFIN-J
  1393.                  AUX = MELVA1.VELCHE(J+K,NLCF)
  1394. C ON DECALE DE K CRAN
  1395.                  IF (ABS(AUX).gt.(1e-14*AUXMA)) THEN
  1396.                   DO I=J,NFIN - K
  1397.                    MELVA1.VELCHE(I,NLCF) = MELVA1.VELCHE(I+K,NLCF)
  1398.                    MELEME.NUM(I,NLCF) = MELEME.NUM(I+K,NLCF)
  1399.                   ENDDO
  1400. C MISE A ZERO DES TERMES DU BOUT
  1401.                   DO I=NFIN-K+1,NFIN
  1402.                    MELVA1.VELCHE(I,NLCF) = 0.0
  1403.                   ENDDO
  1404.                  GOTO 2000
  1405.                  ENDIF
  1406.                  ENDDO
  1407. 2000        CONTINUE
  1408.             ENDIF
  1409.             ENDDO
  1410.          ENDDO
  1411.  
  1412. c TABLEAU CALCULANT LE NOMBRE DE VOISIN NON NUL POUR CHAQUE FACE
  1413.          NMOY = 0
  1414.          DO NLCF = 1,NFAC
  1415.            IREC = 3
  1416.            DO J=NAUX2,1,-1
  1417.            IF (ABS(MELVA1.VELCHE(J,NLCF)).gt.
  1418.      &        (1e-14*ITAB.XMAX(NLCF))) THEN
  1419.            IREC = J
  1420.            GOTO 1111
  1421.            ENDIF
  1422.            ENDDO
  1423. 1111     CONTINUE
  1424.            ITAB.TABL(NLCF) = IREC
  1425.            NMOY = NMOY + IREC
  1426.         ENDDO
  1427.          NMOY = NMOY/(NFAC*1.D0)
  1428. c         WRITE(6,*) 'NEWMOY2= ',NMOY
  1429. c         WRITE(6,*) 'NFAC= ',NFAC
  1430.  
  1431.  
  1432. C   TAB1(U) TABLEAU QUI CONTIENT LE NOMBRE DE FACE AYANT U VOISIN
  1433.           DO ICOUR = 1,NAUX2
  1434.           ITAB.TABL1(ICOUR) = 0
  1435.           ENDDO
  1436.  
  1437.           DO NLCF = 1,NFAC
  1438.           ICOUR =  ITAB.TABL(NLCF)
  1439.           ITAB.TABL1(ICOUR)=ITAB.TABL1(ICOUR) + 1
  1440.           ENDDO
  1441.  
  1442. C ON COMPTE LE NOMVRE DE SOUS DOMAINE
  1443.           NTSOUS = 0
  1444.           DO ICOUR = 1,NAUX2
  1445.           IF (ITAB.TABL1(ICOUR) .NE.0) NTSOUS = NTSOUS +1
  1446.           ENDDO
  1447. C IPOS INDICE DE LA PREMIERE FACE AYANT I VOISIN
  1448. C ICOUR INDICE COURANT INITIALISE A IPOS
  1449.  
  1450.  
  1451.           ITAB.IPOS(1) = 1
  1452.           DO I = 2,NAUX2
  1453.           ITAB.IPOS(I) = ITAB.IPOS(I-1) + ITAB.TABL1(I-1)
  1454.           ITAB.ICOURANT(I) = ITAB.IPOS(I)
  1455.           ENDDO
  1456.  
  1457.  
  1458. c TABL2 TABLEAU QUI RANGE DANS L4ODRES DES SOUS DOMAINES LES FACES NLCF
  1459.  
  1460.            DO I =1,NFAC
  1461.            IHELP = ITAB.TABL(I)
  1462.            IAUX = ITAB.ICOURANT(IHELP)
  1463.            ITAB.TABL2(IAUX) = I
  1464.            IAUX2 = ITAB.TABL(I)
  1465.            ITAB.ICOURANT(IAUX2) = ITAB.ICOURANT(IAUX2) + 1
  1466.            ENDDO
  1467.  
  1468.  
  1469. c          WRITE(6,*) 'NTSOUS= ',NTSOUS
  1470. C**** Initialisation du MCHELM
  1471. C
  1472.       N1=NTSOUS
  1473.       N2=1
  1474.       N3=6
  1475.       L1=8
  1476.       SEGINI MCHEL2
  1477.       MCHEL2.TITCHE='Gradient'
  1478.       MCHEL2.IFOCHE=IFOUR
  1479. C
  1480.       ISOUS=0
  1481.       NBSOUS=0
  1482.       NBREF=0
  1483.       DO I1 = 1, NAUX2, 1
  1484.          NBELEM=ITAB.TABL1(I1)
  1485.          IF(NBELEM .GT. 0)THEN
  1486.             ISOUS=ISOUS+1
  1487.             NBNN=I1
  1488.             SEGINI IPT8
  1489. C           ITYPEL=32 -> 'POLY'
  1490.             ITYPEL=32
  1491.             MCHEL2.IMACHE(ISOUS)=IPT8
  1492.             MCHEL2.CONCHE(ISOUS)='    '
  1493.             MCHEL2.INFCHE(ISOUS,6)=1
  1494.             SEGINI MCHAM2
  1495.             MCHEL2.ICHAML(ISOUS)=MCHAM2
  1496.             MCHAM2.NOMCHE(1)='SCAL'
  1497.             MCHAM2.TYPCHE(1)='REAL*8          '
  1498.             N1PTEL=NBNN
  1499.             N1EL=NBELEM
  1500.             N2PTEL=0
  1501.             N2EL=0
  1502.             SEGINI MELVA2
  1503.             MCHAM2.IELVAL(1)=MELVA2
  1504.  
  1505. C            WRITE(6,*) 'I1= ',I1
  1506. C           WRITE(6,*) 'NBELEM= ',NBELEM
  1507. C           WRITE(6,*) 'NBNN= ',NBNN
  1508.  
  1509.             DO I2=1,NBELEM,1
  1510.                DO I3=1,NBNN,1
  1511.                   IAUX = ITAB.IPOS(I1)
  1512.                   IP= ITAB.TABL2(I2 + IAUX - 1)
  1513. c                  IAUX = MELEME.NUM(I3,1)
  1514. c                  IAUX2 = MLEFA.LECT
  1515. c             WRITE(6,*) 'IP= ',IP,'I1= ',I1,'I2=',I2,'I3=',I3
  1516. c             WRITE(6,*) 'ISOUS= ',ISOUS,'MELEME= ',MELEME.NUM(I3,IP)
  1517.                   IPT8.NUM(I3,I2)= MELEME.NUM(I3,IP)
  1518.                   MELVA2.VELCHE(I3,I2)=MELVA1.VELCHE(I3,IP)
  1519.                ENDDO
  1520.             ENDDO
  1521. C
  1522.             SEGDES MCHAM2
  1523.             SEGDES IPT8
  1524.             SEGDES MELVA2
  1525.          ENDIF
  1526.       ENDDO
  1527.          SEGDES MCHEL2
  1528.          SEGDES ITAB
  1529.  
  1530.  
  1531.  
  1532.  
  1533.  
  1534.          SEGDES MCHAML
  1535.          SEGDES MELEME
  1536.          SEGDES MELVA1
  1537.          SEGDES MCHELM
  1538.  
  1539.          SEGSUP IPO3
  1540.          SEGSUP IPO2
  1541.          SEGSUP INDLI
  1542.          SEGSUP TAB
  1543.          SEGSUP IND2
  1544.          SEGSUP IND
  1545.          SEGSUP IND22
  1546.          SEGSUP VAL1
  1547.          SEGSUP VAL2
  1548.          SEGSUP SCMB
  1549.  
  1550.  
  1551.  
  1552.  9999 CONTINUE
  1553.       RETURN
  1554.       END
  1555.  
  1556.  
  1557.  
  1558.  
  1559.  
  1560.  
  1561.  
  1562.  
  1563.  
  1564.  
  1565.  
  1566.  
  1567.  
  1568.  

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