Esope source files

   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 :