├── .github └── workflows │ └── CI.yml ├── .gitignore ├── LICENSE ├── README.md ├── codecov.yml ├── ford.md ├── fpm.toml ├── media ├── logo.png └── logo.svg ├── src └── stringsort.f90 ├── stringsort.code-workspace └── tests ├── test.f90 └── test_natural.f90 /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push] 3 | jobs: 4 | 5 | Build: 6 | runs-on: ${{ matrix.os }} 7 | permissions: 8 | contents: write 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: [ubuntu-latest] 13 | gcc_v: [14] # Version of GFortran we want to use. 14 | python-version: [3.12] 15 | env: 16 | FC: gfortran-${{ matrix.gcc_v }} 17 | GCC_V: ${{ matrix.gcc_v }} 18 | 19 | steps: 20 | - name: Checkout code 21 | uses: actions/checkout@v3 22 | with: 23 | submodules: recursive 24 | 25 | - name: Install Python 26 | uses: actions/setup-python@v4 # Use pip to install latest CMake, & FORD/Jin2For, etc. 27 | with: 28 | python-version: ${{ matrix.python-version }} 29 | 30 | - name: Setup Graphviz 31 | uses: ts-graphviz/setup-graphviz@v1 32 | 33 | - name: Setup Fortran Package Manager 34 | uses: fortran-lang/setup-fpm@v7 35 | with: 36 | github-token: ${{ secrets.GITHUB_TOKEN }} 37 | 38 | - name: Install Python dependencies 39 | if: contains( matrix.os, 'ubuntu') 40 | run: | 41 | python -m pip install --upgrade pip 42 | pip install ford numpy matplotlib 43 | if [ -f requirements.txt ]; then pip install -r requirements.txt; fi 44 | 45 | - name: Install GFortran Linux 46 | if: contains( matrix.os, 'ubuntu') 47 | run: | 48 | sudo apt-get install lcov 49 | sudo add-apt-repository ppa:ubuntu-toolchain-r/test 50 | sudo apt-get update 51 | sudo apt-get install -y gcc-${{ matrix.gcc_v }} gfortran-${{ matrix.gcc_v }} 52 | sudo update-alternatives \ 53 | --install /usr/bin/gcc gcc /usr/bin/gcc-${{ matrix.gcc_v }} 100 \ 54 | --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${{ matrix.gcc_v }} \ 55 | --slave /usr/bin/gcov gcov /usr/bin/gcov-${{ matrix.gcc_v }} 56 | 57 | # - name: Compile 58 | # run: fpm build --profile release 59 | 60 | - name: Run tests 61 | run: fpm test --profile debug --flag -coverage 62 | 63 | - name: Create coverage report 64 | run: | 65 | mkdir -p ${{ env.COV_DIR }} 66 | mv ./build/gfortran_*/*/* ${{ env.COV_DIR }} 67 | lcov --capture --initial --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.base 68 | lcov --capture --base-directory . --directory ${{ env.COV_DIR }} --output-file ${{ env.COV_DIR }}/coverage.capture 69 | lcov --add-tracefile ${{ env.COV_DIR }}/coverage.base --add-tracefile ${{ env.COV_DIR }}/coverage.capture --output-file ${{ env.COV_DIR }}/coverage.info 70 | env: 71 | COV_DIR: build/coverage 72 | 73 | - name: Upload coverage report 74 | uses: codecov/codecov-action@v5.4.2 75 | with: 76 | files: build/coverage/coverage.info 77 | 78 | - name: Build documentation 79 | run: ford ./ford.md 80 | 81 | - name: Deploy Documentation 82 | if: github.ref == 'refs/heads/master' 83 | uses: JamesIves/github-pages-deploy-action@v4.7.3 84 | with: 85 | branch: gh-pages # The branch the action should deploy to. 86 | folder: doc # The folder the action should deploy. 87 | single-commit: true 88 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Compiled Object files 2 | *.slo 3 | *.lo 4 | *.o 5 | *.obj 6 | 7 | # Precompiled Headers 8 | *.gch 9 | *.pch 10 | 11 | # Compiled Dynamic libraries 12 | *.so 13 | *.dylib 14 | *.dll 15 | 16 | # Fortran module files 17 | *.mod 18 | 19 | # Compiled Static libraries 20 | *.lai 21 | *.la 22 | *.a 23 | *.lib 24 | 25 | # Executables 26 | *.exe 27 | *.out 28 | *.app 29 | 30 | # Directories 31 | /build 32 | /doc 33 | /lib 34 | /bin 35 | 36 | # Misc 37 | .DS_Store -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | stringsort 2 | https://github.com/jacobwilliams/stringsort 3 | 4 | Copyright (c) 2016-2021, Jacob Williams 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, this 14 | list of conditions and the following disclaimer in the documentation and/or 15 | other materials provided with the distribution. 16 | 17 | * The names of its contributors may not be used to endorse or promote products 18 | derived from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 21 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 25 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 26 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 27 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | -------------------------------------------------------------------------------- 32 | LAPACK license 33 | http://www.netlib.org/lapack/LICENSE.txt 34 | -------------------------------------------------------------------------------- 35 | 36 | Copyright (c) 1992-2013 The University of Tennessee and The University 37 | of Tennessee Research Foundation. All rights 38 | reserved. 39 | Copyright (c) 2000-2013 The University of California Berkeley. All 40 | rights reserved. 41 | Copyright (c) 2006-2013 The University of Colorado Denver. All rights 42 | reserved. 43 | 44 | $COPYRIGHT$ 45 | 46 | Additional copyrights may follow 47 | 48 | $HEADER$ 49 | 50 | Redistribution and use in source and binary forms, with or without 51 | modification, are permitted provided that the following conditions are 52 | met: 53 | 54 | - Redistributions of source code must retain the above copyright 55 | notice, this list of conditions and the following disclaimer. 56 | 57 | - Redistributions in binary form must reproduce the above copyright 58 | notice, this list of conditions and the following disclaimer listed 59 | in this license in the documentation and/or other materials 60 | provided with the distribution. 61 | 62 | - Neither the name of the copyright holders nor the names of its 63 | contributors may be used to endorse or promote products derived from 64 | this software without specific prior written permission. 65 | 66 | The copyright holders provide no reassurances that the source code 67 | provided does not infringe any patent, copyright, or any other 68 | intellectual property rights of third parties. The copyright holders 69 | disclaim any liability to any recipient for claims brought against 70 | recipient by any third party for infringement of that parties 71 | intellectual property rights. 72 | 73 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 74 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 75 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 76 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 77 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 78 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 79 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 80 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 81 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 82 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 83 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 84 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![stringsort](media/logo.png) 2 | ============ 3 | 4 | [![CI Status](https://github.com/jacobwilliams/stringsort/actions/workflows/CI.yml/badge.svg)](https://github.com/jacobwilliams/stringsort/actions) 5 | [![GitHub release](https://img.shields.io/github/release/jacobwilliams/stringsort.svg?style=plastic)](https://github.com/jacobwilliams/stringsort/releases/latest) 6 | [![codecov](https://codecov.io/gh/jacobwilliams/stringsort/branch/master/graph/badge.svg?token=43HK33CSMY)](https://codecov.io/gh/jacobwilliams/stringsort) 7 | 8 | ### Description 9 | 10 | Just some Fortran sorting routines for strings. 11 | 12 | ### Building 13 | 14 | Stringsort and the test programs will build with any modern Fortran compiler. A [Fortran Package Manager](https://github.com/fortran-lang/fpm) manifest file (`fpm.toml`) is included, so that the library and tests cases can be compiled with FPM. For example: 15 | 16 | ``` 17 | fpm build --profile release 18 | fpm test --profile release 19 | ``` 20 | 21 | To use `stringsort` within your fpm project, add the following to your `fpm.toml` file: 22 | ```toml 23 | [dependencies] 24 | stringsort = { git="https://github.com/jacobwilliams/stringsort.git" } 25 | ``` 26 | 27 | To generate the documentation using [ford](https://github.com/Fortran-FOSS-Programmers/ford), run: 28 | 29 | ``` 30 | ford ford.md 31 | ``` 32 | 33 | ### Documentation 34 | 35 | The API documentation for the current ```master``` branch can be found [here](https://jacobwilliams.github.io/stringsort/). This is generated by processing the source files with [FORD](https://github.com/Fortran-FOSS-Programmers/ford). 36 | 37 | ### License 38 | 39 | This code and related files and documentation are distributed under a permissive free software [license](https://github.com/jacobwilliams/stringsort/blob/master/LICENSE) (BSD-style). 40 | 41 | ### See also 42 | 43 | * [Natural Sorting](https://degenerateconic.com/natural-sorting.html) [degenerateconic.com] -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: 2 | layout: header, changes, diff, sunburst 3 | coverage: 4 | ignore: 5 | - test 6 | - doc 7 | status: 8 | patch: 9 | default: 10 | target: 70% 11 | project: 12 | default: 13 | target: 60% 14 | -------------------------------------------------------------------------------- /ford.md: -------------------------------------------------------------------------------- 1 | project: stringsort 2 | src_dir: ./src 3 | output_dir: ./doc 4 | media_dir: ./media 5 | project_github: https://github.com/jacobwilliams/stringsort 6 | summary: String Sorting Routines 7 | author: Jacob Williams 8 | github: https://github.com/jacobwilliams 9 | predocmark_alt: > 10 | predocmark: < 11 | docmark_alt: 12 | docmark: ! 13 | display: public 14 | source: true 15 | graph: false 16 | exclude_dir: ./tests 17 | exclude: test.f90 18 | test_natural.f90 19 | iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html 20 | 21 | {!README.md!} 22 | 23 | -------------------------------------------------------------------------------- /fpm.toml: -------------------------------------------------------------------------------- 1 | name = "stringsort" 2 | author = "Jacob Williams" 3 | maintainer = "Jacob Williams" 4 | copyright = "Copyright (c) 2016-2021, Jacob Williams" 5 | license = "BSD-3" 6 | description = "Just some sorting routines for strings" 7 | homepage = "https://github.com/jacobwilliams/stringsort" 8 | 9 | [library] 10 | source-dir = "src" 11 | 12 | [install] 13 | library = true 14 | 15 | [build] 16 | auto-executables = false 17 | auto-examples = false 18 | auto-tests = false 19 | 20 | [[test]] 21 | name = "test_natural" 22 | source-dir = "tests" 23 | main = "test_natural.f90" 24 | 25 | [[test]] 26 | name = "test" 27 | source-dir = "tests" 28 | main = "test.f90" 29 | -------------------------------------------------------------------------------- /media/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jacobwilliams/stringsort/4b074d4930f6d7dcb402609085e7c301437d8699/media/logo.png -------------------------------------------------------------------------------- /media/logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 20 | 22 | 30 | 35 | 36 | 44 | 49 | 50 | 58 | 63 | 64 | 65 | 88 | 93 | 94 | 96 | 97 | 99 | image/svg+xml 100 | 102 | 103 | 104 | 105 | 106 | 111 | stringsort 122 | 127 | s 138 | 139 | 140 | -------------------------------------------------------------------------------- /src/stringsort.f90: -------------------------------------------------------------------------------- 1 | !***************************************************************************************** 2 | !> author: Jacob Williams 3 | ! license: BSD 4 | ! 5 | ! String sorting routines. 6 | 7 | module string_sort_module 8 | 9 | use iso_fortran_env, only: ip => INT32 ! integer precision 10 | 11 | implicit none 12 | 13 | private 14 | 15 | character(len=*),parameter :: lowercase_letters = 'abcdefghijklmnopqrstuvwxyz' 16 | character(len=*),parameter :: uppercase_letters = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 17 | integer,parameter :: max_size_for_insertion_sort = 20 !! max size for using insertion sort. 18 | 19 | type :: int_list 20 | 21 | !! For converting a string into a vector of integers, 22 | !! in order to perform "natural" sorting. 23 | !! 24 | !! Contiguous integer values are stored as an integer. 25 | !! Characters are stored as their ASCII value. 26 | !! 27 | !!### Example 28 | !! * 'A123b' (case insensitive) => [97,123,98] 29 | !! * 'A123b' (case sensitive) => [65,123,98] 30 | 31 | private 32 | 33 | integer :: length = 0 !! number of chunks 34 | integer(ip),dimension(:),allocatable :: chunk !! the integer values 35 | logical,dimension(:),allocatable :: chunk_is_int 36 | !! if the corresponding entry in `chunk` represents an integer 37 | !! from the string. Otherwise, it is the ASCII value for a single 38 | !! character. 39 | contains 40 | private 41 | generic,public :: operator(<) => ints_lt 42 | procedure :: ints_lt 43 | end type int_list 44 | 45 | interface swap 46 | module procedure :: swap_chars 47 | module procedure :: swap_ints 48 | end interface 49 | 50 | public :: lexical_sort_recursive 51 | public :: lexical_sort_nonrecursive 52 | public :: lexical_sort_natural_recursive 53 | public :: list_is_sorted 54 | 55 | contains 56 | !***************************************************************************************** 57 | 58 | !***************************************************************************************** 59 | !> 60 | ! Swap two integer values. 61 | 62 | pure elemental subroutine swap_ints(s1,s2) 63 | 64 | implicit none 65 | 66 | integer,intent(inout) :: s1 67 | integer,intent(inout) :: s2 68 | 69 | integer :: tmp 70 | 71 | tmp = s1 72 | s1 = s2 73 | s2 = tmp 74 | 75 | end subroutine swap_ints 76 | !***************************************************************************************** 77 | 78 | !***************************************************************************************** 79 | !> 80 | ! Converts a character string into an array of integers suitable for the 81 | ! "natural sorting" algorithm. 82 | ! 83 | !@warning If the integer is too large to fit in an integer(ip), 84 | ! then there will be problems. 85 | 86 | pure elemental subroutine string_to_int_list(str,case_sensitive,list) 87 | 88 | implicit none 89 | 90 | character(len=*),intent(in) :: str 91 | logical,intent(in) :: case_sensitive 92 | type(int_list),intent(out) :: list 93 | 94 | integer :: i !! counter 95 | integer :: n !! length of input str 96 | character(len=1) :: c !! temp character 97 | character(len=:),allocatable :: tmp !! for accumulating blocks of contiguous ints 98 | logical :: is_int !! if the current character is an integer 99 | logical :: accumulating_ints !! if a block of contiguous ints is 100 | !! being accumulated 101 | 102 | list%length = 0 ! actual length will be accumulated as we go 103 | n = len_trim(str) 104 | 105 | if (n>0) then 106 | 107 | allocate(list%chunk(n)) ! worst case: all single characters 108 | allocate(list%chunk_is_int(n)) 109 | list%chunk_is_int = .false. 110 | accumulating_ints = .false. 111 | tmp = '' 112 | 113 | do i=1,n ! loop through each character in the string 114 | 115 | c = str(i:i) 116 | is_int = character_is_integer(c) 117 | 118 | if ( is_int ) then ! is a number 119 | 120 | ! accumulate this character in the current int block 121 | accumulating_ints = .true. 122 | tmp = tmp//c 123 | 124 | else ! not a number 125 | 126 | if (accumulating_ints) then 127 | !finish off previous int block 128 | list%length = list%length + 1 129 | list%chunk(list%length) = string_to_integer(tmp) 130 | list%chunk_is_int(list%length) = .true. 131 | accumulating_ints = .false. 132 | tmp = '' 133 | end if 134 | 135 | !accumulate ascii value for current character: 136 | list%length = list%length + 1 137 | if (case_sensitive) then 138 | list%chunk(list%length) = ichar(c) 139 | else 140 | list%chunk(list%length) = ichar(lowercase_char(c)) 141 | end if 142 | 143 | end if 144 | 145 | end do 146 | 147 | if (accumulating_ints) then ! last int block 148 | list%length = list%length + 1 149 | list%chunk(list%length) = string_to_integer(tmp) 150 | list%chunk_is_int(list%length) = .true. 151 | end if 152 | 153 | else 154 | !empty string, just add one element so we can sort it: 155 | allocate(list%chunk(1)) 156 | list%chunk = 0 157 | list%length = 1 158 | end if 159 | 160 | !resize the array: 161 | list%chunk = list%chunk(1:list%length) ! Fortran 2008 LHS auto-reallocation 162 | 163 | end subroutine string_to_int_list 164 | !***************************************************************************************** 165 | 166 | !***************************************************************************************** 167 | !> 168 | ! Returns true if the i1 < i2 for two [[int_list]] variables. 169 | ! Each integer in each list is compared starting from the beginning. 170 | ! Returns true if the first non-matching i1%chunk(:) < i2%chunk(:). 171 | ! 172 | !@note Whether or not it is a case sensitive comparison was determined 173 | ! when the strings were converted to [[int_list]] arrays. 174 | 175 | pure logical function ints_lt(i1,i2) 176 | 177 | implicit none 178 | 179 | class(int_list),intent(in) :: i1 180 | class(int_list),intent(in) :: i2 181 | 182 | integer :: i !! counter 183 | 184 | integer,parameter :: ascii_zero = ichar('0') 185 | 186 | ints_lt = .false. 187 | 188 | do i = 1, min(i1%length, i2%length) 189 | 190 | if ((i1%chunk_is_int(i) .and. i2%chunk_is_int(i)) .or. & 191 | (.not. i1%chunk_is_int(i) .and. .not. i2%chunk_is_int(i)) ) then 192 | !both integers or both characters 193 | if (i1%chunk(i)/=i2%chunk(i)) then 194 | ints_lt = i1%chunk(i) < i2%chunk(i) 195 | return 196 | end if 197 | else 198 | !for [integer,character] comparisons, the actual 199 | !integer value doesn't matter, so we compare to '0' 200 | if (i1%chunk_is_int(i)) then 201 | ints_lt = ascii_zero < i2%chunk(i) 202 | else 203 | ints_lt = i1%chunk(i) < ascii_zero 204 | end if 205 | return 206 | end if 207 | 208 | end do 209 | 210 | !special case where i2 begins with i1, but is longer 211 | ints_lt = (i1%length 218 | ! Convert a string to an integer. 219 | ! 220 | !@note Based on similar routine from `JSON-Fortran`. 221 | ! 222 | !@warning If the integer is too large to fit in an integer(ip), 223 | ! then there will be problems. 224 | 225 | pure elemental function string_to_integer(str) result(ival) 226 | 227 | implicit none 228 | 229 | character(len=*),intent(in) :: str 230 | integer(ip) :: ival 231 | 232 | integer :: ndigits_digits,ndigits,ierr 233 | 234 | ! Compute how many digits we need to read 235 | ndigits = 2*len_trim(str) 236 | ndigits_digits = floor(log10(real(ndigits))) + 1 237 | 238 | block 239 | character(len=ndigits_digits) :: digits_str ! large enough to hold ndigits string 240 | write(digits_str,'(I0)') ndigits 241 | read(str,'(I'//trim(digits_str)//')',iostat=ierr) ival 242 | if (ierr/=0) ival = huge(1_ip) ! for errors just return a large value 243 | end block 244 | 245 | end function string_to_integer 246 | !***************************************************************************************** 247 | 248 | !***************************************************************************************** 249 | !> 250 | ! Returns true if the character represents an integer ('0','1',...,'9'). 251 | 252 | pure elemental function character_is_integer(c) result(is_integer) 253 | 254 | implicit none 255 | 256 | character(len=1),intent(in) :: c 257 | logical :: is_integer 258 | 259 | is_integer = c>='0' .and. c<='9' 260 | 261 | end function character_is_integer 262 | !***************************************************************************************** 263 | 264 | !***************************************************************************************** 265 | !> 266 | ! Returns lowercase version of the string. 267 | 268 | pure elemental function lower(str) result(lcase) 269 | 270 | implicit none 271 | 272 | character(len=*),intent(in) :: str 273 | character(len=(len(str))) :: lcase 274 | 275 | integer :: i,n 276 | 277 | n = len_trim(str) 278 | 279 | if (n>0) then 280 | do concurrent (i=1:n) 281 | lcase(i:i) = lowercase_char(str(i:i)) 282 | end do 283 | else 284 | lcase = '' 285 | end if 286 | 287 | end function lower 288 | !***************************************************************************************** 289 | 290 | !***************************************************************************************** 291 | !> 292 | ! Returns lowercase version of the character. 293 | 294 | pure elemental function lowercase_char(c) result(lcase) 295 | 296 | implicit none 297 | 298 | character(len=1),intent(in) :: c 299 | character(len=1) :: lcase 300 | 301 | integer :: j 302 | 303 | j = index( uppercase_letters,c ) 304 | 305 | if (j>0) then 306 | lcase = lowercase_letters(j:j) 307 | else 308 | lcase = c 309 | end if 310 | 311 | end function lowercase_char 312 | !***************************************************************************************** 313 | 314 | !***************************************************************************************** 315 | !> 316 | ! Returns true if the s1 < s2 in a lexical sense (can be case sensitive). 317 | 318 | pure logical function lexical_lt(s1,s2,case_sensitive) 319 | 320 | implicit none 321 | 322 | character(len=*),intent(in) :: s1 323 | character(len=*),intent(in) :: s2 324 | logical,intent(in) :: case_sensitive 325 | 326 | integer :: i !! counter 327 | character(len=1) :: c1 !! character from s1 328 | character(len=1) :: c2 !! character from s2 329 | 330 | lexical_lt = .false. 331 | 332 | do i = 1, min(len(s1), len(s2)) 333 | if (case_sensitive) then 334 | c1 = s1(i:i) 335 | c2 = s2(i:i) 336 | else 337 | c1 = lower(s1(i:i)) 338 | c2 = lower(s2(i:i)) 339 | end if 340 | if (c1/=c2) then 341 | lexical_lt = c1 < c2 342 | return 343 | end if 344 | end do 345 | 346 | !special case where s2 begins with s1, but is longer 347 | lexical_lt = (len(s1) 354 | ! Returns true if the s1 > s2 in a lexical sense (can be case sensitive). 355 | 356 | pure logical function lexical_gt(s1,s2,case_sensitive) 357 | 358 | implicit none 359 | 360 | character(len=*),intent(in) :: s1 361 | character(len=*),intent(in) :: s2 362 | logical,intent(in) :: case_sensitive 363 | 364 | integer :: i !! counter 365 | character(len=1) :: c1 !! character from s1 366 | character(len=1) :: c2 !! character from s2 367 | 368 | lexical_gt = .false. 369 | 370 | do i = 1, min(len(s1), len(s2)) 371 | if (case_sensitive) then 372 | c1 = s1(i:i) 373 | c2 = s2(i:i) 374 | else 375 | c1 = lower(s1(i:i)) 376 | c2 = lower(s2(i:i)) 377 | end if 378 | if (c1/=c2) then 379 | lexical_gt = c1 > c2 380 | return 381 | end if 382 | end do 383 | 384 | !special case where s2 begins with s1, but is longer 385 | lexical_gt = (len(s1)>len(s2)) 386 | 387 | end function lexical_gt 388 | !***************************************************************************************** 389 | 390 | !***************************************************************************************** 391 | !> 392 | ! Returns true if the s1 == s2 in a lexical sense (can be case sensitive). 393 | 394 | pure logical function lexical_eq(s1,s2,case_sensitive) 395 | 396 | implicit none 397 | 398 | character(len=*),intent(in) :: s1 399 | character(len=*),intent(in) :: s2 400 | logical,intent(in) :: case_sensitive 401 | 402 | if (case_sensitive) then 403 | lexical_eq = s1 == s2 404 | else 405 | lexical_eq = lower(s1) == lower(s2) 406 | end if 407 | 408 | end function lexical_eq 409 | !***************************************************************************************** 410 | 411 | !***************************************************************************************** 412 | !> 413 | ! Returns true if the s1 <= s2 in a lexical sense (can be case sensitive). 414 | 415 | pure logical function lexical_le(s1,s2,case_sensitive) 416 | 417 | implicit none 418 | 419 | character(len=*),intent(in) :: s1 420 | character(len=*),intent(in) :: s2 421 | logical,intent(in) :: case_sensitive 422 | 423 | lexical_le = lexical_lt(s1,s2,case_sensitive) .or. & 424 | lexical_eq(s1,s2,case_sensitive) 425 | 426 | end function lexical_le 427 | !***************************************************************************************** 428 | 429 | !***************************************************************************************** 430 | !> 431 | ! Returns true if the s1 >= s2 in a lexical sense (can be case sensitive). 432 | 433 | pure logical function lexical_ge(s1,s2,case_sensitive) 434 | 435 | implicit none 436 | 437 | character(len=*),intent(in) :: s1 438 | character(len=*),intent(in) :: s2 439 | logical,intent(in) :: case_sensitive 440 | 441 | lexical_ge = lexical_gt(s1,s2,case_sensitive) .or. & 442 | lexical_eq(s1,s2,case_sensitive) 443 | 444 | end function lexical_ge 445 | !***************************************************************************************** 446 | 447 | !***************************************************************************************** 448 | !> 449 | ! Swap two character strings. 450 | 451 | pure elemental subroutine swap_chars(s1,s2) 452 | 453 | implicit none 454 | 455 | character(len=*),intent(inout) :: s1 456 | character(len=*),intent(inout) :: s2 457 | 458 | character(len=len(s1)) :: tmp 459 | 460 | tmp = s1 461 | s1 = s2 462 | s2 = tmp 463 | 464 | end subroutine swap_chars 465 | !***************************************************************************************** 466 | 467 | !***************************************************************************************** 468 | !> 469 | ! Sorts a character array `str` in increasing order. 470 | ! 471 | ! Uses a non-recursive quicksort, reverting to insertion sort on arrays of 472 | ! size \(\le 20\). Dimension of `stack` limits array size to about \(2^{32}\). 473 | ! 474 | !### License 475 | ! * [Original LAPACK license](http://www.netlib.org/lapack/LICENSE.txt) 476 | ! 477 | !### History 478 | ! * Based on the LAPACK routine [DLASRT](http://www.netlib.org/lapack/explore-html/df/ddf/dlasrt_8f.html). 479 | ! * Extensively modified by Jacob Williams,Feb. 2016. Converted to 480 | ! modern Fortran and removed the descending sort option. 481 | 482 | pure subroutine lexical_sort_nonrecursive(str,case_sensitive) 483 | 484 | implicit none 485 | 486 | character(len=*),dimension(:),intent(inout) :: str !! on entry,the array to be sorted. 487 | !! on exit,`str` has been sorted into 488 | !! increasing order (`str(1) <= ... <= str(n)`) 489 | logical,intent(in) :: case_sensitive !! if true, the sort is case sensitive 490 | 491 | integer :: endd,i,j,n,start,stkpnt 492 | character(len=len(str)) :: d1,d2,d3,dmnmx,tmp 493 | integer,dimension(2,32) :: stack 494 | 495 | ! number of elements to sort: 496 | n = size(str) 497 | 498 | if ( n>1 ) then 499 | 500 | stkpnt = 1 501 | stack(1,1) = 1 502 | stack(2,1) = n 503 | 504 | do 505 | 506 | start = stack(1,stkpnt) 507 | endd = stack(2,stkpnt) 508 | stkpnt = stkpnt - 1 509 | if ( endd-start<=max_size_for_insertion_sort .and. endd>start ) then 510 | 511 | ! do insertion sort on str( start:endd ) 512 | insertion: do i = start + 1,endd 513 | do j = i,start + 1,-1 514 | if ( lexical_lt(str(j),str(j-1),case_sensitive) ) then 515 | dmnmx = str(j) 516 | str(j) = str(j-1) 517 | str(j-1) = dmnmx 518 | else 519 | exit 520 | end if 521 | end do 522 | end do insertion 523 | 524 | elseif ( endd-start>max_size_for_insertion_sort ) then 525 | 526 | ! partition str( start:endd ) and stack parts,largest one first 527 | ! choose partition entry as median of 3 528 | 529 | d1 = str(start) 530 | d2 = str(endd) 531 | i =(start+endd)/2 532 | d3 = str(i) 533 | if ( lexical_lt(d1,d2,case_sensitive) ) then 534 | if ( lexical_lt(d3,d1,case_sensitive) ) then 535 | dmnmx = d1 536 | elseif ( lexical_lt(d3,d2,case_sensitive) ) then 537 | dmnmx = d3 538 | else 539 | dmnmx = d2 540 | endif 541 | elseif ( lexical_lt(d3,d2,case_sensitive) ) then 542 | dmnmx = d2 543 | elseif ( lexical_lt(d3,d1,case_sensitive) ) then 544 | dmnmx = d3 545 | else 546 | dmnmx = d1 547 | endif 548 | 549 | i = start - 1 550 | j = endd + 1 551 | do 552 | do 553 | j = j - 1 554 | if ( lexical_le(str(j),dmnmx,case_sensitive) ) exit 555 | end do 556 | do 557 | i = i + 1 558 | if ( lexical_ge(str(i),dmnmx,case_sensitive) ) exit 559 | end do 560 | if ( iendd-j-1 ) then 569 | stkpnt = stkpnt + 1 570 | stack(1,stkpnt) = start 571 | stack(2,stkpnt) = j 572 | stkpnt = stkpnt + 1 573 | stack(1,stkpnt) = j + 1 574 | stack(2,stkpnt) = endd 575 | else 576 | stkpnt = stkpnt + 1 577 | stack(1,stkpnt) = j + 1 578 | stack(2,stkpnt) = endd 579 | stkpnt = stkpnt + 1 580 | stack(1,stkpnt) = start 581 | stack(2,stkpnt) = j 582 | endif 583 | 584 | endif 585 | 586 | if ( stkpnt<=0 ) exit 587 | 588 | end do 589 | 590 | end if 591 | 592 | end subroutine lexical_sort_nonrecursive 593 | !***************************************************************************************** 594 | 595 | !***************************************************************************************** 596 | !> 597 | ! Sorts a character array `str` in increasing order. 598 | ! Uses a basic recursive quicksort 599 | ! (with insertion sort for partitions with <= 20 elements). 600 | 601 | subroutine lexical_sort_recursive(str,case_sensitive) 602 | 603 | implicit none 604 | 605 | character(len=*),dimension(:),intent(inout) :: str 606 | logical,intent(in) :: case_sensitive !! if true, the sort is case sensitive 607 | 608 | call quicksort(1,size(str)) 609 | 610 | contains 611 | 612 | !*************************************************************** 613 | !> 614 | ! Sort the array, based on the lexical string comparison. 615 | 616 | recursive subroutine quicksort(ilow,ihigh) 617 | 618 | implicit none 619 | 620 | integer,intent(in) :: ilow 621 | integer,intent(in) :: ihigh 622 | 623 | integer :: ipivot !! pivot element 624 | integer :: i !! counter 625 | integer :: j !! counter 626 | 627 | if ( ihigh-ilow<=max_size_for_insertion_sort .and. ihigh>ilow ) then 628 | 629 | ! do insertion sort: 630 | do i = ilow + 1,ihigh 631 | do j = i,ilow + 1,-1 632 | if ( lexical_lt(str(j),str(j-1),case_sensitive) ) then 633 | call swap(str(j),str(j-1)) 634 | else 635 | exit 636 | end if 637 | end do 638 | end do 639 | 640 | elseif ( ihigh-ilow>max_size_for_insertion_sort ) then 641 | 642 | ! do the normal quicksort: 643 | call partition(ilow,ihigh,ipivot) 644 | call quicksort(ilow,ipivot - 1) 645 | call quicksort(ipivot + 1,ihigh) 646 | 647 | end if 648 | 649 | end subroutine quicksort 650 | 651 | !*************************************************************** 652 | !> 653 | ! Partition the array, based on the lexical string comparison. 654 | 655 | subroutine partition(ilow,ihigh,ipivot) 656 | 657 | implicit none 658 | 659 | integer,intent(in) :: ilow 660 | integer,intent(in) :: ihigh 661 | integer,intent(out) :: ipivot 662 | 663 | integer :: i,ip 664 | 665 | call swap(str(ilow),str((ilow+ihigh)/2)) 666 | ip = ilow 667 | do i = ilow + 1, ihigh 668 | if (lexical_lt(str(i),str(ilow),case_sensitive)) then 669 | ip = ip + 1 670 | call swap(str(ip),str(i)) 671 | end if 672 | end do 673 | call swap(str(ilow),str(ip)) 674 | ipivot = ip 675 | 676 | end subroutine partition 677 | 678 | end subroutine lexical_sort_recursive 679 | !***************************************************************************************** 680 | 681 | !***************************************************************************************** 682 | !> 683 | ! Sorts a character array `str` in increasing order, 684 | ! using a "natural" sorting method. 685 | ! 686 | ! Uses a basic recursive quicksort 687 | ! (with insertion sort for partitions with <= 20 elements). 688 | 689 | subroutine lexical_sort_natural_recursive(str,case_sensitive) 690 | 691 | implicit none 692 | 693 | character(len=*),dimension(:),intent(inout) :: str 694 | logical,intent(in) :: case_sensitive !! if true, the sort is case sensitive 695 | 696 | type(int_list),dimension(size(str)) :: ints !! the `str` converted into arrays of integers 697 | logical,dimension(size(str)) :: case_sensitive_vec !! for the elemental routine 698 | integer,dimension(size(str)) :: idx !! index vector for sorting 699 | integer :: i !! counter 700 | 701 | !convert vector of strings to vector of int vectors: 702 | case_sensitive_vec = case_sensitive 703 | call string_to_int_list(str,case_sensitive_vec,ints) 704 | 705 | idx = [(i, i=1,size(str))] 706 | call quicksort(1,size(str)) 707 | str = str(idx) 708 | 709 | contains 710 | 711 | !*************************************************************** 712 | !> 713 | ! Sort the index array of `str`, based on int vec comparison. 714 | 715 | recursive subroutine quicksort(ilow,ihigh) 716 | 717 | implicit none 718 | 719 | integer,intent(in) :: ilow 720 | integer,intent(in) :: ihigh 721 | 722 | integer :: ipivot !! pivot element 723 | integer :: i !! counter 724 | integer :: j !! counter 725 | 726 | if ( ihigh-ilow<=max_size_for_insertion_sort .and. ihigh>ilow ) then 727 | 728 | ! do insertion sort: 729 | do i = ilow + 1,ihigh 730 | do j = i,ilow + 1,-1 731 | if ( ints(idx(j)) < ints(idx(j-1)) ) then 732 | call swap(idx(j),idx(j-1)) 733 | else 734 | exit 735 | end if 736 | end do 737 | end do 738 | 739 | elseif ( ihigh-ilow>max_size_for_insertion_sort ) then 740 | 741 | ! do the normal quicksort: 742 | call partition(ilow,ihigh,ipivot) 743 | call quicksort(ilow,ipivot - 1) 744 | call quicksort(ipivot + 1,ihigh) 745 | 746 | end if 747 | 748 | end subroutine quicksort 749 | 750 | !*************************************************************** 751 | !> 752 | ! Partition the index array of `str`, based on int vec comparison. 753 | 754 | subroutine partition(ilow,ihigh,ipivot) 755 | 756 | implicit none 757 | 758 | integer,intent(in) :: ilow 759 | integer,intent(in) :: ihigh 760 | integer,intent(out) :: ipivot 761 | 762 | integer :: i,ip 763 | 764 | call swap(idx(ilow),idx((ilow+ihigh)/2)) 765 | ip = ilow 766 | do i = ilow + 1, ihigh 767 | if ( ints(idx(i)) < ints(idx(ilow)) ) then 768 | ip = ip + 1 769 | call swap(idx(ip),idx(i)) 770 | end if 771 | end do 772 | call swap(idx(ilow),idx(ip)) 773 | ipivot = ip 774 | 775 | end subroutine partition 776 | 777 | end subroutine lexical_sort_natural_recursive 778 | !***************************************************************************************** 779 | 780 | !***************************************************************************************** 781 | !> 782 | ! Returns true if the list is lexically sorted in increasing order. 783 | 784 | logical function list_is_sorted(str,case_sensitive,natural) result(sorted) 785 | 786 | implicit none 787 | 788 | character(len=*),dimension(:),intent(inout) :: str 789 | logical,intent(in) :: case_sensitive !! if true, the sort is case sensitive 790 | logical,intent(in) :: natural !! if true, the sort is "natural" 791 | 792 | type(int_list),dimension(size(str)) :: ints !! the `str` converted into arrays of integers 793 | logical,dimension(size(str)) :: case_sensitive_vec !! for the elemental routine 794 | integer :: i !! counter 795 | 796 | sorted = .true. 797 | 798 | if (natural) then 799 | 800 | !convert vector of strings to vector of int vectors: 801 | case_sensitive_vec = case_sensitive 802 | call string_to_int_list(str,case_sensitive_vec,ints) 803 | 804 | do i = 1, size(str)-1 805 | if ( ints(i+1) < ints(i) ) then 806 | sorted = .false. 807 | return 808 | end if 809 | end do 810 | 811 | else 812 | do i = 1, size(str)-1 813 | if (lexical_lt(str(i+1),str(i),case_sensitive)) then 814 | sorted = .false. 815 | return 816 | end if 817 | end do 818 | end if 819 | 820 | end function list_is_sorted 821 | !***************************************************************************************** 822 | 823 | !***************************************************************************************** 824 | end module string_sort_module 825 | !***************************************************************************************** 826 | -------------------------------------------------------------------------------- /stringsort.code-workspace: -------------------------------------------------------------------------------- 1 | { 2 | "folders": [ 3 | { 4 | "path": "." 5 | } 6 | ], 7 | "settings": { 8 | "files.trimTrailingWhitespace": true, 9 | "editor.insertSpaces": true, 10 | "editor.tabSize": 4, 11 | "editor.trimAutoWhitespace": true, 12 | "files.associations": { 13 | "license": "cpp" 14 | } 15 | } 16 | } -------------------------------------------------------------------------------- /tests/test.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************** 2 | !> 3 | ! Test for [[string_sort_module]]. 4 | 5 | program test 6 | 7 | use string_sort_module 8 | 9 | implicit none 10 | 11 | 12 | ! integer,parameter :: n = 8 !! number of strings to sort 13 | ! character(len=30),dimension(n),parameter :: strings_to_sort = & 14 | ! [ 'Callisto Morphamax ',& 15 | ! 'Callisto Morphamax 600 ',& 16 | ! 'Callisto Morphamax 7000 ',& 17 | ! 'Callisto Morphamax 5000 ',& 18 | ! 'Callisto Morphamax 700 ',& 19 | ! 'Callisto Morphamax 6000 SE2 ',& 20 | ! 'Callisto Morphamax 6000 SE ',& 21 | ! 'Callisto Morphamax 500 ' ] 22 | 23 | integer,parameter :: n = 35 !! number of strings to sort 24 | character(len=30),dimension(n),parameter :: strings_to_sort = & 25 | [ 'Callisto Morphamax ',& 26 | 'Xiph Xlater 40 ',& 27 | 'Alpha 200 ',& 28 | 'Xiph Xlater 5 ',& 29 | 'Callisto Morphamax 600 ',& 30 | '1000X Radonius Maximus ',& 31 | 'Callisto Morphamax 7000 ',& 32 | 'Allegia 500 Clasteron ',& 33 | 'Allegia 51 Clasteron ',& 34 | 'Alpha 2 ',& 35 | 'Xiph Xlater 300 ',& 36 | 'Xiph Xlater 2000 ',& 37 | 'Alpha 2A-8000 ',& 38 | 'Callisto Morphamax 5000 ',& 39 | '30X Radonius ',& 40 | '10X Radonius ',& 41 | 'Callisto Morphamax 700 ',& 42 | 'Alpha 100 ',& 43 | 'Xiph Xlater 5000 ',& 44 | '40X Radonius ',& 45 | 'Alpha 2A ',& 46 | '200X Radonius ',& 47 | 'Callisto Morphamax 6000 SE2 ',& 48 | 'Allegia 6R Clasteron ',& 49 | 'Xiph Xlater 10000 ',& 50 | 'Xiph Xlater 500 ',& 51 | 'Xiph Xlater 58 ',& 52 | '20X Radonius Prime ',& 53 | '20X Radonius ',& 54 | 'xiph Xlater 50 ',& 55 | 'allegia 50 Clasteron ',& 56 | 'Callisto Morphamax 6000 SE ',& 57 | 'allegia 50B Clasteron ',& 58 | 'alpha 2A-900 ',& 59 | 'Callisto Morphamax 500 ' ] 60 | !! Test case from [here](http://www.davekoelle.com/alphanum.html). 61 | 62 | character(len=30),dimension(n) :: str !! copy of `strings_to_sort` for sorting 63 | 64 | write(*,*) '' 65 | write(*,*) '----Case Insensitive----' 66 | write(*,*) '' 67 | write(*,*) 'recursive:' 68 | str = strings_to_sort 69 | call lexical_sort_recursive(str,case_sensitive=.false.) 70 | write(*,'(*(5X,A/))') str 71 | if (.not. list_is_sorted(str,case_sensitive=.false.,natural=.false.)) & 72 | error stop 'Error: list is not sorted.' 73 | 74 | ! this fails with gfortran 11 75 | write(*,*) '' 76 | write(*,*) 'nonrecursive:' 77 | str = strings_to_sort 78 | call lexical_sort_nonrecursive(str,case_sensitive=.false.) 79 | write(*,'(*(5X,A/))') str 80 | if (.not. list_is_sorted(str,case_sensitive=.false.,natural=.false.)) & 81 | error stop 'Error: list is not sorted.' 82 | 83 | write(*,*) '' 84 | write(*,*) '----Case Sensitive----' 85 | write(*,*) '' 86 | write(*,*) 'recursive:' 87 | str = strings_to_sort 88 | call lexical_sort_recursive(str,case_sensitive=.true.) 89 | write(*,'(*(5X,A/))') str 90 | if (.not. list_is_sorted(str,case_sensitive=.true.,natural=.false.)) & 91 | error stop 'Error: list is not sorted.' 92 | 93 | write(*,*) '' 94 | write(*,*) 'nonrecursive:' 95 | str = strings_to_sort 96 | call lexical_sort_nonrecursive(str,case_sensitive=.true.) 97 | write(*,'(*(5X,A/))') str 98 | if (.not. list_is_sorted(str,case_sensitive=.true.,natural=.false.)) & 99 | error stop 'Error: list is not sorted.' 100 | 101 | write(*,*) '' 102 | write(*,*) 'tests...' 103 | write(*,*) 'aab' < 'aaz' 104 | write(*,*) 'aaz' < 'aab' 105 | write(*,*) 'Aab' < 'aaz' 106 | write(*,*) 'aab' < 'Aaz' 107 | 108 | write(*,*) 'Alpha 2' < 'Alpha 200' 109 | 110 | end program test 111 | !******************************************************************************** 112 | -------------------------------------------------------------------------------- /tests/test_natural.f90: -------------------------------------------------------------------------------- 1 | !******************************************************************************** 2 | !> 3 | ! Test for [[string_sort_module]] natural sorting routines. 4 | 5 | program test_natural 6 | 7 | use string_sort_module 8 | use iso_fortran_env, only: ip => INT32 ! integer precision 9 | use iso_fortran_env, only: ip2 => INT64 10 | 11 | implicit none 12 | 13 | character(len=30),dimension(35) :: str 14 | 15 | write(*,*) '' 16 | write(*,*) 'huge(1_INT32) = ', huge(1_ip) 17 | write(*,*) 'huge(1_INT64) = ', huge(1_ip2) 18 | write(*,*) '' 19 | 20 | write(*,*) '' 21 | write(*,*) '----Case Insensitive----' 22 | write(*,*) '' 23 | write(*,*) 'normal:' 24 | call initialize() 25 | call lexical_sort_recursive(str,case_sensitive=.false.) 26 | write(*,'(*(5X,A/))') str 27 | if (.not. list_is_sorted(str,case_sensitive=.false.,natural=.false.)) & 28 | error stop 'Error: list is not sorted.' 29 | 30 | write(*,*) '' 31 | write(*,*) 'natural:' 32 | call initialize() 33 | call lexical_sort_natural_recursive(str,case_sensitive=.false.) 34 | write(*,'(*(5X,A/))') str 35 | if (.not. list_is_sorted(str,case_sensitive=.false.,natural=.true.)) & 36 | error stop 'Error: list is not sorted.' 37 | 38 | write(*,*) '' 39 | write(*,*) '----Case Sensitive----' 40 | write(*,*) '' 41 | write(*,*) 'normal:' 42 | call initialize() 43 | call lexical_sort_recursive(str,case_sensitive=.true.) 44 | write(*,'(*(5X,A/))') str 45 | if (.not. list_is_sorted(str,case_sensitive=.true.,natural=.false.)) & 46 | error stop 'Error: list is not sorted.' 47 | 48 | write(*,*) '' 49 | write(*,*) 'natural:' 50 | call initialize() 51 | call lexical_sort_natural_recursive(str,case_sensitive=.true.) 52 | write(*,'(*(5X,A/))') str 53 | if (.not. list_is_sorted(str,case_sensitive=.true.,natural=.true.)) & 54 | error stop 'Error: list is not sorted.' 55 | 56 | contains 57 | 58 | subroutine initialize() 59 | 60 | !! Test case from [here](http://www.davekoelle.com/alphanum.html). 61 | 62 | implicit none 63 | 64 | str = [ 'Callisto Morphamax ',& 65 | 'Xiph Xlater 40 ',& 66 | 'Alpha 200 ',& 67 | 'Xiph Xlater 5 ',& 68 | 'Callisto Morphamax 600 ',& 69 | '1000X Radonius Maximus ',& 70 | 'Callisto Morphamax 7000 ',& 71 | 'Allegia 500 Clasteron ',& 72 | 'Allegia 51 Clasteron ',& 73 | 'Alpha 2 ',& 74 | 'Xiph Xlater 300 ',& 75 | 'Xiph Xlater 2000 ',& 76 | 'Alpha 2A-8000 ',& 77 | 'Callisto Morphamax 5000 ',& 78 | '30X Radonius ',& 79 | '10X Radonius ',& 80 | 'Callisto Morphamax 700 ',& 81 | 'Alpha 100 ',& 82 | 'Xiph Xlater 5000 ',& 83 | '40X Radonius ',& 84 | 'Alpha 2A ',& 85 | '200X Radonius ',& 86 | 'Callisto Morphamax 6000 SE2 ',& 87 | 'Allegia 6R Clasteron ',& 88 | 'Xiph Xlater 10000 ',& 89 | 'Xiph Xlater 500 ',& 90 | 'Xiph Xlater 58 ',& 91 | '20X Radonius Prime ',& 92 | '20X Radonius ',& 93 | 'xiph Xlater 50 ',& 94 | 'allegia 50 Clasteron ',& 95 | 'Callisto Morphamax 6000 SE ',& 96 | 'allegia 50B Clasteron ',& 97 | 'alpha 2A-900 ',& 98 | 'Callisto Morphamax 500 ' ] 99 | 100 | end subroutine initialize 101 | 102 | end program test_natural 103 | !******************************************************************************** 104 | --------------------------------------------------------------------------------