Télécharger xdiamm.eso

Retour à la liste

Numérotation des lignes :

  1. C XDIAMM SOURCE CHAT 05/01/13 04:13:22 5004
  2. SUBROUTINE XDIAMM(MELEME,DIAM)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC CCREEL
  6. -INC SMELEME
  7. -INC SMCOORD
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. * PARAMETER (XPETI2=XPETIT**2)
  12. XPETI2 = xpetit
  13. * DIAM2=XGRAND**2
  14. DIAM2 = xgrand
  15. SEGACT MELEME
  16. NBSOUS=LISOUS(/1)
  17. IF(NBSOUS.EQ.0)NBSOUS=1
  18. DO 1 L=1,NBSOUS
  19. IF(NBSOUS.EQ.1)THEN
  20. IPT1=MELEME
  21. ELSE
  22. IPT1=LISOUS(L)
  23. SEGACT IPT1
  24. ENDIF
  25. NP =IPT1.NUM(/1)
  26. NEL=IPT1.NUM(/2)
  27. IF(NP.EQ.1) THEN
  28. C On ne veut pas d'objet de type %m1:8
  29. MOTERR(1:8)='POI1 '
  30. CALL ERREUR(39)
  31. RETURN
  32. ENDIF
  33. DO 10 K=1,NEL
  34.  
  35. C CALCUL DU DIAMETRE MIN
  36.  
  37. DO 321 I=1,NP-1
  38. IPI=IPT1.NUM(I,K)
  39. DO 322 J=I+1,NP
  40. IPJ=IPT1.NUM(J,K)
  41. XM2=0.D0
  42. DO 323 N=1,IDIM
  43. XM2=XM2+(XCOOR((IPI-1)*(IDIM+1)+N)
  44. $ -XCOOR((IPJ-1)*(IDIM+1)+N))**2
  45. 323 CONTINUE
  46. DIAM2=MIN(DIAM2,XM2)
  47. 322 CONTINUE
  48. 321 CONTINUE
  49. C
  50. * IF(DIAM2.LT.XPETI2) WRITE(6,*)
  51. * $ 'xdiamm.eso : un element est peut-etre degenere'
  52. 10 CONTINUE
  53. IF(NBSOUS.NE.1)SEGDES IPT1
  54. 1 CONTINUE
  55. SEGDES MELEME
  56. DIAM=SQRT(DIAM2)
  57. RETURN
  58. END
  59.  
  60.  
  61.  
  62.  
  63.  
  64.  

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