LCOV - code coverage report
Current view: top level - eigen - hsmt_fjgj.F90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 29 31 93.5 %
Date: 2019-09-08 04:53:50 Functions: 2 2 100.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_hsmt_fjgj
       7             :   USE m_juDFT
       8             :   IMPLICIT NONE
       9             : 
      10             :   INTERFACE hsmt_fjgj
      11             :     module procedure hsmt_fjgj_cpu
      12             : #ifdef CPP_GPU
      13             :     module procedure hsmt_fjgj_gpu
      14             : #endif
      15             :   END INTERFACE
      16             : 
      17             : CONTAINS
      18             : #ifdef CPP_GPU
      19             : 
      20             :   SUBROUTINE synth_fjgj(nv,ispin,jspins,lmax,lmaxd,apw,l_flag,rk,rmt,con1,uds,dus,us,duds,fj,gj)
      21             :   USE m_sphbes
      22             :   USE m_dsphbs
      23             :   INTEGER, INTENT(IN) :: nv, ispin, jspins, lmax, lmaxd
      24             :   LOGICAL, INTENT(IN) :: apw(0:lmaxd), l_flag
      25             :   REAL, INTENT(IN) :: rk(:),rmt,con1
      26             :   REAL, INTENT(IN) :: uds(0:lmaxd,jspins),dus(0:lmaxd,jspins),us(0:lmaxd,jspins),duds(0:lmaxd,jspins) 
      27             :   REAL,INTENT(OUT),MANAGED     :: fj(:,0:,:),gj(:,0:,:)
      28             : 
      29             :   REAL gb(0:lmaxd), fb(0:lmaxd)
      30             :   REAL ws(jspins)
      31             :   REAL ff,gg,gs
      32             :   INTEGER k,l,jspin
      33             : 
      34             :   DO k = 1,nv
      35             :           gs = rk(k)*rmt
      36             :           CALL sphbes(lmax,gs,fb)
      37             :           CALL dsphbs(lmax,gs,fb,gb)
      38             :           DO l = 0,lmax
      39             :              !---> set up wronskians for the matching conditions for each ntype
      40             :              DO jspin = 1, jspins
      41             :                 ws(jspin) = con1/(uds(l,jspin)*dus(l,jspin) - us(l,jspin)*duds(l,jspin))
      42             :              END DO
      43             :              ff = fb(l)
      44             :              gg = rk(k)*gb(l)
      45             :              IF ( apw(l) ) THEN
      46             :                 fj(k,l,ispin) = 1.0*con1 * ff / us(l,ispin)
      47             :                 gj(k,l,ispin) = 0.0
      48             :              ELSE
      49             :                 IF (l_flag) THEN
      50             :                    DO jspin = 1, jspins
      51             :                       fj(k,l,jspin) = ws(jspin) * ( uds(l,jspin)*gg - duds(l,jspin)*ff )
      52             :                       gj(k,l,jspin) = ws(jspin) * ( dus(l,jspin)*ff - us(l,jspin)*gg )
      53             :                    END DO
      54             :                 ELSE
      55             :                    fj(k,l,ispin) = ws(ispin) * ( uds(l,ispin)*gg - duds(l,ispin)*ff )
      56             :                    gj(k,l,ispin) = ws(ispin) * ( dus(l,ispin)*ff - us(l,ispin)*gg )
      57             :                 ENDIF
      58             :              ENDIF
      59             :           ENDDO
      60             :   ENDDO ! k = 1, lapw%nv
      61             : 
      62             :   END SUBROUTINE synth_fjgj
      63             : 
      64             : 
      65             :   SUBROUTINE hsmt_fjgj_gpu(input,atoms,cell,lapw,noco,usdus,n,ispin,fj,gj)
      66             :     !Calculate the fj&gj array which contain the part of the A,B matching coeff. depending on the
      67             :     !radial functions at the MT boundary as contained in usdus
      68             :     USE m_constants, ONLY : fpi_const
      69             :     USE m_types
      70             :     IMPLICIT NONE
      71             :     TYPE(t_input),INTENT(IN)    :: input
      72             :     TYPE(t_cell),INTENT(IN)     :: cell
      73             :     TYPE(t_noco),INTENT(IN)     :: noco
      74             :     TYPE(t_atoms),INTENT(IN)    :: atoms
      75             :     TYPE(t_lapw),INTENT(IN)     :: lapw
      76             :     TYPE(t_usdus),INTENT(IN)    :: usdus
      77             :     !     ..
      78             :     !     .. Scalar Arguments ..
      79             :     INTEGER, INTENT (IN) :: ispin,n
      80             :   
      81             :     REAL,INTENT(OUT),MANAGED     :: fj(:,0:,:,:),gj(:,0:,:,:)
      82             :     !     ..
      83             :     !     .. Local Scalars ..
      84             :     REAL con1
      85             : 
      86             :     INTEGER l,lo,intspin
      87             :     LOGICAL l_socfirst
      88             :     !     .. Local Arrays ..
      89             :     LOGICAL apw(0:atoms%lmaxd)
      90             :     !     ..
      91             :     l_socfirst = noco%l_soc .AND. noco%l_noco .AND. (.NOT. noco%l_ss)
      92             :     con1 = fpi_const/SQRT(cell%omtil)
      93             :     DO l = 0,atoms%lmax(n)
      94             :        apw(l)=ANY(atoms%l_dulo(:atoms%nlo(n),n))
      95             :        IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l) = .FALSE.
      96             :     ENDDO
      97             :     DO lo = 1,atoms%nlo(n)
      98             :        IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n)) = .TRUE.
      99             :     ENDDO
     100             :     DO intspin=1,MERGE(2,1,noco%l_noco)
     101             : 
     102             :        CALL synth_fjgj(lapw%nv(intspin),ispin,input%jspins,atoms%lmax(n),atoms%lmaxd,apw,noco%l_constr.or.l_socfirst,&
     103             :             lapw%rk(:,intspin),atoms%rmt(n),con1,usdus%uds(:,n,:),usdus%dus(:,n,:),usdus%us(:,n,:),usdus%duds(:,n,:),&
     104             :             fj(:,0:,:,intspin),gj(:,0:,:,intspin))
     105             : 
     106             :     ENDDO
     107             :     RETURN
     108             :   END SUBROUTINE hsmt_fjgj_gpu
     109             : #endif
     110             : 
     111        4156 :   SUBROUTINE hsmt_fjgj_cpu(input,atoms,cell,lapw,noco,usdus,n,ispin,fj,gj)
     112             :     !Calculate the fj&gj array which contain the part of the A,B matching coeff. depending on the
     113             :     !radial functions at the MT boundary as contained in usdus
     114             :     USE m_constants, ONLY : fpi_const
     115             :     USE m_sphbes
     116             :     USE m_dsphbs
     117             :     USE m_types
     118             :     IMPLICIT NONE
     119             :     TYPE(t_input),INTENT(IN)    :: input
     120             :     TYPE(t_cell),INTENT(IN)     :: cell
     121             :     TYPE(t_noco),INTENT(IN)     :: noco
     122             :     TYPE(t_atoms),INTENT(IN)    :: atoms
     123             :     TYPE(t_lapw),INTENT(IN)     :: lapw
     124             :     TYPE(t_usdus),INTENT(IN)    :: usdus
     125             :     !     ..
     126             :     !     .. Scalar Arguments ..
     127             :     INTEGER, INTENT (IN) :: ispin,n
     128             :   
     129             :     REAL,INTENT(OUT)     :: fj(:,0:,:,:),gj(:,0:,:,:)
     130             :     !     ..
     131             :     !     .. Local Scalars ..
     132             :     REAL con1,ff,gg,gs
     133             : 
     134             :     INTEGER k,l,lo,intspin,jspin
     135             :     LOGICAL l_socfirst
     136             :     !     .. Local Arrays ..
     137        4156 :     REAL ws(input%jspins)
     138        4156 :     REAL gb(0:atoms%lmaxd), fb(0:atoms%lmaxd)
     139        8312 :     LOGICAL apw(0:atoms%lmaxd)
     140             :     !     ..
     141        4156 :     l_socfirst = noco%l_soc .AND. noco%l_noco .AND. (.NOT. noco%l_ss)
     142        4156 :     con1 = fpi_const/SQRT(cell%omtil)
     143       42704 :     DO l = 0,atoms%lmax(n)
     144       38548 :        apw(l)=ANY(atoms%l_dulo(:atoms%nlo(n),n))
     145       42704 :        IF ((input%l_useapw).AND.(atoms%lapw_l(n).GE.l)) apw(l) = .FALSE.
     146             :     ENDDO
     147        6096 :     DO lo = 1,atoms%nlo(n)
     148        6096 :        IF (atoms%l_dulo(lo,n)) apw(atoms%llo(lo,n)) = .TRUE.
     149             :     ENDDO
     150       10888 :     DO intspin=1,MERGE(2,1,noco%l_noco)
     151             :        !$OMP PARALLEL DO DEFAULT(NONE) &
     152             :        !$OMP PRIVATE(l,gs,fb,gb,ws,ff,gg,jspin)&
     153             :        !$OMP SHARED(lapw,atoms,con1,usdus,l_socfirst,noco,input)&
     154       10888 :        !$OMP SHARED(fj,gj,intspin,n,ispin,apw)
     155             :        DO k = 1,lapw%nv(intspin)
     156     1187236 :           gs = lapw%rk(k,intspin)*atoms%rmt(n)
     157     1187236 :           CALL sphbes(atoms%lmax(n),gs, fb)
     158     1187236 :           CALL dsphbs(atoms%lmax(n),gs,fb, gb)
     159             : !          !$OMP SIMD PRIVATE(ws,ff,gg)
     160    12013448 :           DO l = 0,atoms%lmax(n)
     161             :              !---> set up wronskians for the matching conditions for each ntype
     162    31196268 :              DO jspin = 1, input%jspins
     163             :                 ws(jspin) = con1/(usdus%uds(l,n,jspin)*usdus%dus(l,n,jspin)&
     164    31196268 :                             - usdus%us(l,n,jspin)*usdus%duds(l,n,jspin))
     165             :              END DO
     166    10812748 :              ff = fb(l)
     167    10812748 :              gg = lapw%rk(k,intspin)*gb(l)
     168    11999984 :              IF ( apw(l) ) THEN
     169           0 :                 fj(k,l,ispin,intspin) = 1.0*con1 * ff / usdus%us(l,n,ispin)
     170           0 :                 gj(k,l,ispin,intspin) = 0.0
     171             :              ELSE
     172    21625496 :                 IF (noco%l_constr.or.l_socfirst) THEN
     173     8899200 :                    DO jspin = 1, input%jspins
     174     3559680 :                       fj(k,l,jspin,intspin) = ws(jspin) * ( usdus%uds(l,n,jspin)*gg - usdus%duds(l,n,jspin)*ff )
     175     5339520 :                       gj(k,l,jspin,intspin) = ws(jspin) * ( usdus%dus(l,n,jspin)*ff - usdus%us(l,n,jspin)*gg )
     176             :                    END DO
     177             :                 ELSE
     178     9032908 :                    fj(k,l,ispin,intspin) = ws(ispin) * ( usdus%uds(l,n,ispin)*gg - usdus%duds(l,n,ispin)*ff )
     179     9032908 :                    gj(k,l,ispin,intspin) = ws(ispin) * ( usdus%dus(l,n,ispin)*ff - usdus%us(l,n,ispin)*gg )
     180             :                 ENDIF
     181             :              ENDIF
     182             :           ENDDO
     183             : !          !$OMP END SIMD
     184             :        ENDDO ! k = 1, lapw%nv
     185             :        !$OMP END PARALLEL DO
     186             :     ENDDO
     187        4156 :     RETURN
     188             :   END SUBROUTINE hsmt_fjgj_cpu
     189             : END MODULE m_hsmt_fjgj

Generated by: LCOV version 1.13