C KPROJF SOURCE CHAT 05/01/13 01:05:13 5004 SUBROUTINE KPROJF(O1,A0,K1,K2 * ,C,U2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C---------------------------------------------------------------------- C Calcul des facteurs de forme en 3D C Sp appele par FACGEN C PROJECTION DE LA FACE K2 PAR RAPPORT A UN POINT DE VUE PRIS C SUR LA FACE K1 (SP KPROJG) C ON DIVISE LA FACE K2 EN CAS D ERREUR ( SP KSUBDV) C C SP APPELE PAR KALFAC C C O1 : POINT DE VUE PRIS SUR K1 C A0 : SOMMETS DU TRIANGLE DE LA FACE K2 C K1 : INDICE DE LA PREMIERE FACE C K2 : INDICE DE LA DEUXIEME FACE C U2 : NORMALE A LA FACE K2 C C NI LES POINTS NI LES ARETES N'ONT ETE PROJETES ANTERIEUREMENT C ON TRAITE LE NIVEAU 0 COMME LES SUIVANTS C C---------------------------------------------------------------------- C DIMENSION O1(3),U2(4),A0(3,3) C TABLEAUX DE TRAVAIL DIMENSION AA0(3,3,4) DIMENSION A1(3,3),AA1(3,3,4) DIMENSION A2(3,3),AA2(3,3,4) DIMENSION A3(3,3),AA3(3,3,4) DIMENSION A4(3,3),AA4(3,3,4) DIMENSION A5(3,3),AA5(3,3,4) DIMENSION A6(3,3),AA6(3,3,4) DIMENSION BBB(3,3,1) C -INC TFFOR3D C C-------------------------------------------------------------- SEGMENT SPROGP INTEGER KF(NPT),ICOO(2,NPT) REAL*8 XR(3,NPT) ENDSEGMENT C-------------------------------------------------------------- SEGMENT SKCEL INTEGER KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC) REAL*8 RMAX ENDSEGMENT C C-------------------------------------------------------------------- C C NIVEAU 0 C -------- C DEFINITION DE BBB C DO 11 K=1,3 DO 12 I=1,3 BBB(K,I,1) = A0(K,I) 12 CONTINUE 11 CONTINUE NSUB = 1 KSUB = 1 CALL KSUBCR(O1,KSUB,NSUB,BBB,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) RETURN C WRITE(6,*) ' NIV 0 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB C NIVEAU 1 C -------- CALL KSUBDV(A0,AA0,NSUB) DO 100 KSUB = 1,NSUB CALL KSUBCR(O1,KSUB,NSUB,AA0,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 100 C WRITE(6,*) ' NIV 1 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB C C NIVEAU 2 C -------- C C DEFIINITION DE A1 C DO 110 K=1,3 DO 111 I=1,3 A1(K,I) = AA0(K,I,KSUB) 111 CONTINUE 110 CONTINUE C CALL KSUBDV(A1,AA1,NSUB2) DO 200 KSUB2 = 1,NSUB2 CALL KSUBCR(O1,KSUB2,NSUB2,AA1,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 200 C WRITE(6,*) ' NIV 2 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB2 C NIVEAU 3 C -------- C C DEFIINITION DE A2 C DO 210 K=1,3 DO 211 I=1,3 A2(K,I) = AA1(K,I,KSUB2) 211 CONTINUE 210 CONTINUE C CALL KSUBDV(A2,AA2,NSUB3) DO 300 KSUB3 = 1,NSUB3 CALL KSUBCR(O1,KSUB3,NSUB3,AA2,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 300 C WRITE(6,*) ' NIV 3 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB3 C NIVEAU 4 C -------- C C DEFIINITION DE A3 C DO 310 K=1,3 DO 311 I=1,3 A3(K,I) = AA2(K,I,KSUB3) 311 CONTINUE 310 CONTINUE C CALL KSUBDV(A3,AA3,NSUB4) DO 400 KSUB4 = 1,NSUB4 CALL KSUBCR(O1,KSUB4,NSUB4,AA3,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 400 C WRITE(6,*) ' NIV 4 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB4 C** C NIVEAU 5 C -------- C C DEFIINITION DE A4 C DO 410 K=1,3 DO 411 I=1,3 A4(K,I) = AA3(K,I,KSUB4) 411 CONTINUE 410 CONTINUE C CALL KSUBDV(A4,AA4,NSUB5) DO 500 KSUB5 = 1,NSUB5 CALL KSUBCR(O1,KSUB5,NSUB5,AA4,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 500 C WRITE(6,*) ' NIV 5 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5 C NIVEAU 6 C -------- C C DEFIINITION DE A5 C DO 510 K=1,3 DO 511 I=1,3 A5(K,I) = AA4(K,I,KSUB4) 511 CONTINUE 510 CONTINUE C CALL KSUBDV(A5,AA5,NSUB6) DO 600 KSUB6 = 1,NSUB6 CALL KSUBCR(O1,KSUB6,NSUB6,AA5,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 600 C WRITE(6,*) ' NIV 6 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5 C NIVEAU 7 C -------- C C DEFIINITION DE A6 C DO 610 K=1,3 DO 611 I=1,3 A6(K,I) = AA5(K,I,KSUB4) 611 CONTINUE 610 CONTINUE C CALL KSUBDV(A6,AA6,NSUB7) DO 700 KSUB7 = 1,NSUB7 CALL KSUBCR(O1,KSUB7,NSUB7,AA6,SHC3D,SPROGP,SPROJA) NNF1 = KF(1) NNF2 = KF(2) NNF3 = KF(3) CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) IF (KERR.EQ.0) GOTO 700 C WRITE(6,*) ' NIV 7 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5 WRITE(6,900) K2,K1,KERR 900 FORMAT(1X,' LA FACE ',I4,' EST GRANDE OU TRES PROCHE DE LA FACE ' $,I4,' NIVEAU D ERREUR ',I2) C** 700 CONTINUE 600 CONTINUE 500 CONTINUE C** 400 CONTINUE 300 CONTINUE 200 CONTINUE 100 CONTINUE RETURN END