1 : C G3GLKK SOURCE CHAT 06/03/29 21:22:23 5360 2 : C 3 : C 4 : SUBROUTINE G3GLKK(IARETE,KARETE,NBLIG,NBCOL,NBRAN, 5 : > ITRNOE,NBNMAX,iarr) 6 : C ********************************************************************** 7 : C OBJET G3GLKK : COLLAGE D'UNE ARETE D'UNE GRILLE 3D 8 : C 9 : C ARETE (K2,K10,K8 OU K7) POUR LE RACCORD DE LA FACE (K4,K7,K12,K8) 10 : C A LA FACE (K2,K6,K10,K5) 11 : C 12 : C EN ENTREE : 13 : C IARETE : NUMERO DE L'ARETE DU BLOC (2,10,8 OU 7) 14 : C KARETE : NOMBRE DE COUCHE D'ELEMENTS A DETRUIRE 15 : C NBLIG,NBCOL,NBRAN : DEFINITION DE LA GRILLE 16 : C ITRNOE : MAILLAGE A MODIFIER 17 : C NBNMAX : NOMBRE MAXIMUM DE NOEUDS PAR MAILLE 18 : C 19 : C EN SORTIE : 20 : C ITRNOE : MAILLAGE MODIFIE. 21 : C LES ELEMENTS DETRUITS ONT TOUS LEURS NOEUDS A 0 22 : C 23 : C ********************************************************************** 24 : IMPLICIT INTEGER(I-N) 25 : INTEGER IARETE,KARETE,NBLIG,NBCOL,NBRAN,NBNMAX 26 : INTEGER ITRNOE(*),iarr 27 : C 28 : INTEGER I,I0,J,J0,K,K0,L,IE,P1,P2,P3,P4 29 : C 30 : GOTO( 1,5,1,1,1,1,200,300,1,400 ) IARETE 31 : 1 iarr = 0 32 : GOTO 999 33 : C ========= 34 : C --- ARETE K2 --- 35 : C ========= 36 : 5 I = NBCOL - KARETE 37 : C PRINT *,'=====ARETE ',IARETE,' =====' 38 : C PRINT *,'---INF---' 39 : DO 15 K=1,KARETE 40 : DO 10 J=1,NBLIG 41 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 42 : C 43 : P1 = (NBCOL+2-K) + (J-1)*(NBCOL+1)+ (K-1)*(NBLIG+1)*(NBCOL+1) 44 : P2 = P1 + (NBCOL+1) 45 : P3 = P1 - 1 + (NBLIG+1)*(NBCOL+1) 46 : P4 = P1 - 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 47 : C 48 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 49 : C PRINT *,ITRNOE((IE-1)*NBNMAX+2),ITRNOE((IE-1)*NBNMAX+3), 50 : C > ITRNOE((IE-1)*NBNMAX+6),ITRNOE((IE-1)*NBNMAX+7) 51 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 52 : C 53 : ITRNOE((IE-1)*NBNMAX+2) = P1 54 : ITRNOE((IE-1)*NBNMAX+3) = P2 55 : ITRNOE((IE-1)*NBNMAX+6) = P3 56 : ITRNOE((IE-1)*NBNMAX+7) = P4 57 : 10 CONTINUE 58 : 15 CONTINUE 59 : K = KARETE +1 60 : C PRINT *,'---SUP---' 61 : DO 40 I=NBCOL-KARETE+1,NBCOL 62 : DO 30 J=1,NBLIG 63 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 64 : C 65 : C P1 = (NBCOL+1-KARETE+I) + (J-1)*(NBCOL+1)+ 66 : C > (K-I+1)*(NBLIG+1)*(NBCOL+1) 67 : P1 = I + (J-1)*(NBCOL+1)+(NBCOL-I+1)*(NBLIG+1)*(NBCOL+1) 68 : P2 = P1+1 - (NBLIG+1)*(NBCOL+1) 69 : P3 = P1+1 + (NBCOL+1) - (NBLIG+1)*(NBCOL+1) 70 : P4 = P1 + (NBCOL+1) 71 : C 72 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 73 : C PRINT *,ITRNOE((IE-1)*NBNMAX+1),ITRNOE((IE-1)*NBNMAX+2), 74 : C > ITRNOE((IE-1)*NBNMAX+3),ITRNOE((IE-1)*NBNMAX+4) 75 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 76 : C 77 : ITRNOE((IE-1)*NBNMAX+1) = P1 78 : ITRNOE((IE-1)*NBNMAX+2) = P2 79 : ITRNOE((IE-1)*NBNMAX+3) = P3 80 : ITRNOE((IE-1)*NBNMAX+4) = P4 81 : 30 CONTINUE 82 : 40 CONTINUE 83 : C 84 : C --- DESTRUCTION --- 85 : C 86 : DO 80 K=1,KARETE 87 : DO 70 I=(NBCOL-KARETE+1),NBCOL 88 : DO 60 J=1,NBLIG 89 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 90 : DO 50 L=1,NBNMAX 91 : ITRNOE((IE-1)*NBNMAX+L) = 0 92 : 50 CONTINUE 93 : 60 CONTINUE 94 : 70 CONTINUE 95 : 80 CONTINUE 96 : GOTO 999 97 : C ========= 98 : C --- ARETE K7 --- 99 : C ========= 100 : C ... 101 : 200 I = KARETE+1 102 : C PRINT *,'=====ARETE ',IARETE,' =====' 103 : C PRINT *,'---DROIT---' 104 : J0 = NBLIG-KARETE 105 : DO 215 K=1,NBRAN 106 : DO 210 J=1,KARETE 107 : IE = I + (J+J0-1)*NBCOL + (K-1)*NBLIG*NBCOL 108 : C 109 : P1 = KARETE+2-J +(J+J0-1)*(NBCOL+1) +(K-1)*(NBLIG+1)*(NBCOL+1) 110 : P2 = P1 - 1 + (NBCOL+1) 111 : P3 = P1 + (NBLIG+1)*(NBCOL+1) 112 : P4 = P1 - 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 113 : C 114 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 115 : C PRINT *,ITRNOE((IE-1)*NBNMAX+1),ITRNOE((IE-1)*NBNMAX+4), 116 : C > ITRNOE((IE-1)*NBNMAX+5),ITRNOE((IE-1)*NBNMAX+8) 117 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 118 : C 119 : ITRNOE((IE-1)*NBNMAX+1) = P1 120 : ITRNOE((IE-1)*NBNMAX+4) = P2 121 : ITRNOE((IE-1)*NBNMAX+5) = P3 122 : ITRNOE((IE-1)*NBNMAX+8) = P4 123 : 210 CONTINUE 124 : 215 CONTINUE 125 : J = NBLIG - KARETE 126 : C PRINT *,'---GAUCH---' 127 : DO 240 I=1,KARETE 128 : DO 230 K=1,NBRAN 129 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 130 : C 131 : P1 = I + (NBLIG-I+1)*(NBCOL+1) + (K-1)*(NBLIG+1)*(NBCOL+1) 132 : P2 = P1 + 1 - (NBCOL+1) 133 : P3 = P1 + (NBLIG+1)*(NBCOL+1) 134 : P4 = P1 + 1 - (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 135 : C 136 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 137 : C PRINT *,ITRNOE((IE-1)*NBNMAX+4),ITRNOE((IE-1)*NBNMAX+3), 138 : C > ITRNOE((IE-1)*NBNMAX+8),ITRNOE((IE-1)*NBNMAX+7) 139 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 140 : C 141 : ITRNOE((IE-1)*NBNMAX+4) = P1 142 : ITRNOE((IE-1)*NBNMAX+3) = P2 143 : ITRNOE((IE-1)*NBNMAX+8) = P3 144 : ITRNOE((IE-1)*NBNMAX+7) = P4 145 : 230 CONTINUE 146 : 240 CONTINUE 147 : C 148 : C --- DESTRUCTION --- 149 : C 150 : DO 280 K=1,NBRAN 151 : DO 270 I=1,KARETE 152 : DO 260 J=NBLIG-KARETE+1,NBLIG 153 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 154 : DO 250 L=1,NBNMAX 155 : ITRNOE((IE-1)*NBNMAX+L) = 0 156 : 250 CONTINUE 157 : 260 CONTINUE 158 : 270 CONTINUE 159 : 280 CONTINUE 160 : GOTO 999 161 : C 162 : C ========= 163 : C --- ARETE K8 --- 164 : C ========= 165 : C ... 166 : 300 I = KARETE+1 167 : C PRINT *,'=====ARETE ',IARETE,' =====' 168 : C PRINT *,'---DROIT---' 169 : DO 315 K=1,NBRAN 170 : DO 310 J=1,KARETE 171 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 172 : C 173 : P1 = J + (J-1)*(NBCOL+1) + (K-1)*(NBLIG+1)*(NBCOL+1) 174 : P2 = P1 + 1 + (NBCOL+1) 175 : P3 = P1 + (NBLIG+1)*(NBCOL+1) 176 : P4 = P1 + 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 177 : C 178 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 179 : C PRINT *,ITRNOE((IE-1)*NBNMAX+1),ITRNOE((IE-1)*NBNMAX+4), 180 : C > ITRNOE((IE-1)*NBNMAX+5),ITRNOE((IE-1)*NBNMAX+8) 181 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 182 : C 183 : ITRNOE((IE-1)*NBNMAX+1) = P1 184 : ITRNOE((IE-1)*NBNMAX+4) = P2 185 : ITRNOE((IE-1)*NBNMAX+5) = P3 186 : ITRNOE((IE-1)*NBNMAX+8) = P4 187 : 310 CONTINUE 188 : 315 CONTINUE 189 : J = KARETE + 1 190 : C PRINT *,'---GAUCH---' 191 : DO 340 I=1,KARETE 192 : DO 330 K=1,NBRAN 193 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 194 : C 195 : P1 = I + (I-1)*(NBCOL+1) + (K-1)*(NBLIG+1)*(NBCOL+1) 196 : P2 = P1 + 1 + (NBCOL+1) 197 : P3 = P1 + (NBLIG+1)*(NBCOL+1) 198 : P4 = P1 + 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 199 : C 200 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 201 : C PRINT *,ITRNOE((IE-1)*NBNMAX+1),ITRNOE((IE-1)*NBNMAX+2), 202 : C > ITRNOE((IE-1)*NBNMAX+5),ITRNOE((IE-1)*NBNMAX+6) 203 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 204 : C 205 : ITRNOE((IE-1)*NBNMAX+1) = P1 206 : ITRNOE((IE-1)*NBNMAX+2) = P2 207 : ITRNOE((IE-1)*NBNMAX+5) = P3 208 : ITRNOE((IE-1)*NBNMAX+6) = P4 209 : 330 CONTINUE 210 : 340 CONTINUE 211 : C 212 : C --- DESTRUCTION --- 213 : C 214 : DO 380 K=1,NBRAN 215 : DO 370 I=1,KARETE 216 : DO 360 J=1,KARETE 217 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 218 : DO 350 L=1,NBNMAX 219 : ITRNOE((IE-1)*NBNMAX+L) = 0 220 : 350 CONTINUE 221 : 360 CONTINUE 222 : 370 CONTINUE 223 : 380 CONTINUE 224 : GOTO 999 225 : C 226 : C ========== 227 : C --- ARETE K10 --- 228 : C ========== 229 : C ... 230 : 400 I = NBCOL - KARETE 231 : C PRINT *,'=====ARETE ',IARETE,' =====' 232 : C PRINT *,'---SUP---' 233 : K0 = NBRAN-KARETE 234 : DO 415 K=1,KARETE 235 : DO 410 J=1,NBLIG 236 : IE = I + (J-1)*NBCOL + (K+K0-1)*NBLIG*NBCOL 237 : C 238 : P1 = (NBCOL-KARETE+K) + (J-1)*(NBCOL+1)+ 239 : > (K+K0-1)*(NBLIG+1)*(NBCOL+1) 240 : P2 = P1 + (NBCOL+1) 241 : P3 = P1 + 1 + (NBLIG+1)*(NBCOL+1) 242 : P4 = P1 + 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 243 : C 244 : C P1 = (NBCOL+2-K) + (J-1)*(NBCOL+1)+ (K-1)*(NBLIG+1)*(NBCOL+1) 245 : C P2 = P1 + (NBCOL+1) 246 : C P3 = P1 - 1 + (NBLIG+1)*(NBCOL+1) 247 : C P4 = P1 - 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 248 : C 249 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 250 : C PRINT *,ITRNOE((IE-1)*NBNMAX+2),ITRNOE((IE-1)*NBNMAX+3), 251 : C > ITRNOE((IE-1)*NBNMAX+6),ITRNOE((IE-1)*NBNMAX+7) 252 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 253 : C 254 : ITRNOE((IE-1)*NBNMAX+2) = P1 255 : ITRNOE((IE-1)*NBNMAX+3) = P2 256 : ITRNOE((IE-1)*NBNMAX+6) = P3 257 : ITRNOE((IE-1)*NBNMAX+7) = P4 258 : 410 CONTINUE 259 : 415 CONTINUE 260 : K = NBRAN - KARETE 261 : C PRINT *,'---INF---' 262 : I0 = NBCOL-KARETE 263 : DO 440 I=1,KARETE 264 : DO 430 J=1,NBLIG 265 : IE = I+I0 + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 266 : C 267 : P1 = I+I0 + (J-1)*(NBCOL+1)+(K+I-1)*(NBLIG+1)*(NBCOL+1) 268 : P2 = P1 + (NBCOL+1) 269 : P3 = P1 + 1 + (NBLIG+1)*(NBCOL+1) 270 : P4 = P1 + 1 + (NBCOL+1) + (NBLIG+1)*(NBCOL+1) 271 : C 272 : C P1 = I + (J-1)*(NBCOL+1)+(NBCOL-I+1)*(NBLIG+1)*(NBCOL+1) 273 : C P2 = P1+1 - (NBLIG+1)*(NBCOL+1) 274 : C P3 = P1+1 + (NBCOL+1) - (NBLIG+1)*(NBCOL+1) 275 : C P4 = P1 + (NBCOL+1) 276 : C 277 : C PRINT *,'IE =',IE,' ANCIEN POINTS = ' 278 : C PRINT *,ITRNOE((IE-1)*NBNMAX+5),ITRNOE((IE-1)*NBNMAX+8), 279 : C > ITRNOE((IE-1)*NBNMAX+6),ITRNOE((IE-1)*NBNMAX+7) 280 : C PRINT *,' NOUVEAUX POINTS = ',P1,P2,P3,P4 281 : C 282 : ITRNOE((IE-1)*NBNMAX+5) = P1 283 : ITRNOE((IE-1)*NBNMAX+8) = P2 284 : ITRNOE((IE-1)*NBNMAX+6) = P3 285 : ITRNOE((IE-1)*NBNMAX+7) = P4 286 : 430 CONTINUE 287 : 440 CONTINUE 288 : C 289 : C --- DESTRUCTION --- 290 : C 291 : DO 480 K=(NBRAN-KARETE+1),NBRAN 292 : DO 470 I=(NBCOL-KARETE+1),NBCOL 293 : DO 460 J=1,NBLIG 294 : IE = I + (J-1)*NBCOL + (K-1)*NBLIG*NBCOL 295 : DO 450 L=1,NBNMAX 296 : ITRNOE((IE-1)*NBNMAX+L) = 0 297 : 450 CONTINUE 298 : 460 CONTINUE 299 : 470 CONTINUE 300 : 480 CONTINUE 301 : GOTO 999 302 : C 303 : C 304 : 999 END 305 : 306 : 307 :
© Cast3M 2003 - All rights reserved.
Disclaimer