Télécharger la plaquette Cast3M


fr en

Télécharger kapcub.eso

Retour à la liste

Numérotation des lignes : 

kapcub

  1. C KAPCUB    SOURCE    CB215821  16/04/21    21:17:26     8920
  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=ABS(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.  
  90.  
  91.  
  92.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales