1 : C CAL2S3 SOURCE CHAT 05/01/12 21:45:33 5004 2 : SUBROUTINE CAL2S3(G,NAM,AM,NBM,BM,N,F3,NYA,NYB,EDIS) 3 : C--------------------------------------------------------------------- 4 : C 3D : CALCUL DE ' SI.FIJ ' 5 : C 6 : C INTEGRATION EN SEMI-ANALYTIQUE 7 : C 8 : C--------------------------------------------------------------------- 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : C Include contenant quelques constantes dont XPI : 12 : -INC CCREEL 13 : C 14 : DIMENSION G(11,10),AM(3,5),BM(3,5),A(3),B(3),C(3),D(3),E(3) 15 : DIMENSION NYA(5),NYB(5) 16 : C 17 : DO 40 K=1,3 18 : AM(K,NAM+1)=AM(K,1) 19 : BM(K,NBM+1)=BM(K,1) 20 : 40 CONTINUE 21 : NYA(NAM+1)=NYA(1) 22 : NYB(NBM+1)=NYB(1) 23 : F3=0.D0 24 : C BOUCLE SUR LA FACE 1 25 : DO 51 I=1,NAM 26 : D1=0.D0 27 : DO 54 K=1,3 28 : A(K)=AM(K,I) 29 : B(K)=AM(K,I+1) 30 : D1=D1+(B(K)-A(K))**2 31 : 54 CONTINUE 32 : D1=DSQRT(D1) 33 : C BOUCLE SUR LA FACE 2 34 : DO 52 J=1,NBM 35 : D2=0.D0 36 : PR=0.D0 37 : DO 53 K=1,3 38 : C(K)=BM(K,J) 39 : D(K)=BM(K,J+1) 40 : D2=D2+(D(K)-C(K))**2 41 : PR=PR+(B(K)-A(K))*(D(K)-C(K)) 42 : 53 CONTINUE 43 : D2=DSQRT(D2) 44 : CO=PR/D1/D2 45 : C>>> 46 : IF( DABS(CO).LT.(1.D-5)) THEN 47 : F2 = 0.D0 48 : GOTO 17 49 : ELSE 50 : DAC = CALDIS(A,C,3) 51 : DAD = CALDIS(A,D,3) 52 : DBC = CALDIS(B,C,3) 53 : DBD = CALDIS(B,D,3) 54 : C 55 : IF(DAC.LT.EDIS) GOTO 9 56 : IF(DAD.LT.EDIS) GOTO 9 57 : IF(DBC.LT.EDIS) GOTO 9 58 : IF(DBD.LT.EDIS) GOTO 9 58 : CALL INTEGA(G,F2,A,B,C,D,N,D2,CO) 59 : GOTO 18 60 : C 61 : C TEST 62 : C 63 : 9 CONTINUE 64 : IF( (DAC.LT.EDIS).AND.(DBD.LT.EDIS) ) THEN 65 : F2=(3-2*DLOG(D1))/2 66 : GOTO 18 67 : ELSE 68 : IF( (DAD.LT.EDIS).AND.(DBC.LT.EDIS) ) THEN 69 : F2=-(3-2*DLOG(D1))/2 70 : GOTO 18 71 : ELSE 72 : IF(ABS(D1-D2).LT.1.D-5)THEN 73 : IF( (DAC.LT.EDIS).OR.(DBD.LT.EDIS) ) THEN 74 : XCO=-CO 74 : CALL ILIN(XCO,D1,F2) 75 : ELSE 75 : CALL ILIN(CO,D1,F2) 76 : ENDIF 77 : GOTO 18 78 : ELSE 79 : IF(D1.GT.D2)THEN 80 : DM=D2 81 : IF(DAC.LT.EDIS) THEN 82 : DO 21 K=1,3 83 : E(K)=B(K)-(D1-D2)/D1*(B(K)-A(K)) 84 : 21 CONTINUE 84 : CALL INTEGA(G,F2S,E,B,C,D,N,D2,CO) 85 : XCO=-CO 85 : CALL ILIN(XCO,D2,FE) 86 : GOTO 19 87 : ENDIF 88 : IF(DAD.LT.EDIS) THEN 89 : DO 22 K=1,3 90 : E(K)=B(K)-(D1-D2)/D1*(B(K)-A(K)) 91 : 22 CONTINUE 91 : CALL INTEGA(G,F2S,E,B,C,D,N,D2,CO) 91 : CALL ILIN(CO,D2,FE) 92 : GOTO 19 93 : ENDIF 94 : IF(DBC.LT.EDIS) THEN 95 : DO 23 K=1,3 96 : E(K)=A(K)+(D1-D2)/D1*(B(K)-A(K)) 97 : 23 CONTINUE 97 : CALL INTEGA(G,F2S,A,E,C,D,N,D2,CO) 97 : CALL ILIN(CO,D2,FE) 98 : GOTO 19 99 : ENDIF 100 : IF(DBD.LT.EDIS) THEN 101 : DO 24 K=1,3 102 : E(K)=A(K)+(D1-D2)/D1*(B(K)-A(K)) 103 : 24 CONTINUE 103 : CALL INTEGA(G,F2S,A,E,C,D,N,D2,CO) 104 : XCO=-CO 104 : CALL ILIN(XCO,D2,FE) 105 : GOTO 19 106 : ENDIF 107 : ELSE 108 : DM=D1 109 : D2M=D2-D1 110 : IF(DAC.LT.EDIS) THEN 111 : DO 31 K=1,3 112 : E(K)=D(K)-(D2-D1)/D2*(D(K)-C(K)) 113 : 31 CONTINUE 113 : CALL INTEGA(G,F2S,A,B,E,D,N,D2M,CO) 114 : XCO=-CO 114 : CALL ILIN(XCO,D1,FE) 115 : GOTO 19 116 : ENDIF 117 : IF(DAD.LT.EDIS) THEN 118 : DO 32 K=1,3 119 : E(K)=C(K)+(D2-D1)/D2*(D(K)-C(K)) 120 : 32 CONTINUE 120 : CALL INTEGA(G,F2S,A,B,C,E,N,D2M,CO) 120 : CALL ILIN(CO,D1,FE) 121 : GOTO 19 122 : ENDIF 123 : IF(DBC.LT.EDIS) THEN 124 : DO 33 K=1,3 125 : E(K)=D(K)-(D2-D1)/D2*(D(K)-C(K)) 126 : 33 CONTINUE 126 : CALL INTEGA(G,F2S,A,B,E,D,N,D2M,CO) 126 : CALL ILIN(CO,D1,FE) 127 : GOTO 19 128 : ENDIF 129 : IF(DBD.LT.EDIS) THEN 130 : DO 34 K=1,3 131 : E(K)=C(K)+(D2-D1)/D2*(D(K)-C(K)) 132 : 34 CONTINUE 132 : CALL INTEGA(G,F2S,A,B,C,E,N,D2M,CO) 133 : XCO=-CO 133 : CALL ILIN(XCO,D1,FE) 134 : GOTO 19 135 : ENDIF 136 : ENDIF 137 : ENDIF 138 : ENDIF 139 : ENDIF 140 : C>>> 141 : ENDIF 142 : C 143 : C FIN DU TEST 144 : C 145 : 19 CONTINUE 146 : F2=(FE*DM+F2S*DABS(D1-D2))*DM*CO 147 : GOTO 17 148 : 18 CONTINUE 149 : F2=F2*CO*D1*D2 150 : 17 CONTINUE 151 : F3=F3+F2 152 : 52 CONTINUE 153 : 51 CONTINUE 154 : F3=F3/2/XPI 155 : RETURN 156 : END 157 : 158 : 159 : 160 : 161 : 162 : 163 :
© Cast3M 2003 - All rights reserved.
Disclaimer