Line data Source code
1 : ! ***********************************************************************
2 : !
3 : ! Copyright (C) 2010 Rich Townsend & 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 utils_lib
21 :
22 : use utils_def, only: max_io_unit
23 : use const_def, only: dp, qp, strlen
24 : use utils_nan
25 :
26 : implicit none
27 :
28 : logical :: assigned(max_io_unit) = .false.
29 :
30 : character(*), private, parameter :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz'
31 : character(*), private, parameter :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
32 :
33 : contains
34 :
35 1311 : integer function utils_OMP_GET_THREAD_NUM()
36 : use utils_openmp, only: eval_OMP_GET_THREAD_NUM
37 1311 : utils_OMP_GET_THREAD_NUM = eval_OMP_GET_THREAD_NUM()
38 1311 : end function utils_OMP_GET_THREAD_NUM
39 :
40 :
41 20 : integer function utils_OMP_GET_MAX_THREADS()
42 : use utils_openmp, only: eval_OMP_GET_MAX_THREADS
43 20 : utils_OMP_GET_MAX_THREADS = eval_OMP_GET_MAX_THREADS()
44 20 : end function utils_OMP_GET_MAX_THREADS
45 :
46 :
47 0 : subroutine utils_OMP_SET_NUM_THREADS(threads)
48 : use utils_openmp, only: eval_OMP_SET_NUM_THREADS
49 : integer :: threads
50 0 : call eval_OMP_SET_NUM_THREADS(threads)
51 0 : end subroutine utils_OMP_SET_NUM_THREADS
52 :
53 :
54 2 : subroutine get_compiler_version(compiler_name,compiler_version_name)
55 : character(len=*) :: compiler_name, compiler_version_name
56 : integer, save :: intel_compiler_build_date = 0, gcc_major = 0, gcc_minor = 0, gcc_patch = 0
57 : character(len=3) :: gcc_major_string, gcc_minor_string, gcc_patch_string
58 : if (.false.) intel_compiler_build_date = 0
59 : #ifdef __INTEL_COMPILER
60 : compiler_name = "ifort"
61 : intel_compiler_build_date = __INTEL_COMPILER_BUILD_DATE
62 : write(compiler_version_name,'(i8)') intel_compiler_build_date
63 : #elif __GFORTRAN__
64 2 : compiler_name = "gfortran"
65 : !compiler_version_name = __VERSION__
66 2 : gcc_major = __GNUC__
67 2 : gcc_minor = __GNUC_MINOR__
68 2 : gcc_patch = __GNUC_PATCHLEVEL__
69 2 : write(gcc_major_string,'(i3)') gcc_major
70 2 : write(gcc_minor_string,'(i3)') gcc_minor
71 2 : write(gcc_patch_string,'(i3)') gcc_patch
72 : compiler_version_name = trim(adjustl(gcc_major_string)) // '.' &
73 : // trim(adjustl(gcc_minor_string)) // '.' &
74 2 : // trim(adjustl(gcc_patch_string))
75 : #else
76 : compiler_name = "unknown"
77 : compiler_version_name = "unknown"
78 : #endif
79 2 : end subroutine get_compiler_version
80 :
81 :
82 2 : subroutine get_mesasdk_version(version, ierr)
83 : character(len=*), intent(out) :: version
84 : integer, intent(out) :: ierr
85 : character(len=strlen) :: mesasdk_root, filename
86 : integer :: unit, root_len, name_len
87 :
88 2 : ierr = 0
89 2 : version = 'unknown' ! set here in case there is a problem below
90 :
91 2 : call get_environment_variable(name='MESASDK_VERSION', value=version, length=name_len, status=ierr)
92 2 : if (ierr /= 0) then
93 0 : ierr=0
94 0 : return
95 : end if
96 :
97 2 : call get_environment_variable(name='MESASDK_ROOT', value=mesasdk_root, length=root_len, status=ierr)
98 2 : if (ierr /= 0 .or. root_len==0) then
99 0 : ierr=0
100 0 : return
101 : end if
102 :
103 2 : filename=trim(mesasdk_root) // '/bin/mesasdk_version'
104 2 : open(newunit=unit, file=filename, status='old', action='read', iostat=ierr)
105 2 : if (ierr /= 0)then
106 0 : ierr=0
107 0 : return
108 : end if
109 :
110 2 : read(unit,'(A)')
111 2 : read(unit,'(A)')
112 2 : read(unit,'(A)')
113 2 : read(unit,'(A)')
114 2 : read(unit,'(5X, A)') version
115 :
116 2 : close(unit)
117 :
118 2 : call strip(version,'"')
119 :
120 2 : end subroutine get_mesasdk_version
121 :
122 :
123 2 : elemental subroutine strip(string,set)
124 : character(len=*), intent(inout) :: string
125 : character(len=*), intent(in) :: set
126 : integer :: old, new, stride
127 2 : old=1; new=1
128 4 : do
129 6 : stride=scan(string(old:),set)
130 6 : if(stride>0)then
131 4 : string(new:new+stride-2)=string(old:old+stride-2)
132 4 : old=old+stride
133 4 : new=new+stride-1
134 : else
135 2 : string(new:)=string(old:)
136 : return
137 : end if
138 : end do
139 : end subroutine strip
140 :
141 :
142 72 : subroutine realloc_double(ptr,new_size,ierr)
143 : real(dp), pointer :: ptr(:)
144 : integer, intent(in) :: new_size
145 : integer, intent(out) :: ierr
146 72 : real(dp), pointer :: new_ptr(:)
147 : integer :: i
148 72 : ierr = 0
149 72 : allocate(new_ptr(new_size),stat=ierr)
150 72 : if (ierr /= 0) return
151 72 : if (associated(ptr)) then
152 197627 : do i = 1, min(new_size,size(ptr,dim=1))
153 197627 : new_ptr(i) = ptr(i)
154 : end do
155 66 : deallocate(ptr)
156 : end if
157 72 : ptr => new_ptr
158 72 : end subroutine realloc_double
159 :
160 :
161 2 : subroutine realloc_double2(ptr,new_size1,new_size2,ierr)
162 : real(dp), pointer :: ptr(:,:)
163 : integer, intent(in) :: new_size1,new_size2
164 : integer, intent(out) :: ierr
165 2 : real(dp), pointer :: new_ptr(:,:)
166 : integer :: i1,i2, i,j
167 2 : ierr = 0
168 2 : allocate(new_ptr(new_size1,new_size2),stat=ierr)
169 2 : if (ierr /= 0) return
170 2 : if (associated(ptr)) then
171 2 : i1 = min(new_size1,size(ptr,dim=1))
172 2 : i2 = min(new_size2,size(ptr,dim=2))
173 : ! ifort uses stack for array copy temp storage
174 : ! for large copies, this can produce seg faults
175 : ! doing the explicit loops seems to be safe
176 : !new_ptr(1:i1,1:i2) = ptr(1:i1,1:i2)
177 18 : do i=1,i1
178 50 : do j=1,i2
179 48 : new_ptr(i,j) = ptr(i,j)
180 : end do
181 : end do
182 2 : deallocate(ptr)
183 : end if
184 2 : ptr => new_ptr
185 2 : end subroutine realloc_double2
186 :
187 :
188 0 : subroutine realloc_quad(ptr,new_size,ierr)
189 : real(qp), pointer :: ptr(:)
190 : integer, intent(in) :: new_size
191 : integer, intent(out) :: ierr
192 0 : real(qp), pointer :: new_ptr(:)
193 : integer :: i
194 0 : ierr = 0
195 0 : allocate(new_ptr(new_size),stat=ierr)
196 0 : if (ierr /= 0) return
197 0 : if (associated(ptr)) then
198 0 : do i = 1, min(new_size,size(ptr,dim=1))
199 0 : new_ptr(i) = ptr(i)
200 : end do
201 0 : deallocate(ptr)
202 : end if
203 0 : ptr => new_ptr
204 0 : end subroutine realloc_quad
205 :
206 :
207 0 : subroutine realloc_quad2(ptr,new_size1,new_size2,ierr)
208 : real(qp), pointer :: ptr(:,:)
209 : integer, intent(in) :: new_size1,new_size2
210 : integer, intent(out) :: ierr
211 0 : real(qp), pointer :: new_ptr(:,:)
212 : integer :: i1,i2, i,j
213 0 : ierr = 0
214 0 : allocate(new_ptr(new_size1,new_size2),stat=ierr)
215 0 : if (ierr /= 0) return
216 0 : if (associated(ptr)) then
217 0 : i1 = min(new_size1,size(ptr,dim=1))
218 0 : i2 = min(new_size2,size(ptr,dim=2))
219 : ! ifort uses stack for array copy temp storage
220 : ! for large copies, this can produce seg faults
221 : ! doing the explicit loops seems to be safe
222 : !new_ptr(1:i1,1:i2) = ptr(1:i1,1:i2)
223 0 : do i=1,i1
224 0 : do j=1,i2
225 0 : new_ptr(i,j) = ptr(i,j)
226 : end do
227 : end do
228 0 : deallocate(ptr)
229 : end if
230 0 : ptr => new_ptr
231 0 : end subroutine realloc_quad2
232 :
233 :
234 0 : subroutine realloc_double3(ptr,new_size1,new_size2,new_size3,ierr)
235 : real(dp), pointer :: ptr(:,:,:)
236 : integer, intent(in) :: new_size1,new_size2,new_size3
237 : integer, intent(out) :: ierr
238 0 : real(dp), pointer :: new_ptr(:,:,:)
239 : integer :: i1,i2,i3, i,j,k
240 0 : ierr = 0
241 0 : allocate(new_ptr(new_size1,new_size2,new_size3),stat=ierr)
242 0 : if (ierr /= 0) return
243 0 : if (associated(ptr)) then
244 0 : i1 = min(new_size1,size(ptr,dim=1))
245 0 : i2 = min(new_size2,size(ptr,dim=2))
246 0 : i3 = min(new_size3,size(ptr,dim=3))
247 : ! ifort uses stack for array copy temp storage
248 : ! for large copies, this can produce seg faults
249 : ! doing the explicit loops seems to be safe
250 : !new_ptr(1:i1,1:i2,1:i3) = ptr(1:i1,1:i2,1:i3)
251 0 : do i=1,i1
252 0 : do j=1,i2
253 0 : do k=1,i3
254 0 : new_ptr(i,j,k) = ptr(i,j,k)
255 : end do
256 : end do
257 : end do
258 0 : deallocate(ptr)
259 : end if
260 0 : ptr => new_ptr
261 0 : end subroutine realloc_double3
262 :
263 :
264 0 : subroutine realloc_real(ptr,new_size,ierr)
265 : real, pointer :: ptr(:)
266 : integer, intent(in) :: new_size
267 : integer, intent(out) :: ierr
268 0 : real, pointer :: new_ptr(:)
269 : integer :: i
270 0 : ierr = 0
271 0 : allocate(new_ptr(new_size),stat=ierr)
272 0 : if (ierr /= 0) return
273 0 : if (associated(ptr)) then
274 0 : do i=1,min(new_size,size(ptr,dim=1))
275 0 : new_ptr(i) = ptr(i)
276 : end do
277 0 : deallocate(ptr)
278 : end if
279 0 : ptr => new_ptr
280 0 : end subroutine realloc_real
281 :
282 :
283 37 : subroutine realloc_integer(ptr,new_size,ierr)
284 : integer, pointer :: ptr(:)
285 : integer, intent(in) :: new_size
286 : integer, intent(out) :: ierr
287 37 : integer, pointer :: new_ptr(:)
288 : integer :: i
289 37 : ierr = 0
290 37 : allocate(new_ptr(new_size),stat=ierr)
291 37 : if (ierr /= 0) return
292 37 : if (associated(ptr)) then
293 9082 : do i = 1, min(new_size,size(ptr,dim=1))
294 9082 : new_ptr(i) = ptr(i)
295 : end do
296 37 : deallocate(ptr)
297 : end if
298 37 : ptr => new_ptr
299 37 : end subroutine realloc_integer
300 :
301 :
302 27 : subroutine realloc_integer2(ptr,new_size1,new_size2,ierr)
303 : integer, pointer :: ptr(:,:)
304 : integer, intent(in) :: new_size1,new_size2
305 : integer, intent(out) :: ierr
306 27 : integer, pointer :: new_ptr(:,:)
307 : integer :: i1,i2, i,j
308 27 : ierr = 0
309 27 : allocate(new_ptr(new_size1,new_size2),stat=ierr)
310 27 : if (ierr /= 0) return
311 27 : if (associated(ptr)) then
312 27 : i1 = min(new_size1,size(ptr,dim=1))
313 27 : i2 = min(new_size2,size(ptr,dim=2))
314 : ! ifort uses stack for array copy temp storage
315 : ! for large copies, this can produce seg faults
316 : ! doing the explicit loops seems to be safe
317 : !new_ptr(1:i1,1:i2) = ptr(1:i1,1:i2)
318 140 : do i=1,i1
319 32391 : do j=1,i2
320 32364 : new_ptr(i,j) = ptr(i,j)
321 : end do
322 : end do
323 27 : deallocate(ptr)
324 : end if
325 27 : ptr => new_ptr
326 27 : end subroutine realloc_integer2
327 :
328 :
329 0 : subroutine realloc_logical(ptr,new_size,ierr)
330 : logical, pointer :: ptr(:)
331 : integer, intent(in) :: new_size
332 : integer, intent(out) :: ierr
333 0 : logical, pointer :: new_ptr(:)
334 : integer :: i
335 0 : ierr = 0
336 0 : allocate(new_ptr(new_size),stat=ierr)
337 0 : if (ierr /= 0) return
338 0 : if (associated(ptr)) then
339 0 : do i = 1, min(new_size,size(ptr,dim=1))
340 0 : new_ptr(i) = ptr(i)
341 : end do
342 0 : deallocate(ptr)
343 : end if
344 0 : ptr => new_ptr
345 0 : end subroutine realloc_logical
346 :
347 :
348 0 : subroutine do1D(ptr,sz,dealloc,ierr)
349 : real(dp),dimension(:),pointer::ptr
350 : integer, intent(in) :: sz
351 : logical, intent(in) :: dealloc
352 : integer, intent(out) :: ierr
353 0 : if (dealloc) then
354 0 : deallocate(ptr,stat=ierr)
355 : else
356 0 : allocate(ptr(sz),stat=ierr)
357 : end if
358 0 : end subroutine do1D
359 :
360 :
361 0 : subroutine do2D(ptr,sz1,sz2,dealloc,ierr)
362 : real(dp),dimension(:,:),pointer::ptr
363 : integer, intent(in) :: sz1,sz2
364 : logical, intent(in) :: dealloc
365 : integer, intent(out) :: ierr
366 0 : if (dealloc) then
367 0 : deallocate(ptr,stat=ierr)
368 : else
369 0 : allocate(ptr(sz1,sz2),stat=ierr)
370 : end if
371 0 : end subroutine do2D
372 :
373 :
374 0 : subroutine do3D(ptr,sz1,sz2,sz3,dealloc,ierr)
375 : real(dp),dimension(:,:,:),pointer::ptr
376 : integer, intent(in) :: sz1,sz2,sz3
377 : logical, intent(in) :: dealloc
378 : integer, intent(out) :: ierr
379 0 : if (dealloc) then
380 0 : deallocate(ptr,stat=ierr)
381 : else
382 0 : allocate(ptr(sz1,sz2,sz3),stat=ierr)
383 : end if
384 0 : end subroutine do3D
385 :
386 :
387 0 : subroutine do4D(ptr,sz1,sz2,sz3,sz4,dealloc,ierr)
388 : real(dp),dimension(:,:,:,:),pointer::ptr
389 : integer, intent(in) :: sz1,sz2,sz3,sz4
390 : logical, intent(in) :: dealloc
391 : integer, intent(out) :: ierr
392 0 : if (dealloc) then
393 0 : deallocate(ptr,stat=ierr)
394 : else
395 0 : allocate(ptr(sz1,sz2,sz3,sz4),stat=ierr)
396 : end if
397 0 : end subroutine do4D
398 :
399 :
400 0 : subroutine do1D_integer(ptr,sz,dealloc,ierr)
401 : integer,dimension(:),pointer::ptr
402 : integer, intent(in) :: sz
403 : logical, intent(in) :: dealloc
404 : integer, intent(out) :: ierr
405 0 : if (dealloc) then
406 0 : deallocate(ptr,stat=ierr)
407 : else
408 0 : allocate(ptr(sz),stat=ierr)
409 : end if
410 0 : end subroutine do1D_integer
411 :
412 :
413 0 : subroutine do2D_integer(ptr,sz1,sz2,dealloc,ierr)
414 : integer,dimension(:,:),pointer::ptr
415 : integer, intent(in) :: sz1,sz2
416 : logical, intent(in) :: dealloc
417 : integer, intent(out) :: ierr
418 0 : if (dealloc) then
419 0 : deallocate(ptr,stat=ierr)
420 : else
421 0 : allocate(ptr(sz1,sz2),stat=ierr)
422 : end if
423 0 : end subroutine do2D_integer
424 :
425 :
426 0 : subroutine do1D_logical(ptr,sz,dealloc,ierr)
427 : logical,dimension(:),pointer::ptr
428 : integer, intent(in) :: sz
429 : logical, intent(in) :: dealloc
430 : integer, intent(out) :: ierr
431 0 : if (dealloc) then
432 0 : deallocate(ptr,stat=ierr)
433 : else
434 0 : allocate(ptr(sz),stat=ierr)
435 : end if
436 0 : end subroutine do1D_logical
437 :
438 :
439 0 : subroutine alloc1(sz,a,ierr)
440 : real(dp), dimension(:), pointer :: a
441 : integer, intent(in) :: sz
442 : integer, intent(out) :: ierr
443 0 : allocate(a(sz),stat=ierr); if (ierr /= 0) return
444 : end subroutine alloc1
445 :
446 :
447 0 : subroutine alloc2(sz1,sz2,a,ierr)
448 : real(dp), dimension(:,:), pointer :: a
449 : integer, intent(in) :: sz1,sz2
450 : integer, intent(out) :: ierr
451 0 : allocate(a(sz1,sz2),stat=ierr); if (ierr /= 0) return
452 : end subroutine alloc2
453 :
454 :
455 0 : subroutine alloc3(sz1,sz2,sz3,a,ierr)
456 : real(dp), dimension(:,:,:), pointer :: a
457 : integer, intent(in) :: sz1,sz2,sz3
458 : integer, intent(out) :: ierr
459 0 : allocate(a(sz1,sz2,sz3),stat=ierr); if (ierr /= 0) return
460 : end subroutine alloc3
461 :
462 :
463 66 : subroutine realloc_if_needed_1(ptr,sz,extra,ierr)
464 : real(dp), pointer :: ptr(:)
465 : integer, intent(in) :: sz, extra
466 : integer, intent(out) :: ierr
467 66 : ierr = 0
468 66 : if (associated(ptr)) then
469 60 : if (size(ptr,dim=1) >= sz) return
470 : end if
471 6 : call realloc_double(ptr, sz + extra, ierr)
472 : end subroutine realloc_if_needed_1
473 :
474 :
475 0 : subroutine quad_realloc_if_needed_1(ptr,sz,extra,ierr)
476 : real(qp), pointer :: ptr(:)
477 : integer, intent(in) :: sz, extra
478 : integer, intent(out) :: ierr
479 0 : ierr = 0
480 0 : if (associated(ptr)) then
481 0 : if (size(ptr,dim=1) >= sz) return
482 : end if
483 0 : call realloc_quad(ptr, sz + extra, ierr)
484 : end subroutine quad_realloc_if_needed_1
485 :
486 :
487 0 : subroutine realloc_integer_if_needed_1(ptr,sz,extra,ierr)
488 : integer, pointer :: ptr(:)
489 : integer, intent(in) :: sz, extra
490 : integer, intent(out) :: ierr
491 0 : ierr = 0
492 0 : if (associated(ptr)) then
493 0 : if (size(ptr,dim=1) >= sz) return
494 : end if
495 0 : call realloc_integer(ptr, sz + extra, ierr)
496 : end subroutine realloc_integer_if_needed_1
497 :
498 :
499 0 : subroutine enlarge_if_needed_1(ptr,sz,extra,ierr)
500 : real(dp), pointer :: ptr(:)
501 : integer, intent(in) :: sz, extra
502 : integer, intent(out) :: ierr
503 0 : ierr = 0
504 0 : if (associated(ptr)) then
505 0 : if (size(ptr,dim=1) >= sz) return
506 0 : deallocate(ptr)
507 : end if
508 0 : allocate(ptr(sz + extra), stat=ierr)
509 : end subroutine enlarge_if_needed_1
510 :
511 :
512 22 : subroutine enlarge_if_needed_2(ptr,sz1,sz2,extra,ierr)
513 : real(dp), pointer :: ptr(:,:)
514 : integer, intent(in) :: sz1, sz2, extra
515 : integer, intent(out) :: ierr
516 22 : ierr = 0
517 22 : if (associated(ptr)) then
518 20 : if (size(ptr,1) == sz1 .and. size(ptr,2) >= sz2) return
519 0 : deallocate(ptr)
520 : end if
521 4 : allocate(ptr(sz1, sz2 + extra), stat=ierr)
522 : end subroutine enlarge_if_needed_2
523 :
524 :
525 0 : subroutine quad_enlarge_if_needed_1(ptr,sz,extra,ierr)
526 : real(qp), pointer :: ptr(:)
527 : integer, intent(in) :: sz, extra
528 : integer, intent(out) :: ierr
529 0 : ierr = 0
530 0 : if (associated(ptr)) then
531 0 : if (size(ptr,dim=1) >= sz) return
532 0 : deallocate(ptr)
533 : end if
534 0 : allocate(ptr(sz + extra), stat=ierr)
535 : end subroutine quad_enlarge_if_needed_1
536 :
537 :
538 0 : subroutine enlarge_integer_if_needed_1(ptr,sz,extra,ierr)
539 : integer, pointer :: ptr(:)
540 : integer, intent(in) :: sz, extra
541 : integer, intent(out) :: ierr
542 0 : ierr = 0
543 0 : if (associated(ptr)) then
544 0 : if (size(ptr,dim=1) >= sz) return
545 0 : deallocate(ptr)
546 : end if
547 0 : allocate(ptr(sz + extra), stat=ierr)
548 : end subroutine enlarge_integer_if_needed_1
549 :
550 :
551 0 : subroutine remove_underbars(str, name)
552 : character (len=*), intent(in) :: str
553 : character (len=*), intent(out) :: name
554 : integer :: i, len
555 0 : len = len_trim(str)
556 0 : name = ''
557 0 : do i=1,len
558 0 : if (str(i:i) == '_') then
559 0 : name(i:i) = ' '
560 : else
561 0 : name(i:i) = str(i:i)
562 : end if
563 : end do
564 0 : end subroutine remove_underbars
565 :
566 :
567 1770 : integer function token(iounit, n, i, buffer, string)
568 : use utils_def
569 : integer, intent(in) :: iounit
570 : integer, intent(inout) :: n ! number of characters currently in buffer
571 : integer, intent(inout) :: i ! number of characters already read from buffer
572 : character (len=*), intent(inout) :: buffer ! line of text from input file
573 : character (len=*), intent(inout) :: string ! holds string or name for string or name token
574 :
575 : integer :: info, j, j1, j2, l, str_len
576 :
577 1770 : token = 0
578 1770 : info = 0
579 :
580 : line_loop: do
581 7613 : do while (i >= n)
582 3976 : read(iounit,fmt='(a)',iostat=info) buffer
583 3976 : if (info /= 0) then
584 1770 : token = eof_token
585 : return
586 : end if
587 3909 : n = len_trim(buffer)
588 7546 : i = 0
589 : !write(*,'(i6,3x,a)') n, trim(buffer)
590 : end do
591 20128 : token_loop: do while (i < n) ! have non-empty buffer
592 20128 : i = i+1
593 20128 : if (buffer(i:i) == char(9)) cycle token_loop ! skip tabs
594 0 : select case(buffer(i:i))
595 : case ('!')
596 1934 : i = n
597 1934 : cycle line_loop
598 : case (' ')
599 : cycle token_loop
600 : case ('&') ! ignore &'s
601 : cycle token_loop
602 : case ('(')
603 1770 : token = left_paren_token; return
604 : case (')')
605 : token = right_paren_token; return
606 : case (',')
607 1 : token = comma_token; return
608 : case ('"')
609 1 : j = 1; str_len = len(string)
610 9 : do
611 10 : i = i+1
612 10 : if (i > n) exit
613 10 : if (buffer(i:i) == '"') exit
614 9 : if (j > str_len) exit
615 9 : string(j:j) = buffer(i:i)
616 10 : j = j+1
617 : end do
618 248 : do while (j <= str_len)
619 247 : string(j:j) = ' '
620 247 : j = j+1
621 : end do
622 : token = string_token
623 87 : return
624 : case ('''')
625 87 : j = 1; str_len = len(string)
626 1315 : do
627 1402 : i = i+1
628 1402 : if (i > n) exit
629 1402 : if (buffer(i:i) == '''') exit
630 1315 : if (j > str_len) exit
631 1315 : string(j:j) = buffer(i:i)
632 1402 : j = j+1
633 : end do
634 21044 : do while (j <= str_len)
635 20957 : string(j:j) = ' '
636 21044 : j = j+1
637 : end do
638 : token = string_token
639 : return
640 : case default
641 : j1 = i; j2 = i
642 14654 : name_loop: do
643 16050 : if (i+1 > n) exit name_loop
644 15135 : if (buffer(i+1:i+1) == ' ') exit name_loop
645 14836 : if (buffer(i+1:i+1) == '(') exit name_loop
646 : if (buffer(i+1:i+1) == ')') exit name_loop
647 : if (buffer(i+1:i+1) == ',') exit name_loop
648 14654 : i = i+1
649 14953 : j2 = i
650 : end do name_loop
651 1396 : str_len = len(string)
652 1396 : l = j2-j1+1
653 1396 : if (l > str_len) then
654 0 : l = str_len
655 0 : j2 = l+j1-1
656 : end if
657 1396 : string(1:l) = buffer(j1:j2)
658 342722 : do j = l+1, str_len
659 342722 : string(j:j) = ' '
660 : end do
661 : token = name_token
662 20128 : return
663 : end select
664 : end do token_loop
665 : end do line_loop
666 :
667 : end function token
668 :
669 :
670 555198 : subroutine integer_dict_define_and_report_duplicates(dict, key, value, duplicate, ierr)
671 : use utils_dict
672 : type (integer_dict), pointer :: dict ! pass null for empty dict
673 : character (len=*), intent(in) :: key
674 : integer, intent(in) :: value
675 : logical, intent(out) :: duplicate ! true if key was already defined
676 : ! if already defined, old value is replaced by new one.
677 : integer, intent(out) :: ierr ! error if len_trim(key) > maxlen_key_string
678 7 : call do_integer_dict_define(dict, key, value, duplicate, ierr)
679 7 : end subroutine integer_dict_define_and_report_duplicates
680 :
681 :
682 1110382 : subroutine integer_dict_define(dict, key, value, ierr)
683 : use utils_def, only: integer_dict
684 : type (integer_dict), pointer :: dict ! pass null for empty dict
685 : character (len=*), intent(in) :: key
686 : integer, intent(in) :: value
687 : integer, intent(out) :: ierr ! error if len_trim(key) > maxlen_key_string
688 : logical :: duplicate
689 555191 : call integer_dict_define_and_report_duplicates(dict, key, value, duplicate, ierr)
690 555191 : end subroutine integer_dict_define
691 :
692 :
693 130 : subroutine integer_dict_create_hash(dict, ierr)
694 : use utils_dict
695 : type (integer_dict), pointer :: dict
696 : integer, intent(out) :: ierr
697 130 : call do_integer_dict_create_hash(dict, ierr)
698 130 : end subroutine integer_dict_create_hash
699 :
700 :
701 510345 : subroutine integer_dict_lookup(dict, key, value, ierr)
702 : use utils_dict
703 : type (integer_dict), pointer :: dict
704 : character (len=*), intent(in) :: key
705 : integer, intent(out) :: value
706 : integer, intent(out) :: ierr ! 0 if found key in dict, -1 if didn't
707 510345 : call do_integer_dict_lookup(dict, key, value, ierr)
708 510345 : end subroutine integer_dict_lookup
709 :
710 :
711 0 : integer function integer_dict_size(dict) ! number of entries
712 : use utils_dict
713 : type (integer_dict), pointer :: dict
714 0 : integer_dict_size = size_integer_dict(dict)
715 0 : end function integer_dict_size
716 :
717 :
718 0 : subroutine integer_dict_map(dict, fcn)
719 : use utils_dict
720 : type (integer_dict), pointer :: dict
721 : interface
722 : subroutine fcn(key, value, ierr)
723 : implicit none
724 : character (len=*), intent(in) :: key
725 : integer, intent(in) :: value
726 : integer, intent(out) :: ierr ! /= 0 means terminate map calls
727 : end subroutine fcn
728 : end interface
729 : integer :: ierr
730 0 : call do_integer_dict_map(dict, fcn, ierr)
731 0 : end subroutine integer_dict_map
732 :
733 :
734 0 : subroutine get_dict_entries(dict, keys, values)
735 : use utils_dict
736 : type (integer_dict), pointer :: dict
737 : character (len=maxlen_key_string), pointer :: keys(:)
738 : integer, pointer :: values(:)
739 0 : call do_get_dict_entries(dict, keys, values)
740 0 : end subroutine get_dict_entries
741 :
742 :
743 37 : subroutine integer_dict_free(dict)
744 : use utils_dict
745 : type (integer_dict), pointer :: dict
746 37 : call do_integer_dict_free(dict)
747 37 : end subroutine integer_dict_free
748 :
749 :
750 7 : subroutine integer_idict_define_and_report_duplicates(idict, key1, key2, value, duplicate, ierr)
751 : use utils_idict
752 : type (integer_idict), pointer :: idict ! pass null for empty idict
753 : integer, intent(in) :: key1, key2, value
754 : logical, intent(out) :: duplicate ! true if key was already defined
755 : ! if already defined, old value is replaced by new one.
756 : integer, intent(out) :: ierr
757 7 : call do_integer_idict_define(idict, key1, key2, value, duplicate, ierr)
758 7 : end subroutine integer_idict_define_and_report_duplicates
759 :
760 :
761 0 : subroutine integer_idict_define(idict, key1, key2, value, ierr)
762 : use utils_def, only: integer_idict
763 : type (integer_idict), pointer :: idict ! pass null for empty idict
764 : integer, intent(in) :: key1, key2, value
765 : integer, intent(out) :: ierr
766 : logical :: duplicate
767 : call integer_idict_define_and_report_duplicates( &
768 0 : idict, key1, key2, value, duplicate, ierr)
769 0 : end subroutine integer_idict_define
770 :
771 :
772 1 : subroutine integer_idict_create_hash(idict, ierr)
773 : use utils_idict
774 : type (integer_idict), pointer :: idict
775 : integer, intent(out) :: ierr
776 1 : call do_integer_idict_create_hash(idict, ierr)
777 1 : end subroutine integer_idict_create_hash
778 :
779 :
780 4 : subroutine integer_idict_lookup(idict, key1, key2, value, ierr)
781 : use utils_idict
782 : type (integer_idict), pointer :: idict
783 : integer, intent(in) :: key1, key2
784 : integer, intent(out) :: value
785 : integer, intent(out) :: ierr ! 0 if found key in idict, -1 if didn't
786 4 : call do_integer_idict_lookup(idict, key1, key2, value, ierr)
787 4 : end subroutine integer_idict_lookup
788 :
789 :
790 0 : integer function integer_idict_size(idict) ! number of entries
791 : use utils_idict
792 : type (integer_idict), pointer :: idict
793 0 : integer_idict_size = size_integer_idict(idict)
794 0 : end function integer_idict_size
795 :
796 :
797 0 : subroutine integer_idict_map(idict, fcn)
798 : use utils_idict
799 : type (integer_idict), pointer :: idict
800 : interface
801 : subroutine fcn(key1, key2, value, ierr)
802 : implicit none
803 : integer, intent(in) :: key1, key2, value
804 : integer, intent(out) :: ierr ! /= 0 means terminate map calls
805 : end subroutine fcn
806 : end interface
807 : integer :: ierr
808 0 : call do_integer_idict_map(idict, fcn, ierr)
809 0 : end subroutine integer_idict_map
810 :
811 :
812 0 : subroutine get_idict_entries(idict, key1s, key2s, values)
813 : use utils_idict
814 : type (integer_idict), pointer :: idict
815 : integer, pointer, dimension(:) :: key1s, key2s, values
816 0 : call do_get_idict_entries(idict, key1s, key2s, values)
817 0 : end subroutine get_idict_entries
818 :
819 :
820 1 : subroutine integer_idict_free(idict)
821 : use utils_idict
822 : type (integer_idict), pointer :: idict
823 1 : call do_integer_idict_free(idict)
824 1 : end subroutine integer_idict_free
825 :
826 :
827 0 : function StrUpCase ( Input_String ) result ( Output_String )
828 : character(len=*), intent(in) :: Input_String
829 : character(len(Input_string)) :: Output_String
830 : integer :: i, n
831 0 : Output_String = Input_String
832 0 : do i = 1, len( Output_String )
833 0 : n = index( LOWER_CASE, Output_String( i:i ) )
834 0 : if ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n )
835 : end do
836 0 : end function StrUpCase
837 :
838 :
839 1236 : function StrLowCase ( Input_String ) result ( Output_String )
840 : character(len=*), intent(in) :: Input_String
841 : character(len(Input_string)) :: Output_String
842 : integer :: i, n
843 1236 : Output_String = Input_String
844 120532 : do i = 1, len( Output_String )
845 119296 : n = index( UPPER_CASE, Output_String( i:i ) )
846 120532 : if ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n )
847 : end do
848 1236 : end function StrLowCase
849 :
850 :
851 52 : subroutine mkdir(folder)
852 : use utils_system, only : mkdir_p
853 : character(len=*), intent(in) :: folder
854 : integer :: res
855 :
856 52 : res = mkdir_p(folder)
857 :
858 52 : if(res/=0)then
859 0 : write(*,*) "mkdir failed for ",trim(folder)
860 0 : write(*,*) "error code ",res
861 0 : call mesa_error(__FILE__,__LINE__)
862 : end if
863 :
864 52 : end subroutine mkdir
865 :
866 211 : subroutine mv(file_in,file_out,skip_errors)
867 : use utils_system, only: mv_c => mv
868 : character(len=*),intent(in) :: file_in,file_out
869 : logical, optional, intent(in) :: skip_errors
870 : integer :: res
871 :
872 211 : res = mv_c(file_in,file_out)
873 :
874 211 : if(res/=0)then
875 0 : if (present(skip_errors))then
876 0 : if (skip_errors) then
877 0 : write(*,*) "mv failed for '"//trim(file_in)//"' '"//trim(file_out)//"' skipping"
878 : else
879 0 : call error()
880 : end if
881 : else
882 0 : call error()
883 : end if
884 : end if
885 :
886 : contains
887 :
888 0 : subroutine error()
889 0 : write(*,*) "mv failed for '"//trim(file_in)//"' '"//trim(file_out)//"'"
890 0 : write(*,*) "Error code: ",res
891 0 : call mesa_error(__FILE__,__LINE__)
892 : end subroutine error
893 :
894 : end subroutine mv
895 :
896 0 : subroutine cp_file(file_in,file_out,skip_errors)
897 : use utils_system, only: cp_c => cp
898 : character(len=*),intent(in) :: file_in,file_out
899 : logical, optional, intent(in) :: skip_errors
900 : integer :: res
901 :
902 0 : res = cp_c(file_in,file_out)
903 :
904 0 : if(res/=0)then
905 0 : if (present(skip_errors))then
906 0 : if (skip_errors) then
907 0 : write(*,*) "cp failed for '"//trim(file_in)//"' '"//trim(file_out)//"' skipping"
908 : else
909 0 : call error()
910 : end if
911 : else
912 0 : call error()
913 : end if
914 : end if
915 :
916 : contains
917 :
918 0 : subroutine error()
919 0 : write(*,*) "cp failed for '"//trim(file_in)//"' '"//trim(file_out)//"'"
920 0 : write(*,*) "Error code: ",res
921 0 : call mesa_error(__FILE__,__LINE__)
922 : end subroutine error
923 :
924 : end subroutine cp_file
925 :
926 8 : logical function folder_exists(folder)
927 : use utils_system, only: is_dir
928 : character(len=*),intent(in) :: folder
929 :
930 8 : folder_exists = is_dir(folder)
931 :
932 8 : end function folder_exists
933 :
934 237 : integer function alloc_iounit(ierr)
935 : use utils_def
936 : integer, intent(out) :: ierr
937 : integer :: i
938 474 : !$omp critical (utils_alloc_io_unit)
939 237 : ierr = 0
940 237 : alloc_iounit = -1
941 355 : do i = min_io_unit, max_io_unit
942 355 : if (.not. assigned(i)) then
943 237 : assigned(i) = .true.
944 237 : alloc_iounit = i
945 237 : exit
946 : end if
947 : end do
948 : !$omp end critical (utils_alloc_io_unit)
949 237 : if (alloc_iounit == -1) then
950 0 : ierr = -1
951 : end if
952 237 : end function alloc_iounit
953 :
954 :
955 44 : integer function number_iounits_allocated()
956 : use utils_def
957 : integer :: i, cnt
958 44 : cnt = 0
959 88 : !$omp critical (utils_alloc_io_unit)
960 3168 : do i = min_io_unit, max_io_unit
961 3168 : if (assigned(i)) cnt = cnt + 1
962 : end do
963 : !$omp end critical (utils_alloc_io_unit)
964 44 : number_iounits_allocated = cnt
965 44 : end function number_iounits_allocated
966 :
967 :
968 237 : subroutine free_iounit(iounit)
969 : use utils_def
970 : integer, intent(in) :: iounit
971 : logical :: bad_iounit
972 237 : bad_iounit = .false.
973 474 : !$omp critical (utils_alloc_io_unit)
974 237 : if (iounit >= min_io_unit .and. iounit <= max_io_unit) then
975 237 : assigned(iounit) = .false.
976 : else
977 : bad_iounit = .true.
978 : end if
979 : !$omp end critical (utils_alloc_io_unit)
980 237 : if (bad_iounit) then
981 0 : write(*,*) 'called free_iounit with invalid arg', iounit
982 0 : stop 'free_iounit'
983 : end if
984 237 : end subroutine free_iounit
985 :
986 :
987 0 : subroutine append_line(n, arry, filename, format_str, initialize, ierr)
988 : integer, intent(in) :: n
989 : real(dp), intent(in) :: arry(n)
990 : character (len=256), intent(in) :: filename, format_str
991 : logical, intent(in) :: initialize
992 : integer, intent(out) :: ierr
993 : integer :: iounit
994 : ierr = 0
995 0 : iounit = alloc_iounit(ierr); if (ierr /= 0) return
996 0 : if (initialize) then
997 0 : open(unit=iounit, file=trim(filename), action='write', iostat=ierr)
998 : else
999 0 : open(unit=iounit, file=trim(filename), position='append', action='write', iostat=ierr)
1000 : end if
1001 0 : if (ierr /= 0) then
1002 0 : call free_iounit(iounit)
1003 0 : return
1004 : end if
1005 0 : write(unit=iounit, fmt=format_str) arry
1006 0 : close(iounit)
1007 0 : call free_iounit(iounit)
1008 : end subroutine append_line
1009 :
1010 :
1011 0 : subroutine append_data(n, arry, filename, format_str, initialize, ierr)
1012 : integer, intent(in) :: n
1013 : real(dp), intent(in) :: arry(n)
1014 : character (len=256), intent(in) :: filename, format_str
1015 : logical, intent(in) :: initialize
1016 : integer, intent(out) :: ierr
1017 : integer :: iounit, i
1018 : ierr = 0
1019 0 : iounit = alloc_iounit(ierr); if (ierr /= 0) return
1020 0 : if (initialize) then
1021 0 : open(unit=iounit, file=trim(filename), action='write', iostat=ierr)
1022 : else
1023 0 : open(unit=iounit, file=trim(filename), position='append', action='write', iostat=ierr)
1024 : end if
1025 0 : if (ierr /= 0) then
1026 0 : call free_iounit(iounit)
1027 0 : return
1028 : end if
1029 0 : do i=1,n
1030 0 : write(unit=iounit, fmt=format_str) arry(i)
1031 : end do
1032 0 : close(iounit)
1033 0 : call free_iounit(iounit)
1034 : end subroutine append_data
1035 :
1036 0 : subroutine append_data_filter_badnums(n, arry, filename, format_str, initialize, ierr)
1037 : integer, intent(in) :: n
1038 : real(dp), intent(in) :: arry(n)
1039 : character (len=256), intent(in) :: filename, format_str
1040 : logical, intent(in) :: initialize
1041 : integer, intent(out) :: ierr
1042 : integer :: iounit, i
1043 : ierr = 0
1044 0 : iounit = alloc_iounit(ierr); if (ierr /= 0) return
1045 0 : if (initialize) then
1046 0 : open(unit=iounit, file=trim(filename), action='write', iostat=ierr)
1047 : else
1048 0 : open(unit=iounit, file=trim(filename), position='append', action='write', iostat=ierr)
1049 : end if
1050 0 : if (ierr /= 0) then
1051 0 : call free_iounit(iounit)
1052 0 : return
1053 : end if
1054 0 : do i=1,n
1055 0 : if (is_bad(arry(i))) then
1056 0 : write(unit=iounit, fmt=format_str) -1d99
1057 : else
1058 0 : write(unit=iounit, fmt=format_str) arry(i)
1059 : end if
1060 : end do
1061 0 : close(iounit)
1062 0 : call free_iounit(iounit)
1063 : end subroutine append_data_filter_badnums
1064 :
1065 :
1066 0 : subroutine mesa_error(file, line,msg)
1067 : use iso_fortran_env, only: error_unit
1068 : character(len=*), intent(in) :: file
1069 : character(len=*), optional,intent(in) :: msg
1070 : integer, intent(in) :: line
1071 : character (len=strlen) :: bt_disable
1072 0 : if(present(msg)) then
1073 0 : write(error_unit,"(A, A, A, I4, A, A)") "File: ", file, ", Line: ",line,", Message: ",msg
1074 : else
1075 0 : write(error_unit,"(A, A, A, I4)") "File: ", file, ", Line: ", line
1076 : end if
1077 0 : call get_environment_variable("MESA_ERROR_BACKTRACE_DISABLE", bt_disable)
1078 0 : if (len_trim(bt_disable) > 0) then
1079 0 : stop 1
1080 : else
1081 0 : error stop 1
1082 : end if
1083 : end subroutine mesa_error
1084 :
1085 :
1086 : ! If flag is true return str1 else return str2
1087 211 : character(len=strlen) function switch_str(str1,str2,flag)
1088 : character(len=*), intent(in) :: str1,str2
1089 : logical, intent(in) :: flag
1090 : logical, parameter :: dbg=.false.
1091 :
1092 211 : if(flag) then
1093 211 : switch_str=str1(1:min(len_trim(str1),strlen))
1094 : if(len_trim(str1) > strlen .and. dbg) &
1095 : write(*,*) "Warning ",trim(str1), "truncated to ",switch_str
1096 : else
1097 0 : switch_str=str2(1:min(len_trim(str2),strlen))
1098 : if(len_trim(str2) > strlen .and. dbg) &
1099 : write(*,*) "Warning ",trim(str2), "truncated to ",switch_str
1100 : end if
1101 :
1102 211 : end function switch_str
1103 :
1104 2 : subroutine split_line(line, num, out)
1105 : ! Given a string line, split on whitespace, into num sub-strings storing them in out
1106 : character(len=*),intent(in) :: line
1107 : integer, intent(in) :: num
1108 : character(len=*),dimension(:) :: out
1109 :
1110 : integer :: i,kstart,k
1111 :
1112 2 : if(size(out)<num) call mesa_error(__FILE__,__LINE__,'out array not large enough for num sub-strings')
1113 :
1114 30 : out = ''
1115 :
1116 : k = 1
1117 : kstart = 1
1118 30 : outer: do i=1, num
1119 2 : inner: do
1120 8192 : if(k < len(line)) then
1121 8190 : if(line(k:k)==' ' .and. line(k+1:k+1)==' ') then
1122 : k = k+1
1123 : cycle inner
1124 : end if
1125 : end if
1126 :
1127 92 : if(line(k:k)==' ' .or. k >= len(line))then
1128 : !write(*,*) '*',i,kstart,k,line(kstart:k-1)
1129 28 : out(i) = line(kstart:k-1)
1130 28 : k = k+1
1131 28 : kstart = k
1132 : cycle outer
1133 : end if
1134 64 : k = k + 1
1135 : end do inner
1136 : end do outer
1137 :
1138 2 : end subroutine split_line
1139 :
1140 :
1141 : ! backward compatibility so Bill can debug older versions of files without changing these calls
1142 2868295 : logical function is_bad_num(x)
1143 : real(dp), intent(in) :: x
1144 2868295 : is_bad_num = is_bad(x)
1145 2868295 : end function is_bad_num
1146 :
1147 :
1148 0 : logical function is_bad_real(x)
1149 : real, intent(in) :: x
1150 0 : is_bad_real = is_bad(x)
1151 0 : end function is_bad_real
1152 :
1153 :
1154 0 : logical function is_bad_quad(x)
1155 : real(qp), intent(in) :: x
1156 0 : is_bad_quad = is_bad(x)
1157 0 : end function is_bad_quad
1158 :
1159 0 : subroutine fill_with_NaNs(ptr)
1160 : real(dp) :: ptr(:)
1161 0 : call set_nan(ptr)
1162 0 : end subroutine fill_with_NaNs
1163 :
1164 :
1165 19 : subroutine fill_with_NaNs_2D(ptr)
1166 : real(dp) :: ptr(:,:)
1167 19 : call set_nan(ptr)
1168 19 : end subroutine fill_with_NaNs_2D
1169 :
1170 :
1171 0 : subroutine fill_with_NaNs_3D(ptr)
1172 : real(dp) :: ptr(:,:,:)
1173 0 : call set_nan(ptr)
1174 0 : end subroutine fill_with_NaNs_3D
1175 :
1176 :
1177 0 : subroutine fill_with_NaNs_4D(ptr)
1178 : real(dp) :: ptr(:,:,:,:)
1179 0 : call set_nan(ptr)
1180 0 : end subroutine fill_with_NaNs_4D
1181 :
1182 0 : subroutine set_to_NaN(x)
1183 : real(dp) :: x
1184 0 : real(dp) :: xa(1)
1185 0 : call set_nan(xa)
1186 0 : x = xa(1)
1187 0 : end subroutine set_to_NaN
1188 :
1189 : end module utils_lib
|
