aboutsummaryrefslogtreecommitdiff
path: root/mendeleev.f90
blob: e36bef7fd167f786301f7146b956888e8af6127a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
program mendeleev

   implicit none

   character(len=2), dimension(0:118), parameter :: ELEMENTS = (/ "? ", &
     "Ac", "Ag", "Al", "Am", "Ar", "As", "At", "Au", "B ", "Ba", "Be", "Bh", &
     "Bi", "Bk", "Br", "C ", "Ca", "Cd", "Ce", "Cf", "Cl", "Cm", "Cn", "Co", &
     "Cr", "Cs", "Cu", "Db", "Ds", "Dy", "Er", "Es", "Eu", "F ", "Fe", "Fl", &
     "Fm", "Fr", "Ga", "Gd", "Ge", "H ", "He", "Hf", "Hg", "Ho", "Hs", "I ", &
     "In", "Ir", "K ", "Kr", "La", "Li", "Lr", "Lu", "Lv", "Mc", "Md", "Mg", &
     "Mn", "Mo", "Mt", "N ", "Na", "Nb", "Nd", "Ne", "Nh", "Ni", "No", "Np", &
     "O ", "Og", "Os", "P ", "Pa", "Pb", "Pd", "Pm", "Po", "Pr", "Pt", "Pu", &
     "Ra", "Rb", "Re", "Rf", "Rg", "Rh", "Rn", "Ru", "S ", "Sb", "Sc", "Se", &
     "Sg", "Si", "Sm", "Sn", "Sr", "Ta", "Tb", "Tc", "Te", "Th", "Ti", "Tl", &
     "Tm", "Ts", "U ", "V ", "W ", "Xe", "Y ", "Yb", "Zn", "Zr" /)

   type :: element_t
      integer :: eid = 0
      character(len=:), pointer :: tail => null()
      type(element_t), pointer :: sibs => null()
      type(element_t), pointer :: next => null()
   end type element_t

   type(element_t), pointer :: root
   character(len=:), pointer :: word
   integer, dimension(:), allocatable :: formula
   integer :: length, argc, i

   argc = command_argument_count()
   do i = 1, argc
      call get_command_argument(i, length=length)
      allocate(character(len=length) :: word)
      call get_command_argument(i, value=word)
      write (*, "(A, ':')") word

      if (length > 0) then
         root => explode(word)
         allocate(formula(length))
         call print_plain(root, formula, 1)
         deallocate(formula)
         call free_elements(root)
      end if

      deallocate(word)
   end do


contains

   pure recursive subroutine free_elements(root)
      type(element_t), pointer, intent(in out) :: root
      type(element_t), pointer :: sibs

      do while (associated(root))
         if (associated(root%next)) call free_elements(root%next)
         sibs => root%sibs
         deallocate(root)
         root => sibs
      end do
   end subroutine free_elements


   pure integer function tolower(c)
      character(len=1), intent(in) :: c

      tolower = ior(32, iachar(c))
   end function tolower


   pure subroutine search(start, end, sh, c)
      integer, intent(in out) :: start, end
      integer, intent(in) :: sh
      character(len=1), intent(in) :: c
      integer :: l, m, u, c_

      c_ = tolower(c)

      u = end
      l = start
      do while (l < u)
         m = (u + l) / 2
         if (tolower(ELEMENTS(m)(sh:sh)) < c_) then
           l = m + 1
         else
           u = m
        endif
      end do

      if (l == end) then
        end = 0
        return
      end if

      if (tolower(ELEMENTS(l)(sh:sh)) /= c_) then
         end = 0
        return
      end if

      u = end
      start = l
      do while (l < u)
         m = (u + l) / 2
         if (c_ < tolower(ELEMENTS(m)(sh:sh))) then
           u = m
         else
           l = m + 1
        endif
      end do

      end = u
   end subroutine search


   function split(tail) result(head)
      character(len=:), pointer, intent(in) :: tail
      type(element_t), pointer :: head, last, el
      integer :: start, end, sh

      head => null()
      last => null()

      start = 1
      end = ubound(ELEMENTS, 1) + 1
      do sh = 1, len(tail)
         call search(start, end, sh, tail(sh:sh))
         if (start >= end) exit

         if (sh == len_trim(ELEMENTS(start))) then
            allocate(el)
            if (associated(last)) then
               last%sibs => el
            else
               head => el
            end if

            last => el
            last%eid = start
            last%tail => tail(sh+1:)

            start = start + 1
         end if
      end do

      if (.not. associated(head)) then
         allocate(head)
         head%tail => tail(2:)
      end if
   end function split


   recursive function explode(tail) result(root)
      character(len=:), pointer, intent(in) :: tail
      type(element_t), pointer :: root, el

      root => split(tail)
      el => root
      do while (associated(el))
         if (0 < len(el%tail)) el%next => explode(el%tail)
         el => el%sibs
      end do
   end function explode


   recursive subroutine print_plain(tree, formula, n)
      type(element_t), pointer, intent(in) :: tree
      integer, dimension(:), intent(in out) :: formula
      integer, value :: n
      type(element_t), pointer :: el
      integer :: i

      el => tree
      do while (associated(el))
         formula(n) = el%eid
         if (associated(el%next)) then
            call print_plain(el%next, formula, n+1)
         else
            do i = 1, n
               write (*, "(' ', A)", advance="no") trim(ELEMENTS(formula(i)))
            end do
            write (*, "()")
         end if
         el => el%sibs
      end do
   end subroutine print_plain

end program mendeleev