5 Integer,
Parameter :: kdp = selected_real_kind(15)
8 private :: r_mrgrnk, i_mrgrnk, d_mrgrnk
10 module procedure d_mrgrnk, r_mrgrnk, i_mrgrnk
14 Subroutine d_mrgrnk (XDONT, IRNGT)
21 Real (kind=kdp),
Dimension (:),
Intent (In) :: xdont
22 Integer,
Dimension (:),
Intent (Out) :: IRNGT
24 Real (kind=kdp) :: xvala, xvalb
26 Integer,
Dimension (SIZE(IRNGT)) :: JWRKT
27 Integer :: LMTNA, LMTNC, IRNG1, IRNG2
28 Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
30 nval = min(
SIZE(xdont),
SIZE(irngt))
44 If (xdont(iind-1) <= xdont(iind))
Then
45 irngt(iind-1) = iind - 1
49 irngt(iind) = iind - 1
52 If (modulo(nval, 2) /= 0)
Then
69 Do iwrkd = 0, nval - 1, 4
70 If ((iwrkd+4) > nval)
Then
71 If ((iwrkd+2) >= nval)
Exit
75 If (xdont(irngt(iwrkd+2)) <= xdont(irngt(iwrkd+3)))
Exit
79 If (xdont(irngt(iwrkd+1)) <= xdont(irngt(iwrkd+3)))
Then
80 irng2 = irngt(iwrkd+2)
81 irngt(iwrkd+2) = irngt(iwrkd+3)
82 irngt(iwrkd+3) = irng2
87 irng1 = irngt(iwrkd+1)
88 irngt(iwrkd+1) = irngt(iwrkd+3)
89 irngt(iwrkd+3) = irngt(iwrkd+2)
90 irngt(iwrkd+2) = irng1
97 If (xdont(irngt(iwrkd+2)) <= xdont(irngt(iwrkd+3))) cycle
101 If (xdont(irngt(iwrkd+1)) <= xdont(irngt(iwrkd+3)))
Then
102 irng2 = irngt(iwrkd+2)
103 irngt(iwrkd+2) = irngt(iwrkd+3)
104 If (xdont(irng2) <= xdont(irngt(iwrkd+4)))
Then
106 irngt(iwrkd+3) = irng2
109 irngt(iwrkd+3) = irngt(iwrkd+4)
110 irngt(iwrkd+4) = irng2
116 irng1 = irngt(iwrkd+1)
117 irng2 = irngt(iwrkd+2)
118 irngt(iwrkd+1) = irngt(iwrkd+3)
119 If (xdont(irng1) <= xdont(irngt(iwrkd+4)))
Then
120 irngt(iwrkd+2) = irng1
121 If (xdont(irng2) <= xdont(irngt(iwrkd+4)))
Then
123 irngt(iwrkd+3) = irng2
126 irngt(iwrkd+3) = irngt(iwrkd+4)
127 irngt(iwrkd+4) = irng2
131 irngt(iwrkd+2) = irngt(iwrkd+4)
132 irngt(iwrkd+3) = irng1
133 irngt(iwrkd+4) = irng2
148 If (lmtna >= nval)
Exit
157 jinda = iwrkf + lmtna
158 iwrkf = iwrkf + lmtnc
159 If (iwrkf >= nval)
Then
160 If (jinda >= nval)
Exit
176 jwrkt(1:lmtna) = irngt(iwrkd:jinda)
178 xvala = xdont(jwrkt(iinda))
179 xvalb = xdont(irngt(iindb))
186 If (xvala > xvalb)
Then
187 irngt(iwrk) = irngt(iindb)
189 If (iindb > iwrkf)
Then
191 irngt(iwrk+1:iwrkf) = jwrkt(iinda:lmtna)
194 xvalb = xdont(irngt(iindb))
196 irngt(iwrk) = jwrkt(iinda)
198 If (iinda > lmtna) exit
199 xvala = xdont(jwrkt(iinda))
212 End Subroutine d_mrgrnk
214 Subroutine r_mrgrnk (XDONT, IRNGT)
221 Real,
Dimension (:),
Intent (In) :: XDONT
222 Integer,
Dimension (:),
Intent (Out) :: IRNGT
226 Integer,
Dimension (SIZE(IRNGT)) :: JWRKT
227 Integer :: LMTNA, LMTNC, IRNG1, IRNG2
228 Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
230 nval = min(
SIZE(xdont),
SIZE(irngt))
244 If (xdont(iind-1) <= xdont(iind))
Then
245 irngt(iind-1) = iind - 1
249 irngt(iind) = iind - 1
252 If (modulo(nval, 2) /= 0)
Then
269 Do iwrkd = 0, nval - 1, 4
270 If ((iwrkd+4) > nval)
Then
271 If ((iwrkd+2) >= nval)
Exit
275 If (xdont(irngt(iwrkd+2)) <= xdont(irngt(iwrkd+3)))
Exit
279 If (xdont(irngt(iwrkd+1)) <= xdont(irngt(iwrkd+3)))
Then
280 irng2 = irngt(iwrkd+2)
281 irngt(iwrkd+2) = irngt(iwrkd+3)
282 irngt(iwrkd+3) = irng2
287 irng1 = irngt(iwrkd+1)
288 irngt(iwrkd+1) = irngt(iwrkd+3)
289 irngt(iwrkd+3) = irngt(iwrkd+2)
290 irngt(iwrkd+2) = irng1
297 If (xdont(irngt(iwrkd+2)) <= xdont(irngt(iwrkd+3))) cycle
301 If (xdont(irngt(iwrkd+1)) <= xdont(irngt(iwrkd+3)))
Then
302 irng2 = irngt(iwrkd+2)
303 irngt(iwrkd+2) = irngt(iwrkd+3)
304 If (xdont(irng2) <= xdont(irngt(iwrkd+4)))
Then
306 irngt(iwrkd+3) = irng2
309 irngt(iwrkd+3) = irngt(iwrkd+4)
310 irngt(iwrkd+4) = irng2
316 irng1 = irngt(iwrkd+1)
317 irng2 = irngt(iwrkd+2)
318 irngt(iwrkd+1) = irngt(iwrkd+3)
319 If (xdont(irng1) <= xdont(irngt(iwrkd+4)))
Then
320 irngt(iwrkd+2) = irng1
321 If (xdont(irng2) <= xdont(irngt(iwrkd+4)))
Then
323 irngt(iwrkd+3) = irng2
326 irngt(iwrkd+3) = irngt(iwrkd+4)
327 irngt(iwrkd+4) = irng2
331 irngt(iwrkd+2) = irngt(iwrkd+4)
332 irngt(iwrkd+3) = irng1
333 irngt(iwrkd+4) = irng2
348 If (lmtna >= nval)
Exit
357 jinda = iwrkf + lmtna
358 iwrkf = iwrkf + lmtnc
359 If (iwrkf >= nval)
Then
360 If (jinda >= nval)
Exit
376 jwrkt(1:lmtna) = irngt(iwrkd:jinda)
378 xvala = xdont(jwrkt(iinda))
379 xvalb = xdont(irngt(iindb))
386 If (xvala > xvalb)
Then
387 irngt(iwrk) = irngt(iindb)
389 If (iindb > iwrkf)
Then
391 irngt(iwrk+1:iwrkf) = jwrkt(iinda:lmtna)
394 xvalb = xdont(irngt(iindb))
396 irngt(iwrk) = jwrkt(iinda)
398 If (iinda > lmtna) exit
399 xvala = xdont(jwrkt(iinda))
412 End Subroutine r_mrgrnk
413 Subroutine i_mrgrnk (XDONT, IRNGT)
420 Integer,
Dimension (:),
Intent (In) :: XDONT
421 Integer,
Dimension (:),
Intent (Out) :: IRNGT
423 Integer :: XVALA, XVALB
425 Integer,
Dimension (SIZE(IRNGT)) :: JWRKT
426 Integer :: LMTNA, LMTNC, IRNG1, IRNG2
427 Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
429 nval = min(
SIZE(xdont),
SIZE(irngt))
443 If (xdont(iind-1) <= xdont(iind))
Then
444 irngt(iind-1) = iind - 1
448 irngt(iind) = iind - 1
451 If (modulo(nval, 2) /= 0)
Then
468 Do iwrkd = 0, nval - 1, 4
469 If ((iwrkd+4) > nval)
Then
470 If ((iwrkd+2) >= nval)
Exit
474 If (xdont(irngt(iwrkd+2)) <= xdont(irngt(iwrkd+3)))
Exit
478 If (xdont(irngt(iwrkd+1)) <= xdont(irngt(iwrkd+3)))
Then
479 irng2 = irngt(iwrkd+2)
480 irngt(iwrkd+2) = irngt(iwrkd+3)
481 irngt(iwrkd+3) = irng2
486 irng1 = irngt(iwrkd+1)
487 irngt(iwrkd+1) = irngt(iwrkd+3)
488 irngt(iwrkd+3) = irngt(iwrkd+2)
489 irngt(iwrkd+2) = irng1
496 If (xdont(irngt(iwrkd+2)) <= xdont(irngt(iwrkd+3))) cycle
500 If (xdont(irngt(iwrkd+1)) <= xdont(irngt(iwrkd+3)))
Then
501 irng2 = irngt(iwrkd+2)
502 irngt(iwrkd+2) = irngt(iwrkd+3)
503 If (xdont(irng2) <= xdont(irngt(iwrkd+4)))
Then
505 irngt(iwrkd+3) = irng2
508 irngt(iwrkd+3) = irngt(iwrkd+4)
509 irngt(iwrkd+4) = irng2
515 irng1 = irngt(iwrkd+1)
516 irng2 = irngt(iwrkd+2)
517 irngt(iwrkd+1) = irngt(iwrkd+3)
518 If (xdont(irng1) <= xdont(irngt(iwrkd+4)))
Then
519 irngt(iwrkd+2) = irng1
520 If (xdont(irng2) <= xdont(irngt(iwrkd+4)))
Then
522 irngt(iwrkd+3) = irng2
525 irngt(iwrkd+3) = irngt(iwrkd+4)
526 irngt(iwrkd+4) = irng2
530 irngt(iwrkd+2) = irngt(iwrkd+4)
531 irngt(iwrkd+3) = irng1
532 irngt(iwrkd+4) = irng2
547 If (lmtna >= nval)
Exit
556 jinda = iwrkf + lmtna
557 iwrkf = iwrkf + lmtnc
558 If (iwrkf >= nval)
Then
559 If (jinda >= nval)
Exit
575 jwrkt(1:lmtna) = irngt(iwrkd:jinda)
577 xvala = xdont(jwrkt(iinda))
578 xvalb = xdont(irngt(iindb))
585 If (xvala > xvalb)
Then
586 irngt(iwrk) = irngt(iindb)
588 If (iindb > iwrkf)
Then
590 irngt(iwrk+1:iwrkf) = jwrkt(iinda:lmtna)
593 xvalb = xdont(irngt(iindb))
595 irngt(iwrk) = jwrkt(iinda)
597 If (iinda > lmtna) exit
598 xvala = xdont(jwrkt(iinda))
611 End Subroutine i_mrgrnk