Esope source files

   1 : C RELR1C    SOURCE    GOUNAND   11/05/24    21:16:01     6976           
   2 :       SUBROUTINE RELR1C(PROFM,NDDLPR,IMPR,IRET)
   3 :       IMPLICIT REAL*8 (A-H,O-Z)
   4 :       IMPLICIT INTEGER (I-N)
   5 : C***********************************************************************
   6 : C NOM         : RELR1C
   7 : C DESCRIPTION :
   8 : * Ordonnancement du profil morse
   9 : *
  10 : * Avant on utilisait csort, mais celui-ci suppose
  11 : * la matrice carrée avec au moins un terme par ligne
  12 : * de plus csort est en fortran pas robuste
  13 : * On fait un code un peu plus lisible que csort
  14 : * mais prenant plus de mémoire.
  15 : * On pourrait écraser certains tableaux de travail
  16 : * au fur et à mesure de leur utilisation (cf. csort)
  17 : C
  18 : C
  19 : C LANGAGE     : ESOPE
  20 : C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  21 : C               mél : gounand@semt2.smts.cea.fr
  22 : C***********************************************************************
  23 : C APPELES          : 
  24 : C APPELES (E/S)    : 
  25 : C APPELES (BLAS)   :
  26 : C APPELES (CALCUL) :
  27 : C APPELE PAR       :
  28 : C***********************************************************************
  29 : C SYNTAXE GIBIANE    :
  30 : C ENTREES            :
  31 : C ENTREES/SORTIES    :
  32 : C SORTIES            :
  33 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  34 : C***********************************************************************
  35 : C VERSION    : v1, 30/06/2003, version initiale
  36 : C HISTORIQUE : v1, 30/06/2003, création
  37 : C HISTORIQUE :
  38 : C HISTORIQUE :
  39 : C***********************************************************************
  40 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  41 : C en cas de modification de ce sous-programme afin de faciliter
  42 : C la maintenance !
  43 : C***********************************************************************
  44 : -INC CCOPTIO
  45 : * Includes persos
  46 : CBEGININCLUDE SMPMORS
  47 :       SEGMENT PMORS
  48 :       INTEGER IA (NTT+1)
  49 :       INTEGER JA (NJA)
  50 :       ENDSEGMENT
  51 : CENDINCLUDE SMPMORS
  52 :       POINTEUR PROFM.PMORS
  53 : *
  54 : -INC SMLENTI
  55 :       POINTEUR IWORK.MLENTI
  56 :       POINTEUR JWORK.MLENTI
  57 :       POINTEUR KWORK.MLENTI
  58 :       POINTEUR LWORK.MLENTI
  59 :       POINTEUR MWORK.MLENTI
  60 : *
  61 :       INTEGER IMPR,IRET
  62 : *     
  63 : * Executable statements
  64 : *
  65 :       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1c.eso' 
  66 :       SEGACT PROFM*MOD
  67 :       NDDLDU=PROFM.IA(/1)-1
  68 :       NNZ=PROFM.JA(/1)
  69 : c     
  70 : c Nombre d'éléments non nuls dans chaque colonne
  71 : c IWORK(ICOL+1) = nb d'éléments non nuls dans la 
  72 : c colonne icol
  73 : c     
  74 :       JG=NDDLPR+1
  75 :       SEGINI IWORK
  76 :       DO IDDLDU=1,NDDLDU
  77 :          DO INZ=PROFM.IA(IDDLDU),PROFM.IA(IDDLDU+1)-1
  78 :             IDDLP1=PROFM.JA(INZ)+1
  79 :             IWORK.LECT(IDDLP1)=IWORK.LECT(IDDLP1)+1
  80 :          ENDDO
  81 :       ENDDO
  82 : C     
  83 : C repérage de ces éléments non nuls dans le futur
  84 : C tableau de travail JWORK
  85 : C    
  86 :       IWORK.LECT(1)=1
  87 :       DO IDDLPR=1,NDDLPR
  88 :          IWORK.LECT(IDDLPR+1)=IWORK.LECT(IDDLPR)+IWORK.LECT(IDDLPR+1)
  89 :       ENDDO
  90 : C     
  91 : C JWORK est trié par colonne croissante
  92 : C et pointe sur des éléments du tableau JA
  93 : C     
  94 :       JG=NNZ
  95 :       SEGINI JWORK
  96 :       DO IDDLDU=1,NDDLDU
  97 :          DO INZ=PROFM.IA(IDDLDU),PROFM.IA(IDDLDU+1)-1
  98 :             IDDLPR=PROFM.JA(INZ)
  99 :             JNZ=IWORK.LECT(IDDLPR)
 100 :             JWORK.LECT(JNZ)=INZ
 101 :             IWORK.LECT(IDDLPR)=JNZ+1
 102 :          ENDDO
 103 :       ENDDO
 104 : * On n'aura plus besoin de IWORK
 105 :       SEGSUP IWORK
 106 : C
 107 : C Tableau de correspondance :
 108 : C INZeme élément de JA est sur la IDDLDUeme ligne
 109 : C KWORK 
 110 : C 
 111 :       JG=NNZ
 112 :       SEGINI KWORK
 113 :       DO IDDLDU=1,NDDLDU
 114 :          DO INZ=PROFM.IA(IDDLDU),PROFM.IA(IDDLDU+1)-1
 115 :             KWORK.LECT(INZ)=IDDLDU
 116 :          ENDDO
 117 :       ENDDO
 118 : C
 119 : C Tableau de repérage dans le futur tableau de travail MWORK
 120 : C qui contiendra la permutation a appliquer a PROFM
 121 : C      
 122 :       JG=NDDLDU
 123 :       SEGINI,LWORK
 124 :       DO IDDLDU=1,NDDLDU
 125 :          LWORK.LECT(IDDLDU)=PROFM.IA(IDDLDU)
 126 :       ENDDO
 127 : C
 128 : C Boucle de remplissage de MWORK
 129 : C      
 130 :       JG=NNZ
 131 :       SEGINI,MWORK
 132 :       DO JNZ=1,NNZ
 133 :          INZ=JWORK.LECT(JNZ)
 134 :          IDDLDU=KWORK.LECT(INZ)
 135 :          KNZ=LWORK.LECT(IDDLDU)
 136 :          MWORK.LECT(INZ)=KNZ
 137 :          LWORK.LECT(IDDLDU)=KNZ+1
 138 :       ENDDO
 139 :       SEGSUP JWORK
 140 :       SEGSUP KWORK
 141 :       SEGSUP LWORK
 142 : C
 143 : C Permutation "in place" de PROFM.JA
 144 : C
 144 :       CALL IVPERM(NNZ,PROFM.JA,MWORK.LECT)
 145 :       SEGSUP MWORK
 146 :       SEGDES PROFM
 147 : *
 148 : * Normal termination
 149 : *
 150 :       IRET=0
 151 :       RETURN
 152 : *
 153 : * Format handling
 154 : *
 155 : *
 156 : * Error handling
 157 : *
 158 :  9999 CONTINUE
 159 :       IRET=1
 160 :       WRITE(IOIMP,*) 'An error was detected in subroutine relr1c'
 161 :       RETURN
 162 : *
 163 : * End of subroutine RELR1C
 164 : *
 165 :       END
 166 : 
 167 :