Line data Source code
1 : !!****m* ABINIT/m_libpaw_tools
2 : !! NAME
3 : !! m_libpaw_tools
4 : !!
5 : !! FUNCTION
6 : !! Several libPAW tools: message printing, error handling, string handling...
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2014-2026 ABINIT group (MT, MG, ...)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~abinit/COPYING
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! NOTES
15 : !! Parts of this module come directly from hide_write & hide_leave src files delivered with ABINIT.
16 : !!
17 : !! FOR DEVELOPPERS: in order to preserve the portability of libPAW library,
18 : !! please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
19 : !!
20 : !! SOURCE
21 :
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
81 :
82 : !!***
83 :
84 : CONTAINS !===========================================================
85 :
86 : !!****f* m_libpaw_tools/libpaw_wrtout
87 : !! NAME
88 : !! libpaw_wrtout
89 : !!
90 : !! FUNCTION
91 : !! Organizes the sequential or parallel version of the write intrinsic
92 : !!
93 : !! INPUTS
94 : !! msg=(character(len=*)) message to be written
95 : !! unit=unit number for writing. The named constant dev_null defined in defs_basis can be used to avoid any printing.
96 : !! [mode_paral]= --optional argument--
97 : !! 'COLL' if all procs are calling the routine with the same message to be written once only. Default.
98 : !! 'PERS' if the procs are calling the routine with different messages each to be written,
99 : !! or if one proc is calling the routine
100 : !! "INIT" to change the rank of the master node that prints the message if "COLL" is used.
101 : !!
102 : !! OUTPUT
103 : !! (only writing)
104 : !!
105 : !! NOTES
106 : !! This routine comes directly from the WRTOUT routine delivered with ABINIT.
107 : !!
108 : !! SOURCE
109 :
110 0 : 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 0 : character(len=len(msg)+50) :: string
121 : character(len=500) :: my_mode_paral
122 :
123 : !******************************************************************
124 :
125 0 : if ((unit==std_out).and.(.not.LIBPAW_HAS_LOG_FILE)) RETURN
126 0 : if (unit==LIBPAW_NULL_UNIT) RETURN
127 :
128 0 : my_mode_paral = "COLL"; if (PRESENT(mode_paral)) my_mode_paral = mode_paral
129 :
130 : !Communicator used for the parallel write
131 0 : comm=LIBPAW_WRITE_COMM
132 0 : nproc = xmpi_comm_size(comm)
133 0 : me = xmpi_comm_rank(comm)
134 :
135 0 : if ((my_mode_paral=='COLL').or.(nproc==1)) then
136 0 : if (me==master) then
137 0 : call libpaw_wrtout_myproc(unit,msg)
138 : end if
139 0 : else if (my_mode_paral=='PERS') then
140 0 : call libpaw_write_lines(unit,msg)
141 0 : else if (my_mode_paral=='INIT') then
142 0 : master=unit
143 : else
144 0 : write(string,'(7a)')ch10,&
145 0 : & 'libpaw_wrtout: ERROR -',ch10,&
146 0 : & ' Unknown write mode: ',my_mode_paral,ch10,&
147 0 : & ' Continuing anyway ...'
148 0 : write(unit,'(A)') trim(string)
149 : end if
150 :
151 0 : end subroutine libpaw_wrtout
152 : !!***
153 :
154 : !----------------------------------------------------------------------
155 :
156 : !!****f* m_libpaw_tools/libpaw_wrtout_myproc
157 : !! NAME
158 : !! libpaw_wrtout_myproc
159 : !!
160 : !! FUNCTION
161 : !! Do the output for one proc.
162 : !!
163 : !! INPUTS
164 : !! unit=unit number for writing
165 : !! msg=(character(len=*)) message to be written
166 : !!
167 : !! OUTPUT
168 : !! (only writing)
169 : !!
170 : !! NOTES
171 : !! This routine comes directly from the WRTOUT_MYPROC routine delivered with ABINIT.
172 : !!
173 : !! SOURCE
174 :
175 0 : 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 0 : print_std_err=(unit==std_out.and.(index(trim(msg),'BUG')/=0.or.index(trim(msg),'ERROR')/=0))
190 :
191 : !Print message
192 0 : call libpaw_write_lines(unit,msg)
193 0 : if (print_std_err) then
194 0 : call libpaw_write_lines(std_err,msg)
195 : end if
196 :
197 : !Append "Contact Abinit group" to BUG messages
198 0 : if (index(trim(msg),'BUG')/=0) then
199 0 : write(unit,'(a)') ' Action: contact libPAW developers.'
200 0 : if (print_std_err) write(std_err, '(a)' ) ' Action: contact libPAW developers.'
201 0 : 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 0 : if (index(trim(msg),'WARNING')/=0 .and. unit==std_out) LIBPAW_WARNING_COUNT=LIBPAW_WARNING_COUNT+1
207 0 : if (index(trim(msg),'COMMENT')/=0 .and. unit==std_out) LIBPAW_COMMENT_COUNT=LIBPAW_COMMENT_COUNT+1
208 0 : if (index(trim(msg),'Exit' )/=0) LIBPAW_EXIT_FLAG=1
209 :
210 0 : end subroutine libpaw_wrtout_myproc
211 : !!***
212 :
213 : !----------------------------------------------------------------------
214 :
215 : !!****f* m_libpaw_tools/libpaw_write_lines
216 : !! NAME
217 : !! libpaw_write_lines
218 : !!
219 : !! FUNCTION
220 : !! This routine receives a string, split the message in lines according to the
221 : !! ch10 character and output the text to the specified unit.
222 : !! Allows to treat correctly the write operations for Unix (+DOS) and MacOS.
223 : !!
224 : !! INPUTS
225 : !! unit=unit number for writing
226 : !! msg=(character(len=*)) message to be written
227 : !!
228 : !! OUTPUT
229 : !! (only writing)
230 : !!
231 : !! NOTES
232 : !! This routine comes directly from the WRITE_LINES routine delivered with ABINIT.
233 : !!
234 : !! SOURCE
235 :
236 0 : 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 0 : 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 0 : if (msg_size==0) then
270 0 : 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 0 : rtnpos=index(msg,ch10)
276 0 : if (rtnpos==0) then
277 0 : write(unit,"(a)") msg(1:msg_size) ; return
278 : end if
279 :
280 : ii=1; jj=rtnpos
281 : do
282 0 : if (ii==jj) then
283 0 : write(unit,*)
284 : else
285 0 : write(unit,'(a)') msg(ii:jj-1)
286 : end if
287 0 : ii=jj+1 ; if (ii>msg_size) exit
288 0 : jj=index(msg(ii:msg_size),ch10)
289 0 : if (jj==0) then
290 0 : jj=msg_size+1
291 : else
292 0 : jj=jj+ii-1
293 : end if
294 : end do
295 :
296 0 : if (msg(msg_size:msg_size)==ch10) write(unit,*)
297 :
298 : end subroutine libpaw_write_lines
299 : !!***
300 :
301 : !----------------------------------------------------------------------
302 :
303 : !!****f* m_libpaw_tools/libpaw_msg_hndl
304 : !! NAME
305 : !! libpaw_msg_hndl
306 : !!
307 : !! FUNCTION
308 : !! Basic error handler.
309 : !!
310 : !! INPUTS
311 : !! msg=string containing additional information on the nature of the problem
312 : !! level=string defining the type of problem. Possible values are:
313 : !! COMMENT, WARNING, ERROR,BUG
314 : !! mode_paral=Either "COLL" or "PERS".
315 : !! [line]=line number of the file where problem occurred (optional)
316 : !! [file]=name of the f90 file containing the caller (optional)
317 : !!
318 : !! OUTPUT
319 : !! (only writing)
320 : !!
321 : !! NOTES
322 : !! This routine comes directly from the MSG_HNDL routine delivered with ABINIT.
323 : !!
324 : !! SOURCE
325 :
326 0 : 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 0 : character(len=LEN(msg)) :: my_msg
337 0 : character(len=MAX(4*LEN(msg),2000)) :: sbuf
338 :
339 : ! *********************************************************************
340 :
341 0 : my_msg=libpaw_lstrip(msg)
342 :
343 0 : write(sbuf,'(3a)') ch10,"--- !",TRIM(level)
344 0 : if (PRESENT(file)) then
345 0 : f90name=libpaw_basename(file)
346 0 : write(sbuf,'(4a)') trim(sbuf),ch10,"src_file: ",TRIM(f90name)
347 : end if
348 0 : if (PRESENT(line)) then
349 0 : write(sbuf,'(3a,i0)') trim(sbuf),ch10,"src_line: ",line
350 : end if
351 0 : write(sbuf,'(8a)') trim(sbuf),ch10,&
352 0 : & "message: |",ch10,trim(libpaw_indent(my_msg)),ch10,&
353 0 : & "...",ch10
354 :
355 0 : select case (libpaw_to_upper(level))
356 : case ('COMMENT','WARNING')
357 0 : call libpaw_wrtout(std_out,sbuf,mode_paral)
358 : case ('ERROR','BUG')
359 0 : call libpaw_wrtout(std_out,sbuf,mode_paral)
360 0 : inquire(file=LIBPAW_MPIABORTFILE,exist=file_exists)
361 0 : if ((.not.file_exists).and.xmpi_comm_size(xmpi_world)>1) then
362 0 : call libpaw_lock_and_write(LIBPAW_MPIABORTFILE,sbuf)
363 : end if
364 0 : call libpaw_leave(mode_paral)
365 : case default
366 0 : write(sbuf,'(4a)') ch10,' libpaw_msg_hndl: BUG**2 - ',ch10,' Wrong value for level!'
367 0 : call libpaw_die(sbuf)
368 : end select
369 :
370 0 : end subroutine libpaw_msg_hndl
371 : !!***
372 :
373 : !----------------------------------------------------------------------
374 :
375 : !!****f* m_libpaw_tools/libpaw_spmsg_getcount
376 : !! NAME
377 : !! libpaw_spmsg_getcount
378 : !!
379 : !! FUNCTION
380 : !! Get the values of the counters of special messages (WARNING, COMMENT)
381 : !!
382 : !! INPUTS
383 : !! ncomment= number of COMMENTs in log file
384 : !! nwarning= number of WARNINGs in log file
385 : !! nexit= 1 if exit requested
386 : !!
387 : !! OUTPUT
388 : !! (only counters updated)
389 : !!
390 : !! NOTES
391 : !! This routine comes directly from the SPECIALMSG_GETCOUNT routine delivered with ABINIT.
392 : !!
393 : !! SOURCE
394 :
395 1426 : 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 1426 : ncomment=LIBPAW_COMMENT_COUNT
405 1426 : nwarning=LIBPAW_WARNING_COUNT
406 1426 : nexit =LIBPAW_EXIT_FLAG
407 :
408 1426 : end subroutine libpaw_spmsg_getcount
409 : !!***
410 :
411 : !----------------------------------------------------------------------
412 :
413 : !!****f* m_libpaw_tools/libpaw_spmsg_mpisum
414 : !! NAME
415 : !! libpaw_spmsg_mpisum
416 : !!
417 : !! FUNCTION
418 : !! Reduce the counters of special messages (WARNING, COMMENTS, EXIT) over a MPI communicator
419 : !!
420 : !! INPUTS
421 : !! mpicomm= MPI communicator
422 : !!
423 : !! OUTPUT
424 : !! (only counters updated)
425 : !!
426 : !! NOTES
427 : !! This routine comes directly from the SPECIALMSG_MPISUM routine delivered with ABINIT.
428 : !!
429 : !! SOURCE
430 :
431 0 : 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 0 : buf(1)=LIBPAW_COMMENT_COUNT;buf(2)=LIBPAW_WARNING_COUNT;buf(3)=LIBPAW_EXIT_FLAG
443 :
444 0 : call xmpi_sum(buf,mpicomm,ierr)
445 :
446 0 : LIBPAW_COMMENT_COUNT=buf(1)
447 0 : LIBPAW_WARNING_COUNT=buf(2)
448 0 : LIBPAW_EXIT_FLAG=buf(3) ; if (LIBPAW_EXIT_FLAG/=0) LIBPAW_EXIT_FLAG=1
449 :
450 0 : end subroutine libpaw_spmsg_mpisum
451 : !!***
452 :
453 : !----------------------------------------------------------------------
454 :
455 : !!****f* m_libpaw_tools/libpaw_write_comm_set
456 : !! NAME
457 : !! libpaw_write_comm_set
458 : !!
459 : !! FUNCTION
460 : !! Set the MPI communicator used for parallel write
461 : !!
462 : !! INPUTS
463 : !! new_write_comm= new value for the parallel write MPI communicator
464 : !!
465 : !! OUTPUT
466 : !!
467 : !! SOURCE
468 :
469 20959 : 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 20959 : LIBPAW_WRITE_COMM=new_write_comm
479 :
480 20959 : end subroutine libpaw_write_comm_set
481 : !!***
482 :
483 : !----------------------------------------------------------------------
484 :
485 : !!****f* m_libpaw_tools/libpaw_log_flag_set
486 : !! NAME
487 : !! libpaw_log_flag_set
488 : !!
489 : !! FUNCTION
490 : !! Set the flag controlling the filling of the LOG file
491 : !!
492 : !! INPUTS
493 : !! log_flag= new value for LOG file flag
494 : !! True: the log file is filled; False: no the log file
495 : !!
496 : !! OUTPUT
497 : !!
498 : !! SOURCE
499 :
500 278 : subroutine libpaw_log_flag_set(log_flag)
501 :
502 : !Arguments ------------------------------------
503 : logical,intent(in) :: log_flag
504 :
505 : !Local variables ------------------------------
506 :
507 : ! **********************************************************************
508 :
509 278 : LIBPAW_HAS_LOG_FILE=log_flag
510 :
511 278 : end subroutine libpaw_log_flag_set
512 : !!***
513 :
514 : !----------------------------------------------------------------------
515 :
516 : !!****f* m_libpaw_tool/libpaw_netcdf_check
517 : !! NAME
518 : !! libpaw_netcdf_check
519 : !!
520 : !! FUNCTION
521 : !! Error handler for Netcdf calls.
522 : !!
523 : !! INPUTS
524 : !! ncerr=Status error returned by the Netcdf library.
525 : !! msg=User-defined string with info on the action that was performed
526 : !! file= name of the file.
527 : !! line= line number.
528 : !!
529 : !! NOTES
530 : !! This routine is usually interfaced with the macros defined in libpaw.h
531 : !!
532 : !! SOURCE
533 :
534 0 : 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 0 : if (ncerr /= NF90_NOERR) then
552 0 : if (PRESENT(line)) then
553 0 : f90line=line
554 : else
555 0 : f90line=0
556 : end if
557 0 : if (PRESENT(file)) then
558 0 : f90name = libpaw_basename(file)
559 : else
560 0 : f90name='Subroutine Unknown'
561 : end if
562 : !
563 : ! Append Netcdf string to user-defined message.
564 0 : write(nc_msg,'(a,3x,a)')' - NetCDF library returned:',TRIM(nf90_strerror(ncerr))
565 0 : my_msg = TRIM(msg) // TRIM(nc_msg)
566 :
567 0 : 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 0 : end subroutine libpaw_netcdf_check
574 : !!***
575 :
576 : !----------------------------------------------------------------------
577 :
578 : !!****f* m_libpaw_tools/libpaw_leave
579 : !! NAME
580 : !! libpaw_leave
581 : !!
582 : !! FUNCTION
583 : !! Routine for clean exit of f90 code, taking into account possible parallelization.
584 : !!
585 : !! INPUTS
586 : !! mode_paral=
587 : !! 'COLL' if all procs are calling the routine with the same msg to be written once only
588 : !! 'PERS' if the procs are calling the routine with different msgs each to be written,
589 : !! or if one proc is calling the routine
590 : !! [exit_status]=(optional, default=1 or -1, see below) the return code of the routine
591 : !!
592 : !! OUTPUT
593 : !! (only writing)
594 : !!
595 : !! NOTES
596 : !! This routine comes directly from the LEAVE_NEW routine delivered with ABINIT.
597 : !! By default, it uses "call exit(1)", that is not completely portable.
598 : !!
599 : !! SOURCE
600 :
601 0 : 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 0 : call libpaw_wrtout(std_out,ch10//' leave_new : decision taken to exit ...','PERS')
612 :
613 : !Caveat: Do not use MPI collective calls!
614 0 : if (mode_paral=="COLL") then
615 0 : call libpaw_wrtout(std_out,"Why COLL? Are you sure that ALL the processors are calling leave_new?")
616 : end if
617 :
618 0 : if (present(exit_status)) then
619 0 : call xmpi_abort(exit_status=exit_status)
620 : else
621 0 : call xmpi_abort()
622 : end if
623 :
624 0 : end subroutine libpaw_leave
625 : !!***
626 :
627 : !----------------------------------------------------------------------
628 :
629 : !!****f* m_libpaw_tools/libpaw_die
630 : !! NAME
631 : !! libpaw_die
632 : !!
633 : !! FUNCTION
634 : !! Stop smoothly the execution in case of unexpected events reporting the
635 : !! line number and the file name where the error occurred as well as the
636 : !! MPI rank of the processor.
637 : !!
638 : !! INPUTS
639 : !! msg=String containing additional information on the nature of the problem
640 : !! [file]=Name of the f90 file containing the caller
641 : !! [line]=Line number of the file where problem occurred
642 : !!
643 : !! NOTES
644 : !! This routine comes directly from the DIE routine delivered with ABINIT.
645 : !!
646 : !! SOURCE
647 :
648 0 : 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 0 : if (PRESENT(line)) f90line=line
665 0 : if (PRESENT(file)) f90name= libpaw_basename(file)
666 :
667 0 : rank=xmpi_comm_rank(xmpi_world) !Determine my rank inside world communicator
668 :
669 0 : write(lnum,"(i0)") f90line
670 0 : write(strank,"(i0)") rank
671 0 : msg=TRIM(f90name)//':'//TRIM(lnum)//' P'//TRIM(strank)
672 0 : write(msg,'(a,2x,2a,2x,a)') ch10,TRIM(msg),ch10,TRIM(message)
673 :
674 0 : call libpaw_wrtout(std_out,msg,'PERS')
675 0 : call libpaw_leave('PERS')
676 :
677 0 : end subroutine libpaw_die
678 : !!***
679 :
680 : !----------------------------------------------------------------------
681 :
682 : !!****f* m_libpaw_tools/libpaw_lock_and_write
683 : !! NAME
684 : !! libpaw_lock_and_write
685 : !!
686 : !! FUNCTION
687 : !! Writes a string to filename with locking mechanism.
688 : !!
689 : !! INPUTS
690 : !! filename= Name of the file.
691 : !! string= Input string.
692 : !!
693 : !! SOURCE
694 :
695 0 : 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 0 : character(len=len(filename)+5) :: lock
703 :
704 : ! *********************************************************************
705 :
706 : !Try to acquire the lock.
707 0 : lock=trim(filename)//".lock"
708 0 : lock_unit=libpaw_get_free_unit()
709 0 : open(unit=lock_unit,file=trim(lock),status='new',err=99)
710 :
711 0 : file_unit=libpaw_get_free_unit()
712 0 : open(unit=file_unit,file=trim(filename),form="formatted")
713 0 : call libpaw_write_lines(file_unit,string)
714 0 : close(lock_unit,status="delete")
715 0 : close(file_unit)
716 0 : return
717 :
718 : 99 continue
719 :
720 : end subroutine libpaw_lock_and_write
721 : !!***
722 :
723 : !----------------------------------------------------------------------
724 :
725 : !!****f* m_libpaw_tools/libpaw_get_free_unit
726 : !! NAME
727 : !! libpaw_get_free_unit
728 : !!
729 : !! FUNCTION
730 : !! Obtain a free logical Fortran unit.
731 : !!
732 : !! OUTPUT
733 : !! The unit number (free unit)
734 : !! Raises:
735 : !! -1 if no logical unit is free (!)
736 : !!
737 : !! SOURCE
738 :
739 17 : 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 17 : do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
755 17 : inquire(unit=iunt,opened=isopen)
756 17 : 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
763 : !!***
764 :
765 : !----------------------------------------------------------------------
766 :
767 : !!****f* m_libpaw_tools/libpaw_flush
768 : !! NAME
769 : !! libpaw_flush
770 : !!
771 : !! FUNCTION
772 : !! Wrapper for the standard flush routine
773 : !! Available only if the compiler implements this intrinsic procedure.
774 : !!
775 : !! INPUTS
776 : !! unit=Fortran logical Unit number
777 : !!
778 : !! NOTES
779 : !! This routine comes directly from the FLUSH_UNIT routine delivered with ABINIT.
780 : !!
781 : !! SOURCE
782 :
783 0 : 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 0 : if (unit==dev_null) return
795 :
796 : !FLUSH on unconnected unit is illegal: F95 std., 9.3.5.
797 0 : inquire(unit=unit,opened=isopen)
798 :
799 : #if defined HAVE_FC_FLUSH
800 0 : if (isopen) then
801 0 : 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
810 : !!***
811 :
812 : !----------------------------------------------------------------------
813 :
814 : !!****f* m_libpaw_tools/libpaw_basename
815 : !! NAME
816 : !! libpaw_basename
817 : !!
818 : !! FUNCTION
819 : !! Returns the final component of a pathname (function version).
820 : !!
821 : !! INPUTS
822 : !! string=The input string
823 : !!
824 : !! NOTES
825 : !! This routine comes directly from the BASENAME routine delivered with ABINIT.
826 : !! If the input string in not a valid path to a file, a blank strink is returned
827 : !!
828 : !! SOURCE
829 :
830 1 : 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 1 : nch =LEN (istr)
844 1 : nch_trim=LEN_TRIM(istr)
845 :
846 1 : ic = INDEX (TRIM(istr), DIR_SEPARATOR, back=.TRUE.)
847 1 : if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the separator.
848 1 : ostr = istr(ic+1:nch_trim)
849 0 : else if (ic==0 .or. ic == nch_trim+1) then ! no separator in string or zero length string,
850 0 : ostr = TRIM(istr) ! return trimmed string.
851 : else ! (ic == nch_trim) separator is the last char.
852 0 : ostr = BLANK ! This is not a valid path to a file, return blank.
853 : end if
854 1 : return
855 :
856 1 : end function libpaw_basename
857 : !!***
858 :
859 : !----------------------------------------------------------------------
860 :
861 : !!****f* m_libpaw_tools/to_upper
862 : !! NAME
863 : !! libpaw_to_upper
864 : !!
865 : !! FUNCTION
866 : !! Convert a string to UPPER CASE (function version).
867 : !!
868 : !! INPUTS
869 : !! istr=Input string
870 : !!
871 : !! NOTES
872 : !! This routine comes directly from the TOUPPER routine delivered with ABINIT.
873 : !!
874 : !! SOURCE
875 :
876 5256 : 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 36792 : do ic=1,LEN_TRIM(istr)
891 31536 : iasc=IACHAR(istr(ic:ic))
892 36792 : if (iasc>=ASCII_aa.and.iasc<=ASCII_zz) then
893 31536 : ostr(ic:ic)=ACHAR(iasc-SHIFT)
894 : else
895 0 : ostr(ic:ic)=istr(ic:ic)
896 : end if
897 : end do
898 :
899 5256 : end function libpaw_to_upper
900 : !!***
901 :
902 : !----------------------------------------------------------------------
903 :
904 : !!****f* m_libpaw_tools/libpaw_lstrip
905 : !! NAME
906 : !! libpaw_lstrip
907 : !!
908 : !! FUNCTION
909 : !! Removes leading spaces from the input string.
910 : !!
911 : !! NOTES
912 : !! This routine comes directly from the LSTRIP routine delivered with ABINIT.
913 : !!
914 : !! SOURCE
915 :
916 0 : 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 0 : lg=LEN(istr)
929 0 : do ii=1,lg
930 0 : if (istr(ii:ii)/=BLANK) EXIT
931 : end do
932 :
933 0 : ostr = " "
934 0 : do jj=1,lg-ii+1
935 0 : ostr(jj:jj) = istr(ii:ii)
936 0 : ii=ii+1
937 : end do
938 :
939 0 : end function libpaw_lstrip
940 : !!***
941 :
942 : !----------------------------------------------------------------------
943 :
944 : !!****f* m_libpaw_tools/libpaw_indent
945 : !! NAME
946 : !! libpaw_indent
947 : !!
948 : !! FUNCTION
949 : !! Indent text (function version).
950 : !!
951 : !! INPUTS
952 : !! istr=Input string
953 : !!
954 : !! NOTES
955 : !! This routine comes directly from the INDENT routine delivered with ABINIT.
956 : !!
957 : !! SOURCE
958 :
959 0 : 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 0 : ostr=" "
974 0 : jj=n
975 0 : do ii=1,LEN_TRIM(istr)
976 0 : ch=istr(ii:ii)
977 0 : jj=jj+1
978 0 : if (ch==NCHAR) then
979 0 : ostr(jj:jj)=NCHAR
980 0 : do kk=jj+1,jj+n
981 0 : ostr(kk:kk)=" "
982 : end do
983 : jj=jj+n
984 : else
985 0 : ostr(jj:jj)=ch
986 : end if
987 : end do
988 :
989 0 : end function libpaw_indent
990 : !!***
991 :
992 : !----------------------------------------------------------------------
993 :
994 : end module m_libpaw_tools
995 : !!***
|
