Télécharger la plaquette Cast3M


fr en

Télécharger ksubcr.eso

Retour à la liste

Numérotation des lignes : 

ksubcr

  1. C KSUBCR    SOURCE    CHAT      05/01/13    01:09:07     5004
  2.       SUBROUTINE KSUBCR(O1,KSUB,NSUB,AA,SHC3D,SPROGP,SPROJA)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C----------------------------------------------------------------------
  6. C Calcul des facteurs de forme en 3D
  7. C Sp appele par Kprojf
  8. C     Determination de la projection des sommets et des aretes
  9. C
  10. C     O1      : POINT DE VUE PRIS SUR K1
  11. C     AA      : SOMMETS DU TRIANGLE DE LA FACE K2
  12. C     U2      : NORMALE A LA FACE K2
  13. C
  14. C----------------------------------------------------------------------
  15. C
  16.       DIMENSION U2(4),AA(3,3,4)
  17.       DIMENSION X1(3),X2(3),KC1(2),KC2(2)
  18.       DIMENSION O1(3),O2(3),XG1(3),XG2(3)
  19.       DIMENSION KG(2),KH(2)
  20. -INC TFFOR3D
  21.       SEGMENT SPROGP
  22.       INTEGER  KF(NPT),ICOO(2,NPT)
  23.       REAL*8   XR(3,NPT)
  24.       ENDSEGMENT
  25. C
  26.       NPT=KF(/1)
  27.       NSE=NFA(/1)
  28. C     WRITE(6,*) ' KSUBCR : NPT NSE KSUB NSUB ',NPT,NSE,KSUB,NSUB
  29.  
  30. C    SOMMETS
  31. C    -------
  32.             DO 320 I = 1,NPT
  33.               DO 322 K=1,KES
  34.               O2(K) = AA(K,I,KSUB)
  35.  322          CONTINUE
  36.  
  37.               CALL KAPCUB(KES,O2,O1,NRES,X1,KF(I),ICOO(1,I),ICOO(2,I))
  38. C             WRITE(6,*) KF(I),ICOO(1,I),ICOO(2,I)
  39. C             WRITE(6,*) ' XR ',(X1(I1),I1=1,KES)
  40.  
  41.               DO 323 K = 1,KES
  42.               XR(K,I) = X1(K)
  43.  323          CONTINUE
  44.  320        CONTINUE
  45. C
  46. C   ARETES
  47. C   ------
  48.             DO 330 I = 1,NSE
  49.               NP1 = I
  50.               NP2 = I + 1
  51.               IF(I.EQ.3) NP2 = 1
  52.               DO 331 K = 1,KES
  53.               X1(K) = XR(K,NP1)
  54.               X2(K) = XR(K,NP2)
  55.               XG1(K) = AA(K,NP1,KSUB)
  56.               XG2(K) = AA(K,NP2,KSUB)
  57.  331          CONTINUE
  58.  
  59.               KC1(1) = ICOO(1,NP1)
  60.               KC1(2) = ICOO(2,NP1)
  61.               KC2(1) = ICOO(1,NP2)
  62.               KC2(2) = ICOO(2,NP2)
  63.               KF1 = KF(NP1)
  64.               KF2 = KF(NP2)
  65.               CALL KPROJA(O1,XG1,XG2,X1,KF1,KC1,X2,KF2,KC2
  66.      &                  ,I,SPROJA,SHC3D)
  67.  
  68.  330        CONTINUE
  69. C
  70. C     WRITE(6,*) '<KSUBCR : NPT NSE KSUB NSUB ',NPT,NSE,KSUB,NSUB
  71.       RETURN
  72.       END
  73.  
  74.  
  75.  

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