New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
obs_sort.F90 in branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/OBS/obs_sort.F90 @ 2281

Last change on this file since 2281 was 2281, checked in by smasson, 14 years ago

set proper svn properties to all files...
  • Property svn:keywords set to Id
File size: 4.3 KB
Line 
1MODULE obs_sort
2   !!=====================================================================
3   !!                       ***  MODULE obs_sort  ***
4   !! Observation diagnostics: Various tools for sorting etc.
5   !!=====================================================================
6
7   !!----------------------------------------------------------------------
8   !!   sort_dp_indx : Get indicies for ascending order for a double prec. array
9   !!   index_sort   : Get indicies for ascending order for a double prec. array
10   !!---------------------------------------------------------------------
11   !! * Modules used
12   USE par_kind, ONLY : & ! Precision variables
13      & dp
14 
15   IMPLICIT NONE
16
17   !! * Routine accessibility
18   PRIVATE index_sort    ! Get indicies for ascending order for a double prec. array
19   
20   PUBLIC sort_dp_indx   ! Get indicies for ascending order for a double prec. array
21 
22CONTAINS
23
24   SUBROUTINE sort_dp_indx( kvals, pvals, kindx )
25      !!----------------------------------------------------------------------
26      !!                    ***  ROUTINE sort_dp_indx  ***
27      !!         
28      !! ** Purpose : Get indicies for ascending order for a double precision array
29      !!
30      !! ** Method  : Call index_sort routine
31      !!
32      !! ** Action  :
33      !!
34      !! History :
35      !!        !  06-05  (K. Mogensen)  Original code
36      !!        !  06-10  (A. Weaver) Cleaning
37      !!----------------------------------------------------------------------
38
39      !! * Arguments
40      INTEGER, INTENT(IN) :: kvals     ! Number of elements to be sorted
41      REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: &
42         & pvals            ! Array to be sorted
43      INTEGER, DIMENSION(kvals), INTENT(OUT) ::  &
44         & kindx            ! Indices for ordering of array
45
46      !! * Local declarations
47
48      !-----------------------------------------------------------------------
49      ! Call qsort routine
50      !-----------------------------------------------------------------------
51      IF (kvals>=1) THEN
52
53         CALL index_sort( pvals, kindx, kvals )
54
55      ENDIF
56
57   END SUBROUTINE sort_dp_indx
58
59   SUBROUTINE index_sort( pval, kindx, kvals )
60      !!----------------------------------------------------------------------
61      !!                    ***  ROUTINE index_sort  ***
62      !!         
63      !! ** Purpose : Get indicies for ascending order for a double precision array
64      !!
65      !! ** Method  : Heapsort
66      !!
67      !! ** Action  :
68      !!
69      !! References : http://en.wikipedia.org/wiki/Heapsort
70      !!
71      !! History :
72      !!        !  06-05  (K. Mogensen)  Original code
73      !!        !  06-10  (A. Weaver) Cleaning
74      !!----------------------------------------------------------------------
75
76      !! * Arguments
77      INTEGER, INTENT(IN) :: kvals         ! Number of values
78      REAL(KIND=dp), DIMENSION(kvals), INTENT(IN) :: &
79         & pval                            ! Array to be sorted
80      INTEGER, DIMENSION(kvals), INTENT(INOUT) :: &
81         & kindx                           ! Indicies for ordering
82
83      !! * Local declarations
84      INTEGER :: ji
85      INTEGER :: jj
86      INTEGER :: jt
87      INTEGER :: jn
88      INTEGER :: jparent
89      INTEGER :: jchild
90
91      DO ji = 1, kvals
92         kindx(ji) = ji
93      END DO
94     
95      ji = kvals/2 + 1
96      jn = kvals
97
98      main_loop : DO
99
100         IF ( ji > 1 ) THEN
101            ji = ji-1
102            jt = kindx(ji)
103         ELSE
104            jt = kindx(jn)
105            kindx(jn) = kindx(1)
106            jn = jn-1
107            IF ( jn <= 1 ) THEN
108               kindx(1) = jt
109               EXIT main_loop
110            ENDIF
111         ENDIF
112
113         jparent = ji
114         jchild =  2 * ji
115
116         inner_loop : DO
117
118            IF ( jchild > jn ) EXIT inner_loop
119            IF ( jchild < jn ) THEN
120               IF ( pval(kindx(jchild)) < pval(kindx(jchild+1)) ) THEN
121                 jchild = jchild+1
122               ENDIF
123            ENDIF
124            IF  ( pval(jt) < pval(kindx(jchild))) THEN
125               kindx(jparent) = kindx(jchild)
126               jparent = jchild
127               jchild  = jchild*2
128            ELSE
129               jchild = jn + 1 
130            ENDIF
131
132         END DO inner_loop
133
134         kindx(jparent) = jt
135
136      END DO main_loop
137     
138   END SUBROUTINE index_sort
139
140END MODULE obs_sort
141 
Note: See TracBrowser for help on using the repository browser.