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