Sources Esope | Cast3M

kprojf
C KPROJF    SOURCE    PV        22/04/15    13:20:10     11344          
      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,4)
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