1 : C CALNU2 SOURCE MAGN 09/07/30 21:15:20 6458 2 : SUBROUTINE CALNU2(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 : CALNU2 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 calnum, on effectuait les choses suivantes : 14 : C - minimisation du profil sur les ddl sans les ML. 15 : C - insertion des ML dans la nouvelle numérotation 16 : C Maintenant, on essaie la chose suivante : 17 : C - minimisation du profil sur les ddl AVEC les ML.; 18 : C - retrait des ML de la numérotation ; 19 : C - réinsertion des ML pour les placer après les ddl non 20 : C ML auxquels ils sont liés. 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, 13/01/00, version initiale 40 : C HISTORIQUE : v1, 13/01/00, 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 : POINTEUR PMTOT.PMORS 58 : -INC SMLENTI 59 : INTEGER JG 60 : POINTEUR NEWNUM.MLENTI 61 : POINTEUR NUINLA.MLENTI 62 : POINTEUR KRDDL.MLENTI 63 : POINTEUR LDDNOR.MLENTI 64 : POINTEUR LDDLAG.MLENTI 65 : POINTEUR NNULAG.MLENTI 66 : POINTEUR NNUNOR.MLENTI 67 : POINTEUR NNUTOT.MLENTI 68 : POINTEUR PRMLAG.MLENTI 69 : POINTEUR PRMNOR.MLENTI 70 : POINTEUR PRMDDL.MLENTI 71 : POINTEUR PRNNUT.MLENTI 72 : *STAT-INC SMSTAT 73 : * 74 : INTEGER IMPR,IRET 75 : INTEGER IRENU 76 : * 77 : INTEGER INULAG,INUNOR,KRNNU 78 : INTEGER ITOTIN,ITOTLA,ITOTPO,ITTDDL,ITTLAG,ITTNOR 79 : INTEGER NTOTI2, JTTDDL, JTTNOR 80 : INTEGER NTOTIN,NTOTLA,NTOTPO,NTTDDL,NTTLAG,NTTNOR 81 : INTEGER J,JSTOP,JSTRT 82 : INTEGER POSI 83 : INTEGER MAXNNJ 84 : * 85 : * Executable statements 86 : * 87 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans calnu2' 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 170 : CALL RENUME(PMTOT,IRENU,NNUTOT,IMPR,IRET) 171 : IF (IRET.NE.0) GOTO 9999 172 : * SEGPRT,NNUTOT 172 : *STAT CALL PRMSTA(' Après renume',MSTAT,IMPR) 173 : * 174 : * Construction de NNUNOR : on "oublie" les nouveaux numéros 175 : * des DDL "multiplicateur de Lagrange" 176 : * 177 : ** Permutation réciproque de NNUTOT 178 : SEGACT,NNUTOT 179 : JG=NTTDDL 180 : SEGINI PRNNUT 181 : DO 40 ITTDDL=1,NTTDDL 182 : PRNNUT.LECT(NNUTOT.LECT(ITTDDL))=ITTDDL 183 : 40 CONTINUE 184 : * SEGPRT,PRNNUT 185 : SEGSUP NNUTOT 186 : ** Construction de NNUNOR 187 : JG=NTTNOR 188 : SEGINI NNUNOR 189 : ITTNOR=0 190 : DO 42 ITTDDL=1,NTTDDL 191 : KRNNU=KRDDL.LECT(PRNNUT.LECT(ITTDDL)) 192 : IF (KRNNU.GT.0) THEN 193 : ITTNOR=ITTNOR+1 194 : NNUNOR.LECT(KRNNU)=ITTNOR 195 : ENDIF 196 : 42 CONTINUE 197 : * SEGPRT,NNUNOR 198 : SEGSUP PRNNUT 199 : * 200 : * Obtention du nouveau numéro de chaque ddl ML : 201 : * ici, le max des nouveaux numéros de chaque ddl non ML 202 : * qui lui sont reliés 203 : * 204 : * SEGPRT,PMTOT 205 : SEGACT PMTOT 206 : JG=NTTLAG 207 : SEGINI NNULAG 208 : DO 5 ITTLAG=1,NTTLAG 209 : ITTDDL=LDDLAG.LECT(ITTLAG) 210 : MAXNNJ=0 211 : JSTRT=PMTOT.IA(ITTDDL) 212 : JSTOP=PMTOT.IA(ITTDDL+1)-1 213 : DO 52 J=JSTRT,JSTOP 214 : JTTDDL=PMTOT.JA(J) 215 : JTTNOR=KRDDL.LECT(JTTDDL) 216 : IF (JTTNOR.GT.0) THEN 217 : MAXNNJ=MAX(MAXNNJ,NNUNOR.LECT(JTTNOR)) 218 : ENDIF 219 : 52 CONTINUE 220 : NNULAG.LECT(ITTLAG)=MAXNNJ 221 : * NNULAG.LECT(ITTLAG)=NTTDDL+1 222 : 5 CONTINUE 223 : SEGDES PMTOT 224 : SEGSUP KRDDL 225 : * SEGPRT,NNULAG 226 : * 227 : * 1 On calcule la permutation qui permet de trier NNULAG 228 : * par ordre croissant de nouveau numéro. 229 : * 2 On calcule la permutation réciproque de NNUNOR (ceci 230 : * est également la permutation qui permet de trier NNUNOR 231 : * par ordre croissant) 232 : * 233 : JG=NTTLAG 234 : SEGINI PRMLAG 234 : CALL ISETI(PRMLAG.LECT,NTTLAG) 234 : CALL ISHELI(NTTLAG,PRMLAG.LECT,NTTLAG,NNULAG.LECT, 235 : $ IMPR,IRET) 236 : IF (IRET.NE.0) GOTO 9999 237 : * SEGPRT,PRMLAG 238 : JG=NTTNOR 239 : SEGINI PRMNOR 239 : CALL RSETXI(PRMNOR.LECT,NNUNOR.LECT,NTTNOR) 240 : SEGSUP NNUNOR 241 : * SEGPRT,PRMNOR 242 : * 243 : * 3 En "merge"ant les deux listes précédentes, on obtient 244 : * la permutation réciproque de la nouvelle numérotation 245 : * totale que l'on cherche (si, si !) 246 : * 247 : JG=NTTDDL 248 : SEGINI PRMDDL 249 : ITTLAG=1 250 : INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) 251 : INUNOR=1 252 : DO 6 ITTDDL=1,NTTDDL 253 : IF (ITTLAG.LE.NTTLAG.AND.INUNOR.LE.NTTNOR) THEN 254 : IF (INULAG.LT.INUNOR) THEN 255 : PRMDDL.LECT(ITTDDL)= 256 : $ LDDLAG.LECT(PRMLAG.LECT(ITTLAG)) 257 : ITTLAG=ITTLAG+1 258 : IF (ITTLAG.LE.NTTLAG) THEN 259 : INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) 260 : ENDIF 261 : ELSE 262 : PRMDDL.LECT(ITTDDL)= 263 : $ LDDNOR.LECT(PRMNOR.LECT(INUNOR)) 264 : INUNOR=INUNOR+1 265 : ENDIF 266 : ELSEIF (ITTLAG.LE.NTTLAG) THEN 267 : PRMDDL.LECT(ITTDDL)= 268 : $ LDDLAG.LECT(PRMLAG.LECT(ITTLAG)) 269 : ITTLAG=ITTLAG+1 270 : IF (ITTLAG.LE.NTTLAG) THEN 271 : INULAG=NNULAG.LECT(PRMLAG.LECT(ITTLAG)) 272 : ENDIF 273 : ELSEIF (INUNOR.LE.NTTNOR) THEN 274 : PRMDDL.LECT(ITTDDL)= 275 : $ LDDNOR.LECT(PRMNOR.LECT(INUNOR)) 276 : INUNOR=INUNOR+1 277 : ELSE 278 : WRITE(IOIMP,*) 'Error' 279 : GOTO 9999 280 : ENDIF 281 : 6 CONTINUE 282 : SEGSUP PRMNOR 283 : SEGSUP PRMLAG 284 : SEGSUP NNULAG 285 : SEGSUP LDDLAG 286 : SEGSUP LDDNOR 287 : * SEGPRT,PRMDDL 288 : * 289 : * D'où la nouvelle numérotation : 290 : * 291 : JG=NTTDDL 292 : SEGINI NEWNUM 292 : CALL RSETXI(NEWNUM.LECT,PRMDDL.LECT,NTTDDL) 293 : SEGDES NEWNUM 294 : SEGSUP PRMDDL 294 : *STAT CALL PRMSTA(' Merge et obtention NEWNUM',MSTAT,IMPR) 295 : ELSEIF(NTOTLA.EQ.0) THEN 295 : CALL RENUME(PMTOT,IRENU, 296 : $ NEWNUM, 297 : $ IMPR,IRET) 298 : IF (IRET.NE.0) GOTO 9999 299 : ENDIF 300 : * SEGPRT,NEWNUM 301 : SEGSUP NUINLA 302 : * 303 : * Normal termination 304 : * 305 : IRET=0 306 : RETURN 307 : * 308 : * Format handling 309 : * 310 : * 311 : * Error handling 312 : * 313 : 9998 CONTINUE 314 : WRITE(IOIMP,*) 'Pb. compatibilité d''objets (dimensions)' 315 : 9999 CONTINUE 316 : IRET=1 317 : WRITE(IOIMP,*) 'An error was detected in subroutine calnu2' 318 : RETURN 319 : * 320 : * End of subroutine CALNU2 321 : * 322 : END 323 : 324 : 325 : 326 : 327 :
© Cast3M 2003 - All rights reserved.
Disclaimer