TABLE OF CONTENTS
- ABINIT/m_specialmsg
- m_specialmsg/herald
- m_specialmsg/specialmsg_getcount
- m_specialmsg/specialmsg_mpisum
- m_specialmsg/specialmsg_setcount
- m_specialmsg/wrtout_myproc
- m_specialmsg/wrtout_unit
- m_specialmsg/wrtout_units
ABINIT/m_specialmsg [ Modules ]
NAME
m_specialmsg
FUNCTION
This module contains tools to deal with special messages counters. Special messages= WARNING, COMMENT, EXIT
COPYRIGHT
Copyright (C) 2008-2024 ABINIT group (MT,XG) This file is distributed under the terms of the GNU General Public License, see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt .
SOURCE
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
m_specialmsg/herald [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
herald
FUNCTION
Prints out a message to unit iout giving info about current code, version of code, platform, and starting date.
INPUTS
code_name= code name code_version= code version iout=unit number for output
OUTPUT
(only writing)
SOURCE
186 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=8) :: strdat 198 character(len=10) :: strtime 199 character(len=500) :: msg 200 character(len=3),parameter :: day_names(7)=(/'Mon','Tue','Wed','Thu','Fri','Sat','Sun'/) 201 character(len=3),parameter :: month_names(12)=(/'Jan','Feb','Mar','Apr','May','Jun',& 202 'Jul','Aug','Sep','Oct','Nov','Dec'/) 203 204 ! ************************************************************************* 205 206 !RELEASE TIME FROM ABIRULES 207 year_rel=2024 208 mm_rel=02 209 !END OF RELEASE TIME 210 211 !The technique used hereafter is the only one that we have found to obtain 212 !perfect transferability across platforms and OS. 213 write(iout, '(/,a,a,a,a,a)' ) '.Version ',trim(code_version),' of ',trim(code_name),' ' 214 #if defined HAVE_MPI 215 write(iout, '(a,a,a,/)' ) '.(MPI version, prepared for a ',build_target,' computer) ' 216 #else 217 write(iout, '(a,a,a,/)' ) '.(sequential version, prepared for a ',build_target,' computer) ' 218 #endif 219 220 !GNU GPL license 221 write(iout, '(a,/,a,a,a,/,a,/,a,/,a,/)' ) & 222 '.Copyright (C) 1998-2022 ABINIT group . ',& 223 ' ',trim(code_name),' comes with ABSOLUTELY NO WARRANTY.',& 224 ' It is free software, and you are welcome to redistribute it',& 225 ' under certain conditions (GNU General Public License,',& 226 ' see ~abinit/COPYING or http://www.gnu.org/copyleft/gpl.txt).' 227 228 if(trim(code_name)=='OPTIC')then 229 write(iout, '(a,a,a,/,a,/,a,/,a,/,a,/,a,/,a,/)' ) & 230 ' ',trim(code_name),' has originally been developed by',& 231 ' Sangeeta Sharma and incorporated in ABINIT with the help of M. Verstraete.',& 232 ' Please refer to : ',& 233 ' S. Sharma, J. K. Dewhurst and C. Ambrosch-Draxl, Phys. Rev. B 67, 165332 (2003), and',& 234 ' S. Sharma and C. Ambrosch-Draxl, Physica Scripta T 109 (2004).',& 235 '- URLs and DOI at https://docs.abinit.org/theory/bibliography/#sharma2003',& 236 '- and https://docs.abinit.org/theory/bibliography/#sharma2004' 237 end if 238 239 write(iout, '(a,/,a,/,a,/,a,/,a)' ) & 240 ' ABINIT is a project of the Universite Catholique de Louvain,',& 241 ' Corning Inc. and other collaborators, see ~abinit/doc/developers/contributors.txt .',& 242 ' Please read https://docs.abinit.org/theory/acknowledgments for suggested',& 243 ' acknowledgments of the ABINIT effort.',& 244 ' For more information, see https://www.abinit.org .' 245 246 !Get year, month and day 247 call date_and_time(strdat,strtime,strzone,values) 248 year=values(1) 249 mm=values(2) 250 dd=values(3) 251 252 !Get day of the week 253 if (mm.gt.2) then 254 jy=year 255 jm=mm+1 256 else 257 jy=year-1 258 jm=mm+13 259 end if 260 jdn=int(365.25d0*jy)+int(30.6001d0*jm)+dd+1720995 261 ja=int(0.01d0*jy) 262 jdn=jdn+2-ja+int(quarter*ja) 263 day=mod(jdn,7)+1 264 265 !Print date in nice format (* new format *) 266 write(iout, '(/,a,a,1x,i2,1x,a,1x,i4,a,/,a,i2.2,a,i2.2,a)' ) & 267 '.Starting date : ',day_names(day),dd,month_names(mm),year,'.','- ( at ',values(5),'h',values(6),' )' 268 write(iout,*)' ' 269 270 !Impose a maximal life cycle of 3 years 271 if(year>year_rel+3 .or. (year==year_rel+3 .and. mm>mm_rel) ) then 272 write(msg, '(5a,i4,5a)' )& 273 '- The starting date is more than 3 years after the initial release',ch10,& 274 '- of this version of ABINIT, namely ',month_names(mm_rel),' ',year_rel,'.',ch10,& 275 '- This version of ABINIT is not supported anymore.',ch10,& 276 '- Action: please, switch to a more recent version of ABINIT.' 277 call wrtout(iout,msg,'COLL') 278 279 ! Gives a warning beyond 2 years 280 else if(year>year_rel+2 .or. (year==year_rel+2 .and. mm>mm_rel) ) then 281 write(msg, '(5a,i4,6a)' )& 282 '- The starting date is more than 2 years after the initial release',ch10,& 283 '- of this version of ABINIT, namely ',month_names(mm_rel),' ',year_rel,'.',ch10,& 284 '- Note that the use beyond 3 years after the release will not be supported.',ch10,& 285 '- Action: please, switch to a more recent version of ABINIT.',ch10 286 call wrtout(iout,msg,'COLL') 287 end if 288 289 end subroutine herald
m_specialmsg/specialmsg_getcount [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
specialmsg_getcount
FUNCTION
Get the values of the counters of special messages (WARNING, COMMENT)
INPUTS
OUTPUT
ncomment= number of COMMENTs in log file nwarning= number of WARNINGs in log file nexit= 1 if exit requested
SOURCE
113 subroutine specialmsg_getcount(ncomment,nwarning,nexit) 114 115 !Arguments ------------------------------------ 116 integer,intent(out) :: ncomment,nexit,nwarning 117 118 ! ********************************************************************* 119 120 ncomment=COMMENT_COUNT 121 nwarning=WARNING_COUNT 122 nexit =EXIT_FLAG 123 124 end subroutine specialmsg_getcount
m_specialmsg/specialmsg_mpisum [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
specialmsg_mpisum
FUNCTION
Reduce the counters of special messages (WARNING, COMMENTS, EXIT) over a MPI communicator
INPUTS
mpicomm= MPI communicator
OUTPUT
(only counters updated)
SOURCE
144 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 buf(1)=COMMENT_COUNT;buf(2)=WARNING_COUNT;buf(3)=EXIT_FLAG 156 157 call xmpi_sum(buf,mpicomm,ierr) 158 159 COMMENT_COUNT=buf(1) 160 WARNING_COUNT=buf(2) 161 EXIT_FLAG=buf(3) ; if (EXIT_FLAG/=0) EXIT_FLAG=1 162 163 end subroutine specialmsg_mpisum
m_specialmsg/specialmsg_setcount [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
specialmsg_setcount
FUNCTION
Update the counters of special messages (WARNING, COMMENTS, EXIT) printed in log file
INPUTS
[n_add_comment]= (optional) number of comments to add to the counter [n_add_exit] = (optional) number of exit messages to add to the counter [n_add_warning]= (optional) number of warnings to add to the counter
OUTPUT
(only counters updated)
SOURCE
78 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 if (PRESENT(n_add_comment)) COMMENT_COUNT=COMMENT_COUNT+n_add_comment 86 if (PRESENT(n_add_warning)) WARNING_COUNT=WARNING_COUNT+n_add_warning 87 if (PRESENT(n_add_exit)) then 88 EXIT_FLAG=EXIT_FLAG+n_add_exit 89 if (EXIT_FLAG>1) EXIT_FLAG=1 90 end if 91 92 end subroutine specialmsg_setcount
m_specialmsg/wrtout_myproc [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
wrtout_myproc
FUNCTION
Do the output for one proc. For parallel or sequential output use wrtout() instead. Also allows to treat correctly the write operations for Unix (+DOS) and MacOS.
INPUTS
unit=unit number for writing msg=(character(len=*)) message to be written [do_flush]=True to flush the unit. Defaults to .False.
OUTPUT
(only writing)
SOURCE
474 subroutine wrtout_myproc(unit, msg, do_flush) ! optional argument 475 476 !Arguments ------------------------------------ 477 !scalars 478 integer,intent(in) :: unit 479 character(len=*),intent(in) :: msg 480 logical,optional,intent(in) :: do_flush 481 482 !Local variables------------------------------- 483 !scalars 484 logical :: print_std_err 485 486 !****************************************************************** 487 488 print_std_err = (unit == std_out .and. std_out /= std_err .and. & 489 (index(trim(msg), 'BUG') /= 0 .or. index(trim(msg), 'ERROR') /= 0)) 490 491 ! Print message 492 call write_lines(unit, msg) 493 if (print_std_err) call write_lines(std_err, msg) 494 495 ! Append "Contact Abinit group" to BUG messages 496 if (index(trim(msg), 'BUG') /= 0 )then 497 write(unit, '(a)' ) ' Action: contact ABINIT group (please attach the output of `abinit -b`)' 498 write(unit,*) 499 if (print_std_err) then 500 write(std_err, '(a)' ) ' Action: contact ABINIT group (please attach the output of `abinit -b`)' 501 write(std_err,*) 502 end if 503 end if 504 505 ! Count the number of warnings and comments. Only take into 506 ! account unit std_out, in order not to duplicate these numbers. 507 if (index(trim(msg), 'WARNING') /= 0 .and. unit==std_out) call specialmsg_setcount(n_add_warning=1) 508 if (index(trim(msg), 'COMMENT') /= 0 .and. unit==std_out) call specialmsg_setcount(n_add_comment=1) 509 if (index(trim(msg), 'Exit') /= 0 ) call specialmsg_setcount(n_add_exit=1) 510 511 ! Flush unit 512 if (present(do_flush)) then 513 if (do_flush) call flush_unit(unit) 514 end if 515 #ifdef DEBUG_MODE 516 call flush_unit(unit) 517 if (print_std_err) call flush_unit(std_err) 518 #endif 519 520 end subroutine wrtout_myproc
m_specialmsg/wrtout_unit [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
wrtout_unit
FUNCTION
Organizes the sequential or parallel version of the write intrinsic Also allows to treat correctly the write operations for Unix (+DOS) and MacOS.
INPUTS
msg=(character(len=*)) message to be written unit=unit number for writing. The named constant dev_null defined in defs_basis can be used to avoid any printing. [mode_paral]= --optional argument-- 'COLL' if all procs are calling the routine with the same message to be written once only. Default. 'PERS' if the procs are calling the routine with different messages each to be written, or if one proc is calling the routine "INIT" to change the rank of the master node that prints the message if "COLL" is used. [do_flush]=True to flush the unit. Defaults to .False. [newlines]: Number of new lines added after message. Default 0 [pre_newlines]: Number of new lines added vefore message. Default 0
OUTPUT
(only writing)
SOURCE
317 subroutine wrtout_unit(unit, msg, mode_paral, do_flush, newlines, pre_newlines) 318 319 !Arguments ------------------------------------ 320 integer,intent(in) :: unit 321 character(len=*),intent(in) :: msg 322 character(len=*),optional,intent(in) :: mode_paral 323 logical,optional,intent(in) :: do_flush 324 integer,optional,intent(in) :: newlines, pre_newlines 325 326 !Local variables------------------------------- 327 integer,save :: master=0 328 integer :: comm, me, nproc, my_newlines, ii, my_pre_newlines 329 logical :: my_flush 330 character(len=len(msg)+50) :: string 331 character(len=500) :: my_mode_paral 332 333 !****************************************************************** 334 335 if (unit == std_out .and. .not. do_write_log) return 336 if (unit == dev_null) return 337 !if (.not. is_open(unit)) return 338 339 my_mode_paral = "COLL"; if (present(mode_paral)) my_mode_paral = mode_paral 340 my_flush = .false.; if (present(do_flush)) my_flush = do_flush 341 my_newlines = 0; if (present(newlines)) my_newlines = newlines 342 my_pre_newlines = 0; if (present(pre_newlines)) my_pre_newlines = pre_newlines 343 344 ! Communicator is xmpi_world by default, except for the parallelization over images 345 if (abinit_comm_output /= -1) then 346 comm = abinit_comm_output 347 else 348 comm = xmpi_world 349 end if 350 351 ! Determine who I am in COMM_WORLD 352 me = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm) 353 354 if (my_mode_paral == 'COLL' .or. nproc == 1) then 355 if (me == master) then 356 if (my_pre_newlines /= 0) then 357 do ii=1,my_pre_newlines; write(unit, "(a)")""; end do 358 end if 359 call wrtout_myproc(unit, msg, do_flush=my_flush) 360 if (my_newlines /= 0) then 361 do ii=1,my_newlines; write(unit, "(a)")""; end do 362 end if 363 end if 364 365 else if (my_mode_paral == 'PERS') then 366 if (my_pre_newlines /= 0) then 367 do ii=1,my_pre_newlines; write(unit, "(a)")""; end do 368 end if 369 call write_lines(unit,msg) 370 if (my_newlines /= 0) then 371 do ii=1,my_newlines; write(unit, "(a)")""; end do 372 end if 373 ! Flush unit 374 if (my_flush) call flush_unit(unit) 375 376 else if (my_mode_paral == 'INIT') then 377 master = unit 378 379 else 380 write(string,'(7a)')ch10,& 381 'wrtout_unit: ERROR -',ch10,& 382 ' Unknown write mode: ',trim(my_mode_paral),ch10,& 383 ' Continuing anyway ...' 384 write(unit, '(A)' ) trim(string) 385 end if 386 387 end subroutine wrtout_unit
m_specialmsg/wrtout_units [ Functions ]
[ Top ] [ m_specialmsg ] [ Functions ]
NAME
wrtout_units
FUNCTION
Write string to multiple units. Wraps wrtout_unit
INPUTS
msg=(character(len=*)) message to be written units=unit number for writing. The named constant dev_null defined in defs_basis can be used to avoid any printing. [mode_paral]= --optional argument-- 'COLL' if all procs are calling the routine with the same message to be written once only. Default. 'PERS' if the procs are calling the routine with different messages each to be written, or if one proc is calling the routine "INIT" to change the rank of the master node that prints the message if "COLL" is used. [do_flush]=True to flush the unit. Defaults to .False. [newlines]: Number of new lines added after message. Default 0 [pre_newlines]: Number of new lines added vefore message. Default 0
OUTPUT
(only writing)
SOURCE
414 subroutine wrtout_units(units, msg, mode_paral, do_flush, newlines, pre_newlines) 415 416 !Arguments ------------------------------------ 417 integer,intent(in) :: units(:) 418 character(len=*),intent(in) :: msg 419 character(len=*),optional,intent(in) :: mode_paral 420 logical,optional,intent(in) :: do_flush 421 integer,optional,intent(in) :: newlines, pre_newlines 422 423 !Local variables------------------------------- 424 !scalars 425 integer :: ii, cnt, my_newlines, my_pre_newlines 426 logical :: my_flush 427 character(len=500) :: my_mode_paral 428 !arrays 429 integer :: my_units(size(units)) 430 431 !****************************************************************** 432 433 my_mode_paral = "COLL"; if (present(mode_paral)) my_mode_paral = mode_paral 434 my_flush = .false.; if (present(do_flush)) my_flush = do_flush 435 my_newlines = 0; if (present(newlines)) my_newlines = newlines 436 my_pre_newlines = 0; if (present(pre_newlines)) my_pre_newlines = pre_newlines 437 438 ! Remove duplicated units (if any) 439 my_units(1) = units(1); cnt = 1 440 do ii=2,size(units) 441 if (any(units(ii) == my_units(1:cnt))) cycle 442 cnt = cnt + 1 443 my_units(cnt) = units(ii) 444 end do 445 446 do ii=1,cnt 447 call wrtout_unit(my_units(ii), msg, mode_paral=my_mode_paral, & 448 do_flush=my_flush, newlines=my_newlines, pre_newlines=my_pre_newlines) 449 end do 450 451 end subroutine wrtout_units