Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010-2019 Pablo Marchant & The MESA Team
4 : !
5 : ! This program is free software: you can redistribute it and/or modify
6 : ! it under the terms of the GNU Lesser General Public License
7 : ! as published by the Free Software Foundation,
8 : ! either version 3 of the License, or (at your option) any later version.
9 : !
10 : ! This program is distributed in the hope that it will be useful,
11 : ! but WITHOUT ANY WARRANTY; without even the implied warranty of
12 : ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13 : ! See the GNU Lesser General Public License for more details.
14 : !
15 : ! You should have received a copy of the GNU Lesser General Public License
16 : ! along with this program. If not, see <https://www.gnu.org/licenses/>.
17 : !
18 : ! ***********************************************************************
19 :
20 :
21 : module binary_history_specs
22 :
23 : use const_def, only: dp
24 : use star_lib
25 : use star_def
26 : use math_lib
27 : use binary_def
28 : use binary_private_def
29 : use utils_Lib, only : StrLowCase
30 :
31 : implicit none
32 :
33 : logical, parameter :: open_close_log = .true.
34 :
35 : contains
36 :
37 0 : recursive subroutine add_binary_history_columns(&
38 : b, level, capacity, spec, history_columns_file, report, ierr)
39 : use utils_lib
40 : use utils_def
41 : use const_def, only : mesa_dir
42 : type (binary_info), pointer :: b
43 : integer, intent(in) :: level
44 : integer, intent(inout) :: capacity
45 : integer, pointer :: spec(:)
46 : logical, intent(in) :: report
47 : character (len = *), intent(in) :: history_columns_file
48 : integer, intent(out) :: ierr
49 :
50 : integer :: iounit, n, i, t, j, nxt_spec
51 : character (len = 256) :: buffer, string, filename
52 : integer, parameter :: max_level = 20
53 : logical :: bad_item
54 : logical, parameter :: dbg = .false.
55 :
56 : include 'formats'
57 :
58 0 : if (level > max_level) then
59 0 : write(*, *) 'too many levels of nesting for binary log column files', level
60 0 : ierr = -1
61 0 : return
62 : end if
63 :
64 0 : ierr = 0
65 :
66 : ! first try local directory
67 0 : filename = history_columns_file
68 0 : if (len_trim(filename) == 0) filename = 'binary_history_columns.list'
69 0 : open(newunit = iounit, file = trim(filename), action = 'read', status = 'old', iostat = ierr)
70 0 : if (ierr /= 0) then ! if don't find that file, look in binary/defaults
71 0 : filename = trim(mesa_dir) // '/binary/defaults/' // trim(filename)
72 0 : ierr = 0
73 0 : open(newunit = iounit, file = trim(filename), action = 'read', status = 'old', iostat = ierr)
74 0 : if (ierr /= 0) then ! fail
75 0 : write(*, *) 'failed to open ' // trim(history_columns_file)
76 0 : return
77 : end if
78 : end if
79 :
80 : if (dbg) then
81 : write(*, '(A)')
82 : write(*, *) 'binary_history_columns_file <' // trim(filename) // '>'
83 : write(*, '(A)')
84 : end if
85 :
86 0 : call count_specs
87 :
88 0 : n = 0
89 0 : i = 0
90 0 : bad_item = .false.
91 :
92 : do
93 :
94 0 : t = token(iounit, n, i, buffer, string)
95 0 : if (t == eof_token) exit
96 0 : if (t /= name_token) then
97 0 : call error; return
98 : end if
99 :
100 0 : if (string == 'include') then
101 0 : t = token(iounit, n, i, buffer, string)
102 0 : if (t /= string_token) then
103 0 : call error; return
104 : end if
105 0 : call add_binary_history_columns(b, level + 1, capacity, spec, string, report, ierr)
106 0 : if (ierr /= 0) then
107 0 : write(*, *) 'failed for included log columns list ' // trim(string)
108 0 : bad_item = .true.
109 : end if
110 0 : if (.not. bad_item) call count_specs
111 : cycle
112 : end if
113 :
114 0 : nxt_spec = do1_binary_history_spec(iounit, t, n, i, string, buffer, report, ierr)
115 0 : if (ierr /= 0) bad_item = .true.
116 0 : if (.not. bad_item) then
117 0 : call insert_spec(nxt_spec, string, ierr)
118 : end if
119 :
120 : end do
121 :
122 : if (dbg) write(*, *) 'finished ' // trim(filename)
123 :
124 0 : close(iounit)
125 :
126 0 : if (bad_item) then
127 0 : ierr = -1
128 0 : return
129 : end if
130 :
131 0 : if (dbg) then
132 : write(*, '(A)')
133 : write(*, *) 'done add_binary_history_columns ' // trim(filename)
134 : write(*, '(A)')
135 : end if
136 :
137 :
138 : contains
139 :
140 :
141 0 : subroutine count_specs
142 : integer :: i
143 0 : j = 1
144 0 : do i = 1, capacity
145 0 : if (spec(i) == 0) then
146 0 : j = i; exit
147 : end if
148 : end do
149 0 : end subroutine count_specs
150 :
151 :
152 0 : subroutine make_room(ierr)
153 : integer, intent(out) :: ierr
154 0 : if (j < capacity) return
155 0 : capacity = 50 + (3 * capacity) / 2
156 0 : call realloc_integer(spec, capacity, ierr)
157 0 : spec(j + 1:capacity) = 0
158 : end subroutine make_room
159 :
160 :
161 0 : subroutine insert_spec(c, name, ierr)
162 : integer, intent(in) :: c
163 : character (len = *) :: name
164 : integer, intent(out) :: ierr
165 : integer :: i
166 : include 'formats'
167 0 : do i = 1, j - 1
168 0 : if (spec(i) == c) return
169 : end do
170 0 : call make_room(ierr)
171 0 : if (ierr /= 0) return
172 0 : spec(j) = c
173 : if (dbg) write(*, 2) trim(name), spec(j)
174 0 : j = j + 1
175 : end subroutine insert_spec
176 :
177 :
178 0 : subroutine error
179 0 : ierr = -1
180 0 : close(iounit)
181 0 : end subroutine error
182 :
183 :
184 : end subroutine add_binary_history_columns
185 :
186 :
187 0 : integer function do1_binary_history_spec(&
188 : iounit, t, n, i, string, buffer, report, ierr) result(spec)
189 : use utils_lib
190 : use utils_def
191 : use chem_lib
192 :
193 : integer :: iounit, t, n, i, j
194 : character (len = *) :: string, buffer
195 : logical, intent(in) :: report
196 : integer, intent(out) :: ierr
197 :
198 0 : ierr = 0
199 0 : spec = -1
200 :
201 0 : do j = 1, bh_col_id_max
202 0 : if (StrLowCase(binary_history_column_name(j)) == StrLowCase(string)) then
203 0 : spec = j
204 0 : return
205 : end if
206 : end do
207 :
208 0 : if (report) write(*, *) 'bad history list name: ' // trim(string)
209 0 : ierr = -1
210 :
211 0 : end function do1_binary_history_spec
212 :
213 0 : subroutine set_binary_history_columns(b, binary_history_columns_file, report, ierr)
214 0 : use utils_lib, only : realloc_integer
215 : type(binary_info), pointer :: b
216 : character (len = *), intent(in) :: binary_history_columns_file
217 : logical, intent(in) :: report
218 : integer, intent(out) :: ierr
219 : integer :: capacity, cnt, i
220 : logical, parameter :: dbg = .false.
221 : integer, pointer :: old_binary_history_column_spec(:) => null()
222 : character (len = strlen) :: fname
223 : logical :: history_file_exists
224 : if (dbg) write(*, *) 'set_binary_history_columns'
225 0 : ierr = 0
226 0 : old_binary_history_column_spec => null()
227 0 : if (associated(b% binary_history_column_spec)) &
228 0 : old_binary_history_column_spec => b% binary_history_column_spec
229 0 : nullify(b% binary_history_column_spec)
230 0 : capacity = 100 ! will increase if needed
231 0 : allocate(b% binary_history_column_spec(capacity), stat = ierr)
232 0 : if (ierr /= 0) return
233 0 : b% binary_history_column_spec(:) = 0
234 : call add_binary_history_columns(b, 1, capacity, &
235 0 : b% binary_history_column_spec, binary_history_columns_file, report, ierr)
236 0 : if (ierr /= 0) then
237 0 : if (associated(old_binary_history_column_spec)) &
238 0 : deallocate(old_binary_history_column_spec)
239 0 : return
240 : end if
241 : ! delete trailing 0's
242 0 : cnt = capacity + 1
243 0 : do i = 1, capacity
244 0 : if (b% binary_history_column_spec(i) == 0) then
245 : cnt = i; exit
246 : end if
247 : end do
248 0 : capacity = cnt - 1
249 0 : call realloc_integer(b% binary_history_column_spec, capacity, ierr)
250 0 : if (ierr /= 0) return
251 0 : if (associated(old_binary_history_column_spec)) then
252 : ! check that haven't changed the cols specs for an existing log file
253 : if (ierr /= 0) return
254 0 : fname = trim(b% log_directory) // '/' // trim(b% history_name)
255 0 : inquire(file = trim(fname), exist = history_file_exists)
256 0 : if (history_file_exists) then
257 0 : if (capacity /= size(old_binary_history_column_spec)) then
258 0 : ierr = -1
259 0 : write(*, *) 'new size of log col specs', capacity
260 0 : write(*, *) 'old size of log col specs', &
261 0 : size(old_binary_history_column_spec)
262 : else
263 0 : do i = 1, capacity
264 0 : if (old_binary_history_column_spec(i) /= &
265 0 : b% binary_history_column_spec(i)) then
266 0 : write(*, *) 'change in log col spec', i, &
267 0 : old_binary_history_column_spec(i), &
268 0 : b% binary_history_column_spec(i)
269 0 : ierr = -1
270 : end if
271 : end do
272 : end if
273 0 : if (ierr /= 0) then
274 0 : write(*, *) 'ERROR: cannot change binary log columns when have an existing log file'
275 0 : write(*, *) 'please delete the log file or go back to previous log columns list'
276 : end if
277 : end if
278 0 : deallocate(old_binary_history_column_spec)
279 0 : if (ierr /= 0) return
280 : end if
281 : if (dbg) write(*, *) 'binary num log columns', capacity
282 : if (dbg) call mesa_error(__FILE__, __LINE__, 'debug: set_binary_history_columns')
283 0 : end subroutine set_binary_history_columns
284 :
285 :
286 : end module binary_history_specs
|
