1!=================================================================== 2! 3! Modules: 4! 5! 1. message_m Originally By DAS 6! 7! die routine "gracefully" kills the computation. 8! alloc_check writes warnings and errors for memory allocation problems. 9! write_memory_usage provides a memory report at the end of a run. 10! open_file opens a file unit, and writes an error if it does not work. 11! 12!=================================================================== 13 14#include "f_defs.h" 15 16module message_m 17 18 use nrtype_m 19 use peinfo_m 20 21 implicit none 22 23 private 24 25 public :: & 26 die, & 27 alloc_check, & 28 write_memory_usage, & 29 open_file, & 30 close_file, & 31 TRUNC, & 32 operator(+) 33 34 !> these names are as short as practical to avoid lines being too long 35 integer, public :: alc !< allocation status for safe(de)allocate 36 INTSIZEOF, public :: sz !< size returned from sizeof for safe(de)allocate 37 !> set to .true. to print array size in bytes, .false. in KB/MB/GB 38 logical, parameter :: reportsizeexact = .false. 39 40 interface operator (+) 41 module procedure cat 42 end interface operator (+) 43 44contains 45 46 !> remove trailing and leading whitespace from a string 47 function TRUNC(s) 48 character(len=*), intent(in) :: s 49 character(len=len_trim(adjustl(s))) :: TRUNC 50 51 TRUNC = trim(adjustl(s)) 52 end function TRUNC 53 54 !----------------------------------------------------------- 55 56 !> concatenate two strings 57 function cat(str1, str2) 58 character(len=*), intent(in) :: str1 59 character(len=*), intent(in) :: str2 60 61 character(len=len(str1) + len(str2)) :: cat 62 cat = str1//str2 63 64 end function cat 65 66 !----------------------------------------------------------- 67 68 subroutine die(str, only_root_writes) 69 character (len=*), intent(in) :: str 70 logical, optional, intent(in) :: only_root_writes 71 72 logical :: should_write, should_write_prefix, is_open 73 74 should_write = .true. 75 should_write_prefix = peinf%npes > 1 76 if(present(only_root_writes)) then 77 if(only_root_writes) then 78 should_write = peinf%inode == 0 79 should_write_prefix = .false. 80 endif 81 endif 82 83 ! There is no good reason why unit 6 would not be open, but ifort 11 -O3 will crash on FLUSH(6) 84 ! with the message "forrtl: severe (707): FLUSH: Unit 6 is not connected", but inclusion of just 85 ! the inquire line is sufficient to avoid the incorrect optimization of this routine. And if we 86 ! are going to inquire, we may as well use the result to decide whether to flush. 87 inquire(unit = 6, opened = is_open) 88 if(is_open) then 89 FLUSH(6) 90 endif 91 ! FHJ: FLUSH is not really reliable because the OS might cache the stdout. 92 ! Sleeping for 1s is the best solution I found to make the output clean, 93 ! otherwise the error message would show up before regular output. 94 MYSLEEP(1) 95 ! FHJ: if we are not writing, wait 60s for the root node to get here and 96 ! write the error message. If the root doesn`t get here, we all print the 97 ! error messsage anyways and die. 98 if (.not.should_write) then 99 MYSLEEP(60) 100 endif 101 write(0,*) 102 if(should_write_prefix) write(0, '(a, i6, a)', advance='no') "From proc ", peinf%inode, ": " 103 write(0, '(2a)') "ERROR: ", TRUNC(str) 104 write(0,*) 105 FLUSH(0) 106 107 ! skip MPI calls if we are running in serial, this is needed 108 ! for calling check_FFT_size from MeanField/EPM/epm2bgw and MeanField/Utilities/wfnreduce 109 if (peinf%npes .gt. 1) then 110#ifdef MPI 111 ! we return error code -1 112 call MPI_Abort(MPI_COMM_WORLD, -1, mpierr) 113 call MPI_Finalize(mpierr) 114#endif 115 endif 116 ! return an error code so the system knows this run has failed 117 ! unfortunately, not all compilers will actually give this error code back to the OS 118 stop 999 119 120 return 121 end subroutine die 122 123 124 !--------------------------------------------------------------------------------------------------- 125 subroutine alloc_check(status, size, name, file, line, flag) 126 integer, intent(in) :: status 127 !> on some platforms there is a different return value for sizeof if build is 64-bit 128 INTSIZEOF, intent(in) :: size 129 character(len=*), intent(in) :: name 130 character(len=*), intent(in) :: file 131 integer, intent(in) :: line 132 logical, intent(in) :: flag 133 134 real(DP) :: sizekb,sizemb,sizegb 135 character(len=16) :: prefix 136 character(len=32) :: sizestr 137 138 sizekb = dble(size) / dble(1024) 139 sizemb = sizekb / dble(1024) 140 sizegb = sizemb / dble(1024) 141 if (sizekb.le.1.0d1.or.reportsizeexact) then 142 write(sizestr,'(i20,1x,"bytes")')size 143 elseif (sizemb.le.1.0d1) then 144 write(sizestr,'(f20.3,1x,"KB")')sizekb 145 elseif (sizegb.le.1.0d1) then 146 write(sizestr,'(f20.3,1x,"MB")')sizemb 147 else 148 write(sizestr,'(f20.3,1x,"GB")')sizegb 149 endif 150 151 if (flag) then 152 prefix = "Allocation" 153 peinf%mymem = peinf%mymem + size 154 peinf%mymaxmem = max(peinf%mymaxmem, peinf%mymem) 155 else 156 prefix = "Deallocation" 157 peinf%mymem = peinf%mymem - size 158 endif 159 160 if (peinf%verb_debug .and. sizemb>100 .and. peinf%inode==0) then 161 write(0,347) trim(prefix), trim(name), TRUNC(sizestr), & 162 trim(file), line 163 endif 164 165 if(size .lt. 0 .and. peinf%inode .eq. 0) then 166 write(0,345) trim(prefix), trim(name), TRUNC(sizestr), & 167 trim(file), line 168 endif 169 170 if(status .eq. 0) return 171 172 write(0,346) trim(prefix), trim(name), peinf%inode, & 173 trim(file), line 174 write(0,348) status, TRUNC(sizestr) 175 FLUSH(0) 176 177 call die('Allocation failure.') 178 179345 format(1x,"WARNING:",1x,a,1x,"of array",1x,a,1x, & 180 "of size",1x,a,/,3x,"in file",1x,a,1x,"at line",i5, & 181 1x,"may fail.",/) 182346 format(1x,"ERROR:",1x,a,1x,"of array",1x,a,1x, & 183 "on processor",i5,/,3x,"in file",1x,a,1x, & 184 "at line",i5,1x,"failed.") 185347 format(1x,"NOTICE:",1x,a,1x,"of array",1x,a,1x, & 186 "of size",1x,a,/,3x,"in file",1x,a,1x,"at line",i5, & 187 1x,"occurring.",/) 188348 format(3x,"Allocation status =",i4,",",1x,"Array size =",1x,a) 189 190 end subroutine alloc_check 191 192 193 !--------------------------------------------------------------------------------------------------- 194 subroutine write_memory_usage() 195 196 ! the memory is not tracked if not in debug mode, so everything would just be zero 197#ifdef DEBUG 198 199 integer :: iunit = 6 200#ifdef MPI 201 real(DP) :: mymemarray(2), maxmemarray(2), mymemresult(2), maxresult(2), minresult(2) 202#endif 203 204 if(peinf%inode == 0) write(iunit,'(/a)') '==== Memory Usage ====' 205 206#ifdef MPI 207 mymemarray(1) = peinf%mymem 208 mymemarray(2) = peinf%inode 209 call MPI_Reduce(mymemarray, mymemresult, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, 0, MPI_COMM_WORLD, mpierr) 210 211 maxmemarray(1) = peinf%mymaxmem 212 maxmemarray(2) = peinf%inode 213 call MPI_Reduce(maxmemarray, maxresult, 1, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, 0, MPI_COMM_WORLD, mpierr) 214 call MPI_Reduce(maxmemarray, minresult, 1, MPI_2DOUBLE_PRECISION, MPI_MINLOC, 0, MPI_COMM_WORLD, mpierr) 215 216 if(peinf%inode == 0) then 217 write(iunit,'(a,f14.4,a,i6)') 'Maximum memory currently allocated (MB): ', & 218 mymemresult(1) / (1024d0)**2, ' on processor ', nint(mymemresult(2)) 219 write(iunit,'(a,f14.4,a,i6)') 'Maximum memory high-water-mark (MB): ', & 220 maxresult(1) / (1024d0)**2, ' on processor ', nint(maxresult(2)) 221 write(iunit,'(a,f14.4,a,i6)') 'Minimum memory high-water-mark (MB): ', & 222 minresult(1) / (1024d0)**2, ' on processor ', nint(minresult(2)) 223 endif 224#else 225 write(iunit,'(a,f14.4)') 'Currently allocated (MB): ', peinf%mymem / (1024d0)**2 226 write(iunit,'(a,f14.4)') 'Memory high-water-mark (MB): ', peinf%mymaxmem / (1024d0)**2 227#endif 228 229#endif 230 231 return 232 end subroutine write_memory_usage 233 234 !--------------------------------------------------------------------------------------------------- 235 !> This is a wrapper to the Fortran 'open' statement, to provide clear error-handling. 236 !> arguments 'status', 'form', 'position' have the same meaning as for 'open'. 237 !> 'iostat', if provided, will make 'iostat' be passed to 'open', and return its value, rather 238 !> than writing a message, if there is an error (e.g. status='old' but file does not exist, or 239 !> status='new' but file does exist). 240 subroutine open_file(unit, file, status, form, position, iostat) 241 integer, intent(in) :: unit 242 character(len=*), intent(in) :: file 243 character(len=*), intent(in) :: status 244 character(len=*), optional, intent(in) :: form 245 character(len=*), optional, intent(in) :: position 246 integer, optional, intent(out) :: iostat 247 248 integer :: ierr, unit_other 249 character*80 :: form_, position_, name, unit_str, unit_other_str 250 character*200 :: string 251 logical :: is_open, does_exist 252 253 if(unit == 0) call die("You may not open unit 0, it is reserved for standard error.") 254 if(unit == 5) call die("You may not open unit 5, it is reserved for standard input.") 255 if(unit == 6) call die("You may not open unit 6, it is reserved for standard output.") 256 ! Cray Fortran has its own reserved units: http://docs.cray.com/books/S-3695-35/html-S-3695-35/pdollsmg.html 257 if(unit == 100) call die("You may not open unit 100, it is reserved for standard input (crayftn).") 258 if(unit == 101) call die("You may not open unit 101, it is reserved for standard output (crayftn).") 259 if(unit == 102) call die("You may not open unit 102, it is reserved for standard error (crayftn).") 260 261 ! these issues would be caught below too, but we can give more helpful messages than just an error code 262 inquire(unit = unit, opened = is_open, name = name) 263 if(is_open) then 264 write(string,'(3a,i6,3a)') "Cannot open file '", TRUNC(file), "' on unit ", unit, & 265 ": unit already open for file '", TRUNC(name), "'." 266 call die(string) 267 endif 268 269 if((trim(status) == 'old' .or. trim(status) == 'OLD') .and. .not. present(iostat)) then 270 inquire(file = TRUNC(file), exist = does_exist, opened = is_open, number = unit_other) 271 if(.not. does_exist) call die("Cannot open file '" // TRUNC(file) // "' for reading: does not exist.") 272 if(is_open) then 273 write(unit_str,*) unit 274 write(unit_other_str,*) unit_other 275 call die("Cannot open file '" // TRUNC(file) // "' for reading on unit " // TRUNC(unit_str) & 276 // ": already opened on unit " // TRUNC(unit_other_str) // ".") 277 endif 278 279! From the Fortran 95 standard, Section 9.3.4: 280! 281! If a file is already connected to a unit, execution of an OPEN 282! statement on that file and a different unit is not permitted. 283! 284! From the Fortran 77 Standard, Section 12.3.2: 285! 286! A unit must not be connected to more than one file at the same time, 287! and a file must not be connected to more than one unit at the same time. 288 289 endif 290 291 if((trim(status) == 'new' .or. trim(status) == 'NEW') .and. .not. present(iostat)) then 292 inquire(file = TRUNC(file), exist = does_exist) 293 if(does_exist) call die("Cannot open file '" // TRUNC(file) // "' for writing as 'new': already exists.") 294 endif 295 296 form_ = 'formatted' 297 if(present(form )) form_ = form 298 position_ = 'asis' 299 if(present(position)) position_ = position 300 301 ! passing the optionals to 'open' if not given to this routine does not work! 302 open(unit=unit, file = TRUNC(file), form=trim(form_), position=trim(position_), status=trim(status), iostat=ierr) 303 if(present(iostat)) then 304 iostat = ierr 305 else if(ierr /= 0) then 306 write(string,'(5a,i4)') "Failed to open file '", TRUNC(file), "' as status ", trim(status), " with error ", ierr 307 call die(string) 308 endif 309 310 return 311 end subroutine open_file 312 313 !--------------------------------------------------------------------------------------------------- 314 subroutine close_file(unit, delete) 315 integer, intent(in) :: unit 316 logical, optional, intent(in) :: delete 317 318 character*80 :: string, status 319 logical :: is_open 320 integer :: ierr 321 322 if(unit == 0) call die("You may not close unit 0, it is reserved for standard error.") 323 if(unit == 5) call die("You may not close unit 5, it is reserved for standard input.") 324 if(unit == 6) call die("You may not close unit 6, it is reserved for standard output.") 325 ! Cray Fortran has its own reserved units: http://docs.cray.com/books/S-3695-35/html-S-3695-35/pdollsmg.html 326 if(unit == 100) call die("You may not close unit 100, it is reserved for standard input (crayftn).") 327 if(unit == 101) call die("You may not close unit 101, it is reserved for standard output (crayftn).") 328 if(unit == 102) call die("You may not close unit 102, it is reserved for standard error (crayftn).") 329 330 ! these issues would be caught below too, but we can give more helpful messages than just an error code 331 inquire(unit = unit, opened = is_open, iostat = ierr) 332 if(ierr /= 0) then 333 write(string,'(a,i6,a,i4)') "inquire in close_file failed for unit ", unit, " with error ", ierr 334 call die(string) 335 endif 336 if(.not. is_open) then 337 write(string,'(a,i6,a)') "Cannot close unit ", unit, ": not open." 338 call die(string) 339 endif 340 341 status = 'keep' 342 if(present(delete)) then 343 if(delete) status = 'delete' 344 endif 345 346 close(unit=unit, status=trim(status), iostat=ierr) 347 if(ierr /= 0) then 348 write(string,'(a,i6,a,i4)') "Failed to close unit ", unit, " with error ", ierr 349 call die(string) 350 endif 351 352 return 353 end subroutine close_file 354 355end module message_m 356