Sources Esope | Cast3M

renume
C RENUME    SOURCE    GOUNAND   25/04/30    21:15:37     12258          
      SUBROUTINE RENUME(PMTOT,
     $     IRENU,
     $     NEWNUM,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : RENUME
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : On cherche une nouvelle numérotation des inconnues
C               pour minimiser le profil ou la largeur de bande d'un
C               profil d'une matrice Morse par les diverses méthodes
C               disponibles.
C
C  IRENU=1 'RIEN' : pas de renumérotation
C        2 'SLOA' : algorithme de chez Sloan
C        3 'GIPR' : Gibbs-King (profile reduction)
C        4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction)
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : PRGRAP, PRSLOA, PRGPSK
C APPELE PAR       : PRASEM
C***********************************************************************
C ENTREES            : PMTOT, IRENU
C SORTIES            : NEWNUM
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 26/11/99, version initiale
C HISTORIQUE : v1, 26/11/99, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
-INC PPARAM
-INC CCOPTIO
-INC SMMATRIK
      POINTEUR PMTOT.PMORS
-INC SMLENTI
      INTEGER JG
      POINTEUR NEWNUM.MLENTI
*-INC SLSTIND
*
*     Segment LSTIND (liste séquentielle indexée)
*
      SEGMENT LSTIND
      INTEGER IDX(NBM+1)
      INTEGER IVAL(NBTVAL)
      ENDSEGMENT
*
*     LISTE SEQUENTIELLE INDEXEE D'ENTIERS
*
*     NBM      : NOMBRE DE MULTIPLETS
*     NBTVAL   : NOMBRE TOTAL DE VALEURS
*     IDX(I)   : INDICE DE LA PREMIERE VALEUR DU IEME
*                MULTIPLET DANS LE TABLEAU IVAL
*     IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
      POINTEUR ADJAC.LSTIND
*
      INTEGER IRENU
      INTEGER IMPR,IRET
*
      INTEGER ITOTPO,NTOTPO
      INTEGER E2,NEWPRO,OLDPRO,NEWPR2,OLDPR2
      LOGICAL OPTPRO,ISROK
*
      ISROK=.FALSE.
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans renume'
*
* Construction de la renumérotation...
*
      IF (IRENU.GE.2.AND.IRENU.LE.4) THEN
* construction du graphe symétrique (Sloan et Gibbs-King ont besoin
* que le graphe soit symétrique)
*
* In PRGRAP : SEGINI ADJAC
         CALL PRGRAP(PMTOT,
     $        ADJAC,
     $        IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
*
* ...par l'algorithme de l'article de Sloan
         IF (IRENU.EQ.2) THEN
            CALL PRSLOA(ADJAC,
     $           NEWNUM,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
* ...par l'algorithme TOMS 582
         ELSEIF (IRENU.EQ.3) THEN
            OPTPRO=.TRUE.
            CALL PRGPSK(ADJAC,OPTPRO,
     $           NEWNUM,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
         ELSEIF (IRENU.EQ.4) THEN
            OPTPRO=.FALSE.
            CALL PRGPSK(ADJAC,OPTPRO,
     $           NEWNUM,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
         ELSE
            WRITE(IOIMP,*) 'Erreur de programmation...'
            GOTO 9999
         ENDIF
         SEGACT NEWNUM
         IF (IMPR.GT.2) THEN
            SEGACT ADJAC
*
*     Compute profiles of adjacency list
*     for old and new node numbers
*
            NTOTPO=ADJAC.IDX(/1)-1
            E2=ADJAC.IDX(NTOTPO+1)-1
            CALL PROFI1(NTOTPO,NEWNUM.LECT,E2,ADJAC.IVAL,ADJAC.IDX,
     $           OLDPR2,NEWPR2,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            WRITE(IOIMP,*) 'Profil symétrique non ordonné = ',OLDPR2
            WRITE(IOIMP,*) 'Profil symétrique ordonné     = ',NEWPR2
         ENDIF
         SEGSUP ADJAC
         SEGACT PMTOT
         NTOTPO=PMTOT.IA(/1)-1
         E2=PMTOT.IA(NTOTPO+1)-1
         CALL PROFI1(NTOTPO,NEWNUM.LECT,E2,PMTOT.JA,PMTOT.IA,
     $        OLDPRO,NEWPRO,
     $        IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         IF (IMPR.GT.1) THEN
            WRITE(IOIMP,*) 'Profil Morse non ordonné = ',OLDPRO
            WRITE(IOIMP,*) 'Profil Morse ordonné     = ',NEWPRO
         ENDIF
         IF (OLDPRO.LT.NEWPRO) THEN
            ISROK=.FALSE.
         ELSE
            ISROK=.TRUE.
         ENDIF
      ENDIF
*
* ...non effectuée
      IF (IRENU.EQ.1.OR.(.NOT.ISROK)) THEN
         IF (IRENU.EQ.1) THEN
            SEGACT PMTOT
            NTOTPO=PMTOT.IA(/1)-1
            JG=NTOTPO
            SEGINI NEWNUM
         ELSEIF (.NOT.ISROK) THEN
            SEGACT NEWNUM*MOD
            NTOTPO=NEWNUM.LECT(/1)
         ENDIF
         DO 1 ITOTPO=1,NTOTPO
            NEWNUM.LECT(ITOTPO)=ITOTPO
 1       CONTINUE
         IF (IMPR.GT.2) THEN
            WRITE(IOIMP,*) 'Pas de renumérotation effectuée'
         ENDIF
      ENDIF
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine renume'
      RETURN
*
* End of subroutine RENUME
*
      END