Télécharger dvboul.eso

Retour à la liste

Numérotation des lignes :

  1. C DVBOUL SOURCE KICH 19/10/25 21:15:06 10351
  2. SUBROUTINE DVBOUL(s,centre,ray,nbrobl,nombre,iel,igau)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. c ***********************************************************
  6. c calcul de la plus petite hypersphere, dimension espace < 6
  7. c algorithme inspiré de miniball
  8. c ***********************************************************
  9. integer lisr(nbrobl)
  10. real*8 centre(nbrobl-1),rayon(nbrobl-1)
  11. real*8 s(nbrobl-1,nombre)
  12.  
  13. klisp = 0
  14. 10 continue
  15. lisr(1) = 1
  16. do iu = 1,nbrobl-1
  17. centre(iu) = s(iu,1)
  18. enddo
  19. ray2 = 0.D0
  20. call dvdmax(s,centre,ray2,lisr,nbrobl,nombre,indx)
  21. * write(6,*)'dvboul1',klisp,((centre(ju)/1.e6),ju=1,nbrobl-1),indx
  22. if(indx.gt.0) then
  23. lisr(2) = lisr(1)
  24. lisr(1) = indx
  25. do iu = 1,nbrobl-1
  26. centre(iu) = (s(iu,lisr(1)) + s(iu,lisr(2)))*0.5D0
  27. rayon(iu) = s(iu,lisr(1)) - centre(iu)
  28. enddo
  29. ray2 = rayon(1)*rayon(1) + rayon(2)*rayon(2) +
  30. &2.D0*rayon(3)*rayon(3)
  31. if (nbrobl.gt.4) then
  32. ray2 = ray2 + 2.D0*(rayon(4)*rayon(4) + rayon(5)*rayon(5))
  33. endif
  34. ray = dsqrt(ray2)
  35. else
  36. * write(6,*) 'boul',klisp
  37. return
  38. endif
  39. klisp = klisp + 1
  40. * verification
  41. call dvdmax(s,centre,ray2,lisr,nbrobl,nombre,indx)
  42. * write(6,*)'dvboul2',klisp,((centre(ju)/1.e6),ju=1,nbrobl-1),indx
  43. * nouvel essai 2D
  44. if(indx.gt.0) then
  45. lisr(2) = lisr(1)
  46. lisr(1) = indx
  47. do iu = 1,nbrobl-1
  48. centre(iu) = (s(iu,lisr(1)) + s(iu,lisr(2)))*0.5D0
  49. rayon(iu) = s(iu,lisr(1)) - centre(iu)
  50. enddo
  51. ray2 = rayon(1)*rayon(1) + rayon(2)*rayon(2)
  52. &+2.D0*rayon(3)*rayon(3)
  53. if (nbrobl.gt.4) then
  54. ray2 = ray2 + 2.D0*(rayon(4)*rayon(4) + rayon(5)*rayon(5))
  55. endif
  56. ray = dsqrt(ray2)
  57. klisp = 2
  58. else
  59. * write(6,*) 'boul',klisp
  60. return
  61. endif
  62. klis0 = 0
  63. NDIM = 2
  64.  
  65. 20 continue
  66. * verification
  67. call dvdmax(s,centre,ray2,lisr,nbrobl,nombre,indx)
  68. * write(6,*)'oul',klisp,((centre(ju)/1.e6),ju=1,nbrobl-1),indx,ray2
  69. ray = dsqrt(ray2)
  70. if(indx.eq.0) then
  71. * write(6,*) 'boulklisp',klisp,ndim
  72. return
  73. else
  74. if(klisp.eq.klis0+ndim) then
  75. ndim = ndim + 1
  76. klis0 = klisp
  77. endif
  78. if (ndim.eq.nbrobl+1) then
  79. * interr(1) = ib
  80. * interr(2) = igau
  81. call erreur(-366)
  82. * write(6,*) 'arret boules',klisp, ib,igau
  83. return
  84. endif
  85. do ll = ndim,2,-1
  86. lisr(ll) = lisr(ll-1)
  87. enddo
  88. lisr(1) = indx
  89. klisp = klisp + 1
  90. nd = ndim
  91. call dvhyp2(nbrobl,nombre,s,nd,lisr,iok,ray2,centre)
  92. goto 20
  93. endif
  94.  
  95. RETURN
  96. END
  97.  
  98.  
  99.  

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