C CAL2S3 SOURCE CB215821 16/04/21 21:15:27 8920 SUBROUTINE CAL2S3(G,NAM,AM,NBM,BM,N,F3,NYA,NYB,EDIS) C--------------------------------------------------------------------- C 3D : CALCUL DE ' SI.FIJ ' C C INTEGRATION EN SEMI-ANALYTIQUE C C--------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C Include contenant quelques constantes dont XPI : -INC CCREEL C DIMENSION G(11,10),AM(3,5),BM(3,5),A(3),B(3),C(3),D(3),E(3) DIMENSION NYA(5),NYB(5) C DO 40 K=1,3 AM(K,NAM+1)=AM(K,1) BM(K,NBM+1)=BM(K,1) 40 CONTINUE NYA(NAM+1)=NYA(1) NYB(NBM+1)=NYB(1) F3=0.D0 C BOUCLE SUR LA FACE 1 DO 51 I=1,NAM D1=0.D0 DO 54 K=1,3 A(K)=AM(K,I) B(K)=AM(K,I+1) D1=D1+(B(K)-A(K))**2 54 CONTINUE D1=SQRT(D1) C BOUCLE SUR LA FACE 2 DO 52 J=1,NBM D2=0.D0 PR=0.D0 DO 53 K=1,3 C(K)=BM(K,J) D(K)=BM(K,J+1) D2=D2+(D(K)-C(K))**2 PR=PR+(B(K)-A(K))*(D(K)-C(K)) 53 CONTINUE D2=SQRT(D2) CO=PR/D1/D2 C>>> IF( ABS(CO).LT.(1.D-5)) THEN F2 = 0.D0 GOTO 17 ELSE DAC = CALDIS(A,C,3) DAD = CALDIS(A,D,3) DBC = CALDIS(B,C,3) DBD = CALDIS(B,D,3) C IF(DAC.LT.EDIS) GOTO 9 IF(DAD.LT.EDIS) GOTO 9 IF(DBC.LT.EDIS) GOTO 9 IF(DBD.LT.EDIS) GOTO 9 CALL INTEGA(G,F2,A,B,C,D,N,D2,CO) GOTO 18 C C TEST C 9 CONTINUE IF( (DAC.LT.EDIS).AND.(DBD.LT.EDIS) ) THEN F2=(3-2*LOG(D1))/2 GOTO 18 ELSE IF( (DAD.LT.EDIS).AND.(DBC.LT.EDIS) ) THEN F2=-(3-2*LOG(D1))/2 GOTO 18 ELSE IF(ABS(D1-D2).LT.1.D-5)THEN IF( (DAC.LT.EDIS).OR.(DBD.LT.EDIS) ) THEN XCO=-CO CALL ILIN(XCO,D1,F2) ELSE CALL ILIN(CO,D1,F2) ENDIF GOTO 18 ELSE IF(D1.GT.D2)THEN DM=D2 IF(DAC.LT.EDIS) THEN DO 21 K=1,3 E(K)=B(K)-(D1-D2)/D1*(B(K)-A(K)) 21 CONTINUE CALL INTEGA(G,F2S,E,B,C,D,N,D2,CO) XCO=-CO CALL ILIN(XCO,D2,FE) GOTO 19 ENDIF IF(DAD.LT.EDIS) THEN DO 22 K=1,3 E(K)=B(K)-(D1-D2)/D1*(B(K)-A(K)) 22 CONTINUE CALL INTEGA(G,F2S,E,B,C,D,N,D2,CO) CALL ILIN(CO,D2,FE) GOTO 19 ENDIF IF(DBC.LT.EDIS) THEN DO 23 K=1,3 E(K)=A(K)+(D1-D2)/D1*(B(K)-A(K)) 23 CONTINUE CALL INTEGA(G,F2S,A,E,C,D,N,D2,CO) CALL ILIN(CO,D2,FE) GOTO 19 ENDIF IF(DBD.LT.EDIS) THEN DO 24 K=1,3 E(K)=A(K)+(D1-D2)/D1*(B(K)-A(K)) 24 CONTINUE CALL INTEGA(G,F2S,A,E,C,D,N,D2,CO) XCO=-CO CALL ILIN(XCO,D2,FE) GOTO 19 ENDIF ELSE DM=D1 D2M=D2-D1 IF(DAC.LT.EDIS) THEN DO 31 K=1,3 E(K)=D(K)-(D2-D1)/D2*(D(K)-C(K)) 31 CONTINUE CALL INTEGA(G,F2S,A,B,E,D,N,D2M,CO) XCO=-CO CALL ILIN(XCO,D1,FE) GOTO 19 ENDIF IF(DAD.LT.EDIS) THEN DO 32 K=1,3 E(K)=C(K)+(D2-D1)/D2*(D(K)-C(K)) 32 CONTINUE CALL INTEGA(G,F2S,A,B,C,E,N,D2M,CO) CALL ILIN(CO,D1,FE) GOTO 19 ENDIF IF(DBC.LT.EDIS) THEN DO 33 K=1,3 E(K)=D(K)-(D2-D1)/D2*(D(K)-C(K)) 33 CONTINUE CALL INTEGA(G,F2S,A,B,E,D,N,D2M,CO) CALL ILIN(CO,D1,FE) GOTO 19 ENDIF IF(DBD.LT.EDIS) THEN DO 34 K=1,3 E(K)=C(K)+(D2-D1)/D2*(D(K)-C(K)) 34 CONTINUE CALL INTEGA(G,F2S,A,B,C,E,N,D2M,CO) XCO=-CO CALL ILIN(XCO,D1,FE) GOTO 19 ENDIF ENDIF ENDIF ENDIF ENDIF C>>> ENDIF C C FIN DU TEST C 19 CONTINUE F2=(FE*DM+F2S*ABS(D1-D2))*DM*CO GOTO 17 18 CONTINUE F2=F2*CO*D1*D2 17 CONTINUE F3=F3+F2 52 CONTINUE 51 CONTINUE F3=F3/2/XPI RETURN END