Sources Esope | Cast3M

prgpsk
C PRGPSK    SOURCE    CHAT      05/01/13    02:26:27     5004
      SUBROUTINE PRGPSK(ADJAC,OPTPRO,
     $     NEWNUM,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : PRGPSK
C DESCRIPTION : Renumérotation d'un graphe symétrique par la méthode de
C               Gibbs-King ou de Gibbs-Poole-Stockmeyer.
C               Prépare la renumérotation par la méthode de
C               1) Gibbs-King si OPTPRO = .TRUE. (réduction du profile)
C               1) Gibbs-Poole-Stockmeyer
C                  si OPTPRO = .FALSE. (bandwidth reduction)
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
C               mél : gounand@semt2.smts.cea.fr
C BIBLIO      : @Article{,
C  author =       {S. W. Sloan},
C  title =        {A Fortran Program for Profile and Wavefront Reduction},
C  journal =      {International Journal for Numerical Methods in Engineering},
C  year =         {1989},
C  volume =    {28},
C  pages =     {2651-2679}
C}
C
C***********************************************************************
C APPELES          : GPSKCA, PROFI1
C APPELE PAR       : RENUME
C***********************************************************************
C ENTREES            : ADJAC, OPTPRO
C SORTIES            : NEWNUM
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 10/11/99, version initiale
C HISTORIQUE : v1, 10/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 SMLENTI
      INTEGER JG
      POINTEUR IWORK.MLENTI
      POINTEUR NEWNUM.MLENTI
      POINTEUR DEGREE.MLENTI
*
*     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
*
*-INC SLSTIND
      POINTEUR ADJAC.LSTIND
      INTEGER IMPR,IRET
*
      INTEGER ITOTPO
      INTEGER NTOTPO
      LOGICAL OPTPRO
      INTEGER WRKLEN,BANDWD,PROFI,ERROR,SPACE
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prgpsk'
      SEGACT ADJAC
      NTOTPO=ADJAC.IDX(/1)-1
      JG=NTOTPO
      SEGINI DEGREE
      DO 1 ITOTPO=1,NTOTPO
         DEGREE.LECT(ITOTPO)=ADJAC.IDX(ITOTPO+1)
     $        -ADJAC.IDX(ITOTPO)
 1    CONTINUE
      JG=NTOTPO
      SEGINI NEWNUM
      DO 3 ITOTPO=1,NTOTPO
         NEWNUM.LECT(ITOTPO)=ITOTPO
 3    CONTINUE
      WRKLEN=(6*NTOTPO)+3
      JG=WRKLEN
      SEGINI IWORK
      CALL GPSKCA(NTOTPO,DEGREE.LECT,ADJAC.IDX,ADJAC.IVAL,OPTPRO,WRKLEN,
     $     NEWNUM.LECT,
     $     IWORK.LECT,
     $     BANDWD,PROFI,
     $     ERROR,SPACE)
      IF (ERROR.NE.0) THEN
         WRITE(IOIMP,*) 'ERROR=',ERROR, 'in GPSKCA'
         GOTO 9999
      ENDIF
      SEGSUP IWORK
      SEGSUP DEGREE
      SEGDES NEWNUM
      SEGDES ADJAC
      IF (IMPR.GT.3) THEN
         WRITE(IOIMP,*) 'BANDWD             = ',BANDWD
         WRITE(IOIMP,*) 'PROFI              = ',PROFI
      ENDIF
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine prgpsk'
      RETURN
*
* End of subroutine PRGPSK
*
      END