1!-----------------------------------------------------------------------------
2!
3!  Copyright (C) 1997-2013 Krzysztof M. Gorski, Eric Hivon,
4!                          Benjamin D. Wandelt, Anthony J. Banday,
5!                          Matthias Bartelmann, Hans K. Eriksen,
6!                          Frode K. Hansen, Martin Reinecke
7!
8!
9!  This file is part of HEALPix.
10!
11!  HEALPix is free software; you can redistribute it and/or modify
12!  it under the terms of the GNU General Public License as published by
13!  the Free Software Foundation; either version 2 of the License, or
14!  (at your option) any later version.
15!
16!  HEALPix is distributed in the hope that it will be useful,
17!  but WITHOUT ANY WARRANTY; without even the implied warranty of
18!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19!  GNU General Public License for more details.
20!
21!  You should have received a copy of the GNU General Public License
22!  along with HEALPix; if not, write to the Free Software
23!  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
24!
25!  For more information about HEALPix see http://healpix.sourceforge.net
26!
27!-----------------------------------------------------------------------------
28module misc_utils
29!   subroutine fatal_error
30!   function file_present
31!   subroutine assert_present
32!   subroutine assert_directory_present
33!   subroutine assert_not_present
34!   subroutine assert_alloc
35!   subroutine assert
36!   function strupcase
37!   function strlowcase
38!   function expand_env_var
39!   function string
40!   subroutine wall_clock_time
41!   subroutine brag_openmp
42!--------------------------------------------------------------------------------------
43  ! edited 2006-10-31: fatal_error for gfortran gcc4.1.1 bug workaround (V. Stolyarov)
44  ! 2007-06-06: string() now accepts LGT variables
45  ! 2008-03-25: added expand_env_var, string() accepts 64-bit integer variables (on systems that can deal with them)
46  ! 2012-10-29: edited file_present to accept virtual files and CFITSIO 'extended filenames'
47  !    the NOCFITSIO flag must be set to return to standard UNIX 'inquire' behavior
48  !--------------------------------------------------------------------------------------
49  use healpix_types
50  use extension, only : exit_with_status, getEnvironment
51  implicit none
52  private
53
54  integer, parameter, private :: LCH=48
55  interface string
56#ifdef NO64BITS
57     module procedure string_l, string_i,           string_s, string_d
58#else
59     module procedure string_l, string_i, string_j, string_s, string_d
60#endif
61  end interface
62
63  interface fatal_error
64  	module procedure fatal_error_womsg, fatal_error_msg
65  end interface
66
67
68  public :: fatal_error, assert, assert_present, assert_not_present, &
69       & assert_alloc, file_present, assert_directory_present
70  public :: upcase, lowcase
71  public :: wall_clock_time
72  public :: brag_openmp
73  public :: strupcase, strlowcase, string
74  public :: expand_env_var
75
76contains
77  !-----------------------------------------------------
78!  subroutine fatal_error (msg)
79!    character(len=*), intent(in), optional :: msg
80!
81!    if (present(msg)) then
82!       print *,'Fatal error: ', trim(msg)
83!    else
84!       print *,'Fatal error'
85!    endif
86!    call exit_with_status(1)
87!  end subroutine fatal_error
88
89  subroutine fatal_error_msg (msg)
90    character(len=*), intent(in) :: msg
91       print *,'Fatal error: ', trim(msg)
92    call exit_with_status(1)
93  end subroutine fatal_error_msg
94
95  subroutine fatal_error_womsg
96      print *,'Fatal error'
97    call exit_with_status(1)
98  end subroutine fatal_error_womsg
99
100
101  !-----------------------------------------------------
102  function file_present (filename)
103    character(len=*), intent(in) :: filename
104    logical :: file_present
105    integer :: ft_flag, ft_status
106    real(sp) :: version
107    real(sp) :: reqversion
108
109#ifdef NOCFITSIO
110    inquire(file=trim(filename),exist=file_present)
111#else
112    ft_status = 0
113    reqversion = 3.20
114    call ftvers(version)
115    if (version  < (reqversion-0.001)) then
116       print *,'******************************************************'
117       print *,'CFITSIO library (version ' &
118            & //trim(string(version,format='(f6.3)')) &
119            & //') is too old.'
120       print *,'Version ' &
121            & //trim(string(reqversion,format='(f6.3)')) &
122            & //' or more is required.'
123       print *,'******************************************************'
124    endif
125    call ftexist(filename, ft_flag, ft_status)
126    ! accept disk files (+1) and remote/virtual files (-1)
127    file_present = (ft_flag == 1  .or. ft_flag == -1)
128#endif
129
130  end function file_present
131
132  !-----------------------------------------------------
133  subroutine assert_present (filename)
134    character(len=*), intent(in) :: filename
135
136    if (.not. file_present(trim(filename))) then
137       print *, 'Error:  file ' // trim(filename) // ' does not exist!'
138       call exit_with_status(1)
139    end if
140  end subroutine assert_present
141
142  !-----------------------------------------------------
143  subroutine assert_directory_present (filename)
144    character(len=*), intent(in) :: filename
145    integer pos
146
147    pos = scan(filename,'/',back=.true.)
148    if (pos<=0) return
149
150    if (.not. file_present(filename(:pos-1))) then
151       print *, 'Error:  directory ' // filename(:pos-1) // ' does not exist!'
152       call exit_with_status(1)
153    end if
154  end subroutine assert_directory_present
155
156  !-----------------------------------------------------
157  subroutine assert_not_present (filename)
158    character(len=*), intent(in) :: filename
159
160    if (file_present(trim(filename))) then
161       print *, 'Error:  file ' // trim(filename) // ' already exists!'
162       call exit_with_status(1)
163    end if
164  end subroutine assert_not_present
165
166  !-----------------------------------------------------
167  subroutine assert_alloc (stat,code,arr)
168!!    integer, intent(in) :: stat
169    integer(i4b), intent(in) :: stat
170    character(len=*), intent(in) :: code, arr
171
172    if (stat==0) return
173
174    print *, trim(code)//'> cannot allocate memory for array: '//trim(arr)
175    call exit_with_status(1)
176  end subroutine assert_alloc
177
178  !-----------------------------------------------------
179  subroutine assert (testval,msg,errcode)
180    logical, intent(in) :: testval
181    character(len=*), intent(in), optional :: msg
182    integer(i4b), intent(in), optional :: errcode
183
184    if (testval) return
185
186    print *,"Assertion failed: "
187    if (present(msg)) print *, trim(msg)
188    if (present(errcode)) call exit_with_status (errcode)
189    call exit_with_status(1)
190  end subroutine assert
191
192  !-----------------------------------------------------
193  subroutine upcase(instr, outstr)
194    ! turns a string to upper case
195    ! instr and outstr can be the same variable
196    character(len=*), intent(in)  :: instr
197    character(len=*), intent(out) :: outstr
198
199    integer(i4b) :: i, j, ascii, ll, la, ua
200
201    la = iachar('a')
202    ua = iachar('A')
203
204    ll = len_trim(outstr)
205    do i = 1, min(len_trim(instr),ll)
206       ascii = iachar( instr(i:i) )
207       if (ascii >= la .and. ascii < la+26) then ! in [a,z]
208          outstr(i:i) = achar( ascii - la + ua )
209       else
210          outstr(i:i) = instr(i:i)
211       endif
212    enddo
213    do j = i, ll ! pad with blanks
214       outstr(j:j) = ' '
215    enddo
216    return
217  end subroutine upcase
218
219  !-----------------------------------------------------
220  subroutine lowcase(instr, outstr)
221    ! turns a string to lower case
222    ! instr and outstr can be the same variable
223    character(len=*), intent(in)  :: instr
224    character(len=*), intent(out) :: outstr
225
226    integer(i4b) :: i, j, ascii, ll, la, ua
227
228    la = iachar('a')
229    ua = iachar('A')
230
231    ll = len_trim(outstr)
232    do i = 1, min(len_trim(instr),ll)
233       ascii = iachar( instr(i:i) )
234       if (ascii >= ua .and. ascii < ua+26) then ! in [A,Z]
235          outstr(i:i) = achar( ascii - ua + la )
236       else
237          outstr(i:i) = instr(i:i)
238       endif
239    enddo
240    do j = i, ll ! pad with blanks
241       outstr(j:j) = ' '
242    enddo
243    return
244  end subroutine lowcase
245  !-----------------------------------------------------
246  function strupcase(instr) result(outstr)
247    ! turns a character string to upper case
248    character(len=*), intent(in)  :: instr
249    character(len=FILENAMELEN)    :: outstr
250
251    integer(i4b) :: i, ascii, la, ua
252
253    la = iachar('a')
254    ua = iachar('A')
255
256    outstr = instr
257    do i = 1, min(len_trim(instr),len_trim(outstr))
258       ascii = iachar( instr(i:i) )
259       if (ascii >= la .and. ascii < la+26) then ! in [a,z]
260          outstr(i:i) = achar( ascii - la + ua )
261       endif
262    enddo
263
264    return
265  end function strupcase
266
267  !-----------------------------------------------------
268  function strlowcase(instr) result(outstr)
269    ! turns a string to lower case
270    character(len=*), intent(in)  :: instr
271    character(len=FILENAMELEN)    :: outstr
272
273    integer(i4b) :: i, ascii, la, ua
274
275    la = iachar('a')
276    ua = iachar('A')
277
278    outstr = instr
279    do i = 1, min(len_trim(instr),len_trim(outstr))
280       ascii = iachar( instr(i:i) )
281       if (ascii >= ua .and. ascii < ua+26) then ! in [A,Z]
282          outstr(i:i) = achar( ascii - ua + la )
283       endif
284    enddo
285
286    return
287  end function strlowcase
288
289  !-----------------------------------------------------
290  function expand_env_var(instr) result(outstr)
291    ! substitute an evironment variable invocation ${VAR}
292    ! with its value in a string
293    character(len=*), intent(in) :: instr
294    character(len=FILENAMELEN)   :: outstr, tmp, varname, varvalue
295    integer  :: i1, i2, ln
296    character(len=*), parameter :: code = 'expand_env_var'
297
298    outstr = trim(adjustl(instr))
299
300    ! replace leading ~/ with the value of $HOME
301    i1 = index(outstr,'~/')
302    if (i1 == 1) then
303       ln = len_trim(outstr)
304       call getEnvironment('HOME',varvalue)
305       tmp = trim(adjustl(varvalue))//outstr(2:ln)
306       outstr = trim(adjustl(tmp))
307    endif
308
309    ! replace ${XXX} with the value of $XXX
310    do
311       ln = len_trim(outstr)
312       i1 = index(outstr,'${')
313       if (i1 <= 0) exit
314       i2 = index(outstr,'}')
315
316       if (i2 <=  i1 + 1) then
317          print*,'WARNING: '//code//' can not process string: '//trim(instr)
318          print*,'         Unmatched  { or } .'
319          outstr = instr
320          return
321       endif
322       varname = outstr(i1+2:i2-1)
323       call getEnvironment(varname, varvalue)
324       tmp = outstr(1:i1-1)//trim(adjustl(varvalue))//outstr(i2+1:ln)
325       outstr = trim(adjustl(tmp))
326    enddo
327
328    return
329  end function expand_env_var
330  !========================================
331  ! function string(arg, format)
332  ! accepts: logical, i8, I4, SP and DP
333  !=======================================
334  function string_l(arg, format) result(str)
335    logical(lgt) :: arg
336    character(len=*),   optional :: format
337    character(len=LCH)           :: str
338    if (present(format)) then
339       write(str,format) arg
340    else
341       write(str,*) arg
342    endif
343    return
344  end function string_l
345  !--------------------------------
346  function string_i(arg, format) result(str)
347    integer(i4b) :: arg
348    character(len=*),   optional :: format
349    character(len=LCH)           :: str
350    if (present(format)) then
351       write(str,format) arg
352    else
353       write(str,*) arg
354    endif
355    return
356  end function string_i
357  !--------------------------------
358#ifndef NO64BITS
359  ! only on systems supporting 64-bit integers
360  function string_j(arg, format) result(str)
361    integer(i8b) :: arg
362    character(len=*),   optional :: format
363    character(len=LCH)           :: str
364    if (present(format)) then
365       write(str,format) arg
366    else
367       write(str,*) arg
368    endif
369    return
370  end function string_j
371#endif
372  !--------------------------------
373  function string_s(arg, format) result(str)
374    real(sp) :: arg
375    character(len=*),   optional :: format
376    character(len=LCH)           :: str
377    if (present(format)) then
378       write(str,format) arg
379    else
380       write(str,*) arg
381    endif
382    return
383  end function string_s
384  !--------------------------------
385  function string_d(arg, format) result(str)
386    real(dp) :: arg
387    character(len=*),   optional :: format
388    character(len=LCH)           :: str
389    if (present(format)) then
390       write(str,format) arg
391    else
392       write(str,*) arg
393    endif
394    return
395  end function string_d
396  !--------------------------------
397
398  !-----------------------------------------------------
399  subroutine wall_clock_time(time_sec)
400    real(sp), intent(out) :: time_sec
401
402    integer :: clock, clock_rate, clock_max
403    integer, dimension(8) :: values_time
404
405    time_sec = 0.
406
407    call system_clock(count=clock, count_rate=clock_rate, count_max=clock_max)
408
409    if (clock < 0 .or. clock_rate <= 0 .or. clock_max <= 0) then
410       call date_and_time(values = values_time) ! y, m, d, x, h, m, s, ms
411       if (minval(values_time) >= 0) then
412          time_sec = ((values_time(3)*24. &
413               &     + values_time(5)    )*60. &
414               &     + values_time(6)        )*60. &
415               &     + values_time(7) + values_time(8)/1000.
416       endif
417    else
418       time_sec = clock/real(clock_rate)
419    endif
420
421    return
422  end subroutine wall_clock_time
423  !================================================
424  subroutine brag_openmp()
425  !================================================
426    ! OpenMP bragging
427    !================================================
428    ! OpenMP variables
429    !$     integer :: omp_get_thread_num, omp_get_num_threads, omp_get_num_procs
430    !IBMP  integer :: omp_get_thread_num, omp_get_num_threads, omp_get_num_procs
431
432!$OMP parallel
433!
434!$   if (omp_get_thread_num() == 0) then
435!$       write(*,9000) ' --------------------------------------'
436!$       write(*,9010) ' Number of OpenMP threads in use: ', omp_get_num_threads()
437!$       write(*,9010) ' Number of CPUs available:        ', omp_get_num_procs()
438!$       write(*,9000) ' --------------------------------------'
439!$   end if
440!
441!IBMP   if (omp_get_thread_num() == 0) then
442!IBMP       write(*,9000) ' --------------------------------------'
443!IBMP       write(*,9010) ' Number of OpenMP threads in use: ', omp_get_num_threads()
444!IBMP       write(*,9010) ' Number of CPUs available:        ', omp_get_num_procs()
445!IBMP       write(*,9000) ' --------------------------------------'
446!IBMP   end if
447!
448!$OMP end parallel
4499000 format(a)
4509010 format(a,i4)
451
452    return
453  end subroutine brag_openmp
454
455end module misc_utils
456