1 : C RF2FAR SOURCE CHAT 06/03/29 21:31:22 5360 2 : SUBROUTINE RF2FAR(NN,INTER, NINTER, 3 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX, 4 : > NOETRI,NBE,COORD, 5 : > ITVL,NTIMAX,RTVL,NTRMAX,iarr) 6 : C ***************************************************************** 7 : C OBJET : FORCE LE MAILLAGE A RESPECTER UNE ARETE 8 : C 9 : C EN ENTREE: 10 : C NN() : LES INDICES DES NOEUDS DE L'ARETE 11 : C INTER : TABLEAU DES ELEMENTS INTERSECTANTS NN() 12 : C NINTER : NBRE D'ELEMENTS DE INTER 13 : C AU MINIMUM = 8 * NINTER + 10 14 : C AU MAXIMUM = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) * 15 : C (NUMERO MAXI DES NOEUDS DES ELEMENTS DE INTER) 16 : C 17 : C ITVL : TABLEAU DE TRAVAIL (ENTIERS) 18 : C NTIMAX : TAILLE DU TABLEAU ITVL 19 : C RTVL : TABLEAU DE TRAVAIL (REELS) 20 : C NTRMAX : TAILLE DU TABLEAU RTVL 21 : C 22 : C EN SORTIE: LE MAILLAGE MODIFIE SI NECESSAIRE. 23 : C iarr : 0 SI OK 24 : C -1 SI LES DONNEES SONT ERRONEES 25 : C NN(1) OU NN(2) N'APPARTIENNT PAS AUX ELEMENTS DE INTER 26 : C -2 SI ITVL EST TROP PETIT 27 : C REMARQUE : ATTENTION LES MAILLES DE INTER SONT RENUMEROTEE DE 28 : C 1 A CARD(INTER), ITRNOE,ITRTRI...SONT MODIFIES !!! 29 : C ***************************************************************** 30 : IMPLICIT INTEGER(I-N) 31 : INTEGER NN(*),INTER(*),NINTER,ITRNOE(*),NBNMAX 32 : INTEGER ITRTRI(*),NBCMAX,NOETRI(*),NBE 33 : INTEGER ITVL(*),NTIMAX,NTRMAX,iarr 34 : REAL*8 COORD(*), RTVL(*) 35 : C on enleve l'external TC 36 : C REAL*8 TRRILF 37 : C EXTERNAL TRRILF 38 : INTEGER IDE,I,NBN,NBC,NBIFR,NBIFR1,IND,IFR 39 : INTEGER NIFMAX 40 : INTEGER IT,IF,IT1,J, NOEUD, IFR2, NBCOL, NOEMAX 41 : INTEGER IPOLY,NBPP,IPOLY1,NBPP1,IPOLY2,NBPP2 42 : INTEGER INOE,ITRI,ITRAV,NBTRAV 43 : INTEGER NBFNOE, N, ISOMP, NBSOMP, NCC 44 : INTEGER ITRIP1, ITRIP2, ITI, ITR, NTIMX, NTRMX 45 : REAL*8 QTMIN1, QTMIN2 46 : C 47 : IDE = 2 48 : iarr = 0 49 : IF(NTIMAX.LT.(8*NINTER+10))THEN 50 : iarr = -2 51 : GO TO 999 52 : ENDIF 53 : C ==================================================== 54 : C --- 1. COMPRESSION DU MAILLAGE ET CALCUL DE LA FRONTIERE 55 : C ==================================================== 56 : C 57 : C ITVL = | IFR | 58 : C 2*NBIFR 59 : C 59 : CALL ENSTRI(INTER,NINTER) 60 : NOEMAX = 1 60 : CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, 61 : > NOEMAX,NBE,INTER,NINTER,iarr) 62 : IF( iarr .NE. 0 )THEN 62 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL NUCOMP') 63 : GOTO 999 64 : ENDIF 65 : C 66 : IND = 1 67 : IFR = 1 68 : NBIFR = 0 69 : NIFMAX = NTIMAX 69 : CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER, 70 : > ITVL(IFR),NBIFR,NIFMAX,iarr) 71 : C 72 : C PRINT *,' FRONTIERE ' 73 : C PRINT *,' ',((ITVL((I-1)*2+IFR-1+J),J=1,2),I=1,NBIFR) 74 : IF( iarr .NE. 0 )THEN 74 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL TMAFRT') 75 : GOTO 999 76 : ENDIF 77 : C ========================================= 78 : C --- 2. CREATION DES 2 POLYGONES A TRIANGULER. ----- 79 : C ========================================= 80 : C ITVL = | IFR | INOE | ITRI | IPOLY 81 : C 2*NBIFR NBN*NBIFR NBC*NBIFR 82 : C 83 : NBN = 2 84 : NBC = 2 85 : NBIFR = NINTER + 2 86 : C 87 : C --- 2.1 CREATION DU MAILLAGE LINEIQUE --- 88 : C ---------------------------------- 89 : C LE NOMBRE DE PARAMETRES DE SFRCRE A CHANGE ??? O.STAB 07.95 90 : C > ITRTRI,NBCMAX,NOETRI,NBE,ITVL(ITRAV),NBTRAV, 91 : C 92 : INOE = ( 2 * NBIFR ) + 1 93 : ITRI = ( NBN * NBIFR ) + INOE 94 : ITRAV = ( NBC * NBIFR ) + ITRI 95 : C --- ECONOMIE DE FNOETRI -- 96 : NBTRAV = (NBC + 1) * NBIFR 97 : NBFNOE = 0 98 : C WRITE(6,*)'APPEL SFRCRE' 98 : CALL SFRCRE(IDE,ITVL(IFR),NBIFR,ITRNOE,NBNMAX, 99 : > ITVL(ITRAV),NBTRAV, 100 : > ITVL(INOE),NBN,ITVL(ITRI),NBC,NBIFR, 101 : > ITVL(1),NBFNOE,NCC,iarr) 102 : C PRINT *,' MAILLAGE FRONTIERE ' 103 : C PRINT *,' ',((ITVL((I-1)*2+INOE-1+J),J=1,2),I=1,NBIFR) 104 : IF( iarr .NE. 0 )THEN 104 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL SFRCRE') 105 : GOTO 999 106 : ENDIF 107 : C 108 : C ---- 2.2 FRONTIERE EXTERIEURE --------- 109 : C -------------------------- 110 : NBIFR1 = 0 111 : DO 30 I=1,NBIFR 112 : IT = ITVL((I-1)*2+IFR) 113 : IF = ITVL((I-1)*2+IFR+1) 114 : IT1 = ITRTRI((IT-1)*NBCMAX+IF) 115 : IF( IT1.NE.0 )THEN 116 : DO 10 J=1,NBCMAX 117 : IF( ITRTRI((IT1-1)*NBCMAX+J).EQ.IT )GO TO 20 118 : 10 CONTINUE 119 : iarr = -1 120 : GO TO 999 121 : 20 NBIFR1 = NBIFR1 + 1 122 : ITVL((NBIFR1-1)*2+IFR) = IT1 123 : ITVL((NBIFR1-1)*2+IFR+1) = J 124 : ENDIF 125 : 30 CONTINUE 126 : C PRINT *,' FRONTIERE EXTERIEUR ' 127 : C PRINT *,' ',((ITVL((I-1)*2+IFR+J-1),J=1,2),I=1,NBIFR1) 128 : C 129 : C ---- DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ---- 130 : C MODIF O.STAB 18.08.95 DEPLACE APRES LE CALCUL 131 : C => PERMET UN RETOUR EN ARRIERE EN CAS D'ERREUR 132 : C 133 : C N = 3 134 : C NBSOMP = 0 135 : C ISOMP = 1 136 : C DO 40 I=1,NINTER 136 : C CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, 137 : C > NBFNOE,I,N,ITVL(ISOMP),NBSOMP,iarr) 138 : C IF( iarr .NE. 0 )THEN 139 : C 40 CONTINUE 140 : C 141 : C --- 2.3 CONSTRUCTION DU POLYGONE --- 142 : C ----------------------------- 143 : C BUG1 : IPOLY = ITRI + ( NBC * NBIFR ) + 1 144 : C REMPLACE PAR : 145 : IPOLY = (6* NBIFR) + MAX(1,NBIFR-4) 146 : C PRINT *,' APPEL ARTOPL ' 146 : CALL ARTOPL(ITVL(INOE),2,ITVL(ITRI),2, 147 : > ITVL(IPOLY),NBPP) 148 : C PRINT *,' POLYGONE RESULTANT ' 149 : C PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1)) 150 : C PRINT *,' ORIGINE, EXTREMITE = ',NN(1),NN(2) 151 : IF( NBPP .LE. 3 )THEN 152 : iarr = -1 152 : CALL DSERRE(1,iarr,'RF2FAR', 153 : > ' POLYGONE A MOINS DE 4 COTES') 154 : GOTO 999 155 : ENDIF 156 : C 157 : C 158 : C --- 2.4 DECOUPAGE DU POLYGONE --- 159 : C --------------------------- 160 : C ITVL = | IFR | XXXXX | IPOLY1 | IPOLY2 | IPOLY 161 : C 2*NBIFR NINTER * 3 NBIFR NBIFR NBIFR 162 : C 163 : C ON STOQUE D'ABORD LA FRONTIERE PUIS LA TRIANGULATION 164 : C PUIS ENFIN LES POLYGONES 165 : C 166 : IPOLY1 = (2 * NBIFR) + (NINTER * 3 ) + 1 167 : C IPOLY1 CONTIENT AU MAX NBPP COTES (NBPP = NBIFR) 168 : C IPOLY2 = IPOLY1 + NBPP - 1 169 : IPOLY2 = IPOLY1 + NBIFR - 1 170 : C DANS LE PIRE CAS C'EST IPOLY2 QUI CONTIENT NBPP COTES 171 : C PRINT *,' APPEL SPLIPL ' 172 : C PRINT *,'IPOLY1,IPOLY2,IPOLY = ',IPOLY1,IPOLY2,IPOLY 172 : CALL SPLIPL(ITVL(IPOLY),NBPP,NN,ITVL(IPOLY1),NBPP1, 173 : > ITVL(IPOLY2),NBPP2,iarr) 174 : IF(iarr.NE.0)THEN 175 : C PRINT *,' POLYGONE RESULTANT ' 176 : C PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1)) 177 : C PRINT *,' POLYGONE 1 ' 178 : C PRINT *,' ',(ITVL(IPOLY1+I),I=0,(NBPP1-1)) 179 : C PRINT *,' POLYGONE 2 ' 180 : C PRINT *,' ',(ITVL(IPOLY2+I),I=0,(NBPP2-1)) 180 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL SPLIPL') 181 : GOTO 999 182 : ENDIF 183 : C 184 : C =========================== 185 : C -------- 3. TRIANGULATION DU TROU ------------------ 186 : C =========================== 187 : C ITVL = |NBIFR| ITRIP1 | ITRIP2 | IPOLY1 | IPOLY2 | 188 : C NINTER * 3 NBIFR NBIFR 189 : C 190 : ITRIP1 = ( 2 * NBIFR ) + 1 191 : ITRIP2 = ( 3 *(NBPP1-2) ) + ITRIP1 192 : ITR = 1 193 : NTRMX = NTRMAX 194 : ITI = IPOLY2 + NBIFR 195 : NTIMX = NTIMAX - ITI 196 : C 197 : C PRINT *,' PREMIER APPEL TRPLS2 ' 197 : CALL TRPLS2(COORD,ITVL(IPOLY1),NBPP1, 198 : > ITVL(ITI),NTIMX,RTVL(ITR),NTRMX, 199 : C > ITVL(ITRIP1),TRRILF,QTMIN1,iarr) modif TC esxternal 200 : > ITVL(ITRIP1),QTMIN1,iarr) 201 : IF(iarr.NE.0)THEN 201 : CALL DSERRE(1,iarr,'RF2FAR',' PREMIER APPEL TRPLS2') 202 : GOTO 999 203 : ENDIF 204 : C 205 : C PRINT *,' DEUXIEME APPEL TRPLS2 ' 205 : CALL TRPLS2(COORD,ITVL(IPOLY2),NBPP2, 206 : > ITVL(ITI),NTIMX,RTVL(ITR),NTRMX, 207 : C > ITVL(ITRIP2),TRRILF,QTMIN2,iarr) modif TC external 208 : > ITVL(ITRIP2),QTMIN2,iarr) 209 : IF(iarr.NE.0)THEN 209 : CALL DSERRE(1,iarr,'RF2FAR',' DEUXIEME APPEL TRPLS2') 210 : GOTO 999 211 : ENDIF 212 : C PRINT *,'QUALITE T1 QUALITE T2 ' 213 : C PRINT '(F7.6,F7.6)',QTMIN1,QTMIN2 214 : C 215 : C ======================================================= 216 : C ---- 4. DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ---- 217 : C ======================================================= 218 : N = 3 219 : NBSOMP = 0 220 : ISOMP = 1 221 : C PRINT *,' APPEL SMADET ' 222 : DO 50 I=1,NINTER 222 : CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, 223 : > NBFNOE,I,N,ITVL(ISOMP),NBSOMP,iarr) 224 : IF( iarr .NE. 0 )THEN 224 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL SMADET') 225 : GOTO 999 226 : ENDIF 227 : 50 CONTINUE 228 : C ================================= 229 : C --- 5. CREATION DU NOUVEAU MAILLAGE --- 230 : C ================================= 231 : NBFNOE = 0 232 : C --- ON LIBERE LES IPOLYS --- 233 : ITRAV = IPOLY1 234 : C PRINT *,' APPEL SMACRE ' 235 : NBTRAV = NTIMAX - ITRAV + 1 235 : CALL SMACRE(IDE,ITVL(ITRIP1),NINTER,0, 236 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBFNOE, 237 : > ITVL(ITRAV),NBTRAV,iarr) 238 : IF( iarr .NE. 0 )THEN 238 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL SMACRE') 239 : GOTO 999 240 : ENDIF 241 : C --- POUR LE DEBUG ------- 242 : C PRINT *,'TABLEAU DES NOEUDS ' 243 : C PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),I=1,NINTER) 244 : C PRINT *,'TABLEAU DES VOISINS ' 245 : C PRINT *,((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX),I=1,NINTER) 246 : C 247 : C --- COLLAGE DES FRONTIERES --- 248 : C 249 : IND = 1 250 : C --- ON LIBERE LA TRIANGULATION --- 251 : IFR2 = ITRIP1 252 : NIFMAX = NTIMAX - ITRIP1 253 : C PRINT *,' APPEL TMAFRT ' 253 : CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER, 254 : > ITVL(IFR2),NBIFR,NIFMAX,iarr) 255 : IF( iarr .NE. 0 )THEN 255 : CALL DSERRE(1,iarr,'RF2FAR',' APPEL TMAFRT') 256 : GOTO 999 257 : ENDIF 258 : C 259 : C --- MISE A JOUR DE ITRTRI ----------------- 260 : C 261 : C PRINT *,' APPEL S2GLAR ' 261 : CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR, 262 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL) 263 : C 264 : C --- MISE A JOUR DE NOETRI ----------------- 265 : C 266 : DO 90 I=1,NINTER 267 : DO 80 J=1,NBNMAX 268 : NOEUD = ITRNOE((I-1)*NBNMAX+J) 269 : IF( NOEUD .NE. 0 )NOETRI(NOEUD)=I 270 : 80 CONTINUE 271 : 90 CONTINUE 272 : 999 END 273 : 274 : 275 :
© Cast3M 2003 - All rights reserved.
Disclaimer