Télécharger voro.eso

Retour à la liste

Numérotation des lignes :

voro
  1. C VORO SOURCE CB215821 23/01/25 21:15:39 11573
  2. SUBROUTINE VORO
  3. C ******************************************************************
  4. C INTERFACE CASTEM 2000
  5. C
  6. C
  7. C TAB1 = VORO MAIL1 MAIL2 ;
  8. C
  9. C
  10. C OBJET :
  11. C _______
  12. C
  13. C L'OPERATEUR VORONOI CONSTRUIT LA PARTITION DE VORONOI D'UN
  14. C ENSEMBLE DE POINTS MAIL1 RESTREINTE PAR UN CONTOUR/ENVELOPPE MAIL2
  15. C
  16. C ******************************************************************
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8 (A-H,O-Z)
  19. C
  20. -INC SMCHPOI
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMELEME
  25. -INC SMCOORD
  26. -INC CCGEOME
  27. -INC SMLENTI
  28. -INC SMTABLE
  29. C
  30. DIMENSION LNBOIT(8)
  31. C
  32. SEGMENT,MCIRCONS
  33. REAL*8 TRC(NBE1,4)
  34. ENDSEGMENT
  35. POINTEUR ITRC1.MCIRCONS
  36. C
  37. SEGMENT,MADJACEN
  38. INTEGER LEAC(NBL1,IDIM+1,2)
  39. ENDSEGMENT
  40. POINTEUR ILEA1.MADJACEN
  41. C
  42. C =======================
  43. C --- 1.LECTURE DES DONNEES ---
  44. C =======================
  45. C
  46. C LECTURE DES OBJETS COURANTS (ENTREES)
  47. C =====================================
  48. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  49. IF (IERR.NE.0) THEN
  50. C ON A PAS TROUVE LE MAILLAGE
  51. CALL ERREUR(503)
  52. GOTO 999
  53. ENDIF
  54. SEGACT,IPT1
  55. NBSZ1=IPT1.LISOUS(/1)
  56. NTYP1=IPT1.ITYPEL
  57. C
  58. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  59. IF (IERR.NE.0) THEN
  60. C ON A PAS TROUVE LE MAILLAGE
  61. SEGDES,IPT1
  62. CALL ERREUR(503)
  63. GOTO 999
  64. ENDIF
  65. SEGACT,IPT2
  66. NBSZ2=IPT2.LISOUS(/1)
  67. NTYP2=IPT2.ITYPEL
  68. C
  69. C Parametre optionnel : critere de distance pour considerer deux
  70. C centres de cercles circonscrits confondus
  71. C Par defaut, on le calcule selon la taille du nuage de points
  72. IDIMP1=IDIM+1
  73. DDMAX=0.
  74. IP1=IPT1.NUM(1,1)
  75.  
  76. SEGACT,MCOORD
  77. XP1=XCOOR((IP1-1)*IDIMP1+1)
  78. YP1=XCOOR((IP1-1)*IDIMP1+2)
  79. ZP1=XCOOR((IP1-1)*IDIMP1+3)
  80. XP2=XP1
  81. YP2=YP1
  82. ZP2=ZP1
  83. DO I=2,IPT1.NUM(/2)
  84. IPI=IPT1.NUM(1,I)
  85. XPI=XCOOR((IPI-1)*IDIMP1+1)
  86. YPI=XCOOR((IPI-1)*IDIMP1+2)
  87. ZPI=XCOOR((IPI-1)*IDIMP1+3)
  88. IF(XPI.LT.XP1) XP1=XPI
  89. IF(YPI.LT.YP1) YP1=YPI
  90. IF(ZPI.LT.ZP1) ZP1=ZPI
  91. IF(XPI.GT.XP2) XP2=XPI
  92. IF(YPI.GT.YP2) YP2=YPI
  93. IF(ZPI.GT.ZP2) ZP2=ZPI
  94. ENDDO
  95. SEGDES,MCOORD
  96.  
  97. DDMAX=(XP2-XP1)+(YP2-YP1)
  98. IF (IDIM.EQ.3) DDMAX=DDMAX+(ZP2-ZP1)
  99. DDMAX=DDMAX*0.333333
  100. C WRITE(6,*) 'DDMAX=', DDMAX
  101. C
  102. C---- SI MAILLAGE DE POI1 ET CONTOUR/ENVELOPPE : PARTITION DE VORONOI --
  103. C
  104. C L'operateur n'est disponible qu'en dimension 2 ou 3
  105. IF ((IDIM.NE.2).AND.(IDIM.NE.3)) THEN
  106. INTERR(1)=IDIM
  107. C FONCTION INDISPONIBLE EN DIMENSION %I1
  108. SEGDES,IPT1,IPT2
  109. CALL ERREUR(709)
  110. GOTO 999
  111. ENDIF
  112. C Test sur les maillages d'entree
  113. C --> Le nombre de sous zones doit etre nul
  114. IF ((NBSZ1.NE.0).OR.(NBSZ2.NE.0)) THEN
  115. C MAILLAGE INCORRECT
  116. SEGDES,IPT1,IPT2
  117. CALL ERREUR(426)
  118. GOTO 999
  119. ENDIF
  120. C --> Le maillage MAIL1 doit etre constitue d'elements POI1
  121. IF (NTYP1.NE.1) THEN
  122. C TYPE D'ELEMENTS INCORRECT
  123. SEGDES,IPT1,IPT2
  124. CALL ERREUR(16)
  125. GOTO 999
  126. ENDIF
  127. C --> Le maillage MAIL2 doit etre constitue d'elements SEG2 ou TRI3
  128. IF (((IDIM.EQ.2).AND.(NTYP2.NE.2)).OR.
  129. & ((IDIM.EQ.3).AND.(NTYP2.NE.4))) THEN
  130. C TYPE D'ELEMENTS INCORRECT
  131. SEGDES,IPT1,IPT2
  132. CALL ERREUR(16)
  133. GOTO 999
  134. ENDIF
  135. C --> Les elements du maillage MAIL2 doivent etre orientes de la
  136. C meme maniere (appel a l'operateur VERSENS)
  137. CALL ECROBJ('MAILLAGE',IPT2)
  138. CALL VERSEN
  139. CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  140. IF (IERR.NE.0) THEN
  141. SEGDES,IPT1
  142. GOTO 999
  143. ENDIF
  144. C --> Le maillage contour/enveloppe MAIL2 doit etre connexe
  145. CALL ECROBJ('MAILLAGE',IPT2)
  146. CALL CCON
  147. CALL DIMENS
  148. CALL LIRENT(NCCON,1,IRETOU)
  149. IF (NCCON.NE.1) THEN
  150. INTERR(1)=NCCON
  151. C CET OBJET CONTIENT %1 COMPOSANTES CONNEXES
  152. SEGDES,IPT1,IPT2
  153. CALL ERREUR(754)
  154. GOTO 999
  155. ENDIF
  156. C
  157. MPOVAL = 0
  158. MCHPOI = 0
  159. CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
  160. IF(IRETOU.EQ.1) THEN
  161. SEGACT MCHPOI
  162. MSOUPO=IPCHP(1)
  163. SEGACT MSOUPO
  164. MPOVAL = IPOVAL
  165. SEGACT MPOVAL
  166. ENDIF
  167. C
  168. C On recree le maillage de points avec une reference vers le
  169. C maillage du contour/enveloppe pour etre pris en compte dans DELAUN
  170. C lors du calcul de la taille de la boite de triangulation
  171. SEGINI,IPT3=IPT1
  172. NBNN=IPT3.NUM(/1)
  173. NBELEM=IPT3.NUM(/2)
  174. NBSOUS=0
  175. NBREF=1
  176. SEGADJ,IPT3
  177. IPT3.LISREF(1)=IPT2
  178. C Appel a DELAUN avec IBOI=1 pour le calcul de la triangulation
  179. C de Delaunay de IPT3
  180. XBOI=50.
  181. IBOI=1
  182. CALL DELAUN(MPOVAL,IPT3,XBOI,IBOI,IPT4,LNBOIT,ITRC1,ILEA1)
  183. IF (IERR.NE.0) GOTO 999
  184. SEGACT,IPT4
  185. C Appel a VORO1 pour le calcul de la partition de Voronoi non coupee
  186. CALL VORO1(IPT1,IPT4,LNBOIT,ILEA1,ITRC1,DDMAX,MTAB1)
  187. IF (IERR.NE.0) GOTO 999
  188. IF (MPOVAL.NE.0) SEGDES,MPOVAL,MSOUPO,MCHPOI
  189. C Decoupage de la partition de Voronoi selon le contour/enveloppe
  190. C avec VORO2
  191. CALL VORO2(IPT1,IPT2,DDMAX,MCHPOI,MTAB1)
  192. IF (IERR.NE.0) GOTO 999
  193. C Ecriture sortie/fin
  194. SEGSUP,IPT3,IPT4,ITRC1,ILEA1
  195. SEGDES,IPT1,IPT2
  196. IF (IERR.EQ.0) CALL ECROBJ('TABLE ',MTAB1)
  197. GOTO 999
  198. C
  199. C
  200. 999 RETURN
  201. END
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  

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