1 : C KCALAR SOURCE PV 11/03/07 21:17:16 6885 2 : SUBROUTINE KCALAR(NR,XR1,IF1,KF1,XR2,IF2,KF2,NBFA,IFA,IG,NCEL,ICELKPR00020 3 : - ,IC,KA,IM) KPR00030 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C-------------------------------------------------------------------- 7 : C Calcul des facteurs de forme en 3D 8 : C Sp appele par KPROJA 9 : C 10 : C DETERMINATION DE LA PROJECTION D' UNE ARETE CONNUE PAR LA 11 : C PROJECTION DE SES SOMMETS SUR L'H.C DE RESOLUTION NR 12 : C 13 : C-------------------------------------------------------------------- 14 : DIMENSION XR1(3),KF1(2),XR2(3),KF2(2) KPR00040 15 : DIMENSION IFA(3),IG(3,2),NCEL(3),ICEL(3,2,1),IC(2,1) KPR00050 16 : DIMENSION KA(6),IM(6) KPR00060 17 : DIMENSION P(3),M1(2),M2(2),KG(2) KPR00070 18 : C 19 : NR2 = NR/2 KPR00090 20 : C WRITE(6,*) ' IF1 IF2 ',IF1,IF2 KPR00100 21 : C WRITE(6,*) ' XR1 ',XR1(1),XR1(2),XR1(3) KPR00100 22 : C WRITE(6,*) ' XR2 ',XR2(1),XR2(2),XR2(3) KPR00100 23 : IF ( IF1.EQ.IF2) THEN KPR00110 24 : NBFA = 1 KPR00120 25 : IFA(1) = IF1 KPR00130 25 : CALL KBRESE(KF1,KF2,NC,IC,KG) KPR00140 26 : IG(1,1) = KG(1) KPR00150 27 : IG(1,2) = KG(2) KPR00160 28 : NCEL(1) = NC KPR00170 29 : DO 1 I = 1,NC KPR00180 30 : ICEL(1,1,I) = IC(1,I) KPR00190 31 : ICEL(1,2,I) = IC(2,I) KPR00200 32 : 1 CONTINUE KPR00210 33 : ELSE KPR00220 34 : IFA(1) = IF1 KPR00230 35 : IFA(2) = IF2 KPR00240 36 : K1 = KA(IF1) KPR00250 37 : K2 = KA(IF2) KPR00260 38 : IF(K1.EQ.K2) THEN KPR00270 39 : NBFA = 0 KPR00280 40 : RETURN KPR00290 41 : ELSE KPR00300 42 : K3 = 6- K1- K2 KPR00310 43 : I1 = IM(IF1) KPR00320 44 : I2 = IM(IF2) KPR00330 44 : CALL KPVEC(XR1,XR2,P) KPR00340 45 : C WRITE(6,*) ' P ',P(1),P(2),P(3) KPR00350 46 : CV = DABS(P(K3)) 47 : C WRITE(6,*) ' CV ',CV 48 : IF (CV.GT.1E-4) THEN 49 : Y = XR1(K3) - (P(K2)/P(K3))*( XR2(K2) - XR1(K2)) KPR00360 50 : ELSE 51 : Y = XR1(K3) 52 : ENDIF 53 : C WRITE(6,*) ' Y ',Y KPR00370 54 : AY = DABS(Y) KPR00380 55 : KPR00390 56 : IF(AY.LE.1.001) THEN KPR00400 57 : NBFA = 2 KPR00410 58 : IIY = 1 + INT(NR2*(1.+Y)) KPR00420 59 : IY = MIN0(NR,IIY) KPR00430 60 : C WRITE(6,*) ' IY ',IY KPR00440 61 : KPR00450 62 : IF( K2.LT.K3) THEN KPR00460 63 : M1(1) = I2 KPR00470 64 : M1(2) = IY KPR00480 65 : ELSE KPR00490 66 : M1(1) = IY KPR00500 67 : M1(2) = I2 KPR00510 68 : ENDIF KPR00520 68 : CALL KBRESE(KF1,M1,NC,IC,KG) KPR00530 69 : NCEL(1) = NC KPR00540 70 : DO 2 I = 1,NC KPR00550 71 : ICEL(1,1,I) = IC(1,I) KPR00560 72 : ICEL(1,2,I) = IC(2,I) KPR00570 73 : 2 CONTINUE KPR00580 74 : C IG(1,1) = KG(1) KPR00590 75 : C IG(1,2) = KG(2) KPR00600 76 : IG(1,1) = M1(1) KPR00610 77 : IG(1,2) = M1(2) KPR00620 78 : KPR00630 79 : IF( K1.LT.K3) THEN KPR00640 80 : M2(1) = I1 KPR00650 81 : M2(2) = IY KPR00660 82 : ELSE KPR00670 83 : M2(1) = IY KPR00680 84 : M2(2) = I1 KPR00690 85 : ENDIF KPR00700 85 : CALL KBRESE(KF2,M2,NC,IC,KG) KPR00710 86 : NCEL(2) = NC KPR00720 87 : DO 3 I = 1,NC KPR00730 88 : ICEL(2,1,I) = IC(1,I) KPR00740 89 : ICEL(2,2,I) = IC(2,I) KPR00750 90 : 3 CONTINUE KPR00760 91 : C IG(2,1) = KG(1) KPR00770 92 : C IG(2,2) = KG(2) KPR00780 93 : IG(2,1) = M2(1) KPR00790 94 : IG(2,2) = M2(2) KPR00800 95 : KPR00810 96 : ELSE KPR00820 97 : NBFA = 3 KPR00830 98 : I3 = IM(IF1) KPR00840 99 : KPR00850 100 : IF(Y.GT.0.) THEN KPR00860 101 : Y = 1. KPR00870 102 : IFA(3) = 2*K3 - 1 KPR00880 103 : ELSE KPR00890 104 : Y= -1. KPR00900 105 : IFA(3) = 2*K3 KPR00910 106 : ENDIF KPR00920 107 : I3 = IM(IFA(3)) KPR00930 108 : 109 : CV = DABS(P(K2)) 110 : IF (CV.GT.1E-4) THEN 111 : X = XR1(K2) - (P(K3)/P(K2))*( Y - XR1(K3)) KPR00940 112 : ELSE 113 : X = XR1(K2) 114 : ENDIF 115 : 116 : CV = DABS(P(K1)) 117 : IF (CV.GT.1E-4) THEN 118 : Z = XR2(K1) - (P(K3)/P(K1))*( Y - XR2(K3)) KPR00950 119 : ELSE 120 : Z = XR2(K1) 121 : ENDIF 122 : C WRITE(6,*) ' X Z ',X,Z KPR00960 123 : IIX = 1 + INT(NR2*(1+X)) KPR00970 124 : IX = MIN0(NR,IIX) KPR00980 125 : IIZ = 1 + INT(NR2*(1+Z)) KPR00990 126 : IZ = MIN0(NR,IIZ) KPR01000 127 : KPR01010 128 : C FACE IF3 KPR01020 129 : IF( K1.LT.K2) THEN KPR01030 130 : M1(1) = I1 KPR01040 131 : M1(2) = IX KPR01050 132 : M2(1) = IZ KPR01060 133 : M2(2) = I2 KPR01070 134 : ELSE KPR01080 135 : M1(1) = IX KPR01090 136 : M1(2) = I1 KPR01100 137 : M2(1) = I2 KPR01110 138 : M2(2) = IZ KPR01120 139 : ENDIF KPR01130 139 : CALL KBRESE(M1,M2,NC,IC,KG) KPR01140 140 : NCEL(3) = NC KPR01150 141 : DO 4 I = 1,NC KPR01160 142 : ICEL(3,1,I) = IC(1,I) KPR01170 143 : ICEL(3,2,I) = IC(2,I) KPR01180 144 : 4 CONTINUE KPR01190 145 : IG(3,1) = KG(1) KPR01200 146 : IG(3,2) = KG(2) KPR01210 147 : KPR01220 148 : C FACE IF1 KPR01230 149 : IF( K2.LT.K3) THEN KPR01240 150 : M1(1) = IX KPR01250 151 : M1(2) = I3 KPR01260 152 : ELSE KPR01270 153 : M1(1) = I3 KPR01280 154 : M1(2) = IX KPR01290 155 : ENDIF KPR01300 155 : CALL KBRESE(KF1,M1,NC,IC,KG) KPR01310 156 : NCEL(1) = NC KPR01320 157 : DO 5 I = 1,NC KPR01330 158 : ICEL(1,1,I) = IC(1,I) KPR01340 159 : ICEL(1,2,I) = IC(2,I) KPR01350 160 : 5 CONTINUE KPR01360 161 : C IG(1,1) = KG(1) KPR01370 162 : C IG(1,2) = KG(2) KPR01380 163 : IG(1,1) = M1(1) KPR01390 164 : IG(1,2) = M1(2) KPR01400 165 : KPR01410 166 : C FACE IF2 KPR01420 167 : IF( K1.LT.K3) THEN KPR01430 168 : M2(1) = IZ KPR01440 169 : M2(2) = I3 KPR01450 170 : ELSE KPR01460 171 : M2(1) = I3 KPR01470 172 : M2(2) = IZ KPR01480 173 : ENDIF KPR01490 173 : CALL KBRESE(KF2,M2,NC,IC,KG) KPR01500 174 : NCEL(2) = NC KPR01510 175 : DO 6 I = 1,NC KPR01520 176 : ICEL(2,1,I) = IC(1,I) KPR01530 177 : ICEL(2,2,I) = IC(2,I) KPR01540 178 : 6 CONTINUE KPR01550 179 : C IG(2,1) = KG(1) KPR01560 180 : C IG(2,2) = KG(2) KPR01570 181 : IG(2,1) = M2(1) KPR01580 182 : IG(2,2) = M2(2) KPR01590 183 : KPR01600 184 : ENDIF KPR01610 185 : ENDIF KPR01620 186 : ENDIF KPR01630 187 : KPR01640 188 : C WRITE(6,*) ' NBFA ',NBFA KPR01650 189 : C WRITE(6,*) ' IFA ',(IFA(I),I=1,NBFA) KPR01660 190 : C WRITE(6,*) ' NCEL ',(NCEL(I),I=1,NBFA) KPR01670 191 : C DO 10 I = 1,NBFA KPR01680 192 : C WRITE(6,*) ' IG ',IG(I,1),IG(I,2) KPR01690 193 : C WRITE(6,*) ' ICEL ',(ICEL(I,1,K),K=1,NCEL(I)) KPR01700 194 : C WRITE(6,*) ' JCEL ',(ICEL(I,2,K),K=1,NCEL(I)) KPR01710 195 : C10 CONTINUE KPR01720 196 : C WRITE(6,*) KPR01730 197 : RETURN KPR01740 198 : END KPR01750 199 : KPR01760 200 : 201 : 202 :
© Cast3M 2003 - All rights reserved.
Disclaimer