Télécharger qsplit.eso

Retour à la liste

Numérotation des lignes :

  1. C QSPLIT SOURCE CHAT 05/01/13 02:40:39 5004
  2. SUBROUTINE QSPLIT(TABLR,TABLI,NTABL,NCUT,
  3. $ IMPR,IRET)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C***********************************************************************
  7. C NOM : QSPLIT
  8. C DESCRIPTION :
  9. C Quicksplit : renvoie les NCUT plus grandes valeurs d'un tableau de
  10. C dimension NTABL.
  11. C TABLR et TABLI sont des arguments d'entrée-sortie
  12. C En sortie : TABLR est modifié de telle façon que TABLR(1:NCUT)
  13. C contient les NCUT plus grands éléments de TABLR.
  14. C TABLI est un tableau de même dimenson que TABLR où
  15. C l'on effectue les mêmes permutations d'éléments que dans
  16. C TABL.
  17. C
  18. C LANGAGE : ESOPE
  19. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  20. C mél : gounand@semt2.smts.cea.fr
  21. C REFERENCE (bibtex-like) :
  22. C Sparskit : a basic tool kit for sparse matrix computations
  23. C Version 2 (Youcef Saad)
  24. C -> URL : http://www.cs.umn.edu/Research/arpa/SPARSKIT/sparskit.html
  25. C REMARQUES :
  26. C Une autre façon (vraisemblablement plus rapide pour les grands NTABL)
  27. C serait d'employer l'algorithme d'Alexeev (Knuth, Art of Programming
  28. C Vol.3 2nd Ed p 232)
  29. C
  30. C***********************************************************************
  31. C APPELES : -
  32. C APPELE PAR : MEILUT
  33. C***********************************************************************
  34. C ENTREES : NTABL, NCUT
  35. C ENTREES/SORTIES : TABLR,TABLI
  36. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  37. C***********************************************************************
  38. C VERSION : v1, 23/02/2000, version initiale
  39. C HISTORIQUE : v1, 23/02/2000, création
  40. C HISTORIQUE :
  41. C HISTORIQUE :
  42. C***********************************************************************
  43. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  44. C en cas de modification de ce sous-programme afin de faciliter
  45. C la maintenance !
  46. C***********************************************************************
  47. -INC CCOPTIO
  48. *
  49. INTEGER NTABL,NCUT
  50. REAL*8 TABLR(NTABL)
  51. INTEGER TABLI(NTABL)
  52.  
  53. INTEGER IMPR,IRET
  54. *
  55. INTEGER IDX,ISTRT,ISTOP,IMID
  56. INTEGER ITMP
  57. REAL*8 ABSKEY,RTMP
  58. *
  59. * Executable statements
  60. *
  61. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans qsplit.eso'
  62. ISTRT=1
  63. ISTOP=NTABL
  64. * IF (NCUT.GE.ISTRT.AND.NCUT.LE.ISTOP) THEN
  65. IF (NCUT.GE.ISTRT.AND.NCUT.LT.ISTOP) THEN
  66. c outer loop -- while mid .ne. ncut do
  67. 1 CONTINUE
  68. IMID=ISTRT
  69. ABSKEY=ABS(TABLR(IMID))
  70. DO 12 IDX=ISTRT+1,ISTOP
  71. IF (ABS(TABLR(IDX)).GT.ABSKEY) THEN
  72. IMID=IMID+1
  73. c interchange
  74. RTMP=TABLR(IMID)
  75. ITMP=TABLI(IMID)
  76. TABLR(IMID)=TABLR(IDX)
  77. TABLI(IMID)=TABLI(IDX)
  78. TABLR(IDX)=RTMP
  79. TABLI(IDX)=ITMP
  80. ENDIF
  81. 12 CONTINUE
  82. c interchange
  83. RTMP=TABLR(IMID)
  84. ITMP=TABLI(IMID)
  85. TABLR(IMID)=TABLR(ISTRT)
  86. TABLI(IMID)=TABLI(ISTRT)
  87. TABLR(ISTRT)=RTMP
  88. TABLI(ISTRT)=ITMP
  89. c test for while loop
  90. IF (IMID.NE.NCUT) THEN
  91. IF (IMID.GT.NCUT) THEN
  92. ISTOP=IMID-1
  93. ELSE
  94. ISTRT=IMID+1
  95. ENDIF
  96. GOTO 1
  97. ENDIF
  98. ENDIF
  99. *
  100. * Teste le bon fonctionnement
  101. *
  102. *!! DO IFIN=NCUT+1,NTABL
  103. *!! XCOMP1=ABS(TABLR(IFIN))
  104. *!! DO IDEB=1,NCUT
  105. *!! XCOMP2=ABS(TABLR(IDEB))
  106. *!! IF (XCOMP1.GT.XCOMP2) THEN
  107. *!! WRITE(IOIMP,*) 'Erreur de programmation dans qsplit'
  108. *!! GOTO 9999
  109. *!! ENDIF
  110. *!! ENDDO
  111. *!! ENDDO
  112. *
  113. * Normal termination
  114. *
  115. IRET=0
  116. RETURN
  117. *
  118. * Format handling
  119. *
  120. *
  121. * Error handling
  122. *
  123. 9999 CONTINUE
  124. IRET=1
  125. WRITE(IOIMP,*) 'An error was detected in subroutine qsplit'
  126. RETURN
  127. *
  128. * End of subroutine QSPLIT
  129. *
  130. END
  131.  
  132.  
  133.  
  134.  
  135.  

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