C SYM2D3 SOURCE OF166741 24/12/13 21:17:35 12097 SUBROUTINE SYM2D3(MELEFA,MELEFL,MLECEN,MELEFP,MLESOM,MPONOR, & MPOSUR,MELTFA,MLEFA,MLEFA2,MPOTEN,MPOCHP,MLENCL, & MLENNE,MLENMI,MPOVCL, & MPOVNE,MPOVMI,ICHTE,ICHCL,ICHNE,IPO2, & SCMB,INDLI, & TAB,VAL1,VAL2,IND22,IND2,IND,NBFAC,NBCOT, & NSOMM,NBMAX) C C************************************************************************ C C PROJET : CASTEM 2000 C C NOM : NORV2 C C DESCRIPTION : Appelle par NORV1 C C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec extensions CISI) C C AUTEUR : C. LE POTIER, DM2S/SFME/MTMS C C************************************************************************ C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (a-h,o-z) -INC SMLENTI -INC SMELEME -INC SMCHPOI -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMLREEL POINTEUR MELEFL.MELEME, MELEFP.MELEME, MELEFA.MELEME, & MELTFA.MELEME, MELEP2.MELEME POINTEUR MPOSUR.MPOVAL, MPONOR.MPOVAL, & MPOCHP.MPOVAL, MPOVCL.MPOVAL, MPGSOM.MPOVAL, MPVOSO.MPOVAL, & MPOGRA.MPOVAL,MPOTEN.MPOVAL,MPOVNE.MPOVAL,MPOVMI.MPOVAL POINTEUR MLENCL.MLENTI, MLECEN.MLENTI, MLESOM.MLENTI, & MLEFA.MLENTI,MLENNE.MLENTI,MLENMI.MLENTI,MLEFA2.MLENTI -INC SMCHAML INTEGER NBNN,NBREF C**** Variable de SMLENTI, SMCHPOI C INTEGER JG, N, NC, NSOUPO, NAT, NBSOUS, NBNO,NBELEM C C**** Les includes C INTEGER I1,ICOMP,ICOMGR,IGEOM & ,IOP1,ICEN,ISOMM,IFAC,IFACEL,IFACEP,INORM & ,ISURF,IMAIL,ICHPO,ICHCL,ICHGRA,ICOEFF & ,NTOT,NSOMM,NCOMP,NFAC,NCEN & ,NLCF,NGCF,NGCF1,NGCF2,NGCG,NGCD,NLCG,NLCD,NGS1,NGS2 & ,NLS1,NLS2,NLFCL & ,ISOUS,IELEM,INOEUD,ICELL INTEGER ICEN2 REAL*8 SCNX,SCNY,SCNZ,SURF,VOL,VAL,VALX,VALY,VALZ,XG,XD,XF,XS1,XS2 & ,YG,YD,YF,YS1,YS2,ZG,ZD,ZF,ZS1,ZS2, & PSCA,XNORM,VECX,VECY,VECZ,PSCAGX,PSCAGY,PSCAGZ, & PSCADX,PSCADY,PSCADZ,K11G,K22G,K21G,K31G,K32G,K33G, & K11D,K22D,K21D,K31D,K32D,K33D,VXG1,VXG2, & VXAU,VYAU,VZAU,VXD1,VXD2,VYG1,VYG2,VYD1,VYD2,VZG1, & VZG2,VZD1,VZD2,TRG1,TRG2, & TRD1,TRD2,TRG,TRD REAL*8 XLONG,AG1,AG2,AD1,AD2,PSCAG1,PSCAG2,PSCAD1,PSCAD2, & COEF1,COEF2,COEF3,COEF4,SCN1X,SCN1Y,SCN1Z,VX,VY,VZ, & COEF1X,COEF2X,COEF1Y,COEF2Y,COEF1Z,COEF2Z, & CX,CY,CZ,ANCX,ANCY,ANCZ,DIFFX,DIFFY,DIFFZ,XLONGG,XLONGD, & VALD,VALG,COEF,GX,GY,GZ,XMINK11,XMAXK11,XMINK22,XMAXK22, & QIMPX,QIMPY,QIMPZ,QIMPS,XLAMBDA1,XLAMBDA2 c REAL*8 VECXG1(3),VECYG1(3) c REAL*8 VECXG2(3),VECYG2(3) c REAL*8 VECXD1(3),VECYD1(3) c REAL*8 VECXD2(3),VECYD2(3) c REAL*8 EPS c INTEGER ICRIT c CHARACTER*(4) NOMCOM(18) c CHARACTER*8 TYPE REAL*8 VECXG(4,4),VECYG(4,4),VECZG(4,4) REAL*8 VECXD(4,4),VECYD(4,4),VECZD(4,4) REAL*8 VOLUG(4),SURFAGX(4),SURFAGY(4),SURFAGZ(4),COEFG(4,4) REAL*8 VOLUD(4),SURFADX(4),SURFADY(4),SURFADZ(4),COEFD(4,4) REAL*8 XARG(4,4),YARG(4,4),ZARG(4,4),XCOUR,YCOUR,ZCOUR REAL*8 XFACG(4,4),YFACG(4,4),ZFACG(4,4),XCO,YCO,ZCO REAL*8 XARD(4,4),YARD(4,4),ZARD(4,4) REAL*8 XFACD(4,4),YFACD(4,4),ZFACD(4,4) REAL*8 XA,YA,ZA,DIST1,DIST2 REAL*8 VAUX(3),VAUY(3),VAUZ(3) REAL*8 PVECX,PVECY,PVECZ INTEGER NGS(4),NLS(4),XS(4),YS(4),ZS(4) INTEGER NLOCFG(4,4),NLOCFD(4,4) REAL*8 EPS,ALPHA INTEGER ICRIT CHARACTER*(4) NOMCOM(18) CHARACTER*8 TYPE C DATA NOMCOM /'P1DX','P1DY', & 'P2DX','P2DY', & 'P3DX','P3DY', & 'P4DX','P4DY', & 'P5DX','P5DY', & 'P6DX','P6DY', & 'P7DX','P7DY', & 'P8DX','P8DY', & 'P9DX','P9DY'/ INTEGER NDIM SEGMENT MMAT1 REAL*8 PM(NDIM,NDIM),PM1(NDIM,NDIM),XSOL(NDIM) INTEGER IC(NDIM) ENDSEGMENT INTEGER K1,K2 SEGMENT INDICE INTEGER NUME(K1,K2) ENDSEGMENT POINTEUR IND.INDICE,IND2.INDICE,IND22.INDICE SEGMENT MATRICE REAL*8 MAT(K1,K2) ENDSEGMENT POINTEUR VAL1.MATRICE,VAL2.MATRICE,SCMB.MATRICE INTEGER K3 SEGMENT POINT2 INTEGER POINT(K3) ENDSEGMENT POINTEUR IPO2.POINT2 SEGMENT MATRICE2 REAL*8 MAT2(K1,K2) ENDSEGMENT POINTEUR MATR1.MATRICE2,MATR2.MATRICE2 SEGMENT REP INTEGER ID(K3) ENDSEGMENT POINTEUR TAB.REP,INDLI.REP INTEGER K5 SEGMENT NBFAC INTEGER NBFACEL(K5) INTEGER IMELEM(K5) ENDSEGMENT INTEGER K6 SEGMENT NBCOT INTEGER NBCOTE(K6) INTEGER IMECOTE(K6) ENDSEGMENT c CALCUL DES DIFFERENTS POINTEURS A ACTIVER DANS POUR PLUSIIEURS c SOUS DOMAINE ALPHA = 2.0/3.0 MAUX = MELTFA MAUX2 = MELEFP NMAI1 = 0 NMAI2 = 0 NMAI3 = 0 NMAI4 = 0 NBSO = MAX(1,MELTFA.LISOUS(/1)) c WRITE(6,*) 'NBSO MAILLE= ',NBSO c WRITE(6,*) 'MELTFA= ',MELTFA IELTFA = MELTFA IF (NBSO.EQ.1) THEN K5 = MELTFA.NUM(/2) ELSEIF (NBSO.EQ.2) THEN IPT1 = MELTFA.LISOUS(1) SEGACT IPT1 N1 = IPT1.NUM(/2) NMAI1 = N1 SEGDES IPT1 IPT2 = MELTFA.LISOUS(2) SEGACT IPT2 N2 = IPT2.NUM(/2) NMAI2 = N2 SEGDES IPT2 K5 = N1 + N2 ELSEIF (NBSO.EQ.3) THEN IPT1 = MELTFA.LISOUS(1) SEGACT IPT1 N1 = IPT1.NUM(/2) NMAI1 = N1 SEGDES IPT1 IPT2 = MELTFA.LISOUS(2) SEGACT IPT2 N2 = IPT2.NUM(/2) NMAI2 = N2 SEGDES IPT2 IPT3 = MELTFA.LISOUS(3) SEGACT IPT3 N3 = IPT3.NUM(/2) NMAI3 = N3 SEGDES IPT3 K5 = N1 + N2 + N3 ELSEIF (NBSO.EQ.4) THEN IPT1 = MELTFA.LISOUS(1) SEGACT IPT1 N1 = IPT1.NUM(/2) NMAI1 = N1 SEGDES IPT1 IPT2 = MELTFA.LISOUS(2) SEGACT IPT2 N2 = IPT2.NUM(/2) NMAI2 = N2 SEGDES IPT2 IPT3 = MELTFA.LISOUS(3) SEGACT IPT3 N3 = IPT3.NUM(/2) NMAI3 = N3 SEGDES IPT3 IPT4 = MELTFA.LISOUS(4) SEGACT IPT4 N4 = IPT4.NUM(/2) NMAI4 = N4 SEGDES IPT4 K5 = N1 + N2 + N3 + N4 ENDIF c WRITE(6,*) 'K5= ',K5 IF (NBSO.EQ.1) THEN DO I = 1,K5 NTYPE = MELTFA.ITYPEL c WRITE(6,*) 'NTYPE= ',NTYPE IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = MELTFA ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = MELTFA ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = MELTFA ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = MELTFA ENDIF c SEGDES MELTFA ENDDO ELSEIF (NBSO.EQ.2) THEN IPT1 = MELTFA.LISOUS(1) SEGACT IPT1 IPT2 = MELTFA.LISOUS(2) SEGACT IPT2 DO I = 1,K5 N1 = IPT1.NUM(/2) IF (I.LE.N1) THEN NTYPE = IPT1.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT1 ENDIF ELSE NTYPE = IPT2.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT2 ENDIF ENDIF ENDDO ELSEIF (NBSO.EQ.3) THEN IPT1 = MELTFA.LISOUS(1) SEGACT IPT1 NTYPE = IPT1.ITYPEL c WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL IPT2 = MELTFA.LISOUS(2) SEGACT IPT2 NTYPE = IPT2.ITYPEL c WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL IPT3 = MELTFA.LISOUS(3) SEGACT IPT3 NTYPE = IPT3.ITYPEL c WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL N1 = IPT1.NUM(/2) N2 = IPT2.NUM(/2) N3 = IPT3.NUM(/2) DO I = 1,K5 IF (I.LE.N1) THEN NTYPE = IPT1.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT1 ENDIF ELSEIF (I.LE.(N1+N2)) THEN NTYPE = IPT2.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT2 ENDIF ELSE NTYPE = IPT3.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT3 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT3 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT3 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT3 ENDIF ENDIF ENDDO ELSEIF (NBSO.EQ.4) THEN IPT1 = MELTFA.LISOUS(1) SEGACT IPT1 NTYPE = IPT1.ITYPEL c WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL IPT2 = MELTFA.LISOUS(2) SEGACT IPT2 NTYPE = IPT2.ITYPEL c WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL IPT3 = MELTFA.LISOUS(3) SEGACT IPT3 NTYPE = IPT3.ITYPEL WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL IPT4 = MELTFA.LISOUS(4) SEGACT IPT4 NTYPE = IPT4.ITYPEL WRITE(6,*) 'NTYPE= ',IPT4.ITYPEL N1 = IPT1.NUM(/2) N2 = IPT2.NUM(/2) N3 = IPT3.NUM(/2) N4 = IPT4.NUM(/2) DO I = 1,K5 IF (I.LE.N1) THEN NTYPE = IPT1.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT1 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT1 ENDIF ELSEIF (I.LE.(N1+N2)) THEN NTYPE = IPT2.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT2 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT2 ENDIF ELSEIF (I.LE.(N1+N2+N3)) THEN NTYPE = IPT3.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT3 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT3 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT3 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT3 ENDIF ELSE NTYPE = IPT4.ITYPEL IF (NTYPE .EQ. 16) THEN NBFACEL(I) = 6 IMELEM(I) = IPT4 ELSEIF (NTYPE .EQ. 25) THEN NBFACEL(I) = 5 IMELEM(I) = IPT4 ELSEIF (NTYPE .EQ. 23) THEN NBFACEL(I) = 4 IMELEM(I) = IPT4 ELSEIF (NTYPE .EQ. 9) THEN NBFACEL(I) = 5 IMELEM(I) = IPT4 ENDIF ENDIF ENDDO ENDIF C ON EST ICI CORRIGER K5 MLEFA2 = MLEFA CALL KRIPAD(MELEFA,MLEFA2) c CAS OU LES FACES SONT DES TRIANGLES OU DES FACES NFAI1 = 0 NBSOF = MAX(1,MELEFP.LISOUS(/1)) c WRITE(6,*) 'NBSO FACE= ',NBSOF IELTFA = MELTFA IF (NBSOF.EQ.1) THEN K6 = MELEFP.NUM(/2) ELSEIF (NBSOF.EQ.2) THEN IPT5 = MELEFP.LISOUS(1) SEGACT IPT5 N1 = IPT5.NUM(/2) NFAI1 = N1 SEGDES IPT5 IPT6 = MELEFP.LISOUS(2) SEGACT IPT6 N2 = IPT6.NUM(/2) NFAI2 = N2 SEGDES IPT6 K6 = N1 + N2 ENDIF c WRITE(6,*) 'K6= ',K6 SEGINI NBCOT c WRITE(6,*) 'POINT1' C ON EST ICI IF (NBSOF.EQ.1) THEN DO I = 1,K6 NTYPE = MELEFP.ITYPEL c WRITE(6,*) 'NTYPE= ',NTYPE IF (NTYPE .EQ. 5) THEN NBCOTE(I) = 3 IMECOTE(I) = MELEFP ELSE NBCOTE(I) = 4 IMECOTE(I) = MELEFP ENDIF c SEGDES MELTFA ENDDO ELSEIF (NBSOF.EQ.2) THEN c WRITE(6,*) 'POINT2' IPT5 = MELEFP.LISOUS(1) SEGACT IPT5 IPT6 = MELEFP.LISOUS(2) SEGACT IPT6 c WRITE(6,*) 'IPT5= ',IPT5.ITYPEL c WRITE(6,*) 'IPT6= ',IPT6.ITYPEL DO I = 1,K6 N1 = IPT5.NUM(/2) C MISE A JOUR DE MLEFA.LECT IF (I.LE.N1) THEN N0 = IPT5.NUM(/1) NGFAUX = IPT5.NUM(N0,I) MLEFA2.LECT(NGFAUX) = I c WRITE(6,*) 'NGFAUX = ',NGFAUX, c & 'MLEFA2=',MLEFA2.LECT(NGFAUX) IF (IPT5.ITYPEL .EQ. 5) THEN NBCOTE(I) = 3 IMECOTE(I) = IPT5 ELSE NBCOTE(I) = 4 IMECOTE(I) = IPT5 ENDIF c SEGDES IPT5 ELSE N0 = IPT6.NUM(/1) NGFAUX = IPT6.NUM(N0,I-NFAI1) MLEFA2.LECT(NGFAUX) = I c WRITE(6,*) 'NGFAUX = ',NGFAUX, c & 'MLEFA2=',MLEFA2.LECT(NGFAUX) IF (IPT6.ITYPEL .EQ. 5) THEN NBCOTE(I) = 3 IMECOTE(I) = IPT6 ELSE NBCOTE(I) = 4 IMECOTE(I) = IPT6 ENDIF c SEGDES IPT6 ENDIF c WRITE(6,*) 'I= ',I c WRITE(6,*) 'NBCOTE= ',NBCOTE(I) c WRITE(6,*) 'IMECOTE= ',IMECOTE(I) ENDDO ENDIF C IL FAUDRA EGALEMENT CREER DES POINTEUR POUR LES FACES DE CHAQUE ELEMENT C EXEMPLE LES PRISMES C SEGMENT SERVANT A UN PRECALCUL DE NBMAX c WRITE(6,*) 'NSOMM= ',NSOMM K3 = NSOMM SEGINI INDLI SEGINI TAB DO I = 1,K3 INDLI.ID(I) = 0 TAB.ID(I) = 0 ENDDO NFAC=MELEFL.NUM(/2) NBMAX = 0 C PRECALCUL DE NBMAX DO NLCF= 1, NFAC, 1 c WRITE(6,*) 'NLCF= ',NLCF NGCF=MELEFL.NUM(2,NLCF) NGCG=MELEFL.NUM(1,NLCF) NGCD=MELEFL.NUM(3,NLCF) NLCG=MLECEN.LECT(NGCG) NLCD=MLECEN.LECT(NGCD) c NFAUX = MELEFA.NUM(NLCF,1) c WRITE(6,*) 'NFAUX= ',NFAUX c c NGFAUX = MELEFA.NUM(NLCF,1) c WRITE(6,*) 'NGFAUX = ',NGFAUX, c & 'MLEFA2=',MLEFA2.LECT(NGFAUX) c NBNO = MELEFP.NUM(/1) - 1 NBNO = NBCOTE(NLCF) c WRITE(6,*) 'NLCF= ',NLCF c WRITE(6,*) 'NBNO= ',NBNO MELEFP = IMECOTE(NLCF) IF (NLCF.GT.NFAI1) THEN NLCFAUX = NLCF - NFAI1 ELSE NLCFAUX = NLCF ENDIF DO IA = 1,NBNO NGS1=MELEFP.NUM(IA,NLCFAUX) NLS1=MLESOM.LECT(NGS1) NLS1=MLESOM.LECT(NGS1) INDLI.ID(NLS1) = INDLI.ID(NLS1) + 1 NBMAX = MAX(NBMAX,INDLI.ID(NLS1)) ENDDO ENDDO SEGSUP INDLI SEGSUP TAB c NBMAX = 6 NBMAX = NBMAX +1 c WRITE(6,*) 'DANS NORV1 NBMAX= ',NBMAX c WRITE(6,*) 'NBSOM= ',NSOMM C ON CONNAIT NBMAX, ON PEUT INITIALISER LES SEGMENTS DE TRAVAIL c INITIALISATION DES MATRICES c NBMAX = 10 K3 = NSOMM SEGINI INDLI SEGINI TAB DO I = 1,K3 INDLI.ID(I) = 0 TAB.ID(I) = 0 ENDDO K1 = NBMAX K2 = NSOMM SEGINI IND2 SEGINI IND SEGINI IND22 SEGINI VAL1 SEGINI VAL2 SEGINI SCMB * K1 = NBMAX * K2 = (NBMAX+1) C INITIALISATION DU POINTEUR MATRICE2 K3 = NSOMM SEGINI IPO2 DO I = 1,K3 K1 = NBMAX K2 = NBMAX + 1 SEGINI MATR1 IPO2.POINT(I) = MATR1 SEGDES MATR1 ENDDO c DO I = 1,K3 c MATR1 = IPO2.POINT(I) c SEGACT MATR1 *MOD c MATR1.MAT2(1,1) = 4.D0 c MATR1.MAT2(2,2) = 3.D0 c WRITE(6,*) 'MATR1=', MATR1.MAT2(1,1) c WRITE(6,*) 'MATR1=', MATR1.MAT2(2,2) c SEGDES MATR1 c ENDDO NFAC=MELEFL.NUM(/2) c WRITE(6,*) 'NFAC= ',NFAC NAUX1 = 0 DO NLCF= 1, NFAC, 1 INDICE = 0 c ON TIENT COMPTE DU CHANGEMENT DE NUMEROTATION NGCF=MELEFL.NUM(2,NLCF) NGCG=MELEFL.NUM(1,NLCF) NGCD=MELEFL.NUM(3,NLCF) NLCG=MLECEN.LECT(NGCG) NLCD=MLECEN.LECT(NGCD) SCNX=MPONOR.VPOCHA(NLCF,1) SCNY=MPONOR.VPOCHA(NLCF,2) SCNZ=MPONOR.VPOCHA(NLCF,3) SCN1X = SCNX SCN1Y = SCNY SCN1Z = SCNZ C 4=IDIM+1 ICELL=(4*(NGCG -1))+1 XG=MCOORD.XCOOR(ICELL) YG=MCOORD.XCOOR(ICELL+1) ZG=MCOORD.XCOOR(ICELL+2) ICELL=(4*(NGCD -1))+1 XD=MCOORD.XCOOR(ICELL) YD=MCOORD.XCOOR(ICELL+1) ZD=MCOORD.XCOOR(ICELL+2) ICELL=(4*(NGCF -1))+1 XF=MCOORD.XCOOR(ICELL) YF=MCOORD.XCOOR(ICELL+1) ZF=MCOORD.XCOOR(ICELL+2) C MISE A ZERO DE NLOC DO JA=1,4 DO IA=1,3 NLOCFG(IA,JA) = 0 NLOCFD(IA,JA) = 0 ENDDO ENDDO MELTFA = IMELEM(NLCG) NBF = NBFACEL(NLCG) IF (NLCG.LE.NMAI1) THEN NGAUX = NLCG ELSEIF ((NLCG.GT.NMAI1).AND.(NLCG.LE.(NMAI1+NMAI2))) THEN NGAUX = NLCG - NMAI1 ELSEIF ((NLCG.GT.(NMAI1+NMAI2)).AND. & (NLCG.LE.(NMAI1+NMAI2+NMAI3))) THEN NGAUX = NLCG - (NMAI1+NMAI2) ELSEIF (NLCG.GT.(NMAI1+NMAI2+NMAI3)) THEN NGAUX = NLCG - (NMAI1+NMAI2+NMAI3) ENDIF c SEGACT MELTFA C ON REPERE LES VECTEURS PRINCIPAUX DE LA BASE NLCF1 = MLEFA2.LECT(NGCF) NBNO = NBCOTE(NLCF1) MELEFP = IMECOTE(NLCF1) IF (NLCF1.GT.NFAI1) THEN NLCF1AUX = NLCF1 - NFAI1 ELSE NLCF1AUX = NLCF1 ENDIF DO JA = 1,NBNO NGS(JA) = MELEFP.NUM(JA,NLCF1AUX) ICELL=(4*(NGS(JA) -1))+1 XA = MCOORD.XCOOR(ICELL) YA = MCOORD.XCOOR(ICELL+1) ZA = MCOORD.XCOOR(ICELL+2) c WRITE(6,*) 'NLCF= ',NLCF,'JA= ',JA, c & 'XA= ',XA,'YA= ',YA,'ZA= ',ZA C ON CALCULE P2 ET P3, VOIR RAPPORT PAGE 17 DIST2 = -100000000000. Con CALCULE LE PLUS GRAND DO I1 =1,NBNO NSOM1 = MELEFP.NUM(I1,NLCF1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) DIST1 = SQRT( DIST1) IF ((DIST1.GT.DIST2)) THEN DIST2 = DIST1 ICOURANT = I1 ENDIF ENDDO IF (JA.EQ.1) ICOURANT = 3 IF (JA.EQ.2) ICOURANT = 4 IF (JA.EQ.3) ICOURANT = 1 IF (JA.EQ.4) ICOURANT = 2 c SI LA FACE EST TRIANGULAIRE ICOURANT NE SERT A RIEN IF (NBNO.EQ.3) THEN ICOURANT = 0 ENDIF INDFAC=2 c WRITE(6,*) 'ICOURANT= ',ICOURANT c WRITE(6,*) 'JA= ',JA DO I1 =1,NBNO NSOM1 = MELEFP.NUM(I1,NLCF1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) IF ((I1.NE.ICOURANT).AND.(I1.NE.JA)) THEN XARG(INDFAC,JA) = 0.5D0*(XA+XCOUR) YARG(INDFAC,JA) = 0.5D0*(YA+YCOUR) ZARG(INDFAC,JA) = 0.5D0*(ZA+ZCOUR) c WRITE(6,*) 'X= ',XARG(INDFAC,JA), c & 'Y= ',YARG(INDFAC,JA),'Z= ',ZARG(INDFAC,JA) c WRITE(6,*) 'XA= ',XA, c & 'YA= ',YA,'ZA= ',ZA c WRITE(6,*) 'XCOUR= ',XCOUR, c & 'YCOUR= ',YCOUR,'ZCOUR= ',ZCOUR INDFAC= INDFAC+1 ENDIF ENDDO c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA c WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', c & ZARG(2,JA) c WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', c & ZARG(3,JA) c WRITE(6,*) 'D', 'X= ',XF,'Y= ',YF,'Z= ',ZF c IF (NLCF.EQ.14) then c WRITE(6,*) 'NGAUX= ',NGAUX,'JA= ',JA,'NGS= ',NGS(JA) c WRITE(6,*) 'NGCF= ',NGCF,'NLCF= ',NLCF c ENDIF ICOUR = 1 DO J = 1,NBF N1 = MELTFA.NUM(J,NGAUX) NL1 = MLEFA2.LECT(N1) NBNO2 = NBCOTE(NL1) MELEP2 = IMECOTE(NL1) IF (NL1.GT.NFAI1) THEN NL1AUX = NL1 - NFAI1 ELSE NL1AUX = NL1 ENDIF c IF (NLCF.EQ.14) then c WRITE(6,*) 'N1= ',N1,'NL1= ',NL1,'NL1AUX= ',NL1AUX c ENDIF DO IA =1,NBNO2 NSOM1 = MELEP2.NUM(IA,NL1AUX) c IF (NLCF.EQ.14) then c WRITE(6,*) 'NBNO2= ',NBNO2,'IA= ',IA,'NSOM1= ',NSOM1 c ENDIF IF (NSOM1.EQ.NGS(JA)) THEN ICELL=(4*(N1 -1))+1 XF=MCOORD.XCOOR(ICELL) YF=MCOORD.XCOOR(ICELL+1) ZF=MCOORD.XCOOR(ICELL+2) C ON CALCULE P1 VOIR RAPPORT p 17 IF (N1.NE.NGCF) THEN ICOUR = ICOUR + 1 VECXG(ICOUR,JA) = (XF - XG) VECYG(ICOUR,JA) = (YF - YG) VECZG(ICOUR,JA) = (ZF - ZG) NLOCFG(ICOUR,JA) = N1 XFACG(ICOUR,JA) = XF YFACG(ICOUR,JA) = YF ZFACG(ICOUR,JA) = ZF DIST2 = -1.e+15 DO I1 =1,NBNO2 NSOM1 = MELEP2.NUM(I1,NL1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) DIST1 = SQRT( DIST1) IF ((DIST1.GT.DIST2)) THEN DIST2 = DIST1 ICOURANT = I1 ENDIF ENDDO IF (IA.EQ.1) ICOURANT = 3 IF (IA.EQ.2) ICOURANT = 4 IF (IA.EQ.3) ICOURANT = 1 IF (IA.EQ.4) ICOURANT = 2 IF (NBNO2.EQ.3) THEN ICOURANT = 0 ENDIF NCON = 0 DO I1 =1,NBNO2 NSOM1 = MELEP2.NUM(I1,NL1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) XCO = 0.5D0*(XCOUR + XA) YCO = 0.5D0*(YCOUR + YA) ZCO = 0.5D0*(ZCOUR + ZA) DIST1 = ((XCO-XARG(2,JA))**2) + & ((YCO-YARG(2,JA))**2) + & ((ZCO-ZARG(2,JA))**2) DIST1 = SQRT(DIST1) IF (DIST1.LT.1e-5) THEN VAX = XARG(ICOUR,JA) VAY = YARG(ICOUR,JA) VAZ = ZARG(ICOUR,JA) C CHANGEMENT INDICE XARG(ICOUR,JA) = XCO YARG(ICOUR,JA) = YCO ZARG(ICOUR,JA) = ZCO XARG(2,JA) = VAX YARG(2,JA) = VAY ZARG(2,JA) = VAZ c WRITE(6,*) 'I1= ',I1,' ICI ON AFFECTE P1' ENDIF DIST2 = ((XCO-XARG(3,JA))**2) + & ((YCO-YARG(3,JA))**2) + & ((ZCO-ZARG(3,JA))**2) DIST2 = SQRT(DIST2) IF (DIST2.LT.1e-5) THEN VAX = XARG(ICOUR,JA) VAY = YARG(ICOUR,JA) VAZ = ZARG(ICOUR,JA) C CHANGEMENT INDICE XARG(ICOUR,JA) = XCO YARG(ICOUR,JA) = YCO ZARG(ICOUR,JA) = ZCO XARG(3,JA) = VAX YARG(3,JA) = VAY ZARG(3,JA) = VAZ c WRITE(6,*) 'I1= ',I1,' ICI ON AFFECTE P2' ENDIF INDFAC=1 c ON VERIFIE QUE LE POINT TROUVE EST BIEN DIFFERENT DE P2 ET P3 IF ((I1.NE.ICOURANT).AND.(I1.NE.IA).AND. & (DIST1.GT.1e-5).AND.(DIST2.GT.1e-5)) THEN XARG(INDFAC,JA) = XCO YARG(INDFAC,JA) = YCO ZARG(INDFAC,JA) = ZCO NCON = NCON + 1 c WRITE(6,*) 'JA = ',JA c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA c WRITE(6,*) 'P1', 'X= ',XARG(1,JA),'Y= ',YARG(1,JA),'Z= ', c & ZARG(1,JA) ENDIF ENDDO IF (NCON.NE.1) THEN WRITE(6,*) 'NLCF= ',NLCF,'NCON=',NCON WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', & ZARG(2,JA) WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', & ZARG(3,JA) DO I1 =1,NBNO2 NSOM1 = MELEP2.NUM(I1,NL1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) XCO = 0.5D0*(XCOUR + XA) YCO = 0.5D0*(YCOUR + YA) ZCO = 0.5D0*(ZCOUR + ZA) DIST1 = ((XCO-XARG(2,JA))**2) + & ((YCO-YARG(2,JA))**2) + & ((ZCO-ZARG(2,JA))**2) DIST1 = SQRT(DIST1) DIST2 = ((XCO-XARG(3,JA))**2) + & ((YCO-YARG(3,JA))**2) + & ((ZCO-ZARG(3,JA))**2) DIST2 = SQRT(DIST2) WRITE(6,*) 'TEST', 'XCO= ',XCO,'YCO ',YCO,'ZCO= ', & ZCO WRITE(6,*) 'DIST1= ',DIST1,'DIST2= ',DIST2 WRITE(6,*) 'I1= ',I1,'XCOUR= ',XCOUR, & 'YCOUR= ',YCOUR,'ZCOUR= ',ZCOUR ENDDO DIST2 = -100000000000. DO I1 =1,NBNO NSOM1 = MELEFP.NUM(I1,NLCF1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) WRITE(6,*) 'I1= ',I1,'XCOUR2= ',XCOUR, & 'YCOUR2= ',YCOUR,'ZCOUR2= ',ZCOUR DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) DIST1 = SQRT( DIST1) IF ((DIST1.GT.DIST2)) THEN DIST2 = DIST1 ICOURANT = I1 ENDIF ENDDO WRITE(6,*) 'ICOURANT= ',ICOURANT WRITE(6,*) 'JA= ',JA ENDIF ENDIF C ON PERMUTE C ICI IF (N1.EQ.NGCF) THEN VECXG(1,JA) = (XF - XG) VECYG(1,JA) = (YF - YG) VECZG(1,JA) = (ZF - ZG) XFACG(1,JA) = XF YFACG(1,JA) = YF ZFACG(1,JA) = ZF NLOCFG(1,JA) = N1 ENDIF ENDIF ENDDO ENDDO c IF (NLCF.EQ.14) THEN c WRITE(6,*) 'JA= ',JA c WRITE(6,*) 'ICOUR= ',ICOUR c ENDIF ENDDO MELTFA = IMELEM(NLCD) NBF = NBFACEL(NLCD) c WRITE(6,*) 'NLCD= ',NLCD c WRITE(6,*) 'NBF= ',NBF c WRITE(6,*) 'NTYPE= ',MELTFA.ITYPEL IF (NLCD.LE.NMAI1) THEN NDAUX = NLCD ELSEIF ((NLCD.GT.NMAI1).AND.(NLCD.LE.(NMAI1+NMAI2))) THEN NDAUX = NLCD - NMAI1 ELSEIF ((NLCD.GT.(NMAI1+NMAI2)).AND. & (NLCD.LE.(NMAI1+NMAI2+NMAI3))) THEN NDAUX = NLCD - (NMAI1+NMAI2) ELSEIF (NLCD.GT.(NMAI1+NMAI2+NMAI3)) THEN NDAUX = NLCD - (NMAI1+NMAI2+NMAI3) ENDIF C ON REPERE LES VECTEURS PRINCIPAUX DE LA BASE DO JA = 1,NBNO NGS(JA) = MELEFP.NUM(JA,NLCF1AUX) ICELL=(4*(NGS(JA) -1))+1 XA = MCOORD.XCOOR(ICELL) YA = MCOORD.XCOOR(ICELL+1) ZA = MCOORD.XCOOR(ICELL+2) C ON CALCULE P2 ET P3, VOIR RAPPORT PAGE 17 DIST2 = -1.e+15 Con CALCULE LE PLUS GRAND DO I1 =1,NBNO NSOM1 = MELEFP.NUM(I1,NLCF1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) DIST1 = SQRT( DIST1) IF ((DIST1.GT.DIST2)) THEN DIST2 = DIST1 ICOURANT = I1 ENDIF ENDDO IF (JA.EQ.1) ICOURANT = 3 IF (JA.EQ.2) ICOURANT = 4 IF (JA.EQ.3) ICOURANT = 1 IF (JA.EQ.4) ICOURANT = 2 IF (NBNO.EQ.3) THEN ICOURANT = 0 ENDIF INDFAC=2 DO I1 =1,NBNO NSOM1 = MELEFP.NUM(I1,NLCF1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) IF ((I1.NE.ICOURANT).AND.(I1.NE.JA)) THEN XARD(INDFAC,JA) = 0.5D0*(XA+XCOUR) YARD(INDFAC,JA) = 0.5D0*(YA+YCOUR) ZARD(INDFAC,JA) = 0.5D0*(ZA+ZCOUR) INDFAC= INDFAC+1 ENDIF ENDDO c WRITE(6,*) 'NDAUX= ',NDAUX,'JA= ',JA,'NGS= ',NGS(JA) c WRITE(6,*) 'NGCF= ',NGCF,'NLCF= ',NLCF ICOUR = 1 DO J = 1,NBF N1 = MELTFA.NUM(J,NDAUX) NL1 = MLEFA2.LECT(N1) c WRITE(6,*) 'N1= ',N1,'NL1= ',NL1 NBNO2 = NBCOTE(NL1) MELEP2 = IMECOTE(NL1) IF (NL1.GT.NFAI1) THEN NL1AUX = NL1 - NFAI1 ELSE NL1AUX = NL1 ENDIF DO IA =1,NBNO2 NSOM1 = MELEP2.NUM(IA,NL1AUX) c WRITE(6,*) 'NBNO2= ',NBNO2,'IA= ',IA,'NSOM1= ',NSOM1 IF (NSOM1.EQ.NGS(JA)) THEN ICELL=(4*(N1 -1))+1 XF=MCOORD.XCOOR(ICELL) YF=MCOORD.XCOOR(ICELL+1) ZF=MCOORD.XCOOR(ICELL+2) C ON CALCULE P1 VOIR RAPPORT p 17 IF (N1.NE.NGCF) THEN ICOUR = ICOUR + 1 VECXD(ICOUR,JA) = (XF - XD) VECYD(ICOUR,JA) = (YF - YD) VECZD(ICOUR,JA) = (ZF - ZD) NLOCFD(ICOUR,JA) = N1 XFACD(ICOUR,JA) = XF YFACD(ICOUR,JA) = YF ZFACD(ICOUR,JA) = ZF DIST2 = -1.e+15 DO I1 =1,NBNO2 NSOM1 = MELEP2.NUM(I1,NL1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) DIST1 = ((XCOUR-XA)**2) + ((YCOUR-YA)**2) + ((ZCOUR-ZA)**2) DIST1 = SQRT( DIST1) IF ((DIST1.GT.DIST2)) THEN DIST2 = DIST1 ICOURANT = I1 ENDIF ENDDO IF (IA.EQ.1) ICOURANT = 3 IF (IA.EQ.2) ICOURANT = 4 IF (IA.EQ.3) ICOURANT = 1 IF (IA.EQ.4) ICOURANT = 2 c BUG CORRIGE 15/06 IF (NBNO.EQ.3) THEN ICOURANT = 0 ENDIF INDFAC=3 DO I1 =1,NBNO2 NSOM1 = MELEP2.NUM(I1,NL1AUX) ICELL=(4*(NSOM1 -1))+1 XCOUR=MCOORD.XCOOR(ICELL) YCOUR=MCOORD.XCOOR(ICELL+1) ZCOUR=MCOORD.XCOOR(ICELL+2) XCO = 0.5D0*(XCOUR + XA) YCO = 0.5D0*(YCOUR + YA) ZCO = 0.5D0*(ZCOUR + ZA) DIST1 = ((XCO-XARD(2,JA))**2) + & ((YCO-YARD(2,JA))**2) + & ((ZCO-ZARD(2,JA))**2) DIST1 = SQRT( DIST1) IF (DIST1.LT.1e-5) THEN VAX = XARD(ICOUR,JA) VAY = YARD(ICOUR,JA) VAZ = ZARD(ICOUR,JA) C CHANGEMENT INDICE XARD(ICOUR,JA) = XCO YARD(ICOUR,JA) = YCO ZARD(ICOUR,JA) = ZCO XARD(2,JA) = VAX YARD(2,JA) = VAY ZARD(2,JA) = VAZ ENDIF DIST2 = ((XCO-XARD(3,JA))**2) + & ((YCO-YARD(3,JA))**2) + & ((ZCO-ZARD(3,JA))**2) DIST2 = SQRT( DIST2) IF (DIST2.LT.1e-5) THEN VAX = XARD(ICOUR,JA) VAY = YARD(ICOUR,JA) VAZ = ZARD(ICOUR,JA) C CHANGEMENT INDICE XARD(ICOUR,JA) = XCO YARD(ICOUR,JA) = YCO ZARD(ICOUR,JA) = ZCO XARD(3,JA) = VAX YARD(3,JA) = VAY ZARD(3,JA) = VAZ ENDIF INDFAC=1 c ON VERIFIE QUE LE POINT TROUVE EST BIEN DIFFERENT DE P2 ET P3 IF ((I1.NE.ICOURANT).AND.(I1.NE.IA).AND. & (DIST1.GT.1e-5).AND.(DIST2.GT.1e-5)) THEN c WRITE(6,*) 'ON AFFECTE INDICE 1 ARD' c WRITE(6,*) 'JA= ',JA XARD(INDFAC,JA) = XCO YARD(INDFAC,JA) = YCO ZARD(INDFAC,JA) = ZCO ENDIF ENDDO ENDIF C ON PERMUTE IF (N1.EQ.NGCF) THEN VECXD(1,JA) = (XF - XD) VECYD(1,JA) = (YF - YD) VECZD(1,JA) = (ZF - ZD) NLOCFD(1,JA) = N1 XFACD(1,JA) = XF YFACD(1,JA) = YF ZFACD(1,JA) = ZF ENDIF ENDIF ENDDO ENDDO c WRITE(6,*) 'JA= ',JA c WRITE(6,*) 'ICOUR= ',ICOUR ENDDO CALCUL DES VOLUMES c DO JA = 1,NBNO c DO KA=1,ICOUR c WRITE(6,*)'JA= ',JA,'KA= ',KA c WRITE(6,*) 'VECG = ',VECXG(KA,JA),VECYG(KA,JA),VECZG(KA,JA) c WRITE(6,*)'VECD = ',VECXD(KA,JA),VECYD(KA,JA),VECZD(KA,JA) c ENDDO c ENDDO DO JA = 1,NBNO c CALCUL DU VOLUME : ON SOMME LE VOLUME DES 6 TETRAEDRES ICELL=(4*(NGS(JA) -1))+1 XA = MCOORD.XCOOR(ICELL) YA = MCOORD.XCOOR(ICELL+1) ZA = MCOORD.XCOOR(ICELL+2) c WRITE(6,*) 'JA = ',JA c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA c WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', c & ZARG(2,JA) c WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', c & ZARG(3,JA) c WRITE(6,*) 'D', 'X= ',XFACG(1,JA),'Y= ',YFACG(1,JA),'Z= ', c & ZFACG(1,JA) c WRITE(6,*) 'B', 'X= ',XFACG(2,JA),'Y= ',YFACG(2,JA),'Z= ', c & ZFACG(2,JA) c WRITE(6,*) 'C', 'X= ',XFACG(3,JA),'Y= ',YFACG(3,JA),'Z= ', c & ZFACG(3,JA) c WRITE(6,*) 'P1', 'X= ',XARG(1,JA),'Y= ',YARG(1,JA),'Z= ', c & ZARG(1,JA) c WRITE(6,*) 'A', 'X= ',XD,'Y= ',YD,'Z= ',ZD VAUX(1) = XA - XARG(1,JA) VAUY(1) = YA - YARG(1,JA) VAUZ(1) = ZA - ZARG(1,JA) VAUX(2) = XA - XARG(2,JA) VAUY(2) = YA - YARG(2,JA) VAUZ(2) = ZA - ZARG(2,JA) VAUX(3) = XA - XARG(3,JA) VAUY(3) = YA - YARG(3,JA) VAUZ(3) = ZA - ZARG(3,JA) PVECX = VAUY(2)*VAUZ(3) - VAUZ(2)*VAUY(3) PVECY = VAUZ(2)*VAUX(3) - VAUX(2)*VAUZ(3) PVECZ = VAUX(2)*VAUY(3) - VAUY(2)*VAUX(3) VOL = & 1.D0/6.D0*ABS((VAUX(1)*PVECX) + (VAUY(1)*PVECY) + & (VAUZ(1)*PVECZ)) VOLUG(JA) = VOL DO KA = 1,ICOUR C COMPLETER ICI C PRODUIT MIXTES C PRODUIT VECTORIEL IF (KA.EQ.1) THEN VAUX(2) = XA - XARG(2,JA) VAUY(2) = YA - YARG(2,JA) VAUZ(2) = ZA - ZARG(2,JA) VAUX(3) = XA - XARG(3,JA) VAUY(3) = YA - YARG(3,JA) VAUZ(3) = ZA - ZARG(3,JA) c WRITE(6,*) 'ZA= ',ZA,'ZARG(3)= ',ZARG(3,JA), c & 'DIFF',ZA - ZARG(3,JA),'VAUXZ3',VAUZ(3) c WRITE(6,*) 'XA= ',XA,'YA= ',YA,'ZA= ',ZA c WRITE(6,*) 'P2', 'X= ',XARG(2,JA),'Y= ',YARG(2,JA),'Z= ', c & ZARG(2,JA) c WRITE(6,*) 'P3', 'X= ',XARG(3,JA),'Y= ',YARG(3,JA),'Z= ', c & ZARG(3,JA) c WRITE(6,*) 'D', 'X= ',XFACG(1,JA),'Y= ',YFACG(1,JA),'Z= ', c & ZFACG(1,JA) c WRITE(6,*) 'JA = ',JA,'KA=',KA,'VAUX2',VAUX(2), c & 'VAUY2',VAUY(2),'VAUZ2',VAUZ(2) c WRITE(6,*) 'ZA= ',ZA,'ZARG(3)= ',ZARG(3,JA), c & 'DIFF',ZA - ZARG(3,JA),'VAUXZ3',VAUZ(3) c WRITE(6,*) 'JA = ',JA,'KA=',KA,'VAUX3',VAUX(3), c & 'VAUY3',VAUY(3),'VAUZ3',VAUZ(3) PSCAGX = (VAUY(2)*VAUZ(3)) - & (VAUZ(2)*VAUY(3)) PSCAGY = (VAUZ(2)*VAUX(3)) - & (VAUX(2)*VAUZ(3)) PSCAGZ = (VAUX(2)*VAUY(3)) - & (VAUY(2)*VAUX(3)) PSCA = (VECXG(1,JA)* PSCAGX) + (VECYG(1,JA)* PSCAGY) + & (VECZG(1,JA)* PSCAGZ) IF (PSCA.LT.0) THEN PSCAGX = - PSCAGX PSCAGY = - PSCAGY PSCAGZ = - PSCAGZ ENDIF SURFAGX(KA) = 0.5D0* PSCAGX SURFAGY(KA) = 0.5D0* PSCAGY SURFAGZ(KA) = 0.5D0* PSCAGZ c WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1) ENDIF IF (KA.EQ.2) THEN VAUX(2) = XA - XARG(2,JA) VAUY(2) = YA - YARG(2,JA) VAUZ(2) = ZA - ZARG(2,JA) VAUX(3) = XA - XARG(1,JA) VAUY(3) = YA - YARG(1,JA) VAUZ(3) = ZA - ZARG(1,JA) PSCAGX = (VAUY(2)*VAUZ(3)) - & (VAUZ(2)*VAUY(3)) PSCAGY = (VAUZ(2)*VAUX(3)) - & (VAUX(2)*VAUZ(3)) PSCAGZ = (VAUX(2)*VAUY(3)) - & (VAUY(2)*VAUX(3)) PSCA = (VECXG(2,JA)* PSCAGX) + (VECYG(2,JA)* PSCAGY) + & (VECZG(2,JA)* PSCAGZ) IF (PSCA.LT.0) THEN PSCAGX = - PSCAGX PSCAGY = - PSCAGY PSCAGZ = - PSCAGZ ENDIF SURFAGX(KA) = 0.5D0* PSCAGX SURFAGY(KA) = 0.5D0* PSCAGY SURFAGZ(KA) = 0.5D0* PSCAGZ ENDIF IF (KA.EQ.3) THEN VAUX(2) = XA - XARG(3,JA) VAUY(2) = YA - YARG(3,JA) VAUZ(2) = ZA - ZARG(3,JA) VAUX(3) = XA - XARG(1,JA) VAUY(3) = YA - YARG(1,JA) VAUZ(3) = ZA - ZARG(1,JA) PSCAGX = (VAUY(2)*VAUZ(3)) - & (VAUZ(2)*VAUY(3)) PSCAGY = (VAUZ(2)*VAUX(3)) - & (VAUX(2)*VAUZ(3)) PSCAGZ = (VAUX(2)*VAUY(3)) - & (VAUY(2)*VAUX(3)) PSCA = (VECXG(3,JA)* PSCAGX) + (VECYG(3,JA)* PSCAGY) + & (VECZG(3,JA)* PSCAGZ) IF (PSCA.LT.0) THEN PSCAGX = - PSCAGX PSCAGY = - PSCAGY PSCAGZ = - PSCAGZ ENDIF SURFAGX(KA) = 0.5D0* PSCAGX SURFAGY(KA) = 0.5D0* PSCAGY SURFAGZ(KA) = 0.5D0* PSCAGZ ENDIF c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS1 IF (ICHTE.EQ.0) THEN COEFG(KA,JA) = ( (SURFAGX(KA)*SCN1X) + (SURFAGY(KA)*SCN1Y) + & (SURFAGZ(KA)*SCN1Z)) & / (VOLUG(JA)) ELSE C TENSEUR IF (MPOTEN.VPOCHA(/2) .EQ.6) THEN K11G = MPOTEN.VPOCHA(NLCG,1) K22G = MPOTEN.VPOCHA(NLCG,2) K33G = MPOTEN.VPOCHA(NLCG,3) K21G = MPOTEN.VPOCHA(NLCG,4) K31G = MPOTEN.VPOCHA(NLCG,5) K32G = MPOTEN.VPOCHA(NLCG,6) ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN K11G = MPOTEN.VPOCHA(NLCG,1) K22G = K11G K33G = K11G K21G = 0.0D0 K31G = 0.0D0 K32G = 0.0D0 ELSE WRITE(6,*) 'TENSEUR NON PREVU' STOP ENDIF PSCAGX = (K11G*SURFAGX(KA)) + (K21G*SURFAGY(KA)) + & (K31G*SURFAGZ(KA)) PSCAGY = (K21G*SURFAGX(KA)) + (K22G*SURFAGY(KA)) + & (K32G*SURFAGZ(KA)) PSCAGZ = (K31G*SURFAGX(KA)) + (K32G*SURFAGY(KA)) + & (K33G*SURFAGZ(KA)) COEFG(KA,JA) = (PSCAGX*SCN1X) + (PSCAGY*SCN1Y) + & (PSCAGZ*SCN1Z) COEFG(KA,JA) = COEFG(KA,JA) / (VOLUG(JA)) ENDIF c WRITE(6,*)'JA = ',JA, 'KA= ',KA,'VOLUG(JA) = ',VOLUG(JA) c WRITE(6,*)'SURFAG = ',SURFAGX(KA),SURFAGY(KA),SURFAGZ(KA) c WRITE(6,*)'VEXG = ',VECXG(KA,JA),VECYG(KA,JA),VECZG(KA,JA) c WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z ENDDO c WRITE(6,*) 'JA = ',JA,'VOLUG(JA) = ',VOLUG(JA) c WRITE(6,*) 'VECG1 = ',VECXG(1,JA),VECYG(1,JA),VECZG(1,JA) c WRITE(6,*) 'VECG2 = ',VECXG(2,JA),VECYG(2,JA),VECZG(2,JA) c WRITE(6,*) 'VECG3 = ',VECXG(3,JA),VECYG(3,JA),VECZG(3,JA) c WRITE(6,*)'NLCF= ',NLCF,'COEFG = ', c & COEFG(1,JA),COEFG(2,JA),COEFG(3,JA) c WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z c WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1) c WRITE(6,*)'SURFAG = ',SURFAGX(2),SURFAGY(2),SURFAGZ(2) c WRITE(6,*)'SURFAG = ',SURFAGX(3),SURFAGY(3),SURFAGZ(3) c WRITE(6,*) 'JA = ',JA,'VOLUG(JA) = ',VOLUG(JA) c WRITE(6,*) 'VECG1 = ',VECXG(1,JA),VECYG(1,JA),VECZG(1,JA) c WRITE(6,*) 'VECG2 = ',VECXG(2,JA),VECYG(2,JA),VECZG(2,JA) c WRITE(6,*) 'VECG3 = ',VECXG(3,JA),VECYG(3,JA),VECZG(3,JA) c WRITE(6,*)'NLCF= ',NLCF,'COEFG = ', c & COEFG(1,JA),COEFG(2,JA),COEFG(3,JA) c WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z c WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1) c WRITE(6,*)'SURFAG = ',SURFAGX(2),SURFAGY(2),SURFAGZ(2) c WRITE(6,*)'SURFAG = ',SURFAGX(3),SURFAGY(3),SURFAGZ(3) ENDDO CALCUL DES VOLUMES DO JA = 1,NBNO NGS(JA) = MELEFP.NUM(JA,NLCF1AUX) NLS(JA)=MLESOM.LECT(NGS(JA)) ICELL=(4*(NGS(JA) -1))+1 XA = MCOORD.XCOOR(ICELL) YA = MCOORD.XCOOR(ICELL+1) ZA = MCOORD.XCOOR(ICELL+2) VAUX(1) = XA - XARD(1,JA) VAUY(1) = YA - YARD(1,JA) VAUZ(1) = ZA - ZARD(1,JA) VAUX(2) = XA - XARD(2,JA) VAUY(2) = YA - YARD(2,JA) VAUZ(2) = ZA - ZARD(2,JA) VAUX(3) = XA - XARD(3,JA) VAUY(3) = YA - YARD(3,JA) VAUZ(3) = ZA - ZARD(3,JA) PVECX = VAUY(2)*VAUZ(3) - VAUZ(2)*VAUY(3) PVECY = VAUZ(2)*VAUX(3) - VAUX(2)*VAUZ(3) PVECZ = VAUX(2)*VAUY(3) - VAUY(2)*VAUX(3) VOL = & 1.D0/6.D0*ABS((VAUX(1)*PVECX) + (VAUY(1)*PVECY) + & (VAUZ(1)*PVECZ)) c WRITE(6,*) 'XA= ',XA,'XARD(1)= ',XARD(1,JA) c WRITE(6,*) 'YA= ',YA,'YARD(1)= ',YARD(1,JA) c WRITE(6,*) 'ZA= ',ZA,'ZARD(1)= ',ZARD(1,JA) c WRITE(6,*) 'XA= ',XA,'XARD(2)= ',XARD(2,JA) c WRITE(6,*) 'YA= ',YA,'YARD(2)= ',YARD(2,JA) c WRITE(6,*) 'ZA= ',ZA,'ZARD(2)= ',ZARD(2,JA) c WRITE(6,*) 'XA= ',XA,'XARD(3)= ',XARD(3,JA) c WRITE(6,*) 'YA= ',YA,'YARD(3)= ',YARD(3,JA) c WRITE(6,*) 'ZA= ',ZA,'ZARD(3)= ',ZARD(3,JA) c WRITE(6,*) 'VAUX(1)= ',VAUX(1) c WRITE(6,*) 'VAUY(1)= ',VAUY(1) c WRITE(6,*) 'VAUZ(1)= ',VAUZ(1) c WRITE(6,*) 'VAUX(2)= ',VAUX(2) c WRITE(6,*) 'VAUY(2)= ',VAUY(2) c WRITE(6,*) 'VAUZ(2)= ',VAUZ(2) c WRITE(6,*) 'VAUX(3)= ',VAUX(3) c WRITE(6,*) 'VAUY(3)= ',VAUY(3) c WRITE(6,*) 'VAUZ(3)= ',VAUZ(3) c CALCUL DU PREMIER VOLUME VOLUD(JA) = VOL DO KA = 1,ICOUR C COMPLETER ICI C PRODUIT MIXTES C PRODUIT VECTORIEL IF (KA.EQ.1) THEN VAUX(2) = XA - XARD(2,JA) VAUY(2) = YA - YARD(2,JA) VAUZ(2) = ZA - ZARD(2,JA) VAUX(3) = XA - XARD(3,JA) VAUY(3) = YA - YARD(3,JA) VAUZ(3) = ZA - ZARD(3,JA) PSCADX = (VAUY(2)*VAUZ(3)) - & (VAUZ(2)*VAUY(3)) PSCADY = (VAUZ(2)*VAUX(3)) - & (VAUX(2)*VAUZ(3)) PSCADZ = (VAUX(2)*VAUY(3)) - & (VAUY(2)*VAUX(3)) PSCA = (VECXD(1,JA)* PSCADX) + (VECYD(1,JA)* PSCADY) + & (VECZD(1,JA)* PSCADZ) IF (PSCA.LT.0) THEN PSCADX = - PSCADX PSCADY = - PSCADY PSCADZ = - PSCADZ ENDIF SURFADX(KA) = 0.5D0* PSCADX SURFADY(KA) = 0.5D0* PSCADY SURFADZ(KA) = 0.5D0* PSCADZ ENDIF IF (KA.EQ.2) THEN VAUX(2) = XA - XARD(2,JA) VAUY(2) = YA - YARD(2,JA) VAUZ(2) = ZA - ZARD(2,JA) VAUX(3) = XA - XARD(1,JA) VAUY(3) = YA - YARD(1,JA) VAUZ(3) = ZA - ZARD(1,JA) PSCADX = (VAUY(2)*VAUZ(3)) - & (VAUZ(2)*VAUY(3)) PSCADY = (VAUZ(2)*VAUX(3)) - & (VAUX(2)*VAUZ(3)) PSCADZ = (VAUX(2)*VAUY(3)) - & (VAUY(2)*VAUX(3)) PSCA = (VECXD(2,JA)* PSCADX) + (VECYD(2,JA)* PSCADY) + & (VECZD(2,JA)* PSCADZ) IF (PSCA.LT.0) THEN PSCADX = - PSCADX PSCADY = - PSCADY PSCADZ = - PSCADZ ENDIF SURFADX(KA) = 0.5D0* PSCADX SURFADY(KA) = 0.5D0* PSCADY SURFADZ(KA) = 0.5D0* PSCADZ ENDIF IF (KA.EQ.3) THEN VAUX(2) = XA - XARD(3,JA) VAUY(2) = YA - YARD(3,JA) VAUZ(2) = ZA - ZARD(3,JA) VAUX(3) = XA - XARD(1,JA) VAUY(3) = YA - YARD(1,JA) VAUZ(3) = ZA - ZARD(1,JA) PSCADX = (VAUY(2)*VAUZ(3)) - & (VAUZ(2)*VAUY(3)) PSCADY = (VAUZ(2)*VAUX(3)) - & (VAUX(2)*VAUZ(3)) PSCADZ = (VAUX(2)*VAUY(3)) - & (VAUY(2)*VAUX(3)) PSCA = (VECXD(3,JA)* PSCADX) + (VECYD(3,JA)* PSCADY) + & (VECZD(3,JA)* PSCADZ) IF (PSCA.LT.0) THEN PSCADX = - PSCADX PSCADY = - PSCADY PSCADZ = - PSCADZ ENDIF SURFADX(KA) = 0.5D0* PSCADX SURFADY(KA) = 0.5D0* PSCADY SURFADZ(KA) = 0.5D0* PSCADZ ENDIF c WRITE(6,*) 'NLCF=',NLCF c WRITE(6,*) 'NLCD=',NLCD c WRITE(6,*) 'NLCD=',NLCG c WRite(6,*) 'AG1=',AG1 c WRite(6,*) 'AG2=',AG2 c WRite(6,*) 'AD1=',AD1 c WRite(6,*) 'AD2=',AD2 c WRite(6,*) 'PSCAG1=',PSCAG1 c WRite(6,*) 'PSCAG2=',PSCAG2 c WRite(6,*) 'PSCAD1=',PSCAD1 c WRite(6,*) 'PSCAD2=',PSCAD2 c WRite(6,*) 'COEF1D=',COEF1D c WRite(6,*) 'COEF2D=',COEF2D c WRite(6,*) 'BETA1GD=',BETA1GD c WRite(6,*) 'BETA2GD=',BETA2GD c WRite(6,*) 'INDD2=',INDD2 c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS1 IF (ICHTE.EQ.0) THEN COEFD(KA,JA) = ( (SURFADX(KA)*SCN1X) + (SURFADY(KA)*SCN1Y) + & (SURFADZ(KA)*SCN1Z)) & / (VOLUD(JA)) ELSE C TENSEUR IF (MPOTEN.VPOCHA(/2) .EQ.6) THEN K11D = MPOTEN.VPOCHA(NLCD,1) K22D = MPOTEN.VPOCHA(NLCD,2) K33D = MPOTEN.VPOCHA(NLCD,3) K21D = MPOTEN.VPOCHA(NLCD,4) K31D = MPOTEN.VPOCHA(NLCD,5) K32D = MPOTEN.VPOCHA(NLCD,6) ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN K11D = MPOTEN.VPOCHA(NLCD,1) K22D = K11D K33D = K11D K21D = 0.0D0 K31D = 0.0D0 K32D = 0.0D0 ELSE WRITE(6,*) 'TENSEUR NON PREVU' STOP ENDIF PSCADX = (K11D*SURFADX(KA)) + (K21D*SURFADY(KA)) + & (K31D*SURFADZ(KA)) PSCADY = (K21D*SURFADX(KA)) + (K22D*SURFADY(KA)) + & (K32D*SURFADZ(KA)) PSCADZ = (K31D*SURFADX(KA)) + (K32D*SURFADY(KA)) + & (K33D*SURFADZ(KA)) COEFD(KA,JA) = (PSCADX*SCN1X) + (PSCADY*SCN1Y) & + (PSCADZ*SCN1Z) COEFD(KA,JA) = COEFD(KA,JA) / (VOLUD(JA)) ENDIF c WRITE(6,*) 'JA = ',JA,'KA= ',KA,'VOLUD(JA) = ',VOLUD(JA) c WRITE(6,*)'SURFAD = ',SURFADX(KA),SURFADY(KA),SURFADZ(KA) c WRITE(6,*)'VECD = ',VECXD(KA,JA),VECYD(KA,JA),VECZD(KA,JA) ENDDO c WRITE(6,*) 'JA = ',JA,'VOLUD(JA) = ',VOLUD(JA) c WRITE(6,*)'VECD1 = ',VECXD(1,JA),VECYD(1,JA),VECZD(1,JA) c WRITE(6,*)'VECD3 = ',VECXD(2,JA),VECYD(2,JA),VECZD(2,JA) c WRITE(6,*)'VECD3 = ',VECXD(3,JA),VECYD(3,JA),VECZD(3,JA) c WRITE(6,*)'NLCF= ',NLCF,'COEFD = ', c & COEFD(1,JA),COEFD(2,JA),COEFD(3,JA) c WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z c WRITE(6,*)'SURFAD = ',SURFADX(1),SURFADY(1),SURFADZ(1) c WRITE(6,*)'SURFAD = ',SURFADX(2),SURFADY(2),SURFADZ(2) c WRITE(6,*)'SURFAD = ',SURFADX(3),SURFADY(3),SURFADZ(3) ENDDO CALCUL DES VOLUMES c WRITE(6,*) 'NLCF= ',NLCF c WRITE(6,*) 'NGCF= ',NGCF c WRITE(6,*) 'KG=', K11G,K22G,K33G,K21G,K31G,K32G c WRITE(6,*) 'KD=', K11D,K22D,K33D,K21D,K31D,K32D DO JA = 1,NBNO XX1 = ABS(COEFG(1,JA)) XX2 = ABS(COEFD(1,JA)) IF ((XX1.LT.1e-8) .OR.(XX2.LT.1E-8)) THEN INDICE = 1 ENDIF MARQ = 0 DO I5 = 1,INDLI.ID(NLS(JA)) INDAUX = IND2.NUME(I5,NLS(JA)) IF (INDAUX.EQ.NGCF) THEN MARQ = 1 IAFF = I5 GOTO 4 ENDIF ENDDO 4 CONTINUE IF (MARQ.EQ.0) THEN INDLI.ID(NLS(JA)) = INDLI.ID(NLS(JA)) + 1 ICOU = INDLI.ID(NLS(JA)) IND2.NUME(ICOU,NLS(JA)) = NGCF ELSE ICOU = IAFF ENDIF COEF = COEFG(1,JA)-COEFD(1,JA) MATR1 = IPO2.POINT(NLS(JA)) c SEGINI MATR1 SEGACT MATR1 *MOD MATR1.MAT2(ICOU,ICOU) = COEF MARQ = 0 DO I5 = 1,INDLI.ID(NLS(JA)) INDAUX = IND2.NUME(I5,NLS(JA)) IF (INDAUX.EQ.NLOCFG(2,JA)) THEN MARQ = 1 IAFF = I5 GOTO 5 ENDIF ENDDO 5 CONTINUE IF (MARQ.EQ.0) THEN INDLI.ID(NLS(JA)) = INDLI.ID(NLS(JA)) + 1 ICOUCO = INDLI.ID(NLS(JA)) IND2.NUME(ICOUCO,NLS(JA)) = NLOCFG(2,JA) ELSE ICOUCO = IAFF ENDIF ICOUG2 = ICOUCO MATR1.MAT2(ICOU,ICOUCO) = COEFG(2,JA) MARQ = 0 DO I5 = 1,INDLI.ID(NLS(JA)) INDAUX = IND2.NUME(I5,NLS(JA)) IF (INDAUX.EQ.NLOCFG(3,JA)) THEN MARQ = 1 IAFF = I5 GOTO 6 ENDIF ENDDO 6 CONTINUE IF (MARQ.EQ.0) THEN INDLI.ID(NLS(JA)) = INDLI.ID(NLS(JA)) + 1 ICOUCO = INDLI.ID(NLS(JA)) IND2.NUME(ICOUCO,NLS(JA)) = NLOCFG(3,JA) ELSE ICOUCO = IAFF ENDIF ICOUG3 = ICOUCO MATR1.MAT2(ICOU,ICOUCO) = COEFG(3,JA) MARQ = 0 DO I5 = 1,INDLI.ID(NLS(JA)) INDAUX = IND2.NUME(I5,NLS(JA)) IF (INDAUX.EQ.NLOCFD(2,JA)) THEN MARQ = 1 IAFF = I5 GOTO 59 ENDIF ENDDO 59 CONTINUE IF (MARQ.EQ.0) THEN INDLI.ID(NLS(JA)) = INDLI.ID(NLS(JA)) + 1 ICOUCO = INDLI.ID(NLS(JA)) IND2.NUME(ICOUCO,NLS(JA)) = NLOCFD(2,JA) ELSE ICOUCO = IAFF ENDIF ICOUD2 = ICOUCO MATR1.MAT2(ICOU,ICOUCO) = - COEFD(2,JA) MARQ = 0 DO I5 = 1,INDLI.ID(NLS(JA)) INDAUX = IND2.NUME(I5,NLS(JA)) IF (INDAUX.EQ.NLOCFD(3,JA)) THEN MARQ = 1 IAFF = I5 GOTO 69 ENDIF ENDDO 69 CONTINUE IF (MARQ.EQ.0) THEN INDLI.ID(NLS(JA)) = INDLI.ID(NLS(JA)) + 1 ICOUCO = INDLI.ID(NLS(JA)) IND2.NUME(ICOUCO,NLS(JA)) = NLOCFD(3,JA) ELSE ICOUCO = IAFF ENDIF ICOUD3 = ICOUCO MATR1.MAT2(ICOU,ICOUCO) = - COEFD(3,JA) c ON EST ICI SCMB.MAT(ICOU,NLS(JA)) = & ((COEFG(1,JA)+COEFG(2,JA)+COEFG(3,JA)) & *ALPHA*MPOCHP.VPOCHA(NLCG,1)) - & ((COEFD(1,JA)+COEFD(2,JA)+COEFD(3,JA))* & ALPHA*MPOCHP.VPOCHA(NLCD,1)) c SCMB.MAT(ICOU,NLS(JA)) = COEF* SCMB.MAT(ICOU,NLS(JA)) c NLS1 = NLS(JA) c WRITE(6,*) 'NLS1= ',NLS1,'ICOU=',ICOU, c & 'SCMB', SCMB.MAT(ICOU,NLS1), c & 'ICOU =',ICOU,'NOUED2= ',MATR1.MAT2(ICOU,ICOU),'COEF= ',COEF, c & 'ICOUG2= ',ICOUG2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG2), c & 'ICOUG3= ',ICOUG3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG3), c & 'ICOUD2= ',ICOUD2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD2), c & 'ICOUD3= ',ICOUD3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD3) * ON EST ICI * IL FAUT VERIFIER CE QUI EST AVANT * COEF POUR INVERSER LA MATRICE * ON CORRIGE ICI VAL1.MAT(ICOU,NLS(JA)) = & ALPHA*(COEFG(1,JA) + COEFG(2,JA) + COEFG(3,JA)) c VAL1.MAT(ICOU,NLS(JA)) = COEF*VAL1.MAT(ICOU,NLS(JA)) VAL2.MAT(ICOU,NLS(JA)) = & - (ALPHA*(COEFD(1,JA) + COEFD(2,JA) + COEFD(3,JA))) c VAL2.MAT(ICOU,NLS(JA)) = COEF*VAL2.MAT(ICOU,NLS(JA)) IND.NUME(ICOU,NLS(JA)) = NGCG IND22.NUME(ICOU,NLS(JA)) = NGCD * CONDITION AUX LIMITE DE DIRICICHLET IF (NGCG.EQ.NGCD) THEN NLFCL=MLENCL.LECT(NGCF) IF (NLFCL.GT.0) THEN c WRITE(6,*) 'NLCF= ',NLCF c WRITE(6,*) 'NGCF= ',NGCF c WRITE(6,*) 'VAL=',MPOVCL.VPOCHA(NLFCL,1) COEF = MAX(ABS(COEFG(1,JA)),ABS(COEFG(2,JA))) COEF = MAX(COEF,ABS(COEFG(3,JA))) MATR1.MAT2(ICOU,ICOU) = COEF MATR1.MAT2(ICOU,ICOUG2) = 0.0D0 MATR1.MAT2(ICOU,ICOUG3) = 0.0D0 MATR1.MAT2(ICOU,ICOUD2) = 0.0D0 MATR1.MAT2(ICOU,ICOUD3) = 0.0D0 c ICI SCMB.MAT(ICOU,NLS(JA)) = (COEF*ALPHA*MPOVCL.VPOCHA(NLFCL,1)) VAL1.MAT(ICOU,NLS(JA)) = 0.D0 VAL2.MAT(ICOU,NLS(JA)) = ALPHA*COEF c ON AJOUTE ICI UN POINT FACE POUR COMPATIBILITE AVEC LAPN IND.NUME(ICOU,NLS(JA)) = NGCG IND22.NUME(ICOU,NLS(JA)) = NGCF ELSE NLFNE=MLENNE.LECT(NGCF) c CONDITION DE FLUX IF (NLFNE.GT.0) THEN QIMPX = MPOVNE.VPOCHA(NLFNE,1) C PRODUIT SCALAIRE DU FLUX IMPOSE AVEC LA NORMALE QIMPS = (QIMPX) QIMPS = -QIMPS c WRITE(6,*) 'NGCF= ',NGCF c WRITE(6,*) 'QIMPS= ',QIMPS COEF = COEFG(1,JA) MATR1.MAT2(ICOU,ICOUD2) = 0.0D0 MATR1.MAT2(ICOU,ICOUD3) = 0.0D0 MATR1.MAT2(ICOU,ICOU) = COEF MATR1.MAT2(ICOU,ICOUG2) = COEFG(2,JA) MATR1.MAT2(ICOU,ICOUG3) = COEFG(3,JA) SCMB.MAT(ICOU,NLS(JA)) = & ((COEFG(1,JA)+COEFG(2,JA)+COEFG(3,JA))*MPOCHP.VPOCHA(NLCG,1)) & + (QIMPS) VAL1.MAT(ICOU,NLS(JA)) = & (COEFG(1,JA) + COEFG(2,JA) + COEFG(3,JA)) VAL2.MAT(ICOU,NLS(JA)) = 1.D0 IND.NUME(ICOU,NLS(JA)) = NGCG IND22.NUME(ICOU,NLS(JA)) = NGCF NLS1 = NLS(JA) c WRITE(6,*) 'NLS1= ',NLS1,'ICOU=',ICOU, c & 'SCMB', SCMB.MAT(ICOU,NLS1) c WRITE(6,*) 'NLS1= ',NLS1,'ICOU=',ICOU, c & 'IND= ',IND.NUME(ICOU,NLS1), c & 'IND22= ',IND22.NUME(ICOU,NLS1), c & 'SCMB', SCMB.MAT(ICOU,NLS1), c & 'ICOU =',ICOU,'NOUED2= ',MATR1.MAT2(ICOU,ICOU,NLS1), c & 'ICOUG2= ',ICOUG2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG2,NLS1), c & 'ICOUG3= ',ICOUG3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG3,NLS1), c & 'ICOUD2= ',ICOUD2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD2,NLS1), c & 'ICOUD3= ',ICOUD3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD3,NLS1) ELSE c CONDITION MIXTE NLFMI=MLENMI.LECT(NGCF) IF (NLFMI.GT.0) THEN XLAMBDA1 = MPOVMI.VPOCHA(NLFMI,1) XLAMBDA2 = MPOVMI.VPOCHA(NLFMI,2) QIMPX = MPOVMI.VPOCHA(NLFMI,3) C PRODUIT SCALAIRE DU FLUX IMPOSE AVEC LA NORMALE QIMPS = (QIMPX) QIMPS= - QIMPS c WRITE(6,*) 'NLCF= ',NLCF c WRITE(6,*) 'NGCF= ',NGCF c WRITE(6,*) 'XLAMBDA1= ',XLAMBDA1,'XLAMBDA2= ',XLAMBDA2 COEF = COEFG(1,JA) c WRITE(6,*) 'COEF= ',COEF c WRITE(6,*) 'COEF= ',COEF,'QIMPS= ',QIMPS MATR1.MAT2(ICOU,ICOUD2) = 0.0D0 MATR1.MAT2(ICOU,ICOUD3) = 0.0D0 MATR1.MAT2(ICOU,ICOU) = (XLAMBDA1*COEF) + & (1.D0*XLAMBDA2) MATR1.MAT2(ICOU,ICOUG2) = (XLAMBDA1*COEFG(2,JA)) MATR1.MAT2(ICOU,ICOUG3) = (XLAMBDA1*COEFG(3,JA)) c ON EST ICI SCMB.MAT(ICOU,NLS(JA)) = & (XLAMBDA1*((COEFG(1,JA)+COEFG(2,JA)+COEFG(3,JA))* & MPOCHP.VPOCHA(NLCG,1))) & + (1.D0*QIMPS) VAL1.MAT(ICOU,NLS(JA)) = XLAMBDA1* & (COEFG(1,JA) + COEFG(2,JA) + COEFG(3,JA)) VAL2.MAT(ICOU,NLS(JA)) = 1.D0 IND.NUME(ICOU,NLS(JA)) = NGCG IND22.NUME(ICOU,NLS(JA)) = NGCF NLS1 = NLS(JA) c WRITE(6,*) 'NLS1= ',NLS1,'ICOU=',ICOU, c & 'IND= ',IND.NUME(ICOU,NLS1), c & 'IND22= ',IND22.NUME(ICOU,NLS1), c & 'SCMB', SCMB.MAT(ICOU,NLS1), c & 'ICOU =',ICOU,'NOUED2= ',MATR1.MAT2(ICOU,ICOU,NLS1), c & 'ICOUG2= ',ICOUG2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG2,NLS1), c & 'ICOUG3= ',ICOUG3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG3,NLS1), c & 'ICOUD2= ',ICOUD2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD2,NLS1), c & 'ICOUD3= ',ICOUD3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD3,NLS1) ELSE C PAR DEFAUT FLUX NUL QIMPS = 0 COEF = COEFG(1,JA) MATR1.MAT2(ICOU,ICOU) = COEF MATR1.MAT2(ICOU,ICOUG2) = COEFG(2,JA) MATR1.MAT2(ICOU,ICOUG3) = COEFG(3,JA) SCMB.MAT(ICOU,NLS(JA)) = & ((COEFG(1,JA)+COEFG(2,JA)+COEFG(3,JA))*MPOCHP.VPOCHA(NLCG,1)) VAL1.MAT(ICOU,NLS(JA)) = & (COEFG(1,JA) + COEFG(2,JA) + COEFG(3,JA)) VAL2.MAT(ICOU,NLS(JA)) = 0.D0 IND.NUME(ICOU,NLS(JA)) = NGCG IND22.NUME(ICOU,NLS(JA)) = NGCD ENDIF ENDIF ENDIF ENDIF c WRITE(6,*) 'COEF1 = ',COEFGG,'COEF2= ',COEF2,'COEF3= ', c & COEF3,'COEF4=',COEF4,'HG=',MPOCHP.VPOCHA(NLCG,1), c & 'HD= ',MPOCHP.VPOCHA(NLCD,1) NAUX1 = MAX(NAUX1,INDLI.ID(NLS(JA))) c WRITE(6,*) 'NLCF= ',NLCF,'NAUX1 = ',NAUX1 c WRITE(6,*) 'NLS= ',NLS(JA),'NGS= ',NGS(JA), c & 'INDLI.ID',INDLI.ID(NLS(JA)) c WRITE(6,*) 'JA= ',JA c WRITE(6,*) 'NLOCFG= ',NLOCFG(1,JA),NLOCFG(2,JA),NLOCFG(3,JA) c WRITE(6,*) 'NLOCFD= ',NLOCFD(1,JA),NLOCFD(2,JA),NLOCFD(3,JA) c DO I5 = 1,INDLI.ID(NLS(JA)) c INDAUX = IND2.NUME(I5,NLS(JA)) c WRITE(6,*) 'I5= ','JA= ','NLS= ',NLS(JA), c & 'IND2= ',IND2.NUME(I5,NLS(JA)) c ENDDO C ON DESACTIVE (FIN DE LA BOUCLE SUR LES POINTS) c SEGDES MATRICE2 c SEGACT MATRICE2 NLS1 = NLS(JA) IF (ABS(COEF).LT. (-1.D0)) THEN NLFCL=MLENCL.LECT(NGCF) WRITE(6,*) 'CLIMD = ',NLFCL NLFNE=MLENNE.LECT(NGCF) WRITE(6,*) 'CLIMN = ',NLFNE WRITE(6,*) 'NLS1= ',NLS1,'ICOU=',ICOU, & 'SCMB', SCMB.MAT(ICOU,NLS1), & 'ICOU =',ICOU,'NOUED2= ',MATR1.MAT2(ICOU,ICOU),'COEF= ',COEF, & 'ICOUG2= ',ICOUG2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG2), & 'ICOUG3= ',ICOUG3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUG3), & 'ICOUD2= ',ICOUD2,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD2), & 'ICOUD3= ',ICOUD3,'NOUED2= ',MATR1.MAT2(ICOU,ICOUD3), & 'COEFG1JA', COEFG(1,JA),'COEFD1JA',COEFD(1,JA) c WRITE(6,*)'JA = ',JA, 'KA= ',KA,'VOLUG(JA) = ',VOLUG(JA) c WRITE(6,*)'SURFAG = ',SURFAGX(KA),SURFAGY(KA),SURFAGZ(KA) c WRITE(6,*)'VEXG = ',VECXG(KA,JA),VECYG(KA,JA),VECZG(KA,JA) WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z WRITE(6,*) 'JA = ',JA,'VOLUG(JA) = ',VOLUG(JA) WRITE(6,*) 'VECG1 = ',VECXG(1,JA),VECYG(1,JA),VECZG(1,JA) WRITE(6,*) 'VECG2 = ',VECXG(2,JA),VECYG(2,JA),VECZG(2,JA) WRITE(6,*) 'VECG3 = ',VECXG(3,JA),VECYG(3,JA),VECZG(3,JA) WRITE(6,*)'NLCF= ',NLCF,'COEFG = ', & COEFG(1,JA),COEFG(2,JA),COEFG(3,JA) WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z WRITE(6,*)'SURFAG = ',SURFAGX(1),SURFAGY(1),SURFAGZ(1) WRITE(6,*)'SURFAG = ',SURFAGX(2),SURFAGY(2),SURFAGZ(2) WRITE(6,*)'SURFAG = ',SURFAGX(3),SURFAGY(3),SURFAGZ(3) WRITE(6,*) 'JA = ',JA,'VOLUD(JA) = ',VOLUD(JA) WRITE(6,*)'VECD1 = ',VECXD(1,JA),VECYD(1,JA),VECZD(1,JA) WRITE(6,*)'VECD3 = ',VECXD(2,JA),VECYD(2,JA),VECZD(2,JA) WRITE(6,*)'VECD3 = ',VECXD(3,JA),VECYD(3,JA),VECZD(3,JA) WRITE(6,*)'NLCF= ',NLCF,'COEFD = ', & COEFD(1,JA),COEFD(2,JA),COEFD(3,JA) WRITE(6,*) 'SCN1X= ',SCN1X,'SCN1Y= ',SCN1Y,'SCN1Z= ',SCN1Z WRITE(6,*)'SURFAD = ',SURFADX(1),SURFADY(1),SURFADZ(1) WRITE(6,*)'SURFAD = ',SURFADX(2),SURFADY(2),SURFADZ(2) WRITE(6,*)'SURFAD = ',SURFADX(3),SURFADY(3),SURFADZ(3) WRITE(6,*) 'KG=', K11G,K22G,K33G,K21G,K31G,K32G WRITE(6,*) 'KD=', K11D,K22D,K33D,K21D,K31D,K32D ENDIF SEGDES MATR1 * MOD ENDDO c IF (INDICE.EQ.1) THEN c WRITE(6,*)'NLCF= ',NLCF,'COEFG(1) OU COEFD(1) TRES PETIT' c ENDIF ENDDO IF (NAUX1.GT.NBMAX) THEN WRITE(6,*) 'ERREUR DANS LES PARAMETRES' c STOP ENDIF c DO J= 1,INDLI.ID(NLS1) c WRITE(6,*) 'MELVA1=',MELVA1.VELCHE(J,NLCF) c WRITE(6,*) 'MELVA2=',MELVA1.VELCHE(J,NLCF) c WRITE(6,*) 'MELEME=',MELEME.NUM(J,NLCF) c ENDDO MELTFA = MAUX MELEFP = MAUX2 IF (NBSO.EQ.2) THEN SEGDES IPT1 SEGDES IPT2 ELSEIF (NBSO.EQ.3) THEN SEGDES IPT1 SEGDES IPT2 SEGDES IPT3 ELSEIF (NBSO.EQ.4) THEN SEGDES IPT1 SEGDES IPT2 SEGDES IPT3 SEGDES IPT4 ENDIF IF (NBSOF.EQ.2) THEN SEGDES IPT5 SEGDES IPT6 ENDIF c MAUX = MELEFP c MELEFP = IMECOTE(1) c NGCF=MELEFP.NUM(4,1) c WRITE(6,*) 'NGCF= ',NGCF c MELEFP = MAUX c DO NLS1=1,NSOMM,1 c MATR1 = IPO2.POINT(NLS1) c SEGACT MATR1 c c DO I=1,INDLI.ID(NLS1) c DO J = 1,INDLI.ID(NLS1) c WRITE(6,*) 'NLS1= ',NLS1,'I=',I,'J=',J,MATR1.MAT2(I,J) c ENDDO c ENDDO c ENDDO c SEGDES MATR1 9999 CONTINUE RETURN END