Sources Esope | Cast3M

kproja
C KPROJA    SOURCE    CHAT      05/01/13    01:05:08     5004
      SUBROUTINE KPROJA(O1,XG1,XG2,X1,KF1,KC1,X2,KF2,KC2,I,SPROJA,SHC3D)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C----------------------------------------------------------------------
C Calcul des facteurs de forme en 3D
C Sp appele par Kprojf et Ksubcr
C
C     PROJECTION DES ARETES
C     ---------------------
C
C     O1 : POINT SUR L'ELEMENT 1
C     XG1: COORDONNEES GLOBALES DU SOMMET 1
C     X1 : COORDONNEES SUR L'H.C
C     KF1: FACE SUR L'H.C
C     KC1: COORDONNEES ENTIERES SUR L'H.C
C     idem point 2
C----------------------------------------------------------------------
-INC TFFOR3D
C
      DIMENSION X1(3),X2(3),KC1(2),KC2(2)
      DIMENSION IFAC(3),IGC(3,2),NCELC(3)
      DIMENSION O1(3),X(3),XR(3),KI(2),XG1(1),XG2(1)
C
C     WRITE(6,*) ' KPROJA KF ',KF1,KF2
C     WRITE(6,*) ' KPROJA KA ',KA(KF1),KA(KF2)
C          WRITE(6,*) ' XG1 ',XG1(1),XG1(2),XG1(3)
C          WRITE(6,*) ' XG2 ',XG2(1),XG2(2),XG2(3)
 
      IF ((KA(KF1).NE.KA(KF2)).OR.(KF1.EQ.KF2)) THEN
 
         CALL KCALAR(NRES,X1,KF1,KC1,X2,KF2,KC2,
     -               NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM)
 
C        WRITE(6,*) '       IF1 IF2 NFA ',KF(NP1),KF(NP2),NFAC          KAR02020
C          WRITE(6,*) ' X1 ',X1(1),X1(2),X1(3)
C          WRITE(6,*) ' X2 ',X2(1),X2(2),X2(3)
 
         NFA(I) = NFAC
         DO 332 J = 1,NFAC
           IFA(J,I) = IFAC(J)
           NCEL(J,I) = NCELC(J)
           IG(J,1,I) = IGC(J,1)
           IG(J,2,I) = IGC(J,2)
           DO 334 K = 1,NCELC(J)
           ICEL(J,1,K,I) = ICELC(J,1,K)
           ICEL(J,2,K,I) = ICELC(J,2,K)
 334       CONTINUE
 332     CONTINUE
 
      ELSE
 
        DO 1 K=1,KES
          X(K) = (XG1(K)+XG2(K))/2
 1      CONTINUE
C
        II = 0
C       WRITE(6,*) ' KA ',KA(KF1)
        KAC = KA(KF1)
 10     CONTINUE
        II = II + 1
C       IF (II.GT.20) CALL ARRET(0)
C       05-90
        IF (II.GT.20) THEN
        RETURN
        ENDIF
        CALL KAPCU1(KES,X,O1,NRES,XR,KF,KI,KAC)
C       WRITE(6,*) ' KF ',KF
C          WRITE(6,*) ' O1 ',O1(1),O1(2),O1(3)
 
        IF (KF.EQ.KF1) THEN
 
              DO 2 K = 1,KES
              X(K) = (X(K)+XG2(K))/2
 2            CONTINUE
              GOTO 10
        ELSE
          IF(KF.EQ.KF2) THEN
              DO 3 K = 1,KES
              X(K) = (XG1(K)+X(K))/2
 3            CONTINUE
              GOTO 10
          ELSE
 
C          KF1 KF2 KF KFP
C
            CALL KCALAR(NRES,X1,KF1,KC1,XR,KF,KI,
     -                  NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM)
 
           IFA(1,I) = IFAC(1)
           NCEL(1,I) = NCELC(1)
           IG(1,1,I) = IGC(1,1)
           IG(1,2,I) = IGC(1,2)
           DO 300 K = 1,NCELC(1)
           ICEL(1,1,K,I) = ICELC(1,1,K)
           ICEL(1,2,K,I) = ICELC(1,2,K)
 300       CONTINUE
 
           IFA(3,I) = IFAC(2)
           NCEL(3,I) = NCELC(2)
           IG(3,1,I) = IGC(2,1)
           IG(3,2,I) = IGC(2,2)
           DO 301 K = 1,NCELC(2)
           ICEL(3,1,K,I) = ICELC(2,1,K)
           ICEL(3,2,K,I) = ICELC(2,2,K)
 301       CONTINUE
 
          IF (NFAC.EQ.3) THEN
           IFA(4,I) = IFAC(3)
           NCEL(4,I) = NCELC(3)
           IG(4,1,I) = IGC(3,1)
           IG(4,2,I) = IGC(3,2)
           DO 302 K = 1,NCELC(3)
           ICEL(4,1,K,I) = ICELC(3,1,K)
           ICEL(4,2,K,I) = ICELC(3,2,K)
 302       CONTINUE
           NFA(I) = 4
          ELSE
           NFA(I) = 3
          ENDIF
 
          ENDIF
 
            CALL KCALAR(NRES,X2,KF2,KC2,XR,KF,KI,
     -                  NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM)
 
 
           IFA(2,I) = IFAC(1)
           NCEL(2,I) = NCELC(1)
           IG(2,1,I) = IGC(1,1)
           IG(2,2,I) = IGC(1,2)
           DO 303 K = 1,NCELC(1)
           ICEL(2,1,K,I) = ICELC(1,1,K)
           ICEL(2,2,K,I) = ICELC(1,2,K)
 303       CONTINUE
 
           IG(3,1,I) = (IG(3,1,I) + IGC(2,1)) /2
           IG(3,2,I) = (IG(3,2,I) + IGC(2,2)) /2
C          DO 304 K1 = 1,NCELC(2)-1
 
           DO 304 K1 = 1,NCELC(2)
           K = K1 + NCEL(3,I)
           ICEL(3,1,K,I) = ICELC(2,1,K1)
           ICEL(3,2,K,I) = ICELC(2,2,K1)
 304       CONTINUE
C          NCEL(3,I) = NCEL(3,I) + NCELC(2)-1
 
           NCEL(3,I) = NCEL(3,I) + NCELC(2)
 
          IF (NFAC.EQ.3) THEN
           IF(NFA(I).EQ.3) THEN
 
             IFA(4,I) = IFAC(3)
             NCEL(4,I) = NCELC(3)
             IG(4,1,I) = IGC(3,1)
             IG(4,2,I) = IGC(3,2)
             DO 305 K = 1,NCELC(3)
             ICEL(4,1,K,I) = ICELC(3,1,K)
             ICEL(4,2,K,I) = ICELC(3,2,K)
 305         CONTINUE
             NFA(I) = 4
           ELSE
             WRITE(6,*) ' ERREUR '
           ENDIF
          ENDIF
 
        ENDIF
 
      ENDIF
 
C         WRITE(6,*) ' VERIF ',NFA(I)
C         NFAC = NFA(I)
C          WRITE(6,*) ' IFA  ',(IFA(I1,I),I1=1,NFAC)                    KAR02030
C          WRITE(6,*) ' NCEL ',(NCEL(I1,I),I1=1,NFAC)                   KAR02040
C          DO 105 I1 = 1,NFAC                                           KAR02050
C          WRITE(6,*) ' IG   ',IG(I1,1,I),IG(I1,2,I)                    KAR02060
C          WRITE(6,*) ' ICEL ',(ICEL(I1,1,K,I),K=1,NCEL(I1,I))          KAR02070
C          WRITE(6,*) ' JCEL ',(ICEL(I1,2,K,I),K=1,NCEL(I1,I))          KAR02080
C105       CONTINUE
C          WRITE(6,*) ' '
 
      RETURN
      END