LCOV - code coverage report
Current view: top level - inpgen - super_check.f (source / functions) Hit Total Coverage
Test: combined.info Lines: 36 41 87.8 %
Date: 2019-09-08 04:53:50 Functions: 2 2 100.0 %

          Line data    Source code
       1             :       MODULE m_supercheck
       2             : !*********************************************************************
       3             : !     checks whether this is a supercell and determines the
       4             : !     translations that take the crystal in to itself
       5             : !*********************************************************************
       6             :       CONTAINS
       7           3 :       SUBROUTINE super_check(
       8           3 :      >                       nat,pos,ity,ntypm,
       9             :      <                       ns,trs)
      10             : 
      11             :       IMPLICIT NONE
      12             : 
      13             : !==> Arguments
      14             :       INTEGER, INTENT (IN)  :: nat,ntypm,ity(nat)
      15             :       REAL,    INTENT (IN)  :: pos(3,nat)
      16             :       INTEGER, INTENT (OUT) :: ns       ! size of supercell
      17             :       REAL,    INTENT (OUT) :: trs(3,*) ! translations
      18             : !==> Locals
      19             :       INTEGER i,j,n,ntysmin
      20           6 :       INTEGER ntys(ntypm)
      21             :       REAL    tr(3)
      22             :       LOGICAL l_f
      23             : 
      24             :       REAL, PARAMETER :: eps=1.e-7
      25             : 
      26             : 
      27           3 :       ns = 1
      28          12 :       trs(1:3,ns) = (/ 0.000 , 0.000 , 0.000 /)
      29             : 
      30             : !---> check if possible to be a supercell
      31           6 :       ntys(1:ntypm) = 0
      32           9 :       DO n = 1, nat
      33           9 :          ntys( ity(n) ) = ntys( ity(n) ) + 1
      34             :       ENDDO
      35           6 :       ntysmin = minval( ntys )
      36             : 
      37           3 :       IF ( ntysmin == 1 ) RETURN  ! not a supercell if one atom different
      38             : 
      39           3 :       DO i = ntysmin,2,-1                 ! check ratios of atoms
      40           3 :          IF ( mod(ntysmin,i).ne.0 ) CYCLE ! only factors of ntysmin allowed
      41           3 :          l_f = .true.
      42           6 :          DO n = 1, ntypm
      43           6 :             IF ( mod( ntys(n), i ) .ne. 0 ) THEN
      44             :                l_f = .false.
      45             :                EXIT
      46             :             ENDIF
      47             :          ENDDO
      48           3 :          IF (l_f) THEN
      49           3 :             ns = i    ! possible value
      50           3 :             exit
      51             :          ENDIF
      52             :       ENDDO
      53           3 :       IF (ns == 1) RETURN
      54             : 
      55             : !---> based on number of atoms (and type), possibly a supercell;
      56             : !---> now need to check by doing translations
      57             : 
      58           3 :       ns = 1
      59             : !---> get possible shifts
      60           3 :       DO j = 1, nat-1
      61           6 :          shift_i:  DO i = j+1, nat  ! -ve shifts will come through naturally
      62             : 
      63           3 :             tr(:) = pos(:,i)-pos(:,j) - anint( pos(:,i)-pos(:,j) - eps )
      64             : 
      65             : !--->       check if already done
      66           6 :             DO n=1,ns
      67           6 :                IF ( all( abs( tr(:)-trs(:,n) ) < eps ) ) CYCLE shift_i
      68             :             ENDDO
      69             : 
      70           6 :             IF ( l_shiftm(tr,pos,nat) ) THEN
      71           0 :                 ns = ns + 1
      72           0 :                 trs(:,ns) = tr(:)
      73             :             ENDIF
      74             : 
      75             :          ENDDO shift_i
      76             :       ENDDO
      77             : 
      78           3 :       IF ( ns > 1 ) THEN
      79             :          WRITE(6,'(/," The system appears to be a supercell",
      80           0 :      &               " containing",i4," primitive cells:")') ns
      81           0 :          DO n = 1, ns
      82           0 :             WRITE (6,'(i8,3f12.6)') n,trs(1:3,n)
      83             :          ENDDO
      84             :       ENDIF
      85             : 
      86             :       CONTAINS ! internal function
      87             : 
      88           3 :       LOGICAL FUNCTION l_shiftm(tr,pos,nat)
      89             : !********************************************************************
      90             : !     determines whether the vector tr is a translation of the
      91             : !     crystal (non-primitive for supercell)
      92             : !********************************************************************
      93             :       IMPLICIT NONE
      94             : 
      95             :       INTEGER, INTENT(IN) :: nat
      96             :       REAL,    INTENT(IN) :: tr(3)
      97             :       REAL,    INTENT(IN) :: pos(3,nat)
      98             : 
      99             :       REAL    rp(3)
     100             :       INTEGER i,j,in
     101             : 
     102           3 :       l_shiftm = .false.
     103             : 
     104           6 :       DO i = 1, nat
     105             : !--->    rotated and shifted atom, reduced to (-1/2,1/2]
     106           6 :          rp(:) = pos(:,i) + tr(:) - anint( pos(:,i) + tr(:) - eps )
     107             : !--->    find which atom, if any, this matches
     108             :          in = 0
     109          24 :          DO j = 1, nat
     110          12 :             IF ( ity(i).NE.ity(j) ) CYCLE
     111             : !            if( all( abs(pos(:,j)-rp(:) ) < eps ) ) then
     112             : ! causes problem with intel compiler ifc Version 5.0.1 (gs2001-11-07)
     113             :             IF ( abs(pos(1,j)-rp(1) ) < eps  .and.
     114          12 :      &           abs(pos(2,j)-rp(2) ) < eps  .and.
     115           3 :      &           abs(pos(3,j)-rp(3) ) < eps  ) THEN
     116             :                in = j
     117             :                EXIT
     118             :             ENDIF
     119             :          ENDDO
     120           6 :          IF (in == 0 ) RETURN
     121             :       ENDDO
     122             : 
     123             :       l_shiftm = .true.  !  only if everything matches
     124             : 
     125             :       END FUNCTION l_shiftm
     126             : 
     127             :       END SUBROUTINE super_check
     128             :       END MODULE m_supercheck

Generated by: LCOV version 1.13