C CH1CH2 SOURCE CHAT 08/11/07 21:15:01 6195 SUBROUTINE CH1CH2(MELE,MINTE,MINTE1,NBPTEL,NBPGA1,NBNN,SWORK, > KERRE) C---------------------------------------------------------------------- C C PASSAGE DES VALEURS D'UN JEU DE POINTS DE GAUSS A UN AUTRE C C---------------------------------------------------------------------- C MINTE POINTEUR SUR LES POINTS ET POIDS DE CH2 C MINTE1 POINTEUR SUR LES POINTS ET POIDS DE CH1 C NBPTEL NBRE DE POINTS DE GAUSS DE CH2 C NBPGA1 NBRE DE POINTS DE GAUSS DE CH1 C NBNN NBRE DE NOEUDS DE L'ELEMENT C SWORK SEGMENT DE TRAVAIL C KERRE EN ENTREE : DIMENSION C EN SORTIE : CODE D'ERREUR ( 0 SI OK ) C---------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCREEL -INC CCOPTIO -INC SMINTE SEGMENT/SWORK/(VAL1(NBPGA1)*D,VAL2(NBPTEL)*D,VALN(NBNN)*D, . SHP(6,NBNN)*D,XE(3,NBNN)*D) SEGMENT/AMOI/(AM(NBNN,NBNN)*D,BM(NBNN)*D,CM(NBNN)*D) C= Quelques constantes (2.Pi et 4.Pi) PARAMETER (X2Pi=6.283185307179586476925286766559D0) PARAMETER (X4Pi=12.566370614359172953850573533118D0) C XCOEF=1.d0 IF( mele.ge.85.and.mele.le.90) xcoef = 0.5d0 if( mele.ge.108.and.mele.le.110) xcoef=0.5D0 if(mele.eq.12.or.mele.eq.13) xcoef=0.5D0 if(mele.ge.18.and.mele.le.21) xcoef=0.5D0 if(mele.ge.185.and.mele.le.190) xcoef=0.5D0 JDIM=KERRE IF(JDIM.EQ.0) THEN KERRE=29 RETURN ENDIF C KERRE=0 IF(NBPGA1.EQ.1) THEN DO 10 IA=1,NBNN VALN(IA)=VAL1(1) 10 CONTINUE DO 11 IB=1,NBPTEL VAL2(IB)=VAL1(1) 11 CONTINUE C ELSE IF(NBPGA1.GT.1) THEN IF(IIMPI.EQ.529) WRITE(6,77883) NBPGA1,NBNN 77883 FORMAT('0 NB DE POINTS DE GAUSS ',I4,2X, . 'NB DE NOEUDS ' ,I4/) SEGINI AMOI VV=0.D0 DO 30 IC=1,NBPGA1 C C CALCUL DU JACOBIEN C if(iimpi.eq.529) write(6,*) ' mele ifour ',mele , ifour IFR = IFOUR+4 GO TO (81,81,81,81,81,82,83,83,83,83, . 83,83,83,83,83,83,83,83,83),IFR 89 KERRE=29 GO TO 99 81 IDK=3 GO TO 86 82 IDK=4 GO TO 86 83 IDK=2 86 CONTINUE DO 33 ID=1,IDK DO 331 IE=1,NBNN SHP(ID,IE)=MINTE1.SHPTOT(ID,IE,IC) 331 CONTINUE 33 CONTINUE CALL GTEMRD(XE,SHP,JDIM,NBNN,DJAC) DJAC=DJAC*MINTE1.POIGAU(IC) IF(IFR.EQ.4.OR.IFR.EQ.5) THEN CALL DISTRR(XE,SHP,NBNN,RR) IF(IFR.EQ.4.OR.(IFR.EQ.5.AND. + NIFOUR.EQ.0)) THEN DJAC=DJAC*RR*2*XPI ELSE DJAC=DJAC*RR*XPI ENDIF ELSE IF (IFR.GE.16.AND.IFR.LE.18) THEN CALL DISTRR(XE,SHP,NBNN,RR) DJAC=X2Pi*DJAC*RR ELSE IF (IFR.EQ.19) THEN CALL DISTRR(XE,SHP,NBNN,RR) DJAC=X4Pi*DJAC*RR ENDIF VV=VV+DJAC C C CALCUL DE LA MATRICE ET DU SECOND MEMBRE C DO 20 IA=1,NBNN DO 21 IB=1,NBNN AM(IA,IB)=AM(IA,IB)+SHP(1,IA)*SHP(1,IB)*DJAC 21 CONTINUE BM(IA)=BM(IA)+SHP(1,IA)*VAL1(IC)*DJAC 20 CONTINUE 30 CONTINUE * dans le cas du tri6, on impose les noeuds milieux par penalisation if (mele.eq.6) then call chnsng(am,nbnn,2,1,3) call chnsng(am,nbnn,4,3,5) call chnsng(am,nbnn,6,5,1) endif * dans le cas du tet10, on impose les noeuds milieux par penalisation if (mele.eq.24) then call chnsng(am,nbnn,2,1,3) call chnsng(am,nbnn,4,3,5) call chnsng(am,nbnn,6,5,1) call chnsng(am,nbnn,7,1,10) call chnsng(am,nbnn,8,3,10) call chnsng(am,nbnn,9,5,10) endif * dans le cas du pr15, on impose certains noeuds milieux par penalisation if (mele.eq.17) then call chnsng(am,nbnn,2,1,3) call chnsng(am,nbnn,4,3,5) call chnsng(am,nbnn,6,5,1) call chnsng(am,nbnn,11,10,12) call chnsng(am,nbnn,13,12,14) call chnsng(am,nbnn,15,14,10) endif * C DO 62 IA=1,NBNN CM(IA)=AM(IA,IA) 62 CONTINUE SOM=0.D0 DO 63 IA=1,NBNN SOM=SOM+CM(IA) 63 CONTINUE IF(SOM.EQ.0.D0) THEN KERRE=358 GO TO 61 ENDIF IF(IIMPI.EQ.529) WRITE(6,77884)((AM(I,J),J=1,NBNN),I=1,NBNN) 77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/)) PREC=SOM*1.D-10/NBNN CALL INVALM(AM,NBNN,NBNN,KERRE,PREC) 61 IF(KERRE.NE.0) THEN C C A EST SINGULIERE - ON MOYENNE | C KERRE=0 IF(IIMPI.GE.529) WRITE(6,77854) 77854 FORMAT(' A EST SINGULIERE - ON MOYENNE ' /) SOM=0.D0 DO 64 IC=1,NBPGA1 SOM=SOM+VAL1(IC) 64 CONTINUE SOM=SOM/NBPGA1 DO 65 IA=1,NBNN VALN(IA)=SOM 65 CONTINUE C ELSE DO 40 IA=1,NBNN VA=0.D0 DO 41 IB=1,NBNN VA=VA+AM(IA,IB)*BM(IB) 41 CONTINUE VALN(IA)=VA 40 CONTINUE ENDIF C C CALCUL DES VALEURS AUX POINTS DE GAUSS C DO 50 IB=1,NBPTEL VA=0.D0 DO 51 IC=1,NBNN VA=VA+SHPTOT(1,IC,IB)*VALN(IC) 51 CONTINUE VAL2(IB)=VA*xcoef 50 CONTINUE C 99 CONTINUE SEGSUP AMOI ENDIF C RETURN END