TABLE OF CONTENTS

ABINIT/m_libpaw_tools [ Modules ]

[ Top ] [ Modules ]

NAME

  m_libpaw_tools

FUNCTION

  Several libPAW tools: message printing, error handling, string handling...

COPYRIGHT

  Copyright (C) 2014-2024 ABINIT group (MT, MG, ...)
  This file is distributed under the terms of the
  GNU General Public License, see ~abinit/COPYING
  or http://www.gnu.org/copyleft/gpl.txt .

NOTES

  Parts of this module come directly from hide_write & hide_leave src files delivered with ABINIT.

  FOR DEVELOPPERS: in order to preserve the portability of libPAW library,
  please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt

SOURCE

22 #include "libpaw.h"
23 
24 module m_libpaw_tools
25 
26  USE_DEFS
27  USE_MPI_WRAPPERS
28 
29 #if defined HAVE_YAML
30   use yaml_output
31 #endif
32 #ifdef LIBPAW_HAVE_NETCDF
33   use netcdf
34 #endif
35 
36  implicit none
37 
38  private
39 
40 !PUBLIC FUNCTIONS - MESSAGE HANDLING
41  public  :: libpaw_wrtout         ! Parallel output of messages
42  public  :: libpaw_msg_hndl       ! Basic error handler
43  public  :: libpaw_flush          ! Wrapper for the standard flush routine
44  public  :: libpaw_spmsg_getcount ! Get number of special messages (WARNING/COMMENT) already printed
45  public  :: libpaw_spmsg_mpisum   ! Reduce number of special messages (WARNING/COMMENT) over MPI comm
46  public  :: libpaw_write_comm_set ! Set the MPI communicator used for parallel write
47  public  :: libpaw_log_flag_set   ! Set the flag controlling the filling of the LOG file
48  public  :: libpaw_netcdf_check   ! Stop execution after a NetCDF I/O error
49 
50 !PUBLIC FUNCTIONS - STRING HANDLING
51  public  :: libpaw_basename       ! String, base name extraction from path
52  public  :: libpaw_to_upper       ! String conversion to uppercase
53  public  :: libpaw_lstrip         ! String right blanks removal
54  public  :: libpaw_indent         ! String indentation
55 
56 !PUBLIC FUNCTIONS - IO TOOLS
57  public :: libpaw_get_free_unit  ! Get a free I/O unit
58 
59 !PRIVATE FUNCTIONS
60  private :: libpaw_wrtout_myproc  ! Sequential output of messages
61  private :: libpaw_write_lines    ! OS-compatible string output
62  private :: libpaw_leave          ! Clean exit of F90 routines
63  private :: libpaw_die            ! Clean exit
64  private :: libpaw_lock_and_write ! Write a string to a file with locking mechanism
65 
66 !PRIVATE VARIABLES
67  integer,save :: LIBPAW_WRITE_COMM=xmpi_world ! Communicator used for the parallel write
68  integer,save :: LIBPAW_COMMENT_COUNT=0           ! Number of COMMENTs printed in log file
69  integer,save :: LIBPAW_WARNING_COUNT=0           ! Number of WARNINGs printed in log file
70  integer,save :: LIBPAW_EXIT_FLAG=0               ! Flag set to 1 if an exit is requested
71  logical,save :: LIBPAW_HAS_LOG_FILE=.TRUE.       ! Flag: True if std output exists
72 
73 !PRIVATE PARAMETERS
74  integer,parameter :: LIBPAW_NULL_UNIT=-1     ! Fake null unit
75  character(len=25),parameter :: LIBPAW_MPIABORTFILE="__LIBPAW_MPIABORTFILE__"
76 #if defined HAVE_OS_WINDOWS
77  character(len=3),parameter :: LIBPAW_NULL_FILE="NUL"
78 #else
79  character(len=9),parameter :: LIBPAW_NULL_FILE="/dev/null"
80 #endif

m_libpaw_tool/libpaw_netcdf_check [ Functions ]

[ Top ] [ Functions ]

NAME

  libpaw_netcdf_check

FUNCTION

  Error handler for Netcdf calls.

INPUTS

  ncerr=Status error returned by the Netcdf library.
  msg=User-defined string with info on the action that was performed
  file= name of the file.
  line= line number.

NOTES

  This routine is usually interfaced with the macros defined in libpaw.h

SOURCE

534 subroutine libpaw_netcdf_check(ncerr,msg,file,line)
535 
536 !Arguments ------------------------------------
537  integer,intent(in) :: ncerr
538  character(len=*),intent(in) :: msg
539  character(len=*),optional,intent(in) :: file
540  integer,optional,intent(in) :: line
541 
542 !Local variables-------------------------------
543  integer :: f90line
544  character(len=500) :: f90name
545  character(len=1024) :: nc_msg
546  character(len=2048) :: my_msg
547 
548 ! *************************************************************************
549 
550 #ifdef LIBPAW_HAVE_NETCDF
551  if (ncerr /= NF90_NOERR) then
552    if (PRESENT(line)) then
553      f90line=line
554    else
555      f90line=0
556    end if
557    if (PRESENT(file)) then
558      f90name = libpaw_basename(file)
559    else
560      f90name='Subroutine Unknown'
561    end if
562    !
563    ! Append Netcdf string to user-defined message.
564    write(nc_msg,'(a,3x,a)')' - NetCDF library returned:',TRIM(nf90_strerror(ncerr))
565    my_msg = TRIM(msg) // TRIM(nc_msg)
566 
567    call libpaw_msg_hndl(my_msg,"ERROR","PERS",f90name,f90line)
568  end if
569 #else
570  call libpaw_die("LIBPAW_HAVE_NETCDF is not defined!")
571 #endif
572 
573 end subroutine libpaw_netcdf_check

m_libpaw_tools/libpaw_basename [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

 libpaw_basename

FUNCTION

  Returns the final component of a pathname (function version).

INPUTS

  string=The input string

NOTES

  This routine comes directly from the BASENAME routine delivered with ABINIT.
  If the input string in not a valid path to a file, a blank strink is returned

SOURCE

830 pure function libpaw_basename(istr) result(ostr)
831 
832 !Arguments ------------------------------------
833  character(len=*),intent(in) :: istr
834  character(len=LEN_TRIM(istr)) :: ostr
835 
836 !Local variables ------------------------------
837  integer :: ic,nch_trim,nch
838  character(len=1),parameter :: BLANK=' '
839  character(len=1),parameter :: DIR_SEPARATOR = '/'
840 
841 !************************************************************************
842 
843  nch     =LEN     (istr)
844  nch_trim=LEN_TRIM(istr)
845 
846  ic = INDEX (TRIM(istr), DIR_SEPARATOR, back=.TRUE.)
847  if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the separator.
848    ostr = istr(ic+1:nch_trim)
849  else if (ic==0 .or. ic == nch_trim+1) then ! no separator in string or zero length string,
850    ostr = TRIM(istr)     ! return trimmed string.
851  else                    ! (ic == nch_trim) separator is the last char.
852    ostr = BLANK ! This is not a valid path to a file, return blank.
853  end if
854  return
855 
856 end function libpaw_basename

m_libpaw_tools/libpaw_die [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_die

FUNCTION

  Stop smoothly the execution in case of unexpected events reporting the
  line number and the file name where the error occurred as well as the
  MPI rank of the processor.

INPUTS

  msg=String containing additional information on the nature of the problem
  [file]=Name of the f90 file containing the caller
  [line]=Line number of the file where problem occurred

NOTES

  This routine comes directly from the DIE routine delivered with ABINIT.

SOURCE

648 subroutine libpaw_die(message,file,line)
649 
650 !Arguments ------------------------------------
651  integer,optional,intent(in) :: line
652  character(len=*),intent(in) :: message
653  character(len=*),optional,intent(in) :: file
654 
655 !Local variables ------------------------------
656  integer :: rank
657  integer :: f90line=0
658  character(len=10) :: lnum,strank
659  character(len=500) :: f90name='Subroutine Unknown'
660  character(len=500) :: msg
661 
662 ! *********************************************************************
663 
664  if (PRESENT(line)) f90line=line
665  if (PRESENT(file)) f90name= libpaw_basename(file)
666 
667  rank=xmpi_comm_rank(xmpi_world) !Determine my rank inside world communicator
668 
669  write(lnum,"(i0)") f90line
670  write(strank,"(i0)") rank
671  msg=TRIM(f90name)//':'//TRIM(lnum)//' P'//TRIM(strank)
672  write(msg,'(a,2x,2a,2x,a)') ch10,TRIM(msg),ch10,TRIM(message)
673 
674  call libpaw_wrtout(std_out,msg,'PERS')
675  call libpaw_leave('PERS')
676 
677 end subroutine libpaw_die

m_libpaw_tools/libpaw_flush [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_flush

FUNCTION

  Wrapper for the standard flush routine
  Available only if the compiler implements this intrinsic procedure.

INPUTS

  unit=Fortran logical Unit number

NOTES

  This routine comes directly from the FLUSH_UNIT routine delivered with ABINIT.

SOURCE

783 subroutine libpaw_flush(unit)
784 
785 !Arguments ------------------------------------
786  integer,intent(in) :: unit
787 
788 !Local variables ------------------------------
789  integer, parameter :: dev_null=-1
790  logical :: isopen
791 
792 !************************************************************************
793 
794  if (unit==dev_null) return
795 
796 !FLUSH on unconnected unit is illegal: F95 std., 9.3.5.
797  inquire(unit=unit,opened=isopen)
798 
799 #if defined HAVE_FC_FLUSH
800  if (isopen) then
801    call flush(unit)
802  endif
803 #elif defined HAVE_FC_FLUSH_
804  if (isopen) then
805    call flush_(unit)
806   end if
807 #endif
808 
809 end subroutine libpaw_flush

m_libpaw_tools/libpaw_get_free_unit [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_get_free_unit

FUNCTION

  Obtain a free logical Fortran unit.

OUTPUT

  The unit number (free unit)
  Raises:
   -1 if no logical unit is free (!)

SOURCE

739 integer function libpaw_get_free_unit()
740 
741 !Local variables-------------------------------
742  integer,parameter :: MIN_UNIT_NUMBER=10
743 #ifdef FC_NAG
744   integer,parameter :: MAX_UNIT_NUMBER=64    ! There's a serious problem in Nag6.0. In principle
745                                              ! Maximum unit number: 2147483647
746 #else
747  integer,parameter :: MAX_UNIT_NUMBER=1024
748 #endif
749  integer :: iunt
750  logical :: isopen
751 
752 ! *********************************************************************
753 
754  do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
755    inquire(unit=iunt,opened=isopen)
756    if (.not.isopen) then
757       libpaw_get_free_unit=iunt; return
758    end if
759  end do
760  libpaw_get_free_unit=-1
761 
762 end function libpaw_get_free_unit

m_libpaw_tools/libpaw_indent [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_indent

FUNCTION

  Indent text (function version).

INPUTS

   istr=Input string

NOTES

  This routine comes directly from the INDENT routine delivered with ABINIT.

SOURCE

959 pure function libpaw_indent(istr) result(ostr)
960 
961 !Arguments ------------------------------------
962  character(len=*),intent(in) :: istr
963  character(len=len(istr)*4+4) :: ostr
964 
965 !Local variables-------------------------------
966  character(len=1),parameter :: NCHAR = char(10)
967  integer,parameter :: n=4
968  integer :: ii,jj,kk
969  character(len=1) :: ch
970 
971 ! *********************************************************************
972 
973  ostr=" "
974  jj=n
975  do ii=1,LEN_TRIM(istr)
976    ch=istr(ii:ii)
977    jj=jj+1
978    if (ch==NCHAR) then
979       ostr(jj:jj)=NCHAR
980       do kk=jj+1,jj+n
981         ostr(kk:kk)=" "
982       end do
983       jj=jj+n
984    else
985      ostr(jj:jj)=ch
986    end if
987  end do
988 
989 end function libpaw_indent

m_libpaw_tools/libpaw_leave [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_leave

FUNCTION

  Routine for clean exit of f90 code, taking into account possible parallelization.

INPUTS

  mode_paral=
   'COLL' if all procs are calling the routine with the same msg to be written once only
   'PERS' if the procs are calling the routine with different msgs each to be written,
          or if one proc is calling the routine
  [exit_status]=(optional, default=1 or -1, see below) the return code of the routine

OUTPUT

  (only writing)

NOTES

  This routine comes directly from the LEAVE_NEW routine delivered with ABINIT.
  By default, it uses "call exit(1)", that is not completely portable.

SOURCE

601 subroutine libpaw_leave(mode_paral,exit_status)
602 
603 !Arguments ------------------------------------
604  integer,intent(in),optional :: exit_status
605  character(len=4),intent(in) :: mode_paral
606 
607 !Local variables ------------------------------
608 
609 ! **********************************************************************
610 
611  call libpaw_wrtout(std_out,ch10//' leave_new : decision taken to exit ...','PERS')
612 
613 !Caveat: Do not use MPI collective calls!
614  if (mode_paral=="COLL") then
615    call libpaw_wrtout(std_out,"Why COLL? Are you sure that ALL the processors are calling leave_new?")
616  end if
617 
618  if (present(exit_status)) then
619    call xmpi_abort(exit_status=exit_status)
620  else
621    call xmpi_abort()
622  end if
623 
624 end subroutine libpaw_leave

m_libpaw_tools/libpaw_lock_and_write [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_lock_and_write

FUNCTION

  Writes a string to filename with locking mechanism.

INPUTS

  filename= Name of the file.
  string= Input string.

SOURCE

695 subroutine libpaw_lock_and_write(filename,string)
696 
697 !Arguments ------------------------------------
698  character(len=*),intent(in) :: filename,string
699 
700 !Local variables-------------------------------
701  integer :: lock_unit,file_unit
702  character(len=len(filename)+5) :: lock
703 
704 ! *********************************************************************
705 
706  !Try to acquire the lock.
707  lock=trim(filename)//".lock"
708  lock_unit=libpaw_get_free_unit()
709  open(unit=lock_unit,file=trim(lock),status='new',err=99)
710 
711  file_unit=libpaw_get_free_unit()
712  open(unit=file_unit,file=trim(filename),form="formatted")
713  call libpaw_write_lines(file_unit,string)
714  close(lock_unit,status="delete")
715  close(file_unit)
716  return
717 
718 99 continue
719 
720 end subroutine libpaw_lock_and_write

m_libpaw_tools/libpaw_log_flag_set [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_log_flag_set

FUNCTION

  Set the flag controlling the filling of the LOG file

INPUTS

  log_flag= new value for LOG file flag
            True: the log file is filled; False: no the log file

OUTPUT

SOURCE

500 subroutine libpaw_log_flag_set(log_flag)
501 
502 !Arguments ------------------------------------
503  logical,intent(in) :: log_flag
504 
505 !Local variables ------------------------------
506 
507 ! **********************************************************************
508 
509  LIBPAW_HAS_LOG_FILE=log_flag
510 
511 end subroutine libpaw_log_flag_set

m_libpaw_tools/libpaw_lstrip [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_lstrip

FUNCTION

  Removes leading spaces from the input string.

NOTES

  This routine comes directly from the LSTRIP routine delivered with ABINIT.

SOURCE

916 pure function libpaw_lstrip(istr) result(ostr)
917 
918 !Arguments ------------------------------------
919  character(len=*),intent(in) :: istr
920  character(len=len(istr)) :: ostr
921 
922 !Local variables ------------------------------
923  integer :: ii,jj,lg
924  character(len=1),parameter :: BLANK=' '
925 
926 ! *********************************************************************
927 
928  lg=LEN(istr)
929  do ii=1,lg
930    if (istr(ii:ii)/=BLANK) EXIT
931  end do
932 
933  ostr = " "
934  do jj=1,lg-ii+1
935    ostr(jj:jj) = istr(ii:ii)
936    ii=ii+1
937  end do
938 
939 end function libpaw_lstrip

m_libpaw_tools/libpaw_msg_hndl [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_msg_hndl

FUNCTION

  Basic error handler.

INPUTS

  msg=string containing additional information on the nature of the problem
  level=string defining the type of problem. Possible values are:
   COMMENT, WARNING, ERROR,BUG
  mode_paral=Either "COLL" or "PERS".
  [line]=line number of the file where problem occurred (optional)
  [file]=name of the f90 file containing the caller (optional)

OUTPUT

  (only writing)

NOTES

  This routine comes directly from the MSG_HNDL routine delivered with ABINIT.

SOURCE

326 subroutine libpaw_msg_hndl(msg,level,mode_paral,file,line)
327 
328 !Arguments ------------------------------------
329  integer,optional,intent(in) :: line
330  character(len=*),intent(in) :: level,msg,mode_paral
331  character(len=*),optional,intent(in) :: file
332 
333 !Local variables ------------------------------
334  logical :: file_exists
335  character(len=500) :: f90name='Unknown'
336  character(len=LEN(msg)) :: my_msg
337  character(len=MAX(4*LEN(msg),2000)) :: sbuf
338 
339 ! *********************************************************************
340 
341  my_msg=libpaw_lstrip(msg)
342 
343  write(sbuf,'(3a)') ch10,"--- !",TRIM(level)
344  if (PRESENT(file)) then
345    f90name=libpaw_basename(file)
346    write(sbuf,'(4a)') trim(sbuf),ch10,"src_file: ",TRIM(f90name)
347  end if
348  if (PRESENT(line)) then
349    write(sbuf,'(3a,i0)') trim(sbuf),ch10,"src_line: ",line
350  end if
351  write(sbuf,'(8a)') trim(sbuf),ch10,&
352 &  "message: |",ch10,trim(libpaw_indent(my_msg)),ch10,&
353 &  "...",ch10
354 
355  select case (libpaw_to_upper(level))
356  case ('COMMENT','WARNING')
357    call libpaw_wrtout(std_out,sbuf,mode_paral)
358  case ('ERROR','BUG')
359    call libpaw_wrtout(std_out,sbuf,mode_paral)
360    inquire(file=LIBPAW_MPIABORTFILE,exist=file_exists)
361    if ((.not.file_exists).and.xmpi_comm_size(xmpi_world)>1) then
362      call libpaw_lock_and_write(LIBPAW_MPIABORTFILE,sbuf)
363    end if
364    call libpaw_leave(mode_paral)
365  case default
366    write(sbuf,'(4a)') ch10,' libpaw_msg_hndl: BUG**2 - ',ch10,' Wrong value for level!'
367    call libpaw_die(sbuf)
368  end select
369 
370 end subroutine libpaw_msg_hndl

m_libpaw_tools/libpaw_spmsg_getcount [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_spmsg_getcount

FUNCTION

  Get the values of the counters of special messages (WARNING, COMMENT)

INPUTS

  ncomment= number of COMMENTs in log file
  nwarning= number of WARNINGs in log file
  nexit=    1 if exit requested

OUTPUT

  (only counters updated)

NOTES

  This routine comes directly from the SPECIALMSG_GETCOUNT routine delivered with ABINIT.

SOURCE

395 subroutine libpaw_spmsg_getcount(ncomment,nwarning,nexit)
396 
397 !Arguments ------------------------------------
398  integer,intent(out) :: ncomment,nexit,nwarning
399 
400 !Local variables ------------------------------
401 
402 ! **********************************************************************
403 
404  ncomment=LIBPAW_COMMENT_COUNT
405  nwarning=LIBPAW_WARNING_COUNT
406  nexit   =LIBPAW_EXIT_FLAG
407 
408 end subroutine libpaw_spmsg_getcount

m_libpaw_tools/libpaw_spmsg_mpisum [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_spmsg_mpisum

FUNCTION

  Reduce the counters of special messages (WARNING, COMMENTS, EXIT) over a MPI communicator

INPUTS

  mpicomm= MPI communicator

OUTPUT

  (only counters updated)

NOTES

  This routine comes directly from the SPECIALMSG_MPISUM routine delivered with ABINIT.

SOURCE

431 subroutine libpaw_spmsg_mpisum(mpicomm)
432 
433 !Arguments ------------------------------------
434  integer,intent(in) :: mpicomm
435 
436 !Local variables ------------------------------
437  integer :: ierr
438  integer :: buf(3)
439 
440 ! **********************************************************************
441 
442   buf(1)=LIBPAW_COMMENT_COUNT;buf(2)=LIBPAW_WARNING_COUNT;buf(3)=LIBPAW_EXIT_FLAG
443 
444   call xmpi_sum(buf,mpicomm,ierr)
445 
446   LIBPAW_COMMENT_COUNT=buf(1)
447   LIBPAW_WARNING_COUNT=buf(2)
448   LIBPAW_EXIT_FLAG=buf(3) ; if (LIBPAW_EXIT_FLAG/=0) LIBPAW_EXIT_FLAG=1
449 
450 end subroutine libpaw_spmsg_mpisum

m_libpaw_tools/libpaw_write_comm_set [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_write_comm_set

FUNCTION

  Set the MPI communicator used for parallel write

INPUTS

  new_write_comm= new value for the parallel write MPI communicator

OUTPUT

SOURCE

469 subroutine libpaw_write_comm_set(new_write_comm)
470 
471 !Arguments ------------------------------------
472  integer,intent(in) :: new_write_comm
473 
474 !Local variables ------------------------------
475 
476 ! **********************************************************************
477 
478  LIBPAW_WRITE_COMM=new_write_comm
479 
480 end subroutine libpaw_write_comm_set

m_libpaw_tools/libpaw_write_lines [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_write_lines

FUNCTION

  This routine receives a string, split the message in lines according to the
  ch10 character and output the text to the specified unit.
  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

OUTPUT

  (only writing)

NOTES

  This routine comes directly from the WRITE_LINES routine delivered with ABINIT.

SOURCE

236 subroutine libpaw_write_lines(unit,msg)
237 
238 !Arguments ------------------------------------
239 !scalars
240  integer,intent(in) :: unit
241  character(len=*),intent(in) :: msg
242 
243 !Local variables ------------------------------
244 !scalars
245  integer :: msg_size,ii,jj,rtnpos
246 #if defined HAVE_YAML
247  character(len = len_trim(msg)) :: msg_out
248 #endif
249 
250 !******************************************************************
251 
252  msg_size=len_trim(msg)
253 
254 #if defined HAVE_YAML
255  if (msg_size>0 .and. unit==std_out) then
256     ! Change any carriage return into space.
257     do ii = 1, msg_size
258        if (msg(ii:ii) /= char(10)) then
259           msg_out(ii:ii) = msg(ii:ii)
260        else
261           msg_out(ii:ii) = " "
262        end if
263     end do
264     call yaml_comment(msg_out)
265  end if
266  return
267 #endif
268 
269  if (msg_size==0) then
270    write(unit,*) ; return
271  end if
272 
273 !Here, split the message, according to the char(10) characters (carriage return).
274 !This technique is portable accross different OS.
275  rtnpos=index(msg,ch10)
276  if (rtnpos==0) then
277    write(unit,"(a)") msg(1:msg_size) ; return
278  end if
279 
280  ii=1; jj=rtnpos
281  do
282    if (ii==jj) then
283      write(unit,*)
284    else
285      write(unit,'(a)') msg(ii:jj-1)
286    end if
287    ii=jj+1 ; if (ii>msg_size) exit
288    jj=index(msg(ii:msg_size),ch10)
289    if (jj==0) then
290      jj=msg_size+1
291    else
292      jj=jj+ii-1
293    end if
294  end do
295 
296  if (msg(msg_size:msg_size)==ch10) write(unit,*)
297 
298 end subroutine libpaw_write_lines

m_libpaw_tools/libpaw_wrtout [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

 libpaw_wrtout

FUNCTION

  Organizes the sequential or parallel version of the write intrinsic

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.

OUTPUT

  (only writing)

NOTES

  This routine comes directly from the WRTOUT routine delivered with ABINIT.

SOURCE

110 subroutine libpaw_wrtout(unit,msg,mode_paral)
111 
112 !Arguments ------------------------------------
113  integer,intent(in) :: unit
114  character(len=*),intent(in) :: msg
115  character(len=*),optional,intent(in) :: mode_paral
116 
117 !Local variables ------------------------------
118  integer :: comm,me,nproc
119  integer,save :: master=0
120  character(len=len(msg)+50) :: string
121  character(len=500) :: my_mode_paral
122 
123 !******************************************************************
124 
125  if ((unit==std_out).and.(.not.LIBPAW_HAS_LOG_FILE)) RETURN
126  if (unit==LIBPAW_NULL_UNIT) RETURN
127 
128  my_mode_paral = "COLL"; if (PRESENT(mode_paral)) my_mode_paral = mode_paral
129 
130 !Communicator used for the parallel write
131  comm=LIBPAW_WRITE_COMM
132  nproc = xmpi_comm_size(comm)
133  me    = xmpi_comm_rank(comm)
134 
135  if ((my_mode_paral=='COLL').or.(nproc==1)) then
136    if (me==master) then
137      call libpaw_wrtout_myproc(unit,msg)
138    end if
139  else if (my_mode_paral=='PERS') then
140    call libpaw_write_lines(unit,msg)
141  else if (my_mode_paral=='INIT') then
142    master=unit
143  else
144    write(string,'(7a)')ch10,&
145 &   'libpaw_wrtout: ERROR -',ch10,&
146 &   '  Unknown write mode: ',my_mode_paral,ch10,&
147 &   '  Continuing anyway ...'
148    write(unit,'(A)') trim(string)
149  end if
150 
151 end subroutine libpaw_wrtout

m_libpaw_tools/libpaw_wrtout_myproc [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_wrtout_myproc

FUNCTION

  Do the output for one proc.

INPUTS

  unit=unit number for writing
  msg=(character(len=*)) message to be written

OUTPUT

  (only writing)

NOTES

  This routine comes directly from the WRTOUT_MYPROC routine delivered with ABINIT.

SOURCE

175 subroutine libpaw_wrtout_myproc(unit,msg)
176 
177 !Arguments ------------------------------------
178 !scalars
179  integer,intent(in) :: unit
180  character(len=*),intent(in) :: msg
181 
182 !Local variables ------------------------------
183 !scalars
184  logical :: print_std_err
185 !arrays
186 
187 !******************************************************************
188 
189  print_std_err=(unit==std_out.and.(index(trim(msg),'BUG')/=0.or.index(trim(msg),'ERROR')/=0))
190 
191 !Print message
192  call libpaw_write_lines(unit,msg)
193  if (print_std_err) then
194    call libpaw_write_lines(std_err,msg)
195  end if
196 
197 !Append "Contact Abinit group" to BUG messages
198  if (index(trim(msg),'BUG')/=0) then
199    write(unit,'(a)') '  Action: contact libPAW developers.'
200    if (print_std_err) write(std_err, '(a)' ) '  Action: contact libPAW developers.'
201    write(unit,*); if (print_std_err) write(std_err,*)
202  end if
203 
204 !Count the number of warnings and comments. Only take into
205 !account unit std_out, in order not to duplicate these numbers.
206  if (index(trim(msg),'WARNING')/=0 .and. unit==std_out) LIBPAW_WARNING_COUNT=LIBPAW_WARNING_COUNT+1
207  if (index(trim(msg),'COMMENT')/=0 .and. unit==std_out) LIBPAW_COMMENT_COUNT=LIBPAW_COMMENT_COUNT+1
208  if (index(trim(msg),'Exit'   )/=0) LIBPAW_EXIT_FLAG=1
209 
210 end subroutine libpaw_wrtout_myproc

m_libpaw_tools/to_upper [ Functions ]

[ Top ] [ m_libpaw_tools ] [ Functions ]

NAME

  libpaw_to_upper

FUNCTION

  Convert a string to UPPER CASE (function version).

INPUTS

   istr=Input string

NOTES

  This routine comes directly from the TOUPPER routine delivered with ABINIT.

SOURCE

876 pure function libpaw_to_upper(istr) result(ostr)
877 
878 !Arguments ------------------------------------
879  character(len=*),intent(in) :: istr
880  character(len=LEN_TRIM(istr)) :: ostr
881 
882 !Local variables ------------------------------
883  integer,parameter :: ASCII_aa=ICHAR('a')
884  integer,parameter :: ASCII_zz=ICHAR('z')
885  integer,parameter :: SHIFT=ICHAR('a')-ICHAR('A')
886  integer :: ic,iasc
887 
888 ! *********************************************************************
889 
890  do ic=1,LEN_TRIM(istr)
891    iasc=IACHAR(istr(ic:ic))
892    if (iasc>=ASCII_aa.and.iasc<=ASCII_zz) then
893      ostr(ic:ic)=ACHAR(iasc-SHIFT)
894    else
895      ostr(ic:ic)=istr(ic:ic)
896    end if
897  end do
898 
899 end function libpaw_to_upper