Télécharger cal2s3.eso

Retour à la liste

cal2s3
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
 
 
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales