1 : C TNUPOT SOURCE CHAT 06/03/29 21:36:07 5360 2 : SUBROUTINE TNUPOT(COORD,NBN,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 3 : > NOETRI,NBE,ITVL,IMAX,RTVL,iarr) 4 : C ********************************************************************** 5 : C OBJET : TRIANGULATION D'UN NUAGE DE POINTS 6 : C 7 : C EN ENTREE : 8 : C COORD : COORDONNEES DES POINTS 9 : C NBN : NOMBRE DE POINTS 10 : C ITVL : TABLEAU DE TRAVAIL. ON EMPILE SUCCESSIVEMENT : 11 : C LA TRIANGULATION INITIALE QUI NECESSITE : 3 * 50 12 : C PUIS SIMULTANEMENT LE NOMBRE DE NOEUDS REJETES, ET 13 : C LE TABLEAU DE TRAVAIL POUR TAJPOT = (6*NBADET +10) 14 : C D'OU IMAX > MAX(150,(6*NBADET+10)+NREJET) 15 : C 16 : C IMAX : TAILLE DU TABLEAU DE TRAVAIL 17 : C RTVL : TABLEAU DE TRAVAIL DE (8*NBN+244) 18 : C 19 : C EN SORTIE : LA TRIANGULATION MISE A JOUR 20 : C 21 : C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LA TRIANGULATION 22 : C NBNMAX : =3 A MOINS D'ETRE DONNE (NBNMAX != 0 EN ENTREE) 23 : C NBCMAX : =3 A MOINS D'ETRE DONNE (NBCMAX != 0 EN ENTREE) 24 : C 25 : C iarr : CODE D'ERREUR 26 : C -1 TRIANGULATION INCOMPLETE : TOUS LES POINTS N'ONT PAS 27 : C PU ETRE AJOUTES 28 : C -2 ITVL TROP PETIT 29 : C ********************************************************************** 30 : IMPLICIT INTEGER(I-N) 31 : REAL*8 COORD(*) 32 : INTEGER NBN 33 : INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX 34 : INTEGER NOETRI(*),NBE,ITVL(*),IMAX,iarr 35 : REAL*8 RTVL(*) 36 : C 37 : C --- POUR LE DEBUG --- 38 : C 39 : C COMMON /DEBUG/ ITRACE, ITEST, IERROR, IMESS 40 : C INTEGER ITRACE, ITEST, IERROR 41 : C CHARACTER*256 IMESS 42 : C 43 : C --- POUR LES STATS --- 44 : C 45 : C COMMON /STATS/ ICARD(100), TEMPSCPU(100) 46 : C INTEGER ICARD 47 : C REAL TEMPSCPU 48 : C --- CONSTANTES --- 49 : INTEGER NADMAX 50 : PARAMETER ( NADMAX = 50 ) 51 : REAL*8 ZEROTR, SZERO 52 : PARAMETER ( ZEROTR = 1.D-30, SZERO = 1.D-8 ) 53 : C --- VARIABLES INTERNES --- 54 : REAL*8 BOITE(6) 55 : INTEGER IDIMC,IDE,NBC,NCOORD, NBFNOE, NOEMAX, ISENS 56 : INTEGER ITRI,NBPB,ITRAV,NBTRAV,I,J,IPT,ITC,IF2,NP,NCC 57 : INTEGER ISOMP,NBSOMP,ISPH,NTMEM 58 : INTEGER NCFMAX,NREJET,NBP,ICOORD,NPASSE 59 : INTEGER ITD,NBSMAX,NBTNEW 60 : INTEGER NOP, ITRACE 61 : C 62 : ITRACE = 0 63 : IDIMC = 2 64 : IF( NBN .EQ. 0 )THEN 65 : iarr = -1 66 : GO TO 999 67 : ENDIF 68 : IF( NBNMAX.EQ.0 )NBNMAX = 3 69 : IF( NBCMAX.EQ.0 )NBCMAX = 3 70 : IF(( NBNMAX.LT.3 ).OR.(NBCMAX.LT.3))THEN 71 : iarr = -1 72 : GOTO 999 73 : ENDIF 74 : IF( IDIMC .EQ. 2 )THEN 75 : C NBE = (2*(NBN+4)) + 2 - 4 76 : C NTMEM =(NBE*3)+((NBE+2)*2)+(NBE*3)+((NBN*7)+NBE) 77 : C NBE = 2*NBN + 6 78 : C NTMEM = 27 * NBN 79 : NTMEM = MAX(150,(6*NADMAX+10)) 80 : IF( NTMEM.GT.IMAX )THEN 81 : iarr = -2 82 : GO TO 999 83 : ENDIF 84 : ENDIF 85 : C 86 : C ---- 1. INITIALISATION ----------------------------------------- 87 : C NORMALISATION DES POINTS (PTINIT) 88 : C CALCUL DU MAILLAGE INITIAL ENGLOBANT (T2INIT) 89 : C CALCUL DES SPHERES CIRCONSCRITES 90 : C ---------------------------------------------------------------- 91 : NBE = 0 92 : IDE = IDIMC 93 : NBC = IDIMC + 1 94 : NCOORD = NBN 95 : C ISPH = 1 96 : ISPH = IDIMC * ( NBN + 50 ) + 1 97 : ICOORD = 1 98 : ITRI = 1 99 : DO 5 I=1,IDIMC 100 : BOITE(I) = -1.0D0 101 : BOITE(IDIMC+I) = 1.0D0 102 : 5 CONTINUE 102 : CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),iarr) 102 : C CALL PTBOITENC(COORD,IDIMC,NBN,BOITE) 103 : C ITRI = 1 104 : C 105 : C --- TRIANGULATION DE LA BOITE D'ENCOMBREMENT -------------------- 106 : C 106 : C CALL TRI2DBOITE(BOITE,ITVL(ITRI),NBE, 107 : C > COORD((NBN*IDIMC)+1),NBPB) 108 : C 108 : CALL T2INIT(BOITE,(1-NBN),ITVL(ITRI),NBE, 109 : > RTVL((NBN*IDIMC)+ICOORD),NBPB) 110 : C 111 : IPT = 2 112 : DO 10 I=0,(NBE*(IDIMC+1))-1 113 : ITVL(ITRI+I) = ITVL(ITRI+I) + NBN 114 : 10 CONTINUE 115 : NCOORD = NCOORD + NBPB 116 : NOEMAX = NCOORD 117 : ITRAV = ITRI + (NBE * NBC) 118 : NBTRAV = IMAX - ITRAV 118 : CALL SMAOCR(IDE,ITVL(ITRI),NBE,RTVL(ICOORD),NCOORD, 119 : > IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, 120 : > ITVL(ITRAV),NBTRAV,NCC,iarr) 121 : DO 20 I=1,NBE 121 : CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD), 122 : > RTVL(ISPH),ZEROTR,iarr) 123 : IF( iarr .NE. 0 )THEN 123 : CALL DSERRE(1,iarr,'TNUPOT','CALCUL DES SPHERES') 124 : GOTO 999 125 : ENDIF 126 : 20 CONTINUE 127 : C -------- POUR LE DEBUG --------------- 128 : NCFMAX = IDE 129 : IF( ITRACE.NE.0 )THEN 130 : C PRINT *,'VERIF TRIANGULATION INITIALE' 130 : C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 131 : C > NBE,NCFMAX,ITRACE,iarr) 131 : C CALL DEBORIEN(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 132 : C > NOETRI,NBE,RTVL(ICOORD),ITRACE,iarr) 132 : C CALL DEBDELF1(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, 133 : C > NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 134 : C > ITRACE,ZEROTR,iarr) 135 : IF( iarr .NE. 0 )THEN 135 : C CALL DEBTABIPR(ITRNOE,NBE,3,1) 135 : C CALL DEBTABRPR(RTVL(ISPH),NBE,3,1) 136 : GO TO 999 137 : ENDIF 138 : ENDIF 139 : C 140 : C ---- 2. AJOUT DES NOEUDS ---------------------------------------- 141 : C 142 : NPASSE = 0 143 : DO 25 I=IPT,NBN 144 : ITVL(I)=I 145 : 25 CONTINUE 146 : C 147 : ITD = 0 148 : NBP = NBN 149 : NBSMAX = 3 150 : C IPT = 1 151 : NREJET = 0 152 : 30 iarr = 0 153 : IF( ITRACE .NE. 0 )THEN 154 : C PRINT *,'*********************' 155 : C PRINT *,'AJOUT DU POINT :',IPT 156 : ENDIF 156 : CALL TAJPOT(ITVL(IPT),ITD,ITRNOE,NBNMAX,ITRTRI, 157 : > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), 158 : > NBSMAX,ITVL(NBP+1), (IMAX-NBP),SZERO, 159 : > NBTNEW,iarr) 160 : IF( iarr.NE.0 )THEN 161 : C IF( ITRACE .EQ. 1 )PRINT *,'ERREUR A L AJOUT DU POINT :',IPT 162 : C ----- PERMUTATION : EN FIN ------- 163 : NREJET = NREJET + 1 164 : ITVL(NREJET) = ITVL(IPT) 165 : ENDIF 166 : C -------- POUR LE DEBUG --------------- 167 : NCFMAX = IDE 168 : IF((ITRACE .NE. 0 ).AND.( iarr .NE. 0 ))GOTO 999 169 : C -------- FIN POUR DEBUG --------------- 170 : IPT = IPT+1 171 : IF( IPT .LE. NBP )GO TO 30 172 : C -------- ON PASSE AU REJETES --------- 173 : C -------- TOUS LES POINTS REJETES ----- 174 : IF( NREJET .GE. NBP )THEN 175 : IF( NPASSE .LT. 10 )THEN 176 : NPASSE = NPASSE + 1 177 : NBP = NREJET 178 : IPT = 1 179 : NREJET = 0 180 : iarr = 0 181 : GOTO 30 182 : ELSE 183 : iarr = -1 183 : CALL DSERRE(1,iarr,'TNUPOT','BOUCLE REJET') 184 : C ---- ON CONTINUE QUAND MEME POUR VERIFICATION ---- 185 : iarr = 0 186 : GO TO 35 187 : C ENDIF 188 : ENDIF 189 : ENDIF 190 : C 191 : IF( NREJET .NE. 0 )THEN 192 : NPASSE = 0 193 : NBP = NREJET 194 : IPT = 1 195 : NREJET = 0 196 : GO TO 30 197 : ENDIF 198 : C 199 : C ---- 3. DESTRUCTION DES ELEMENTS BIDON -------------------------- 200 : C 201 : 35 CONTINUE 202 : ITRACE = 0 203 : ISENS = 1 204 : NBFNOE = 1 205 : DO 50 I=1,NBPB 206 : NP = NBN + I 206 : 40 CALL SESFR2(NP,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, 207 : > NBCMAX,NOETRI,ITC,IF2) 208 : C --- DE LA PREMIERE ARETE DE FRONTIERE --- 209 : IF( ITC.EQ. 0 )GO TO 50 210 : IF( ITRTRI((ITC-1)*NBCMAX+IF2) .NE. 0 )THEN 211 : iarr = -1 211 : CALL DSERRE(1,iarr,'TNUPOT','DESTRUCTION FINALE') 212 : GO TO 999 213 : ENDIF 214 : C --- L'ELEMENT EST MIS A LA FIN : PERMUTE ITC ET NBE --------- 215 : IF( ITRACE .NE. 0 )THEN 216 : C PRINT *,'DESTRUCTION DE ',ITC 217 : C PRINT *,(ITRNOE((ITC-1)*NBNMAX+J),J=1,NBNMAX) 218 : ENDIF 218 : CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 219 : > NBFNOE,NBE,ITC,NBE,iarr) 220 : C --- LE DERNIER ELEMENT EST DETRUIT -------------------------- 221 : ISOMP = 1 222 : NBSOMP = 0 222 : CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, 223 : > NBFNOE,NBE,NBC,ITVL(ISOMP),NBSOMP,iarr) 224 : NBE = NBE-1 225 : IF( iarr .NE. 0 )THEN 226 : iarr = -1 226 : CALL DSERRE(1,iarr,'TNUPOT','DESTRUCTION FINALE') 227 : GO TO 999 228 : ENDIF 229 : IF( NBSOMP .EQ. 0 )GO TO 40 230 : C --- LE NOEUD (NBN + I) EST DECONNECTE ---------------------- 231 : 50 CONTINUE 232 : C ================================== 233 : C --- MISE A JOUR DE NOETRI : O(3*NBE) --- 234 : C ================================== 235 : DO 70 I=1,NBE 236 : DO 60 J=1,3 237 : NOP = ITRNOE((I-1)*NBNMAX+J) 238 : IF((NOP.GT.NBN).OR.(NOP.LE.0))THEN 239 : iarr = -1 240 : GOTO 999 241 : ENDIF 242 : NOETRI(NOP) = I 243 : 60 CONTINUE 244 : 70 CONTINUE 245 : C 246 : IF( NREJET.NE. 0 )iarr = -1 247 : 999 END 248 : 249 : 250 : 251 :
© Cast3M 2003 - All rights reserved.
Disclaimer