Esope source files

   1 : C KAPCUB    SOURCE    PV        11/03/07    21:17:15     6885           
   2 :       SUBROUTINE  KAPCUB(NES,X,A,NR,XR,IFACE,KFACE1,KFACE2)
   3 : *
   4 : C-----------------------------------------------------------------------
   5 : C Calcul des facteurs de forme en 3D
   6 : C Sp appele par ksubcr
   7 : C     PROJECTION D'UN POINT X SUR L'H.C  DE RESOLUTION NR                       
   8 : C     ---------------------------------------------------                       
   9 : C     A   : CENTRE DE L'H.C                                                     
  10 : C     IFACE : NUMERO DE FACE                                                    
  11 : C     KFACE1,KFACE2 : COORDONNEES ENTIERES SUR LA FACE
  12 : C                                                                               
  13 : C-----------------------------------------------------------------------
  14 : *
  15 : *
  16 :       IMPLICIT INTEGER(I-N)
  17 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
  18 :       DIMENSION X(NES),A(NES),XA(3),XR(NES)
  19 : C
  20 :       NR2 = NR/2
  21 :       EPS=1E-5
  22 :       XAB = -EPS
  23 :       A1 = -1E-10
  24 : 
  25 :         DO 1  IES = 1,NES
  26 :          XA(IES) = X(IES)-A(IES)
  27 :          A2=DABS(XA(IES))
  28 :          IF(A2.GT.A1) THEN
  29 :            A1 = A2
  30 :            I = IES
  31 :          ENDIF
  32 :  1      CONTINUE
  33 : C
  34 : C     WRITE(6,*) 'A1 XA(I) ',A1,XA(I)
  35 :       KS = KSIG(XA(I),EPS)
  36 : C     WRITE(6,*) ' KS ',KS
  37 : C
  38 :       IF (I.EQ.1) THEN
  39 :            XR(2) = XA(2)/A1
  40 :            XR(3) = XA(3)/A1
  41 :            I1 = 1 + INT(NR2*(1+XR(2)))
  42 :            I2 = 1 + INT(NR2*(1+XR(3)))
  43 :            KFACE1 = MIN0(NR,I1)
  44 :            KFACE2 = MIN0(NR,I2)
  45 :            IF(KS.EQ.1) THEN
  46 :            IFACE= 1
  47 :            XR(1) = 1.
  48 :            ELSE
  49 :            IFACE = 2
  50 :            XR(1) = -1.
  51 :            ENDIF
  52 :            RETURN
  53 :       ENDIF
  54 :       IF (I.EQ.2) THEN
  55 :            XR(1) = XA(1)/A1
  56 :            XR(3) = XA(3)/A1
  57 :            I1 = 1 + INT(NR2*(1+XR(1)))
  58 :            I2 = 1 + INT(NR2*(1+XR(3)))
  59 :            KFACE1 = MIN0(NR,I1)
  60 :            KFACE2 = MIN0(NR,I2)
  61 :            IF(KS.EQ.1) THEN
  62 :            IFACE    = 3
  63 :            XR(2) =  1.
  64 :            ELSE
  65 :            IFACE    = 4
  66 :            XR(2) = -1.
  67 :            ENDIF
  68 :            RETURN
  69 :       ENDIF
  70 :       IF (I.EQ.3) THEN
  71 :            XR(1) = XA(1)/A1
  72 :            XR(2) = XA(2)/A1
  73 :            I1 = 1 + INT(NR2*(1+XR(1)))
  74 :            I2 = 1 + INT(NR2*(1+XR(2)))
  75 :            KFACE1 = MIN0(NR,I1)
  76 :            KFACE2 = MIN0(NR,I2)
  77 :            IF(KS.EQ.1) THEN
  78 :            IFACE    = 5
  79 :            XR(3) =  1.
  80 :            ELSE
  81 :            IFACE    = 6
  82 :            XR(3) = -1.
  83 :            ENDIF
  84 :            RETURN
  85 :       ENDIF
  86 :       END
  87 :  
  88 :  
  89 :