Télécharger tajpot.eso

Retour à la liste

Numérotation des lignes :

  1. C TAJPOT SOURCE PV 16/04/06 21:15:18 8864
  2. SUBROUTINE TAJPOT(IPT,ITD,ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  3. > NOETRI,NBE,COORD,SPH,NBSMAX,
  4. > ITVL,IMAX,SZERO,NBTNEW,iarr)
  5. C **********************************************************************
  6. C OBJET : AJOUT DU POINT IPT DANS UNE TRIANGULATION DE DELAUNAY
  7. C
  8. C EN ENTREE :
  9. C IPT : LE NUMERO (DANS COORD) DU POINT A AJOUTER
  10. C ITD : UN TRIANGLE PROCHE DE IPT (SI POSSIBLE)
  11. C
  12. C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LA TRIANGULATION
  13. C COORD : COORDONNEES DES NOEUDS DE LA TRIANGULATION
  14. C
  15. C SPH : TABLEAU DES SPHERES CIRCONSCRITES AUX TRIANGLES
  16. C (CF. SPHCERTRI)
  17. C NBSMAX : NOMBRE DE CHAMPS POUR LE CALCUL DES SPHERES (>=2)
  18. C
  19. C ITVL: TABLEAU DE TRAVAIL. ON Y EMPILE SIMULTANEMENT :
  20. C - LES ELEMENTS A DETRUIRE ET LEUR FRONTIERE
  21. C - LES ELEMENTS A CONSTRUIRE ET LES SOMMETS PERDUS
  22. C IMAX : TAILLE DU TABLEAU DE TRAVAIL (6*NBADET+10)
  23. C
  24. C SZERO : SURFACE MINIMUM DES TRIANGLES CREES
  25. C SI ELLE EST ATTEINTE LE POINT EST REJETE
  26. C
  27. C EN SORTIE : LA TRIANGULATION CONTENANT IPT (SI iarr=0)
  28. C NBTNEW : LE NOMBRE D'ELEMENTS CREES
  29. C LES ELEMENTS CREES SONT LES TRIANGLES DE NUMERO 1 A NBTNEW
  30. C iarr : CODE D'ERREUR 0 SI OK
  31. C -1 LE NOEUD N'A PAS PU ETRE AJOUTE (REJET)
  32. C LA TRIANGULATION RESTE VALIDE
  33. C -2 ITVL TROP PETIT
  34. C REMARQUE :
  35. C POUR UTILISER TAJPOT ET AJOUTER UN POINT A UNE TRIANGULATION
  36. C IL FAUT :
  37. C - CREER LA STRUCTURE DU MAILLAGE (CF. SMAOCR)
  38. C - INITIALISER SPH EN APPELANT SPHCERTRI POUR CHAQUE TRIANGLE
  39. C - AJOUTER LES COORDONNEES DU POINT A COORD.
  40. C **********************************************************************
  41. IMPLICIT INTEGER(I-N)
  42. INTEGER IPT,ITD,NBSMAX,NBTNEW
  43. INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX
  44. INTEGER NOETRI(*),NBE,ITVL(*),IMAX,iarr
  45. REAL*8 SPH(*),COORD(*),SZERO
  46. C
  47. C --- POUR LE DEBUG ---
  48. C
  49. C COMMON /DEBUG/ ITEST, iarrOR, IMESS
  50. C INTEGER ITEST, iarrOR
  51. C CHARACTER*256 IMESS
  52. C
  53. C --- POUR LES STATS ---
  54. C
  55. C COMMON /STATS/ ICARD(100),TEMPSCPU(100)
  56. C INTEGER ICARD
  57. C REAL TEMPSCPU
  58. C --- VARIABLES INTERNES ---
  59. INTEGER IDE,NBC,IADETR,NADETR,NBCSTR,IACSTR,NTCMAX
  60. C INTEGER ITRAV,NBTRAV,
  61. INTEGER NBFNOE
  62. INTEGER I,J,K, IND, IFR,NIFMAX,NBIFR,ISOMP,NBSOMP
  63. INTEGER NBIFR1,IT,IF,IT1,IFR2,NBCOL,NP, NOEMAX
  64. INTEGER ISENS, IDIMC
  65. INTEGER GORIEN
  66. EXTERNAL GORIEN
  67. C
  68. C ---- POUR LE DEBUG ----
  69. INTEGER ITERR, ITAMPO
  70. INTEGER ITERR2, IAERR, NT, IPTDSC, IPTDS2, IPOINT(3),IOR
  71. INTEGER SPPOIN, SPPOI2
  72. EXTERNAL SPPOIN, SPPOI2
  73. REAL*8 TAILLE, ZERO
  74. C REAL TIMED, TIMEF, TABTIME(2), ETIME
  75. C EXTERNAL ETIME
  76. C
  77. IDIMC = 2
  78. NBTNEW = 0
  79. ZERO = 1.D-30
  80. IDE = IDIMC
  81. NBC = IDIMC + 1
  82. NOEMAX = 1
  83. C
  84. C ---- 1. RECHERCHE DES ELEMENTS A DETRUIRE --------------------
  85. C LES ELEMENTS DONT LE CERCLE CIRCONSCRIT CONTIENT LE POINT "IPT"
  86. C SONT MIS DANS LE TABLEAU ITVL DE "IADETR" JUSQU'A "NADETR"
  87. C --------------------------------------------------------------
  88. C TIMED = ETIME(TABTIME)
  89. C
  90. IADETR = 1
  91. IF( ITD.GT.0 )THEN
  92. C ------------------------------------------------
  93. C --- ON CONNAIT 1 TRIANGLE CONTENANT LE POINT : ITD ---
  94. C ------------------------------------------------
  95. ITVL(IADETR) = ITD
  96. NADETR = 1
  97. CALL RTCONN(COORD((IPT-1)*IDIMC+1),IDIMC,ITRNOE,NBNMAX,
  98. > ITRTRI,NBCMAX,COORD,SPH,
  99. > ITVL(IADETR),NADETR,IMAX,ZERO,iarr)
  100.  
  101. ELSE
  102. C -----------------------------------------------------
  103. C --- ON RECHERCHE LES TRIANGLES CONTENANT LE POINT : ITD ---
  104. C -----------------------------------------------------
  105. NADETR = 0
  106. CALL RTADET(COORD((IPT-1)*IDIMC+1),IDIMC,ITRNOE,NBNMAX,
  107. > ITRTRI,NBCMAX,NBE,COORD,SPH,
  108. > ITVL(IADETR),NADETR,IMAX,ZERO,iarr)
  109. ENDIF
  110. IF((NADETR.LT.1).OR.(iarr .NE. 0))THEN
  111. iarr = -1
  112. CALL DSERRE(1,iarr,'TAJPOT','DANS LA RECHERCHE')
  113. GOTO 999
  114. ELSE
  115. ENDIF
  116. C
  117. NTCMAX = 2
  118. C
  119. C TIMEF = ETIME(TABTIME)
  120. C TEMPSCPU(1) = TEMPSCPU(1) + TIMEF - TIMED
  121. C
  122. C
  123. C ---- 2. CALCUL DE LA FRONTIERE -----------------------------
  124. C
  125. C TIMED = TIMEF
  126. C
  127. CALL ENSTRI(ITVL(IADETR),NADETR)
  128. C
  129. DO 10 I=1,NTCMAX
  130. ITVL(IADETR+NADETR+I-1) = I + NBE
  131. DO 5 K=1,NBNMAX
  132. ITRNOE(((I+NBE)-1)*NBNMAX + K ) = 0
  133. 5 CONTINUE
  134. DO 6 K=1,NBCMAX
  135. ITRTRI(((I+NBE)-1)*NBCMAX + K ) = 0
  136. 6 CONTINUE
  137. 10 CONTINUE
  138. C PRINT *,'AVANT RENUMEROTATION'
  139. C CALL DEBTABIPR(ITRNOE,NBE,NBNMAX,1)
  140. C CALL DEBTABIPR(ITRTRI,NBE,NBCMAX,1)
  141. CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  142. > NOEMAX,(NBE+NTCMAX),ITVL(IADETR),
  143. > (NADETR+NTCMAX),iarr)
  144. IF(iarr .NE. 0)THEN
  145. CALL DSERRE(1,iarr,'NUCOMP','COMPRESSION EL')
  146. GOTO 999
  147. ENDIF
  148. C ---- COMPACTAGE DES SPHERES --------------------------------
  149. CALL SPCOMP(SPH, NBSMAX, (NBE+NTCMAX),ITVL(IADETR),
  150. > (NADETR+NTCMAX),iarr)
  151. IF(iarr .NE. 0)THEN
  152. CALL DSERRE(1,iarr,'SPCOMP','COMPRESSION SPH')
  153. GOTO 999
  154. ENDIF
  155. IND = 1
  156. IFR = IADETR + NADETR
  157. NBIFR = 0
  158. NIFMAX = IMAX - NADETR
  159. CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NADETR,
  160. > ITVL(IFR),NBIFR,NIFMAX,iarr)
  161. C ---- POUR LE DEBUG ----------
  162. IF( iarr .NE. 0 )THEN
  163. CALL DSERRE(1,iarr,'TAJPOT','FRONTIERE T A DET.')
  164. C CALL DEBTABIPR(ITRNOE,NBE+NTCMAX,NBNMAX,1)
  165. C CALL DEBTABIPR(ITRTRI,NBE+NTCMAX,NBCMAX,1)
  166. GOTO 999
  167. ENDIF
  168. C
  169. C TIMEF = ETIME(TABTIME)
  170. C TEMPSCPU(2) = TEMPSCPU(2) + TIMEF - TIMED
  171. C
  172. C ---- 3. VERIFICATION DE L'ORIENTATION ----------------------
  173. C
  174. IACSTR = IFR + ( NBIFR * 2 )
  175. NBCSTR = NBIFR
  176. IF( NBCSTR .LT. (NADETR+2))THEN
  177. C --- POUR LE CAS 2D ---
  178. iarr = -1
  179. CALL DSERRE(1,iarr,'TAJPOT','SOMMET PERDU')
  180. C ICARD(4) = ICARD(4) + 1
  181. GOTO 100
  182. ENDIF
  183. C
  184. IF( NBCSTR .GT. (NADETR+2))THEN
  185. C --- POUR LE CAS 2D ---
  186. iarr = -1
  187. CALL DSERRE(1,iarr,'TAJPOT','TRI NON CONNEXES')
  188. C ICARD(5) = ICARD(5) + 1
  189. GOTO 100
  190. ENDIF
  191. C
  192. DO 20 I=1,NBIFR
  193. C ITVL((I-1)*NBC+IACSTR) = IPT
  194. C CALL TNOFRT(IDE,ITRNOE,NBNMAX,ITVL((I-1)*2+IFR),
  195. C > ITVL((I-1)*2+IFR+1),ITVL((I-1)*NBC+IACSTR+1))
  196. C
  197. C
  198. ITVL((I-1)*NBC+IACSTR+2) = IPT
  199. CALL TNOFRT(IDE,ITRNOE,NBNMAX,ITVL((I-1)*2+IFR),
  200. > ITVL((I-1)*2+IFR+1),ITVL((I-1)*NBC+IACSTR))
  201. IF( GORIEN(ITVL((I-1)*NBC+IACSTR),NBC,COORD,IDIMC,SZERO)
  202. > .NE.1 )THEN
  203. C
  204. C ---- REPRISE SUR ERREUR : RECOMPACTAGE ----
  205.  
  206. iarr = -1
  207. C CALL DSERRE(1,iarr,'TAJPOT','ORIENTATION ELEMENT')
  208. C ICARD(5) = ICARD(5) + 1
  209. C
  210. C --- ON PERTURBE LE CALCUL DES SPHERES ---
  211. C
  212. ITERR = ITVL((I-1)*2+IFR)
  213. IAERR = ITVL((I-1)*2+IFR+1)
  214. ITERR2 = ITRTRI((ITERR-1)*NBCMAX+IAERR)
  215. ITAMPO = ITRNOE(ITERR*NBNMAX)
  216. ITRNOE(ITERR*NBNMAX) = ITRNOE(ITERR*NBNMAX-1)
  217. ITRNOE(ITERR*NBNMAX-1) = ITRNOE(ITERR*NBNMAX-2)
  218. ITRNOE(ITERR*NBNMAX-2) = ITAMPO
  219. ITAMPO = ITRTRI(ITERR*NBCMAX)
  220. ITRTRI(ITERR*NBCMAX) = ITRTRI(ITERR*NBCMAX-1)
  221. ITRTRI(ITERR*NBCMAX-1) = ITRTRI(ITERR*NBCMAX-2)
  222. ITRTRI(ITERR*NBCMAX-2) = ITAMPO
  223. C
  224. CALL SPCREE(IDIMC,ITERR,ITRNOE((ITERR-1)*NBNMAX+1),
  225. > COORD,SPH,ZERO,iarr)
  226. C
  227. C --- ON PERTURBE AUSSI LE VOISIN ---
  228. C
  229. IF( ITERR2.LE.0 )GOTO 100
  230. ITERR = ITERR2
  231. ITAMPO = ITRNOE(ITERR*NBNMAX)
  232. ITRNOE(ITERR*NBNMAX) = ITRNOE(ITERR*NBNMAX-1)
  233. ITRNOE(ITERR*NBNMAX-1) = ITRNOE(ITERR*NBNMAX-2)
  234. ITRNOE(ITERR*NBNMAX-2) = ITAMPO
  235. ITAMPO = ITRTRI(ITERR*NBCMAX)
  236. ITRTRI(ITERR*NBCMAX) = ITRTRI(ITERR*NBCMAX-1)
  237. ITRTRI(ITERR*NBCMAX-1) = ITRTRI(ITERR*NBCMAX-2)
  238. ITRTRI(ITERR*NBCMAX-2) = ITAMPO
  239. C
  240. CALL SPCREE(IDIMC,ITERR,ITRNOE((ITERR-1)*NBNMAX+1),
  241. > COORD,SPH,ZERO,iarr)
  242.  
  243. GOTO 100
  244. ENDIF
  245. 20 CONTINUE
  246. C
  247. C ---- 4. FRONTIERE EXTERIEUR DU TROU ---------
  248. C LES VOISINS SUR LA FRONTIERES DES ELEMENTS A DETRUIRE
  249. C
  250. NBIFR1 = 0
  251. DO 50 I=1,NBIFR
  252. IT = ITVL((I-1)*2+IFR)
  253. IF = ITVL((I-1)*2+IFR+1)
  254. C --- MULTI-MAT ---
  255. ISENS = 1
  256. IF( IF.LT.0 )ISENS = -1
  257. IT1 = ABS(ITRTRI((IT-1)*NBCMAX+(IF*ISENS)))
  258. IF( IT1.NE.0 )THEN
  259. DO 30 J=1,NBCMAX
  260. IF(ABS(ITRTRI((IT1-1)*NBCMAX+J)).EQ.IT)GO TO 40
  261. 30 CONTINUE
  262. iarr = -1
  263. CALL DSERRE(1,iarr,'TAJPOT','ERREUR TROU')
  264. GO TO 999
  265. 40 NBIFR1 = NBIFR1 + 1
  266. ITVL((NBIFR1-1)*2+IFR) = ABS(IT1)
  267. ITVL((NBIFR1-1)*2+IFR+1) = ISENS*J
  268. ENDIF
  269. 50 CONTINUE
  270. C
  271. C ---- 5. DESTRUCTION DES MAILLES ----------------------------
  272. C
  273. C TIMED = ETIME(TABTIME)
  274. C
  275. NBFNOE = 0
  276. NBSOMP = 0
  277. ISOMP = IACSTR + (NBCSTR * NBC)
  278. DO 60 I=1,NADETR
  279. CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
  280. > NBFNOE,I,NBC,ITVL(ISOMP+NBSOMP),NBSOMP,iarr)
  281. IF( iarr .NE. 0 )THEN
  282. CALL DSERRE(1,iarr,'TAJPOT','ERREUR DESTRUCTION')
  283. GOTO 999
  284. ENDIF
  285. 60 CONTINUE
  286. NBE = NBE - NADETR
  287. IF( NBSOMP.NE.0 )THEN
  288. iarr = -1
  289. CALL DSERRE(1,iarr,'TAJPOT','SOMMETS PERDUS')
  290. C PRINT *, (ITVL(ISOMP),I=1,NBSOMP)
  291. GO TO 999
  292. ENDIF
  293. C
  294. C TIMEF = ETIME(TABTIME)
  295. C TEMPSCPU(5) = TEMPSCPU(5) + TIMEF - TIMED
  296. C
  297. C ---- 6. CONSTRUCTION DES NOUVEAUX ELEMENTS -----------------
  298. C
  299. C TIMED = TIMEF
  300. C
  301. NBFNOE = 0
  302. C ITRAV = ISOMP
  303. C NBTRAV = IMAX - ITRAV + 1
  304. C CALL STRCREE(IDE,ITVL(IACSTR),NBCSTR,
  305. C > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBFNOE,
  306. C > ITVL(ITRAV),NBTRAV,iarr)
  307. C REMPLACE PAR :
  308. C =========================================================
  309. DO 63 I=1,NBCSTR
  310. DO 61 J=1,NBC
  311. ITRNOE((I-1)*NBNMAX+J)=ITVL((I-1)*NBC+IACSTR-1+J)
  312. ITRTRI((I-1)*NBCMAX+J)=0
  313. 61 CONTINUE
  314. DO 62 J=1,(I-1)
  315. IF( ITRNOE((J-1)*NBNMAX+1).EQ.ITRNOE((I-1)*NBNMAX+2) )THEN
  316. ITRTRI((J-1)*NBCMAX+3) = I
  317. ITRTRI((I-1)*NBCMAX+2) = J
  318. ENDIF
  319. IF( ITRNOE((J-1)*NBCMAX+2).EQ.ITRNOE((I-1)*NBCMAX+1) )THEN
  320. ITRTRI((J-1)*NBCMAX+2) = I
  321. ITRTRI((I-1)*NBCMAX+3) = J
  322. ENDIF
  323. 62 CONTINUE
  324. 63 CONTINUE
  325. C DO 62 J=1,(I-1)
  326. C IF( ITRNOE((J-1)*NBNMAX+3).EQ.ITRNOE((I-1)*NBNMAX+2) )THEN
  327. C ITRTRI((J-1)*NBCMAX+3) = I
  328. C ITRTRI((I-1)*NBCMAX+1) = J
  329. C ENDIF
  330. C IF( ITRNOE((J-1)*NBCMAX+2).EQ.ITRNOE((I-1)*NBCMAX+3) )THEN
  331. C ITRTRI((J-1)*NBCMAX+1) = I
  332. C ITRTRI((I-1)*NBCMAX+3) = J
  333. C ENDIF
  334. C 62 CONTINUE
  335. C 63 CONTINUE
  336. C NOETRI(ITVL((I-1)*NBC+IACSTR)) = 1
  337. C BUG4 O.STAB 08.08.95 REMPLACER PAR :
  338. NOETRI(IPT) = 1
  339. C CALL DEBTABIPR(ITRNOE,NBCSTR,NBNMAX,1)
  340. C CALL DEBTABIPR(ITRTRI,NBCSTR,NBCMAX,1)
  341. C ==========================================================
  342. DO 70 I=1,NBCSTR
  343. C ---------------------
  344. CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),COORD,SPH,
  345. > ZERO,iarr)
  346. IF( iarr .NE. 0 )THEN
  347. CALL DSERRE(1,iarr,'TAJPOT','CALCUL SPHERES')
  348. GOTO 999
  349. ENDIF
  350. 70 CONTINUE
  351. C
  352. C TIMEF = ETIME(TABTIME)
  353. C TEMPSCPU(6) = TEMPSCPU(6) + TIMEF - TIMED
  354. C
  355. C --- 7. CONNECTION AVEC LES ANCIENS ---
  356. C
  357. C TIMED = TIMEF
  358. C
  359. IND = 1
  360. IFR2 = IACSTR
  361. NIFMAX = IMAX - IACSTR
  362. CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NBCSTR,
  363. > ITVL(IFR2),NBIFR,NIFMAX,iarr)
  364. IF( iarr .NE. 0 )THEN
  365. CALL DSERRE(1,iarr,'TAJPOT','FRONTIERE T CREES')
  366. GOTO 999
  367. ENDIF
  368. C
  369. C --- MISE A JOUR DE ITRTRI -----------------
  370. C
  371. CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR,
  372. > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL)
  373. C
  374. C --- MISE A JOUR DE NOETRI -----------------
  375. C
  376. DO 90 I=1,NBCSTR
  377. DO 80 J=1,NBNMAX
  378. NP = ITRNOE((I-1)*NBNMAX+J)
  379. IF( NP .NE. 0 )NOETRI(NP)=I
  380. 80 CONTINUE
  381. 90 CONTINUE
  382. NBE = NBE + NBCSTR
  383. NBTNEW = NBCSTR
  384. C ICARD(6) = ICARD(6) + NBCSTR
  385. C ICARD(7) = ICARD(7) + NADETR
  386. C
  387. C TIMEF = ETIME(TABTIME)
  388. C TEMPSCPU(7) = TEMPSCPU(7) + TIMEF - TIMED
  389. GOTO 999
  390. C
  391. C ---- REPRISE SUR ERREUR : RECOMPACTAGE ----
  392. C
  393. 100 iarr = 0
  394. IF( NADETR .EQ. NBE )GO TO 999
  395. DO 110 J=1,NADETR
  396. ITVL(J) = J
  397. 110 CONTINUE
  398. DO 120 J=1,NTCMAX
  399. ITVL(NADETR+J) = NBE + J
  400. 120 CONTINUE
  401. C DO 110 J=1, (NADETR+NTCMAX)
  402. C ITVL(IADETR+J-1) = NBE - NADETR + J
  403. C 110 CONTINUE
  404. CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  405. > NOEMAX,(NBE+NTCMAX),ITVL(IADETR),
  406. > (NADETR+NTCMAX),iarr)
  407. IF(iarr .NE. 0)THEN
  408. CALL DSERRE(1,iarr,'NUCOMP','COMPRESS 2 EL')
  409. GOTO 999
  410. ENDIF
  411. CALL SPCOMP(SPH, NBSMAX, (NBE+NTCMAX),ITVL(IADETR),
  412. > (NADETR+NTCMAX),iarr)
  413. IF(iarr .NE. 0)THEN
  414. CALL DSERRE(1,iarr,'SPCOMP','COMPRESS 2 SPH')
  415. GOTO 999
  416. ENDIF
  417. iarr = -1
  418. C
  419. 999 END
  420.  
  421.  
  422.  
  423.  
  424.  
  425.  

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