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