quantum-espresso/Modules/qexsd.f90

! Copyright (C) 2003-2015 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!----------------------------------------------------------------------------
MODULE qexsd_module
  !----------------------------------------------------------------------------
  !
  ! This module contains subroutines used to read and write in XML format,
  ! according to the "shema", the data produced by Quantum ESPRESSO
  !
  ! Based on initial work by Carlo Sbraccia (2003)
  ! and on the qexml.f90 routines written by Andrea Ferretti (2006)
  ! Modified by Simone Ziraldo (2013).
  ! Rewritten by Giovanni Borghi, A. Ferretti, et al. (2015).
  ! Heavily modified by Pietro Delugas and Paolo Giannozzi (2016 on)
  !
  !
  USE kinds,            ONLY : DP
  USE input_parameters, ONLY : input_xml_schema_file
  USE mp_world,         ONLY : nproc
  USE mp_images,        ONLY : nimage,nproc_image
  USE mp_pools,         ONLY : npool
  USE mp_bands,         ONLY : ntask_groups, nproc_bgrp, nbgrp
  USE global_version,   ONLY : version_number
  !
  USE qes_types_module
  USE qes_write_module, ONLY : qes_write
  USE qes_reset_module, ONLY : qes_reset
  USE qes_init_module,  ONLY : qes_init
  !
  USE FoX_wxml,         ONLY : xmlf_t
  !
  IMPLICIT NONE
  !
  PRIVATE
  SAVE
  !
  ! definitions for the fmt
  !
  CHARACTER(5), PARAMETER :: fmt_name = "QEXSD"
  CHARACTER(8), PARAMETER :: fmt_version = "19.03.04"
  !
  ! internal data to be set
  !
  TYPE(xmlf_t)     :: qexsd_xf
  !
  ! vars to manage back compatibility
  !
  CHARACTER(10)    :: qexsd_current_version = " "
  CHARACTER(10)    :: qexsd_default_version = trim( fmt_version  )
  LOGICAL          :: qexsd_current_version_init = .FALSE.
  ! 
  TYPE (input_type)                            :: qexsd_input_obj
  TYPE (general_info_type)                     :: general_info
  TYPE (parallel_info_type)                    :: parallel_info
  TYPE (step_type), ALLOCATABLE                :: steps(:)
  INTEGER                                      :: exit_status
  TYPE ( closed_type )                         :: qexsd_closed_element
  INTEGER                                      :: step_counter
  !
  ! end of declarations
  !
  PUBLIC :: qexsd_xf  
  PUBLIC :: qexsd_openschema, qexsd_closeschema
  PUBLIC :: qexsd_input_obj
  PUBLIC :: qexsd_step_addstep, qexsd_reset_steps
  PUBLIC :: qexsd_current_version, qexsd_default_version, qexsd_current_version_init
  PUBLIC :: qexsd_set_status
  ! 
CONTAINS
!
!-------------------------------------------
! ... basic subroutines
!-------------------------------------------
!
    !
    !-------------------------------------------------------------------------------------------------
    SUBROUTINE qexsd_set_status(status_int)
    !-------------------------------------------------------------------------------------------------
    IMPLICIT NONE
    !
    INTEGER      :: status_int
    END SUBROUTINE qexsd_set_status
    !
!
!-------------------------------------------
! ... subroutine writing header, general, parallel info to file
!-------------------------------------------
!
    !
    !------------------------------------------------------------------------
    SUBROUTINE qexsd_openschema(filename, ounit, prog, title)
      !------------------------------------------------------------------------
      !
      USE  FoX_wxml,  ONLY: xml_OpenFile, xml_DeclareNamespace, xml_NewElement, xml_addAttribute, xml_addComment                         
      IMPLICIT NONE
      !
      CHARACTER(len=*), INTENT(IN) :: filename, prog, title
      INTEGER, INTENT(IN) :: ounit
      CHARACTER(len=16) :: subname = 'qexsd_openschema'
      INTEGER :: ierr, len_steps, i_step
      !
      ! we need a qes-version number here
      CALL xml_OpenFile(FILENAME = TRIM(filename), XF = qexsd_xf, UNIT = ounit,&
              PRETTY_PRINT = .TRUE., REPLACE  = .TRUE., NAMESPACE = .TRUE., &
              IOSTAT = ierr ) 
      !
      CALL xml_DeclareNamespace (XF=qexsd_xf, PREFIX = "xsi", nsURI ="http://www.w3.org/2001/XMLSchema-instance")
      CALL xml_DeclareNamespace (XF=qexsd_xf, PREFIX = "qes", nsURI ="http://www.quantum-espresso.org/ns/qes/qes-1.0")
      CALL xml_NewElement (XF=qexsd_xf, NAME = "qes:espresso")
      CALL xml_addAttribute(XF=qexsd_xf, NAME = "xsi:schemaLocation", &
                            VALUE = "http://www.quantum-espresso.org/ns/qes/qes-1.0 "//&
                                    "http://www.quantum-espresso.org/ns/qes/qes_190304.xsd" )
      CALL xml_addAttribute(XF=qexsd_xf, NAME="Units", VALUE="Hartree atomic units")
      CALL xml_addComment(XF = qexsd_xf, &
              COMMENT = "All quantities are in Hartree atomic units unless otherwise specified" ) 
      !
      IF (ierr /= 0) call errore(subname, 'opening xml output file', ierr)
      ! the input file is mandatory to have a validating schema 
      ! here an error should be issued, instead
      !
      CALL qexsd_init_general_info(general_info, prog(1:2), title )
      CALL qes_write (qexsd_xf,general_info)
      CALL qes_reset (general_info)
      !
      CALL qexsd_init_parallel_info(parallel_info)
      CALL qes_write (qexsd_xf,parallel_info)
      CALL qes_reset (parallel_info) 
      IF ( check_file_exst(input_xml_schema_file) )  THEN
         CALL xml_addComment( XF = qexsd_xf, COMMENT= "")
         CALL qexsd_cp_line_by_line(ounit ,input_xml_schema_file, spec_tag="input")
      ELSE IF ( TRIM(qexsd_input_obj%tagname) == "input") THEN 
         CALL qes_write (qexsd_xf, qexsd_input_obj)
      END IF
      ! 
      IF (ALLOCATED(steps) ) THEN 
         len_steps= step_counter 
         IF (TRIM (steps(1)%tagname ) .EQ. 'step') THEN
            DO i_step = 1, len_steps
               CALL qes_write (qexsd_xf, steps(i_step) )
            END DO 
         END IF
      END IF
      ! 
    END SUBROUTINE qexsd_openschema
    !
    !
    !---------------------------------------------------------------------------------------
    SUBROUTINE qexsd_init_general_info(obj, prog, title )
    !---------------------------------------------------------------------------------------
      IMPLICIT NONE
      !
      TYPE( general_info_type )         ::  obj
      CHARACTER(LEN=*),INTENT(IN)       ::  prog
      CHARACTER(LEN=*),INTENT(IN)       ::  title
      CHARACTER(LEN=*),PARAMETER        ::  TAGNAME="general_info"
      TYPE( creator_type )              ::  creator_obj
      TYPE( created_type )              ::  created_obj
      TYPE( xml_format_type)            ::  xml_fmt_obj
      CHARACTER(LEN=256)                ::  version
      CHARACTER(9)                      ::  cdate, ctime
      CHARACTER(60)                     ::  timestamp
      !
      version=TRIM(version_number)
      SELECT CASE( prog(1:2))
         CASE ('pw','PW') 
            CALL qes_init (creator_obj, "creator", "PWSCF", version, "XML file generated by PWSCF")
         CASE ('cp', 'CP') 
            CALL qes_init (creator_obj, "creator", "CP", version, "XML file generated by CP") 
      END SELECT
      !
      CALL date_and_tim(cdate, ctime) 
      timestamp = 'This run was terminated on:  ' // ctime // ' ' // cdate(1:2) // & 
                  ' '//cdate(3:5) // ' '// cdate (6:9)
     
      CALL qes_init (created_obj, "created", cdate, ctime, timestamp ) 
      !
      CALL qes_init (xml_fmt_obj, "xml_format", fmt_name, fmt_version, fmt_name//"_"//fmt_version)
      !
      CALL qes_init ( obj, TAGNAME, XML_FORMAT = xml_fmt_obj, CREATOR = creator_obj, CREATED = created_obj, &
                      JOB=title)
      !
      CALL qes_reset (creator_obj)
      CALL qes_reset (created_obj)
      CALL qes_reset (xml_fmt_obj) 
    END SUBROUTINE qexsd_init_general_info    
    !
    !---------------------------------------------------------------------------------------------
    SUBROUTINE   qexsd_init_parallel_info(obj)
    !---------------------------------------------------------------------------------------------
      IMPLICIT NONE
      !
      TYPE ( parallel_info_type )           :: obj
      !
      INTEGER                               :: nthreads=1
#if defined(__OMP) 
      INTEGER,EXTERNAL                      :: omp_get_max
      !     
      nthreads = omp_get_max()
#endif      
      CALL qes_init (obj, "parallel_info", nproc, nthreads, ntask_groups, &
                                  nbgrp, npool, nproc_bgrp)
    END SUBROUTINE qexsd_init_parallel_info
    !
!
!-------------------------------------------
! ... subroutine writing status and timing info to file and closing it
!-------------------------------------------
!
    !
    !------------------------------------------------------------------------
    SUBROUTINE qexsd_closeschema()
      !------------------------------------------------------------------------
      USE mytime,    ONLY: nclock, clock_label
      USE FOX_wxml,  ONLY: xml_NewElement, xml_AddCharacters, xml_EndElement, xml_Close   
      IMPLICIT NONE
      REAL(DP),EXTERNAL     :: get_clock
      TYPE(timing_type) :: qexsd_timing_  
      !
      CHARACTER(len=17) :: subname = 'qexsd_closeschema'
      INTEGER :: ierr
      !
      IF (exit_status .ge. 0 ) THEN 
         CALL xml_NewElement(qexsd_xf, "status")
         CALL xml_AddCharacters(qexsd_xf, exit_status)
         CALL xml_EndElement(qexsd_xf, "status")          
         CALL qexsd_set_closed()
         IF (get_clock('PWSCF') > get_clock('CP'))  THEN 
            CALL qexsd_init_clocks (qexsd_timing_, 'PWSCF       ' , ['electrons   '])
         ELSE 
            CALL qexsd_init_clocks (qexsd_timing_, 'CP          ') 
         END IF 
         CALL qes_write ( qexsd_xf, qexsd_timing_) 
         CALL qes_reset(qexsd_timing_) 
         !CALL xml_NewElement (qexsd_xf, "cputime")
         !CALL xml_addCharacters(qexsd_xf, MAX(nint(get_clock('PWSCF')),nint(get_clock('CP'))) )
         !CALL xml_EndElement ( qexsd_xf, "cputime")
         CALL qes_write (qexsd_xf, qexsd_closed_element)
      END IF
         CALL xml_Close(qexsd_xf) 
      !
    END SUBROUTINE qexsd_closeschema
    !
!
!-------------------------------------------
! ... utilities
!-------------------------------------------
!
    !
    !------------------------------------------------------------------------
    FUNCTION check_file_exst( filename )
      !------------------------------------------------------------------------
      !
      IMPLICIT NONE
      !
      LOGICAL          :: check_file_exst
      CHARACTER(len=*) :: filename
      !
      LOGICAL :: lexists
      !
      INQUIRE( FILE = trim( filename ), EXIST = lexists )
      !
      check_file_exst = lexists
      RETURN
      !
    END FUNCTION check_file_exst
    !
    !
    !------------------------------------------------------------------------
    SUBROUTINE qexsd_cp_line_by_line(iun_out,filename,spec_tag)
      !------------------------------------------------------------------------
      implicit none
      !
      integer,      intent(in) :: iun_out
      character(*), intent(in) :: filename
      character(*), optional, intent(in) :: spec_tag
      !
      integer :: iun, ierr
      character(256) :: str
      logical :: icopy, exists
      integer, external  :: find_free_unit

      iun =  find_free_unit()
      !
      INQUIRE(FILE=trim(filename), EXIST=exists)
      !
      IF(.not.exists) THEN
         CALL errore('qexsd_cp_line_by_line', 'input xml file "' // & 
        &             TRIM(filename) // '" not found', 1)
      ENDIF
      !
      open(iun,FILE=trim(filename),status="old", IOSTAT=ierr)
      !
      icopy=.false.
      copy_loop: do
         !
         read(iun,"(a256)",iostat=ierr) str
         if (ierr<0) exit copy_loop
         if (present(spec_tag)) then
            !
            if (index(str,"<"//trim(adjustl(spec_tag))//">")/=0) then
               !
               icopy=.true.
               !
            endif
            !
         else
            !
            icopy=.true.
            !
         endif
         ! 
         ! filtering
         ! 
         if ( index(str,"<Root>")/=0 .or. index(str,"<Root>")/=0 .or. &
              index(str,"<?")/=0     .or. .not.icopy) cycle copy_loop
         !
         write(iun_out,"(a)") trim(str)
         !
         if (present(spec_tag)) then
            if (index(str,"</input>")/=0) icopy=.false.
         endif
         ! 
      enddo copy_loop
      !
      close(iun)
      ! 
    END SUBROUTINE qexsd_cp_line_by_line
    !
!
!-------------------------------------------
! ... subroutine related to MD steps
!-------------------------------------------
!
    ! 
    !----------------------------------------------------------------------------------------
    SUBROUTINE qexsd_step_addstep(i_step, max_steps, ntyp, atm, ityp, nat, tau, alat, a1, a2, a3, &
                                  etot, eband, ehart, vtxc, etxc, ewald, degauss, demet, forces,  &
                                  stress, scf_has_converged, n_scf_steps, scf_error, efieldcorr, potstat_contr,      &
                                  fcp_force, fcp_tot_charge, gatefield_en)
    !-----------------------------------------------------------------------------------------
    !! This routing initializes le steps array containing up to max_steps elements of the step_type
    !! data structure. Each element contains structural and energetic info for m.d. trajectories and 
    !! structural minimization paths. All quantities must be provided directly in Hartree atomic units. 
    !! @Note updated on April 10th 2018 by Pietro Delugas
    USE qexsd_init, ONLY : qexsd_init_atomic_structure, qexsd_init_total_energy
    IMPLICIT NONE 
    ! 
    INTEGER ,INTENT(IN)             :: i_step, max_steps, ntyp, nat, n_scf_steps, ityp(:)
    REAL(DP),INTENT(IN)             :: tau(3,nat), alat, a1(3), a2(3), a3(3), etot, eband, ehart, vtxc, &
                                       etxc, ewald, scf_error, forces(3,nat), stress(3,3) 
    LOGICAL,INTENT(IN)              :: scf_has_converged 
    REAL(DP),OPTIONAL,INTENT(IN)    :: degauss, demet, gatefield_en, efieldcorr
    REAL(DP),OPTIONAL,INTENT (IN)   :: potstat_contr, fcp_force, fcp_tot_charge       
    CHARACTER(LEN=*),INTENT(IN)     :: atm(:)
    TYPE (step_type)                :: step_obj
    TYPE ( scf_conv_type )          :: scf_conv_obj
    TYPE ( atomic_structure_type )  :: atomic_struct_obj
    TYPE ( total_energy_type )      :: tot_en_obj
    TYPE ( matrix_type )            :: mat_forces, mat_stress  
    !    
    IF ( i_step .EQ. 1 ) THEN 
       ALLOCATE (steps(max_steps))
       step_counter = 0
    END IF 
    step_counter = step_counter+1
    !
    step_obj%tagname="step"
    step_obj%n_step = i_step 
    !
    CALL qes_init( scf_conv_obj,"scf_conv", scf_has_converged, n_scf_steps, scf_error )
    !
    step_obj%scf_conv = scf_conv_obj 
    CALL qes_reset(scf_conv_obj)
    ! 
    CALL qexsd_init_atomic_structure(atomic_struct_obj, ntyp, atm, ityp, nat, tau, &
                                     alat, a1, a2, a3, 0)
    step_obj%atomic_structure=atomic_struct_obj
    CALL qes_reset( atomic_struct_obj )
    ! 
    CALL qexsd_init_total_energy (tot_en_obj, etot, eband, ehart, &
          vtxc, etxc, ewald, degauss, demet, efieldcorr, potstat_contr, gatefield_en)  
    step_obj%total_energy=tot_en_obj
    CALL qes_reset( tot_en_obj )
    ! 
    CALL  qes_init( mat_forces, "forces", [3, nat], forces ) 
    step_obj%forces=mat_forces
    CALL qes_reset ( mat_forces )
    ! 
    CALL qes_init( mat_stress, "stress", [3, 3], stress ) 
    step_obj%stress = mat_stress
    CALL qes_reset ( mat_stress ) 
    IF ( PRESENT ( fcp_force ) ) THEN 
       step_obj%FCP_force = fcp_force
       step_obj%FCP_force_ispresent = .TRUE.
    END IF 
    IF (PRESENT( fcp_tot_charge)) THEN 
       step_obj%FCP_tot_charge = fcp_tot_charge
       step_obj%FCP_tot_charge_ispresent = .TRUE. 
    END IF 
    !  
    ! 
    steps(step_counter) = step_obj
    steps(step_counter)%lwrite  = .TRUE.
    steps(step_counter)%lread   = .TRUE. 
    call qes_reset (step_obj)
    END SUBROUTINE qexsd_step_addstep 
    !
    !------------------------------------------------------------------------------------
    SUBROUTINE qexsd_reset_steps()
       IMPLICIT NONE
       INTEGER  :: i_step
       IF (ALLOCATED(steps)) THEN
          DO i_step =1, SIZE(steps) 
            CALL qes_reset(steps(i_step))
          END DO
          DEALLOCATE (steps)
      END IF
   END SUBROUTINE
    !
    !--------------------------------------------------------------------------------------------------
    SUBROUTINE qexsd_set_closed() 
    ! 
    IMPLICIT NONE 
    CHARACTER(LEN=9)                  :: cdate, time_string
    CHARACTER(LEN=12)                 :: date_string
    !
    CALL date_and_tim( cdate, time_string ) 
    date_string = cdate(1:2) // ' ' // cdate(3:5) // ' ' // cdate (6:9)
    CALL qes_init (qexsd_closed_element, "closed", date_string, time_string,&
                          "")
    END SUBROUTINE qexsd_set_closed 
    
!
!-------------------------------------------
! ... subroutine related to timing information
!-------------------------------------------
!
    ! 

SUBROUTINE qexsd_init_clocks (timing_, total_clock, partial_clocks)
      USE mytime,  ONLY: nclock, clock_label, cputime, walltime, called
      USE qes_libs_module, ONLY: qes_init, qes_reset 
      IMPLICIT NONE
      TYPE(timing_type),INTENT(INOUT)          :: timing_ 
      CHARACTER(LEN=12),INTENT(IN)             :: total_clock 
      CHARACTER(LEN=12),OPTIONAL,INTENT(IN)    :: partial_clocks(:) 
      ! 
      TYPE (clock_type)                 :: total_
      TYPE(clock_type),ALLOCATABLE      :: partial_(:)  
      LOGICAL,ALLOCATABLE               :: match(:)
      INTEGER                           :: partial_ndim = 0, ic, ipar, nc 
      REAL (DP)                         :: t(2)
      INTERFACE
         FUNCTION get_cpu_and_wall(n_) result(t_)
            IMPORT :: DP
            IMPLICIT NONE
            INTEGER    :: n_ 
            REAL(DP)   t_(2)
         END FUNCTION get_cpu_and_wall 
      END INTERFACE
      ! 
      IF (PRESENT(partial_clocks)) partial_ndim = SIZE (partial_clocks)
      DO ic = 1, nclock
         IF ( TRIM(total_clock) == clock_label(ic) ) EXIT 
      END DO 
      t = get_cpu_and_wall(ic) 
      CALL qes_init ( total_, "total", TRIM(clock_label(ic)), t(1), t(2) ) 
      IF ( partial_ndim .GT.  0 ) THEN  
         ALLOCATE(partial_(partial_ndim), match(nclock) ) 
         DO ipar = 1, partial_ndim 
            match = clock_label(1:nclock) == TRIM(partial_clocks(ipar)) 
            IF ( ANY (match))  THEN
               nc = get_index(.TRUE., match)
               t = get_cpu_and_wall(nc) 
               CALL qes_init(partial_(ipar), "partial", TRIM(clock_label(nc)), t(1), t(2),&
                             called(nc))
            ELSE 
               CALL qes_init (partial_(ipar), "partial", "not_found",  -1.d0, -1.d0, 0)  
               CALL infomsg("add_xml_clocks_pw: label not found ", TRIM(partial_clocks(ipar))) 
               partial_(ipar)%lwrite=.FALSE. 
            END IF 
            END DO
      END IF 
      CALL qes_init( timing_, "timing_info", total_, partial_)
      CALL qes_reset ( total_) 
      DO ipar =1, partial_ndim 
         CALL qes_reset(partial_(ipar)) 
      END DO
      CONTAINS 
         FUNCTION get_index(val, array)  result(n) 
            IMPLICIT NONE
            LOGICAL                     :: val 
            LOGICAL                     :: array(:)
            INTEGER                     :: n 
            ! 
            INTEGER                     :: i 
            !
            n = - 1
            DO i =1, SIZE(array) 
               IF (array(i) .EQV. val) EXIT 
            END DO
            IF ( array(i) .EQV. val )  n = i 
         END FUNCTION get_index 
   END SUBROUTINE qexsd_init_clocks  


END MODULE qexsd_module