1 : C K1K2 SOURCE MAGN 05/02/18 21:15:10 5031 2 : SUBROUTINE K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,SWORK, 3 : > KK,KERRE) 4 : C---------------------------------------------------------------------- 5 : C 6 : C PASSAGE D'UN SPG DE CHAMELEM VERS UN AUTRE SPG DE DEGRE INFERIEUR --- 7 : C 8 : C---------------------------------------------------------------------- 9 : IMPLICIT REAL*8(A-H,O-Z) 10 : -INC CCREEL 11 : -INC CCOPTIO 12 : -INC SMINTE 13 : SEGMENT SWORK 14 : REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2) 15 : REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN) 16 : ENDSEGMENT 17 : SEGMENT/AMOI/(BM(NBN2,NBN1)*D,AM(NBN2,NBN2)*D,VAL3(NBN1)*D) 18 : C 19 : JDIM=KERRE 20 : IF(JDIM.EQ.0) THEN 21 : KERRE=29 22 : RETURN 23 : ENDIF 24 : C 25 : KERRE=0 26 : 27 : SEGINI AMOI 28 : 29 : C Verification cas 2D ou 3D 30 : IFR = IFOUR+4 31 : GO TO (81,81,81,81,81,82),IFR 32 : 89 KERRE=29 33 : GO TO 99 34 : 81 IDK=3 35 : GO TO 86 36 : 82 IDK=4 37 : 86 CONTINUE 38 : CCC --- CHAMP SOMMET --> CHAMP CENTRE 39 : IF(NBN2.EQ.1) THEN 40 : VV=0.D0 41 : DO 30 IC=1,MINTE1.SHPTOT(/3) 42 : DO 33 ID=1,IDK 43 : DO 331 IE=1,NBN1 44 : SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC) 45 : 331 CONTINUE 46 : 33 CONTINUE 46 : CALL GTEMRD(XE,SHP1,JDIM,NBN1,DJAC) 47 : DJAC=DJAC*MINTE1.POIGAU(IC) 48 : IF(IFR.EQ.4.OR.IFR.EQ.5) THEN 48 : CALL DISTRR(XE,SHP1,NBNN,RR) 49 : IF(IFR.EQ.4.OR.(IFR.EQ.5.AND. 50 : + NIFOUR.EQ.0)) THEN 51 : DJAC=DJAC*RR*2*XPI 52 : ELSE 53 : DJAC=DJAC*RR*XPI 54 : ENDIF 55 : ENDIF 56 : DO 31 IB=1,NBN1 57 : VAL3(IB)=VAL3(IB)+SHP1(1,IB)*DJAC 58 : VV=VV+SHP1(1,IB)*DJAC 59 : 31 CONTINUE 60 : 30 CONTINUE 61 : WW=0.D0 62 : DO 32 IB=1,NBN1 63 : WW=WW+VAL3(IB)*VAL1(IB) 64 : 32 CONTINUE 65 : VAL2(1)=WW/VV 66 : 67 : CCC --- CHAMP SOMMET --> CHAMP CENTREP1 ou MSOMMET 68 : ELSE 69 : VV=0.D0 70 : DO 40 IC=1,MINTE1.SHPTOT(/3) 71 : DO 43 ID=1,IDK 72 : DO 431 IE=1,NBN1 73 : SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC) 74 : 431 CONTINUE 75 : DO 432 IE=1,NBN2 76 : SHP2(ID,IE)=SHPTOT(ID,IE,IC) 77 : 432 CONTINUE 78 : 43 CONTINUE 79 : IF (KK.EQ.1) THEN 79 : CALL GTEMRD(XE,SHP1,JDIM,NBNN,DJAC) 80 : DJAC=DJAC*MINTE1.POIGAU(IC) 81 : ELSEIF (KK.EQ.2) THEN 81 : CALL GTEMRD(XE,SHP2,JDIM,NBNN,DJAC) 82 : DJAC=DJAC*POIGAU(IC) 83 : ENDIF 84 : IF(IFR.EQ.4.OR.IFR.EQ.5) THEN 85 : IF (KK.EQ.1) THEN 85 : CALL DISTRR(XE,SHP1,NBNN,RR) 86 : ELSEIF (KK.EQ.2) THEN 86 : CALL DISTRR(XE,SHP2,NBNN,RR) 87 : ENDIF 88 : IF(IFR.EQ.4.OR.(IFR.EQ.5.AND. 89 : + NIFOUR.EQ.0)) THEN 90 : DJAC=DJAC*RR*2*XPI 91 : ELSE 92 : DJAC=DJAC*RR*XPI 93 : ENDIF 94 : ENDIF 95 : C 96 : C CALCUL DE LA MATRICE ET DU SECOND MEMBRE 97 : C 98 : DO 20 IA=1,NBN2 99 : DO 21 IB=1,NBN1 100 : BM(IA,IB)=BM(IA,IB)+SHP1(1,IB)*SHP2(1,IA)*DJAC 101 : 21 CONTINUE 102 : DO 22 IB=1,NBN2 103 : AM(IA,IB)=AM(IA,IB)+SHP2(1,IB)*SHP2(1,IA)*DJAC 104 : 22 CONTINUE 105 : 20 CONTINUE 106 : 40 CONTINUE 107 : C WRITE(6,77883)((BM(I,J),J=1,NBN1),I=1,NBN2) 108 : C77883 FORMAT(' MATRICE BM '/(6(1X,1PE12.5)/)) 109 : C WRITE(6,77884)((AM(I,J),J=1,NBN2),I=1,NBN2) 110 : C77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/)) 111 : SOM=0.D0 112 : DO 63 IA=1,NBN2 113 : SOM=SOM+AM(IA,IA) 114 : 63 CONTINUE 115 : IF(SOM.EQ.0.D0) THEN 116 : KERRE=358 117 : GO TO 99 118 : ENDIF 119 : PREC=SOM*1.D-40/NBN2 119 : CALL INVALM(AM,NBN2,NBN2,KERRE,PREC) 120 : C WRITE(6,77885)((AM(I,J),J=1,NBN2),I=1,NBN2) 121 : C77885 FORMAT(' MATRICE A-1'/(6(1X,1PE12.5)/)) 122 : C 123 : C T{AUTRES} = (inve(A))*B*T{SOMMET} 124 : C 125 : DO 36 IA=1,NBN2 126 : SS=0. 127 : DO 37 IB=1,NBN1 128 : SS=SS+BM(IA,IB)*VAL1(IB) 129 : 37 CONTINUE 130 : VALN(IA)=SS 131 : 36 CONTINUE 132 : 133 : DO 48 IA=1,NBN2 134 : SS=0. 135 : DO 49 IB=1,NBN2 136 : SS=SS+AM(IA,IB)*VALN(IB) 137 : 49 CONTINUE 138 : VAL2(IA)=SS 139 : 48 CONTINUE 140 : ENDIF 141 : 142 : 143 : 99 CONTINUE 144 : SEGSUP AMOI 145 : CC ENDIF 146 : C 147 : RETURN 148 : END 149 : 150 : 151 : 152 : 153 : 154 :
© Cast3M 2003 - All rights reserved.
Disclaimer