1 : C GRADIA SOURCE CHAT 05/01/13 00:20:39 5004 2 : SUBROUTINE GRADIA(ICEN,ISOMM,IFACEL,IFACEP,IMAIL,ISGLIM, 3 : & ICHELM) 4 : C 5 : C**** Variables de COOPTIO 6 : C 7 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 8 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 9 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 10 : C & ,IECHO, IIMPI, IOSPI 11 : C & ,IDIM 12 : C & ,MCOORD 13 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 14 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 15 : C & ,NORINC,NORVAL,NORIND,NORVAD 16 : C & ,NUCROU, IPSAUV 17 : C 18 : IMPLICIT INTEGER(I-N) 19 : -INC CCOPTIO 20 : -INC SMCHPOI 21 : -INC SMELEME 22 : -INC SMLREEL 23 : -INC SMLENTI 24 : -INC SMLMOTS 25 : C 26 : INTEGER ISGLIM 27 : & ,ICEN,ISOMM,IFACEL,IFACEP,IMAIL,IFACE,IFACE1 28 : & ,ICHELM 29 : 30 : C 31 : SEGMENT MLELEM 32 : INTEGER INDEX(NBL+1) 33 : INTEGER LESPOI(NBTPOI) 34 : ENDSEGMENT 35 : POINTEUR MLELSB.MLELEM, MLELSC.MLELEM, MLESBC.MLELEM, 36 : & MLESCF.MLELEM,MLEFSC.MLELEM, 37 : & MLRDIS.MLREEL, MLEFC.MLELEM 38 : C 39 : INTEGER N1,N2 40 : SEGMENT MATRIX 41 : REAL*8 MAT(N1,N2) 42 : ENDSEGMENT 43 : POINTEUR MATCOE.MATRIX, MACOE1.MATRIX, MACOE2.MATRIX 44 : C 45 : C 46 : C**** Ordonnement FACE, FACEL, FACEP avec le meme ordre 47 : C 47 : CALL RLEORD(IFACEL,IFACEP,IFACE,IFACE1) 48 : IF(IERR .NE. 0)GOTO 9999 49 : C 50 : C**** test RLEORD 51 : C 52 : C MELEME= IFACEP 53 : C IPT1 = IFACE1 54 : C SEGACT MELEME 55 : C SEGACT IPT1 56 : C NBSOUS=MELEME.LISOUS(/1) 57 : C JG=MAX(1,NBSOUS) 58 : C SEGINI MLENTI 59 : C IF(NBSOUS.EQ.0)THEN 60 : C MLENTI.LECT(1)=IFACEP 61 : C ELSE 62 : C DO I1 = 1, NBSOUS, 1 63 : C MLENTI.LECT(I1)=MELEME.LISOUS(I1) 64 : C ENDDO 65 : C ENDIF 66 : C NBSOUS=JG 67 : C IELEM=0 68 : C DO I1 = 1, NBSOUS, 1 69 : C IPT2=MLENTI.LECT(I1) 70 : C SEGACT IPT2 71 : C NBN=IPT2.NUM(/1) 72 : C NBE=IPT2.NUM(/2) 73 : C DO I2 = 1, NBE, 1 74 : C IELEM=IELEM+1 75 : C NGF=IPT2.NUM(NBN,I2) 76 : C NGF1=IPT1.NUM(2,IELEM) 77 : C write(ioimp,*) ngf, ngf1 78 : C ENDDO 79 : C ENDDO 80 : C 81 : C**** Fin test 82 : C 83 : IFACEL=IFACE1 84 : C 85 : C Ici on crée les MELEME IFACE, IFACEL (à eliminer)! 86 : C 87 : C**** Ls voisins type SOMMETS des sommets sur le bord 88 : C 88 : CALL RLEXVB(IFACEL,IFACEP,ISOMM,MLELSB) 89 : IF(IERR.NE.0) GOTO 9999 90 : C 91 : C**** MLELSB = LISTE SEQUENTIELLE INDEXEE D'ELEMENTS 92 : C 93 : C NBL : NOMBRE D'ELEMENTS 94 : C NBTPOI : NOMBRE TOTAL DE POINTS REFERENCEES 95 : C INDEX(I) : INDICE DU 1ER POINT DU IEME ELEMENT 96 : C DANS LE TABLEAU LESPOI 97 : C LESPOI(INDEX(I) -> INDEX(I+1)-1) : NUMERO DES NOEUDS 98 : C DU IEME ELEMENT 99 : C 100 : C NB: LESPOI contient de numero (globals) de noeuds 101 : C (voir RLEVFA) 102 : C 103 : C**** Test de RLEXVB 104 : C 105 : C SEGACT MLELSB 106 : C MELEME = ISOMM 107 : C SEGACT MELEME 108 : C NBL=MLELSB.INDEX(/1)-1 109 : C NBTPOI=MLELSB.LESPOI(/1) 110 : C IPOI=0 111 : C DO I1 = 1, NBL, 1 112 : C IPOI=IPOI+1 113 : C WRITE(IOIMP,*) I1 114 : C IPOS=MLELSB.INDEX(I1) 115 : C NGV=MLELSB.LESPOI(IPOS) 116 : C WRITE(IOIMP,*) 'NGV = ', NGV 117 : C WRITE(IOIMP,*) ' Position ', IPOS 118 : C NVOIS= MLELSB.INDEX(I1+1) - MLELSB.INDEX(I1) - 1 119 : C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS 120 : C DO I2 = 1, NVOIS, 1 121 : C IPOI=IPOI+1 122 : C NGV1=MLELSB.LESPOI(IPOS+I2) 123 : C WRITE(IOIMP,*) NGV1 124 : C ENDDO 125 : C ENDDO 126 : C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI 127 : C 128 : C***** Fin test 129 : C 130 : C**** Ls voisins type CENTRE des sommets 131 : C 131 : CALL RLEXVC(IMAIL,ICEN,ISOMM,MLELSC) 132 : IF(IERR .NE. 0) GOTO 9999 133 : C 134 : C**** MLELSC = LISTE SEQUENTIELLE INDEXEE D'ELEMENTS 135 : C (avec des numeros globals de noeuds) 136 : C 137 : C**** Test de RLEXVC 138 : C 139 : C SEGACT MLELSC 140 : C MELEME = ISOMM 141 : C SEGACT MELEME 142 : C NBL=MLELSC.INDEX(/1)-1 143 : C NBTPOI=MLELSC.LESPOI(/1) 144 : C IPOI=0 145 : C DO I1 = 1, NBL, 1 146 : C IPOI=IPOI+1 147 : C WRITE(IOIMP,*) I1 148 : C IPOS=MLELSC.INDEX(I1) 149 : C NGV=MLELSC.LESPOI(IPOS) 150 : C WRITE(IOIMP,*) 'NGV = ', NGV 151 : C WRITE(IOIMP,*) ' Position ', IPOS 152 : C NVOIS= MLELSC.INDEX(I1+1) - MLELSC.INDEX(I1) - 1 153 : C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS 154 : C DO I2 = 1, NVOIS, 1 155 : C IPOI=IPOI+1 156 : C NGV1=MLELSC.LESPOI(IPOS+I2) 157 : C WRITE(IOIMP,*) NGV1 158 : C ENDDO 159 : C ENDDO 160 : C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI 161 : C 162 : C***** Fin test 163 : C 164 : C Pour les points de bords on va chercher les centres voisins des 165 : C voisins et on va le mettre en ordre decroissante pas raport a la 166 : C distance 167 : C 168 : C MLESBC = sommet de bord - centres voisins de sommets voisins, 169 : C ordonné apar distance 170 : C MLRDIS = LISTREEL qui contient les distances aux carré 171 : C 172 : C En RLEVB1 on detrui MLELSB (= sommet de bord - sommets voisins) 173 : C 173 : CALL RLEVB1(ISOMM,ICEN,MLELSC,MLELSB,MLESBC,MLRDIS) 174 : IF(IERR.NE.0)GOTO 9999 175 : C 176 : C**** Test de RLEVB1 177 : C 178 : C SEGACT MLRDIS 179 : C SEGACT MLESBC 180 : C MELEME = ISOMM 181 : C SEGACT MELEME 182 : C NBL=MLESBC.INDEX(/1)-1 183 : C NBTPOI=MLESBC.LESPOI(/1) 184 : C IPOI=0 185 : C DO I1 = 1, NBL, 1 186 : C IPOI=IPOI+1 187 : C WRITE(IOIMP,*) I1 188 : C IPOS=MLESBC.INDEX(I1) 189 : C NGV=MLESBC.LESPOI(IPOS) 190 : C WRITE(IOIMP,*) 'NGV = ', NGV 191 : C WRITE(IOIMP,*) ' Position ', IPOS 192 : C NVOIS= MLESBC.INDEX(I1+1) - MLESBC.INDEX(I1) - 1 193 : C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS 194 : C DO I2 = 1, NVOIS, 1 195 : C IPOI=IPOI+1 196 : C NGV1=MLESBC.LESPOI(IPOS+I2) 197 : C WRITE(IOIMP,*) NGV1 198 : C WRITE(IOIMP,*) MLRDIS.PROG(IPOS+I2) 199 : C ENDDO 200 : C ENDDO 201 : C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI 202 : C 203 : C***** Fin test 204 : C 205 : C 206 : C**** On cree: MLESCF : sommet - centres "voisins" (F = final) 207 : C MATCOE : MATIRCE qui contient les coeff pour 208 : C la projection CENTRE -> SOMMET 209 : C 210 : C On detrui MLELSC, MLESBC, MLRDIS 211 : C 211 : CALL RLEXCA(ISGLIM,MLELSC,MLESBC,MLRDIS,MLESCF,MATCOE) 212 : IF(IERR.NE.0) GOTO 9999 213 : C 214 : C**** Test de RLEXCA 215 : C 216 : C SEGACT MLESCF 217 : C SEGACT MATCOE 218 : C MELEME = ISOMM 219 : C SEGACT MELEME 220 : C JG=IDIM+1 221 : C SEGINI MLREE1 222 : C NBL=MLESCF.INDEX(/1)-1 223 : C NBTPOI=MLESCF.LESPOI(/1) 224 : C IPOI=0 225 : C DO I1 = 1, NBL, 1 226 : C IPOI=IPOI+1 227 : C WRITE(IOIMP,*) I1 228 : C IPOS=MLESCF.INDEX(I1) 229 : C NGV=MLESCF.LESPOI(IPOS) 230 : C WRITE(IOIMP,*) 'NGV = ', NGV 231 : C WRITE(IOIMP,*) ' Position ', IPOS 232 : C WRITE(IOIMP,*) 233 : C & 'Coeff(',NGV,')=',(MATCOE.MAT(I3,IPOS),I3=1,IDIM+1) 234 : C DO I3=1,IDIM+1 235 : C MLREE1.PROG(I3)=MATCOE.MAT(I3,IPOS) 236 : C ENDDO 237 : C NVOIS= MLESCF.INDEX(I1+1) - MLESCF.INDEX(I1) - 1 238 : C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS 239 : C DO I2 = 1, NVOIS, 1 240 : C IPOI=IPOI+1 241 : C NGV1=MLESCF.LESPOI(IPOS+I2) 242 : C WRITE(IOIMP,*) NGV1 243 : C WRITE(IOIMP,*) 244 : C & 'Coeff(',NGV1,')=',(MATCOE.MAT(I3,IPOI),I3=1,IDIM+1) 245 : C DO I3=1,IDIM+1 246 : C MLREE1.PROG(I3)=MLREE1.PROG(I3)+MATCOE.MAT(I3,IPOI) 247 : C ENDDO 248 : C ENDDO 249 : C WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM+1) 250 : C ENDDO 251 : C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI 252 : C 253 : C***** Fin test 254 : C 255 : C**** On cree: MLEFSC : centre de face - (sommets - centres) voisins 256 : C MACOE1 : MATRICE qui contient les coeff pour 257 : C la projection CENTRE, SOMMET -> FACE 258 : C 258 : CALL RLECA1(IFACEL,IFACEP,MLEFSC,MACOE1) 259 : IF(IERR.NE.0)GOTO 9999 260 : C 261 : C**** Test de RLECA1 262 : C 263 : C SEGACT MLEFSC 264 : C SEGACT MACOE1 265 : C JG=IDIM+1 266 : C SEGINI MLREE1 267 : C NBL=MLEFSC.INDEX(/1)-1 268 : C NBTPOI=MLEFSC.LESPOI(/1) 269 : C IPOI=0 270 : C DO I1 = 1, NBL, 1 271 : C IPOI=IPOI+1 272 : C WRITE(IOIMP,*) I1 273 : C IPOS=MLEFSC.INDEX(I1) 274 : C NGV=MLEFSC.LESPOI(IPOS) 275 : C WRITE(IOIMP,*) 'NGF = ', NGV 276 : C WRITE(IOIMP,*) ' Position ', IPOS 277 : C WRITE(IOIMP,*) 278 : C & 'Coeff(',NGV,')=',(MACOE1.MAT(I3,IPOS),I3=1,IDIM+1) 279 : C DO I3=1,IDIM+1 280 : C MLREE1.PROG(I3)=MACOE1.MAT(I3,IPOS) 281 : C ENDDO 282 : C NVOIS= MLEFSC.INDEX(I1+1) - MLEFSC.INDEX(I1) - 1 283 : C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS 284 : C DO I2 = 1, NVOIS, 1 285 : C IPOI=IPOI+1 286 : C NGV1=MLEFSC.LESPOI(IPOS+I2) 287 : C WRITE(IOIMP,*) NGV1 288 : C WRITE(IOIMP,*) 289 : C & 'Coeff(',NGV1,')=',(MACOE1.MAT(I3,IPOI),I3=1,IDIM+1) 290 : C DO I3=1,IDIM+1 291 : C MLREE1.PROG(I3)=MLREE1.PROG(I3)+MACOE1.MAT(I3,IPOI) 292 : C ENDDO 293 : C ENDDO 294 : C WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM+1) 295 : C ENDDO 296 : C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI 297 : C 298 : C***** Fin test 299 : C 300 : C 301 : C**** RLEXFI 302 : C 303 : C Creation du MLELEM qui contient 304 : C Points faces - voisins centres 305 : C 305 : CALL RLEXFI(MLESCF,MATCOE,MLEFSC,MACOE1,MLEFC,MACOE2) 306 : C 307 : C**** Test de RLEXFI 308 : C 309 : C SEGACT MLEFC 310 : C SEGACT MACOE2 311 : C JG=IDIM 312 : C SEGINI MLREE1 313 : C MELEME = ISOMM 314 : C SEGACT MELEME 315 : C NBL=MLEFC.INDEX(/1)-1 316 : C NBTPOI=MLEFC.LESPOI(/1) 317 : C IPOI=0 318 : C DO I1 = 1, NBL, 1 319 : C IPOI=IPOI+1 320 : C WRITE(IOIMP,*) I1 321 : C IPOS=MLEFC.INDEX(I1) 322 : C NGV=MLEFC.LESPOI(IPOS) 323 : C WRITE(IOIMP,*) 'NGV = ', NGV 324 : C WRITE(IOIMP,*) ' Position ', IPOS 325 : C WRITE(IOIMP,*) 326 : C & 'Coeff(',NGV,')=',(MACOE2.MAT(I3,IPOS),I3=1,IDIM) 327 : C DO I3=1,IDIM 328 : C MLREE1.PROG(I3)=MACOE2.MAT(I3,IPOS) 329 : C ENDDO 330 : C NVOIS= MLEFC.INDEX(I1+1) - MLEFC.INDEX(I1) - 1 331 : C WRITE(IOIMP,*) 'Nombre voisins : ', NVOIS 332 : C DO I2 = 1, NVOIS, 1 333 : C IPOI=IPOI+1 334 : C NGV1=MLEFC.LESPOI(IPOS+I2) 335 : C WRITE(IOIMP,*) NGV1 336 : C WRITE(IOIMP,*) 337 : C & 'Coeff(',NGV1,')=',(MACOE2.MAT(I3,IPOI),I3=1,IDIM) 338 : C DO I3=1,IDIM 339 : C MLREE1.PROG(I3)=MLREE1.PROG(I3)+MACOE2.MAT(I3,IPOI) 340 : C ENDDO 341 : C ENDDO 342 : C WRITE(IOIMP,*) 'Somme =',(MLREE1.PROG(I3),I3=1,IDIM) 343 : C ENDDO 344 : C WRITE(IOIMP,*) 'Total points:', NBTPOI, IPOI 345 : C 346 : C***** Fin test 347 : C 348 : C 349 : C**** Creation de MCHAML 350 : C MLEFC, MACOE2 -> MCHAML 351 : C 351 : CALL RLEXCO(MLEFC,MACOE2,ICHELM) 352 : IF(IERR.NE.0)GOTO 9999 353 : C 354 : C**** On detrui le FACEL et IFAC ici crée 355 : C 356 : MELEME=IFACEL 357 : SEGSUP MELEME 358 : MELEME=IFACE 359 : SEGSUP MELEME 360 : C 361 : 9999 CONTINUE 362 : RETURN 363 : END 364 : 365 : 366 : 367 : 368 : 369 : 370 : 371 :
© Cast3M 2003 - All rights reserved.
Disclaimer