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 PPARAM
  48. -INC CCOPTIO
  49. *
  50. INTEGER NTABL,NCUT
  51. REAL*8 TABLR(NTABL)
  52. INTEGER TABLI(NTABL)
  53.  
  54. INTEGER IMPR,IRET
  55. *
  56. INTEGER IDX,ISTRT,ISTOP,IMID
  57. INTEGER ITMP
  58. REAL*8 ABSKEY,RTMP
  59. *
  60. * Executable statements
  61. *
  62. IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans qsplit.eso'
  63. ISTRT=1
  64. ISTOP=NTABL
  65. * IF (NCUT.GE.ISTRT.AND.NCUT.LE.ISTOP) THEN
  66. IF (NCUT.GE.ISTRT.AND.NCUT.LT.ISTOP) THEN
  67. c outer loop -- while mid .ne. ncut do
  68. 1 CONTINUE
  69. IMID=ISTRT
  70. ABSKEY=ABS(TABLR(IMID))
  71. DO 12 IDX=ISTRT+1,ISTOP
  72. IF (ABS(TABLR(IDX)).GT.ABSKEY) THEN
  73. IMID=IMID+1
  74. c interchange
  75. RTMP=TABLR(IMID)
  76. ITMP=TABLI(IMID)
  77. TABLR(IMID)=TABLR(IDX)
  78. TABLI(IMID)=TABLI(IDX)
  79. TABLR(IDX)=RTMP
  80. TABLI(IDX)=ITMP
  81. ENDIF
  82. 12 CONTINUE
  83. c interchange
  84. RTMP=TABLR(IMID)
  85. ITMP=TABLI(IMID)
  86. TABLR(IMID)=TABLR(ISTRT)
  87. TABLI(IMID)=TABLI(ISTRT)
  88. TABLR(ISTRT)=RTMP
  89. TABLI(ISTRT)=ITMP
  90. c test for while loop
  91. IF (IMID.NE.NCUT) THEN
  92. IF (IMID.GT.NCUT) THEN
  93. ISTOP=IMID-1
  94. ELSE
  95. ISTRT=IMID+1
  96. ENDIF
  97. GOTO 1
  98. ENDIF
  99. ENDIF
  100. *
  101. * Teste le bon fonctionnement
  102. *
  103. *!! DO IFIN=NCUT+1,NTABL
  104. *!! XCOMP1=ABS(TABLR(IFIN))
  105. *!! DO IDEB=1,NCUT
  106. *!! XCOMP2=ABS(TABLR(IDEB))
  107. *!! IF (XCOMP1.GT.XCOMP2) THEN
  108. *!! WRITE(IOIMP,*) 'Erreur de programmation dans qsplit'
  109. *!! GOTO 9999
  110. *!! ENDIF
  111. *!! ENDDO
  112. *!! ENDDO
  113. *
  114. * Normal termination
  115. *
  116. IRET=0
  117. RETURN
  118. *
  119. * Format handling
  120. *
  121. *
  122. * Error handling
  123. *
  124. 9999 CONTINUE
  125. IRET=1
  126. WRITE(IOIMP,*) 'An error was detected in subroutine qsplit'
  127. RETURN
  128. *
  129. * End of subroutine QSPLIT
  130. *
  131. END
  132.  
  133.  
  134.  
  135.  
  136.  

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