Line data Source code
1 : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2 : ! Copyright (c) 2015, Regents of the University of Colorado
3 : ! All rights reserved.
4 : !
5 : ! Redistribution and use in source and binary forms, with or without modification, are
6 : ! permitted provided that the following conditions are met:
7 : !
8 : ! 1. Redistributions of source code must retain the above copyright notice, this list of
9 : ! conditions and the following disclaimer.
10 : !
11 : ! 2. Redistributions in binary form must reproduce the above copyright notice, this list
12 : ! of conditions and the following disclaimer in the documentation and/or other
13 : ! materials provided with the distribution.
14 : !
15 : ! 3. Neither the name of the copyright holder nor the names of its contributors may be
16 : ! used to endorse or promote products derived from this software without specific prior
17 : ! written permission.
18 : !
19 : ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
20 : ! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
21 : ! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
22 : ! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 : ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
24 : ! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 : ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26 : ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27 : ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 : !
29 : ! History:
30 : ! May 2015: Dustin Swales - Modified for COSPv2.0
31 : !
32 : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 : Module m_mrgrnk
34 : USE COSP_KINDS, ONLY: wp
35 : Integer, Parameter :: kdp = selected_real_kind(15)
36 : public :: mrgrnk
37 : private :: kdp
38 : private :: R_mrgrnk, I_mrgrnk, D_mrgrnk
39 :
40 : interface mrgrnk
41 : ! module procedure D_mrgrnk, R_mrgrnk, I_mrgrnk
42 : module procedure R_mrgrnk, I_mrgrnk
43 :
44 : end interface
45 : contains
46 :
47 : Subroutine D_mrgrnk (XDONT, IRNGT)
48 : ! __________________________________________________________
49 : ! MRGRNK = Merge-sort ranking of an array
50 : ! For performance reasons, the first 2 passes are taken
51 : ! out of the standard loop, and use dedicated coding.
52 : ! __________________________________________________________
53 : ! __________________________________________________________
54 : Real (wp), Dimension (:), Intent (In) :: XDONT
55 : Integer, Dimension (:), Intent (Out) :: IRNGT
56 : ! __________________________________________________________
57 : Real (wp) :: XVALA, XVALB
58 : !
59 : Integer, Dimension (SIZE(IRNGT)) :: JWRKT
60 : Integer :: LMTNA, LMTNC, IRNG1, IRNG2
61 : Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
62 : !
63 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
64 : Select Case (NVAL)
65 : Case (:0)
66 : Return
67 : Case (1)
68 : IRNGT (1) = 1
69 : Return
70 : Case Default
71 : Continue
72 : End Select
73 : !
74 : ! Fill-in the index array, creating ordered couples
75 : !
76 : Do IIND = 2, NVAL, 2
77 : If (XDONT(IIND-1) <= XDONT(IIND)) Then
78 : IRNGT (IIND-1) = IIND - 1
79 : IRNGT (IIND) = IIND
80 : Else
81 : IRNGT (IIND-1) = IIND
82 : IRNGT (IIND) = IIND - 1
83 : End If
84 : End Do
85 : If (Modulo(NVAL, 2) /= 0) Then
86 : IRNGT (NVAL) = NVAL
87 : End If
88 : !
89 : ! We will now have ordered subsets A - B - A - B - ...
90 : ! and merge A and B couples into C - C - ...
91 : !
92 : LMTNA = 2
93 : LMTNC = 4
94 : !
95 : ! First iteration. The length of the ordered subsets goes from 2 to 4
96 : !
97 : Do
98 : If (NVAL <= 2) Exit
99 : !
100 : ! Loop on merges of A and B into C
101 : !
102 : Do IWRKD = 0, NVAL - 1, 4
103 : If ((IWRKD+4) > NVAL) Then
104 : If ((IWRKD+2) >= NVAL) Exit
105 : !
106 : ! 1 2 3
107 : !
108 : If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
109 : !
110 : ! 1 3 2
111 : !
112 : If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
113 : IRNG2 = IRNGT (IWRKD+2)
114 : IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
115 : IRNGT (IWRKD+3) = IRNG2
116 : !
117 : ! 3 1 2
118 : !
119 : Else
120 : IRNG1 = IRNGT (IWRKD+1)
121 : IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
122 : IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
123 : IRNGT (IWRKD+2) = IRNG1
124 : End If
125 : Exit
126 : End If
127 : !
128 : ! 1 2 3 4
129 : !
130 : If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
131 : !
132 : ! 1 3 x x
133 : !
134 : If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
135 : IRNG2 = IRNGT (IWRKD+2)
136 : IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
137 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
138 : ! 1 3 2 4
139 : IRNGT (IWRKD+3) = IRNG2
140 : Else
141 : ! 1 3 4 2
142 : IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
143 : IRNGT (IWRKD+4) = IRNG2
144 : End If
145 : !
146 : ! 3 x x x
147 : !
148 : Else
149 : IRNG1 = IRNGT (IWRKD+1)
150 : IRNG2 = IRNGT (IWRKD+2)
151 : IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
152 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
153 : IRNGT (IWRKD+2) = IRNG1
154 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
155 : ! 3 1 2 4
156 : IRNGT (IWRKD+3) = IRNG2
157 : Else
158 : ! 3 1 4 2
159 : IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
160 : IRNGT (IWRKD+4) = IRNG2
161 : End If
162 : Else
163 : ! 3 4 1 2
164 : IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
165 : IRNGT (IWRKD+3) = IRNG1
166 : IRNGT (IWRKD+4) = IRNG2
167 : End If
168 : End If
169 : End Do
170 : !
171 : ! The Cs become As and Bs
172 : !
173 : LMTNA = 4
174 : Exit
175 : End Do
176 : !
177 : ! Iteration loop. Each time, the length of the ordered subsets
178 : ! is doubled.
179 : !
180 : Do
181 : If (LMTNA >= NVAL) Exit
182 : IWRKF = 0
183 : LMTNC = 2 * LMTNC
184 : !
185 : ! Loop on merges of A and B into C
186 : !
187 : Do
188 : IWRK = IWRKF
189 : IWRKD = IWRKF + 1
190 : JINDA = IWRKF + LMTNA
191 : IWRKF = IWRKF + LMTNC
192 : If (IWRKF >= NVAL) Then
193 : If (JINDA >= NVAL) Exit
194 : IWRKF = NVAL
195 : End If
196 : IINDA = 1
197 : IINDB = JINDA + 1
198 : !
199 : ! Shortcut for the case when the max of A is smaller
200 : ! than the min of B. This line may be activated when the
201 : ! initial set is already close to sorted.
202 : !
203 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
204 : !
205 : ! One steps in the C subset, that we build in the final rank array
206 : !
207 : ! Make a copy of the rank array for the merge iteration
208 : !
209 : JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
210 : !
211 : XVALA = XDONT (JWRKT(IINDA))
212 : XVALB = XDONT (IRNGT(IINDB))
213 : !
214 : Do
215 : IWRK = IWRK + 1
216 : !
217 : ! We still have unprocessed values in both A and B
218 : !
219 : If (XVALA > XVALB) Then
220 : IRNGT (IWRK) = IRNGT (IINDB)
221 : IINDB = IINDB + 1
222 : If (IINDB > IWRKF) Then
223 : ! Only A still with unprocessed values
224 : IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
225 : Exit
226 : End If
227 : XVALB = XDONT (IRNGT(IINDB))
228 : Else
229 : IRNGT (IWRK) = JWRKT (IINDA)
230 : IINDA = IINDA + 1
231 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
232 : XVALA = XDONT (JWRKT(IINDA))
233 : End If
234 : !
235 : End Do
236 : End Do
237 : !
238 : ! The Cs become As and Bs
239 : !
240 : LMTNA = 2 * LMTNA
241 : End Do
242 : !
243 : Return
244 : !
245 : End Subroutine D_mrgrnk
246 :
247 0 : Subroutine R_mrgrnk (XDONT, IRNGT)
248 : ! __________________________________________________________
249 : ! MRGRNK = Merge-sort ranking of an array
250 : ! For performance reasons, the first 2 passes are taken
251 : ! out of the standard loop, and use dedicated coding.
252 : ! __________________________________________________________
253 : ! _________________________________________________________
254 : Real(wp), Dimension (:), Intent (In) :: XDONT
255 : Integer, Dimension (:), Intent (Out) :: IRNGT
256 : ! __________________________________________________________
257 : Real(wp) :: XVALA, XVALB
258 : !
259 0 : Integer, Dimension (SIZE(IRNGT)) :: JWRKT
260 : Integer :: LMTNA, LMTNC, IRNG1, IRNG2
261 : Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
262 : !
263 0 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
264 : Select Case (NVAL)
265 : Case (:0)
266 0 : Return
267 : Case (1)
268 0 : IRNGT (1) = 1
269 0 : Return
270 : Case Default
271 0 : Continue
272 : End Select
273 : !
274 : ! Fill-in the index array, creating ordered couples
275 : !
276 0 : Do IIND = 2, NVAL, 2
277 0 : If (XDONT(IIND-1) <= XDONT(IIND)) Then
278 0 : IRNGT (IIND-1) = IIND - 1
279 0 : IRNGT (IIND) = IIND
280 : Else
281 0 : IRNGT (IIND-1) = IIND
282 0 : IRNGT (IIND) = IIND - 1
283 : End If
284 : End Do
285 0 : If (Modulo(NVAL, 2) /= 0) Then
286 0 : IRNGT (NVAL) = NVAL
287 : End If
288 : !
289 : ! We will now have ordered subsets A - B - A - B - ...
290 : ! and merge A and B couples into C - C - ...
291 : !
292 0 : LMTNA = 2
293 0 : LMTNC = 4
294 : !
295 : ! First iteration. The length of the ordered subsets goes from 2 to 4
296 : !
297 : Do
298 0 : If (NVAL <= 2) Exit
299 : !
300 : ! Loop on merges of A and B into C
301 : !
302 0 : Do IWRKD = 0, NVAL - 1, 4
303 0 : If ((IWRKD+4) > NVAL) Then
304 0 : If ((IWRKD+2) >= NVAL) Exit
305 : !
306 : ! 1 2 3
307 : !
308 0 : If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
309 : !
310 : ! 1 3 2
311 : !
312 0 : If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
313 0 : IRNG2 = IRNGT (IWRKD+2)
314 0 : IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
315 0 : IRNGT (IWRKD+3) = IRNG2
316 : !
317 : ! 3 1 2
318 : !
319 : Else
320 0 : IRNG1 = IRNGT (IWRKD+1)
321 0 : IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
322 0 : IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
323 0 : IRNGT (IWRKD+2) = IRNG1
324 : End If
325 : Exit
326 : End If
327 : !
328 : ! 1 2 3 4
329 : !
330 0 : If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
331 : !
332 : ! 1 3 x x
333 : !
334 0 : If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
335 0 : IRNG2 = IRNGT (IWRKD+2)
336 0 : IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
337 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
338 : ! 1 3 2 4
339 0 : IRNGT (IWRKD+3) = IRNG2
340 : Else
341 : ! 1 3 4 2
342 0 : IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
343 0 : IRNGT (IWRKD+4) = IRNG2
344 : End If
345 : !
346 : ! 3 x x x
347 : !
348 : Else
349 0 : IRNG1 = IRNGT (IWRKD+1)
350 0 : IRNG2 = IRNGT (IWRKD+2)
351 0 : IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
352 0 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
353 0 : IRNGT (IWRKD+2) = IRNG1
354 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
355 : ! 3 1 2 4
356 0 : IRNGT (IWRKD+3) = IRNG2
357 : Else
358 : ! 3 1 4 2
359 0 : IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
360 0 : IRNGT (IWRKD+4) = IRNG2
361 : End If
362 : Else
363 : ! 3 4 1 2
364 0 : IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
365 0 : IRNGT (IWRKD+3) = IRNG1
366 0 : IRNGT (IWRKD+4) = IRNG2
367 : End If
368 : End If
369 : End Do
370 : !
371 : ! The Cs become As and Bs
372 : !
373 : LMTNA = 4
374 0 : Exit
375 : End Do
376 : !
377 : ! Iteration loop. Each time, the length of the ordered subsets
378 : ! is doubled.
379 : !
380 0 : Do
381 0 : If (LMTNA >= NVAL) Exit
382 0 : IWRKF = 0
383 0 : LMTNC = 2 * LMTNC
384 : !
385 : ! Loop on merges of A and B into C
386 : !
387 : Do
388 0 : IWRK = IWRKF
389 0 : IWRKD = IWRKF + 1
390 0 : JINDA = IWRKF + LMTNA
391 0 : IWRKF = IWRKF + LMTNC
392 0 : If (IWRKF >= NVAL) Then
393 0 : If (JINDA >= NVAL) Exit
394 : IWRKF = NVAL
395 : End If
396 0 : IINDA = 1
397 0 : IINDB = JINDA + 1
398 : !
399 : ! Shortcut for the case when the max of A is smaller
400 : ! than the min of B. This line may be activated when the
401 : ! initial set is already close to sorted.
402 : !
403 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
404 : !
405 : ! One steps in the C subset, that we build in the final rank array
406 : !
407 : ! Make a copy of the rank array for the merge iteration
408 : !
409 0 : JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
410 : !
411 0 : XVALA = XDONT (JWRKT(IINDA))
412 0 : XVALB = XDONT (IRNGT(IINDB))
413 : !
414 0 : Do
415 0 : IWRK = IWRK + 1
416 : !
417 : ! We still have unprocessed values in both A and B
418 : !
419 0 : If (XVALA > XVALB) Then
420 0 : IRNGT (IWRK) = IRNGT (IINDB)
421 0 : IINDB = IINDB + 1
422 0 : If (IINDB > IWRKF) Then
423 : ! Only A still with unprocessed values
424 0 : IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
425 : Exit
426 : End If
427 0 : XVALB = XDONT (IRNGT(IINDB))
428 : Else
429 0 : IRNGT (IWRK) = JWRKT (IINDA)
430 0 : IINDA = IINDA + 1
431 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
432 0 : XVALA = XDONT (JWRKT(IINDA))
433 : End If
434 : !
435 : End Do
436 : End Do
437 : !
438 : ! The Cs become As and Bs
439 : !
440 0 : LMTNA = 2 * LMTNA
441 : End Do
442 : !
443 : Return
444 : !
445 : End Subroutine R_mrgrnk
446 0 : Subroutine I_mrgrnk (XDONT, IRNGT)
447 : ! __________________________________________________________
448 : ! MRGRNK = Merge-sort ranking of an array
449 : ! For performance reasons, the first 2 passes are taken
450 : ! out of the standard loop, and use dedicated coding.
451 : ! __________________________________________________________
452 : ! __________________________________________________________
453 : Integer, Dimension (:), Intent (In) :: XDONT
454 : Integer, Dimension (:), Intent (Out) :: IRNGT
455 : ! __________________________________________________________
456 : Integer :: XVALA, XVALB
457 : !
458 0 : Integer, Dimension (SIZE(IRNGT)) :: JWRKT
459 : Integer :: LMTNA, LMTNC, IRNG1, IRNG2
460 : Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
461 : !
462 0 : NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
463 : Select Case (NVAL)
464 : Case (:0)
465 0 : Return
466 : Case (1)
467 0 : IRNGT (1) = 1
468 0 : Return
469 : Case Default
470 0 : Continue
471 : End Select
472 : !
473 : ! Fill-in the index array, creating ordered couples
474 : !
475 0 : Do IIND = 2, NVAL, 2
476 0 : If (XDONT(IIND-1) <= XDONT(IIND)) Then
477 0 : IRNGT (IIND-1) = IIND - 1
478 0 : IRNGT (IIND) = IIND
479 : Else
480 0 : IRNGT (IIND-1) = IIND
481 0 : IRNGT (IIND) = IIND - 1
482 : End If
483 : End Do
484 0 : If (Modulo(NVAL, 2) /= 0) Then
485 0 : IRNGT (NVAL) = NVAL
486 : End If
487 : !
488 : ! We will now have ordered subsets A - B - A - B - ...
489 : ! and merge A and B couples into C - C - ...
490 : !
491 0 : LMTNA = 2
492 0 : LMTNC = 4
493 : !
494 : ! First iteration. The length of the ordered subsets goes from 2 to 4
495 : !
496 : Do
497 0 : If (NVAL <= 2) Exit
498 : !
499 : ! Loop on merges of A and B into C
500 : !
501 0 : Do IWRKD = 0, NVAL - 1, 4
502 0 : If ((IWRKD+4) > NVAL) Then
503 0 : If ((IWRKD+2) >= NVAL) Exit
504 : !
505 : ! 1 2 3
506 : !
507 0 : If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
508 : !
509 : ! 1 3 2
510 : !
511 0 : If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
512 0 : IRNG2 = IRNGT (IWRKD+2)
513 0 : IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
514 0 : IRNGT (IWRKD+3) = IRNG2
515 : !
516 : ! 3 1 2
517 : !
518 : Else
519 0 : IRNG1 = IRNGT (IWRKD+1)
520 0 : IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
521 0 : IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
522 0 : IRNGT (IWRKD+2) = IRNG1
523 : End If
524 : Exit
525 : End If
526 : !
527 : ! 1 2 3 4
528 : !
529 0 : If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
530 : !
531 : ! 1 3 x x
532 : !
533 0 : If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
534 0 : IRNG2 = IRNGT (IWRKD+2)
535 0 : IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
536 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
537 : ! 1 3 2 4
538 0 : IRNGT (IWRKD+3) = IRNG2
539 : Else
540 : ! 1 3 4 2
541 0 : IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
542 0 : IRNGT (IWRKD+4) = IRNG2
543 : End If
544 : !
545 : ! 3 x x x
546 : !
547 : Else
548 0 : IRNG1 = IRNGT (IWRKD+1)
549 0 : IRNG2 = IRNGT (IWRKD+2)
550 0 : IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
551 0 : If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
552 0 : IRNGT (IWRKD+2) = IRNG1
553 0 : If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
554 : ! 3 1 2 4
555 0 : IRNGT (IWRKD+3) = IRNG2
556 : Else
557 : ! 3 1 4 2
558 0 : IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
559 0 : IRNGT (IWRKD+4) = IRNG2
560 : End If
561 : Else
562 : ! 3 4 1 2
563 0 : IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
564 0 : IRNGT (IWRKD+3) = IRNG1
565 0 : IRNGT (IWRKD+4) = IRNG2
566 : End If
567 : End If
568 : End Do
569 : !
570 : ! The Cs become As and Bs
571 : !
572 : LMTNA = 4
573 0 : Exit
574 : End Do
575 : !
576 : ! Iteration loop. Each time, the length of the ordered subsets
577 : ! is doubled.
578 : !
579 0 : Do
580 0 : If (LMTNA >= NVAL) Exit
581 0 : IWRKF = 0
582 0 : LMTNC = 2 * LMTNC
583 : !
584 : ! Loop on merges of A and B into C
585 : !
586 : Do
587 0 : IWRK = IWRKF
588 0 : IWRKD = IWRKF + 1
589 0 : JINDA = IWRKF + LMTNA
590 0 : IWRKF = IWRKF + LMTNC
591 0 : If (IWRKF >= NVAL) Then
592 0 : If (JINDA >= NVAL) Exit
593 : IWRKF = NVAL
594 : End If
595 0 : IINDA = 1
596 0 : IINDB = JINDA + 1
597 : !
598 : ! Shortcut for the case when the max of A is smaller
599 : ! than the min of B. This line may be activated when the
600 : ! initial set is already close to sorted.
601 : !
602 : ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
603 : !
604 : ! One steps in the C subset, that we build in the final rank array
605 : !
606 : ! Make a copy of the rank array for the merge iteration
607 : !
608 0 : JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
609 : !
610 0 : XVALA = XDONT (JWRKT(IINDA))
611 0 : XVALB = XDONT (IRNGT(IINDB))
612 : !
613 0 : Do
614 0 : IWRK = IWRK + 1
615 : !
616 : ! We still have unprocessed values in both A and B
617 : !
618 0 : If (XVALA > XVALB) Then
619 0 : IRNGT (IWRK) = IRNGT (IINDB)
620 0 : IINDB = IINDB + 1
621 0 : If (IINDB > IWRKF) Then
622 : ! Only A still with unprocessed values
623 0 : IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
624 : Exit
625 : End If
626 0 : XVALB = XDONT (IRNGT(IINDB))
627 : Else
628 0 : IRNGT (IWRK) = JWRKT (IINDA)
629 0 : IINDA = IINDA + 1
630 0 : If (IINDA > LMTNA) Exit! Only B still with unprocessed values
631 0 : XVALA = XDONT (JWRKT(IINDA))
632 : End If
633 : !
634 : End Do
635 : End Do
636 : !
637 : ! The Cs become As and Bs
638 : !
639 0 : LMTNA = 2 * LMTNA
640 : End Do
641 : !
642 : Return
643 : !
644 : End Subroutine I_mrgrnk
645 : end module m_mrgrnk
|
