Télécharger la plaquette Cast3M


fr en

Télécharger bcirco.eso

Retour à la liste

Numérotation des lignes : 

bcirco

  1. C BCIRCO    SOURCE    BP208322  16/11/18    21:15:14     9177           
  2.       SUBROUTINE BCIRCO(IRN1,IPT0,JEL,XC,XR)
  3. C---------------------------------------------------------------------C
  4. C     BCIRCO renvoie les coordonnees du centre et le rayon de la      C
  5. C     boule circonscrite a l'element JEL du MELEME IPT0.              C
  6. C                                                                     C
  7. C     IPT0 : pointeur de type MELEME actif en entree et en sortie     C
  8. C     JEL  : numero de l'element de IPT0 dont on cherche le centre et C
  9. C            le rayon de la boule circonscrite                        C
  10. C     XC   : vecteur de dimension IDIM contenant les coordonnees du   C
  11. C            centre de la boule circonscrite                          C
  12. C     XR   : rayon de la boule circonscrite                           C
  13. C---------------------------------------------------------------------C
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8 (A-H,O-Z)
  16. c
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC SMELEME
  21. -INC SMCOORD
  22. -INC CCGEOME
  23.       DIMENSION XC(3),XPTS(4,3),A(3,3),B(3,1),BB(4),XM(4,3)
  24. C
  25.       DIMENSION RPTS(4),XPTS1(3),YPTS1(3),ZPTS1(3),W(3)
  26.  
  27.       SEGMENT RAYONOE
  28.          REAL*8 RAYN(NBNER)
  29.       ENDSEGMENT
  30.       POINTEUR IRN1.RAYONOE
  31.  
  32.  
  33.       IDIMP1=IDIM+1
  34.       IPT1=IPT0
  35. c
  36.       DO I=1,IDIMP1
  37.           RPTS(I)=IRN1.RAYN(IPT1.NUM(I,JEL))
  38.       END DO
  39. C
  40.       IF (IDIM.EQ.3) THEN
  41.          IREF1=(IPT1.NUM(1,JEL)-1)*IDIMP1
  42.          IREF2=(IPT1.NUM(2,JEL)-1)*IDIMP1
  43.          IREF3=(IPT1.NUM(3,JEL)-1)*IDIMP1
  44.          IREF4=(IPT1.NUM(4,JEL)-1)*IDIMP1
  45.          XPTS(1,1)=XCOOR(IREF1+1)
  46.          XPTS(1,2)=XCOOR(IREF1+2)
  47.          XPTS(1,3)=XCOOR(IREF1+3)
  48.          XPTS(2,1)=XCOOR(IREF2+1)
  49.          XPTS(2,2)=XCOOR(IREF2+2)
  50.          XPTS(2,3)=XCOOR(IREF2+3)
  51.          XPTS(3,1)=XCOOR(IREF3+1)
  52.          XPTS(3,2)=XCOOR(IREF3+2)
  53.          XPTS(3,3)=XCOOR(IREF3+3)
  54.          XPTS(4,1)=XCOOR(IREF4+1)
  55.          XPTS(4,2)=XCOOR(IREF4+2)
  56.          XPTS(4,3)=XCOOR(IREF4+3)
  57. C
  58.          DO i=1,3
  59.          W(i)= (RPTS(1)*RPTS(1))-(RPTS(i+1)*RPTS(i+1))
  60.      &       +(XPTS(i+1,1)*XPTS(i+1,1))+(XPTS(i+1,2)*XPTS(i+1,2))
  61.      &       +(XPTS(i+1,3)*XPTS(i+1,3))-(XPTS(1,1)*XPTS(1,1))
  62.      &       -(XPTS(1,2)*XPTS(1,2))-(XPTS(1,3)*XPTS(1,3))
  63.          W(i)=0.5*W(i)
  64.          END DO
  65.  
  66.          A(1,1)=XPTS(2,1)-XPTS(1,1)
  67.          A(1,2)=XPTS(2,2)-XPTS(1,2)
  68.          A(1,3)=XPTS(2,3)-XPTS(1,3)
  69.          A(2,1)=XPTS(3,1)-XPTS(1,1)
  70.          A(2,2)=XPTS(3,2)-XPTS(1,2)
  71.          A(2,3)=XPTS(3,3)-XPTS(1,3)
  72.          A(3,1)=XPTS(4,1)-XPTS(1,1)
  73.          A(3,2)=XPTS(4,2)-XPTS(1,2)
  74.          A(3,3)=XPTS(4,3)-XPTS(1,3)
  75.          B(1,1)=W(1)
  76.          B(2,1)=W(2)
  77.          B(3,1)=W(3)
  78. C
  79. c
  80.  
  81.          CALL GAUSSK(A,3,3,B,1,1)
  82. C
  83.          IF (IERR.NE.0) then
  84.             WRITE(6,*) 'il y a une erreur dans bcirco'
  85.             RETURN
  86.          endif
  87. C
  88.          XC(1)=B(1,1)
  89.          XC(2)=B(2,1)
  90.          XC(3)=B(3,1)
  91. C
  92.          XR=(XC(1)-XPTS(1,1))*(XC(1)-XPTS(1,1))
  93.      &      +(XC(2)-XPTS(1,2))*(XC(2)-XPTS(1,2))
  94.      &      +(XC(3)-XPTS(1,3))*(XC(3)-XPTS(1,3))
  95.      &      - ((RPTS(1))*(RPTS(1)))
  96. c
  97.          XR = XR**0.5
  98. c
  99. C
  100.       ELSEIF (IDIM.EQ.2) THEN
  101.          IREF1=(IPT1.NUM(1,JEL)-1)*IDIMP1
  102.          IREF2=(IPT1.NUM(2,JEL)-1)*IDIMP1
  103.          IREF3=(IPT1.NUM(3,JEL)-1)*IDIMP1
  104.          XPTS(1,1)=XCOOR(IREF1+1)
  105.          XPTS(1,2)=XCOOR(IREF1+2)
  106.          XPTS(2,1)=XCOOR(IREF2+1)
  107.          XPTS(2,2)=XCOOR(IREF2+2)
  108.          XPTS(3,1)=XCOOR(IREF3+1)
  109.          XPTS(3,2)=XCOOR(IREF3+2)
  110. C
  111.          DO i=1,2
  112.          W(i)= ((RPTS(1))**2)-((RPTS(i+1))**2)
  113.      &       +((XPTS(i+1,1))**2)+((XPTS(i+1,2))**2)
  114.      &       -((XPTS(1,1))**2)-((XPTS(1,2))**2)
  115.          W(i)=0.5*W(i)
  116.          END DO
  117. c
  118.          A(1,1)=XPTS(2,1)-XPTS(1,1)
  119.          A(1,2)=XPTS(2,2)-XPTS(1,2)
  120.          A(2,1)=XPTS(3,1)-XPTS(1,1)
  121.          A(2,2)=XPTS(3,2)-XPTS(1,2)
  122. c
  123.          B(1,1)=W(1)
  124.          B(2,1)=W(2)
  125. C
  126.          CALL GAUSSK(A,2,3,B,1,1)
  127. C
  128.          IF (IERR.NE.0) then
  129.             print*,'il y a une erreur dans bcirco : GAUSSK'
  130.             RETURN
  131.          endif
  132. C
  133.          XC(1)=B(1,1)
  134.          XC(2)=B(2,1)
  135. C
  136.          XR=(XC(1)-XPTS(1,1))**2+(XC(2)-XPTS(1,2))**2
  137.      &     - ((RPTS(1))**2)
  138. c
  139.          XR = XR**0.5
  140.  
  141. c
  142. c
  143.       ELSEIF (IDIM.EQ.1) THEN
  144.          XPTS(1,1)=XCOOR((IPT1.NUM(1,JEL)-1)*IDIMP1+1)
  145.          XPTS(2,1)=XCOOR((IPT1.NUM(2,JEL)-1)*IDIMP1+1)
  146.          XC(1)=0.5*((RPTS(1)**2)-(RPTS(2)**2)+(XPTS(2,1)**2)-
  147.      &             (XPTS(1,1)**2))/(XPTS(2,1)-XPTS(1,1))
  148.          XR = XC(1)-XPTS(1,1)
  149.       ENDIF
  150. C
  151.       RETURN
  152.       END
  153.  
  154.  
  155.  
  156.  
  157.  

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