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