Télécharger relr1c.eso

Retour à la liste

Numérotation des lignes :

  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
  145. CALL IVPERM(NNZ,PROFM.JA,MWORK.LECT)
  146. SEGSUP MWORK
  147. SEGDES PROFM
  148. *
  149. * Normal termination
  150. *
  151. IRET=0
  152. RETURN
  153. *
  154. * Format handling
  155. *
  156. *
  157. * Error handling
  158. *
  159. 9999 CONTINUE
  160. IRET=1
  161. WRITE(IOIMP,*) 'An error was detected in subroutine relr1c'
  162. RETURN
  163. *
  164. * End of subroutine RELR1C
  165. *
  166. END
  167.  
  168.  
  169.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales