Esope source files

   1 : C KAPC21    SOURCE    PV        11/03/07    21:17:10     6885           
   2 :       SUBROUTINE  KAPC21(NES,X,A,NR,XR,IFACE,KFACE,KAC)
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)                                                 
   5 : C
   6 : C     CAS DE 2 FACES PARALLELES: DIRECTION KAC                                  
   7 : C     ----------------------------------------                                  
   8 : C     A   : CENTRE DE L'H.C
   9 : C     IFACE : NUMERO DE FACE
  10 : C     KFACE : COORDONNEES ENTIERES SUR LA FACE
  11 : C
  12 :       DIMENSION X(NES),A(NES),XA(2),XR(NES)
  13 : C
  14 :       NR2 = NR/2
  15 :       EPS=1D-5
  16 :       XAB = -EPS
  17 :       A1 = -1D-10
  18 :                                                                                 
  19 :         DO 1  IES = 1,NES
  20 :          XA(IES) = X(IES)-A(IES)
  21 :          A2=DABS(XA(IES))
  22 :          IF(A2.GT.A1) THEN
  23 :            A1 = A2
  24 :            I = IES
  25 :          ENDIF
  26 :  1      CONTINUE
  27 : C
  28 :       IF (I.EQ.KAC) THEN
  29 :         DO 2 IES = 1,NES                                                        
  30 :            A2 = DABS(XA(IES))                                                   
  31 :            ERR = DABS(1.-A2/A1)                                                 
  32 :            IF (IES.EQ.I.AND.ERR.LT.0.01) THEN                                   
  33 :            I = IES                                                              
  34 :            GOTO 3                                                               
  35 :            ENDIF                                                                
  36 :  2      CONTINUE                                                                
  37 :       ENDIF                                                                     
  38 :                                                                                 
  39 :  3      CONTINUE                                                                
  40 :                                                                                 
  41 : C     WRITE(6,*) 'A1 XA(I) ',A1,XA(I)
  42 :       KS = KSIG(XA(I),EPS)
  43 : C     WRITE(6,*) ' KS ',KS
  44 : C
  45 :       IF (I.EQ.1) THEN
  46 :            XR(2) = XA(2)/A1
  47 :            I1 = 1 + INT(NR2*(1+XR(2)))
  48 :            KFACE = MIN0(NR,I1)
  49 :            IF(KS.EQ.1) THEN
  50 :            IFACE= 1
  51 :            XR(1) = 1.
  52 :            ELSE
  53 :            IFACE = 2
  54 :            XR(1) = -1.
  55 :            ENDIF
  56 :            RETURN
  57 :       ENDIF
  58 :       IF (I.EQ.2) THEN
  59 :            XR(1) = XA(1)/A1
  60 :            I1 = 1 + INT(NR2*(1+XR(1)))
  61 :            KFACE    = MIN0(NR,I1)
  62 :            IF(KS.EQ.1) THEN
  63 :            IFACE    = 3
  64 :            XR(2) =  1.
  65 :            ELSE
  66 :            IFACE    = 4
  67 :            XR(2) = -1.
  68 :            ENDIF
  69 :            RETURN
  70 :       ENDIF
  71 :       END
  72 :  
  73 :