1 : C BLOCOS SOURCE CHAT 06/03/29 21:16:04 5360 2 : C ********************************************************************** 3 : C FICHIER : BLOCOS.F 4 : C 5 : C MAILLAGE D'UN DOMAINE DE 4 COTES 6 : C 7 : C OBJET : 8 : C 9 : C OBJET BLOCOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE 10 : C OBJET LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME. 11 : C OBJET Q4CRGR : MAILLAGE EN GRILLE A PARTIR DE 4 COTES 12 : C OBJET (MEME CARDINAUX SUR LES COTES OPPOSES). 13 : C 14 : C 15 : C AUTEUR : O. STAB 16 : C DATE : 06.96 17 : C MODIFICATIONS : 18 : C AUTEUR, DATE, OBJET : 19 : C 20 : C 21 : C ********************************************************************** 22 : C 23 : C 24 : SUBROUTINE BLOCOS(IPOLY,N, 25 : > COORD,IDIMC,NBCOOR, 26 : > NBLIG,NBCOL,ICOIN, 27 : > ITVL,NITMAX, 28 : > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, 29 : > NBE,NBP,NBEMAX,NBPMAX, 30 : > ICOMPR,ILISS,EPSLIS,W, 31 : > ITRACE,IERCOD,iarr) 32 : C ********************************************************************** 33 : C OBJET BLOCOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE 34 : C OBJET LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME. 35 : C 36 : C EN ENTREE : 37 : C ------------- MAILLAGE LINEIQUE ------------ 38 : C IPOLY : TABLEAU DES NOEUDS DU CONTOUR FERME 39 : C N : N(I) NOMBRE D'ELEMENTS SUR LE COTES I 40 : C N(I) DOIVENT ETRE STRICTEMENT POSITIF 41 : C LEUR SOMME DOIT ETRE PAIR. 42 : C COORD : TABLEAU DES COORDONNEES DES POINTS 43 : C IDIMC : DIMENSION DE L'ESPACE (>= 2) 44 : C ------------- TABLEAU DE TRAVAIL ------------ 45 : C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS 46 : C T1 = 2*(NBCOL+NBLIG) POUR LE CONTOUR 47 : C T2 = (NBCOL*NBLIG) POUR LA GRILLE 48 : C T3 = (NBLIG*NBCOL)*6 POUR LA STRUCTURE 49 : C ITVL >= T1+T3 50 : C NITMAX : TAILLE DE ITVL 51 : C SI NBEMAX = 0 NITMAX PEUT ETRE NUL 52 : C SINON NITMAX >= T1+T3 53 : c 54 : C NBNMAX : NOMBRE DE NOEUDS PAR ELEMENT (>=4) 55 : C NBCMAX : NOMBRE DE VOISINS A UN ELEMENT (>=4) 56 : C ------------- TAILLE DES TABLEAU DE SORTIE ------------ 57 : C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS 58 : C SI NBEMAX = 0 LE MAILLAGE N'EST PAS CALCULE 59 : C SEULES LES INFORMATIONS SUR LA GRILLE SONT DONNEES 60 : C SINON NBEMAX >= (NBLIG-1)*(NBCOL-1) 61 : C NBPMAX : NOMBRE MAXIMUM DE POINTS 62 : C NBPMAX >= NBLIG*NBCOL 63 : C 64 : C ITRNOE : TAILLE >= NBEMAX*NBNMAX 65 : C ITRTRI : TAILLE >= NBEMAX*NBCMAX 66 : C NOETRI : TAILLE >= NBPMAX 67 : C COORD : TAILLE >= NBPMAX*IDIMC 68 : C 69 : C ------------- PARAMETRES DE POSTTRAITEMENT ------------ 70 : C ICOMPR : ICOMPR = 1, COMPRESSION ACTIVE 71 : C ILISS : LISSAGE DES NOEUDS INTERIEURS ACTIF 72 : C EPSLIS : DEPLACEMENT NEGLIGEABLE 73 : C W : COEFFICIENT DE RIGIDITE DES ELEMENTS QUADRANGULAIRES 74 : C [0,1] (LISSAGE DE HERRMANN) 75 : C 76 : C EN SORTIE : 77 : C ------------- INFORMATIONS SUR LA GRILLE ----------- 78 : C NBLIG, NBCOL, ICOIN : NOMBRE DE LIGNE ET NOMBRE DE COLONNES DE 79 : C LA GRILLE AVEC LES VALEURS DES COUPER-COLLER AUX COINS. 80 : C ------------- LE MAILLAGE -------------------------- 81 : C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBE,NBP : LE MAILLAGE 82 : C EN QUADRANGLES LINEAIRES 83 : C COORD : TABLEAU DES COORDONNEES DES POINTS (COMPLETE) 84 : C iarr : TYPE D'ERREUR 85 : C -1 SI DONNEES INCORRECTES 86 : C -2 SI TABLEAUX INSUFFISANTS(COORD,ITRNOE OU ITVL) 87 : C IERCOD : CODE DETAILLE DE L'ERREUR 88 : C -100 : ERREUR NON REPERTORIEE 89 : C -101 : LE NOMBRE DE NOEUDS SUR LE CONTOUR EST IMPAIR 90 : C -102 : LA DIMENSION DES COORDONNEES EST INCORRECTE 91 : C -103 : LE CONTOUR N A PAS 4 COTES 92 : C APPELS : Q4CRGR 93 : C ********************************************************************** 94 : IMPLICIT INTEGER(I-N) 95 : INTEGER IPOLY(*),N(*) 96 : REAL*8 COORD(*) 97 : INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX 98 : INTEGER NBLIG,NBCOL,ICOIN(*) 99 : INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX 100 : INTEGER NBEMAX,NBPMAX,NBE,NBP 101 : INTEGER ICOMPR,ILISS 102 : REAL*8 EPSLIS,W 103 : INTEGER ITRACE,IERCOD,iarr 104 : C 105 : C --- VARIABLES INTERNES --- 106 : INTEGER I,ICOURF,IND(4),NBEL2 107 : C 108 : INTEGER INDICE,INCREM 109 : INTEGER NBCOAJ(2),INCOAJ(2),NBAJ 110 : INTEGER INDXYZ,ITRAV,NITMX2 111 : INTEGER ITBLOQ,IPARA,NPASMX,NCC,NBENUL,NBISOL 112 : REAL*8 RELAX,RTRAV(3) 113 : C ============================= 114 : C --- 0. VERIFICATION DES ENTREES --- 115 : C ============================= 116 : IERCOD = -100 117 : NBE = 0 118 : NBP = 0 119 : NBLIG = 0 120 : NBCOL = 0 121 : DO 5 I=1,4 122 : ICOIN(I) = 0 123 : 5 CONTINUE 124 : C 125 : IF( (N(1).LT.1).OR.(N(2).LT.1).OR. 126 : > (N(3).LT.1).OR.(N(4).LT.1))THEN 127 : IERCOD = -103 128 : iarr = -1 129 : GOTO 9999 130 : ENDIF 131 : IF( MOD(N(1)+N(2)+N(3)+N(4),2) .NE.0 )THEN 132 : IERCOD = -101 133 : iarr = -1 134 : GOTO 9999 135 : ENDIF 136 : IF( IDIMC.LT.0 )THEN 137 : IERCOD = -102 138 : iarr = -1 139 : GOTO 9999 140 : ENDIF 141 : C 142 : C =========================== 143 : C --- 0. ON DETERMINE LA MEMOIRE --- 144 : C =========================== 145 : C 145 : CALL G2NBKK(N(1),N(2),N(3),N(4), 146 : > ICOIN(1),ICOIN(2),ICOIN(3),ICOIN(4),iarr) 147 : IF( iarr.NE. 0 )GOTO 9999 148 : C 149 : NBLIG = MAX(N(4)+ICOIN(4)+ICOIN(3),N(2)+ICOIN(2)+ICOIN(1)) + 1 150 : NBCOL = MAX(ICOIN(4)+N(1)+ICOIN(1),ICOIN(2)+N(3)+ICOIN(3)) + 1 151 : NBE = (NBLIG-1)*(NBCOL-1) 152 : NBP = NBCOL*NBLIG 153 : C 154 : IF(NBEMAX.EQ.0)GOTO 9999 155 : C 156 : IF(NBEMAX.LT.NBE)THEN 157 : iarr = -2 157 : CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ') 157 : CALL ESEINT(1,'PLACE NECESSAIRE POUR LES ELEMENTS',NBE*NBNMAX,1) 158 : GOTO 9999 159 : ENDIF 160 : IF(NBPMAX.LT.NBP)THEN 161 : iarr = -2 161 : CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ') 161 : CALL ESEINT(1,'PLACE NECESSAIRE POUR LES NOEUDS',NBP*IDIMC,1) 162 : GOTO 9999 163 : ENDIF 164 : IF(NITMAX.LT.(2*(NBCOL+NBLIG)+(NBCOL*NBLIG)))THEN 165 : iarr = -2 165 : CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ') 165 : CALL ESEINT(1,'PLACE NECESSAIRE POUR LES CALCUL', 166 : > (2*(NBCOL+NBLIG)+(NBCOL*NBLIG)),1) 167 : ENDIF 168 : C 169 : C =========================== 170 : C --- 1. ON COMPLETE LES COURBES --- 171 : C =========================== 172 : C 173 : IF(ITRACE.GT.0) 173 : > CALL ESECHA(1,'-> COURBES COMPLETEES',' ') 174 : C 175 : C 176 : C --- CONSTRUCTION D'UN MAILLAGE DE FRONTIERE SIMPLE : 177 : C DE 4 COTES (NBLIG,NBCOL,NBLIG,NBCOL) 178 : C NOEUDS RESPECTIVEMENT 179 : C --- INDICE DES NOEUDS DES COTES --- 180 : IND(1) = N(1) + 1 181 : DO 10 I=2,4 182 : IND(I) = N(I) + IND(I-1) 183 : 10 CONTINUE 184 : ICOURF = 1 185 : C 186 : INDXYZ = NBCOOR+1 187 : INDICE = NBCOOR+1 188 : INCREM = 1 189 : C 190 : NBAJ = 2 191 : INCOAJ(1) = 1 192 : NBCOAJ(1) = ICOIN(4) 193 : NBCOAJ(2) = ICOIN(1) 194 : INCOAJ(2) = -N(1)-1 194 : CALL G2MOCO(IPOLY,1,N(1)+1, 195 : > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM, 196 : > ITVL(ICOURF),NBLIG2,NBEL2) 197 : C PRINT *,'N1 = ',NBEL2 198 : C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG)) 198 : CALL G2POCO(IPOLY,1,N(1)+1, 199 : > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM, 200 : > COORD,IDIMC) 201 : C 202 : INCOAJ(1) = 1 203 : NBCOAJ(1) = ICOIN(1) 204 : NBCOAJ(2) = ICOIN(2) 205 : INCOAJ(2) = -N(2)-1 206 : C PRINT *,' IND =',ICOURF+NBCOL-1 206 : CALL G2MOCO(IPOLY(IND(1)),1,N(2)+1, 207 : > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM, 208 : > ITVL(ICOURF+NBCOL),NBLIG2,NBEL2) 208 : CALL G2POCO(IPOLY(IND(1)),1,N(2)+1, 209 : > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM, 210 : > COORD,IDIMC) 211 : C PRINT *,'N2 = ',NBEL2 212 : C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG)) 213 : C 214 : INCOAJ(1) = 1 215 : NBCOAJ(1) = ICOIN(2) 216 : NBCOAJ(2) = ICOIN(3) 217 : INCOAJ(2) = -N(3)-1 218 : C PRINT *,' IND =',ICOURF+NBCOL+NBLIG-1 218 : CALL G2MOCO(IPOLY(IND(2)),1,N(3)+1, 219 : > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM, 220 : > ITVL(ICOURF+NBCOL+NBLIG),NBLIG2,NBEL2) 220 : CALL G2POCO(IPOLY(IND(2)),1,N(3)+1, 221 : > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM, 222 : > COORD,IDIMC) 223 : C PRINT *,'N3 = ',NBEL2 224 : C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG)) 225 : C 226 : INCOAJ(1) = 1 227 : NBCOAJ(1) = ICOIN(3) 228 : NBCOAJ(2) = ICOIN(4) 229 : INCOAJ(2) = -N(4)-1 230 : C PRINT *,' IND =',ICOURF+2*NBCOL+NBLIG-1 230 : CALL G2MOCO(IPOLY(IND(3)),1,N(4)+1, 231 : > NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM, 232 : > ITVL(ICOURF+2*NBCOL+NBLIG),NBLIG2,NBEL2) 232 : CALL G2POCO(IPOLY(IND(3)),1,N(4)+1, 233 : > NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM, 234 : > COORD,IDIMC) 235 : C 236 : C PRINT *,'N4 = ',NBEL2 237 : C PRINT *,'IPOLY = ',(IPOLY(I),I=1,N(1)+N(2)+N(3)+N(4)) 238 : C PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG)) 239 : C PRINT *,((COORD((I-1)*IDIMC+J),J=1,IDIMC),'+',I=1,INDXYZ) 240 : C PRINT *,'ITRACE =',ITRACE 241 : C 242 : C ======================================== 243 : C --- 2.CREATION DU PAVAGE --- 244 : C ======================================== 245 : C 246 : C 247 : IF(ITRACE.GT.0) 247 : > CALL ESECHA(1,'-> CREATION DU PAVAGE',' ') 248 : C 249 : ITRAV = ICOURF + 2*(NBLIG+NBCOL) 250 : NITMX2 = NITMAX - ITRAV 251 : NBCOOR = INDXYZ - 1 252 : C ------- POUR LE TEST SANS COLLAGE --- 253 : C DO 20 I=1,4 254 : C ICOIN(I) = 0 255 : C 20 CONTINUE 255 : CALL Q4CRGR(ITVL(ICOURF),ITVL(NBCOL+ICOURF), 256 : > ITVL(ICOURF+NBCOL+NBLIG), 257 : > ITVL(ICOURF+2*NBCOL+NBLIG),N, 258 : > COORD,IDIMC,NBCOOR, 259 : > NBLIG,NBCOL,ICOIN, 260 : > ITVL(ITRAV),NITMX2, 261 : > IDE,ITRNOE,NBNMAX,NBE,NBP, 262 : > NBEMAX,NBPMAX,ITRACE,iarr) 263 : C 264 : IF(iarr.NE.0)THEN 264 : CALL DSERRE(1,iarr,'BLOCOS',' APPEL Q4CRGR ') 265 : GOTO 9999 266 : ENDIF 267 : C 268 : C =================================================== 269 : C --- 3. COMPRESSION DU MAILLAGE --- 270 : C =================================================== 271 : C 272 : IDE = 2 273 : C 274 : IF(( (ICOIN(1)+ICOIN(2)+ICOIN(3)+ICOIN(4)).NE.0).AND. 275 : > (ICOMPR.EQ.1))THEN 276 : C 277 : IF(ITRACE.GT.0) 277 : > CALL ESECHA(1,'-> COMPRESSION DU MAILLAGE',' ') 278 : C 279 : NBENUL = NBE 280 : NBISOL = NBP 280 : CALL NUGCNU(IDE,ITRNOE,NBNMAX,0,0, 281 : > 0,0,NBE,COORD,IDIMC,NBP, 282 : > ITVL,NITMAX,iarr) 283 : C 284 : IF(iarr.NE.0)THEN 284 : CALL DSERRE(1,iarr,'BLOCOS',' APPEL NUGCNU ') 285 : GOTO 9999 286 : ENDIF 287 : C 288 : IF(ITRACE.GT.0)THEN 288 : CALL ESEINT(1,'NOMBRE D ELEMENTS SUPPRIMES : ',NBENUL-NBE,1) 288 : CALL ESEINT(1,'NOMBRE DE POINTS SUPPRIMES : ',NBISOL-NBP,1) 289 : ENDIF 290 : ENDIF 291 : C 292 : C ============================================ 293 : C --- 4.CREATION DE LA STRUCTURE DE DONNEES --- 294 : C ============================================ 295 : C 296 : IF(ITRACE.GT.0) 296 : > CALL ESECHA(1,'-> CREATION DE LA STRUCTURE',' ') 297 : C 297 : CALL SMAOCR(IDE,ITRNOE,NBE,COORD,NBP,IDIMC, 298 : > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, 299 : > ITVL,NITMAX,NCC,iarr) 300 : C 301 : IF(iarr.NE.0)THEN 301 : CALL DSERRE(1,iarr,'BLOCOS',' APPEL SMAOCR ') 302 : GOTO 9999 303 : ENDIF 304 : C 305 : C ============================================ 306 : C --- 5.LISSAGE (BARYCENTRIQUE,ISOPARAMETRIQUE) --- 307 : C ============================================ 308 : C 309 : IF( ILISS.EQ. 1)THEN 310 : C 311 : IF(ITRACE.GT.0) 311 : > CALL ESECHA(1,'-> LISSAGE',' ') 312 : C 313 : C WRITE(6,*) 'ITRTRI = ',((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX), 314 : C > '/',I=1,NBE) 315 : C WRITE(6,*) 'NOETRI = ',(NOETRI(I),I=1,NBN) 316 : ITBLOQ = 1 317 : IPARA = 0 318 : RELAX = 1.5 319 : NPASMX = 100 319 : * CALL LISNOI(ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBP, 320 : * > COORD,IDIMC, 321 : * > COORD,IDIMC,EPSLIS,COORD, 322 : * > ITBLOQ,0,0, 323 : * > IPARA,RELAX,NPASMX, 324 : * > W,RTRAV,ITRACE,iarr) 325 : C 326 : IF(iarr.NE.0)THEN 326 : CALL DSERRE(1,iarr,'BLOCOS',' APPEL LISNOI ') 327 : GOTO 9999 328 : ENDIF 329 : ENDIF 330 : C 331 : 9999 END 332 : 333 : 334 : 335 :
© Cast3M 2003 - All rights reserved.
Disclaimer