1! 2! Copyright (C) 2002-2020 Quantum ESPRESSO group 3! This file is distributed under the terms of the 4! GNU General Public License. See the file `License' 5! in the root directory of the present distribution, 6! or http://www.gnu.org/copyleft/gpl.txt . 7! 8!=----------------------------------------------------------------------------=! 9MODULE io_files 10!=----------------------------------------------------------------------------=! 11 ! 12 USE parameters, ONLY: ntypx 13 USE kinds, ONLY: dp 14 USE io_global, ONLY: ionode, ionode_id, stdout 15 USE mp, ONLY: mp_barrier, mp_bcast, mp_sum 16 USE mp_images, ONLY: me_image, intra_image_comm, nproc_image 17 ! 18 ! ... I/O related variables: file names, units, utilities 19 ! ... IMPORTANT: when directory names are set, they must always end with "/" 20 ! 21 IMPLICIT NONE 22 ! 23 SAVE 24 PUBLIC :: create_directory, check_tempdir, clean_tempdir, check_file_exist, & 25 delete_if_present, check_writable, restart_dir, xmlfile, check_restartfile 26 ! 27 ! ... directory for all temporary files 28 CHARACTER(len=256) :: tmp_dir = './' 29 ! ... directory for large files on each node. Default: same as tmp_dir 30 CHARACTER(len=256) :: wfc_dir = 'undefined' 31 ! ... prefix is prepended to all file (and directory) names 32 CHARACTER(len=256) :: prefix = 'os' 33 ! ... postfix is appended to directory names 34#if defined (_WIN32) 35#if defined (__PGI) 36 CHARACTER(len=6) :: postfix = '.save/' 37#else 38 CHARACTER(len=6) :: postfix = '.save\' 39#endif 40#else 41 CHARACTER(len=6) :: postfix = '.save/' 42#endif 43 ! ... for parallel case and distributed I/O: node number 44 CHARACTER(len=6) :: nd_nmbr = '000000' 45 ! ... directory where pseudopotential files are found 46 CHARACTER(len=256) :: pseudo_dir = './' 47 ! ... location of PP files after a restart from file 48 CHARACTER(len=256) :: pseudo_dir_cur = ' ' 49 CHARACTER(len=256) :: psfile( ntypx ) = 'UPF' 50 ! 51 CHARACTER(LEN=256) :: qexsd_fmt = ' ', qexsd_version = ' ' 52 LOGICAL :: qexsd_init = .FALSE. 53 ! ... next two variables are no longer read from input but can be set 54 ! ... by external codes using QE routines to perform an interpolation 55 ! ... of valence electrons only, without the atomic-like part 56 CHARACTER(LEN=256) :: input_drho = ' ' 57 CHARACTER(LEN=256) :: output_drho= ' ' 58 ! 59 CHARACTER(LEN=5 ), PARAMETER :: crash_file = 'CRASH' 60 CHARACTER (LEN=261) :: exit_file = 'os.EXIT' ! file required for a soft exit 61 ! 62 CHARACTER (LEN=20), PARAMETER :: xmlpun_schema = 'data-file-schema.xml' 63 ! 64 ! ... The units where various variables are saved 65 ! ... Only units that are kept open during the run should be listed here 66 ! 67 INTEGER :: iunres = 1 ! unit for the restart of the run 68 INTEGER :: iunpun = 4 ! unit for saving the final results (data-file.xml) 69 INTEGER :: iunwfc = 10 ! unit with wavefunctions 70 INTEGER :: iunoldwfc = 11 ! unit with old wavefunctions 71 INTEGER :: iunoldwfc2 = 12 ! as above at step -2 72 INTEGER :: iunhub = 13 ! unit for saving Hubbard-U atomic wfcs * S 73 INTEGER :: iunsat = 14 ! unit for saving (orthogonal) atomic wfcs * S 74 INTEGER :: iunmix = 15 ! unit for saving mixing information 75 INTEGER :: iunwfc_exx = 16 ! unit with exx wavefunctions 76 ! 77 INTEGER :: iunexit = 26 ! unit for a soft exit 78 INTEGER :: iunupdate = 27 ! unit for saving old positions (extrapolation) 79 ! NEB 80 INTEGER :: iunnewimage = 28 ! unit for parallelization among images 81 INTEGER :: iunlock = 29 ! as above (locking file) 82 ! 83 INTEGER :: iunbfgs = 30 ! unit for the bfgs restart file 84 ! 85 INTEGER :: iuntmp = 90 ! temporary unit, when used must be closed ASAP 86 ! 87 INTEGER :: nwordwfc = 2 ! length of record in wavefunction file 88 INTEGER :: nwordatwfc = 2 ! length of record in atomic wfc file 89 INTEGER :: nwordwfcU = 2 ! length of record in atomic hubbard wfc file 90 INTEGER :: nwordwann = 2 ! length of record in sic wfc file 91 ! 92 !... finite electric field 93 ! 94 INTEGER :: iunefield = 31 ! unit to store wavefunction for calculating 95 ! electric field operator 96 INTEGER :: iunefieldm = 32 ! unit to store projectors for hermitean 97 ! electric field potential 98 INTEGER :: iunefieldp = 33 ! unit to store projectors for hermitean 99 ! electric field potential 100 ! 101 ! ... For Wannier Hamiltonian 102 ! 103 INTEGER :: iunwpp = 113 104 INTEGER :: iunwf = 114 105 INTEGER :: nwordwpp = 2 106 INTEGER :: nwordwf = 2 107 ! 108CONTAINS 109 ! 110 !------------------------------------------------------------------------ 111 SUBROUTINE create_directory( dirname ) 112 !------------------------------------------------------------------------ 113 ! 114 USE wrappers, ONLY : f_mkdir_safe 115 ! 116 CHARACTER(LEN=*), INTENT(IN) :: dirname 117 ! 118 INTEGER :: ierr, length 119 ! 120 CHARACTER(LEN=6), EXTERNAL :: int_to_char 121 ! 122 length = LEN_TRIM(dirname) 123#if defined (_WIN32) 124 ! Windows returns error if tmp_dir ends with a backslash 125#if defined (__PGI) 126 IF ( dirname(length:length) == '\\' ) length=length-1 127#else 128 IF ( dirname(length:length) == '\' ) length=length-1 129#endif 130#endif 131 IF ( ionode ) ierr = f_mkdir_safe( dirname(1:length ) ) 132 CALL mp_bcast ( ierr, ionode_id, intra_image_comm ) 133 ! 134 CALL errore( 'create_directory', & 135 'unable to create directory ' // TRIM( dirname ), ierr ) 136 ! 137 ! ... syncronize all jobs (not sure it is really useful) 138 ! 139 CALL mp_barrier( intra_image_comm ) 140 ! 141 ! ... check whether the scratch directory is writable 142 ! 143 IF ( ionode ) ierr = check_writable ( dirname, me_image ) 144 CALL mp_bcast( ierr, ionode_id, intra_image_comm ) 145 ! 146 CALL errore( 'create_directory:', & 147 TRIM( dirname ) // ' non existent or non writable', ierr ) 148 ! 149 RETURN 150 ! 151 END SUBROUTINE create_directory 152 ! 153 !----------------------------------------------------------------------- 154 SUBROUTINE check_tempdir ( tmp_dir, exst, pfs ) 155 !----------------------------------------------------------------------- 156 ! 157 ! ... Verify if tmp_dir exists, creates it if not 158 ! ... On output: 159 ! ... exst= .t. if tmp_dir exists 160 ! ... pfs = .t. if tmp_dir visible from all procs of an image 161 ! 162 USE wrappers, ONLY : f_mkdir_safe 163 ! 164 IMPLICIT NONE 165 ! 166 CHARACTER(len=*), INTENT(in) :: tmp_dir 167 LOGICAL, INTENT(out) :: exst, pfs 168 ! 169 INTEGER :: ios, image, proc, nofi, length 170 CHARACTER (len=256) :: file_path, filename 171 CHARACTER(len=6), EXTERNAL :: int_to_char 172 ! 173 ! ... create tmp_dir on ionode 174 ! ... f_mkdir_safe returns -1 if tmp_dir already exists 175 ! ... 0 if created 176 ! ... 1 if cannot be created 177 ! 178 length = LEN_TRIM(tmp_dir) 179#if defined (_WIN32) 180 ! Windows returns error if tmp_dir ends with a backslash 181#if defined (__PGI) 182 IF ( tmp_dir(length:length) == '\\' ) length=length-1 183#else 184 IF ( tmp_dir(length:length) == '\' ) length=length-1 185#endif 186#endif 187 IF ( ionode ) ios = f_mkdir_safe( tmp_dir(1:length) ) 188 CALL mp_bcast ( ios, ionode_id, intra_image_comm ) 189 exst = ( ios == -1 ) 190 IF ( ios > 0 ) CALL errore ('check_tempdir', 'temporary directory ' & 191 & // tmp_dir(1:length) // ' cannot be created or accessed',1) 192 ! 193 ! ... let us check now if tmp_dir is visible on all nodes 194 ! ... if not, a local tmp_dir is created on each node 195 ! 196 ios = f_mkdir_safe( TRIM(tmp_dir) ) 197 CALL mp_sum ( ios, intra_image_comm ) 198 pfs = ( ios == -nproc_image ) ! actually this is true only if .not.exst 199 ! 200 RETURN 201 ! 202 END SUBROUTINE check_tempdir 203 ! 204 !----------------------------------------------------------------------- 205 SUBROUTINE clean_tempdir( tmp_dir ) 206 !----------------------------------------------------------------------- 207 ! 208 IMPLICIT NONE 209 ! 210 CHARACTER(len=*), INTENT(in) :: tmp_dir 211 ! 212 CHARACTER (len=256) :: file_path, filename 213 ! 214 ! ... remove temporary files from tmp_dir ( only by the master node ) 215 ! 216 file_path = trim( tmp_dir ) // trim( prefix ) 217 IF ( ionode ) THEN 218 CALL delete_if_present( trim( file_path ) // '.update' ) 219 CALL delete_if_present( trim( file_path ) // '.md' ) 220 CALL delete_if_present( trim( file_path ) // '.bfgs' ) 221 ENDIF 222 ! 223 RETURN 224 ! 225 END SUBROUTINE clean_tempdir 226 ! 227 !------------------------------------------------------------------------ 228 FUNCTION check_file_exist( filename ) 229 !------------------------------------------------------------------------ 230 ! 231 IMPLICIT NONE 232 ! 233 LOGICAL :: check_file_exist 234 CHARACTER(LEN=*) :: filename 235 ! 236 LOGICAL :: lexists 237 ! 238 IF ( ionode ) THEN 239 ! 240 INQUIRE( FILE = TRIM( filename ), EXIST = lexists ) 241 ! 242 ENDIF 243 ! 244 CALL mp_bcast ( lexists, ionode_id, intra_image_comm ) 245 ! 246 check_file_exist = lexists 247 RETURN 248 ! 249 END FUNCTION check_file_exist 250 ! 251 !-------------------------------------------------------------------------- 252 SUBROUTINE delete_if_present(filename, para) 253 !-------------------------------------------------------------------------- 254 !! 255 !! Same as the delete_if_present subroutine but allows for other cores to 256 !! enters (SP - Jan 2020). Ideally, both could be merged. 257 !! 258 ! 259 IMPLICIT NONE 260 ! 261 CHARACTER(len = *), INTENT(in) :: filename 262 !! Name of the file 263 LOGICAL, OPTIONAL, INTENT(in) :: para 264 !! Optionally, the remove can be done by all the cores. 265 ! 266 ! Local variables 267 LOGICAL :: exst 268 !! Check if the file exist 269 INTEGER :: iunit 270 !! UNit of the file 271 INTEGER, EXTERNAL :: find_free_unit 272 !! Find a unallocated unit 273 ! 274 IF (PRESENT(para)) THEN 275 IF (.NOT. para) THEN 276 IF (.NOT. ionode) RETURN 277 ENDIF 278 ELSE ! Default if not present 279 IF (.NOT. ionode) RETURN 280 ENDIF 281 ! 282 INQUIRE(FILE = filename, EXIST = exst) 283 ! 284 IF (exst) THEN 285 ! 286 iunit = find_free_unit() 287 ! 288 OPEN(UNIT = iunit, FILE = filename, STATUS = 'OLD') 289 CLOSE(UNIT = iunit, STATUS = 'DELETE') 290 ! 291 WRITE(UNIT = stdout, FMT = '(/,5X,"File ", A, " deleted, as requested")') TRIM(filename) 292 ! 293 ENDIF 294 ! 295 RETURN 296 ! 297 !-------------------------------------------------------------------------- 298 END SUBROUTINE delete_if_present 299 !-------------------------------------------------------------------------- 300 ! 301 !-------------------------------------------------------------------------- 302 FUNCTION check_writable ( file_path, process_id ) RESULT ( ios ) 303 !-------------------------------------------------------------------------- 304 ! 305 ! ... if run by multiple processes, specific "process_id" to avoid 306 ! ... opening, closing, deleting the same file from different processes 307 ! 308 ! 309 IMPLICIT NONE 310 ! 311 CHARACTER(LEN=*), INTENT(IN) :: file_path 312 INTEGER, OPTIONAL, INTENT(IN) :: process_id 313 ! 314 INTEGER :: ios 315 ! 316 CHARACTER(LEN=6), EXTERNAL :: int_to_char 317 ! 318 ! ... check whether the scratch directory is writable 319 ! ... note that file_path should end by a "/" 320 ! 321 IF ( PRESENT (process_id ) ) THEN 322 OPEN( UNIT = 4, FILE = TRIM(file_path) // 'test' // & 323 & TRIM( int_to_char ( process_id ) ), & 324 & STATUS = 'UNKNOWN', FORM = 'UNFORMATTED', IOSTAT = ios ) 325 ELSE 326 OPEN( UNIT = 4, FILE = TRIM(file_path) // 'test', & 327 STATUS = 'UNKNOWN', FORM = 'UNFORMATTED', IOSTAT = ios ) 328 END IF 329 ! 330 CLOSE( UNIT = 4, STATUS = 'DELETE' ) 331 ! 332 !----------------------------------------------------------------------- 333 END FUNCTION check_writable 334 !----------------------------------------------------------------------- 335 ! 336 !------------------------------------------------------------------------ 337 FUNCTION restart_dir( runit ) 338 !------------------------------------------------------------------------ 339 ! 340 CHARACTER(LEN=256) :: restart_dir 341 INTEGER, INTENT(IN), OPTIONAL :: runit 342 ! 343 CHARACTER(LEN=6), EXTERNAL :: int_to_char 344 ! 345 ! ... main restart directory (contains final / or Windows equivalent) 346 ! 347 IF ( PRESENT (runit) ) THEN 348 restart_dir = TRIM(tmp_dir) // TRIM(prefix) // '_' // & 349 TRIM(int_to_char(runit)) // postfix 350 ELSE 351 restart_dir = TRIM(tmp_dir) // TRIM(prefix) // postfix 352 END IF 353 ! 354 RETURN 355 ! 356 END FUNCTION restart_dir 357 ! 358 !------------------------------------------------------------------------ 359 FUNCTION xmlfile ( runit ) 360 !------------------------------------------------------------------------ 361 ! 362 CHARACTER(LEN=320) :: xmlfile 363 INTEGER, INTENT(IN), OPTIONAL :: runit 364 ! 365 ! ... xml file in main restart directory 366 ! 367 xmlfile = TRIM( restart_dir(runit) ) // xmlpun_schema 368 ! 369 RETURN 370 ! 371 END FUNCTION xmlfile 372 ! 373 !------------------------------------------------------------------------ 374 FUNCTION check_restartfile( ndr ) 375 !------------------------------------------------------------------------ 376 ! 377 IMPLICIT NONE 378 ! 379 LOGICAL :: check_restartfile 380 INTEGER, INTENT(IN), OPTIONAL:: ndr 381 CHARACTER(LEN=320) :: filename 382 LOGICAL :: lval 383 ! 384 ! 385 filename = xmlfile( ndr ) 386 ! 387 IF ( ionode ) THEN 388 ! 389 INQUIRE( FILE = TRIM( filename ), EXIST = lval ) 390 ! 391 END IF 392 ! 393 CALL mp_bcast( lval, ionode_id, intra_image_comm ) 394 ! 395 check_restartfile = lval 396 ! 397 RETURN 398 ! 399 END FUNCTION check_restartfile 400! 401!----------------------------------------------------------------------- 402subroutine diropn (unit, extension, recl, exst, tmp_dir_) 403 !----------------------------------------------------------------------- 404 ! 405 ! Opens a direct-access file named "prefix"."extension" in directory 406 ! "tmp_dir_" if specified, in "tmp_dir" otherwise. 407 ! In parallel execution, the node number is added to the file name. 408 ! The record length is "recl" double-precision numbers. 409 ! On output, "exst" is .T. if opened file already exists 410 ! If recl=-1, the file existence is checked, nothing else is done 411 ! 412 implicit none 413 ! 414 ! first the input variables 415 ! 416 character(len=*) :: extension 417 ! input: name of the file to open 418 character(len=*), optional :: tmp_dir_ 419 ! optional variable, if present it is used as tmp_dir 420 integer :: unit, recl 421 ! input: unit of the file to open 422 ! input: length of the records 423 logical :: exst 424 ! output: if true the file exists 425 ! 426 ! local variables 427 ! 428 character(len=256) :: tempfile, filename 429 ! complete file name 430 real(dp):: dummy 431 integer*8 :: unf_recl 432 ! double precision to prevent integer overflow 433 integer :: ios, direct_io_factor 434 logical :: opnd 435 ! 436 ! initial checks 437 ! 438 if (unit < 0) call errore ('diropn', 'wrong unit', 1) 439 ! 440 ! ifirst we check that the file is not already openend 441 ! 442 ios = 0 443 inquire (unit = unit, opened = opnd) 444 if (opnd) call errore ('diropn', "can't open a connected unit", abs(unit)) 445 ! 446 ! then we check the filename extension 447 ! 448 if (extension == ' ') call errore ('diropn','filename extension not given',2) 449 filename = trim(prefix) // "." // trim(extension) 450 if (present(tmp_dir_)) then 451 tempfile = trim(tmp_dir_) // trim(filename) //nd_nmbr 452 else 453 tempfile = trim(tmp_dir) // trim(filename) //nd_nmbr 454 endif 455 456 inquire (file = tempfile, exist = exst) 457 if (recl == -1) RETURN 458 ! 459 ! the record length in direct-access I/O is given by the number of 460 ! real*8 words times direct_io_factor (may depend on the compiler) 461 ! 462 INQUIRE (IOLENGTH=direct_io_factor) dummy 463 unf_recl = direct_io_factor * int(recl, kind=kind(unf_recl)) 464 if (unf_recl <= 0) call errore ('diropn', 'wrong record length', 3) 465 ! 466 open (unit, file=trim(adjustl(tempfile)), iostat=ios, form='unformatted', & 467 status = 'unknown', access = 'direct', recl = unf_recl) 468 469 if (ios /= 0) call errore ('diropn', 'error opening '//trim(tempfile), unit) 470 return 471 !----------------------------------------------------------------------- 472end subroutine diropn 473!----------------------------------------------------------------------- 474! 475!----------------------------------------------------------------------- 476subroutine seqopn (unit, extension, formatt, exst, tmp_dir_) 477 !----------------------------------------------------------------------- 478 ! 479 ! this routine opens a file named "prefix"."extension" 480 ! in tmp_dir for sequential I/O access 481 ! If appropriate, the node number is added to the file name 482 ! 483 implicit none 484 ! 485 ! first the dummy variables 486 ! 487 character(len=*) :: formatt, extension 488 ! input: name of the file to connect 489 ! input: 'formatted' or 'unformatted' 490 character(len=*), optional :: tmp_dir_ 491 ! optional variable, if present it is used as tmp_dir 492 integer :: unit 493 ! input: unit to connect 494 logical :: exst 495 ! output: true if the file already exist 496 ! 497 ! here the local variables 498 ! 499 character(len=256) :: tempfile, filename 500 ! complete file name 501 integer :: ios 502 ! integer variable to test I/O status 503 logical :: opnd 504 ! true if the file is already opened 505 506 507 if (unit < 1) call errore ('seqopn', 'wrong unit', 1) 508 ! 509 ! test if the file is already opened 510 ! 511 ios = 0 512 inquire (unit = unit, opened = opnd) 513 if (opnd) call errore ('seqopn', "can't open a connected unit", & 514 abs (unit) ) 515 ! 516 ! then we check the extension of the filename 517 ! 518 if (extension.eq.' ') call errore ('seqopn','filename extension not given',2) 519 filename = trim(prefix) // "." // trim(extension) 520 ! Use the tmp_dir from input, if available 521 if ( present(tmp_dir_) ) then 522 tempfile = trim(tmp_dir_) // trim(filename) 523 else 524 tempfile = trim(tmp_dir) // trim(filename) 525 end if 526 if ( trim(nd_nmbr) /= '1' .and. trim(nd_nmbr) /= '01' .and. & 527 trim(nd_nmbr) /= '001' .and. trim(nd_nmbr) /= '0001' .and. & 528 trim(nd_nmbr) /= '00001' .and. trim(nd_nmbr) /= '000001' ) then 529 ! 530 ! do not add processor number to files opened by processor 1 531 ! in parallel execution: if only the first processor writes, 532 ! we do not want the filename to be dependent on the number 533 ! of processors 534 ! 535 tempfile = trim(tempfile) // nd_nmbr 536 end if 537 inquire (file = tempfile, exist = exst) 538 ! 539 ! Open the file 540 ! 541 open (unit = unit, file = tempfile, form = formatt, status = & 542 'unknown', iostat = ios) 543 544 if (ios /= 0) call errore ('seqopn', 'error opening '//trim(tempfile), unit) 545 return 546 !----------------------------------------------------------------------- 547end subroutine seqopn 548!----------------------------------------------------------------------- 549! 550!=----------------------------------------------------------------------------=! 551END MODULE io_files 552!=----------------------------------------------------------------------------=! 553! 554!---------------------------------------------------------------------------- 555SUBROUTINE davcio( vect, nword, unit, nrec, io ) 556 !---------------------------------------------------------------------------- 557 ! 558 ! ... direct-access vector input/output 559 ! ... read/write nword words starting from the address specified by vect 560 ! 561 USE kinds , ONLY : DP 562 ! 563 IMPLICIT NONE 564 ! 565 INTEGER, INTENT(IN) :: nword, unit, nrec, io 566 ! input: the dimension of vect 567 ! input: the unit where to read/write 568 ! input: the record where to read/write 569 ! input: flag if < 0 reading if > 0 writing 570 REAL(DP), INTENT(INOUT) :: vect(nword) 571 ! input/output: the vector to read/write 572 ! 573 INTEGER :: ios 574 ! integer variable for I/O control 575 LOGICAL :: opnd 576 CHARACTER*256 :: name 577 ! 578 ! 579 CALL start_clock( 'davcio' ) 580 ! 581 IF ( unit <= 0 ) CALL errore( 'davcio', 'wrong unit', 1 ) 582 IF ( nrec <= 0 ) CALL errore( 'davcio', 'wrong record number', 2 ) 583 IF ( nword <= 0 ) CALL errore( 'davcio', 'wrong record length', 3 ) 584 IF ( io == 0 ) CALL infomsg( 'davcio', 'nothing to do?' ) 585 ! 586 INQUIRE( UNIT = unit, OPENED = opnd, NAME = name ) 587 ! 588 IF ( .NOT. opnd ) & 589 CALL errore( 'davcio', 'unit is not opened', unit ) 590 ! 591 ios = 0 592 ! 593 IF ( io < 0 ) THEN 594 ! 595 READ( UNIT = unit, REC = nrec, IOSTAT = ios ) vect 596 IF ( ios /= 0 ) CALL errore( 'davcio', & 597 & 'error reading file "' // TRIM(name) // '"', unit ) 598 ! 599 ELSE IF ( io > 0 ) THEN 600 ! 601 WRITE( UNIT = unit, REC = nrec, IOSTAT = ios ) vect 602 IF ( ios /= 0 ) CALL errore( 'davcio', & 603 & 'error writing file "' // TRIM(name) // '"', unit ) 604 ! 605 END IF 606 ! 607 CALL stop_clock( 'davcio' ) 608 ! 609 RETURN 610 ! 611END SUBROUTINE davcio 612 613