Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010-2022 The MESA Team, Bill Paxton & Matthias Fabry
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 pgbinary_support
21 :
22 : use binary_private_def
23 : use const_def, only: dp, secyer
24 : use rates_def, only : i_rate
25 : use utils_lib
26 : use pgstar_support, only : do1_pgmtxt
27 : use star_pgstar
28 :
29 : implicit none
30 :
31 : logical :: have_initialized_pgbinary = .false.
32 :
33 :
34 : contains
35 :
36 :
37 0 : subroutine add_to_pgbinary_hist(b, pg_hist_new)
38 : type (binary_info), pointer :: b
39 : type (pgbinary_hist_node), pointer :: pg_hist_new
40 : type (pgbinary_hist_node), pointer :: next => null()
41 : integer :: step
42 0 : step = pg_hist_new% step
43 0 : do
44 0 : if (.not. associated(b% pg% pgbinary_hist)) then
45 0 : b% pg% pgbinary_hist => pg_hist_new
46 0 : nullify(pg_hist_new% next)
47 0 : return
48 : end if
49 0 : if (step > b% pg% pgbinary_hist% step) then
50 0 : pg_hist_new% next => b% pg% pgbinary_hist
51 0 : b% pg% pgbinary_hist => pg_hist_new
52 0 : return
53 : end if
54 : ! discard item
55 0 : next => b% pg% pgbinary_hist% next
56 0 : deallocate(b% pg% pgbinary_hist% vals)
57 0 : deallocate(b% pg% pgbinary_hist)
58 0 : b% pg% pgbinary_hist => next
59 : end do
60 : end subroutine add_to_pgbinary_hist
61 :
62 :
63 0 : subroutine pgbinary_clear(b)
64 : type (binary_info), pointer :: b
65 : integer :: i
66 : type (pgbinary_win_file_data), pointer :: p
67 : type (pgbinary_hist_node), pointer :: pg_hist => null(), next => null()
68 0 : pg_hist => b% pg% pgbinary_hist
69 0 : do while(associated(pg_hist))
70 0 : if (associated(pg_hist% vals)) deallocate(pg_hist% vals)
71 0 : next => pg_hist% next
72 0 : deallocate(pg_hist)
73 0 : pg_hist => next
74 : end do
75 0 : nullify(b% pg% pgbinary_hist)
76 0 : if (have_initialized_pgbinary) return
77 0 : do i = 1, num_pgbinary_plots
78 0 : p => b% pg% pgbinary_win_file_ptr(i)
79 0 : p% id_win = 0
80 0 : p% have_called_mkdir = .false.
81 0 : p% file_dir_for_previous_mkdir = ''
82 : end do
83 : end subroutine pgbinary_clear
84 :
85 :
86 0 : subroutine init_pgbinary(ierr)
87 : use pgstar_support, only : init_pgstar
88 : integer, intent(out) :: ierr
89 :
90 0 : call init_pgstar(ierr)
91 :
92 0 : if (ierr /= 0) then
93 0 : write(*, *) 'failed to init pgstar, required for pgbinary'
94 : return
95 : end if
96 :
97 0 : have_initialized_pgbinary = .true.
98 0 : end subroutine init_pgbinary
99 :
100 0 : subroutine check_window(b, p, ierr)
101 : type (binary_info), pointer :: b
102 : type (pgbinary_win_file_data), pointer :: p
103 : integer, intent(out) :: ierr
104 0 : ierr = 0
105 0 : if (p% do_win .and. (.not. p% win_flag)) then
106 0 : p% do_win = .false.
107 0 : if (p% id_win > 0) then
108 0 : call pgslct(p% id_win)
109 0 : call pgclos
110 0 : p% id_win = 0
111 : end if
112 0 : else if (p% win_flag .and. (.not. p% do_win)) then
113 0 : if (p% id_win == 0) &
114 0 : call open_device(b, p, .false., '/xwin', p% id_win, ierr)
115 0 : if (ierr == 0 .and. p% id_win > 0) p% do_win = .true.
116 : end if
117 0 : if (p% do_win .and. p% id_win > 0 .and. &
118 : (p% win_width /= p% prev_win_width .or. &
119 : p% win_aspect_ratio /= p% prev_win_aspect_ratio)) then
120 0 : call pgslct(p% id_win)
121 0 : call pgpap(p% win_width, p% win_aspect_ratio)
122 0 : p% prev_win_width = p% win_width
123 0 : p% prev_win_aspect_ratio = p% win_aspect_ratio
124 : end if
125 0 : end subroutine check_window
126 :
127 :
128 0 : subroutine check_file(b, p, ierr)
129 : use utils_lib, only : mkdir
130 : type (binary_info), pointer :: b
131 : type (pgbinary_win_file_data), pointer :: p
132 : integer, intent(out) :: ierr
133 : character (len = strlen) :: name
134 0 : ierr = 0
135 0 : if (p% do_file .and. (.not. p% file_flag)) then
136 0 : p% do_file = .false.
137 0 : else if (p% file_flag .and. (.not. p% do_file)) then
138 0 : if (p% id_file == 0) then
139 0 : if (.not. p% have_called_mkdir .or. &
140 : p% file_dir /= p% file_dir_for_previous_mkdir) then
141 0 : call mkdir(p% file_dir)
142 0 : p% have_called_mkdir = .true.
143 0 : p% file_dir_for_previous_mkdir = p% file_dir
144 : end if
145 0 : call create_file_name(b, p% file_dir, p% file_prefix, name)
146 0 : name = trim(name) // '/' // trim(b% pg% file_device)
147 0 : call open_device(b, p, .true., name, p% id_file, ierr)
148 0 : if (ierr /= 0) return
149 0 : p% most_recent_filename = name
150 : end if
151 0 : p% do_file = .true.
152 : end if
153 : end subroutine check_file
154 :
155 :
156 0 : subroutine create_file_name(b, dir, prefix, name)
157 : type (binary_info), pointer :: b
158 : character (len = *), intent(in) :: dir, prefix
159 : character (len = *), intent(out) :: name
160 : character (len = strlen) :: num_str, fstring
161 : character (len = 32) :: file_extension
162 : write(fstring, '( "(i",i2.2,".",i2.2,")" )') &
163 0 : b% pg% file_digits, b% pg% file_digits
164 0 : write(num_str, fstring) b% model_number
165 0 : if (len_trim(dir) > 0) then
166 0 : name = trim(dir) // '/' // trim(prefix)
167 : else
168 0 : name = prefix
169 : end if
170 0 : if (b%pg%file_device=='vcps') then
171 0 : file_extension = 'ps'
172 : else
173 0 : file_extension = b%pg%file_device
174 : end if
175 0 : name = trim(name) // trim(num_str) // '.' // trim(file_extension)
176 0 : end subroutine create_file_name
177 :
178 :
179 0 : subroutine write_plot_to_file(b, p, filename, ierr)
180 : type (binary_info), pointer :: b
181 : type (pgbinary_win_file_data), pointer :: p
182 : character (len = *), intent(in) :: filename
183 : integer, intent(out) :: ierr
184 : character (len = strlen) :: name
185 0 : ierr = 0
186 : !name = trim(filename) // '/' // trim(b% file_device)
187 0 : name = trim(filename) // '/png'
188 0 : write(*, '(a)') 'write_plot_to_file device: ' // trim(name)
189 0 : call open_device(b, p, .true., trim(name), p% id_file, ierr)
190 0 : if (ierr /= 0) then
191 0 : write(*, *) 'failed in open_device'
192 0 : return
193 : end if
194 0 : call p% plot(b% binary_id, p% id_file, ierr)
195 0 : call pgclos
196 0 : p% id_file = 0
197 0 : p% do_file = .false.
198 : end subroutine write_plot_to_file
199 :
200 :
201 0 : subroutine open_device(b, p, is_file, dev, id, ierr)
202 : use pgstar_colors, only: set_device_colors
203 : type (binary_info), pointer :: b
204 : type (pgbinary_win_file_data), pointer :: p
205 : logical, intent(in) :: is_file
206 : character (len = *), intent(in) :: dev
207 : integer, intent(out) :: id
208 : integer, intent(out) :: ierr
209 :
210 : integer :: pgopen
211 : character (len = strlen) :: dir
212 : logical :: white_on_black_flag
213 0 : real :: width, ratio
214 :
215 0 : if (is_file) then
216 0 : dir = p% file_dir
217 0 : white_on_black_flag = b% pg% file_white_on_black_flag
218 : else
219 0 : dir = ''
220 0 : white_on_black_flag = b% pg% win_white_on_black_flag
221 : end if
222 :
223 0 : ierr = 0
224 0 : id = -1
225 0 : id = pgopen(trim(dev))
226 0 : if (id <= 0) return
227 :
228 : ! write(*,*) 'open device <' // trim(dev) // '> ' // trim(p% name), id
229 0 : if (is_file) then
230 0 : width = p% file_width; if (width < 0) width = p% win_width
231 0 : ratio = p% file_aspect_ratio; if (ratio < 0) ratio = p% win_aspect_ratio
232 0 : call pgpap(width, ratio)
233 : else
234 0 : call pgpap(p% win_width, p% win_aspect_ratio)
235 0 : p% prev_win_width = p% win_width
236 0 : p% prev_win_aspect_ratio = p% win_aspect_ratio
237 : end if
238 0 : call set_device_colors(white_on_black_flag)
239 : end subroutine open_device
240 :
241 :
242 0 : integer function count_hist_points(b, step_min, step_max) result(numpts)
243 : type (binary_info), pointer :: b
244 : integer, intent(in) :: step_min, step_max
245 : type (pgbinary_hist_node), pointer :: pg
246 : include 'formats'
247 0 : numpts = 0
248 0 : pg => b% pg% pgbinary_hist
249 0 : do ! recall that hist list is decreasing by age (and step)
250 0 : if (.not. associated(pg)) return
251 0 : if (pg% step < step_min) return
252 0 : if (pg% step <= step_max .or. step_max <= 0) numpts = numpts + 1
253 0 : pg => pg% next
254 : end do
255 : end function count_hist_points
256 :
257 :
258 0 : logical function get1_hist_yvec(b, step_min, step_max, n, name, vec)
259 : use utils_lib, only : integer_dict_lookup
260 : type (binary_info), pointer :: b
261 : integer, intent(in) :: step_min, step_max, n ! n = count_hist_points
262 : character (len = *) :: name
263 : real, dimension(:), pointer :: vec
264 : integer :: i, ierr, cnt
265 : character (len = 64) :: key_name
266 : include 'formats'
267 0 : cnt = 0
268 0 : do i = 1, len(key_name)
269 0 : key_name(i:i) = ' '
270 : end do
271 0 : do i = 1, len_trim(name)
272 0 : if (name(i:i) == ' ') then
273 0 : cnt = cnt + 1
274 0 : key_name(i:i) = '_'
275 : else
276 0 : key_name(i:i) = name(i:i)
277 : end if
278 : end do
279 0 : call integer_dict_lookup(b% binary_history_names_dict, key_name, i, ierr)
280 0 : if (ierr /= 0 .or. i <= 0) then ! didn't find it
281 0 : get1_hist_yvec = .false.
282 : return
283 : end if
284 0 : call get_hist_points(b, step_min, step_max, n, i, vec)
285 0 : get1_hist_yvec = .true.
286 0 : end function get1_hist_yvec
287 :
288 :
289 0 : subroutine set_hist_points_steps(&
290 0 : b, step_min, step_max, numpts, vec, ierr)
291 : type (binary_info), pointer :: b
292 : integer, intent(in) :: step_min, step_max, numpts
293 : real, intent(out) :: vec(:)
294 : integer, intent(out) :: ierr
295 : integer :: i
296 : type (pgbinary_hist_node), pointer :: pg
297 0 : ierr = 0
298 0 : if (numpts == 0) return
299 0 : pg => b% pg% pgbinary_hist
300 0 : i = numpts
301 0 : do ! recall that hist list is decreasing by age (and step)
302 0 : if (.not. associated(pg)) then
303 0 : ierr = -1
304 0 : return
305 : end if
306 0 : if (pg% step < step_min) then
307 0 : ierr = -1
308 0 : return
309 : end if
310 0 : if (pg% step <= step_max) then
311 0 : vec(i) = real(pg% step)
312 0 : i = i - 1
313 0 : if (i == 0) return
314 : end if
315 0 : pg => pg% next
316 : end do
317 : end subroutine set_hist_points_steps
318 :
319 :
320 0 : integer function get_hist_index(b, spec) result(index)
321 : type (binary_info), pointer :: b
322 : integer, intent(in) :: spec
323 : integer :: i, num
324 : ! note: this doesn't include "extra" columns
325 0 : num = size(b% binary_history_column_spec, dim = 1)
326 0 : do i = 1, num
327 0 : if (b% binary_history_column_spec(i) == spec) then
328 0 : index = i
329 0 : return
330 : end if
331 : end do
332 0 : index = -1
333 : end function get_hist_index
334 :
335 :
336 0 : subroutine get_hist_points(&
337 0 : b, step_min, step_max, numpts, index, vec)
338 : type (binary_info), pointer :: b
339 : integer, intent(in) :: step_min, step_max, numpts, index
340 : real, intent(out) :: vec(:)
341 : integer :: i
342 : type (pgbinary_hist_node), pointer :: pg => null()
343 : include 'formats'
344 0 : if (numpts == 0) return
345 0 : pg => b% pg% pgbinary_hist
346 0 : i = numpts
347 0 : vec = 0
348 0 : do ! recall that hist list is decreasing by age (and step)
349 0 : if (.not. associated(pg)) return
350 0 : if (pg% step < step_min) then
351 : ! this will not happen if have correct numpts
352 : return
353 : end if
354 0 : if (pg% step <= step_max .or. step_max <= 0) then
355 0 : if (.not. associated(pg% vals)) return
356 0 : if (size(pg% vals, dim = 1) < index) return
357 0 : vec(i) = pg% vals(index)
358 0 : i = i - 1
359 0 : if (i == 0) return
360 : end if
361 0 : pg => pg% next
362 : end do
363 : end subroutine get_hist_points
364 :
365 :
366 0 : subroutine show_annotations(b, show_annotation1, show_annotation2, show_annotation3)
367 : type (binary_info), pointer :: b
368 : logical, intent(in) :: show_annotation1, show_annotation2, show_annotation3
369 0 : if (show_annotation1 .and. len_trim(b% pg% annotation1_text) > 0) then
370 0 : call pgsci(b% pg% annotation1_ci)
371 0 : call pgscf(b% pg% annotation1_cf)
372 : call do1_pgmtxt(b% pg% annotation1_side, b% pg% annotation1_disp, &
373 : b% pg% annotation1_coord, b% pg% annotation1_fjust, b% pg% annotation1_text, &
374 0 : b% pg% annotation1_ch, b% pg% annotation1_lw)
375 : end if
376 0 : if (show_annotation2 .and. len_trim(b% pg% annotation2_text) > 0) then
377 0 : call pgsci(b% pg% annotation2_ci)
378 0 : call pgscf(b% pg% annotation2_cf)
379 : call do1_pgmtxt(b% pg% annotation2_side, b% pg% annotation2_disp, &
380 : b% pg% annotation2_coord, b% pg% annotation2_fjust, b% pg% annotation2_text, &
381 0 : b% pg% annotation2_ch, b% pg% annotation2_lw)
382 : end if
383 0 : if (show_annotation3 .and. len_trim(b% pg% annotation3_text) > 0) then
384 0 : call pgsci(b% pg% annotation3_ci)
385 0 : call pgscf(b% pg% annotation3_cf)
386 : call do1_pgmtxt(b% pg% annotation3_side, b% pg% annotation3_disp, &
387 : b% pg% annotation3_coord, b% pg% annotation3_fjust, b% pg% annotation3_text, &
388 0 : b% pg% annotation3_ch, b% pg% annotation3_lw)
389 : end if
390 0 : end subroutine show_annotations
391 :
392 :
393 0 : subroutine show_box_pgbinary(b, str1, str2)
394 : type (binary_info), pointer :: b
395 : character (len = *), intent(in) :: str1, str2
396 0 : real :: ch
397 : integer :: lw
398 0 : call pgqch(ch)
399 0 : call pgqlw(lw)
400 0 : call pgsch(b% pg% pgbinary_num_scale * ch)
401 0 : call pgslw(b% pg% pgbinary_box_lw)
402 0 : call pgbox(str1, 0.0, 0, str2, 0.0, 0)
403 0 : call pgsch(ch)
404 0 : call pgslw(lw)
405 0 : end subroutine show_box_pgbinary
406 :
407 :
408 0 : subroutine draw_rect()
409 : use pgstar_colors, only: clr_Foreground
410 0 : real, dimension(5) :: xs, ys
411 0 : call pgsave
412 0 : call pgsci(clr_Foreground)
413 0 : xs = [0.0, 0.0, 1.0, 1.0, 0.0]
414 0 : ys = [0.0, 1.0, 1.0, 0.0, 0.0]
415 0 : call pgswin(0.0, 1.0, 0.0, 1.0)
416 0 : call pgmove(0.0, 0.0)
417 0 : call pgline(5, xs, ys)
418 0 : call pgunsa
419 0 : end subroutine draw_rect
420 :
421 :
422 0 : subroutine show_grid_title_pgbinary(b, title, pad)
423 : type (binary_info), pointer :: b
424 : character (len = *), intent(in) :: title
425 : real, intent(in) :: pad
426 : optional pad
427 0 : real :: ch, disp
428 0 : if (.not. b% pg% pgbinary_grid_show_title) return
429 0 : if (len_trim(title) == 0) return
430 0 : call pgqch(ch)
431 0 : disp = b% pg% pgbinary_grid_title_disp
432 0 : if (present(pad)) disp = disp + pad
433 : call do1_pgmtxt('T', disp, &
434 : b% pg% pgbinary_grid_title_coord, b% pg% pgbinary_grid_title_fjust, title, &
435 0 : b% pg% pgbinary_grid_title_scale * ch, b% pg% pgbinary_grid_title_lw)
436 : end subroutine show_grid_title_pgbinary
437 :
438 :
439 0 : subroutine show_title_pgbinary(b, title, pad)
440 : type (binary_info), pointer :: b
441 : character (len = *), intent(in) :: title
442 : real, intent(in) :: pad
443 : optional pad
444 0 : real :: ch, disp
445 0 : if (.not. b% pg% pgbinary_show_title) return
446 0 : if (len_trim(title) == 0) return
447 0 : call pgqch(ch)
448 0 : disp = b% pg% pgbinary_title_disp
449 0 : if (present(pad)) disp = disp + pad
450 : call do1_pgmtxt('T', disp, &
451 : b% pg% pgbinary_title_coord, b% pg% pgbinary_title_fjust, title, &
452 0 : b% pg% pgbinary_title_scale * ch, b% pg% pgbinary_title_lw)
453 : end subroutine show_title_pgbinary
454 :
455 :
456 0 : subroutine show_title_label_pgmtxt_pgbinary(&
457 : b, coord, fjust, label, pad)
458 : type (binary_info), pointer :: b
459 : character (len = *), intent(in) :: label
460 : real, intent(in) :: pad, coord, fjust
461 : optional pad
462 : real :: disp
463 0 : disp = b% pg% pgbinary_title_disp
464 0 : if (present(pad)) disp = disp + pad
465 0 : call pgmtxt('T', disp, coord, fjust, label)
466 0 : end subroutine show_title_label_pgmtxt_pgbinary
467 :
468 :
469 0 : subroutine show_xaxis_label_pgbinary(b, label, pad)
470 : type (binary_info), pointer :: b
471 : character (len = *), intent(in) :: label
472 : real, intent(in) :: pad
473 : optional pad
474 0 : real :: ch, disp
475 0 : call pgqch(ch)
476 0 : disp = b% pg% pgbinary_xaxis_label_disp
477 0 : if (present(pad)) disp = disp + pad
478 : call do1_pgmtxt('B', disp, 0.5, 0.5, label, &
479 0 : b% pg% pgbinary_xaxis_label_scale * ch, b% pg% pgbinary_xaxis_label_lw)
480 0 : end subroutine show_xaxis_label_pgbinary
481 :
482 :
483 0 : subroutine show_xaxis_label_pgmtxt_pgbinary(&
484 : b, coord, fjust, label, pad)
485 : type (binary_info), pointer :: b
486 : character (len = *), intent(in) :: label
487 : real, intent(in) :: pad, coord, fjust
488 : optional pad
489 : real :: disp
490 0 : disp = b% pg% pgbinary_xaxis_label_disp
491 0 : if (present(pad)) disp = disp + pad
492 0 : call pgmtxt('B', disp, coord, fjust, label)
493 0 : end subroutine show_xaxis_label_pgmtxt_pgbinary
494 :
495 :
496 0 : subroutine show_left_yaxis_label_pgbinary(b, label, pad)
497 : type (binary_info), pointer :: b
498 : character (len = *), intent(in) :: label
499 : real, intent(in) :: pad
500 : optional pad
501 0 : real :: ch, disp
502 0 : call pgqch(ch)
503 0 : disp = b% pg% pgbinary_left_yaxis_label_disp
504 0 : if (present(pad)) disp = disp + pad
505 : call do1_pgmtxt('L', disp, 0.5, 0.5, label, &
506 0 : b% pg% pgbinary_left_yaxis_label_scale * ch, b% pg% pgbinary_left_yaxis_label_lw)
507 0 : end subroutine show_left_yaxis_label_pgbinary
508 :
509 :
510 0 : subroutine show_right_yaxis_label_pgbinary(b, label, pad)
511 : type (binary_info), pointer :: b
512 : character (len = *), intent(in) :: label
513 : real, intent(in) :: pad
514 : optional pad
515 0 : real :: ch, disp
516 0 : call pgqch(ch)
517 0 : disp = b% pg% pgbinary_right_yaxis_label_disp
518 0 : if (present(pad)) disp = disp + pad
519 : call do1_pgmtxt('R', disp, 0.5, 0.5, label, &
520 0 : b% pg% pgbinary_right_yaxis_label_scale * ch, b% pg% pgbinary_right_yaxis_label_lw)
521 0 : end subroutine show_right_yaxis_label_pgbinary
522 :
523 :
524 0 : subroutine show_left_yaxis_label_pgmtxt_pgbinary(&
525 : b, coord, fjust, label, pad)
526 : type (binary_info), pointer :: b
527 : character (len = *), intent(in) :: label
528 : real, intent(in) :: pad, coord, fjust
529 : optional pad
530 0 : real :: ch, disp
531 0 : call pgqch(ch)
532 0 : call pgsch(1.1 * ch)
533 0 : disp = b% pg% pgbinary_left_yaxis_label_disp
534 0 : if (present(pad)) disp = disp + pad
535 0 : call pgmtxt('L', disp, coord, fjust, label)
536 0 : call pgsch(ch)
537 0 : end subroutine show_left_yaxis_label_pgmtxt_pgbinary
538 :
539 :
540 0 : subroutine show_right_yaxis_label_pgmtxt_pgbinary(&
541 : b, coord, fjust, label, pad)
542 : type (binary_info), pointer :: b
543 : character (len = *), intent(in) :: label
544 : real, intent(in) :: pad, coord, fjust
545 : optional pad
546 0 : real :: ch, disp
547 0 : call pgqch(ch)
548 0 : call pgsch(1.1 * ch)
549 0 : disp = b% pg% pgbinary_right_yaxis_label_disp
550 0 : if (present(pad)) disp = disp + pad
551 0 : call pgmtxt('R', disp, coord, fjust, label)
552 0 : call pgsch(ch)
553 0 : end subroutine show_right_yaxis_label_pgmtxt_pgbinary
554 :
555 :
556 0 : subroutine show_model_number_pgbinary(b)
557 : type (binary_info), pointer :: b
558 : character (len = 32) :: str
559 0 : real :: ch
560 0 : if (.not. b% pg% pgbinary_show_model_number) return
561 0 : write(str, '(i9)') b% model_number
562 0 : str = 'model ' // trim(adjustl(str))
563 0 : call pgqch(ch)
564 : call do1_pgmtxt('T', &
565 : b% pg% pgbinary_model_disp, b% pg% pgbinary_model_coord, &
566 : b% pg% pgbinary_model_fjust, str, &
567 0 : b% pg% pgbinary_model_scale * ch, b% pg% pgbinary_model_lw)
568 : end subroutine show_model_number_pgbinary
569 :
570 :
571 0 : subroutine show_age_pgbinary(b)
572 : type (binary_info), pointer :: b
573 : character (len = 32) :: age_str, units_str
574 : real(dp) :: age
575 0 : real :: ch
576 : integer :: len, i, j, iE
577 0 : if (.not. b% pg% pgbinary_show_age) return
578 0 : age = b% binary_age
579 0 : if (b% pg% pgbinary_show_age_in_seconds) then
580 0 : age = age * secyer
581 0 : units_str = 'secs'
582 0 : else if (b% pg% pgbinary_show_age_in_minutes) then
583 0 : age = age * secyer / 60
584 0 : units_str = 'mins'
585 0 : else if (b% pg% pgbinary_show_age_in_hours) then
586 0 : age = age * secyer / (60 * 60)
587 0 : units_str = 'hrs'
588 0 : else if (b% pg% pgbinary_show_age_in_days) then
589 0 : age = age * secyer / (60 * 60 * 24)
590 0 : units_str = 'days'
591 0 : else if (b% pg% pgbinary_show_age_in_years) then
592 : !age = age
593 0 : units_str = 'yrs'
594 0 : else if (b% pg% pgbinary_show_log_age_in_years) then
595 0 : age = log10(max(1d-99, age))
596 0 : units_str = 'log yrs'
597 0 : else if (age * secyer < 60) then
598 0 : age = age * secyer
599 0 : units_str = 'secs'
600 0 : else if (age * secyer < 60 * 60) then
601 0 : age = age * secyer / 60
602 0 : units_str = 'mins'
603 0 : else if (age * secyer < 60 * 60 * 24) then
604 0 : age = age * secyer / (60 * 60)
605 0 : units_str = 'hrs'
606 0 : else if (age * secyer < 60 * 60 * 24 * 500) then
607 0 : age = age * secyer / (60 * 60 * 24)
608 0 : units_str = 'days'
609 : else
610 : !age = age
611 0 : units_str = 'yrs'
612 : end if
613 0 : if (abs(age) > 1d-3 .and. abs(age) < 1d3) then
614 0 : write(age_str, '(f14.6)') age
615 : else
616 0 : write(age_str, '(1pe14.6)') age
617 0 : len = len_trim(age_str)
618 0 : iE = 0
619 0 : do i = 1, len
620 0 : if (age_str(i:i) == 'E') then
621 0 : iE = i
622 0 : age_str(i:i) = 'e'
623 0 : exit
624 : end if
625 : end do
626 0 : if (iE > 0) then
627 0 : i = iE + 1
628 0 : if (age_str(i:i) == '+') then
629 0 : do j = i, len - 1
630 0 : age_str(j:j) = age_str(j + 1:j + 1)
631 : end do
632 0 : age_str(len:len) = ' '
633 0 : len = len - 1
634 : else
635 0 : i = i + 1
636 : end if
637 0 : if (age_str(i:i) == '0') then
638 0 : do j = i, len - 1
639 0 : age_str(j:j) = age_str(j + 1:j + 1)
640 : end do
641 0 : age_str(len:len) = ' '
642 0 : len = len - 1
643 : end if
644 : end if
645 : end if
646 0 : age_str = adjustl(age_str)
647 0 : age_str = 'age ' // trim(age_str) // ' ' // trim(units_str)
648 0 : call pgqch(ch)
649 : call do1_pgmtxt('T', &
650 : b% pg% pgbinary_age_disp, b% pg% pgbinary_age_coord, &
651 : b% pg% pgbinary_age_fjust, age_str, &
652 0 : b% pg% pgbinary_age_scale * ch, b% pg% pgbinary_age_lw)
653 : end subroutine show_age_pgbinary
654 :
655 :
656 0 : logical function read_values_from_file(fname, x_data, y_data, data_len)
657 : character(len = *), intent(in) :: fname
658 : real, pointer, dimension(:) :: x_data, y_data
659 : integer, intent(out) :: data_len
660 : integer :: iounit, ierr, i
661 : include 'formats'
662 0 : read_values_from_file = .false.
663 0 : ierr = 0
664 0 : open(newunit = iounit, file = trim(fname), action = 'read', status = 'old', iostat = ierr)
665 0 : if (ierr /= 0) then
666 : !write(*, *) 'failed to open ' // trim(fname)
667 : return
668 : end if
669 0 : read(iounit, *, iostat = ierr) data_len
670 0 : if (ierr /= 0) then
671 0 : write(*, *) 'failed to read num points on 1st line ' // trim(fname)
672 0 : return
673 : end if
674 : !write(*,2) trim(fname) // ' data_len', data_len
675 0 : allocate(x_data(data_len), y_data(data_len))
676 0 : do i = 1, data_len
677 0 : read(iounit, *, iostat = ierr) x_data(i), y_data(i)
678 0 : if (ierr /= 0) then
679 0 : write(*, *) 'failed to read data ' // trim(fname)
680 0 : deallocate(x_data, y_data)
681 0 : return
682 : end if
683 : end do
684 0 : close(iounit)
685 0 : read_values_from_file = .true.
686 0 : end function read_values_from_file
687 :
688 :
689 0 : subroutine show_pgbinary_decorator(binary_id, use_flag, pgbinary_decorator, plot_num, ierr)
690 : logical, intent(in) :: use_flag
691 0 : real :: xmin, xmax, ymin, ymax
692 : integer, intent(in) :: binary_id, plot_num
693 : integer, intent(inout) :: ierr
694 : procedure(pgbinary_decorator_interface), pointer :: pgbinary_decorator
695 :
696 0 : if(use_flag)then
697 0 : if(associated(pgbinary_decorator))then
698 0 : call pgsave
699 0 : call PGQWIN(xmin, xmax, ymin, ymax)
700 0 : call pgbinary_decorator(binary_id, xmin, xmax, ymin, ymax, plot_num, ierr)
701 0 : call pgunsa
702 0 : if(ierr/=0)then
703 0 : write(*, *) "Error in pgbinary_decorator"
704 : end if
705 : end if
706 : end if
707 :
708 0 : end subroutine show_pgbinary_decorator
709 :
710 : end module pgbinary_support
711 :
|
