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