1 : C CH1CH2 SOURCE CHAT 08/11/07 21:15:01 6195 2 : SUBROUTINE CH1CH2(MELE,MINTE,MINTE1,NBPTEL,NBPGA1,NBNN,SWORK, 3 : > KERRE) 4 : C---------------------------------------------------------------------- 5 : C 6 : C PASSAGE DES VALEURS D'UN JEU DE POINTS DE GAUSS A UN AUTRE 7 : C 8 : C---------------------------------------------------------------------- 9 : C MINTE POINTEUR SUR LES POINTS ET POIDS DE CH2 10 : C MINTE1 POINTEUR SUR LES POINTS ET POIDS DE CH1 11 : C NBPTEL NBRE DE POINTS DE GAUSS DE CH2 12 : C NBPGA1 NBRE DE POINTS DE GAUSS DE CH1 13 : C NBNN NBRE DE NOEUDS DE L'ELEMENT 14 : C SWORK SEGMENT DE TRAVAIL 15 : C KERRE EN ENTREE : DIMENSION 16 : C EN SORTIE : CODE D'ERREUR ( 0 SI OK ) 17 : C---------------------------------------------------------------------- 18 : IMPLICIT INTEGER(I-N) 19 : IMPLICIT REAL*8(A-H,O-Z) 20 : -INC CCREEL 21 : -INC CCOPTIO 22 : -INC SMINTE 23 : SEGMENT/SWORK/(VAL1(NBPGA1)*D,VAL2(NBPTEL)*D,VALN(NBNN)*D, 24 : . SHP(6,NBNN)*D,XE(3,NBNN)*D) 25 : SEGMENT/AMOI/(AM(NBNN,NBNN)*D,BM(NBNN)*D,CM(NBNN)*D) 26 : C= Quelques constantes (2.Pi et 4.Pi) 27 : PARAMETER (X2Pi=6.283185307179586476925286766559D0) 28 : PARAMETER (X4Pi=12.566370614359172953850573533118D0) 29 : C 30 : XCOEF=1.d0 31 : IF( mele.ge.85.and.mele.le.90) xcoef = 0.5d0 32 : if( mele.ge.108.and.mele.le.110) xcoef=0.5D0 33 : if(mele.eq.12.or.mele.eq.13) xcoef=0.5D0 34 : if(mele.ge.18.and.mele.le.21) xcoef=0.5D0 35 : if(mele.ge.185.and.mele.le.190) xcoef=0.5D0 36 : JDIM=KERRE 37 : IF(JDIM.EQ.0) THEN 38 : KERRE=29 39 : RETURN 40 : ENDIF 41 : C 42 : KERRE=0 43 : IF(NBPGA1.EQ.1) THEN 44 : DO 10 IA=1,NBNN 45 : VALN(IA)=VAL1(1) 46 : 10 CONTINUE 47 : DO 11 IB=1,NBPTEL 48 : VAL2(IB)=VAL1(1) 49 : 11 CONTINUE 50 : C 51 : ELSE IF(NBPGA1.GT.1) THEN 52 : IF(IIMPI.EQ.529) WRITE(6,77883) NBPGA1,NBNN 53 : 77883 FORMAT('0 NB DE POINTS DE GAUSS ',I4,2X, 54 : . 'NB DE NOEUDS ' ,I4/) 55 : SEGINI AMOI 56 : VV=0.D0 57 : DO 30 IC=1,NBPGA1 58 : C 59 : C CALCUL DU JACOBIEN 60 : C 61 : if(iimpi.eq.529) write(6,*) ' mele ifour ',mele , ifour 62 : IFR = IFOUR+4 63 : GO TO (81,81,81,81,81,82,83,83,83,83, 64 : . 83,83,83,83,83,83,83,83,83),IFR 65 : 89 KERRE=29 66 : GO TO 99 67 : 81 IDK=3 68 : GO TO 86 69 : 82 IDK=4 70 : GO TO 86 71 : 83 IDK=2 72 : 86 CONTINUE 73 : DO 33 ID=1,IDK 74 : DO 331 IE=1,NBNN 75 : SHP(ID,IE)=MINTE1.SHPTOT(ID,IE,IC) 76 : 331 CONTINUE 77 : 33 CONTINUE 77 : CALL GTEMRD(XE,SHP,JDIM,NBNN,DJAC) 78 : DJAC=DJAC*MINTE1.POIGAU(IC) 79 : IF(IFR.EQ.4.OR.IFR.EQ.5) THEN 79 : CALL DISTRR(XE,SHP,NBNN,RR) 80 : IF(IFR.EQ.4.OR.(IFR.EQ.5.AND. 81 : + NIFOUR.EQ.0)) THEN 82 : DJAC=DJAC*RR*2*XPI 83 : ELSE 84 : DJAC=DJAC*RR*XPI 85 : ENDIF 86 : ELSE IF (IFR.GE.16.AND.IFR.LE.18) THEN 86 : CALL DISTRR(XE,SHP,NBNN,RR) 87 : DJAC=X2Pi*DJAC*RR 88 : ELSE IF (IFR.EQ.19) THEN 88 : CALL DISTRR(XE,SHP,NBNN,RR) 89 : DJAC=X4Pi*DJAC*RR 90 : ENDIF 91 : VV=VV+DJAC 92 : C 93 : C CALCUL DE LA MATRICE ET DU SECOND MEMBRE 94 : C 95 : DO 20 IA=1,NBNN 96 : DO 21 IB=1,NBNN 97 : AM(IA,IB)=AM(IA,IB)+SHP(1,IA)*SHP(1,IB)*DJAC 98 : 21 CONTINUE 99 : BM(IA)=BM(IA)+SHP(1,IA)*VAL1(IC)*DJAC 100 : 20 CONTINUE 101 : 30 CONTINUE 102 : * dans le cas du tri6, on impose les noeuds milieux par penalisation 103 : if (mele.eq.6) then 103 : call chnsng(am,nbnn,2,1,3) 103 : call chnsng(am,nbnn,4,3,5) 103 : call chnsng(am,nbnn,6,5,1) 104 : endif 105 : * dans le cas du tet10, on impose les noeuds milieux par penalisation 106 : if (mele.eq.24) then 106 : call chnsng(am,nbnn,2,1,3) 106 : call chnsng(am,nbnn,4,3,5) 106 : call chnsng(am,nbnn,6,5,1) 106 : call chnsng(am,nbnn,7,1,10) 106 : call chnsng(am,nbnn,8,3,10) 106 : call chnsng(am,nbnn,9,5,10) 107 : endif 108 : * dans le cas du pr15, on impose certains noeuds milieux par penalisation 109 : if (mele.eq.17) then 109 : call chnsng(am,nbnn,2,1,3) 109 : call chnsng(am,nbnn,4,3,5) 109 : call chnsng(am,nbnn,6,5,1) 109 : call chnsng(am,nbnn,11,10,12) 109 : call chnsng(am,nbnn,13,12,14) 109 : call chnsng(am,nbnn,15,14,10) 110 : endif 111 : * 112 : C 113 : DO 62 IA=1,NBNN 114 : CM(IA)=AM(IA,IA) 115 : 62 CONTINUE 116 : SOM=0.D0 117 : DO 63 IA=1,NBNN 118 : SOM=SOM+CM(IA) 119 : 63 CONTINUE 120 : IF(SOM.EQ.0.D0) THEN 121 : KERRE=358 122 : GO TO 61 123 : ENDIF 124 : IF(IIMPI.EQ.529) WRITE(6,77884)((AM(I,J),J=1,NBNN),I=1,NBNN) 125 : 77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/)) 126 : PREC=SOM*1.D-10/NBNN 126 : CALL INVALM(AM,NBNN,NBNN,KERRE,PREC) 127 : 61 IF(KERRE.NE.0) THEN 128 : C 129 : C A EST SINGULIERE - ON MOYENNE | 130 : C 131 : KERRE=0 132 : IF(IIMPI.GE.529) WRITE(6,77854) 133 : 77854 FORMAT(' A EST SINGULIERE - ON MOYENNE ' /) 134 : SOM=0.D0 135 : DO 64 IC=1,NBPGA1 136 : SOM=SOM+VAL1(IC) 137 : 64 CONTINUE 138 : SOM=SOM/NBPGA1 139 : DO 65 IA=1,NBNN 140 : VALN(IA)=SOM 141 : 65 CONTINUE 142 : C 143 : ELSE 144 : DO 40 IA=1,NBNN 145 : VA=0.D0 146 : DO 41 IB=1,NBNN 147 : VA=VA+AM(IA,IB)*BM(IB) 148 : 41 CONTINUE 149 : VALN(IA)=VA 150 : 40 CONTINUE 151 : ENDIF 152 : C 153 : C CALCUL DES VALEURS AUX POINTS DE GAUSS 154 : C 155 : DO 50 IB=1,NBPTEL 156 : VA=0.D0 157 : DO 51 IC=1,NBNN 158 : VA=VA+SHPTOT(1,IC,IB)*VALN(IC) 159 : 51 CONTINUE 160 : VAL2(IB)=VA*xcoef 161 : 50 CONTINUE 162 : C 163 : 99 CONTINUE 164 : SEGSUP AMOI 165 : ENDIF 166 : C 167 : RETURN 168 : END 169 : 170 : 171 : 172 : 173 : 174 : 175 : 176 : 177 : 178 : 179 :
© Cast3M 2003 - All rights reserved.
Disclaimer