1 : C RENUME SOURCE MAGN 09/07/30 21:20:48 6458 2 : SUBROUTINE RENUME(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 : RENUME 10 : C PROJET : Noyau linéaire NLIN 11 : C DESCRIPTION : On cherche une nouvelle numérotation des inconnues 12 : C pour minimiser le profil ou la largeur de bande d'un 13 : C profil d'une matrice Morse par les diverses méthodes 14 : C disponibles. 15 : C 16 : C IRENU=1 'RIEN' : pas de renumérotation 17 : C 2 'SLOA' : algorithme de chez Sloan 18 : C 3 'GIPR' : Gibbs-King (profile reduction) 19 : C 4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction) 20 : C 21 : C LANGAGE : ESOPE 22 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) 23 : C mél : gounand@semt2.smts.cea.fr 24 : C*********************************************************************** 25 : C APPELES : PRGRAP, PRSLOA, PRGPSK 26 : C APPELE PAR : PRASEM 27 : C*********************************************************************** 28 : C ENTREES : PMTOT, IRENU 29 : C SORTIES : NEWNUM 30 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 31 : C*********************************************************************** 32 : C VERSION : v1, 26/11/99, version initiale 33 : C HISTORIQUE : v1, 26/11/99, création 34 : C HISTORIQUE : 35 : C HISTORIQUE : 36 : C*********************************************************************** 37 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 38 : C en cas de modification de ce sous-programme afin de faciliter 39 : C la maintenance ! 40 : C*********************************************************************** 41 : -INC CCOPTIO 42 : -INC SMMATRIK 43 : POINTEUR PMTOT.PMORS 44 : -INC SMLENTI 45 : INTEGER JG 46 : POINTEUR NEWNUM.MLENTI 47 : *-INC SLSTIND 48 : * 49 : * Segment LSTIND (liste séquentielle indexée) 50 : * 51 : SEGMENT LSTIND 52 : INTEGER IDX(NBM+1) 53 : INTEGER IVAL(NBTVAL) 54 : ENDSEGMENT 55 : * 56 : * LISTE SEQUENTIELLE INDEXEE D'ENTIERS 57 : * 58 : * NBM : NOMBRE DE MULTIPLETS 59 : * NBTVAL : NOMBRE TOTAL DE VALEURS 60 : * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME 61 : * MULTIPLET DANS LE TABLEAU IVAL 62 : * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET 63 : POINTEUR ADJAC.LSTIND 64 : * 65 : INTEGER IRENU 66 : INTEGER IMPR,IRET 67 : * 68 : INTEGER ITOTPO,NTOTPO 69 : INTEGER E2,NEWPRO,OLDPRO,NEWPR2,OLDPR2 70 : LOGICAL OPTPRO,ISROK 71 : * 72 : * Executable statements 73 : * 74 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans renume' 75 : * 76 : * Construction de la renumérotation... 77 : * 78 : IF (IRENU.GE.2.AND.IRENU.LE.4) THEN 79 : * construction du graphe symétrique (Sloan et Gibbs-King ont besoin 80 : * sue le graphe soit symétrique) 81 : * 82 : * In PRGRAP : SEGINI ADJAC 82 : CALL PRGRAP(PMTOT, 83 : $ ADJAC, 84 : $ IMPR,IRET) 85 : IF (IRET.NE.0) GOTO 9999 86 : * 87 : * ...par l'algorithme de l'article de Sloan 88 : IF (IRENU.EQ.2) THEN 88 : CALL PRSLOA(ADJAC, 89 : $ NEWNUM, 90 : $ IMPR,IRET) 91 : IF (IRET.NE.0) GOTO 9999 92 : * ...par l'algorithme TOMS 582 93 : ELSEIF (IRENU.EQ.3) THEN 94 : OPTPRO=.TRUE. 94 : CALL PRGPSK(ADJAC,OPTPRO, 95 : $ NEWNUM, 96 : $ IMPR,IRET) 97 : IF (IRET.NE.0) GOTO 9999 98 : ELSEIF (IRENU.EQ.4) THEN 99 : OPTPRO=.FALSE. 99 : CALL PRGPSK(ADJAC,OPTPRO, 100 : $ NEWNUM, 101 : $ IMPR,IRET) 102 : IF (IRET.NE.0) GOTO 9999 103 : ELSE 104 : WRITE(IOIMP,*) 'Erreur de programmation...' 105 : GOTO 9999 106 : ENDIF 107 : SEGACT NEWNUM 108 : IF (IMPR.GT.2) THEN 109 : SEGACT ADJAC 110 : * 111 : * Compute profiles of adjacency list 112 : * for old and new node numbers 113 : * 114 : NTOTPO=ADJAC.IDX(/1)-1 115 : E2=ADJAC.IDX(NTOTPO+1)-1 115 : CALL PROFI1(NTOTPO,NEWNUM.LECT,E2,ADJAC.IVAL,ADJAC.IDX, 116 : $ OLDPR2,NEWPR2, 117 : $ IMPR,IRET) 118 : IF (IRET.NE.0) GOTO 9999 119 : WRITE(IOIMP,*) 'Profil symétrique non ordonné = ',OLDPR2 120 : WRITE(IOIMP,*) 'Profil symétrique ordonné = ',NEWPR2 121 : SEGDES ADJAC 122 : ENDIF 123 : SEGSUP ADJAC 124 : SEGACT PMTOT 125 : NTOTPO=PMTOT.IA(/1)-1 126 : E2=PMTOT.IA(NTOTPO+1)-1 126 : CALL PROFI1(NTOTPO,NEWNUM.LECT,E2,PMTOT.JA,PMTOT.IA, 127 : $ OLDPRO,NEWPRO, 128 : $ IMPR,IRET) 129 : IF (IRET.NE.0) GOTO 9999 130 : SEGDES PMTOT 131 : IF (IMPR.GT.1) THEN 132 : WRITE(IOIMP,*) 'Profil Morse non ordonné = ',OLDPRO 133 : WRITE(IOIMP,*) 'Profil Morse ordonné = ',NEWPRO 134 : ENDIF 135 : SEGDES NEWNUM 136 : IF (OLDPRO.LT.NEWPRO) THEN 137 : ISROK=.FALSE. 138 : ELSE 139 : ISROK=.TRUE. 140 : ENDIF 141 : ENDIF 142 : * 143 : * ...non effectuée 144 : IF (IRENU.EQ.1.OR.(.NOT.ISROK)) THEN 145 : IF (IRENU.EQ.1) THEN 146 : SEGACT PMTOT 147 : NTOTPO=PMTOT.IA(/1)-1 148 : SEGDES PMTOT 149 : JG=NTOTPO 150 : SEGINI NEWNUM 151 : ELSEIF (.NOT.ISROK) THEN 152 : SEGACT NEWNUM*MOD 153 : NTOTPO=NEWNUM.LECT(/1) 154 : ENDIF 155 : DO 1 ITOTPO=1,NTOTPO 156 : NEWNUM.LECT(ITOTPO)=ITOTPO 157 : 1 CONTINUE 158 : * SEGDES NEWNUM 159 : SEGDES NEWNUM 160 : IF (IMPR.GT.2) THEN 161 : WRITE(IOIMP,*) 'Pas de renumérotation effectuée' 162 : ENDIF 163 : ENDIF 164 : * 165 : * Normal termination 166 : * 167 : IRET=0 168 : RETURN 169 : * 170 : * Format handling 171 : * 172 : * 173 : * Error handling 174 : * 175 : 9999 CONTINUE 176 : IRET=1 177 : WRITE(IOIMP,*) 'An error was detected in subroutine renume' 178 : RETURN 179 : * 180 : * End of subroutine RENUME 181 : * 182 : END 183 : 184 : 185 : 186 : 187 :
© Cast3M 2003 - All rights reserved.
Disclaimer