1 : C CALNUM SOURCE MAGN 09/07/30 21:15:25 6458 2 : SUBROUTINE CALNUM(LILAG,KMINCT,PMTOT, 3 : $ IRENU, 4 : $ NEWNUM, 5 : $ IMPR,IRET) 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : C*********************************************************************** 9 : C NOM : CALNUM 10 : C PROJET : Noyau linéaire NLIN 11 : C DESCRIPTION : Calcul d'une renumérotation avec minimisation d'un 12 : C profil PUIS placement des multiplicateurs de Lagrange. 13 : C Dans le couple renume-modnum, on effectuait les choses 14 : C suivantes : 15 : C - minimisation du profil sur l'ensemble des ddl. 16 : C - échange multiplicateur-noeuds associés pour que le 17 : C multiplicateur ait le plus grand numéro. 18 : C Maintenant, on essaie la chose suivante : 19 : C - minimisation du profil sur les ddl sans les ML. 20 : C - insertion des ML dans la nouvelle numérotation 21 : C 22 : C IRENU=1 'RIEN' : pas de renumérotation 23 : C 2 'SLOA' : algorithme de chez Sloan 24 : C 3 'GIPR' : Gibbs-King (profile reduction) 25 : C 4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction) 26 : C 27 : C LANGAGE : ESOPE 28 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 29 : C mél : gounand@semt2.smts.cea.fr 30 : C*********************************************************************** 31 : C APPELES : RENUME 32 : C APPELES (UTIL.) : ISETI, ISHELI, RSETXI 33 : C APPELE PAR : PRASEM 34 : C*********************************************************************** 35 : C ENTREES : LILAG, KMINCT, PMTOT, IRENU 36 : C SORTIES : NEWNUM 37 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 38 : C*********************************************************************** 39 : C VERSION : v1, 02/12/99, version initiale 40 : C HISTORIQUE : v1, 02/12/99, création 41 : C HISTORIQUE : 42 : C HISTORIQUE : 43 : C*********************************************************************** 44 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 45 : C en cas de modification de ce sous-programme afin de faciliter 46 : C la maintenance ! 47 : C*********************************************************************** 48 : -INC CCOPTIO 49 : *-INC SMLLOGI 50 : SEGMENT MLLOGI 51 : LOGICAL LOGI(JG) 52 : ENDSEGMENT 53 : POINTEUR LILAG.MLLOGI 54 : POINTEUR ISDDLA.MLLOGI 55 : -INC SMMATRIK 56 : POINTEUR KMINCT.MINC 57 : INTEGER NJA,NTT 58 : POINTEUR PMTOT.PMORS 59 : POINTEUR PMRED.PMORS 60 : -INC SMLENTI 61 : INTEGER JG 62 : POINTEUR NEWNUM.MLENTI 63 : POINTEUR NUINLA.MLENTI 64 : POINTEUR KRDDL.MLENTI 65 : POINTEUR LDDNOR.MLENTI 66 : POINTEUR LDDLAG.MLENTI 67 : POINTEUR NNULAG.MLENTI 68 : POINTEUR NNUNOR.MLENTI 69 : POINTEUR PRMLAG.MLENTI 70 : POINTEUR PRMNOR.MLENTI 71 : POINTEUR PRMDDL.MLENTI 72 : *STAT-INC SMSTAT 73 : * 74 : INTEGER IMPR,IRET 75 : INTEGER IRENU 76 : * 77 : INTEGER INULAG,INUNOR 78 : INTEGER IJARED,ITOTIN,ITOTLA,ITOTPO,ITTDDL,ITTLAG,ITTNOR 79 : INTEGER NTOTI2, JTTDDL, JTTNOR 80 : INTEGER NJARED,NTOTIN,NTOTLA,NTOTPO,NTTDDL,NTTLAG,NTTNOR 81 : INTEGER J,JSTOP,JSTRT 82 : INTEGER NNZERO,NJATOT,POSI 83 : INTEGER MAXNNJ 84 : * 85 : * Executable statements 86 : * 87 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans calnum' 87 : *STAT CALL INMSTA(MSTAT,0) 88 : * 89 : * Construction de NUINLA : la liste d'entiers telle que : 90 : * KMINCT.LISINC(NUINLA.LECT(imulag)), imulag=1..nbulag 91 : * sont des noms d'inconnues "mult. lag." 92 : * 93 : * SEGPRT,LILAG 94 : JG=0 95 : SEGINI NUINLA 96 : SEGACT LILAG 97 : NTOTIN=LILAG.LOGI(/1) 98 : DO 1 ITOTIN=1,NTOTIN 99 : IF (LILAG.LOGI(ITOTIN)) THEN 100 : NUINLA.LECT(**)=ITOTIN 101 : ENDIF 102 : 1 CONTINUE 103 : SEGDES LILAG 104 : NTOTLA=NUINLA.LECT(/1) 105 : * SEGPRT,NUINLA 106 : IF (NTOTLA.GT.0) THEN 107 : * 108 : * Construction de ISDDLA : c'est un tableau de logique tel que : 109 : * ISDDLA.LOGI(ittddl)=.FALSE. si ittddl est un ddl "normal" 110 : * =.TRUE. si ittddl est un ML 111 : * iddl=1..nttddl 112 : * 113 : * SEGPRT,KMINCT 114 : SEGACT KMINCT 115 : NTOTI2=KMINCT.LISINC(/2) 116 : IF (NTOTI2.NE.NTOTIN) GOTO 9998 117 : NTOTPO=KMINCT.NPOS(/1)-1 118 : NTTDDL=KMINCT.NPOS(NTOTPO+1)-1 119 : NTTLAG=0 120 : JG=NTTDDL 121 : * Par défaut, ce tableau est à .FALSE. 122 : SEGINI ISDDLA 123 : DO 2 ITOTLA=1,NTOTLA 124 : ITOTIN=NUINLA.LECT(ITOTLA) 125 : DO 22 ITOTPO=1,NTOTPO 126 : POSI=KMINCT.MPOS(ITOTPO,ITOTIN) 127 : IF (POSI.NE.0) THEN 128 : NTTLAG=NTTLAG+1 129 : ISDDLA.LOGI(KMINCT.NPOS(ITOTPO)+POSI-1)=.TRUE. 130 : ENDIF 131 : 22 CONTINUE 132 : 2 CONTINUE 133 : SEGDES KMINCT 134 : * SEGPRT,ISDDLA 135 : * 136 : * Construction des trois tableaux d'entiers suivants : 137 : * - LDDNOR(1..NTTNOR) : liste des ddl non ML 138 : * - LDDLAG(1..NTTLAG) : liste des ddl ML 139 : * - KRDDL (1..NTTDDL) : segment de correspondance dans les 140 : * tableaux précédents, pour un ddl de numéro ITTDDL : 141 : * - KRDDL(ITTDDL)=ITTNOR avec LDDNOR(ITTNOR)=ITTDDL 142 : * - KRDDL(ITTDDL)=-ITTLAG avec LDDLAG(ITTLAG)=ITTDDL 143 : * suivant le cas d'un ddl ML ou non ML 144 : * 145 : NTTNOR=NTTDDL-NTTLAG 146 : JG=NTTNOR 147 : SEGINI LDDNOR 148 : JG=NTTLAG 149 : SEGINI LDDLAG 150 : JG=NTTDDL 151 : SEGINI KRDDL 152 : ITTNOR=0 153 : ITTLAG=0 154 : DO 3 ITTDDL=1,NTTDDL 155 : IF (ISDDLA.LOGI(ITTDDL))THEN 156 : ITTLAG=ITTLAG+1 157 : LDDLAG.LECT(ITTLAG)=ITTDDL 158 : KRDDL.LECT(ITTDDL)=-ITTLAG 159 : ELSE 160 : ITTNOR=ITTNOR+1 161 : LDDNOR.LECT(ITTNOR)=ITTDDL 162 : KRDDL.LECT(ITTDDL)=ITTNOR 163 : ENDIF 164 : 3 CONTINUE 165 : SEGSUP ISDDLA 166 : * SEGPRT,LDDLAG 167 : * SEGPRT,LDDNOR 168 : * SEGPRT,KRDDL 168 : *STAT CALL PRMSTA(' Préparation renume divers',MSTAT,IMPR) 169 : * 170 : * Obtention de la nouvelle numérotation des ddl normaux : 171 : * - construction du profil morse "réduit" 172 : * - appel de la subroutine RENUME 173 : * 174 : SEGACT PMTOT 175 : NNZERO=PMTOT.JA(/1) 176 : NTT=NTTNOR 177 : NJA=NNZERO 178 : SEGINI PMRED 179 : IJARED=1 180 : DO 4 ITTNOR=1,NTTNOR 181 : ITTDDL=LDDNOR.LECT(ITTNOR) 182 : JSTRT=PMTOT.IA(ITTDDL) 183 : JSTOP=PMTOT.IA(ITTDDL+1)-1 184 : PMRED.IA(ITTNOR)=IJARED 185 : DO 42 J=JSTRT,JSTOP 186 : NJATOT=PMTOT.JA(J) 187 : NJARED=KRDDL.LECT(NJATOT) 188 : IF (NJARED.GT.0) THEN 189 : PMRED.JA(IJARED)=NJARED 190 : IJARED=IJARED+1 191 : ENDIF 192 : 42 CONTINUE 193 : 4 CONTINUE 194 : PMRED.IA(NTTNOR+1)=IJARED 195 : NTT=NTTNOR 196 : NJA=IJARED-1 197 : SEGADJ,PMRED 198 : SEGDES PMTOT 199 : * SEGPRT,PMRED 199 : *STAT CALL PRMSTA(' Construction profil réduit',MSTAT,IMPR) 199 : CALL RENUME(PMRED,IRENU,NNUNOR,IMPR,IRET) 200 : IF (IRET.NE.0) GOTO 9999 201 : SEGSUP PMRED 202 : * SEGPRT,NNUNOR 202 : *STAT CALL PRMSTA(' Après renume',MSTAT,IMPR) 203 : * 204 : * Obtention du nouveau numéro de chaque ddl ML : 205 : * ici, le max des nouveaux numéros de chaque ddl non ML 206 : * qui lui sont reliés 207 : * 208 : * SEGPRT,PMTOT 209 : SEGACT PMTOT 210 : SEGACT NNUNOR 211 : JG=NTTLAG 212 : SEGINI NNULAG 213 : DO 5 ITTLAG=1,NTTLAG 214 : ITTDDL=LDDLAG.LECT(ITTLAG) 215 : MAXNNJ=0 216 : JSTRT=PMTOT.IA(ITTDDL) 217 : JSTOP=PMTOT.IA(ITTDDL+1)-1 218 : DO 52 J=JSTRT,JSTOP 219 : JTTDDL=PMTOT.JA(J) 220 : JTTNOR=KRDDL.LECT(JTTDDL) 221 : IF (JTTNOR.GT.0) THEN 222 : MAXNNJ=MAX(MAXNNJ,NNUNOR.LECT(JTTNOR)) 223 : ENDIF 224 : 52 CONTINUE 225 : NNULAG.LECT(ITTLAG)=MAXNNJ 226 : * NNULAG.LECT(ITTLAG)=NTTDDL+1 227 : 5 CONTINUE 228 : SEGDES PMTOT 229 : SEGSUP KRDDL 230 : * SEGPRT,NNULAG 231 : * 232 : * 1 On calcule la permutation qui permet de trier NNULAG 233 : * par ordre croissant de nouveau numéro. 234 : * 2 On calcule la permutation réciproque de NNUNOR (ceci 235 : * est également la permutation qui permet de trier NNUNOR 236 : * par ordre croissant) 237 : * 238 : JG=NTTLAG 239 : SEGINI PRMLAG 239 : CALL ISETI(PRMLAG.LECT,NTTLAG) 239 : CALL ISHELI(NTTLAG,PRMLAG.LECT,NTTLAG,NNULAG.LECT, 240 : $ IMPR,IRET) 241 : IF (IRET.NE.0) GOTO 9999 242 : * SEGPRT,PRMLAG 243 : JG=NTTNOR 244 : SEGINI PRMNOR 244 : CALL RSETXI(PRMNOR.LECT,NNUNOR.LECT,NTTNOR) 245 : SEGSUP NNUNOR 246 : * SEGPRT,PRMNOR 247 : * 248 : * 3 En "merge"ant les deux listes précédentes, on obtient 249 : * la permutation réciproque de la nouvelle numérotation 250 : * totale que l'on cherche (si, si !) 251 : * 252 : JG=NTTDDL 253 : SEGINI PRMDDL 254 : ITTLAG=1 255 : INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) 256 : INUNOR=1 257 : DO 6 ITTDDL=1,NTTDDL 258 : IF (ITTLAG.LE.NTTLAG.AND.INUNOR.LE.NTTNOR) THEN 259 : IF (INULAG.LT.INUNOR) THEN 260 : PRMDDL.LECT(ITTDDL)= 261 : $ LDDLAG.LECT(PRMLAG.LECT(ITTLAG)) 262 : ITTLAG=ITTLAG+1 263 : IF (ITTLAG.LE.NTTLAG) THEN 264 : INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) 265 : ENDIF 266 : ELSE 267 : PRMDDL.LECT(ITTDDL)= 268 : $ LDDNOR.LECT(PRMNOR.LECT(INUNOR)) 269 : INUNOR=INUNOR+1 270 : ENDIF 271 : ELSEIF (ITTLAG.LE.NTTLAG) THEN 272 : PRMDDL.LECT(ITTDDL)= 273 : $ LDDLAG.LECT(PRMLAG.LECT(ITTLAG)) 274 : ITTLAG=ITTLAG+1 275 : IF (ITTLAG.LE.NTTLAG) THEN 276 : INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) 277 : ENDIF 278 : ELSEIF (INUNOR.LE.NTTNOR) THEN 279 : PRMDDL.LECT(ITTDDL)= 280 : $ LDDNOR.LECT(PRMNOR.LECT(INUNOR)) 281 : INUNOR=INUNOR+1 282 : ELSE 283 : WRITE(IOIMP,*) 'Error' 284 : ENDIF 285 : * write(ioimp,*) 'prmddl=',PRMDDL.LECT(ITTDDL) 286 : 6 CONTINUE 287 : SEGSUP PRMNOR 288 : SEGSUP PRMLAG 289 : SEGSUP NNULAG 290 : SEGSUP LDDLAG 291 : SEGSUP LDDNOR 292 : * SEGPRT,PRMDDL 293 : * 294 : * D'où la nouvelle numérotation : 295 : * 296 : JG=NTTDDL 297 : SEGINI NEWNUM 297 : CALL RSETXI(NEWNUM.LECT,PRMDDL.LECT,NTTDDL) 298 : SEGDES NEWNUM 299 : SEGSUP PRMDDL 299 : *STAT CALL PRMSTA(' Merge et obtention NEWNUM',MSTAT,IMPR) 300 : ELSEIF(NTOTLA.EQ.0) THEN 300 : CALL RENUME(PMTOT,IRENU, 301 : $ NEWNUM, 302 : $ IMPR,IRET) 303 : IF (IRET.NE.0) GOTO 9999 304 : ENDIF 305 : * SEGPRT,NEWNUM 306 : SEGSUP NUINLA 307 : * 308 : * Normal termination 309 : * 310 : IRET=0 311 : RETURN 312 : * 313 : * Format handling 314 : * 315 : * 316 : * Error handling 317 : * 318 : 9998 CONTINUE 319 : WRITE(IOIMP,*) 'Pb. compatibilité d''objets (dimensions)' 320 : 9999 CONTINUE 321 : IRET=1 322 : WRITE(IOIMP,*) 'An error was detected in subroutine calnum' 323 : RETURN 324 : * 325 : * End of subroutine CALNUM 326 : * 327 : END 328 : 329 : 330 : 331 :
© Cast3M 2003 - All rights reserved.
Disclaimer