Sources Esope | Cast3M

relr1c
C RELR1C    SOURCE    GOUNAND   11/05/24    21:16:01     6976
      SUBROUTINE RELR1C(PROFM,NDDLPR,IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : RELR1C
C DESCRIPTION :
* Ordonnancement du profil morse
*
* Avant on utilisait csort, mais celui-ci suppose
* la matrice carrée avec au moins un terme par ligne
* de plus csort est en fortran pas robuste
* On fait un code un peu plus lisible que csort
* mais prenant plus de mémoire.
* On pourrait écraser certains tableaux de travail
* au fur et à mesure de leur utilisation (cf. csort)
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELES (E/S)    :
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 30/06/2003, version initiale
C HISTORIQUE : v1, 30/06/2003, 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
* Includes persos
CBEGININCLUDE SMPMORS
      SEGMENT PMORS
      INTEGER IA (NTT+1)
      INTEGER JA (NJA)
      ENDSEGMENT
CENDINCLUDE SMPMORS
      POINTEUR PROFM.PMORS
*
-INC SMLENTI
      POINTEUR IWORK.MLENTI
      POINTEUR JWORK.MLENTI
      POINTEUR KWORK.MLENTI
      POINTEUR LWORK.MLENTI
      POINTEUR MWORK.MLENTI
*
      INTEGER IMPR,IRET
*
* Executable statements
*
      IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1c.eso'
      SEGACT PROFM*MOD
      NDDLDU=PROFM.IA(/1)-1
      NNZ=PROFM.JA(/1)
c
c Nombre d'éléments non nuls dans chaque colonne
c IWORK(ICOL+1) = nb d'éléments non nuls dans la
c colonne icol
c
      JG=NDDLPR+1
      SEGINI IWORK
      DO IDDLDU=1,NDDLDU
         DO INZ=PROFM.IA(IDDLDU),PROFM.IA(IDDLDU+1)-1
            IDDLP1=PROFM.JA(INZ)+1
            IWORK.LECT(IDDLP1)=IWORK.LECT(IDDLP1)+1
         ENDDO
      ENDDO
C
C repérage de ces éléments non nuls dans le futur
C tableau de travail JWORK
C
      IWORK.LECT(1)=1
      DO IDDLPR=1,NDDLPR
         IWORK.LECT(IDDLPR+1)=IWORK.LECT(IDDLPR)+IWORK.LECT(IDDLPR+1)
      ENDDO
C
C JWORK est trié par colonne croissante
C et pointe sur des éléments du tableau JA
C
      JG=NNZ
      SEGINI JWORK
      DO IDDLDU=1,NDDLDU
         DO INZ=PROFM.IA(IDDLDU),PROFM.IA(IDDLDU+1)-1
            IDDLPR=PROFM.JA(INZ)
            JNZ=IWORK.LECT(IDDLPR)
            JWORK.LECT(JNZ)=INZ
            IWORK.LECT(IDDLPR)=JNZ+1
         ENDDO
      ENDDO
* On n'aura plus besoin de IWORK
      SEGSUP IWORK
C
C Tableau de correspondance :
C INZeme élément de JA est sur la IDDLDUeme ligne
C KWORK
C
      JG=NNZ
      SEGINI KWORK
      DO IDDLDU=1,NDDLDU
         DO INZ=PROFM.IA(IDDLDU),PROFM.IA(IDDLDU+1)-1
            KWORK.LECT(INZ)=IDDLDU
         ENDDO
      ENDDO
C
C Tableau de repérage dans le futur tableau de travail MWORK
C qui contiendra la permutation a appliquer a PROFM
C
      JG=NDDLDU
      SEGINI,LWORK
      DO IDDLDU=1,NDDLDU
         LWORK.LECT(IDDLDU)=PROFM.IA(IDDLDU)
      ENDDO
C
C Boucle de remplissage de MWORK
C
      JG=NNZ
      SEGINI,MWORK
      DO JNZ=1,NNZ
         INZ=JWORK.LECT(JNZ)
         IDDLDU=KWORK.LECT(INZ)
         KNZ=LWORK.LECT(IDDLDU)
         MWORK.LECT(INZ)=KNZ
         LWORK.LECT(IDDLDU)=KNZ+1
      ENDDO
      SEGSUP JWORK
      SEGSUP KWORK
      SEGSUP LWORK
C
C Permutation "in place" de PROFM.JA
C
      CALL IVPERM(NNZ,PROFM.JA,MWORK.LECT)
      SEGSUP MWORK
      SEGDES PROFM
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine relr1c'
      RETURN
*
* End of subroutine RELR1C
*
      END