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.
index_sort.F90 in utils/tools/OBSTOOLS/src – NEMO

source: utils/tools/OBSTOOLS/src/index_sort.F90 @ 10841

Last change on this file since 10841 was 3026, checked in by djlea, 12 years ago

Remove unneeded sec_to_dt from dataplot. Also add obstools build instructions to documentation.
File size: 10.2 KB
Line 
1MODULE index_sort
2
3CONTAINS
4
5   LOGICAL FUNCTION lessn(a,b,n)
6      !!----------------------------------------------------------------------
7      !!                    ***  ROUTINE lessn  ***
8      !!         
9      !! ** Purpose : Compare two array and return true if the first
10      !!              element of array "a" different from the corresponding
11      !!              array "b" element is less than the this element
12      !!
13      !! ** Method  :
14      !!
15      !! ** Action  :
16      !!
17      !! References :
18      !!
19      !! History :
20      !!        !  08-02  (K. Mogensen)  Original code
21      !!----------------------------------------------------------------------
22      !! * Arguments
23      USE toolspar_kind
24      IMPLICIT NONE
25      INTEGER :: n
26      REAL(KIND=dp), DIMENSION(n) :: a,b
27      INTEGER :: i,j
28
29      DO i=1,n
30         IF (a(i)/=b(i)) THEN
31            IF (a(i)<b(i)) THEN
32               lessn=.TRUE.
33            ELSE
34               lessn=.FALSE.
35            ENDIF
36            EXIT
37         ENDIF
38      ENDDO
39
40   END FUNCTION lessn
41
42   SUBROUTINE  index_sort_dp_n(pval, n, kindx, kvals)
43      USE toolspar_kind
44      IMPLICIT NONE
45      !!----------------------------------------------------------------------
46      !!                    ***  ROUTINE index_sort  ***
47      !!         
48      !! ** Purpose : Get indicies for ascending order for a
49      !!              double precision array 2D
50      !!
51      !! ** Method  : Heapsort with call to lessn for comparision
52      !!
53      !! ** Action  :
54      !!
55      !! References : http://en.wikipedia.org/wiki/Heapsort
56      !!
57      !! History :
58      !!        !  08-02  (K. Mogensen)  Original code based on index_sort_dp
59      !!----------------------------------------------------------------------
60      !! * Arguments
61      INTEGER, INTENT(IN) :: &
62         & n                               ! Number of keys
63      INTEGER, INTENT(IN) :: &
64         & kvals                           ! Number of values
65      REAL(KIND=dp),DIMENSION(n,kvals),INTENT(IN) :: &
66         & pval                            ! Array to be sorted
67      INTEGER,DIMENSION(kvals),INTENT(INOUT) :: &
68         & kindx                           ! Indicies for ordering
69      !! * Local variables
70      INTEGER :: ji, jj, jt, jn, jparent, jchild
71
72      DO ji = 1, kvals
73         kindx(ji) = ji
74      END DO
75
76      IF (kvals > 1) THEN
77
78         ji = kvals/2 + 1
79         jn = kvals
80
81         main_loop : DO
82
83            IF ( ji > 1 ) THEN
84               ji = ji-1
85               jt = kindx(ji)
86            ELSE
87               jt = kindx(jn)
88               kindx(jn) = kindx(1)
89               jn = jn-1
90               IF ( jn == 1 ) THEN
91                  kindx(1) = jt
92                  EXIT main_loop
93               ENDIF
94            ENDIF
95
96            jparent = ji
97            jchild =  2*ji
98
99            inner_loop : DO
100               IF ( jchild > jn ) EXIT inner_loop
101               IF ( jchild < jn ) THEN
102                  IF ( lessn(pval(:,kindx(jchild)),pval(:,kindx(jchild+1)),n) ) THEN
103                     jchild = jchild+1
104                  ENDIF
105               ENDIF
106               IF  ( lessn(pval(:,jt),pval(:,kindx(jchild)),n) ) THEN
107                  kindx(jparent) = kindx(jchild)
108                  jparent = jchild
109                  jchild = jchild*2
110               ELSE
111                  jchild = jn + 1 
112               ENDIF
113            ENDDO inner_loop
114
115            kindx(jparent) = jt
116
117         END DO  main_loop
118      ENDIF
119
120   END SUBROUTINE index_sort_dp_n
121
122   SUBROUTINE  index_sort_dp(pval, kindx, kvals)
123      USE toolspar_kind
124      IMPLICIT NONE
125      !!----------------------------------------------------------------------
126      !!                    ***  ROUTINE index_sort  ***
127      !!         
128      !! ** Purpose : Get indicies for ascending order for a
129      !!              double precision array
130      !!
131      !! ** Method  : Heapsort
132      !!
133      !! ** Action  :
134      !!
135      !! References : http://en.wikipedia.org/wiki/Heapsort
136      !!
137      !! History :
138      !!        !  06-05  (K. Mogensen)  Original code
139      !!----------------------------------------------------------------------
140      !! * Arguments
141      REAL(KIND=dp),DIMENSION(*),INTENT(IN) :: &
142         & pval                            ! Array to be sorted
143      INTEGER,DIMENSION(*),INTENT(INOUT) :: &
144         & kindx                           ! Indicies for ordering
145      INTEGER, INTENT(IN) :: &
146         & kvals                           ! Number of values
147
148      !! * Local variables
149      INTEGER :: ji, jj, jt, jn, jparent, jchild
150
151      DO ji = 1, kvals
152         kindx(ji) = ji
153      END DO
154
155      IF (kvals > 1) THEN
156
157         ji = kvals/2 + 1
158         jn = kvals
159
160         main_loop : DO
161
162            IF ( ji > 1 ) THEN
163               ji = ji-1
164               jt = kindx(ji)
165            ELSE
166               jt = kindx(jn)
167               kindx(jn) = kindx(1)
168               jn = jn-1
169               IF ( jn == 1 ) THEN
170                  kindx(1) = jt
171                  EXIT main_loop
172               ENDIF
173            ENDIF
174
175            jparent = ji
176            jchild =  2*ji
177
178            inner_loop : DO
179               IF ( jchild > jn ) EXIT inner_loop
180               IF ( jchild < jn ) THEN
181                  IF ( pval(kindx(jchild)) <  pval(kindx(jchild+1)) ) THEN
182                     jchild = jchild+1
183                  ENDIF
184               ENDIF
185               IF  ( pval(jt) < pval(kindx(jchild))) THEN
186                  kindx(jparent) = kindx(jchild)
187                  jparent = jchild
188                  jchild = jchild*2
189               ELSE
190                  jchild = jn + 1 
191               ENDIF
192            ENDDO inner_loop
193
194            kindx(jparent) = jt
195
196         END DO  main_loop
197
198      ENDIF
199   END SUBROUTINE index_sort_dp
200
201   SUBROUTINE  index_sort_int(kval, kindx, kvals)
202      USE toolspar_kind
203      IMPLICIT NONE
204      !!----------------------------------------------------------------------
205      !!                    ***  ROUTINE index_sort  ***
206      !!         
207      !! ** Purpose : Get indicies for ascending order for an
208      !!              integer array
209      !!
210      !! ** Method  : Heapsort
211      !!
212      !! ** Action  :
213      !!
214      !! References : http://en.wikipedia.org/wiki/Heapsort
215      !!
216      !! History :
217      !!        !  06-05  (K. Mogensen)  Original code
218      !!----------------------------------------------------------------------
219      !! * Arguments
220      INTEGER,DIMENSION(*),INTENT(IN) :: &
221         & kval                            ! Array to be sorted
222      INTEGER,DIMENSION(*),INTENT(INOUT) :: &
223         & kindx                           ! Indicies for ordering
224      INTEGER, INTENT(IN) :: &
225         & kvals                           ! Number of values
226
227      !! * Local variables
228      INTEGER :: ji, jj, jt, jn, jparent, jchild
229
230      DO ji = 1, kvals
231         kindx(ji) = ji
232      END DO
233
234      IF (kvals > 1 ) THEN
235
236         ji = kvals/2 + 1
237         jn = kvals
238
239         main_loop : DO
240
241            IF ( ji > 1 ) THEN
242               ji = ji-1
243               jt = kindx(ji)
244            ELSE
245               jt = kindx(jn)
246               kindx(jn) = kindx(1)
247               jn = jn-1
248               IF ( jn == 1 ) THEN
249                  kindx(1) = jt
250                  EXIT main_loop
251               ENDIF
252            ENDIF
253
254            jparent = ji
255            jchild =  2*ji
256
257            inner_loop : DO
258               IF ( jchild > jn ) EXIT inner_loop
259               IF ( jchild < jn ) THEN
260                  IF ( kval(kindx(jchild)) <  kval(kindx(jchild+1)) ) THEN
261                     jchild = jchild+1
262                  ENDIF
263               ENDIF
264               IF  ( kval(jt) < kval(kindx(jchild))) THEN
265                  kindx(jparent) = kindx(jchild)
266                  jparent = jchild
267                  jchild = jchild*2
268               ELSE
269                  jchild = jn + 1 
270               ENDIF
271            ENDDO inner_loop
272
273            kindx(jparent) = jt
274
275         END DO  main_loop
276
277      ENDIF
278
279   END SUBROUTINE index_sort_int
280
281   SUBROUTINE  index_sort_string(cdval, kindx, kvals)
282      USE toolspar_kind
283      IMPLICIT NONE
284      !!----------------------------------------------------------------------
285      !!                    ***  ROUTINE index_sort  ***
286      !!         
287      !! ** Purpose : Get indicies for ascending order for an
288      !!              integer array
289      !!
290      !! ** Method  : Heapsort
291      !!
292      !! ** Action  :
293      !!
294      !! References : http://en.wikipedia.org/wiki/Heapsort
295      !!
296      !! History :
297      !!        !  06-05  (K. Mogensen)  Original code
298      !!----------------------------------------------------------------------
299      !! * Arguments
300      CHARACTER(len=*),DIMENSION(*),INTENT(IN) :: &
301         & cdval                            ! Array to be sorted
302      INTEGER,DIMENSION(*),INTENT(INOUT) :: &
303         & kindx                           ! Indicies for ordering
304      INTEGER, INTENT(IN) :: &
305         & kvals                           ! Number of values
306
307      !! * Local variables
308      INTEGER :: ji, jj, jt, jn, jparent, jchild
309
310      DO ji = 1, kvals
311         kindx(ji) = ji
312      END DO
313
314      IF (kvals > 1 ) THEN
315
316         ji = kvals/2 + 1
317         jn = kvals
318
319         main_loop : DO
320
321            IF ( ji > 1 ) THEN
322               ji = ji-1
323               jt = kindx(ji)
324            ELSE
325               jt = kindx(jn)
326               kindx(jn) = kindx(1)
327               jn = jn-1
328               IF ( jn == 1 ) THEN
329                  kindx(1) = jt
330                  EXIT main_loop
331               ENDIF
332            ENDIF
333
334            jparent = ji
335            jchild =  2*ji
336
337            inner_loop : DO
338               IF ( jchild > jn ) EXIT inner_loop
339               IF ( jchild < jn ) THEN
340                  IF ( cdval(kindx(jchild)) <  cdval(kindx(jchild+1)) ) THEN
341                     jchild = jchild+1
342                  ENDIF
343               ENDIF
344               IF  ( cdval(jt) < cdval(kindx(jchild))) THEN
345                  kindx(jparent) = kindx(jchild)
346                  jparent = jchild
347                  jchild = jchild*2
348               ELSE
349                  jchild = jn + 1 
350               ENDIF
351            ENDDO inner_loop
352
353            kindx(jparent) = jt
354
355         END DO  main_loop
356
357      ENDIF
358
359   END SUBROUTINE index_sort_string
360
361END MODULE index_sort
Note: See TracBrowser for help on using the repository browser.