Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2015 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 other_extras
21 : use star_def
22 : use star_lib
23 : use const_def, only: dp
24 : use utils_lib
25 :
26 : implicit none
27 :
28 : private warn_run_star_extras
29 : public
30 :
31 : contains
32 :
33 : ! Each null routine should have a call to warn_run_star_extras
34 : ! This adds a warning message to let people know they are
35 : ! calling the null_ version and not the version in their
36 : ! run_star_extras.f file
37 :
38 0 : subroutine null_extras_startup(id,restart,ierr)
39 : type (star_info), pointer :: s
40 : integer, intent(in) :: id
41 : integer, intent(out) :: ierr
42 : logical, intent(in) :: restart
43 0 : call star_ptr(id, s, ierr)
44 0 : if (ierr /= 0) then ! failure in ptr
45 0 : return
46 : end if
47 :
48 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "extras_startup")
49 :
50 : end subroutine null_extras_startup
51 :
52 :
53 : ! return either retry, keep_going or terminate
54 0 : integer function null_extras_check_model(id)
55 : type (star_info), pointer :: s
56 : integer, intent(in) :: id
57 : integer :: ierr
58 0 : call star_ptr(id, s, ierr)
59 0 : if (ierr /= 0) then ! failure in ptr
60 : return
61 : end if
62 0 : null_extras_check_model = keep_going
63 :
64 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "extras_check_model")
65 :
66 0 : end function null_extras_check_model
67 :
68 :
69 : ! returns either keep_going or terminate.
70 : ! note: cannot request retry; extras_check_model can do that.
71 0 : integer function null_extras_start_step(id)
72 : type (star_info), pointer :: s
73 : integer, intent(in) :: id
74 : integer :: ierr
75 0 : call star_ptr(id, s, ierr)
76 : if (ierr /= 0) then ! failure in ptr
77 : return
78 : end if
79 : null_extras_start_step = keep_going
80 :
81 : !call warn_run_star_extras(s%job%warn_run_star_extras, "extras_start_step")
82 :
83 : end function null_extras_start_step
84 :
85 :
86 : ! returns either keep_going or terminate.
87 : ! note: cannot request retry; extras_check_model can do that.
88 0 : integer function null_extras_finish_step(id)
89 : type (star_info), pointer :: s
90 : integer, intent(in) :: id
91 : integer :: ierr
92 0 : call star_ptr(id, s, ierr)
93 0 : if (ierr /= 0) then ! failure in ptr
94 : return
95 : end if
96 0 : null_extras_finish_step = keep_going
97 :
98 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "extras_finish_step")
99 :
100 0 : end function null_extras_finish_step
101 :
102 :
103 0 : subroutine null_extras_after_evolve(id, ierr)
104 : type (star_info), pointer :: s
105 : integer, intent(in) :: id
106 : integer, intent(out) :: ierr
107 0 : call star_ptr(id, s, ierr)
108 0 : if (ierr /= 0) then ! failure in ptr
109 0 : return
110 : end if
111 :
112 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "extras_after_evolve")
113 :
114 : end subroutine null_extras_after_evolve
115 :
116 :
117 0 : integer function null_how_many_extra_history_columns(id)
118 : integer, intent(in) :: id
119 : type (star_info), pointer :: s
120 : integer :: ierr
121 0 : call star_ptr(id, s, ierr)
122 0 : if (ierr /= 0) then ! failure in ptr
123 : return
124 : end if
125 0 : null_how_many_extra_history_columns=0
126 :
127 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "how_many_extra_history_columns")
128 :
129 0 : end function null_how_many_extra_history_columns
130 :
131 :
132 0 : subroutine null_data_for_extra_history_columns(id, n, names, vals, ierr)
133 : integer, intent(in) :: id
134 : integer, intent(in) :: n
135 : character (len=maxlen_history_column_name) :: names(n)
136 : real(dp) :: vals(n)
137 : integer, intent(out) :: ierr
138 : type (star_info), pointer :: s
139 0 : call star_ptr(id, s, ierr)
140 0 : if (ierr /= 0) then ! failure in ptr
141 0 : return
142 : end if
143 :
144 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "data_for_extra_history_columns")
145 :
146 : end subroutine null_data_for_extra_history_columns
147 :
148 :
149 0 : integer function null_how_many_extra_profile_columns(id)
150 : integer, intent(in) :: id
151 : type (star_info), pointer :: s
152 : integer :: ierr
153 0 : call star_ptr(id, s, ierr)
154 0 : if (ierr /= 0) then ! failure in ptr
155 : return
156 : end if
157 0 : null_how_many_extra_profile_columns=0
158 :
159 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "how_many_extra_profile_columns")
160 :
161 0 : end function null_how_many_extra_profile_columns
162 :
163 :
164 0 : subroutine null_data_for_extra_profile_columns(id, n, nz, names, vals, ierr)
165 : integer, intent(in) :: id
166 : integer, intent(in) :: n, nz
167 : character (len=maxlen_profile_column_name) :: names(n)
168 : real(dp) :: vals(nz,n)
169 : integer, intent(out) :: ierr
170 : type (star_info), pointer :: s
171 0 : call star_ptr(id, s, ierr)
172 0 : if (ierr /= 0) then ! failure in ptr
173 0 : return
174 : end if
175 :
176 0 : call warn_run_star_extras(s%job%warn_run_star_extras, "data_for_extra_profile_columns")
177 :
178 : end subroutine null_data_for_extra_profile_columns
179 :
180 :
181 0 : subroutine warn_run_star_extras(warn, routine)
182 : logical, intent(in) :: warn
183 : character(len=*), intent(in) :: routine
184 :
185 0 : if (warn) then
186 0 : write(*,*) "WARNING: you are calling a null version of " // trim(routine)
187 0 : write(*,'(A)')
188 0 : write(*,*) "If you have customized your run_star_extras.f file, your routine is not being called."
189 0 : write(*,*) "Check that your extras_controls has a line like"
190 0 : write(*,*) " s% " // trim(routine) // " => " // trim(routine)
191 0 : write(*,*) "See $MESA_DIR/star/job/standard_run_star_extras.inc for the standard example."
192 0 : write(*,'(A)')
193 0 : write(*,*) "This error can also occur if you switched MESA versions without recompiling."
194 0 : write(*,*) "Do a ./clean and ./mk in your work directory to get recompiled."
195 0 : write(*,'(A)')
196 0 : write(*,*) "To disable this warning set"
197 0 : write(*,*) " warn_run_star_extras = .false."
198 0 : write(*,*) "in your star_job inlist."
199 0 : write(*,'(A)')
200 0 : write(*,*) "MESA exited due to run_star_extras warning."
201 0 : stop
202 : end if
203 :
204 0 : end subroutine warn_run_star_extras
205 :
206 :
207 : end module other_extras
|
