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