Branch data 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 : 1450 : 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 : 1450 : ncomment=LIBPAW_COMMENT_COUNT
405 : 1450 : nwarning=LIBPAW_WARNING_COUNT
406 : 1450 : nexit =LIBPAW_EXIT_FLAG
407 : :
408 : 1450 : 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 : 21151 : 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 : 21151 : LIBPAW_WRITE_COMM=new_write_comm
479 : :
480 : 21151 : 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 : 287 : subroutine libpaw_log_flag_set(log_flag)
501 : :
502 : : !Arguments ------------------------------------
503 : : logical,intent(in) :: log_flag
504 : :
505 : : !Local variables ------------------------------
506 : :
507 : : ! **********************************************************************
508 : :
509 : 287 : LIBPAW_HAS_LOG_FILE=log_flag
510 : :
511 : 287 : 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 : 37 : 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 [ + - ]: 37 : do iunt=MAX_UNIT_NUMBER,MIN_UNIT_NUMBER,-1
755 : 37 : inquire(unit=iunt,opened=isopen)
756 [ - + ]: 37 : 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 : 9 : 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 : 9 : nch =LEN (istr)
844 : 9 : nch_trim=LEN_TRIM(istr)
845 : :
846 : 9 : ic = INDEX (TRIM(istr), DIR_SEPARATOR, back=.TRUE.)
847 : 9 : if (ic >= 1 .and. ic <= nch_trim-1) then ! there is stuff after the separator.
848 [ + - + - ]: 9 : 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 : 9 : return
855 : :
856 [ + - ]: 9 : 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 : 5375 : 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 [ + + ]: 37625 : do ic=1,LEN_TRIM(istr)
891 : 32250 : iasc=IACHAR(istr(ic:ic))
892 [ + - ]: 37625 : if (iasc>=ASCII_aa.and.iasc<=ASCII_zz) then
893 : 32250 : ostr(ic:ic)=ACHAR(iasc-SHIFT)
894 : : else
895 : 0 : ostr(ic:ic)=istr(ic:ic)
896 : : end if
897 : : end do
898 : :
899 : 5375 : 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 : : !!***
|
