@*0 Test of Hash and Insertion ranking.
@f range _range
@f index _index

@*1 Main program.
This is an example of a program that tests the ranking routines from the module |Sorting_Ranking| and tests these for single integer keys, multiple integer keys, and single real keys of a chosen precision. The |StopWatch| module is used for timing.
@a@%%
PROGRAM Test_Quick @;
 USE Precision @;
 USE Error_Handling @;
 USE Sorting_Ranking @;
 USE Random_Numbers @;
 USE Simple_Graphics @;
 USE StopWatch @;
 IMPLICIT NONE @;
 
 INTEGER, DIMENSION(:), ALLOCATABLE :: permutation @; 
 INTEGER, DIMENSION(:), ALLOCATABLE :: i_array @;
 REAL(KIND=r_sp), DIMENSION(:), ALLOCATABLE :: r_array @; 
 INTEGER, DIMENSION(:,:), ALLOCATABLE :: i_array_2 @;

 TYPE(WATCHTYPE) :: timer @;
 REAL :: elapsed_time, mean, std, disorder,memory_factor, uniformity @;  
 LOGICAL :: test, use_pointers @;  
 INTEGER :: size_array, n_repeated, cutoff, n_keys, n_bits, n_passes, n_ignored @;
 INTEGER :: i, key @;
 CHARACTER(LEN=1) :: distribution, method, pivot_method, pointer_method @;

 debug=.TRUE. @;
 CALL CREATE_WATCH(timer, name="Single real keys:") @; 
 CALL UnpredictableSeeds() @;

 _RankIntegerKeys @;
 _RankMultipleKeys @;
 _RankRealKeys @;
 
END PROGRAM Test_Quick @;  
@%%   
   @*2 Ranking single integer keys.
   @m _RankIntegerKeys @;
    WRITE(*,*) "Enter the size of the integer array to be *fully* ranked: " @;
    READ(*,*) size_array @;    
	 WRITE(*,*) "Enter the number of repetitions per key in integer array" @;
	 READ(*,*) n_repeated @;     
    ALLOCATE(permutation(size_array), i_array(size_array)) @;	 
	 CALL RandomUniform(i_array, range=(/1,size_array/n_repeated/)) @;
    IF(debug) THEN @; 
      _DisplayArray("Input array:",i_array) @; 
    END IF @;

    RankSingleIntegerKeys: DO @;    
    
	    WRITE(*,*) "Enter method of sorting for integers ('X'-exit, 'Shell', 'Quick', 'Hash' or 'Radix'):" @;
	    READ(*,*) method @;
	    IF(method=='X') @~ EXIT RankSingleIntegerKeys @;	  	   
		 IF(method=='R') THEN @;
		    WRITE(*,*) "Enter the number of bits in the radix: " @;
		    READ(*,*) n_bits @;
		 ELSE IF(method=='H') THEN @;   
			 WRITE(*,*) "Enter method of hashing ('Pointers' or 'NoPointers'):" @;
			 READ(*,*) pointer_method @;
			 IF(pointer_method=='P') THEN @;
			    use_pointers=.TRUE. @;
			 ELSE @;
			    use_pointers=.FALSE. @;    
			 END IF @;   
			 WRITE(*,*) "Enter the number of passes, the memory and the uniformity factors: " @;
			 READ(*,*) n_passes, memory_factor, uniformity @;  	   
	    ELSE IF(method=='S') THEN @;
		    WRITE(*,*) "Enter the final gap: " @;   
		    READ(*,*) cutoff @; 		     		  
		 ELSE @;    	
		    WRITE(*,*) "Enter the cutoff size: " @;
		    READ(*,*) cutoff @; 	  
		    WRITE(*,*) "Enter the pivot selection rule ('U' or 'R'): " @;
		    READ(*,*) pivot_method @;              
	    END IF @;
	     
		 CALL RESET_WATCH(timer) @;
		 CALL START_WATCH(timer) @;
		 IF(method=='R') THEN @;
		    CALL RadixRank(array=i_array, permutation= permutation, &
		                   partially_ranked = .FALSE., n_radix_bits=n_bits) @;
		 ELSE IF(method=='H') THEN @;	 
	      CALL HashRank(array=i_array, permutation= permutation, &
	             number_passes=n_passes, partially_ranked = .FALSE., &
	             memory_factor=memory_factor, uniformity=uniformity, &
	             distribution='U', use_hash_pointers=use_pointers) @;	                            	 
		 ELSE IF (method=='S') THEN @;              
		    CALL ShellInsertionRank(array=i_array, permutation= permutation, &
		      partially_ranked = .FALSE., method="Shell", last_gap=cutoff ) @;
		    IF(cutoff>1) THEN @;
		      CALL ShellInsertionRank(array=i_array, permutation= permutation, &
			                partially_ranked = .TRUE., method='Insertion') @;
			 END IF @; 	                        
		 ELSE @;   	     
			 CALL QuickRank(array=i_array, permutation= permutation, & 
			                partially_ranked = .FALSE., pivot_selection=pivot_method, cutoff_size=cutoff) @;
		    IF(cutoff>1) THEN @;
		      CALL ShellInsertionRank(array=i_array, permutation= permutation, &
			                partially_ranked = .TRUE., method='Insertion') @;
			 END IF @;               	                	                
	    END IF @;
		 CALL STOP_WATCH(timer) @;  
		 CALL READ_WATCH(read_result=elapsed_time, watch=timer, clock="cpu") @;                    
		 WRITE(*,"(A,F10.2)") "Ranking took (s):", elapsed_time @;   
	    
		 test=TestPermutation(permutation) @;
		 IF(.NOT.test) THEN @;             
		   WRITE(*,*) "The returned permutation is invalid !!!"
		   STOP @;
		 END IF @;  
		 test=TestRanking(i_array,permutation) @;
		 IF(.NOT.test) THEN @;             
		   WRITE(*,*) "The final ranking is not strictly non-descreasing !!!" @;
		   STOP @;
		 END IF @;  
		 i_array=i_array(permutation) @; 
	    IF(debug) THEN @; 
	      _DisplayArray("Sorted array:",i_array) @; 
	    END IF @;
	    
    END DO RankSingleIntegerKeys @; 
    
	 DEALLOCATE(permutation, i_array) @;
@%%
    @*2 Ranking Multiple Integer Keys.  
    @m _RankMultipleKeys @;
    WRITE(*,*) "Enter the size of the multiple-key integer array to be sorted: " @;
    READ(*,*) size_array @;   
	 WRITE(*,*) "Enter the number of repetitions per key in integer array" @;
	 READ(*,*) n_repeated @;       
    WRITE(*,*) "Enter the number of multiple keys:" @;
    READ(*,*) n_keys @;

    ALLOCATE(permutation(size_array), i_array_2(n_keys,size_array)) @;
	 CALL RandomUniform(i_array_2, range=(/1, size_array/n_repeated /)) @;
		 
    RankMultipleIntegerKeys: DO @;
     
	    WRITE(*,*) "Enter method of sorting ('X'-exit, 'Q'-pure quick or 'I'-quick/insertion):" @;
	    READ(*,*) method @;
		 IF(method=='X') @~ EXIT RankMultipleIntegerKeys @;	
		    
		 WRITE(*,*) "Enter the cutoff size (or cutoff gap): " @;
		 READ(*,*) cutoff @;     	   

		 IF(debug.AND.(size_array<20)) THEN @;
			 WRITE(*,*) "Multiple keys before ranking:" @;
			 DO key=1,SIZE(i_array_2,1) @;  
			   WRITE(*,"(A,I1,A,20I5)") "Key #",key,":", i_array_2(key,:) @;
			 END DO @;
		 END IF @;

		 CALL RESET_WATCH(timer) @;
		 CALL START_WATCH(timer) @;
		 IF(method=='I') THEN @;
		    CALL QuickRank(array=i_array_2(1,:), permutation= permutation, & 
		                partially_ranked = .FALSE., pivot_selection=pivot_method, cutoff_size=cutoff) @;	// Sort using quick on first key             
		    CALL ShellInsertionRank(array=i_array_2, permutation= permutation, &
		                partially_ranked = .TRUE., method='Insertion') @; // Sort with insertion on the rest of the keys
		 ELSE @;	                 
		  CALL QuickRank(array=i_array_2, permutation= permutation, & 
		                partially_ranked = .FALSE., pivot_selection='R', cutoff_size=cutoff) @; // Sort using quick on all keys
		    IF(cutoff>1) THEN @;
		      CALL ShellInsertionRank(array=i_array_2, permutation= permutation, &
			                partially_ranked = .TRUE., method='Insertion') @;
			 END IF @;               	                
	    END IF @;	                
		 CALL STOP_WATCH(timer) @;  
		 CALL READ_WATCH(read_result=elapsed_time, watch=timer, clock="cpu") @;                    
		 WRITE(*,"(A,F10.2)") "Ranking took (s):", elapsed_time @;    	  
		 
		 test=TestPermutation(permutation) @;
		 IF(.NOT.test) THEN @;             
		   WRITE(*,*) "The permutation with multiple keys is invalid!!!" @;
		   STOP @;
		 END IF @; 
		 test=TestRanking(i_array_2,permutation) @; 
		 IF(.NOT.test) THEN @;             
		   WRITE(*,*) "The final ranking is not strictly non-descreasing !!!" @;
		   STOP @;
		 END IF @;  
		    
		 i_array_2=i_array_2(:,permutation) @;  
		 IF(debug.AND.(size_array<20)) THEN @;	 	 
			 WRITE(*,*) "After ranking:" @;
			 DO key=1,SIZE(i_array_2,1) @;  
			   WRITE(*,"(A,I1,A,20I5)") "Key #",key,":", i_array_2(key,:) @;
			 END DO @; 
		 END IF @;	 
		 
    END DO RankMultipleIntegerKeys @;
   
	 DEALLOCATE(permutation, i_array_2) @;
@%%  
 @*2 Ranking Single Real Keys.
 @m _RankRealKeys @;
 WRITE(*,*) "Enter the size of the real array to be *partially* sorted: " @;
 READ(*,*) size_array @; 
 WRITE(*,*) "Enter the disorder:" @;
 READ(*,*) disorder @;  
 WRITE(*,*) "Distribution for random numbers in array ('Uniform' or 'Normal'):" @;
 READ(*,*) distribution @;

 ALLOCATE(permutation(size_array), r_array(size_array)) @;  
 IF(distribution=="U") THEN @;
   CALL RandomUniform(r_array) @; // |range=(/0.0,1.0/)| by default
   mean=0.5 @;
   std=0.5/SQRT(3.0) @;
 ELSE @;  
   CALL RandomNormal(r_array) @; // |mean_std=(/0.0,1.0/)| by default
   mean=0.0 @;
   std=1.0 @;
 END IF @; 

 IF(disorder!=1.0) THEN @; 
	 CALL QuickRank(r_array, permutation) @; // Order then disorder the array
	 r_array=r_array(permutation) @; 
	 CALL DisorderPermutation(permutation=permutation, &
	        disorder=disorder,disorder_distribution='N') @;    
	 r_array=r_array(permutation) @; // Now disorder the sorted array
 END IF @;

 RankRealKeys: DO @;     
	 WRITE(*,*) "Enter method of sorting ('X'-exit, 'Q', 'R', 'H', 'I' or 'S'):" @;
	 READ(*,*) method @;  
    IF(method=='X') @~ EXIT RankRealKeys @;	
	 IF(method=='S') THEN @;
		 WRITE(*,*) "Enter the cutoff gap:" @;
		 READ(*,*) cutoff @;  
	 ELSE IF(method=='I') THEN @;		 
	 ELSE IF(method=='R') THEN @;
	 	    WRITE(*,*) "Enter the number of ignored bits in the real numbers: " @;
		    READ(*,*) n_ignored @;
	 ELSE IF(method=='H') THEN @;	  
			 WRITE(*,*) "Enter the number of passes, the memory and the uniformity factors: " @;
			 READ(*,*) n_passes, memory_factor, uniformity @;  	  
			 WRITE(*,*) "Distribution for hashing ('Uniform' or 'Normal'):" @;
			 READ(*,*) distribution @;	   		 
	 ELSE @;  
		 WRITE(*,*) "Enter the cutoff size: " @;
		 READ(*,*) cutoff @;  
		 WRITE(*,*) "Distribution for pivot selection ('Uniform' or 'Normal'):" @;
		 READ(*,*) distribution @;	    
	 END IF @; 	   
	   
	 CALL RESET_WATCH(timer) @;
	 CALL START_WATCH(timer) @;
	 IF(method=='S' .OR. method=='I') THEN @;
		 CALL ShellInsertionRank(array=r_array, permutation=permutation, & 
		                         partially_ranked=.FALSE., method=method, &
		                         last_gap=cutoff, disorder=disorder) @; 
	 ELSE IF(method=='R') THEN @;
	       WRITE(*,*) "Calling RadixSort real..." @;
		    CALL RadixRank(array=r_array, &
		    @%%TRANSFER(r_array, MOLD=1, SIZE=size_array) 
		                   permutation= permutation, &
		                   partially_ranked = .FALSE., n_ignored_bits=n_ignored) @; 
	 ELSE IF(method=='H') THEN @;
		 CALL HashRank(array=r_array, permutation= permutation, &
		             partially_ranked = .FALSE., number_passes=n_passes, &
		             @%% mean_value=mean, standard_deviation=std, &
		             memory_factor=memory_factor, uniformity=uniformity, &
		             distribution=distribution, use_hash_pointers=.FALSE., full_ranking=.FALSE.) @; 	                                                            
	 ELSE @;	                          
	    CALL QuickRank(array=r_array, permutation= permutation, &
	                  @%% mean_value=mean, standard_deviation=std, & 
		               partially_ranked = .FALSE., pivot_selection=distribution, cutoff_size=cutoff) @;
	 END IF @;
	 CALL STOP_WATCH(timer) @;  
	 CALL READ_WATCH(read_result=elapsed_time, watch=timer, clock="cpu") @;                    
	 WRITE(*,"(A,F10.2)") "Ranking took (s):", elapsed_time @;
			               
	 IF(debug) THEN @;
	  IF(size_array<2500.AND.size_array>20) THEN @; 
	    CALL InitGraphics(plot_title=(/"Almost-sorted array  ", &
	                                   "A. Donev 1/18/2001   "/), & 
	                    x_label="$i$",y_label="$A_{i}$") @;
	    CALL Plot2D(x=@E REAL((/(i,i=1,size_array)/),r_sg),y=@E REAL(r_array(permutation),r_sg), &
	              plot_spec="SCR") @; 
	    CALL EndGraphics() @;  
	  END IF @;   
	 END IF @; 

    IF(method!='I') THEN @;
		 WRITE(*,*) "Enter method of insertion ('Insertion' or 'Shell') for final sort:" @;
		 READ(*,*) method @;
		 CALL START_WATCH(timer) @;
		 CALL ShellInsertionRank(array=r_array, permutation=permutation, & 
		                         partially_ranked=.TRUE., method=method, &
		                         disorder = REAL(cutoff)/REAL(size_array), last_gap=1) @; 
		 CALL STOP_WATCH(timer) @;  
		 CALL READ_WATCH(read_result=elapsed_time, watch=timer, clock="cpu") @;                    
		 WRITE(*,"(A,F10.2)") "Partial Ranking+Insertion ranking took (s):", elapsed_time @;
		 CALL RESET_WATCH(timer) @;   
	 END IF @;

 END DO RankRealKeys @;
 
 DEALLOCATE(r_array, permutation) @;             
@%%
@I HPF2Formatting.hweb
@%%