LCOV - code coverage report
Current view: top level - mix - type_mixvector.F90 (source / functions) Hit Total Coverage
Test: FLEUR test coverage Lines: 325 440 73.9 %
Date: 2024-03-28 04:22:06 Functions: 16 20 80.0 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------
       2             : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
       3             : ! This file is part of FLEUR and available as free software under the conditions
       4             : ! of the MIT license as expressed in the LICENSE file in more detail.
       5             : !--------------------------------------------------------------------------------
       6             : MODULE m_types_mixvector
       7             :    !TODO!!!
       8             :    ! LDA+U
       9             :    ! Noco (third spin)
      10             : #ifdef CPP_MPI
      11             :    use mpi
      12             : #endif
      13             :    USE m_types
      14             :    IMPLICIT NONE
      15             : 
      16             :    PRIVATE
      17             :    !Here we store the pointers used for metric
      18             :    TYPE(t_stars), POINTER  :: stars
      19             :    TYPE(t_cell), POINTER   :: cell
      20             :    TYPE(t_sphhar), POINTER :: sphhar
      21             :    TYPE(t_atoms), POINTER  :: atoms => NULL()
      22             :    TYPE(t_sym), POINTER    :: sym => NULL()
      23             :    INTEGER                :: jspins, nvac
      24             :    LOGICAL                :: l_noco, invs, invs2, l_mtnocopot, l_spinoffd_ldau
      25             :    INTEGER                :: pw_length !The shape of the local arrays
      26             :    INTEGER                :: pw_start(3) = 0, pw_stop(3) !First and last index for spin
      27             :    INTEGER                :: mt_length, mt_length_g
      28             :    INTEGER                :: mt_start(3) = 0, mt_stop(3) !First and last index for spin
      29             :    INTEGER                :: vac_length, vac_length_g
      30             :    INTEGER                :: vac_start(3) = 0, vac_stop(3) !First and last index for spin
      31             :    INTEGER                :: misc_length = 0, misc_length_g
      32             :    INTEGER                :: misc_start(3) = 0, misc_stop(3) !First and last index for spin
      33             :    INTEGER                :: mix_mpi_comm !Communicator for all PEs doing mixing
      34             :    LOGICAL                :: spin_here(3) = .TRUE.
      35             :    LOGICAL                :: pw_here = .TRUE.
      36             :    LOGICAL                :: mt_here = .TRUE.
      37             :    LOGICAL                :: vac_here = .TRUE.
      38             :    LOGICAL                :: misc_here = .TRUE.
      39             :    INTEGER                :: mt_rank = 0
      40             :    INTEGER                :: mt_size = 1
      41             :    LOGICAL                :: l_pot = .FALSE. !Is this a potential?
      42             :    REAL, ALLOCATABLE       :: g_mt(:), g_vac(:), g_misc(:)
      43             : 
      44             :    TYPE, PUBLIC:: t_mixvector
      45             :       REAL, ALLOCATABLE       :: vec_pw(:)
      46             :       REAL, ALLOCATABLE       :: vec_mt(:)
      47             :       REAL, ALLOCATABLE       :: vec_vac(:)
      48             :       REAL, ALLOCATABLE       :: vec_misc(:)
      49             :    CONTAINS
      50             :       PROCEDURE :: alloc => mixvector_alloc
      51             :       PROCEDURE :: from_density => mixvector_from_density
      52             :       PROCEDURE :: to_density => mixvector_to_density
      53             :       PROCEDURE :: apply_metric => mixvector_metric
      54             :       PROCEDURE :: multiply_dot_mask
      55             :       PROCEDURE :: dfpt_multiply_dot_mask
      56             :       PROCEDURE :: read_unformatted
      57             :       PROCEDURE :: write_unformatted
      58             :       PROCEDURE :: allocated => mixvector_allocated
      59             :    END TYPE t_mixvector
      60             : 
      61             :    INTERFACE OPERATOR(*)
      62             :       MODULE PROCEDURE multiply_scalar
      63             :       MODULE PROCEDURE multiply_scalar_spin
      64             :    END INTERFACE OPERATOR(*)
      65             :    INTERFACE OPERATOR(+)
      66             :       MODULE PROCEDURE add_vectors
      67             :    END INTERFACE OPERATOR(+)
      68             :    INTERFACE OPERATOR(-)
      69             :       MODULE PROCEDURE subtract_vectors
      70             :    END INTERFACE OPERATOR(-)
      71             :    INTERFACE OPERATOR(.dot.)
      72             :       MODULE PROCEDURE multiply_dot
      73             :    END INTERFACE OPERATOR(.dot.)
      74             : 
      75             :    PUBLIC :: OPERATOR(+), OPERATOR(-), OPERATOR(*), OPERATOR(.dot.)
      76             :    PUBLIC :: mixvector_init, mixvector_reset
      77             : 
      78             : CONTAINS
      79             : 
      80          76 :    SUBROUTINE READ_unformatted(this, unit)
      81             :       IMPLICIT NONE
      82             :       CLASS(t_mixvector), INTENT(INOUT)::this
      83             :       INTEGER, INTENT(IN)::unit
      84          76 :       call timestart("read_mixing")
      85          76 :       CALL this%alloc()
      86          76 :       IF (pw_here) READ (unit) this%vec_pw
      87          76 :       IF (mt_here) READ (unit) this%vec_mt
      88          76 :       IF (vac_here) READ (unit) this%vec_vac
      89          76 :       IF (misc_here) READ (unit) this%vec_misc
      90          76 :       call timestop("read_mixing")
      91          76 :    END SUBROUTINE READ_unformatted
      92             : 
      93         832 :    SUBROUTINE write_unformatted(this, unit)
      94             :       IMPLICIT NONE
      95             :       CLASS(t_mixvector), INTENT(IN)::this
      96             :       INTEGER, INTENT(IN)::unit
      97         832 :       call timestart("write_mixing")
      98         832 :       IF (pw_here) WRITE (unit) this%vec_pw
      99         832 :       IF (mt_here) WRITE (unit) this%vec_mt
     100         832 :       IF (vac_here) WRITE (unit) this%vec_vac
     101         832 :       IF (misc_here) WRITE (unit) this%vec_misc
     102         832 :       call timestop("write_mixing")
     103         832 :    END SUBROUTINE write_unformatted
     104             : 
     105         146 :    SUBROUTINE mixvector_reset(fullreset)
     106             :       IMPLICIT NONE
     107             :       LOGICAL, OPTIONAL, INTENT(IN) :: fullreset
     108         146 :       atoms => NULL()
     109         146 :       sym => NULL()
     110         146 :       IF (PRESENT(fullreset)) stars => NULL()
     111         146 :       IF (ALLOCATED(g_mt)) DEALLOCATE (g_mt)
     112         146 :       IF (ALLOCATED(g_vac)) DEALLOCATE (g_vac)
     113         146 :       IF (ALLOCATED(g_misc)) DEALLOCATE (g_misc)
     114             :       !restore defaults
     115         146 :       pw_start = 0
     116         146 :       mt_start = 0
     117         146 :       vac_start = 0
     118         146 :       misc_length = 0
     119         146 :       misc_start = 0
     120         584 :       spin_here = .TRUE.
     121         146 :       pw_here = .TRUE.
     122         146 :       mt_here = .TRUE.
     123         146 :       vac_here = .TRUE.
     124         146 :       misc_here = .TRUE.
     125         146 :       mt_rank = 0
     126         146 :       mt_size = 1
     127         146 :       l_pot = .FALSE. !Is this a potential?
     128         146 :    END SUBROUTINE mixvector_reset
     129             : 
     130        2114 :    SUBROUTINE mixvector_from_density(vec, den, nmzxyd, swapspin, denIm)
     131             :       USE m_types
     132             :       IMPLICIT NONE
     133             :       CLASS(t_mixvector), INTENT(INOUT)    :: vec
     134             :       TYPE(t_potden), INTENT(inout)    :: Den
     135             :       INTEGER, INTENT(IN) :: nmzxyd
     136             :       LOGICAL, INTENT(IN), OPTIONAL         :: swapspin
     137             :       TYPE(t_potden), INTENT(INOUT), OPTIONAL :: denIm
     138             :       INTEGER:: js, ii, n, l, iv, jspin, mmpSize, nIJ_llp_mmpSize, offset
     139             : 
     140        2114 :       CALL den%DISTRIBUTE(mix_mpi_comm)
     141        2114 :       IF (PRESENT(denIm)) CALL denIm%DISTRIBUTE(mix_mpi_comm)
     142        6554 :       DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
     143        4440 :          jspin = js
     144        4440 :          IF (PRESENT(swapspin)) THEN
     145        1940 :             IF (swapspin .AND. js < 3) jspin = MERGE(1, 2, js == 2)
     146             :          ENDIF
     147        6554 :          IF (spin_here(js)) THEN
     148             :             !PW part
     149        2494 :             IF (pw_here) THEN
     150     5359554 :                vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1) = REAL(den%pw(:, jspin))
     151        2220 :                IF ((.NOT. sym%invs) .OR. (js == 3).OR.PRESENT(denIm)) THEN
     152     4573880 :                   vec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1) = AIMAG(den%pw(:, jspin))
     153             :                ENDIF
     154        2220 :                IF ((js == 3).AND.PRESENT(denIm)) THEN
     155           0 :                   vec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1) =  REAL(den%pw(:, 4))
     156           0 :                   vec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1) = AIMAG(den%pw(:, 4))
     157             :                END IF
     158             :             ENDIF
     159        2494 :             IF (vac_here) THEN
     160             :                !This PE stores vac-data
     161         168 :                ii = vac_start(js) - 1
     162         416 :                DO iv = 1, nvac
     163       62248 :                   vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1)) = REAL(den%vac(:, 1, iv, jspin))
     164         248 :                   ii = ii + SIZE(den%vac, 1)
     165         248 :                   IF (PRESENT(denIm)) THEN
     166           0 :                      vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1)) = AIMAG(den%vac(:, 1, iv, jspin))
     167             :                      ii = ii + SIZE(den%vac, 1)
     168             :                   END IF
     169             :                   vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)) = RESHAPE(REAL(den%vac(:nmzxyd, 2:, iv, jspin)), &
     170    12305314 :                                                                                                (/nmzxyd*(SIZE(den%vac,2)-1)/))
     171         248 :                   ii = ii + nmzxyd*(SIZE(den%vac,2)-1)
     172         248 :                   IF ((.NOT. sym%invs2) .OR. (js == 3)) THEN
     173             :                      vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)) = RESHAPE(AIMAG(den%vac(:nmzxyd, 2:, iv, jspin)), &
     174    12044380 :                                                                                                   (/nmzxyd*(SIZE(den%vac,2)-1)/))
     175         230 :                      ii = ii + nmzxyd*(SIZE(den%vac,2)-1)
     176             :                   ENDIF
     177         416 :                   IF (js > 2) THEN
     178           0 :                      vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1)) = AIMAG(den%vac(:, 1, iv, 3))
     179             :                      ii = ii + SIZE(den%vac, 1)
     180             :                   ENDIF
     181             :                ENDDO
     182             :             ENDIF
     183        2494 :             IF (mt_here .AND. (js < 3 .OR. l_mtnocopot)) THEN
     184             :                !This PE stores some(or all) MT data
     185        1884 :                ii = mt_start(js) - 1
     186        1884 :                IF (.NOT.PRESENT(denIm)) THEN
     187        5082 :                   DO n = mt_rank + 1, atoms%ntype, mt_size
     188       98860 :                      DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     189    67262884 :                         vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, jspin)
     190       96976 :                         ii = ii + atoms%jri(n)
     191             :                      ENDDO
     192             :                   ENDDO
     193        1884 :                   IF (js == 3) THEN !Imaginary part
     194         112 :                      DO n = mt_rank + 1, atoms%ntype, mt_size
     195        5560 :                         DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     196     4126944 :                            vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, 4)
     197        5516 :                            ii = ii + atoms%jri(n)
     198             :                         ENDDO
     199             :                      ENDDO
     200             :                   ENDIF
     201             :                ELSE ! DFPT mixing
     202           0 :                   DO n = mt_rank + 1, atoms%ntype, mt_size
     203           0 :                      DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     204           0 :                         vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, jspin)
     205           0 :                         ii = ii + atoms%jri(n)
     206             :                      END DO
     207             :                   END DO
     208           0 :                   DO n = mt_rank + 1, atoms%ntype, mt_size
     209           0 :                      DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     210           0 :                         vec%vec_mt(ii + 1:ii + atoms%jri(n)) = denIm%mt(:atoms%jri(n), l, n, jspin)
     211           0 :                         ii = ii + atoms%jri(n)
     212             :                      END DO
     213             :                   END DO
     214           0 :                   IF (js == 3) THEN !Imaginary part
     215           0 :                      DO n = mt_rank + 1, atoms%ntype, mt_size
     216           0 :                         DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     217           0 :                            vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, 4)
     218           0 :                            ii = ii + atoms%jri(n)
     219             :                         END DO
     220             :                      END DO
     221           0 :                      DO n = mt_rank + 1, atoms%ntype, mt_size
     222           0 :                         DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     223           0 :                            vec%vec_mt(ii + 1:ii + atoms%jri(n)) = denIm%mt(:atoms%jri(n), l, n, 4)
     224           0 :                            ii = ii + atoms%jri(n)
     225             :                         END DO
     226             :                      END DO
     227             :                   END IF
     228             :                END IF
     229             :             ENDIF
     230        2494 :             IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
     231         640 :                mmpSize = SIZE(den%mmpMat(:, :, 1:atoms%n_u, jspin))
     232       34240 :                vec%vec_misc(misc_start(js):misc_start(js) + mmpSize - 1) = RESHAPE(REAL(den%mmpMat(:, :, 1:atoms%n_u, jspin)), (/mmpSize/))
     233       34240 :                vec%vec_misc(misc_start(js) + mmpSize:misc_start(js) + 2*mmpSize - 1) = RESHAPE(AIMAG(den%mmpMat(:, :, 1:atoms%n_u, jspin)), (/mmpSize/))
     234         160 :                IF (atoms%n_v.GT.0) THEN
     235           0 :                   nIJ_llp_mmpSize = SIZE(den%nIJ_llp_mmp(:,:,:,jspin))
     236           0 :                   offset = misc_start(js) + 2*mmpSize
     237           0 :                   vec%vec_misc(offset:offset + nIJ_llp_mmpSize - 1) = RESHAPE(REAL(den%nIJ_llp_mmp(:,:,:,jspin)), (/nIJ_llp_mmpSize/))
     238           0 :                   vec%vec_misc(offset+nIJ_llp_mmpSize:offset + 2*nIJ_llp_mmpSize - 1) = RESHAPE(AIMAG(den%nIJ_llp_mmp(:,:,:,jspin)), (/nIJ_llp_mmpSize/))
     239             :                END IF
     240             :             END IF
     241             :          END IF
     242             :       END DO
     243             : 
     244        2114 :    END SUBROUTINE mixvector_from_density
     245             : 
     246         664 :    SUBROUTINE mixvector_to_density(vec, den, nmzxyd, denIm)
     247             :       USE m_types
     248             :       IMPLICIT NONE
     249             :       CLASS(t_mixvector), INTENT(IN)    :: vec
     250             :       TYPE(t_potden), INTENT(INOUT) :: den
     251             :       TYPE(t_potden), INTENT(INOUT), OPTIONAL :: denIm
     252             :       INTEGER,INTENT(IN) :: nmzxyd
     253             :       INTEGER:: js, i, ii, n, l, iv, mmpSize, nIJ_llp_mmpSize, offset
     254             : 
     255             :       LOGICAL :: l_dfpt
     256         664 :       REAL :: vacOffdiagTemp(SIZE(den%vac, 1))
     257             : 
     258         664 :       l_dfpt = PRESENT(denIm)
     259             : 
     260        1908 :       DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
     261        1908 :          IF (spin_here(js)) THEN
     262             :             !PW part
     263         759 :             IF (pw_here) THEN
     264         622 :                IF (sym%invs .AND. js < 3 .AND. .NOT. l_dfpt) THEN
     265      207403 :                   den%pw(:, js) = vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1)
     266             :                ELSE
     267     1288176 :                   den%pw(:, js) = CMPLX(vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1), vec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1))
     268         332 :                   IF (l_dfpt.AND.js==3) THEN
     269           0 :                      den%pw(:, 4) = CMPLX(vec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1), vec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1))
     270             :                   END IF
     271             :                ENDIF
     272             :             ENDIF
     273         759 :             IF (mt_here .AND. (js < 3 .OR. l_mtnocopot)) THEN
     274             :                !This PE stores some(or all) MT data
     275         538 :                ii = mt_start(js)
     276        1459 :                DO n = mt_rank + 1, atoms%ntype, mt_size
     277       27309 :                   DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     278    18499808 :                      den%mt(:atoms%jri(n), l, n, js) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
     279       26771 :                      ii = ii + atoms%jri(n)
     280             :                   ENDDO
     281             :                ENDDO
     282         538 :                IF (l_dfpt) THEN
     283           0 :                   DO n = mt_rank + 1, atoms%ntype, mt_size
     284           0 :                      DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     285           0 :                         denIm%mt(:atoms%jri(n), l, n, js) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
     286           0 :                         ii = ii + atoms%jri(n)
     287             :                      ENDDO
     288             :                   ENDDO
     289             :                END IF
     290         538 :                IF (js == 3) THEN !Imaginary part comes as 4th spin
     291          28 :                   DO n = mt_rank + 1, atoms%ntype, mt_size
     292        1390 :                      DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     293     1031736 :                         den%mt(:atoms%jri(n), l, n, 4) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
     294        1379 :                         ii = ii + atoms%jri(n)
     295             :                      ENDDO
     296             :                   ENDDO
     297          11 :                   IF (l_dfpt) THEN
     298           0 :                      DO n = mt_rank + 1, atoms%ntype, mt_size
     299           0 :                         DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     300           0 :                            denIm%mt(:atoms%jri(n), l, n, 4) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
     301           0 :                            ii = ii + atoms%jri(n)
     302             :                         ENDDO
     303             :                      ENDDO
     304             :                   END IF
     305             :                ENDIF
     306             :             ENDIF
     307         759 :             IF (vac_here) THEN
     308             :                !This PE stores vac-data
     309          56 :                ii = vac_start(js) - 1
     310         132 :                DO iv = 1, nvac
     311       19076 :                   den%vac(:, 1, iv, js) = vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1))
     312          76 :                   ii = ii + SIZE(den%vac, 1)
     313          76 :                   IF (l_dfpt) THEN
     314           0 :                      den%vac(:, 1, iv, js) = den%vac(:, 1, iv, js) + ImagUnit*vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1))
     315             :                      ii = ii + SIZE(den%vac, 1)
     316             :                   END IF
     317          76 :                   IF (sym%invs2 .AND. js < 3) THEN
     318       36880 :                      den%vac(:nmzxyd, 2:, iv, js) = RESHAPE(vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)), SHAPE(den%vac(:nmzxyd, 2:, iv, js)))
     319           5 :                      ii = ii + nmzxyd*(SIZE(den%vac,2)-1)
     320             :                   ELSE
     321             :                      den%vac(:nmzxyd, 2:, iv, js) = RESHAPE(CMPLX(vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)), &
     322             :                                                              vec%vec_vac(ii + nmzxyd*(SIZE(den%vac,2)-1) + 1:ii + 2*nmzxyd*(SIZE(den%vac,2)-1))), &
     323     4435148 :                                                        SHAPE(den%vac(:nmzxyd, 2:, iv, js)))
     324          71 :                      ii = ii + 2*nmzxyd*(SIZE(den%vac,2)-1)
     325             :                   ENDIF
     326         132 :                   IF (js > 2) THEN
     327           0 :                      vacOffdiagTemp(:) = vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1))
     328           0 :                      DO i = 1, SIZE(den%vac, 1)
     329           0 :                         den%vac(i, 1, iv, 3) = CMPLX(REAL(den%vac(i, 1, iv, 3)),vacOffdiagTemp(i))
     330             :                      END DO
     331             :                      ii = ii + SIZE(den%vac, 1)
     332             :                   ENDIF
     333             :                ENDDO
     334             :             ENDIF
     335         759 :             IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
     336         184 :                mmpSize = SIZE(den%mmpMat(:, :, 1:atoms%n_u, js))
     337             :                den%mmpMat(:, :, 1:atoms%n_u, js) = RESHAPE(CMPLX(vec%vec_misc(misc_start(js):misc_start(js) + mmpSize - 1), &
     338             :                                                                  vec%vec_misc(misc_start(js) + mmpSize:misc_start(js) + 2*mmpSize - 1)), &
     339       11254 :                                                            SHAPE(den%mmpMat(:, :, 1:atoms%n_u, js)))
     340          46 :                IF (atoms%n_v.GT.0) THEN
     341           0 :                   nIJ_llp_mmpSize = SIZE(den%nIJ_llp_mmp(:,:,:,js))
     342           0 :                   offset = misc_start(js) + 2*mmpSize
     343             :                   den%nIJ_llp_mmp(:,:,:,js) = RESHAPE(CMPLX(vec%vec_misc(offset:offset + nIJ_llp_mmpSize - 1), &
     344             :                                                             vec%vec_misc(offset + nIJ_llp_mmpSize:offset + 2*nIJ_llp_mmpSize - 1)), &
     345           0 :                                                       SHAPE(den%nIJ_llp_mmp(:,:,:,js)))
     346             :                END IF
     347             :             END IF
     348             :          END IF
     349             :       ENDDO
     350             : 
     351         664 :       IF (.NOT.l_dfpt) THEN
     352         664 :          CALL den%collect(mix_mpi_comm)
     353             :       ELSE
     354           0 :          CALL den%collect(mix_mpi_comm,denIm)
     355             :       END IF
     356             : 
     357         664 :    END SUBROUTINE mixvector_to_density
     358             : 
     359        4478 :    FUNCTION mixvector_metric(vec,l_dfpt) RESULT(mvec)
     360             :       USE m_types
     361             :       USE m_convol
     362             :       IMPLICIT NONE
     363             :       CLASS(t_mixvector), INTENT(IN) :: vec
     364             :       LOGICAL,            INTENT(IN) :: l_dfpt
     365             : 
     366             :       TYPE(t_mixvector)              :: mvec
     367             : 
     368             :       INTEGER:: js, ii, n, l, iv
     369        4478 :       COMPLEX, ALLOCATABLE::pw(:), pw_w(:)
     370        4478 :       call timestart("metric")
     371        4478 :       mvec = vec
     372       14543 :       IF (pw_here) ALLOCATE (pw(stars%ng3), pw_w(stars%ng3))
     373             : 
     374       12456 :       DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
     375       12456 :          IF (spin_here(js)) THEN
     376             :             !PW part
     377        5112 :             IF (pw_here) THEN
     378             :                !Put back on g-grid and use convol
     379        3989 :                IF (sym%invs .AND. js < 3 .AND. .NOT. l_dfpt) THEN
     380      612658 :                   pw(:) = vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1)
     381             :                ELSE
     382     5353107 :                   pw(:) = CMPLX(vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1), vec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1))
     383             :                ENDIF
     384        3989 :                CALL convol(stars, pw_w, pw)
     385     5965765 :                pw_w = pw_w*cell%omtil
     386     5965765 :                mvec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1) = REAL(pw_w)
     387        3989 :                IF ((.NOT. sym%invs) .OR. (js == 3) .OR. l_dfpt) THEN
     388     5353107 :                   mvec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1) = AIMAG(pw_w)
     389             :                ENDIF
     390        3989 :                IF ((js == 3) .AND. l_dfpt) THEN
     391           0 :                   pw(:) = CMPLX(vec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1), vec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1))
     392           0 :                   CALL convol(stars, pw_w, pw)
     393           0 :                   pw_w = pw_w*cell%omtil
     394           0 :                   mvec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1) =  REAL(pw_w)
     395           0 :                   mvec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1) = AIMAG(pw_w)
     396             :                END IF
     397             :             ENDIF
     398        5112 :             IF (mt_here .AND. (js < 3 .OR. l_mtnocopot)) THEN
     399             :                !This PE stores some(or all) MT data
     400        3371 :                IF (.NOT.l_dfpt) THEN
     401    86510441 :                   mvec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1)
     402        3371 :                   IF (js == 3) THEN
     403             :                      !Here we have a the imaginary part as well
     404     1520926 :                      mvec%vec_mt(mt_start(js) + SIZE(g_mt):mt_stop(js)) = g_mt*vec%vec_mt(mt_start(js) + SIZE(g_mt):mt_stop(js))
     405             :                   ENDIF
     406             :                ELSE
     407           0 :                   mvec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1)
     408           0 :                   mvec%vec_mt(mt_start(js) + SIZE(g_mt):mt_start(js) + 2*SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js) + SIZE(g_mt):mt_start(js) + 2*SIZE(g_mt) - 1)
     409           0 :                   IF (js == 3) THEN
     410           0 :                      mvec%vec_mt(mt_start(js) + 2*SIZE(g_mt):mt_start(js) + 3*SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js) + 2*SIZE(g_mt):mt_start(js) + 3*SIZE(g_mt) - 1)
     411           0 :                      mvec%vec_mt(mt_start(js) + 3*SIZE(g_mt):mt_start(js) + 4*SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js) + 3*SIZE(g_mt):mt_start(js) + 4*SIZE(g_mt) - 1)
     412             :                   ENDIF
     413             :                END IF
     414             :             ENDIF
     415        5112 :             IF (vac_here) THEN
     416    40803696 :                mvec%vec_vac(vac_start(js):vac_start(js) + SIZE(g_vac) - 1) = g_vac*vec%vec_vac(vac_start(js):vac_start(js) + SIZE(g_vac) - 1)
     417         396 :                IF (js == 3) THEN !We have some extra data that corresponds to first part of metric
     418           0 :                   mvec%vec_vac(vac_start(js) + SIZE(g_vac):vac_stop(js)) = g_vac(:vac_stop(js) - vac_start(js) - SIZE(g_vac) + 1)*vec%vec_vac(vac_start(js) + SIZE(g_vac):vac_stop(js))
     419             :                ENDIF
     420             :             ENDIF
     421        5112 :             IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
     422       46623 :                mvec%vec_misc(misc_start(js):misc_stop(js)) = g_misc*vec%vec_misc(misc_start(js):misc_stop(js))
     423             :             END IF
     424             :          ENDIF
     425             :       END DO
     426        4478 :       call timestop("metric")
     427        8956 :    END FUNCTION mixvector_metric
     428             : 
     429         144 :    SUBROUTINE init_metric(vacuum, stars, l_dfpt)
     430             :       USE m_metrz0
     431             :       IMPLICIT NONE
     432             :       !
     433             :       TYPE(t_vacuum), INTENT(in) :: vacuum
     434             :       TYPE(t_stars),  INTENT(in) :: stars
     435             :       LOGICAL,        INTENT(in) :: l_dfpt
     436             : 
     437             :       INTEGER:: i, n, l, j, ivac, iz, iv2c, k2, iv2
     438             :       REAL:: dxn, dxn2, dxn4, dvol, volnstr2
     439         144 :       REAL, ALLOCATABLE:: wght(:)
     440             : 
     441         144 :       IF (mt_here) THEN
     442             :          !This PE stores some(or all) MT data
     443         369 :          ALLOCATE (g_mt(mt_length_g))
     444         123 :          i = 0
     445         328 :          DO n = mt_rank + 1, atoms%ntype, mt_size
     446         205 :             dxn = atoms%neq(n)*atoms%dx(n)/3.0
     447         205 :             dxn2 = 2.0*dxn
     448         205 :             dxn4 = 4.0*dxn
     449        7906 :             DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
     450        7578 :                i = i + 1
     451        7578 :                g_mt(i) = dxn/atoms%rmsh(1, n)
     452        7783 :                IF (.NOT. l_pot) THEN
     453        7578 :                   DO j = 2, atoms%jri(n) - 1, 2
     454     2756920 :                      i = i + 2
     455     2756920 :                      g_mt(i - 1) = dxn4/atoms%rmsh(j, n)
     456     2756920 :                      g_mt(i) = dxn2/atoms%rmsh(j + 1, n)
     457             :                   END DO
     458             :                   ! CHANGE JR 96/12/01
     459             :                   ! take care when jri(n) is even
     460        7578 :                   i = i + 1 - MOD(atoms%jri(n), 2)
     461        7578 :                   g_mt(i) = dxn/atoms%rmsh(atoms%jri(n), n)
     462             :                ELSE
     463             :                   ! for the potential multiply by r^4
     464           0 :                   DO j = 2, atoms%jri(n) - 1, 2
     465           0 :                      i = i + 2
     466           0 :                      g_mt(i - 1) = dxn4*atoms%rmsh(j, n)**3
     467           0 :                      g_mt(i) = dxn2*atoms%rmsh(j + 1, n)**3
     468             :                   END DO
     469           0 :                   i = i + 1 - MOD(atoms%jri(n), 2)
     470           0 :                   g_mt(i) = dxn*atoms%rmsh(atoms%jri(n), n)**3
     471             :                END IF
     472             :             END DO
     473             :          END DO
     474             :       ENDIF
     475         144 :       i = 0
     476         144 :       IF (vac_here) THEN
     477          16 :          iv2 = 2
     478          16 :          IF (sym%invs2) iv2 = 1
     479             : 
     480          80 :          ALLOCATE (g_vac(vac_length_g), wght(vacuum%nmzd))
     481      710316 :          g_vac(:) = 0.0
     482          16 :          dvol = cell%area*vacuum%delz
     483             :          ! nvac=1 if (zrfs.or.invs)
     484          16 :          IF (vacuum%nvac .EQ. 1) dvol = dvol + dvol
     485          36 :          DO ivac = 1, vacuum%nvac
     486             :             ! G||=0 components
     487             :             !
     488             :             ! use 7-point simpson integration in accordance to intgz0.f
     489             :             ! calculate weights for integration
     490          20 :             CALL metr_z0(vacuum%nmz, wght)
     491        5020 :             DO iz = 1, vacuum%nmz
     492        5000 :                i = i + 1
     493             :                !
     494        5020 :                g_vac(i) = wght(iz)*dvol
     495             :                !
     496             :             END DO
     497          20 :             IF (l_dfpt) THEN
     498           0 :                DO iz = 1, vacuum%nmz
     499           0 :                   i = i + 1
     500             :                   !
     501           0 :                   g_vac(i) = wght(iz)*dvol
     502             :                   !
     503             :                END DO
     504             :             END IF
     505             :             ! G||.ne.0 components
     506             :             !
     507             :             ! calculate weights for integration
     508          20 :             CALL metr_z0(vacuum%nmzxy, wght)
     509          71 :             DO iv2c = 1, iv2
     510        7108 :                DO k2 = 1, stars%ng2 - 1
     511             :                   !
     512        7053 :                   volnstr2 = dvol*stars%nstr2(k2)
     513      712388 :                   DO iz = 1, vacuum%nmzxy
     514      705300 :                      i = i + 1
     515      712353 :                      g_vac(i) = wght(iz)*volnstr2
     516             :                   END DO
     517             :                   !
     518             :                END DO
     519             :             END DO
     520             :          END DO
     521             :       END IF
     522         144 :       IF (misc_here) THEN
     523          33 :          ALLOCATE (g_misc(misc_length_g))
     524        1775 :          g_misc = 1.0
     525             :       END IF
     526             : 
     527         144 :    END SUBROUTINE init_metric
     528             : 
     529         144 :    SUBROUTINE init_storage_mpi(comm_mpi)
     530             :       IMPLICIT NONE
     531             :       INTEGER, INTENT(in):: comm_mpi
     532             :       INTEGER      :: irank, isize, err, js, new_comm
     533         144 :       mix_mpi_comm = comm_mpi
     534             : #ifdef CPP_MPI
     535             : 
     536         144 :       CALL mpi_comm_rank(comm_mpi, irank, err)
     537         144 :       CALL mpi_comm_size(comm_mpi, isize, err)
     538             : 
     539         288 :       IF (isize == 1) RETURN !No parallelization
     540         144 :       js = MERGE(jspins, 3,.NOT. l_noco)!distribute spins
     541         144 :       js = MIN(js, isize)
     542         144 :       CALL judft_comm_split(comm_mpi, MOD(irank, js), irank, new_comm)
     543         648 :       spin_here = (/MOD(irank, js) == 0, MOD(irank, js) == 1, (isize == 2 .AND. irank == 0) .OR. MOD(irank, js) == 2/)
     544             : 
     545         144 :       CALL mpi_comm_rank(new_comm, irank, err)
     546         144 :       CALL mpi_comm_size(new_comm, isize, err)
     547         144 :       CALL mpi_comm_free(new_comm, err)
     548             : 
     549             :       !Now distribute data
     550         144 :       IF (isize == 1) RETURN !No further parallelism
     551             :       !Split off the pw-part
     552          42 :       pw_here = (irank == 0)
     553          42 :       mt_here = (irank > 0)
     554          42 :       vac_here = vac_here .AND. (irank > 0)
     555          42 :       misc_here = misc_here .AND. (irank > 0)
     556          42 :       isize = isize - 1
     557          42 :       irank = irank - 1
     558          42 :       mt_rank = irank
     559          42 :       mt_size = isize
     560          42 :       IF (isize == 1 .OR. irank < 0) RETURN !No further parallelism
     561           0 :       IF (vac_here .OR. misc_here) THEN !split off-vacuum&misc part
     562           0 :          vac_here = vac_here .AND. (irank == 0)
     563           0 :          misc_here = misc_here .AND. (irank == 0)
     564           0 :          mt_here = (irank > 0)
     565           0 :          isize = isize - 1
     566           0 :          irank = irank - 1
     567             :       ENDIF
     568           0 :       mt_rank = irank
     569           0 :       mt_size = isize
     570             : #endif
     571         288 :    END SUBROUTINE init_storage_mpi
     572             : 
     573         664 :    SUBROUTINE mixvector_init(comm_mpi, l_densitymatrix, l_densitymatrixV, input, vacuum, noco, stars_i, cell_i, sphhar_i, atoms_i, sym_i, l_dfpt)
     574             :       USE m_types
     575             :       IMPLICIT NONE
     576             :       INTEGER, INTENT(IN)               :: comm_mpi
     577             :       LOGICAL, INTENT(IN)               :: l_densitymatrix
     578             :       LOGICAL, INTENT(IN)               :: l_densitymatrixV
     579             : 
     580             :       TYPE(t_input), INTENT(IN)         :: input
     581             :       TYPE(t_vacuum), INTENT(IN), TARGET :: vacuum
     582             :       TYPE(t_noco), INTENT(IN)          :: noco
     583             :       TYPE(t_stars), INTENT(IN), TARGET  :: stars_i
     584             :       TYPE(t_cell), INTENT(IN), TARGET   :: cell_i
     585             :       TYPE(t_sphhar), INTENT(IN), TARGET :: sphhar_i
     586             :       TYPE(t_atoms), INTENT(IN), TARGET  :: atoms_i
     587             :       TYPE(t_sym), INTENT(IN), TARGET    :: sym_i
     588             : 
     589             :       LOGICAL, INTENT(IN) :: l_dfpt
     590             : 
     591             :       INTEGER :: js, n, len, i_v, natom2
     592             : 
     593             :       !Store pointers to data-types
     594         664 :       IF (ASSOCIATED(atoms)) RETURN !was done before...
     595         144 :       jspins = input%jspins
     596         144 :       nvac = vacuum%nvac
     597         144 :       l_noco = noco%l_noco
     598         372 :       l_mtnocopot = any(noco%l_unrestrictMT)
     599         622 :       l_spinoffd_ldau = any(noco%l_unrestrictMT).OR.any(noco%l_spinoffd_ldau)
     600         144 :       stars => stars_i; cell => cell_i; sphhar => sphhar_i; atoms => atoms_i; sym => sym_i
     601             : 
     602         144 :       vac_here = input%film
     603         144 :       misc_here = l_densitymatrix.OR.l_densitymatrixV
     604         144 :       CALL init_storage_mpi(comm_mpi)
     605             : 
     606         144 :       pw_length = 0; mt_length = 0; vac_length = 0; misc_length = 0
     607         144 :       mt_length_g = 0; vac_length_g = 0; misc_length_g = 0
     608         436 :       DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
     609         436 :          IF (spin_here(js)) THEN
     610             :             !Now calculate the length of the vectors
     611         167 :             IF (pw_here) THEN
     612         146 :                pw_start(js) = pw_length + 1
     613         146 :                IF (sym%invs .AND. js < 3 .AND. .NOT. l_dfpt) THEN
     614          73 :                   pw_length = pw_length + stars%ng3
     615             :                ELSE
     616          73 :                   pw_length = pw_length + 2*stars%ng3
     617             :                ENDIF
     618         146 :                IF (l_dfpt.AND.js==3) pw_length = pw_length + 2*stars%ng3
     619             :             ENDIF
     620         167 :             pw_stop(js) = pw_length
     621         167 :             IF (mt_here) THEN
     622         351 :                IF (js < 3 .OR. any(noco%l_unrestrictMT)) mt_start(js) = mt_length + 1
     623         146 :                len = 0
     624             :                !This PE stores some(or all) MT data
     625         384 :                DO n = mt_rank + 1, atoms%ntype, mt_size
     626         384 :                   IF (l_dfpt) THEN
     627           0 :                      len = len + 2*(sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
     628             :                   ELSE
     629         238 :                      len = len + (sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
     630             :                   END IF
     631             :                ENDDO
     632         146 :                mt_length_g = MAX(len, mt_length_g)
     633         146 :                IF (l_dfpt) mt_length_g = mt_length_g / 2
     634         146 :                IF (js == 3) THEN
     635             :                   !need to store imaginary part as well...
     636          56 :                   DO n = mt_rank + 1, atoms%ntype, mt_size
     637          56 :                      IF (l_dfpt) THEN
     638           0 :                         len = len + 2*(sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
     639             :                      ELSE
     640          33 :                         len = len + (sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
     641             :                      END IF
     642             :                   ENDDO
     643             :                ENDIF
     644         351 :                IF (js < 3 .OR. any(noco%l_unrestrictMT)) mt_length = mt_length + len
     645         146 :                mt_stop(js) = mt_length
     646             :             END IF
     647         167 :             IF (vac_here) THEN
     648             :                !This PE stores vac-data
     649          16 :                vac_start(js) = vac_length + 1
     650          16 :                len = 0
     651          16 :                IF (sym%invs2 .AND. js < 3) THEN
     652           5 :                   len = len + vacuum%nmzxyd*(stars%ng2 - 1)*vacuum%nvac + vacuum%nmzd*vacuum%nvac
     653             :                ELSE
     654          11 :                   len = len + 2*vacuum%nmzxyd*(stars%ng2 - 1)*vacuum%nvac + vacuum%nmzd*vacuum%nvac
     655             :                ENDIF
     656          16 :                IF (l_dfpt) len = len + vacuum%nmzd*vacuum%nvac !vacz is complex
     657          16 :                vac_length_g = MAX(vac_length_g, len)
     658          16 :                IF (js == 3) len = len + vacuum%nmzd*vacuum%nvac !Offdiagnal potential is complex
     659          16 :                vac_length = vac_length + len
     660          16 :                vac_stop(js) = vac_length
     661             :             ENDIF
     662         167 :             IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
     663          11 :                len = 7*7*2*atoms%n_u
     664          11 :                DO i_v = 1, atoms%n_v  !loop over pairs which are corrected by U+V 
     665          11 :                   DO natom2 = 1, atoms%lda_v(i_v)%numOtherAtoms
     666           0 :                      len = len + 7*7*2
     667             :                   END DO
     668             :                END DO
     669          11 :                misc_start(js) = misc_length + 1
     670          11 :                misc_length = misc_length + len
     671          11 :                misc_stop(js) = misc_length
     672          11 :                misc_length_g = MAX(len, misc_length_g)
     673             :             END IF
     674             :          END IF
     675             :       END DO
     676         144 :       CALL init_metric(vacuum, stars, l_dfpt)
     677             :    END SUBROUTINE mixvector_init
     678       12166 :    SUBROUTINE mixvector_alloc(vec)
     679             :       IMPLICIT NONE
     680             :       CLASS(t_mixvector), INTENT(OUT)    :: vec
     681       36498 :       ALLOCATE (vec%vec_pw(pw_length))
     682       36498 :       ALLOCATE (vec%vec_mt(mt_length))
     683       36498 :       ALLOCATE (vec%vec_vac(vac_length))
     684       36498 :       ALLOCATE (vec%vec_misc(misc_length))
     685       12166 :    END SUBROUTINE mixvector_alloc
     686             : 
     687       47540 :    FUNCTION multiply_scalar(scalar, vec) RESULT(vecout)
     688             :       TYPE(t_mixvector), INTENT(IN)::vec
     689             :       REAL, INTENT(IN)             ::scalar
     690             :       TYPE(t_mixvector)           ::vecout
     691             : 
     692       47540 :       vecout = vec
     693   104596589 :       vecout%vec_pw = vecout%vec_pw*scalar
     694   753403582 :       vecout%vec_mt = vecout%vec_mt*scalar
     695   598855840 :       vecout%vec_vac = vecout%vec_vac*scalar
     696      326252 :       vecout%vec_misc = vecout%vec_misc*scalar
     697       47540 :    END FUNCTION multiply_scalar
     698             : 
     699           0 :    FUNCTION multiply_scalar_spin(scalar, vec) RESULT(vecout)
     700             :       TYPE(t_mixvector), INTENT(IN)::vec
     701             :       REAL, INTENT(IN)             ::scalar(:)
     702             :       TYPE(t_mixvector)           ::vecout
     703             : 
     704             :       INTEGER:: js
     705             :       REAL:: fac
     706             : 
     707           0 :       vecout = vec
     708           0 :       DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
     709           0 :          IF (SIZE(scalar) < js) THEN
     710             :             fac = 0.0
     711             :          ELSE
     712           0 :             fac = scalar(js)
     713             :          ENDIF
     714           0 :          IF (pw_start(js) > 0) vecout%vec_pw(pw_start(js):pw_stop(js)) = vecout%vec_pw(pw_start(js):pw_stop(js))*fac
     715           0 :          IF (mt_start(js) > 0) vecout%vec_mt(mt_start(js):mt_stop(js)) = vecout%vec_mt(mt_start(js):mt_stop(js))*fac
     716           0 :          IF (vac_start(js) > 0) vecout%vec_vac(vac_start(js):vac_stop(js)) = vecout%vec_vac(vac_start(js):vac_stop(js))*fac
     717           0 :          IF (misc_start(js) > 0) vecout%vec_misc(misc_start(js):misc_stop(js)) = vecout%vec_misc(misc_start(js):misc_stop(js))*fac
     718             :       END DO
     719           0 :    END FUNCTION multiply_scalar_spin
     720             : 
     721        4478 :    FUNCTION add_vectors(vec1, vec2) RESULT(vecout)
     722             :       TYPE(t_mixvector), INTENT(IN)::vec1, vec2
     723             :       TYPE(t_mixvector)           ::vecout
     724             : 
     725        4478 :       vecout = vec1
     726    11321617 :       vecout%vec_pw = vecout%vec_pw + vec2%vec_pw
     727    88036936 :       vecout%vec_mt = vecout%vec_mt + vec2%vec_mt
     728    40812256 :       vecout%vec_vac = vecout%vec_vac + vec2%vec_vac
     729       55408 :       vecout%vec_misc = vecout%vec_misc + vec2%vec_misc
     730        4478 :    END FUNCTION add_vectors
     731             : 
     732       47930 :    FUNCTION subtract_vectors(vec1, vec2) RESULT(vecout)
     733             :       TYPE(t_mixvector), INTENT(IN)::vec1, vec2
     734             :       TYPE(t_mixvector)           ::vecout
     735             : 
     736       47930 :       vecout = vec1
     737   106823307 :       vecout%vec_pw = vecout%vec_pw - vec2%vec_pw
     738   769436172 :       vecout%vec_mt = vecout%vec_mt - vec2%vec_mt
     739   600523760 :       vecout%vec_vac = vecout%vec_vac - vec2%vec_vac
     740      380060 :       vecout%vec_misc = vecout%vec_misc - vec2%vec_misc
     741       47930 :    END FUNCTION subtract_vectors
     742             : 
     743       23958 :    FUNCTION multiply_dot(vec1, vec2) RESULT(dprod)
     744             :       TYPE(t_mixvector), INTENT(IN)::vec1, vec2
     745             :       REAL                        ::dprod, dprod_tmp
     746             :       INTEGER                     ::ierr
     747    52670158 :       dprod = DOT_PRODUCT(vec1%vec_pw, vec2%vec_pw)
     748   379601986 :       dprod = dprod + DOT_PRODUCT(vec1%vec_mt, vec2%vec_mt)
     749   300951958 :       dprod = dprod + DOT_PRODUCT(vec1%vec_vac, vec2%vec_vac)
     750      166646 :       dprod = dprod + DOT_PRODUCT(vec1%vec_misc, vec2%vec_misc)
     751             : #ifdef CPP_MPI
     752       23958 :       CALL MPI_ALLREDUCE(dprod, dprod_tmp, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
     753       23958 :       dprod = dprod_tmp
     754             : #endif
     755       23958 :    END FUNCTION multiply_dot
     756             : 
     757        1634 :    FUNCTION multiply_dot_mask(vec1, vec2, mask, spin) RESULT(dprod)
     758             :       CLASS(t_mixvector), INTENT(IN)::vec1
     759             :       TYPE(t_mixvector), INTENT(IN)::vec2
     760             :       LOGICAL, INTENT(IN)          ::mask(4)
     761             :       INTEGER, INTENT(IN)          ::spin
     762             :       REAL                        ::dprod, dprod_tmp
     763             : 
     764             :       INTEGER:: js, ierr
     765             : 
     766        1634 :       dprod = 0.0
     767             : 
     768        6536 :       DO js = 1, 3
     769        4902 :          IF (mask(1) .AND. (spin == js .OR. spin == 0) .AND. pw_start(js) > 0) &
     770             :             dprod = dprod + DOT_PRODUCT(vec1%vec_pw(pw_start(js):pw_stop(js)), &
     771     3563876 :                                         vec2%vec_pw(pw_start(js):pw_stop(js)))
     772        4902 :          IF (mask(2) .AND. (spin == js .OR. spin == 0) .AND. mt_start(js) > 0) &
     773             :             dprod = dprod + DOT_PRODUCT(vec1%vec_mt(mt_start(js):mt_stop(js)), &
     774    26466826 :                                         vec2%vec_mt(mt_start(js):mt_stop(js)))
     775        4902 :          IF (mask(3) .AND. (spin == js .OR. spin == 0) .AND. vac_start(js) > 0) &
     776             :             dprod = dprod + DOT_PRODUCT(vec1%vec_vac(vac_start(js):vac_stop(js)), &
     777     5278170 :                                         vec2%vec_vac(vac_start(js):vac_stop(js)))
     778        4902 :          IF (mask(4) .AND. (spin == js .OR. spin == 0) .AND. misc_start(js) > 0) &
     779             :             dprod = dprod + DOT_PRODUCT(vec1%vec_misc(misc_start(js):misc_stop(js)), &
     780        1634 :                                         vec2%vec_misc(misc_start(js):misc_stop(js)))
     781             :       ENDDO
     782             : 
     783             : #ifdef CPP_MPI
     784        1634 :       CALL MPI_ALLREDUCE(dprod, dprod_tmp, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
     785        1634 :       dprod = dprod_tmp
     786             : #endif
     787        1634 :    END FUNCTION multiply_dot_mask
     788             : 
     789           0 :    SUBROUTINE dfpt_multiply_dot_mask(vec1, vec2, mask, spin, dprod1, dprod2)
     790             :       CLASS(t_mixvector), INTENT(IN)::vec1
     791             :       TYPE(t_mixvector),  INTENT(IN)::vec2
     792             : 
     793             :       LOGICAL, INTENT(IN)    :: mask(3)
     794             :       INTEGER, INTENT(IN)    :: spin
     795             :       REAL,    INTENT(INOUT) :: dprod1(2)
     796             : 
     797             :       REAL, OPTIONAL, INTENT(INOUT) :: dprod2(2)
     798             : 
     799             :       REAL :: dprod1_tmp(2), dprod2_tmp(2)
     800             :       INTEGER:: js, ierr
     801             : 
     802           0 :       dprod1 = 0.0
     803           0 :       IF (PRESENT(dprod2)) dprod2 = 0.0
     804             : 
     805           0 :       DO js = 1, 2
     806           0 :          IF (mask(1) .AND. (spin == js) .AND. pw_start(js) > 0) THEN
     807             :             dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_pw(pw_start(js):pw_stop(js)/2), &
     808           0 :                                                 vec2%vec_pw(pw_start(js):pw_stop(js)/2))
     809             :             dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_pw(pw_stop(js)/2+1:pw_stop(js)), &
     810           0 :                                                 vec2%vec_pw(pw_stop(js)/2+1:pw_stop(js)))
     811             :          END IF
     812           0 :          IF (mask(2) .AND. (spin == js) .AND. mt_start(js) > 0) THEN
     813             :             dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_mt(mt_start(js):mt_stop(js)/2), &
     814           0 :                                                 vec2%vec_mt(mt_start(js):mt_stop(js)/2))
     815             :             dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_mt(mt_stop(js)/2+1:mt_stop(js)), &
     816           0 :                                                 vec2%vec_mt(mt_stop(js)/2+1:mt_stop(js)))
     817             :          END IF
     818           0 :          IF (mask(3) .AND. (spin == js) .AND. vac_start(js) > 0) THEN
     819             :             dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_vac(vac_start(js):vac_stop(js)), &
     820           0 :                                                 vec2%vec_vac(vac_start(js):vac_stop(js)))
     821             :          END IF
     822             :       END DO
     823             : 
     824           0 :       IF (js==3.AND.PRESENT(dprod2)) THEN
     825           0 :          IF (mask(1) .AND. pw_start(js) > 0) THEN
     826             :             dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_pw(pw_start(js):pw_stop(js)/4), &
     827           0 :                                                 vec2%vec_pw(pw_start(js):pw_stop(js)/4))
     828             :             dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_pw(pw_stop(js)/4+1:pw_stop(js)/2), &
     829           0 :                                                 vec2%vec_pw(pw_stop(js)/4+1:pw_stop(js)/2))
     830             :             dprod2(1) = dprod2(1) + DOT_PRODUCT(vec1%vec_pw(pw_stop(js)/2+1:3*pw_stop(js)/4), &
     831           0 :                                                 vec2%vec_pw(pw_stop(js)/2+1:3*pw_stop(js)/4))
     832             :             dprod2(2) = dprod2(2) + DOT_PRODUCT(vec1%vec_pw(3*pw_stop(js)/4+1:pw_stop(js)), &
     833           0 :                                                 vec2%vec_pw(3*pw_stop(js)/4+1:pw_stop(js)))
     834             :          END IF
     835           0 :          IF (mask(2) .AND. pw_start(js) > 0) THEN
     836             :             dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_mt(mt_start(js):mt_stop(js)/4), &
     837           0 :                                                 vec2%vec_mt(mt_start(js):mt_stop(js)/4))
     838             :             dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_mt(mt_stop(js)/4+1:mt_stop(js)/2), &
     839           0 :                                                 vec2%vec_mt(mt_stop(js)/4+1:mt_stop(js)/2))
     840             :             dprod2(1) = dprod2(1) + DOT_PRODUCT(vec1%vec_mt(mt_stop(js)/2+1:3*mt_stop(js)/4), &
     841           0 :                                                 vec2%vec_mt(mt_stop(js)/2+1:3*mt_stop(js)/4))
     842             :             dprod2(2) = dprod2(2) + DOT_PRODUCT(vec1%vec_mt(3*mt_stop(js)/4+1:mt_stop(js)), &
     843           0 :                                                 vec2%vec_mt(3*mt_stop(js)/4+1:mt_stop(js)))
     844             :          END IF
     845             :       END IF
     846             : 
     847             : #ifdef CPP_MPI
     848           0 :       CALL MPI_ALLREDUCE(dprod1, dprod1_tmp, 2, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
     849           0 :       dprod1 = dprod1_tmp
     850           0 :       IF (PRESENT(dprod2)) THEN
     851           0 :          CALL MPI_ALLREDUCE(dprod2, dprod2_tmp, 2, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
     852           0 :          dprod2 = dprod2_tmp
     853             :       END IF
     854             : #endif
     855           0 :    END SUBROUTINE dfpt_multiply_dot_mask
     856             : 
     857           0 :    FUNCTION mixvector_allocated(self) RESULT(l_array)
     858             :       IMPLICIT NONE
     859             :       CLASS(t_mixvector), INTENT(in) :: self
     860             :       LOGICAL, ALLOCATABLE :: l_array(:)
     861             : 
     862             :       l_array = [ALLOCATED(self%vec_pw), &
     863             :                  ALLOCATED(self%vec_mt), &
     864             :                  ALLOCATED(self%vec_vac), &
     865           0 :                  ALLOCATED(self%vec_misc)]
     866           0 :    END FUNCTION mixvector_allocated
     867       36498 : END MODULE m_types_mixvector

Generated by: LCOV version 1.14