C KCALAR SOURCE PV 11/03/07 21:17:16 6885 SUBROUTINE KCALAR(NR,XR1,IF1,KF1,XR2,IF2,KF2,NBFA,IFA,IG,NCEL,ICELKPR00020 - ,IC,KA,IM) KPR00030 IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C-------------------------------------------------------------------- C Calcul des facteurs de forme en 3D C Sp appele par KPROJA C C DETERMINATION DE LA PROJECTION D' UNE ARETE CONNUE PAR LA C PROJECTION DE SES SOMMETS SUR L'H.C DE RESOLUTION NR C C-------------------------------------------------------------------- DIMENSION XR1(3),KF1(2),XR2(3),KF2(2) KPR00040 DIMENSION IFA(3),IG(3,2),NCEL(3),ICEL(3,2,1),IC(2,1) KPR00050 DIMENSION KA(6),IM(6) KPR00060 DIMENSION P(3),M1(2),M2(2),KG(2) KPR00070 C NR2 = NR/2 KPR00090 C WRITE(6,*) ' IF1 IF2 ',IF1,IF2 KPR00100 C WRITE(6,*) ' XR1 ',XR1(1),XR1(2),XR1(3) KPR00100 C WRITE(6,*) ' XR2 ',XR2(1),XR2(2),XR2(3) KPR00100 IF ( IF1.EQ.IF2) THEN KPR00110 NBFA = 1 KPR00120 IFA(1) = IF1 KPR00130 CALL KBRESE(KF1,KF2,NC,IC,KG) KPR00140 IG(1,1) = KG(1) KPR00150 IG(1,2) = KG(2) KPR00160 NCEL(1) = NC KPR00170 DO 1 I = 1,NC KPR00180 ICEL(1,1,I) = IC(1,I) KPR00190 ICEL(1,2,I) = IC(2,I) KPR00200 1 CONTINUE KPR00210 ELSE KPR00220 IFA(1) = IF1 KPR00230 IFA(2) = IF2 KPR00240 K1 = KA(IF1) KPR00250 K2 = KA(IF2) KPR00260 IF(K1.EQ.K2) THEN KPR00270 NBFA = 0 KPR00280 RETURN KPR00290 ELSE KPR00300 K3 = 6- K1- K2 KPR00310 I1 = IM(IF1) KPR00320 I2 = IM(IF2) KPR00330 CALL KPVEC(XR1,XR2,P) KPR00340 C WRITE(6,*) ' P ',P(1),P(2),P(3) KPR00350 CV = DABS(P(K3)) C WRITE(6,*) ' CV ',CV IF (CV.GT.1E-4) THEN Y = XR1(K3) - (P(K2)/P(K3))*( XR2(K2) - XR1(K2)) KPR00360 ELSE Y = XR1(K3) ENDIF C WRITE(6,*) ' Y ',Y KPR00370 AY = DABS(Y) KPR00380 KPR00390 IF(AY.LE.1.001) THEN KPR00400 NBFA = 2 KPR00410 IIY = 1 + INT(NR2*(1.+Y)) KPR00420 IY = MIN0(NR,IIY) KPR00430 C WRITE(6,*) ' IY ',IY KPR00440 KPR00450 IF( K2.LT.K3) THEN KPR00460 M1(1) = I2 KPR00470 M1(2) = IY KPR00480 ELSE KPR00490 M1(1) = IY KPR00500 M1(2) = I2 KPR00510 ENDIF KPR00520 CALL KBRESE(KF1,M1,NC,IC,KG) KPR00530 NCEL(1) = NC KPR00540 DO 2 I = 1,NC KPR00550 ICEL(1,1,I) = IC(1,I) KPR00560 ICEL(1,2,I) = IC(2,I) KPR00570 2 CONTINUE KPR00580 C IG(1,1) = KG(1) KPR00590 C IG(1,2) = KG(2) KPR00600 IG(1,1) = M1(1) KPR00610 IG(1,2) = M1(2) KPR00620 KPR00630 IF( K1.LT.K3) THEN KPR00640 M2(1) = I1 KPR00650 M2(2) = IY KPR00660 ELSE KPR00670 M2(1) = IY KPR00680 M2(2) = I1 KPR00690 ENDIF KPR00700 CALL KBRESE(KF2,M2,NC,IC,KG) KPR00710 NCEL(2) = NC KPR00720 DO 3 I = 1,NC KPR00730 ICEL(2,1,I) = IC(1,I) KPR00740 ICEL(2,2,I) = IC(2,I) KPR00750 3 CONTINUE KPR00760 C IG(2,1) = KG(1) KPR00770 C IG(2,2) = KG(2) KPR00780 IG(2,1) = M2(1) KPR00790 IG(2,2) = M2(2) KPR00800 KPR00810 ELSE KPR00820 NBFA = 3 KPR00830 I3 = IM(IF1) KPR00840 KPR00850 IF(Y.GT.0.) THEN KPR00860 Y = 1. KPR00870 IFA(3) = 2*K3 - 1 KPR00880 ELSE KPR00890 Y= -1. KPR00900 IFA(3) = 2*K3 KPR00910 ENDIF KPR00920 I3 = IM(IFA(3)) KPR00930 CV = DABS(P(K2)) IF (CV.GT.1E-4) THEN X = XR1(K2) - (P(K3)/P(K2))*( Y - XR1(K3)) KPR00940 ELSE X = XR1(K2) ENDIF CV = DABS(P(K1)) IF (CV.GT.1E-4) THEN Z = XR2(K1) - (P(K3)/P(K1))*( Y - XR2(K3)) KPR00950 ELSE Z = XR2(K1) ENDIF C WRITE(6,*) ' X Z ',X,Z KPR00960 IIX = 1 + INT(NR2*(1+X)) KPR00970 IX = MIN0(NR,IIX) KPR00980 IIZ = 1 + INT(NR2*(1+Z)) KPR00990 IZ = MIN0(NR,IIZ) KPR01000 KPR01010 C FACE IF3 KPR01020 IF( K1.LT.K2) THEN KPR01030 M1(1) = I1 KPR01040 M1(2) = IX KPR01050 M2(1) = IZ KPR01060 M2(2) = I2 KPR01070 ELSE KPR01080 M1(1) = IX KPR01090 M1(2) = I1 KPR01100 M2(1) = I2 KPR01110 M2(2) = IZ KPR01120 ENDIF KPR01130 CALL KBRESE(M1,M2,NC,IC,KG) KPR01140 NCEL(3) = NC KPR01150 DO 4 I = 1,NC KPR01160 ICEL(3,1,I) = IC(1,I) KPR01170 ICEL(3,2,I) = IC(2,I) KPR01180 4 CONTINUE KPR01190 IG(3,1) = KG(1) KPR01200 IG(3,2) = KG(2) KPR01210 KPR01220 C FACE IF1 KPR01230 IF( K2.LT.K3) THEN KPR01240 M1(1) = IX KPR01250 M1(2) = I3 KPR01260 ELSE KPR01270 M1(1) = I3 KPR01280 M1(2) = IX KPR01290 ENDIF KPR01300 CALL KBRESE(KF1,M1,NC,IC,KG) KPR01310 NCEL(1) = NC KPR01320 DO 5 I = 1,NC KPR01330 ICEL(1,1,I) = IC(1,I) KPR01340 ICEL(1,2,I) = IC(2,I) KPR01350 5 CONTINUE KPR01360 C IG(1,1) = KG(1) KPR01370 C IG(1,2) = KG(2) KPR01380 IG(1,1) = M1(1) KPR01390 IG(1,2) = M1(2) KPR01400 KPR01410 C FACE IF2 KPR01420 IF( K1.LT.K3) THEN KPR01430 M2(1) = IZ KPR01440 M2(2) = I3 KPR01450 ELSE KPR01460 M2(1) = I3 KPR01470 M2(2) = IZ KPR01480 ENDIF KPR01490 CALL KBRESE(KF2,M2,NC,IC,KG) KPR01500 NCEL(2) = NC KPR01510 DO 6 I = 1,NC KPR01520 ICEL(2,1,I) = IC(1,I) KPR01530 ICEL(2,2,I) = IC(2,I) KPR01540 6 CONTINUE KPR01550 C IG(2,1) = KG(1) KPR01560 C IG(2,2) = KG(2) KPR01570 IG(2,1) = M2(1) KPR01580 IG(2,2) = M2(2) KPR01590 KPR01600 ENDIF KPR01610 ENDIF KPR01620 ENDIF KPR01630 KPR01640 C WRITE(6,*) ' NBFA ',NBFA KPR01650 C WRITE(6,*) ' IFA ',(IFA(I),I=1,NBFA) KPR01660 C WRITE(6,*) ' NCEL ',(NCEL(I),I=1,NBFA) KPR01670 C DO 10 I = 1,NBFA KPR01680 C WRITE(6,*) ' IG ',IG(I,1),IG(I,2) KPR01690 C WRITE(6,*) ' ICEL ',(ICEL(I,1,K),K=1,NCEL(I)) KPR01700 C WRITE(6,*) ' JCEL ',(ICEL(I,2,K),K=1,NCEL(I)) KPR01710 C10 CONTINUE KPR01720 C WRITE(6,*) KPR01730 RETURN KPR01740 END KPR01750 KPR01760