1 : C KPROJA SOURCE CHAT 05/01/13 01:05:08 5004 2 : SUBROUTINE KPROJA(O1,XG1,XG2,X1,KF1,KC1,X2,KF2,KC2,I,SPROJA,SHC3D) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C---------------------------------------------------------------------- 6 : C Calcul des facteurs de forme en 3D 7 : C Sp appele par Kprojf et Ksubcr 8 : C 9 : C PROJECTION DES ARETES 10 : C --------------------- 11 : C 12 : C O1 : POINT SUR L'ELEMENT 1 13 : C XG1: COORDONNEES GLOBALES DU SOMMET 1 14 : C X1 : COORDONNEES SUR L'H.C 15 : C KF1: FACE SUR L'H.C 16 : C KC1: COORDONNEES ENTIERES SUR L'H.C 17 : C idem point 2 18 : C---------------------------------------------------------------------- 19 : -INC TFFOR3D 20 : C 21 : DIMENSION X1(3),X2(3),KC1(2),KC2(2) 22 : DIMENSION IFAC(3),IGC(3,2),NCELC(3) 23 : DIMENSION O1(3),X(3),XR(3),KI(2),XG1(1),XG2(1) 24 : C 25 : C WRITE(6,*) ' KPROJA KF ',KF1,KF2 26 : C WRITE(6,*) ' KPROJA KA ',KA(KF1),KA(KF2) 27 : C WRITE(6,*) ' XG1 ',XG1(1),XG1(2),XG1(3) 28 : C WRITE(6,*) ' XG2 ',XG2(1),XG2(2),XG2(3) 29 : 30 : IF ((KA(KF1).NE.KA(KF2)).OR.(KF1.EQ.KF2)) THEN 31 : 31 : CALL KCALAR(NRES,X1,KF1,KC1,X2,KF2,KC2, 32 : - NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM) 33 : 34 : C WRITE(6,*) ' IF1 IF2 NFA ',KF(NP1),KF(NP2),NFAC KAR02020 35 : C WRITE(6,*) ' X1 ',X1(1),X1(2),X1(3) 36 : C WRITE(6,*) ' X2 ',X2(1),X2(2),X2(3) 37 : 38 : NFA(I) = NFAC 39 : DO 332 J = 1,NFAC 40 : IFA(J,I) = IFAC(J) 41 : NCEL(J,I) = NCELC(J) 42 : IG(J,1,I) = IGC(J,1) 43 : IG(J,2,I) = IGC(J,2) 44 : DO 334 K = 1,NCELC(J) 45 : ICEL(J,1,K,I) = ICELC(J,1,K) 46 : ICEL(J,2,K,I) = ICELC(J,2,K) 47 : 334 CONTINUE 48 : 332 CONTINUE 49 : 50 : ELSE 51 : 52 : DO 1 K=1,KES 53 : X(K) = (XG1(K)+XG2(K))/2 54 : 1 CONTINUE 55 : C 56 : II = 0 57 : C WRITE(6,*) ' KA ',KA(KF1) 58 : KAC = KA(KF1) 59 : 10 CONTINUE 60 : II = II + 1 60 : C IF (II.GT.20) CALL ARRET(0) 61 : C 05-90 62 : IF (II.GT.20) THEN 63 : RETURN 64 : ENDIF 64 : CALL KAPCU1(KES,X,O1,NRES,XR,KF,KI,KAC) 65 : C WRITE(6,*) ' KF ',KF 66 : C WRITE(6,*) ' O1 ',O1(1),O1(2),O1(3) 67 : 68 : IF (KF.EQ.KF1) THEN 69 : 70 : DO 2 K = 1,KES 71 : X(K) = (X(K)+XG2(K))/2 72 : 2 CONTINUE 73 : GOTO 10 74 : ELSE 75 : IF(KF.EQ.KF2) THEN 76 : DO 3 K = 1,KES 77 : X(K) = (XG1(K)+X(K))/2 78 : 3 CONTINUE 79 : GOTO 10 80 : ELSE 81 : 82 : C KF1 KF2 KF KFP 83 : C 83 : CALL KCALAR(NRES,X1,KF1,KC1,XR,KF,KI, 84 : - NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM) 85 : 86 : IFA(1,I) = IFAC(1) 87 : NCEL(1,I) = NCELC(1) 88 : IG(1,1,I) = IGC(1,1) 89 : IG(1,2,I) = IGC(1,2) 90 : DO 300 K = 1,NCELC(1) 91 : ICEL(1,1,K,I) = ICELC(1,1,K) 92 : ICEL(1,2,K,I) = ICELC(1,2,K) 93 : 300 CONTINUE 94 : 95 : IFA(3,I) = IFAC(2) 96 : NCEL(3,I) = NCELC(2) 97 : IG(3,1,I) = IGC(2,1) 98 : IG(3,2,I) = IGC(2,2) 99 : DO 301 K = 1,NCELC(2) 100 : ICEL(3,1,K,I) = ICELC(2,1,K) 101 : ICEL(3,2,K,I) = ICELC(2,2,K) 102 : 301 CONTINUE 103 : 104 : IF (NFAC.EQ.3) THEN 105 : IFA(4,I) = IFAC(3) 106 : NCEL(4,I) = NCELC(3) 107 : IG(4,1,I) = IGC(3,1) 108 : IG(4,2,I) = IGC(3,2) 109 : DO 302 K = 1,NCELC(3) 110 : ICEL(4,1,K,I) = ICELC(3,1,K) 111 : ICEL(4,2,K,I) = ICELC(3,2,K) 112 : 302 CONTINUE 113 : NFA(I) = 4 114 : ELSE 115 : NFA(I) = 3 116 : ENDIF 117 : 118 : ENDIF 119 : 119 : CALL KCALAR(NRES,X2,KF2,KC2,XR,KF,KI, 120 : - NFAC,IFAC,IGC,NCELC,ICELC,IC,KA,IM) 121 : 122 : 123 : IFA(2,I) = IFAC(1) 124 : NCEL(2,I) = NCELC(1) 125 : IG(2,1,I) = IGC(1,1) 126 : IG(2,2,I) = IGC(1,2) 127 : DO 303 K = 1,NCELC(1) 128 : ICEL(2,1,K,I) = ICELC(1,1,K) 129 : ICEL(2,2,K,I) = ICELC(1,2,K) 130 : 303 CONTINUE 131 : 132 : IG(3,1,I) = (IG(3,1,I) + IGC(2,1)) /2 133 : IG(3,2,I) = (IG(3,2,I) + IGC(2,2)) /2 134 : C DO 304 K1 = 1,NCELC(2)-1 135 : 136 : DO 304 K1 = 1,NCELC(2) 137 : K = K1 + NCEL(3,I) 138 : ICEL(3,1,K,I) = ICELC(2,1,K1) 139 : ICEL(3,2,K,I) = ICELC(2,2,K1) 140 : 304 CONTINUE 141 : C NCEL(3,I) = NCEL(3,I) + NCELC(2)-1 142 : 143 : NCEL(3,I) = NCEL(3,I) + NCELC(2) 144 : 145 : IF (NFAC.EQ.3) THEN 146 : IF(NFA(I).EQ.3) THEN 147 : 148 : IFA(4,I) = IFAC(3) 149 : NCEL(4,I) = NCELC(3) 150 : IG(4,1,I) = IGC(3,1) 151 : IG(4,2,I) = IGC(3,2) 152 : DO 305 K = 1,NCELC(3) 153 : ICEL(4,1,K,I) = ICELC(3,1,K) 154 : ICEL(4,2,K,I) = ICELC(3,2,K) 155 : 305 CONTINUE 156 : NFA(I) = 4 157 : ELSE 158 : WRITE(6,*) ' ERREUR ' 159 : ENDIF 160 : ENDIF 161 : 162 : ENDIF 163 : 164 : ENDIF 165 : 166 : C WRITE(6,*) ' VERIF ',NFA(I) 167 : C NFAC = NFA(I) 168 : C WRITE(6,*) ' IFA ',(IFA(I1,I),I1=1,NFAC) KAR02030 169 : C WRITE(6,*) ' NCEL ',(NCEL(I1,I),I1=1,NFAC) KAR02040 170 : C DO 105 I1 = 1,NFAC KAR02050 171 : C WRITE(6,*) ' IG ',IG(I1,1,I),IG(I1,2,I) KAR02060 172 : C WRITE(6,*) ' ICEL ',(ICEL(I1,1,K,I),K=1,NCEL(I1,I)) KAR02070 173 : C WRITE(6,*) ' JCEL ',(ICEL(I1,2,K,I),K=1,NCEL(I1,I)) KAR02080 174 : C105 CONTINUE 175 : C WRITE(6,*) ' ' 176 : 177 : RETURN 178 : END 179 : 180 :
© Cast3M 2003 - All rights reserved.
Disclaimer