1 : C FIXMEL SOURCE CHAT 05/01/13 00:01:55 5004 2 : SUBROUTINE FIXMEL(MELPRI,MELDUA, 3 : $ MELPR2,MELDU2, 4 : $ IMPR,IRET) 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : C*********************************************************************** 8 : C NOM : FIXMEL 9 : C PROJET : Noyau linéaire NLIN 10 : C DESCRIPTION : On corrige les maillages primaux et duaux s'ils n'ont 11 : C pas le même nombre de sous-objets géométriques. 12 : C 13 : C LANGAGE : ESOPE 14 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 15 : C mél : gounand@semt2.smts.cea.fr 16 : C*********************************************************************** 17 : C APPELES (UTIL.) : RSETI 18 : C APPELE PAR : PRASEM 19 : C*********************************************************************** 20 : C ENTREES : MELPRI, MELDUA 21 : C SORTIES : MELPR2, MELDU2 22 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 23 : C*********************************************************************** 24 : C VERSION : v1, 16/11/99, version initiale 25 : C HISTORIQUE : v1, 16/11/99, création 26 : C HISTORIQUE : 27 : C HISTORIQUE : 28 : C*********************************************************************** 29 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 30 : C en cas de modification de ce sous-programme afin de faciliter 31 : C la maintenance ! 32 : C*********************************************************************** 33 : -INC CCOPTIO 34 : -INC SMELEME 35 : INTEGER NBNN,NBELEM,NBSOUS,NBREF 36 : POINTEUR MELPRI.MELEME 37 : POINTEUR MELDUA.MELEME 38 : POINTEUR MELPR2.MELEME 39 : POINTEUR MELDU2.MELEME 40 : POINTEUR SMLPRI.MELEME 41 : POINTEUR SMLDUA.MELEME 42 : POINTEUR SMLPR2.MELEME 43 : POINTEUR SMLDU2.MELEME 44 : -INC SMLENTI 45 : INTEGER JG 46 : POINTEUR NBLPRI.MLENTI 47 : POINTEUR NBLDUA.MLENTI 48 : POINTEUR NBLMIX.MLENTI 49 : * 50 : INTEGER IDXPRI,IDXDUA 51 : INTEGER NELPRI,NELDUA 52 : INTEGER NUPRI,NUDUA,NUMIX 53 : INTEGER ISOUS,ISOUP,ISOUD,ISOUM 54 : INTEGER NSOUS,NSOUP,NSOUD,NSOUM 55 : * 56 : INTEGER IMPR,IRET 57 : * 58 : * Executable statements 59 : * 60 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans fixmel' 61 : * 62 : * Comptage des éléments dans chaque MELEME 63 : * 64 : * primal... 65 : SEGACT MELPRI 66 : NSOUS=MELPRI.LISOUS(/1) 67 : JG=MAX(1,NSOUS)+1 68 : SEGINI NBLPRI 69 : NBLPRI.LECT(1)=1 70 : DO 1 ISOUS=1,MAX(1,NSOUS) 71 : IF (NSOUS.EQ.0) THEN 72 : SMLPRI=MELPRI 73 : ELSE 74 : SMLPRI=MELPRI.LISOUS(ISOUS) 75 : SEGACT SMLPRI 76 : ENDIF 77 : NBLPRI.LECT(ISOUS+1)=NBLPRI.LECT(ISOUS)+SMLPRI.NUM(/2) 78 : IF (NSOUS.NE.0) SEGDES SMLPRI 79 : 1 CONTINUE 80 : SEGDES MELPRI 81 : * ... et dual 82 : SEGACT MELDUA 83 : NSOUS=MELDUA.LISOUS(/1) 84 : JG=MAX(1,NSOUS)+1 85 : SEGINI NBLDUA 86 : NBLDUA.LECT(1)=1 87 : DO 3 ISOUS=1,MAX(1,NSOUS) 88 : IF (NSOUS.EQ.0) THEN 89 : SMLDUA=MELDUA 90 : ELSE 91 : SMLDUA=MELDUA.LISOUS(ISOUS) 92 : SEGACT SMLDUA 93 : ENDIF 94 : NBLDUA.LECT(ISOUS+1)=NBLDUA.LECT(ISOUS)+SMLDUA.NUM(/2) 95 : IF (NSOUS.NE.0) SEGDES SMLDUA 96 : 3 CONTINUE 97 : SEGDES MELDUA 98 : * 99 : * D'où les nombres d'éléments (+1)... 100 : * 101 : NSOUP=NBLPRI.LECT(/1)-1 102 : NELPRI=NBLPRI.LECT(NSOUP+1) 103 : NSOUD=NBLDUA.LECT(/1)-1 104 : NELDUA=NBLDUA.LECT(NSOUD+1) 105 : IF (NELPRI.NE.NELDUA) THEN 106 : WRITE(IOIMP,*) 'Maillage primaux et duaux : nbel différents' 107 : GOTO 9999 108 : ENDIF 109 : IF (NSOUP.EQ.NSOUD) THEN 110 : MELPR2=MELPRI 111 : MELDU2=MELDUA 112 : ELSE 113 : * 114 : * On détermine combien il faudra de sous-maillages 115 : * avec quels nombres d'éléments par sous-maillage 116 : * 117 : NSOUM=NSOUP*NSOUD 118 : JG=NSOUM+1 119 : SEGINI NBLMIX 120 : ISOUP=1 121 : ISOUD=1 122 : ISOUM=0 123 : NUPRI=NBLPRI.LECT(ISOUP+1) 124 : NUDUA=NBLDUA.LECT(ISOUD+1) 125 : NBLMIX.LECT(ISOUM+1)=1 126 : 5 CONTINUE 127 : IF (NUPRI.LT.NUDUA) THEN 128 : ISOUM=ISOUM+1 129 : NBLMIX.LECT(ISOUM+1)=NUPRI 130 : ISOUP=ISOUP+1 131 : NUPRI=NBLPRI.LECT(ISOUP+1) 132 : GOTO 5 133 : ELSEIF (NUPRI.GT.NUDUA) THEN 134 : ISOUM=ISOUM+1 135 : NBLMIX.LECT(ISOUM+1)=NUDUA 136 : ISOUD=ISOUD+1 137 : NUDUA=NBLDUA.LECT(ISOUD+1) 138 : GOTO 5 139 : ELSE 140 : ISOUM=ISOUM+1 141 : NBLMIX.LECT(ISOUM+1)=NUDUA 142 : IF (NUPRI.LT.NELPRI.AND.NUDUA.LT.NELDUA) THEN 143 : ISOUP=ISOUP+1 144 : ISOUD=ISOUD+1 145 : NUPRI=NBLPRI.LECT(ISOUP+1) 146 : NUDUA=NBLDUA.LECT(ISOUD+1) 147 : GOTO 5 148 : ELSEIF (.NOT.(NUPRI.EQ.NELPRI.AND.NUDUA.EQ.NELDUA)) THEN 149 : WRITE(IOIMP,*) 'Erreur de programmation' 150 : GOTO 9999 151 : ENDIF 152 : ENDIF 153 : * 154 : * On remplit MELPR2 et MELDU2 (partitionnés) comme il faut. 155 : * 156 : NBNN=0 157 : NBELEM=0 158 : NBSOUS=ISOUM 159 : NBREF=0 160 : SEGINI MELPR2 161 : SEGINI MELDU2 162 : ISOUP=1 163 : ISOUD=1 164 : ISOUM=0 165 : SEGACT MELPRI 166 : NSOUP=MELPRI.LISOUS(/1) 167 : IF (NSOUP.EQ.0) THEN 168 : SMLPRI=MELPRI 169 : ELSE 170 : SMLPRI=MELPRI.LISOUS(1) 171 : SEGACT SMLPRI 172 : ENDIF 173 : SEGACT MELDUA 174 : NSOUD=MELDUA.LISOUS(/1) 175 : IF (NSOUD.EQ.0) THEN 176 : SMLDUA=MELDUA 177 : ELSE 178 : SMLDUA=MELDUA.LISOUS(1) 179 : SEGACT SMLDUA 180 : ENDIF 181 : NUPRI=NBLPRI.LECT(ISOUP+1) 182 : NUDUA=NBLDUA.LECT(ISOUD+1) 183 : NUMIX=NBLMIX.LECT(ISOUM+1) 184 : 7 CONTINUE 185 : IF (NUPRI.LT.NUDUA) THEN 186 : ISOUM=ISOUM+1 187 : NBNN=SMLPRI.NUM(/1) 188 : NBELEM=NUPRI-NUMIX 189 : NBSOUS=0 190 : NBREF=0 191 : SEGINI SMLPR2 192 : SMLPR2.ITYPEL=SMLPRI.ITYPEL 193 : IDXPRI=NUMIX-NBLPRI.LECT(ISOUP)+1 193 : CALL RSETI(SMLPR2.NUM,SMLPRI.NUM(1,IDXPRI),NBELEM*NBNN) 194 : SEGDES SMLPR2 195 : MELPR2.LISOUS(ISOUM)=SMLPR2 196 : NBNN=SMLDUA.NUM(/1) 197 : SEGINI SMLDU2 198 : SMLDU2.ITYPEL=SMLDUA.ITYPEL 199 : IDXDUA=NUMIX-NBLDUA.LECT(ISOUD)+1 199 : CALL RSETI(SMLDU2.NUM,SMLDUA.NUM(1,IDXDUA),NBELEM*NBNN) 200 : SEGDES SMLDU2 201 : MELDU2.LISOUS(ISOUM)=SMLDU2 202 : SEGDES SMLPRI 203 : ISOUP=ISOUP+1 204 : SMLPRI=MELPRI.LISOUS(ISOUP) 205 : SEGACT SMLPRI 206 : NUPRI=NBLPRI.LECT(ISOUP+1) 207 : NUMIX=NBLMIX.LECT(ISOUM+1) 208 : GOTO 7 209 : ELSEIF (NUPRI.GT.NUDUA) THEN 210 : ISOUM=ISOUM+1 211 : NBNN=SMLPRI.NUM(/1) 212 : NBELEM=NUDUA-NUMIX 213 : NBSOUS=0 214 : NBREF=0 215 : SEGINI SMLPR2 216 : SMLPR2.ITYPEL=SMLPRI.ITYPEL 217 : IDXPRI=NUMIX-NBLPRI.LECT(ISOUP)+1 217 : CALL RSETI(SMLPR2.NUM,SMLPRI.NUM(1,IDXPRI),NBELEM*NBNN) 218 : SEGDES SMLPR2 219 : MELPR2.LISOUS(ISOUM)=SMLPR2 220 : NBNN=SMLDUA.NUM(/1) 221 : SEGINI SMLDU2 222 : SMLDU2.ITYPEL=SMLDUA.ITYPEL 223 : IDXDUA=NUMIX-NBLDUA.LECT(ISOUD)+1 223 : CALL RSETI(SMLDU2.NUM,SMLDUA.NUM(1,IDXDUA),NBELEM*NBNN) 224 : SEGDES SMLDU2 225 : MELDU2.LISOUS(ISOUM)=SMLDU2 226 : SEGDES SMLDUA 227 : ISOUD=ISOUD+1 228 : SMLDUA=MELDUA.LISOUS(ISOUD) 229 : SEGACT SMLDUA 230 : NUDUA=NBLDUA.LECT(ISOUD+1) 231 : NUMIX=NBLMIX.LECT(ISOUM+1) 232 : GOTO 7 233 : ELSE 234 : ISOUM=ISOUM+1 235 : NBNN=SMLPRI.NUM(/1) 236 : NBELEM=NUDUA-NUMIX 237 : NBSOUS=0 238 : NBREF=0 239 : SEGINI SMLPR2 240 : SMLPR2.ITYPEL=SMLPRI.ITYPEL 241 : IDXPRI=NUMIX-NBLPRI.LECT(ISOUP)+1 241 : CALL RSETI(SMLPR2.NUM,SMLPRI.NUM(1,IDXPRI),NBELEM*NBNN) 242 : SEGDES SMLPR2 243 : MELPR2.LISOUS(ISOUM)=SMLPR2 244 : NBNN=SMLDUA.NUM(/1) 245 : SEGINI SMLDU2 246 : SMLDU2.ITYPEL=SMLDUA.ITYPEL 247 : IDXDUA=NUMIX-NBLDUA.LECT(ISOUD)+1 247 : CALL RSETI(SMLDU2.NUM,SMLDUA.NUM(1,IDXDUA),NBELEM*NBNN) 248 : SEGDES SMLDU2 249 : MELDU2.LISOUS(ISOUM)=SMLDU2 250 : IF (NUPRI.LT.NELPRI.AND.NUDUA.LT.NELDUA) THEN 251 : SEGDES SMLPRI 252 : ISOUP=ISOUP+1 253 : SMLPRI=MELPRI.LISOUS(ISOUP) 254 : SEGACT SMLPRI 255 : SEGDES SMLDUA 256 : ISOUD=ISOUD+1 257 : SMLDUA=MELDUA.LISOUS(ISOUD) 258 : SEGACT SMLDUA 259 : NUPRI=NBLPRI.LECT(ISOUP+1) 260 : NUDUA=NBLDUA.LECT(ISOUD+1) 261 : NUMIX=NBLMIX.LECT(ISOUM+1) 262 : GOTO 7 263 : ELSEIF (.NOT.(NUPRI.EQ.NELPRI.AND.NUDUA.EQ.NELDUA)) THEN 264 : WRITE(IOIMP,*) 'Erreur de programmation' 265 : GOTO 9999 266 : ENDIF 267 : ENDIF 268 : IF (NSOUD.NE.0) SEGDES SMLDUA 269 : SEGDES MELDUA 270 : IF (NSOUP.NE.0) SEGDES SMLPRI 271 : SEGDES MELPRI 272 : SEGDES MELDU2 273 : SEGDES MELPR2 274 : SEGSUP NBLMIX 275 : ENDIF 276 : SEGSUP NBLDUA 277 : SEGSUP NBLPRI 278 : * 279 : * Normal termination 280 : * 281 : IRET=0 282 : RETURN 283 : * 284 : * Format handling 285 : * 286 : * 287 : * Error handling 288 : * 289 : 9999 CONTINUE 290 : IRET=1 291 : WRITE(IOIMP,*) 'An error was detected in subroutine fixmel' 292 : RETURN 293 : * 294 : * End of subroutine FIXMEL 295 : * 296 : END 297 : 298 : 299 :
© Cast3M 2003 - All rights reserved.
Disclaimer