Line data Source code
1 : !!****m* ABINIT/m_specialmsg
2 : !! NAME
3 : !! m_specialmsg
4 : !!
5 : !! FUNCTION
6 : !! This module contains tools to deal with special messages counters.
7 : !! Special messages= WARNING, COMMENT, EXIT
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2008-2026 ABINIT group (MT,XG)
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public License, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !!
15 : !! SOURCE
16 :
17 : #if defined HAVE_CONFIG_H
18 : #include "config.h"
19 : #endif
20 :
21 : #include "abi_common.h"
22 :
23 : module m_specialmsg
24 :
25 : use defs_basis
26 : use m_build_info
27 : use m_xmpi
28 :
29 : use m_io_tools, only : flush_unit, write_lines, is_open
30 :
31 : implicit none
32 :
33 : private
34 : !!***
35 :
36 : public :: herald ! Prints message to unit iout giving info about current
37 : ! code, version of code, platform, and starting date.
38 :
39 : !Number of WARNINGS/COMMENTS printed in log file
40 : integer,save :: COMMENT_COUNT = 0
41 : integer,save :: WARNING_COUNT = 0
42 : integer,save :: EXIT_FLAG = 0
43 :
44 : !Public procedures
45 : public :: specialmsg_setcount ! Update number of special messages (WARNING/COMMENT) present in log file
46 : public :: specialmsg_getcount ! Get number of special messages (WARNING/COMMENT) present in log file
47 : public :: specialmsg_mpisum ! Reduce number of special messages (WARNING/COMMENT) over MPI comm
48 :
49 : public :: wrtout
50 :
51 : interface wrtout
52 : module procedure wrtout_unit
53 : module procedure wrtout_units
54 : end interface wrtout
55 :
56 : CONTAINS !===========================================================
57 : !!***
58 :
59 : !----------------------------------------------------------------------
60 :
61 : !!****f* m_specialmsg/specialmsg_setcount
62 : !! NAME
63 : !! specialmsg_setcount
64 : !!
65 : !! FUNCTION
66 : !! Update the counters of special messages (WARNING, COMMENTS, EXIT) printed in log file
67 : !!
68 : !! INPUTS
69 : !! [n_add_comment]= (optional) number of comments to add to the counter
70 : !! [n_add_exit] = (optional) number of exit messages to add to the counter
71 : !! [n_add_warning]= (optional) number of warnings to add to the counter
72 : !!
73 : !! OUTPUT
74 : !! (only counters updated)
75 : !!
76 : !! SOURCE
77 :
78 229332 : subroutine specialmsg_setcount(n_add_comment,n_add_warning,n_add_exit)
79 :
80 : !Arguments ------------------------------------
81 : integer,optional,intent(in) :: n_add_comment,n_add_warning,n_add_exit
82 :
83 : ! *********************************************************************
84 :
85 22169 : if (PRESENT(n_add_comment)) COMMENT_COUNT=COMMENT_COUNT+n_add_comment
86 207163 : if (PRESENT(n_add_warning)) WARNING_COUNT=WARNING_COUNT+n_add_warning
87 0 : if (PRESENT(n_add_exit)) then
88 0 : EXIT_FLAG=EXIT_FLAG+n_add_exit
89 0 : if (EXIT_FLAG>1) EXIT_FLAG=1
90 : end if
91 :
92 0 : end subroutine specialmsg_setcount
93 : !!***
94 :
95 : !----------------------------------------------------------------------
96 :
97 : !!****f* m_specialmsg/specialmsg_getcount
98 : !! NAME
99 : !! specialmsg_getcount
100 : !!
101 : !! FUNCTION
102 : !! Get the values of the counters of special messages (WARNING, COMMENT)
103 : !!
104 : !! INPUTS
105 : !!
106 : !! OUTPUT
107 : !! ncomment= number of COMMENTs in log file
108 : !! nwarning= number of WARNINGs in log file
109 : !! nexit= 1 if exit requested
110 : !!
111 : !! SOURCE
112 :
113 1426 : subroutine specialmsg_getcount(ncomment,nwarning,nexit)
114 :
115 : !Arguments ------------------------------------
116 : integer,intent(out) :: ncomment,nexit,nwarning
117 :
118 : ! *********************************************************************
119 :
120 1426 : ncomment=COMMENT_COUNT
121 1426 : nwarning=WARNING_COUNT
122 1426 : nexit =EXIT_FLAG
123 :
124 1426 : end subroutine specialmsg_getcount
125 : !!***
126 :
127 : !----------------------------------------------------------------------
128 :
129 : !!****f* m_specialmsg/specialmsg_mpisum
130 : !! NAME
131 : !! specialmsg_mpisum
132 : !!
133 : !! FUNCTION
134 : !! Reduce the counters of special messages (WARNING, COMMENTS, EXIT) over a MPI communicator
135 : !!
136 : !! INPUTS
137 : !! mpicomm= MPI communicator
138 : !!
139 : !! OUTPUT
140 : !! (only counters updated)
141 : !!
142 : !! SOURCE
143 :
144 0 : subroutine specialmsg_mpisum(mpicomm)
145 :
146 : !Arguments ------------------------------------
147 : integer,intent(in) :: mpicomm
148 :
149 : !Local variables-------------------------------
150 : integer :: ierr
151 : integer :: buf(3)
152 :
153 : ! *********************************************************************
154 :
155 0 : buf(1)=COMMENT_COUNT;buf(2)=WARNING_COUNT;buf(3)=EXIT_FLAG
156 :
157 0 : call xmpi_sum(buf,mpicomm,ierr)
158 :
159 0 : COMMENT_COUNT=buf(1)
160 0 : WARNING_COUNT=buf(2)
161 0 : EXIT_FLAG=buf(3) ; if (EXIT_FLAG/=0) EXIT_FLAG=1
162 :
163 0 : end subroutine specialmsg_mpisum
164 : !!***
165 :
166 : !----------------------------------------------------------------------
167 :
168 : !!****f* m_specialmsg/herald
169 : !! NAME
170 : !! herald
171 : !!
172 : !! FUNCTION
173 : !! Prints out a message to unit iout giving info about current
174 : !! code, version of code, platform, and starting date.
175 : !!
176 : !! INPUTS
177 : !! code_name= code name
178 : !! code_version= code version
179 : !! iout=unit number for output
180 : !!
181 : !! OUTPUT
182 : !! (only writing)
183 : !!
184 : !! SOURCE
185 :
186 2629 : subroutine herald(code_name,code_version,iout)
187 :
188 : !Arguments ------------------------------------
189 : integer,intent(in) :: iout
190 : character(len=*),intent(in) :: code_name
191 : character(len=*),intent(in) :: code_version
192 :
193 : !Local variables-------------------------------
194 : integer :: day,dd,ja,jy,jm,jdn,mm,mm_rel,year,year_rel
195 : integer :: values(8)
196 : character(len=5) :: strzone
197 : character(len=7) :: version_rel
198 : character(len=8) :: strdat
199 : character(len=10) :: strtime
200 : character(len=500) :: msg
201 : character(len=3),parameter :: day_names(7)=(/'Mon','Tue','Wed','Thu','Fri','Sat','Sun'/)
202 : character(len=3),parameter :: month_names(12)=(/'Jan','Feb','Mar','Apr','May','Jun',&
203 : 'Jul','Aug','Sep','Oct','Nov','Dec'/)
204 :
205 : ! *************************************************************************
206 :
207 : !RELEASE TIME FROM ABIRULES
208 2629 : year_rel=2026
209 2629 : mm_rel=8
210 2629 : version_rel='10.9.3 '
211 : !END OF RELEASE TIME
212 :
213 : !The technique used hereafter is the only one that we have found to obtain
214 : !perfect transferability across platforms and OS.
215 : write(iout, '(/,9a,i4,a)' )&
216 2629 : & '.Version ',trim(code_version),' of ',trim(code_name),'. v',version_rel,'released ',month_names(mm_rel),' ',year_rel,'.'
217 : #if defined HAVE_MPI
218 2629 : write(iout, '(a,a,a,/)' ) '.(MPI version, prepared for a ',build_target,' computer) '
219 : #else
220 : write(iout, '(a,a,a,/)' ) '.(sequential version, prepared for a ',build_target,' computer) '
221 : #endif
222 :
223 : !GNU GPL license
224 : write(iout, '(a,/,a,a,a,/,a,/,a,/,a,/)' ) &
225 2629 : '.Copyright (C) 1998-2026 ABINIT group . ',&
226 2629 : ' ',trim(code_name),' comes with ABSOLUTELY NO WARRANTY.',&
227 2629 : ' It is free software, and you are welcome to redistribute it',&
228 2629 : ' under certain conditions (GNU General Public License,',&
229 5258 : ' see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt).'
230 :
231 2629 : if(trim(code_name)=='OPTIC')then
232 : write(iout, '(a,a,a,/,a,/,a,/,a,/,a,/,a,/,a,/)' ) &
233 14 : ' ',trim(code_name),' has originally been developed by',&
234 14 : ' Sangeeta Sharma and incorporated in ABINIT with the help of M. Verstraete.',&
235 14 : ' Please refer to : ',&
236 14 : ' S. Sharma, J. K. Dewhurst and C. Ambrosch-Draxl, Phys. Rev. B 67, 165332 (2003), and',&
237 14 : ' S. Sharma and C. Ambrosch-Draxl, Physica Scripta T 109 (2004).',&
238 14 : '- URLs and DOI at https://docs.abinit.org/theory/bibliography/#sharma2003',&
239 28 : '- and https://docs.abinit.org/theory/bibliography/#sharma2004'
240 : end if
241 :
242 : write(iout, '(a,/,a,/,a,/,a,/,a)' ) &
243 2629 : ' ABINIT is a project of the Universite Catholique de Louvain,',&
244 2629 : ' Corning Inc. and other collaborators, see ~abinit/doc/developers/contributors.txt .',&
245 2629 : ' Please read https://docs.abinit.org/theory/acknowledgments for suggested',&
246 2629 : ' acknowledgments of the ABINIT effort.',&
247 5258 : ' For more information, see https://www.abinit.org .'
248 :
249 : !Get year, month and day
250 2629 : call date_and_time(strdat,strtime,strzone,values)
251 2629 : year=values(1)
252 2629 : mm=values(2)
253 2629 : dd=values(3)
254 :
255 : !Get day of the week
256 2629 : if (mm.gt.2) then
257 2629 : jy=year
258 2629 : jm=mm+1
259 : else
260 0 : jy=year-1
261 0 : jm=mm+13
262 : end if
263 2629 : jdn=int(365.25d0*jy)+int(30.6001d0*jm)+dd+1720995
264 2629 : ja=int(0.01d0*jy)
265 2629 : jdn=jdn+2-ja+int(quarter*ja)
266 2629 : day=mod(jdn,7)+1
267 :
268 : ! Print date in nice format (* new format *)
269 : write(iout, '(/,a,a,1x,i2,1x,a,1x,i4,a,/,a,i2.2,a,i2.2,a)' ) &
270 2629 : '.Starting date : ',day_names(day),dd,month_names(mm),year,'.','- ( at ',values(5),'h',values(6),' )'
271 2629 : write(iout,*)' '
272 :
273 : !Impose a maximal life cycle of 3 years
274 2629 : if(year>year_rel+3 .or. (year==year_rel+3 .and. mm>mm_rel) ) then
275 : write(msg, '(5a,i4,5a)' )&
276 0 : '- The starting date is more than 3 years after the initial release',ch10,&
277 0 : '- of this version of ABINIT, namely ',month_names(mm_rel),' ',year_rel,'.',ch10,&
278 0 : '- This version of ABINIT is not supported anymore.',ch10,&
279 0 : '- Action: please, switch to a more recent version of ABINIT.'
280 0 : call wrtout(iout,msg,'COLL')
281 :
282 : ! Gives a warning beyond 2 years
283 2629 : else if(year>year_rel+2 .or. (year==year_rel+2 .and. mm>mm_rel) ) then
284 : write(msg, '(5a,i4,6a)' )&
285 0 : '- The starting date is more than 2 years after the initial release',ch10,&
286 0 : '- of this version of ABINIT, namely ',month_names(mm_rel),' ',year_rel,'.',ch10,&
287 0 : '- Note that the use beyond 3 years after the release will not be supported.',ch10,&
288 0 : '- Action: please, switch to a more recent version of ABINIT.',ch10
289 0 : call wrtout(iout,msg,'COLL')
290 : end if
291 :
292 2629 : end subroutine herald
293 : !!***
294 :
295 : !!****f* m_specialmsg/wrtout_unit
296 : !! NAME
297 : !! wrtout_unit
298 : !!
299 : !! FUNCTION
300 : !! Organizes the sequential or parallel version of the write intrinsic
301 : !! Also allows to treat correctly the write operations for Unix (+DOS) and MacOS.
302 : !!
303 : !! INPUTS
304 : !! msg=(character(len=*)) message to be written
305 : !! unit=unit number for writing. The named constant dev_null defined in defs_basis can be used to avoid any printing.
306 : !! [mode_paral]= --optional argument--
307 : !! 'COLL' if all procs are calling the routine with the same message to be written once only. Default.
308 : !! 'PERS' if the procs are calling the routine with different messages each to be written,
309 : !! or if one proc is calling the routine
310 : !! "INIT" to change the rank of the master node that prints the message if "COLL" is used.
311 : !! [do_flush]=True to flush the unit. Defaults to .False.
312 : !! [newlines]: Number of new lines added after message. Default 0
313 : !! [pre_newlines]: Number of new lines added vefore message. Default 0
314 : !!
315 : !! OUTPUT
316 : !! (only writing)
317 : !!
318 : !! SOURCE
319 :
320 8692336 : subroutine wrtout_unit(unit, msg, mode_paral, do_flush, newlines, pre_newlines)
321 :
322 : !Arguments ------------------------------------
323 : integer,intent(in) :: unit
324 : character(len=*),intent(in) :: msg
325 : character(len=*),optional,intent(in) :: mode_paral
326 : logical,optional,intent(in) :: do_flush
327 : integer,optional,intent(in) :: newlines, pre_newlines
328 :
329 : !Local variables-------------------------------
330 : integer,save :: master = 0
331 : integer :: comm, me, nproc, my_newlines, ii, my_pre_newlines
332 : integer,save :: cached_comm = -666777, cached_me=-1, cached_nproc=-1
333 : logical :: my_flush
334 8692336 : character(len=len(msg)+50) :: string
335 : character(len=500) :: my_mode_paral
336 : !******************************************************************
337 :
338 7158336 : if (unit == std_out .and. .not. do_write_log) return
339 7474155 : if (unit == dev_null) return
340 : !if (.not. is_open(unit)) return
341 :
342 7426088 : my_mode_paral = "COLL"; if (present(mode_paral)) my_mode_paral = trim(mode_paral)
343 7426088 : my_flush = .false.; if (present(do_flush)) my_flush = do_flush
344 7426088 : my_newlines = 0; if (present(newlines)) my_newlines = newlines
345 7426088 : my_pre_newlines = 0; if (present(pre_newlines)) my_pre_newlines = pre_newlines
346 :
347 : ! Communicator is xmpi_world by default, except for the parallelization over images
348 7426088 : if (abinit_comm_output /= -1) then
349 7426088 : comm = abinit_comm_output
350 : else
351 0 : comm = xmpi_world
352 : end if
353 :
354 7426088 : if (comm /= cached_comm) then
355 : ! Determine who I am in comm and cache results
356 1821 : me = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
357 1821 : cached_comm = comm; cached_me = me ; cached_nproc = nproc
358 : else
359 7424267 : me = cached_me; nproc = cached_nproc
360 : end if
361 :
362 7426088 : if (my_mode_paral == 'COLL' .or. nproc == 1) then
363 7353936 : if (me == master) then
364 7172320 : if (my_pre_newlines /= 0) then
365 3371 : do ii=1,my_pre_newlines; write(unit, "(a)")""; end do
366 : end if
367 7172320 : call wrtout_myproc(unit, msg, do_flush=my_flush)
368 7172320 : if (my_newlines /= 0) then
369 1192 : do ii=1,my_newlines; write(unit, "(a)")""; end do
370 : end if
371 : end if
372 :
373 72152 : else if (my_mode_paral == 'PERS') then
374 72152 : if (my_pre_newlines /= 0) then
375 0 : do ii=1,my_pre_newlines; write(unit, "(a)")""; end do
376 : end if
377 72152 : call write_lines(unit,msg)
378 72152 : if (my_newlines /= 0) then
379 0 : do ii=1,my_newlines; write(unit, "(a)")""; end do
380 : end if
381 : ! Flush unit
382 72152 : if (my_flush) call flush_unit(unit)
383 :
384 0 : else if (my_mode_paral == 'INIT') then
385 0 : master = unit
386 :
387 : else
388 : !print *, trim(my_mode_paral)
389 0 : write(string,'(7a)')ch10,&
390 0 : 'wrtout_unit: ERROR -',ch10,&
391 0 : ' Unknown write mode: ',trim(my_mode_paral),ch10,&
392 0 : ' Continuing anyway ...'
393 0 : write(unit, '(A)' ) trim(string)
394 : end if
395 :
396 8692336 : end subroutine wrtout_unit
397 : !!***
398 :
399 : !!****f* m_specialmsg/wrtout_units
400 : !! NAME
401 : !! wrtout_units
402 : !!
403 : !! FUNCTION
404 : !! Write string to multiple units. Wraps wrtout_unit
405 : !!
406 : !! INPUTS
407 : !! msg=(character(len=*)) message to be written
408 : !! units=unit number for writing. The named constant dev_null defined in defs_basis can be used to avoid any printing.
409 : !! [mode_paral]= --optional argument--
410 : !! 'COLL' if all procs are calling the routine with the same message to be written once only. Default.
411 : !! 'PERS' if the procs are calling the routine with different messages each to be written,
412 : !! or if one proc is calling the routine
413 : !! "INIT" to change the rank of the master node that prints the message if "COLL" is used.
414 : !! [do_flush]=True to flush the unit. Defaults to .False.
415 : !! [newlines]: Number of new lines added after message. Default 0
416 : !! [pre_newlines]: Number of new lines added vefore message. Default 0
417 : !!
418 : !! OUTPUT
419 : !! (only writing)
420 : !!
421 : !! SOURCE
422 :
423 972518 : subroutine wrtout_units(units, msg, mode_paral, do_flush, newlines, pre_newlines)
424 :
425 : !Arguments ------------------------------------
426 : integer,intent(in) :: units(:)
427 : character(len=*),intent(in) :: msg
428 : character(len=*),optional,intent(in) :: mode_paral
429 : logical,optional,intent(in) :: do_flush
430 : integer,optional,intent(in) :: newlines, pre_newlines
431 :
432 : !Local variables-------------------------------
433 : !scalars
434 : integer :: ii, cnt, my_newlines, my_pre_newlines
435 : logical :: my_flush
436 : character(len=500) :: my_mode_paral
437 : !arrays
438 972518 : integer :: my_units(size(units))
439 :
440 : !******************************************************************
441 :
442 486259 : my_mode_paral = "COLL"; if (present(mode_paral)) my_mode_paral = mode_paral
443 486259 : my_flush = .false.; if (present(do_flush)) my_flush = do_flush
444 486259 : my_newlines = 0; if (present(newlines)) my_newlines = newlines
445 486259 : my_pre_newlines = 0; if (present(pre_newlines)) my_pre_newlines = pre_newlines
446 :
447 : ! Remove duplicated units (if any)
448 486259 : my_units(1) = units(1); cnt = 1
449 723116 : do ii=2,size(units)
450 467415 : if (any(units(ii) == my_units(1:cnt))) cycle
451 230465 : cnt = cnt + 1
452 723116 : my_units(cnt) = units(ii)
453 : end do
454 :
455 1202983 : do ii=1,cnt
456 : call wrtout_unit(my_units(ii), msg, mode_paral=my_mode_paral, &
457 1202983 : do_flush=my_flush, newlines=my_newlines, pre_newlines=my_pre_newlines)
458 : end do
459 :
460 486259 : end subroutine wrtout_units
461 : !!***
462 :
463 : !----------------------------------------------------------------------
464 :
465 : !!****f* m_specialmsg/wrtout_myproc
466 : !! NAME
467 : !! wrtout_myproc
468 : !!
469 : !! FUNCTION
470 : !! Do the output for one proc. For parallel or sequential output use wrtout()
471 : !! instead. Also allows to treat correctly the write operations for Unix (+DOS) and MacOS.
472 : !!
473 : !! INPUTS
474 : !! unit=unit number for writing
475 : !! msg=(character(len=*)) message to be written
476 : !! [do_flush]=True to flush the unit. Defaults to .False.
477 : !!
478 : !! OUTPUT
479 : !! (only writing)
480 : !!
481 : !! SOURCE
482 :
483 7172320 : subroutine wrtout_myproc(unit, msg, do_flush) ! optional argument
484 :
485 : !Arguments ------------------------------------
486 : !scalars
487 : integer,intent(in) :: unit
488 : character(len=*),intent(in) :: msg
489 : logical,optional,intent(in) :: do_flush
490 :
491 : !Local variables-------------------------------
492 : !scalars
493 : logical :: print_std_err
494 :
495 : !******************************************************************
496 :
497 : print_std_err = (unit == std_out .and. std_out /= std_err .and. &
498 7172320 : (index(trim(msg), 'BUG') /= 0 .or. index(trim(msg), 'ERROR') /= 0))
499 :
500 : ! Print message
501 7172320 : call write_lines(unit, msg)
502 7172320 : if (print_std_err) call write_lines(std_err, msg)
503 :
504 : ! Append "Contact Abinit group" to BUG messages
505 7172320 : if (index(trim(msg), 'BUG') /= 0 )then
506 2 : write(unit, '(a)' ) ' Action: contact ABINIT group (please attach the output of `abinit -b`)'
507 2 : write(unit,*)
508 2 : if (print_std_err) then
509 1 : write(std_err, '(a)' ) ' Action: contact ABINIT group (please attach the output of `abinit -b`)'
510 1 : write(std_err,*)
511 : end if
512 : end if
513 :
514 : ! Count the number of warnings and comments. Only take into
515 : ! account unit std_out, in order not to duplicate these numbers.
516 7172320 : if (index(trim(msg), 'WARNING') /= 0 .and. unit==std_out) call specialmsg_setcount(n_add_warning=1)
517 7172320 : if (index(trim(msg), 'COMMENT') /= 0 .and. unit==std_out) call specialmsg_setcount(n_add_comment=1)
518 7172320 : if (index(trim(msg), 'Exit') /= 0 ) call specialmsg_setcount(n_add_exit=1)
519 :
520 : ! Flush unit
521 7172320 : if (present(do_flush)) then
522 7172320 : if (do_flush) call flush_unit(unit)
523 : end if
524 : #ifdef DEBUG_MODE
525 : call flush_unit(unit)
526 : if (print_std_err) call flush_unit(std_err)
527 : #endif
528 :
529 7172320 : end subroutine wrtout_myproc
530 : !!***
531 :
532 : end module m_specialmsg
533 : !!***
|
