1 : C G2GLKK SOURCE CHAT 06/03/29 21:21:39 5360 2 : C 3 : C 4 : SUBROUTINE G2GLKK(ICOIN,KCOIN,NBLIG,NBCOL, 5 : > ITRNOE,NBNMAX,iarr) 6 : C ********************************************************************** 7 : C OBJET G2GLKK : COLLAGE D'UN COIN D'UN MAILLAGE GRILLE 2D 8 : C 9 : C EN ENTREE : 10 : C ICOIN, KCOIN : INDICE DU COIN ET NOMBRE D'ELEMENTS A ENLEVER 11 : C ITRNOE : MAILLAGE GRILLE 12 : C NBNMAX : NOMBRE MAXIMUM DE NOEUDS PAR MAILLES 13 : C NBLIG, NBCOL : NOMBRE DE LIGNES ET DE COLONNES DE LA GRILLE 14 : C 15 : C EN SORTIE : 16 : C ITRNOE : MAILLAGE GRILLE MODIFIE 17 : C iarr : CODE D'ERREUR (INUTILISE) 18 : C 19 : C REMARQUE : ATTENTION LE MAILLAGE RESULTANT GARDE UNE STRUCTURE 20 : C DE GRILLE (NBLIG,NBCOL). CELA SIGNIFIE QU'IL Y A DES 21 : C ELEMENTS "NULS" (TOUS LEURS NOEUDS SONT A "0"). 22 : C ********************************************************************** 23 : IMPLICIT INTEGER(I-N) 24 : INTEGER ICOIN,KCOIN,NBLIG,NBCOL,NBNMAX 25 : INTEGER ITRNOE(*),iarr 26 : C 27 : INTEGER I,J,K,IE,IN,INNEW 28 : C 29 : GOTO( 5,50,100,150 ) ICOIN 30 : 1 iarr = 0 31 : GOTO 999 32 : C ========= 33 : C --- COIN K1 --- 34 : C ========= 35 : 5 I = NBCOL - KCOIN 36 : INNEW = NBCOL+1 37 : C PRINT *,'COLONNE' 38 : DO 10 J=1,KCOIN 39 : K = (J-1)*(NBCOL+1)+I 40 : IE = K-J+1 41 : C INNEW = J*NBCOL+1 42 : C PRINT *,'NOEUD =',K+1,'ELEM =',IE, 43 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+2), 44 : C > 'NOUVEAU NOEUD = ',INNEW 45 : ITRNOE((IE-1)*NBNMAX+2) = INNEW 46 : INNEW = INNEW + NBCOL 47 : C PRINT *,'NOEUD =',K+NBCOL+2,'ELEM =',IE, 48 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+3), 49 : C > 'NOUVEAU NOEUD = ',INNEW 50 : ITRNOE((IE-1)*NBNMAX+3) = INNEW 51 : 10 CONTINUE 52 : J = KCOIN +1 53 : INNEW = (KCOIN+1)*NBCOL+1 54 : C PRINT *,'LIGNE' 55 : DO 20 I=(NBCOL +1- KCOIN),NBCOL 56 : K = (J-1)*(NBCOL+1)+I 57 : IE = K-J+1 58 : IN = K 59 : C INNEW = (NBCOL-I+2)*NBCOL+1 60 : C PRINT *,'NOEUD =',K,'ELEM =',IE, 61 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+1), 62 : C > 'NOUVEAU NOEUD = ',INNEW 63 : ITRNOE((IE-1)*NBNMAX+1) = INNEW 64 : C IN = IN+NBCOL+1 65 : INNEW = INNEW - NBCOL 66 : C PRINT *,'NOEUD =',K+1,'ELEM =',IE, 67 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+2), 68 : C > 'NOUVEAU NOEUD = ',INNEW 69 : ITRNOE((IE-1)*NBNMAX+2) = INNEW 70 : 20 CONTINUE 71 : C --- DESTRUCTION --- 72 : DO 40 I=(NBCOL-KCOIN+1),NBCOL 73 : DO 35 J=1,KCOIN 74 : IE = (J-1)*NBCOL+I 75 : DO 30 K=1,NBNMAX 76 : ITRNOE((IE-1)*NBNMAX+K) = 0 77 : 30 CONTINUE 78 : 35 CONTINUE 79 : 40 CONTINUE 80 : GOTO 999 81 : C ========= 82 : C --- COIN K2 --- 83 : C ========= 84 : 50 I = NBCOL - KCOIN 85 : INNEW = (NBLIG+1-KCOIN)*(NBCOL+2)-NBLIG-1 86 : C PRINT *,'COLONNE' 87 : DO 60 J=(NBLIG+1-KCOIN),NBLIG 88 : K = (J-1)*(NBCOL+1)+I 89 : IE = K-J+1 90 : C INNEW = (I-NBCOL+NBLIG)*(NBCOL+2)-1-NBLIG 91 : C INNEW = J*(NBCOL+2)-NBLIG-1 92 : C PRINT *,'NOEUD =',K+1,'ELEM =',IE, 93 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+2), 94 : C > 'NOUVEAU NOEUD = ',INNEW 95 : ITRNOE((IE-1)*NBNMAX+2) = INNEW 96 : INNEW = INNEW + NBCOL + 2 97 : C PRINT *,'NOEUD =',K+NBCOL+2,'ELEM =',IE, 98 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+3), 99 : C > 'NOUVEAU NOEUD = ',INNEW 100 : ITRNOE((IE-1)*NBNMAX+3) = INNEW 101 : 60 CONTINUE 102 : J = NBLIG - KCOIN 103 : INNEW = (NBLIG+1-KCOIN)*(NBCOL+2)-1-NBLIG 104 : C PRINT *,'LIGNE' 105 : DO 70 I=(NBCOL +1- KCOIN),NBCOL 106 : K = (J-1)*(NBCOL+1)+I 107 : IE = K-J+1 108 : IN = K 109 : C INNEW = (NBLIG-KCOIN)*NBCOL+I-1 110 : C INNEW = (I-NBCOL+NBLIG)*(NBCOL+2)-1-NBLIG 111 : C PRINT *,'NOEUD =',K+NBCOL+1,'ELEM =',IE, 112 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+4), 113 : C > 'NOUVEAU NOEUD = ',INNEW 114 : ITRNOE((IE-1)*NBNMAX+4) = INNEW 115 : C IN = IN+NBCOL+1 116 : INNEW = INNEW + NBCOL + 2 117 : C PRINT *,'NOEUD =',K+NBCOL+2,'ELEM =',IE, 118 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+3), 119 : C > 'NOUVEAU NOEUD = ',INNEW 120 : ITRNOE((IE-1)*NBNMAX+3) = INNEW 121 : 70 CONTINUE 122 : C --- DESTRUCTION --- 123 : DO 90 I=(NBCOL-KCOIN+1),NBCOL 124 : DO 85 J=(NBLIG-KCOIN+1),NBLIG 125 : IE = (J-1)*NBCOL+I 126 : DO 80 K=1,NBNMAX 127 : ITRNOE((IE-1)*NBNMAX+K) = 0 128 : 80 CONTINUE 129 : 85 CONTINUE 130 : 90 CONTINUE 131 : GOTO 999 132 : C ========= 133 : C --- COIN K3 --- 134 : C ========= 135 : 100 I = KCOIN+1 136 : C PRINT *,'COLONNE' 137 : INNEW = (NBLIG-KCOIN)*(NBCOL+1)+KCOIN+1 138 : DO 110 J=(NBLIG+1-KCOIN),NBLIG 139 : K = (J-1)*(NBCOL+1)+I 140 : IE = K-J+1 141 : C PRINT *,'NOEUD =',K,'ELEM =',IE, 142 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+1), 143 : C > 'NOUVEAU NOEUD = ',INNEW 144 : ITRNOE((IE-1)*NBNMAX+1) = INNEW 145 : INNEW = INNEW + NBCOL 146 : C PRINT *,'NOEUD =',K+NBCOL+2,'ELEM =',IE, 147 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+4), 148 : C > 'NOUVEAU NOEUD = ',INNEW 149 : ITRNOE((IE-1)*NBNMAX+4) = INNEW 150 : 110 CONTINUE 151 : J = NBLIG - KCOIN 152 : C PRINT *,'LIGNE' 153 : INNEW = NBLIG*(NBCOL+1)+1 154 : DO 120 I=1,KCOIN 155 : K = (J-1)*(NBCOL+1)+I 156 : IE = K-J+1 157 : IN = K 158 : C INNEW = (NBLIG-KCOIN)*NBCOL+I-1 159 : C PRINT *,'NOEUD =',K+NBCOL+1,'ELEM =',IE, 160 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+4), 161 : C > 'NOUVEAU NOEUD = ',INNEW 162 : ITRNOE((IE-1)*NBNMAX+4) = INNEW 163 : C IN = IN+NBCOL+1 164 : INNEW = INNEW - NBCOL 165 : C PRINT *,'NOEUD =',K+NBCOL+2,'ELEM =',IE, 166 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+3), 167 : C > 'NOUVEAU NOEUD = ',INNEW 168 : ITRNOE((IE-1)*NBNMAX+3) = INNEW 169 : 120 CONTINUE 170 : C --- DESTRUCTION --- 171 : DO 140 I=1,KCOIN 172 : DO 135 J=(NBLIG-KCOIN+1),NBLIG 173 : IE = (J-1)*NBCOL+I 174 : DO 130 K=1,NBNMAX 175 : ITRNOE((IE-1)*NBNMAX+K) = 0 176 : 130 CONTINUE 177 : 135 CONTINUE 178 : 140 CONTINUE 179 : GOTO 999 180 : C ========= 181 : C --- COIN K4 --- 182 : C ========= 183 : 150 I = KCOIN +1 184 : INNEW = 1 185 : DO 160 J=1,KCOIN 186 : K = (J-1)*(NBCOL+1)+I 187 : IE = K-J+1 188 : C INNEW = (J-1)*(NBCOL+2)+1 189 : C PRINT *,'NOEUD =',K,'ELEM =',IE, 190 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+1), 191 : C > 'NOUVEAU NOEUD = ',INNEW 192 : ITRNOE((IE-1)*NBNMAX+1) = INNEW 193 : INNEW = INNEW + NBCOL + 2 194 : C PRINT *,'NOEUD =',K+NBCOL+1,'ELEM =',IE, 195 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+4), 196 : C > 'NOUVEAU NOEUD = ',INNEW 197 : ITRNOE((IE-1)*NBNMAX+4) = INNEW 198 : 160 CONTINUE 199 : J = KCOIN +1 200 : INNEW = 1 201 : DO 170 I=1,KCOIN 202 : K = (J-1)*(NBCOL+1)+I 203 : IE = K-J+1 204 : IN = K 205 : C INNEW = (I-1)*(NBCOL+2)+1 206 : C PRINT *,'NOEUD =',K,'ELEM =',IE, 207 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+1), 208 : C > 'NOUVEAU NOEUD = ',INNEW 209 : ITRNOE((IE-1)*NBNMAX+1) = INNEW 210 : C IN = IN+NBCOL+1 211 : INNEW = INNEW + NBCOL + 2 212 : C PRINT *,'NOEUD =',K+1,'ELEM =',IE, 213 : C > 'NOEUD DE ELEM =', ITRNOE((IE-1)*NBNMAX+2), 214 : C > 'NOUVEAU NOEUD = ',INNEW 215 : ITRNOE((IE-1)*NBNMAX+2) = INNEW 216 : 170 CONTINUE 217 : C --- DESTRUCTION --- 218 : DO 200 I=1,KCOIN 219 : DO 190 J=1,KCOIN 220 : IE = (J-1)*NBCOL+I 221 : DO 180 K=1,NBNMAX 222 : ITRNOE((IE-1)*NBNMAX+K) = 0 223 : 180 CONTINUE 224 : 190 CONTINUE 225 : 200 CONTINUE 226 : GOTO 999 227 : C 228 : 999 END 229 : 230 : 231 :
© Cast3M 2003 - All rights reserved.
Disclaimer