1 : C TRPLSI SOURCE CHAT 06/03/29 21:36:47 5360 2 : SUBROUTINE TRPLSI(X,IPOLYG,NCP, 3 : > IND,ICARD,JT,IFD, 4 : > IFG,IT,ITM,IPERE, 5 : > ITPOLY,ITRIA, 6 : > ITRMIN, 7 : > QTRIA,QMIN,NPMAX,NCMAX, 8 : C > ITRPOL,FCRMIN,QTMIN,iarr) modif TC 9 : > ITRPOL,QTMIN,iarr) 10 : C ***************************************************************** 11 : C OBJET : CALCULE LA TRIANGULATION D'UN POLYGONE SIMPLE 12 : C QUI MAXIMISE LA VALEUR MINIMUM D'UN CRITERE DONNE 13 : C 14 : C EN ENTREE : 15 : C X : COORDONNEES DES POINTS DU POLYGONE 16 : C IPOLYG : NUMERO DES NOEUDS DU POLYGONE 17 : C NCP : NOMBRE DE POINT DU POLYGONE 18 : C FCRMIN: FONCTION RENVOYANT LA VALEUR DU CRITERE 19 : C FUNCTION REAL FCRMIN(P1,P2,P3) 20 : C REAL*8 P1(*),P2(*),P3(*) 21 : C OU P1,P2,P3 SONT LES COORDONNEES DES POINTS 22 : C DU TRIANGLE 23 : C QTMIN : VALEUR MINIMUM DU CRITERE 24 : C 25 : C LES TABLEAUX DES POLYGONES 26 : C -------------------------- 27 : C IND(IPI) DONNE L'ADRESSE DU POLYGONE "IPI" DANS "ITPOLY" 28 : C ICARD(IPI) DONNE LE NOMBRE DE COTES DU POLYGONE "IPI" 29 : C JT(IPI) DONNE L'INDICE DES TRIANGLES DEJA TESTES 30 : C IFG(IPI),IFD(IPI) DONNENT LES ADRESSES DES POLYGONES 31 : C FILS DROIT ET FILS GAUCHE 32 : C QTRIA(IPI) DONNE LA QUALITE DE LA TRIANGULATION COURANTE 33 : C QMIN(IPI) DONNE LA QUALITE MINI DEJA ATTEINTE POUR UNE 34 : C TRIANGULATION DE IPI 35 : C IT(IPI) L'ADRESSE DE LA TRIANGULATION COURANTE DE IPI 36 : C LE NB DE TRIANGLES = ICARD(IPI) - 2 37 : C ITM(IPI) L'ADRESSE DE LA TRIANGULATION MINI DE IPI 38 : C ---------------------------- 39 : C ITPOLY : TABLEAU OU SONT DECRITS LES POLYGONES 40 : C LA LISTE DES INDICES DES NOEUDS 41 : C ITRIA : TABLEAU OU SONT DECRITES LES TRIANGULATIONS 42 : C -------------------------------------------------------- 43 : C NCMAX : LE NOMBRE MAXIMUM DE COTE DU POLYGONE 44 : C NPMAX : LE NOMBRE MAXIMUM DE POLYGONES EMPILES 45 : C POUR UN POLY DE N COTE = 2*(N-2) POLYGONES 46 : C DONT UN FILS PEUT AVOIR N-1 COTE. 47 : C DANS LE PIRE CAS NPMAX = (NCMAX-2)! 48 : C (NCMAX-2)!= 6.4E15 49 : C 1000 > 7! 50 : C INTEGER IND(NPMAX),ICARD(NPMAX),JT(NPMAX),IFD(NPMAX) 51 : C INTEGER IFG(NPMAX),IT(NPMAX),ITM(NPMAX),IPERE(NPMAX) 52 : C INTEGER ITPOLY(NPMAX*NCMAX),ITRIA((NCMAX-2)*3) 53 : C INTEGER ITRMIN((NCMAX-2)*3*NPMAX) 54 : C REAL*8 QTRIA(NPMAX),QMIN(NPMAX) 55 : C 56 : C EN SORTIE : 57 : C ITRPOL: TRIANGULATION RESULANTE 58 : C ITRPOL((I-1)*3+1) PREMIER NOEUD DU TRIANGLE I 59 : C ITRPOL((I-1)*3+2) DEUXIEME NOEUD DU TRIANGLE I 60 : C ITRPOL((I-1)*3+3) TROISIEME NOEUD DU TRIANGLE I 61 : C QTMIN : VALEUR MINIMUM DE FCRMIN SUR ITRPOL 62 : C iarr : 0 SI TOUT EST OK 63 : C -1 SI QTMIN N'A PAS PU ETRE ATTEINT 64 : C -2 SI UN PROBLEME DE TAILLE MEMOIRE 65 : C REMARQUE : 66 : C --------- 67 : C POLYGONE DE 5 COTE => 5 TRIANGULATIONS POSSIBLES 68 : C POLYGONE DE 10 COTE => 1430 TRIANGULATIONS POSSIBLES 69 : C POLYGONE DE 14 COTE => 208012 TRIANGULATIONS POSSIBLES 70 : C POLYGONE DE 20 COTE => 477638700 TRIANGULATIONS POSSIBLES 71 : C 72 : C DANS LE CAS GENERAL LE RESULTAT EST TOUT A FAIT ACCEPTABLE : 73 : C POUR UN POLYGONE 14 COTES, CORRESPONDANT A 14 A 28 TRIANGLES 74 : C INTERSECTANTS 75 : C SUIVANT LE CAS : 0.08 SECONDES SUR HP700 76 : C AVEC 1939 POLYGONES TESTES, 54 POLYGONES EMPILES 77 : C POUR 208012 TRIANGULATIONS POSSIBLES. 78 : C 79 : C ***************************************************************** 80 : IMPLICIT INTEGER(I-N) 81 : REAL*8 X(*),QTMIN 82 : INTEGER IPOLYG(*),NCP,ITRPOL(*),iarr 83 : C REAL*8 FCRMIN 84 : C EXTERNAL FCRMIN 85 : REAL*8 TRRILF 86 : EXTERNAL TRRILF 87 : INTEGER NPMAX,NCMAX 88 : C 89 : C ---- LES TABLEAUX DE TRAVAIL ---- 90 : C 91 : INTEGER IND(*),ICARD(*),JT(*),IFD(*) 92 : INTEGER IFG(*),IT(*),ITM(*),IPERE(*) 93 : INTEGER ITPOLY(*),ITRIA(*) 94 : INTEGER ITRMIN(*) 95 : REAL*8 QTRIA(*),QMIN(*) 96 : C 97 : C ---- VARIABLES LOCALES ---- 98 : C 99 : INTEGER IDIMC 100 : PARAMETER (IDIMC = 2) 101 : INTEGER NBP,II,I,J,K,N,ITP,IPI,LIBTL,LIBTR,LIBPL 102 : INTEGER LPLMAX,NPTEST 103 : C 104 : IF( NCP .GT. NCMAX )GO TO 888 105 : C 106 : NPTEST = 0 107 : LPLMAX = 0 108 : iarr = 0 109 : NBP = 1 110 : LIBPL = 2 111 : IND(1) = 1 112 : ICARD(1) = NCP 113 : JT(1) = 1 114 : IFD(1) = -1 115 : IFG(1) = -1 116 : QTRIA(1) = 0.0D0 117 : QMIN(1) = -1.0D0 118 : IT(1) = 1 119 : ITM(1) = 1 120 : IPERE(1) = 0 121 : DO 5 I=1,NCP 122 : ITPOLY(I) = IPOLYG(I) 123 : 5 CONTINUE 124 : ITPOLY(NCP+1) = IPOLYG(1) 125 : LIBTL = NCP+1 126 : LIBTR = (NCP-2)*3 127 : C 128 : C --- 1. BOUCLE SUR LES POLYGONES --- 129 : C ----------------------------------- 130 : 10 IPI = NBP 131 : ITP = IND(IPI) 132 : N = ICARD(IPI) 133 : J = JT(IPI) 134 : I = IT(IPI) 135 : C ------- POUR LE DEBUG ---------- 136 : LPLMAX = MAX(LIBPL,LPLMAX) 137 : NPTEST = NPTEST + 1 138 : IF((IFD(IPI).NE.-1).AND.(IFG(IPI).NE.-1))THEN 139 : C 140 : C --- ON A 1 TRIANGULATION DU POLY IPI --- 141 : C 142 : IF(IFD(IPI).NE.0) 143 : > QTRIA(IPI)=MIN(QMIN(IFD(IPI)),QTRIA(IPI)) 144 : IF(IFG(IPI).NE.0) 145 : > QTRIA(IPI)=MIN(QMIN(IFG(IPI)),QTRIA(IPI)) 146 : C 147 : C --- ON A TROUVER UNE MEILLEURE TRIANGULATION --- 148 : C 149 : IF(QTRIA(IPI) .GT. QMIN(IPI) )THEN 150 : K = ITM(IPI)-1 151 : DO 15 II=1,3 152 : ITRMIN(K+II) = ITRIA((I-1)*3+II) 153 : 15 CONTINUE 154 : IF(IFG(IPI).NE.0)THEN 155 : K = ITM(IPI) + 2 156 : DO 16 II=1,(ICARD(IFG(IPI))-2)*3 157 : ITRMIN(K+II)=ITRMIN(ITM(IFG(IPI))-1+II) 158 : 16 CONTINUE 159 : ENDIF 160 : C 161 : IF(IFD(IPI).NE.0)THEN 162 : IF(IFG(IPI).NE.0)THEN 163 : K = ITM(IPI) + 2 + (ICARD(IFG(IPI))-2)*3 164 : ELSE 165 : K = ITM(IPI) + 2 166 : ENDIF 167 : DO 17 II=1,(ICARD(IFD(IPI))-2)*3 168 : ITRMIN(K+II)=ITRMIN(ITM(IFD(IPI))-1+II) 169 : 17 CONTINUE 170 : ENDIF 171 : QMIN(IPI) = QTRIA(IPI) 172 : C --- POUR LE DEBUG ---- 173 : C PRINT *,'---------------------------------------' 174 : C PRINT *,' TRIANGULATION RETENUE POUR LE POLYGON ',IPI 175 : C PRINT *,' PERE DE ',IFG(IPI),' ET ',IFD(IPI) 176 : C PRINT *,' ',(ITRMIN(ITM(IPI)-1+II),II=1,((N-2)*3)) 177 : C PRINT *,' QMIN ',QMIN(IPI) 178 : C PRINT *,'---------------------------------------' 179 : ENDIF 180 : ENDIF 181 : C 182 : C --- 2. BOUCLE SUR LES TRIANGULATIONS D'UN POLYGONE 183 : C -------------------------------------------------- 184 : 20 J=J+1 185 : IF( J.GE.N )THEN 186 : C 187 : C --- ON A TOUTES LES TRIANGULATIONS DU POLY IPI --- 188 : C 189 : IF( IPERE(NBP).EQ.0 )THEN 190 : C --- ON EST A LA RACINE : ON A FINI --- 191 : DO 25 II=1,(ICARD(1)-2)*3 192 : ITRPOL(II) = ITRMIN(ITM(1)-1+II) 193 : 25 CONTINUE 194 : QTMIN = QMIN(1) 195 : C --- POUR LE DEBUG ------------------------------- 196 : C PRINT *,' ',(ITRPOL(II),II=1,((N-2)*3)) 197 : C PRINT *,' NOMBRE DE POLYS TESTES : ',NPTEST 198 : C PRINT *,' NOMBRE MAX DE POLYS EMPILES : ',LPLMAX 199 : GO TO 999 200 : ENDIF 201 : C --- ON REMONTE SUR LE FILS GAUCHE --- 202 : IF((IFD(IPERE(IPI)).EQ.IPI).AND. 203 : > (IFG(IPERE(IPI)).NE.0))THEN 204 : NBP = IFG(IPERE(IPI)) 205 : IF( LIBPL.GT.(IPI+1))THEN 206 : C --- ON LIBERE LES FILS DU FILS DROIT --- 207 : LIBPL = IPI+1 208 : LIBTR = ITM(IPI+1) 209 : C PRINT *,'LIBPL = ',LIBPL 210 : C PRINT *,'LIBTR = ',LIBTR 211 : C PRINT *,'LIBTL = ',LIBTL 212 : ENDIF 213 : ELSE 214 : NBP = IPERE(IPI) 215 : IF( LIBPL.GT.(IPI+2))THEN 216 : C --- ON LIBERE LES FILS DU FILS GAUCHE--- 217 : LIBPL = IPI+2 218 : LIBTR = ITM(IPI+2) 219 : LIBTL = IND(IPI+2) 220 : C PRINT *,'LIBPL = ',LIBPL 221 : C PRINT *,'LIBTR = ',LIBTR 222 : C PRINT *,'LIBTL = ',LIBTL 223 : ENDIF 224 : ENDIF 225 : GO TO 10 226 : ENDIF 227 : C --- ON CALCULE TOUTES LES TRIANGULATIONS CONTENANT 228 : C --- LE TRIANGLE ITP,ITP+1,ITP+J 229 : C -------------------------------------------------- 230 : QTRIA(IPI) = TRRILF(X((ITPOLY(ITP )-1)*IDIMC+1), 231 : > X((ITPOLY(ITP+1)-1)*IDIMC+1), 232 : > X((ITPOLY(ITP+J)-1)*IDIMC+1)) 233 : C --------- POUR LE DEBUG ------------- 234 : C PRINT *,'POLYGON ',IPI,' ',IND(IPI),' ',ICARD(IPI), 235 : C > ' TRIANGLE ',ITPOLY(ITP),' ',(ITPOLY(ITP+1)), 236 : C > ' ',(ITPOLY(ITP+J)),' RIL = ',QTRIA(IPI) 237 : IF( QTRIA(IPI) .LE. QMIN(IPI) ) GO TO 20 238 : ITRIA((I-1)*3+1) = ITPOLY(ITP) 239 : ITRIA((I-1)*3+2) = ITPOLY(ITP+1) 240 : ITRIA((I-1)*3+3) = ITPOLY(ITP+J) 241 : C 242 : C --- FILS GAUCHE --- 243 : C 244 : IF( (N-J+1) .GT. 2 )THEN 245 : C --- ON DESCEND SUR LE FILS GAUCHE --- 246 : IF( LIBPL .EQ. NPMAX )GO TO 888 247 : NBP = LIBPL 248 : IND(NBP) = LIBTL 249 : ICARD(NBP) = N-J+1 250 : IFG(NBP) = -1 251 : IFD(NBP) = -1 252 : IPERE(NBP) = IPI 253 : JT(NBP) = 1 254 : IT(NBP) = I+1+J-2 255 : ITM(NBP) = LIBTR 256 : QMIN(NBP) = QMIN(IPI) 257 : QTRIA(NBP)= 0.0D0 258 : IFG(IPI) = NBP 259 : C --- 260 : IF( ((NPMAX*NCMAX)-LIBTL) .LT. (N-J+1) )GO TO 888 261 : DO 30 II=0,(N-(J+1)) 262 : ITPOLY(LIBTL+II) = ITPOLY(ITP+J+II) 263 : 30 CONTINUE 264 : ITPOLY(LIBTL+N-J) = ITPOLY(ITP) 265 : LIBTL = LIBTL + ICARD(NBP) 266 : IF(((NPMAX*NCMAX)-LIBTR).LT.((ICARD(NBP)-2)*3))GO TO 888 267 : LIBTR = LIBTR + ((ICARD(NBP)-2)*3) 268 : LIBPL = LIBPL + 1 269 : ELSE 270 : IFG(IPI) = 0 271 : ENDIF 272 : C 273 : C --- FILS DROIT --- 274 : C 275 : IF( J .GE. 3 )THEN 276 : C --- ON DESCEND SUR LE FILS DROIT --- 277 : IF( LIBPL .EQ. NPMAX )GO TO 888 278 : NBP = LIBPL 279 : IND(NBP) = ITP+1 280 : ICARD(NBP) = J 281 : IFG(NBP) = -1 282 : IFD(NBP) = -1 283 : IPERE(NBP) = IPI 284 : JT(NBP) = 1 285 : IT(NBP) = I+1 286 : ITM(NBP) = LIBTR 287 : QMIN(NBP) = QMIN(IPI) 288 : QTRIA(NBP)= 0.0 289 : IFD(IPI) = NBP 290 : IF(((NPMAX*NCMAX)-LIBTR).LT.((ICARD(NBP)-2)*3))GO TO 888 291 : LIBTR = LIBTR + ((ICARD(NBP)-2)*3) 292 : LIBPL = LIBPL + 1 293 : ELSE 294 : IFD(IPI) = 0 295 : ENDIF 296 : C 297 : JT(IPI) = J 298 : C 299 : C --- ON TRAITE DANS L'ORDRE : IFD, IFG, IPERE 300 : C 301 : GOTO 10 302 : C 303 : 888 iarr = -2 304 : C 305 : 999 END 306 : 307 : 308 :
© Cast3M 2003 - All rights reserved.
Disclaimer