source/unres/src_Eshel/SRC-SURPLUS/sort.f

   1 c
   2 c
   3 c     ###################################################
   4 c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
   5 c     ##              All Rights Reserved              ##
   6 c     ###################################################
   7 c
   8 c     #########################################################
   9 c     ##                                                     ##
  10 c     ##  subroutine sort  --  heapsort of an integer array  ##
  11 c     ##                                                     ##
  12 c     #########################################################
  13 c
  14 c
  15 c     "sort" takes an input list of integers and sorts it
  16 c     into ascending order using the Heapsort algorithm
  17 c
  18 c
  19       subroutine sort (n,list)
  20       implicit none
  21       integer i,j,k,n
  22       integer index,lists
  23       integer list(*)
  24 c
  25 c
  26 c     perform the heapsort of the input list
  27 c
  28       k = n/2 + 1
  29       index = n
  30       dowhile (n .gt. 1)
  31          if (k .gt. 1) then
  32             k = k - 1
  33             lists = list(k)
  34          else
  35             lists = list(index)
  36             list(index) = list(1)
  37             index = index - 1
  38             if (index .le. 1) then
  39                list(1) = lists
  40                return
  41             end if
  42          end if
  43          i = k
  44          j = k + k
  45          dowhile (j .le. index)
  46             if (j .lt. index) then
  47                if (list(j) .lt. list(j+1))  j = j + 1
  48             end if
  49             if (lists .lt. list(j)) then
  50                list(i) = list(j)
  51                i = j
  52                j = j + j
  53             else
  54                j = index + 1
  55             end if
  56          end do
  57          list(i) = lists
  58       end do
  59       return
  60       end
  61 c
  62 c
  63 c     ##############################################################
  64 c     ##                                                          ##
  65 c     ##  subroutine sort2  --  heapsort of real array with keys  ##
  66 c     ##                                                          ##
  67 c     ##############################################################
  68 c
  69 c
  70 c     "sort2" takes an input list of reals and sorts it
  71 c     into ascending order using the Heapsort algorithm;
  72 c     it also returns a key into the original ordering
  73 c
  74 c
  75       subroutine sort2 (n,list,key)
  76       implicit none
  77       integer i,j,k,n
  78       integer index,keys
  79       integer key(*)
  80       real*8 lists
  81       real*8 list(*)
  82 c
  83 c
  84 c     initialize index into the original ordering
  85 c
  86       do i = 1, n
  87          key(i) = i
  88       end do
  89 c
  90 c     perform the heapsort of the input list
  91 c
  92       k = n/2 + 1
  93       index = n
  94       dowhile (n .gt. 1)
  95          if (k .gt. 1) then
  96             k = k - 1
  97             lists = list(k)
  98             keys = key(k)
  99          else
 100             lists = list(index)
 101             keys = key(index)
 102             list(index) = list(1)
 103             key(index) = key(1)
 104             index = index - 1
 105             if (index .le. 1) then
 106                list(1) = lists
 107                key(1) = keys
 108                return
 109             end if
 110          end if
 111          i = k
 112          j = k + k
 113          dowhile (j .le. index)
 114             if (j .lt. index) then
 115                if (list(j) .lt. list(j+1))  j = j + 1
 116             end if
 117             if (lists .lt. list(j)) then
 118                list(i) = list(j)
 119                key(i) = key(j)
 120                i = j
 121                j = j + j
 122             else
 123                j = index + 1
 124             end if
 125          end do
 126          list(i) = lists
 127          key(i) = keys
 128       end do
 129       return
 130       end
 131 c
 132 c
 133 c     #################################################################
 134 c     ##                                                             ##
 135 c     ##  subroutine sort3  --  heapsort of integer array with keys  ##
 136 c     ##                                                             ##
 137 c     #################################################################
 138 c
 139 c
 140 c     "sort3" takes an input list of integers and sorts it
 141 c     into ascending order using the Heapsort algorithm;
 142 c     it also returns a key into the original ordering
 143 c
 144 c
 145       subroutine sort3 (n,list,key)
 146       implicit none
 147       integer i,j,k,n
 148       integer index
 149       integer lists
 150       integer keys
 151       integer list(*)
 152       integer key(*)
 153 c
 154 c
 155 c     initialize index into the original ordering
 156 c
 157       do i = 1, n
 158          key(i) = i
 159       end do
 160 c
 161 c     perform the heapsort of the input list
 162 c
 163       k = n/2 + 1
 164       index = n
 165       dowhile (n .gt. 1)
 166          if (k .gt. 1) then
 167             k = k - 1
 168             lists = list(k)
 169             keys = key(k)
 170          else
 171             lists = list(index)
 172             keys = key(index)
 173             list(index) = list(1)
 174             key(index) = key(1)
 175             index = index - 1
 176             if (index .le. 1) then
 177                list(1) = lists
 178                key(1) = keys
 179                return
 180             end if
 181          end if
 182          i = k
 183          j = k + k
 184          dowhile (j .le. index)
 185             if (j .lt. index) then
 186                if (list(j) .lt. list(j+1))  j = j + 1
 187             end if
 188             if (lists .lt. list(j)) then
 189                list(i) = list(j)
 190                key(i) = key(j)
 191                i = j
 192                j = j + j
 193             else
 194                j = index + 1
 195             end if
 196          end do
 197          list(i) = lists
 198          key(i) = keys
 199       end do
 200       return
 201       end
 202 c
 203 c
 204 c     #################################################################
 205 c     ##                                                             ##
 206 c     ##  subroutine sort4  --  heapsort of integer absolute values  ##
 207 c     ##                                                             ##
 208 c     #################################################################
 209 c
 210 c
 211 c     "sort4" takes an input list of integers and sorts it into
 212 c     ascending absolute value using the Heapsort algorithm
 213 c
 214 c
 215       subroutine sort4 (n,list)
 216       implicit none
 217       integer i,j,k,n
 218       integer index
 219       integer lists
 220       integer list(*)
 221 c
 222 c
 223 c     perform the heapsort of the input list
 224 c
 225       k = n/2 + 1
 226       index = n
 227       dowhile (n .gt. 1)
 228          if (k .gt. 1) then
 229             k = k - 1
 230             lists = list(k)
 231          else
 232             lists = list(index)
 233             list(index) = list(1)
 234             index = index - 1
 235             if (index .le. 1) then
 236                list(1) = lists
 237                return
 238             end if
 239          end if
 240          i = k
 241          j = k + k
 242          dowhile (j .le. index)
 243             if (j .lt. index) then
 244                if (abs(list(j)) .lt. abs(list(j+1)))  j = j + 1
 245             end if
 246             if (abs(lists) .lt. abs(list(j))) then
 247                list(i) = list(j)
 248                i = j
 249                j = j + j
 250             else
 251                j = index + 1
 252             end if
 253          end do
 254          list(i) = lists
 255       end do
 256       return
 257       end
 258 c
 259 c
 260 c     ################################################################
 261 c     ##                                                            ##
 262 c     ##  subroutine sort5  --  heapsort of integer array modulo m  ##
 263 c     ##                                                            ##
 264 c     ################################################################
 265 c
 266 c
 267 c     "sort5" takes an input list of integers and sorts it
 268 c     into ascending order based on each value modulo "m"
 269 c
 270 c
 271       subroutine sort5 (n,list,m)
 272       implicit none
 273       integer i,j,k,m,n
 274       integer index,smod
 275       integer jmod,j1mod
 276       integer lists
 277       integer list(*)
 278 c
 279 c
 280 c     perform the heapsort of the input list
 281 c
 282       k = n/2 + 1
 283       index = n
 284       dowhile (n .gt. 1)
 285          if (k .gt. 1) then
 286             k = k - 1
 287             lists = list(k)
 288          else
 289             lists = list(index)
 290             list(index) = list(1)
 291             index = index - 1
 292             if (index .le. 1) then
 293                list(1) = lists
 294                return
 295             end if
 296          end if
 297          i = k
 298          j = k + k
 299          dowhile (j .le. index)
 300             if (j .lt. index) then
 301                jmod = mod(list(j),m)
 302                j1mod = mod(list(j+1),m)
 303                if (jmod .lt. j1mod) then
 304                   j = j + 1
 305                else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then
 306                   j = j + 1
 307                end if
 308             end if
 309             smod = mod(lists,m)
 310             jmod = mod(list(j),m)
 311             if (smod .lt. jmod) then
 312                list(i) = list(j)
 313                i = j
 314                j = j + j
 315             else if (smod.eq.jmod .and. lists.lt.list(j)) then
 316                list(i) = list(j)
 317                i = j
 318                j = j + j
 319             else
 320                j = index + 1
 321             end if
 322          end do
 323          list(i) = lists
 324       end do
 325       return
 326       end
 327 c
 328 c
 329 c     #############################################################
 330 c     ##                                                         ##
 331 c     ##  subroutine sort6  --  heapsort of a text string array  ##
 332 c     ##                                                         ##
 333 c     #############################################################
 334 c
 335 c
 336 c     "sort6" takes an input list of character strings and sorts
 337 c     it into alphabetical order using the Heapsort algorithm
 338 c
 339 c
 340       subroutine sort6 (n,list)
 341       implicit none
 342       integer i,j,k,n
 343       integer index
 344       character*256 lists
 345       character*(*) list(*)
 346 c
 347 c
 348 c     perform the heapsort of the input list
 349 c
 350       k = n/2 + 1
 351       index = n
 352       dowhile (n .gt. 1)
 353          if (k .gt. 1) then
 354             k = k - 1
 355             lists = list(k)
 356          else
 357             lists = list(index)
 358             list(index) = list(1)
 359             index = index - 1
 360             if (index .le. 1) then
 361                list(1) = lists
 362                return
 363             end if
 364          end if
 365          i = k
 366          j = k + k
 367          dowhile (j .le. index)
 368             if (j .lt. index) then
 369                if (list(j) .lt. list(j+1))  j = j + 1
 370             end if
 371             if (lists .lt. list(j)) then
 372                list(i) = list(j)
 373                i = j
 374                j = j + j
 375             else
 376                j = index + 1
 377             end if
 378          end do
 379          list(i) = lists
 380       end do
 381       return
 382       end
 383 c
 384 c
 385 c     ################################################################
 386 c     ##                                                            ##
 387 c     ##  subroutine sort7  --  heapsort of text strings with keys  ##
 388 c     ##                                                            ##
 389 c     ################################################################
 390 c
 391 c
 392 c     "sort7" takes an input list of character strings and sorts it
 393 c     into alphabetical order using the Heapsort algorithm; it also
 394 c     returns a key into the original ordering
 395 c
 396 c
 397       subroutine sort7 (n,list,key)
 398       implicit none
 399       integer i,j,k,n
 400       integer index
 401       integer keys
 402       integer key(*)
 403       character*256 lists
 404       character*(*) list(*)
 405 c
 406 c
 407 c     initialize index into the original ordering
 408 c
 409       do i = 1, n
 410          key(i) = i
 411       end do
 412 c
 413 c     perform the heapsort of the input list
 414 c
 415       k = n/2 + 1
 416       index = n
 417       dowhile (n .gt. 1)
 418          if (k .gt. 1) then
 419             k = k - 1
 420             lists = list(k)
 421             keys = key(k)
 422          else
 423             lists = list(index)
 424             keys = key(index)
 425             list(index) = list(1)
 426             key(index) = key(1)
 427             index = index - 1
 428             if (index .le. 1) then
 429                list(1) = lists
 430                key(1) = keys
 431                return
 432             end if
 433          end if
 434          i = k
 435          j = k + k
 436          dowhile (j .le. index)
 437             if (j .lt. index) then
 438                if (list(j) .lt. list(j+1))  j = j + 1
 439             end if
 440             if (lists .lt. list(j)) then
 441                list(i) = list(j)
 442                key(i) = key(j)
 443                i = j
 444                j = j + j
 445             else
 446                j = index + 1
 447             end if
 448          end do
 449          list(i) = lists
 450          key(i) = keys
 451       end do
 452       return
 453       end
 454 c
 455 c
 456 c     #########################################################
 457 c     ##                                                     ##
 458 c     ##  subroutine sort8  --  heapsort to unique integers  ##
 459 c     ##                                                     ##
 460 c     #########################################################
 461 c
 462 c
 463 c     "sort8" takes an input list of integers and sorts it into
 464 c     ascending order using the Heapsort algorithm, duplicate
 465 c     values are removed from the final sorted list
 466 c
 467 c
 468       subroutine sort8 (n,list)
 469       implicit none
 470       integer i,j,k,n
 471       integer index
 472       integer lists
 473       integer list(*)
 474 c
 475 c
 476 c     perform the heapsort of the input list
 477 c
 478       k = n/2 + 1
 479       index = n
 480       dowhile (n .gt. 1)
 481          if (k .gt. 1) then
 482             k = k - 1
 483             lists = list(k)
 484          else
 485             lists = list(index)
 486             list(index) = list(1)
 487             index = index - 1
 488             if (index .le. 1) then
 489                list(1) = lists
 490 c
 491 c     remove duplicate values from final list
 492 c
 493                j = 1
 494                do i = 2, n
 495                   if (list(i-1) .ne. list(i)) then
 496                      j = j + 1
 497                      list(j) = list(i)
 498                   end if
 499                end do
 500                if (j .lt. n)  n = j
 501                return
 502             end if
 503          end if
 504          i = k
 505          j = k + k
 506          dowhile (j .le. index)
 507             if (j .lt. index) then
 508                if (list(j) .lt. list(j+1))  j = j + 1
 509             end if
 510             if (lists .lt. list(j)) then
 511                list(i) = list(j)
 512                i = j
 513                j = j + j
 514             else
 515                j = index + 1
 516             end if
 517          end do
 518          list(i) = lists
 519       end do
 520       return
 521       end
 522 c
 523 c
 524 c     #############################################################
 525 c     ##                                                         ##
 526 c     ##  subroutine sort9  --  heapsort to unique text strings  ##
 527 c     ##                                                         ##
 528 c     #############################################################
 529 c
 530 c
 531 c     "sort9" takes an input list of character strings and sorts
 532 c     it into alphabetical order using the Heapsort algorithm,
 533 c     duplicate values are removed from the final sorted list
 534 c
 535 c
 536       subroutine sort9 (n,list)
 537       implicit none
 538       integer i,j,k,n
 539       integer index
 540       character*256 lists
 541       character*(*) list(*)
 542 c
 543 c
 544 c     perform the heapsort of the input list
 545 c
 546       k = n/2 + 1
 547       index = n
 548       dowhile (n .gt. 1)
 549          if (k .gt. 1) then
 550             k = k - 1
 551             lists = list(k)
 552          else
 553             lists = list(index)
 554             list(index) = list(1)
 555             index = index - 1
 556             if (index .le. 1) then
 557                list(1) = lists
 558 c
 559 c     remove duplicate values from final list
 560 c
 561                j = 1
 562                do i = 2, n
 563                   if (list(i-1) .ne. list(i)) then
 564                      j = j + 1
 565                      list(j) = list(i)
 566                   end if
 567                end do
 568                if (j .lt. n)  n = j
 569                return
 570             end if
 571          end if
 572          i = k
 573          j = k + k
 574          dowhile (j .le. index)
 575             if (j .lt. index) then
 576                if (list(j) .lt. list(j+1))  j = j + 1
 577             end if
 578             if (lists .lt. list(j)) then
 579                list(i) = list(j)
 580                i = j
 581                j = j + j
 582             else
 583                j = index + 1
 584             end if
 585          end do
 586          list(i) = lists
 587       end do
 588       return
 589       end