Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010 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 : module history_specs
21 :
22 : use star_private_def
23 : use star_history_def
24 : use const_def, only: dp
25 : use chem_def
26 : use num_lib, only: linear_interp, find0
27 :
28 : implicit none
29 :
30 : public ! history.f90 uses most of this
31 :
32 : ! spacing between these must be larger than max number of nuclides
33 : integer, parameter :: idel = 10000
34 :
35 : integer, parameter :: center_xa_offset = idel
36 : integer, parameter :: surface_xa_offset = center_xa_offset + idel
37 : integer, parameter :: average_xa_offset = surface_xa_offset + idel
38 : integer, parameter :: category_offset = average_xa_offset + idel
39 : integer, parameter :: total_mass_offset = category_offset + idel
40 : integer, parameter :: log_total_mass_offset = total_mass_offset + idel
41 : integer, parameter :: log_average_xa_offset = log_total_mass_offset + idel
42 : integer, parameter :: log_center_xa_offset = log_average_xa_offset + idel
43 : integer, parameter :: log_surface_xa_offset = log_center_xa_offset + idel
44 : integer, parameter :: cz_max_offset = log_surface_xa_offset + idel
45 : integer, parameter :: cz_top_max_offset = cz_max_offset + idel
46 : integer, parameter :: max_eps_nuc_offset = cz_top_max_offset + idel
47 : integer, parameter :: c_log_eps_burn_offset = max_eps_nuc_offset + idel
48 :
49 : integer, parameter :: bc_offset = c_log_eps_burn_offset + idel
50 : integer, parameter :: abs_mag_offset = bc_offset + idel
51 : integer, parameter :: lum_band_offset = abs_mag_offset + idel
52 : integer, parameter :: log_lum_band_offset = lum_band_offset + idel
53 :
54 : integer, parameter :: raw_rate_offset = log_lum_band_offset + idel
55 : integer, parameter :: screened_rate_offset = raw_rate_offset + idel
56 : integer, parameter :: eps_nuc_rate_offset = screened_rate_offset + idel
57 : integer, parameter :: eps_neu_rate_offset = eps_nuc_rate_offset + idel
58 :
59 : integer, parameter :: start_of_special_cases = eps_neu_rate_offset + idel
60 : ! mixing and burning regions must be given the largest offsets
61 : ! so they can be distinguished from the other ones
62 :
63 : integer, parameter :: mixing_offset = start_of_special_cases
64 : integer, parameter :: mix_relr_offset = mixing_offset + idel
65 : integer, parameter :: burning_offset = mix_relr_offset + idel
66 : integer, parameter :: burn_relr_offset = burning_offset + idel
67 :
68 : !integer, parameter :: next_available_offset = burning_offset + idel
69 :
70 : contains
71 :
72 1 : recursive subroutine add_history_columns( &
73 : s, level, capacity, spec, history_columns_file, report, ierr)
74 : use utils_lib
75 : use utils_def
76 : use chem_def
77 : use chem_lib
78 : use const_def, only: mesa_dir
79 : !use colors_def, only: bc_total_num_colors
80 : use colors_lib
81 : type (star_info), pointer :: s
82 : integer, intent(in) :: level
83 : integer, intent(inout) :: capacity
84 : integer, pointer :: spec(:)
85 : character (len=*), intent(in) :: history_columns_file
86 : logical, intent(in) :: report
87 : integer, intent(out) :: ierr
88 :
89 : integer :: iounit, n, i, t, j, cnt, ii, nxt_spec, spec_err
90 : character (len=strlen) :: buffer, string, filename
91 : integer, parameter :: max_level = 20
92 : logical :: special_case, exists
93 : logical, parameter :: dbg = .false.
94 :
95 : include 'formats'
96 :
97 1 : if (level > max_level) then
98 0 : write(*,*) 'too many levels of nesting for log column files', level
99 0 : ierr = -1
100 0 : return
101 : end if
102 :
103 1 : ierr = 0
104 1 : spec_err = 0
105 :
106 :
107 : ! first try local directory
108 1 : filename = history_columns_file
109 :
110 1 : if(level==1) then ! First pass either the user set the file or we load the defaults
111 1 : if (len_trim(filename) == 0) filename = 'history_columns.list'
112 :
113 1 : exists=.false.
114 1 : inquire(file=filename,exist=exists)
115 :
116 1 : if(.not.exists) filename = trim(mesa_dir) // '/star/defaults/history_columns.list'
117 : else
118 : ! User had include '' in their history_columns.list file, so dont try to load the local one, jump to the defaults
119 0 : if (len_trim(filename) == 0) filename =trim(mesa_dir) // '/star/defaults/history_columns.list'
120 : end if
121 :
122 :
123 :
124 1 : open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr)
125 1 : if (ierr /= 0) then
126 0 : write(*,*) 'failed to open ' // trim(history_columns_file)
127 0 : return
128 : end if
129 :
130 : if (dbg) then
131 : write(*,'(A)')
132 : write(*,*) 'history_columns_file <' // trim(filename) // '>'
133 : write(*,'(A)')
134 : end if
135 :
136 1 : call count_specs
137 :
138 1 : n = 0
139 1 : i = 0
140 :
141 : do
142 :
143 61 : t = token(iounit, n, i, buffer, string)
144 61 : if (t == eof_token) exit
145 60 : if (t /= name_token) then
146 0 : call error; return
147 : end if
148 :
149 60 : if (string == 'include') then
150 0 : t = token(iounit, n, i, buffer, string)
151 0 : if (t /= string_token) then
152 0 : call error; return
153 : end if
154 0 : call add_history_columns(s, level+1, capacity, spec, string, report, spec_err)
155 0 : if (spec_err /= 0) then
156 0 : write(*,*) 'failed for included log columns list ' // trim(string)
157 0 : call error; return
158 : end if
159 0 : call count_specs
160 0 : cycle
161 : end if
162 :
163 : spec_err = 0
164 :
165 60 : if (string == 'add_center_abundances') then
166 0 : call do_abundances(center_xa_offset, spec_err)
167 0 : if (spec_err /= 0) then
168 0 : call error; return
169 : end if
170 0 : call count_specs
171 0 : cycle
172 : end if
173 :
174 60 : if (string == 'add_surface_abundances') then
175 0 : call do_abundances(surface_xa_offset, spec_err)
176 0 : if (spec_err /= 0) then
177 0 : call error; return
178 : end if
179 0 : call count_specs
180 0 : cycle
181 : end if
182 :
183 60 : if (string == 'add_average_abundances') then
184 0 : call do_abundances(average_xa_offset, spec_err)
185 0 : if (spec_err /= 0) then
186 0 : call error; return
187 : end if
188 0 : call count_specs
189 0 : cycle
190 : end if
191 :
192 60 : if (string == 'add_log_center_abundances') then
193 0 : call do_abundances(log_center_xa_offset, spec_err)
194 0 : if (spec_err /= 0) then
195 0 : call error; return
196 : end if
197 0 : call count_specs
198 0 : cycle
199 : end if
200 :
201 60 : if (string == 'add_log_surface_abundances') then
202 0 : call do_abundances(log_surface_xa_offset, spec_err)
203 0 : if (spec_err /= 0) then
204 0 : call error; return
205 : end if
206 0 : call count_specs
207 0 : cycle
208 : end if
209 :
210 60 : if (string == 'add_log_average_abundances') then
211 0 : call do_abundances(log_average_xa_offset, spec_err)
212 0 : if (spec_err /= 0) then
213 0 : call error; return
214 : end if
215 0 : call count_specs
216 0 : cycle
217 : end if
218 :
219 60 : if (string == 'add_total_mass') then
220 0 : call do_abundances(total_mass_offset, spec_err)
221 0 : if (spec_err /= 0) then
222 0 : call error; return
223 : end if
224 0 : call count_specs
225 0 : cycle
226 : end if
227 :
228 60 : if (string == 'add_log_total_mass') then
229 0 : call do_abundances(log_total_mass_offset, spec_err)
230 0 : if (spec_err /= 0) then
231 0 : call error; return
232 : end if
233 0 : call count_specs
234 0 : cycle
235 : end if
236 :
237 60 : if (string == 'add_bc') then
238 0 : call do_colors(bc_offset,'bc_', spec_err)
239 : if (spec_err /= 0) then
240 : call error; return
241 : end if
242 0 : call count_specs
243 0 : cycle
244 : end if
245 :
246 60 : if (string == 'add_abs_mag') then
247 0 : call do_colors(abs_mag_offset,'abs_mag_', spec_err)
248 : if (spec_err /= 0) then
249 : call error; return
250 : end if
251 0 : call count_specs
252 0 : cycle
253 : end if
254 :
255 60 : if (string == 'add_lum_band') then
256 0 : call do_colors(lum_band_offset,'lum_band_', spec_err)
257 : if (spec_err /= 0) then
258 : call error; return
259 : end if
260 0 : call count_specs
261 0 : cycle
262 : end if
263 :
264 60 : if (string == 'add_log_lum_band') then
265 0 : call do_colors(log_lum_band_offset,'log_lum_band_', spec_err)
266 : if (spec_err /= 0) then
267 : call error; return
268 : end if
269 0 : call count_specs
270 0 : cycle
271 : end if
272 :
273 60 : if (string == 'add_raw_rates') then
274 0 : call do_rate(raw_rate_offset,'raw_rate_', spec_err)
275 0 : if (spec_err /= 0) then
276 0 : call error; return
277 : end if
278 0 : call count_specs
279 0 : cycle
280 : end if
281 :
282 60 : if (string == 'add_screened_rates') then
283 0 : call do_rate(screened_rate_offset,'screened_rate_', spec_err)
284 0 : if (spec_err /= 0) then
285 0 : call error; return
286 : end if
287 0 : call count_specs
288 0 : cycle
289 : end if
290 :
291 60 : if (string == 'add_eps_nuc_rates') then
292 0 : call do_rate(eps_nuc_rate_offset,'eps_nuc_rate_', spec_err)
293 0 : if (spec_err /= 0) then
294 0 : call error; return
295 : end if
296 0 : call count_specs
297 0 : cycle
298 : end if
299 :
300 60 : if (string == 'add_eps_neu_rates') then
301 0 : call do_rate(eps_neu_rate_offset,'eps_neu_rate_', spec_err)
302 0 : if (spec_err /= 0) then
303 0 : call error; return
304 : end if
305 0 : call count_specs
306 0 : cycle
307 : end if
308 :
309 : nxt_spec = do1_history_spec( &
310 60 : s, iounit, t, n, i, string, buffer, special_case, report, spec_err)
311 61 : if (spec_err /= 0) then
312 0 : ierr = spec_err
313 : else
314 60 : if (.not. special_case) then
315 60 : call insert_spec(nxt_spec, string, spec_err)
316 60 : if (spec_err /= 0) then
317 0 : write(*,*) 'failed for history item ' // trim(string)
318 0 : ierr = -1; cycle
319 : end if
320 0 : else if (nxt_spec == h_mixing_regions) then
321 0 : t = token(iounit, n, i, buffer, string)
322 0 : if (t /= name_token) then
323 0 : ierr = -1; cycle
324 : end if
325 0 : read(string,fmt=*,iostat=spec_err) cnt
326 0 : if (spec_err /= 0 .or. cnt <= 0 .or. cnt > 1000) then
327 0 : write(*,*) 'bad integer count for mixing regions: ' // trim(string)
328 0 : ierr = -1; cycle
329 : end if
330 0 : do ii=1,2*cnt
331 0 : call insert_spec(mixing_offset + ii, string, spec_err)
332 0 : if (spec_err /= 0) then
333 0 : call error; return
334 : end if
335 : end do
336 0 : else if (nxt_spec == h_mix_relr_regions) then
337 0 : t = token(iounit, n, i, buffer, string)
338 0 : if (t /= name_token) then
339 0 : ierr = -1; cycle
340 : end if
341 0 : read(string,fmt=*,iostat=spec_err) cnt
342 0 : if (spec_err /= 0 .or. cnt <= 0 .or. cnt > 1000) then
343 0 : write(*,*) 'bad integer count for mix_relr regions: ' // trim(string)
344 0 : ierr = -1; cycle
345 : end if
346 0 : do ii=1,2*cnt
347 0 : call insert_spec(mix_relr_offset + ii, string, spec_err)
348 0 : if (spec_err /= 0) then
349 0 : call error; return
350 : end if
351 : end do
352 0 : else if (nxt_spec == h_burning_regions) then
353 0 : t = token(iounit, n, i, buffer, string)
354 0 : if (t /= name_token) then
355 0 : ierr = -1; cycle
356 : end if
357 0 : read(string,fmt=*,iostat=spec_err) cnt
358 0 : if (spec_err /= 0 .or. cnt <= 0 .or. cnt > 1000) then
359 0 : write(*,*) 'bad integer count following burning regions: ' // trim(string)
360 0 : ierr = -1
361 : end if
362 0 : do ii=1,2*cnt
363 0 : call insert_spec(burning_offset + ii, string, spec_err)
364 0 : if (spec_err /= 0) then
365 0 : call error; return
366 : end if
367 : end do
368 0 : else if (nxt_spec == h_burn_relr_regions) then
369 0 : t = token(iounit, n, i, buffer, string)
370 0 : if (t /= name_token) then
371 0 : ierr = -1; cycle
372 : end if
373 0 : read(string,fmt=*,iostat=spec_err) cnt
374 0 : if (spec_err /= 0 .or. cnt <= 0 .or. cnt > 1000) then
375 0 : write(*,*) 'bad integer count following burn_relr regions: ' // trim(string)
376 0 : ierr = -1
377 : end if
378 0 : do ii=1,2*cnt
379 0 : call insert_spec(burn_relr_offset + ii, string, spec_err)
380 0 : if (spec_err /= 0) then
381 0 : call error; return
382 : end if
383 : end do
384 : else
385 0 : write(*,*) 'confusion in history specs'
386 0 : ierr = -1
387 : end if
388 : end if
389 :
390 : end do
391 :
392 : if (dbg) write(*,*) 'finished ' // trim(filename)
393 :
394 1 : close(iounit)
395 :
396 2 : if (dbg) then
397 : write(*,'(A)')
398 : write(*,*) 'done add_history_columns ' // trim(filename)
399 : write(*,'(A)')
400 : end if
401 :
402 :
403 : contains
404 :
405 :
406 1 : subroutine count_specs
407 : integer :: i
408 1 : j = 1
409 1 : do i=1, capacity
410 1 : if (spec(i) == 0) then
411 1 : j = i; exit
412 : end if
413 : end do
414 1 : end subroutine count_specs
415 :
416 :
417 60 : subroutine make_room(ierr)
418 : integer, intent(out) :: ierr
419 60 : if (j < capacity) return
420 0 : capacity = 50 + (3*capacity)/2
421 0 : call realloc_integer(spec,capacity,ierr)
422 0 : spec(j+1:capacity) = 0
423 : end subroutine make_room
424 :
425 :
426 120 : subroutine insert_spec(c, name, ierr)
427 : integer, intent(in) :: c
428 : character (len=*) :: name
429 : integer, intent(out) :: ierr
430 : integer :: i
431 : include 'formats'
432 1830 : do i=1,j-1
433 1830 : if (spec(i) == c) return
434 : end do
435 60 : call make_room(ierr)
436 60 : if (ierr /= 0) return
437 60 : spec(j) = c
438 : if (dbg) write(*,2) trim(name), spec(j)
439 60 : j = j+1
440 : end subroutine insert_spec
441 :
442 :
443 0 : subroutine do_abundances(offset, ierr)
444 : integer, intent(in) :: offset
445 : integer, intent(out) :: ierr
446 : integer :: k
447 0 : ierr = 0
448 0 : do k=1,s% species
449 : call insert_spec( &
450 : offset + s% chem_id(k), &
451 0 : chem_isos% name(s% chem_id(k)), ierr)
452 0 : if (ierr /= 0) return
453 : end do
454 : end subroutine do_abundances
455 :
456 0 : subroutine do_colors(offset,prefix,ierr)
457 : integer, intent(in) :: offset
458 : character(len=*) :: prefix
459 : integer, intent(out) :: ierr
460 : integer :: k
461 :
462 0 : ierr = 0
463 : ! TODO. below is old module
464 : !do k=1,bc_total_num_colors
465 : ! call insert_spec( &
466 : ! offset + k,trim(prefix)//trim(get_bc_name_by_id(k,ierr)), ierr)
467 : ! if (ierr /= 0) return
468 : !end do
469 : end subroutine do_colors
470 :
471 0 : subroutine do_rate(offset,prefix,ierr) ! raw_rate, screened_rate, eps_nuc_rate, eps_neu_rate
472 : use rates_def, only: reaction_name
473 : use net_def, only: get_net_ptr
474 : integer, intent(in) :: offset
475 : character(len=*) :: prefix
476 : integer, intent(out) :: ierr
477 : integer :: k, ir
478 : type(net_general_info), pointer :: g=>null()
479 : ierr = 0
480 0 : call get_net_ptr(s% net_handle, g, ierr)
481 0 : if(ierr/=0) return
482 0 : do k=1,s% num_reactions
483 0 : ir = g% reaction_id(k)
484 : call insert_spec( &
485 0 : offset + k,trim(prefix)//trim(reaction_name(ir)), ierr)
486 0 : if (ierr /= 0) return
487 : end do
488 0 : end subroutine do_rate
489 :
490 :
491 0 : subroutine error
492 0 : ierr = -1
493 0 : close(iounit)
494 0 : end subroutine error
495 :
496 :
497 : end subroutine add_history_columns
498 :
499 :
500 60 : integer function do1_history_spec( &
501 : s, iounit, t, n, i, string, buffer, special_case, report, ierr) result(spec)
502 :
503 : use utils_lib
504 : use utils_def
505 : use chem_def
506 : use chem_lib
507 : use net_def
508 : integer :: iounit, t, n, i
509 :
510 : type(star_info), pointer :: s
511 : character (len=*) :: string, buffer
512 : logical, intent(out) :: special_case
513 : logical, intent(in) :: report
514 : integer, intent(out) :: ierr
515 :
516 : integer :: id
517 : type(Net_General_Info), pointer :: g
518 :
519 60 : ierr = 0
520 60 : spec = -1
521 60 : special_case = .false.
522 :
523 60 : call get_net_ptr(s% net_handle, g, ierr)
524 60 : if(ierr/=0) return
525 :
526 : ! These must come first otherwise things like center_mu will be caught by the
527 : ! center abundances check
528 60 : id = do_get_history_id(string)
529 60 : if (id > 0) then
530 49 : spec = id
531 : if (id == h_mixing_regions .or. &
532 : id == h_mix_relr_regions .or. &
533 49 : id == h_burning_regions .or. &
534 : id == h_burn_relr_regions) then
535 0 : special_case = .true.
536 : end if
537 49 : return
538 : end if
539 11 : id = rates_category_id(string)
540 11 : if (id > 0) then
541 3 : spec = category_offset + id
542 3 : return
543 : end if
544 :
545 68 : if (do1(string, 'raw_rate', raw_rate_offset, do1_rate)) then
546 0 : return
547 :
548 8 : else if (do1(string, 'screened_rate', screened_rate_offset, do1_rate)) then
549 0 : return
550 :
551 8 : else if (do1(string, 'eps_nuc_rate', eps_nuc_rate_offset, do1_rate)) then
552 0 : return
553 :
554 8 : else if (do1(string, 'eps_neu_rate', eps_neu_rate_offset, do1_rate)) then
555 0 : return
556 :
557 8 : else if (do1(string, 'abs_mag', abs_mag_offset, do1_color)) then
558 0 : return
559 :
560 8 : else if (do1(string, 'bc', bc_offset, do1_color)) then
561 0 : return
562 :
563 8 : else if (do1(string, 'lum_band', lum_band_offset, do1_color)) then
564 0 : return
565 :
566 8 : else if (do1(string, 'log_lum_band', log_lum_band_offset, do1_color)) then
567 0 : return
568 :
569 8 : else if (do1(string, 'center', center_xa_offset, do1_nuclide)) then
570 4 : return
571 :
572 4 : else if (do1(string, 'surface', surface_xa_offset, do1_nuclide)) then
573 2 : return
574 :
575 2 : else if (do1(string, 'average', average_xa_offset, do1_nuclide)) then
576 0 : return
577 :
578 2 : else if (do1(string, 'total_mass', total_mass_offset, do1_nuclide)) then
579 2 : return
580 :
581 0 : else if (do1(string, 'log_total_mass', log_total_mass_offset, do1_nuclide)) then
582 0 : return
583 :
584 0 : else if (do1(string, 'log_average', log_average_xa_offset, do1_nuclide)) then
585 0 : return
586 :
587 0 : else if (do1(string, 'log_center', log_center_xa_offset, do1_nuclide)) then
588 0 : return
589 :
590 0 : else if (do1(string, 'log_surface', log_surface_xa_offset, do1_nuclide)) then
591 0 : return
592 :
593 0 : else if (do1(string, 'max_eps_nuc_log_xa', max_eps_nuc_offset, do1_nuclide)) then
594 0 : return
595 :
596 0 : else if (do1(string, 'cz_top_log_xa', cz_top_max_offset, do1_nuclide)) then
597 0 : return
598 :
599 0 : else if (do1(string, 'cz_log_xa', cz_max_offset, do1_nuclide)) then
600 0 : return
601 :
602 0 : else if (do1(string, 'c_log_eps_burn', c_log_eps_burn_offset, do1_rates_category)) then
603 0 : return
604 :
605 : else
606 0 : if (report) write(*,*) 'bad history list name: ' // trim(string)
607 0 : ierr = -1
608 : end if
609 :
610 :
611 : contains
612 :
613 80 : logical function do1(string, name, offset, func)
614 : character(len=*) :: string, name
615 : integer :: offset, k
616 : interface
617 : subroutine func(offset)
618 : implicit none
619 : integer, intent(in) :: offset
620 : end subroutine func
621 : end interface
622 :
623 80 : if(string == name) then
624 : ! We have string value (i.e total_mass c12)
625 8 : call func(offset)
626 8 : do1 = .true.
627 72 : else if(string(1:len_trim(name)+1) == trim(name)//'_') then
628 : ! We have string_value (i.e total_mass_c12)
629 : ! Rewrite string so its in the form string value (i.e total_mass c12)
630 : ! By finding the last _ and replacing with a space
631 0 : k = index(string,'_',.true.)
632 0 : string(k:) = ' '
633 0 : buffer(k:k) = ' '
634 0 : i = len_trim(name)
635 0 : call func(offset)
636 0 : do1 = .true.
637 : else
638 : do1 = .false.
639 : end if
640 60 : end function do1
641 :
642 :
643 :
644 8 : subroutine do1_nuclide(offset)
645 : integer, intent(in) :: offset
646 8 : t = token(iounit, n, i, buffer, string)
647 8 : if (t /= name_token) then
648 0 : ierr = -1; return
649 : end if
650 8 : id = chem_get_iso_id(string)
651 8 : if (id > 0) then
652 8 : spec = offset + id
653 8 : return
654 : end if
655 0 : write(*,*) 'bad iso name: ' // trim(string)
656 0 : ierr = -1
657 : end subroutine do1_nuclide
658 :
659 :
660 0 : subroutine do1_rates_category(offset)
661 : integer, intent(in) :: offset
662 0 : t = token(iounit, n, i, buffer, string)
663 0 : if (t /= name_token) then
664 0 : ierr = -1; return
665 : end if
666 0 : id = rates_category_id(string)
667 0 : if (id > 0) then
668 0 : spec = offset + id
669 0 : return
670 : end if
671 0 : write(*,*) 'bad rates category name: ' // trim(string)
672 0 : ierr = -1
673 : end subroutine do1_rates_category
674 :
675 0 : subroutine do1_color(offset)
676 : use colors_lib, only : get_bc_id_by_name
677 : integer, intent(in) :: offset
678 0 : t = token(iounit, n, i, buffer, string)
679 0 : if (t /= name_token) then
680 0 : ierr = -1; return
681 : end if
682 0 : id = get_bc_id_by_name(string,ierr)
683 0 : if (ierr/=0) return
684 0 : if (id > 0) then
685 0 : spec = offset + id
686 0 : return
687 : end if
688 0 : write(*,*) 'bad filter name: ' // trim(string)
689 0 : ierr = -1
690 : end subroutine do1_color
691 :
692 0 : subroutine do1_rate(offset)
693 : use rates_lib, only: rates_reaction_id
694 : integer, intent(in) :: offset
695 0 : t = token(iounit, n, i, buffer, string)
696 0 : if (t /= name_token) then
697 0 : ierr = -1; return
698 : end if
699 0 : id = rates_reaction_id(string)
700 0 : id = g% net_reaction(id) ! Convert to net id not the global rate id
701 0 : if (ierr/=0) return
702 0 : if (id > 0) then
703 0 : spec = offset + id
704 0 : return
705 : end if
706 0 : write(*,*) 'bad reaction name: ' // trim(string)
707 0 : ierr = -1
708 : end subroutine do1_rate
709 :
710 :
711 : end function do1_history_spec
712 :
713 :
714 1 : subroutine set_history_columns(id, history_columns_file, report, ierr)
715 : use utils_lib, only: realloc_integer
716 : integer, intent(in) :: id
717 : character (len=*), intent(in) :: history_columns_file
718 : logical, intent(in) :: report
719 : integer, intent(out) :: ierr
720 :
721 : type (star_info), pointer :: s
722 : integer :: capacity, cnt, i
723 : logical, parameter :: dbg = .false.
724 : integer, pointer :: old_history_column_spec(:) => null()
725 : character (len=strlen) :: fname
726 : logical :: history_file_exists
727 : if (dbg) write(*,*) 'set_history_columns'
728 : ierr = 0
729 1 : call get_star_ptr(id, s, ierr)
730 1 : if (ierr /= 0) return
731 1 : old_history_column_spec => null()
732 1 : if (associated(s% history_column_spec)) old_history_column_spec => s% history_column_spec
733 : nullify(s% history_column_spec)
734 1 : capacity = 100 ! will increase if needed
735 1 : allocate(s% history_column_spec(capacity), stat=ierr)
736 1 : if (ierr /= 0) return
737 101 : s% history_column_spec(:) = 0
738 : call add_history_columns( &
739 1 : s, 1, capacity, s% history_column_spec, history_columns_file, report, ierr)
740 1 : if (ierr /= 0) then
741 0 : if (associated(old_history_column_spec)) deallocate(old_history_column_spec)
742 0 : return
743 : end if
744 : ! delete trailing 0's
745 1 : cnt = capacity+1
746 61 : do i=1, capacity
747 61 : if (s% history_column_spec(i) == 0) then
748 : cnt = i; exit
749 : end if
750 : end do
751 1 : capacity = cnt-1
752 1 : call realloc_integer(s% history_column_spec, capacity, ierr)
753 1 : if (ierr /= 0) return
754 1 : if (associated(old_history_column_spec)) then
755 : ! check that haven't changed the cols specs for an existing log file
756 0 : fname = trim(s% log_directory) // '/' // trim(s% star_history_name)
757 0 : inquire(file=trim(fname), exist=history_file_exists)
758 0 : if (history_file_exists) then
759 0 : if (capacity /= size(old_history_column_spec)) then
760 0 : ierr = -1
761 0 : write(*,*) 'new size of history col specs', capacity
762 0 : write(*,*) 'old size of history col specs', size(old_history_column_spec)
763 : else
764 0 : do i=1,capacity
765 0 : if (old_history_column_spec(i) /= s% history_column_spec(i)) then
766 0 : write(*,*) 'change in history col spec', &
767 0 : i, old_history_column_spec(i), s% history_column_spec(i)
768 0 : ierr = -1
769 : end if
770 : end do
771 : end if
772 0 : if (ierr /= 0) then
773 0 : write(*,*) 'ERROR: cannot change history columns when have an existing history file'
774 0 : write(*,*) 'please delete the history file or go back to previous history columns list'
775 : end if
776 : end if
777 0 : deallocate(old_history_column_spec)
778 0 : if (ierr /= 0) return
779 : end if
780 :
781 2 : end subroutine set_history_columns
782 :
783 : end module history_specs
|
