Télécharger la plaquette Cast3M


fr en

Télécharger tajpot.eso

Retour à la liste

Numérotation des lignes : 

tajpot

  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