LCOV - code coverage report
Current view: top level - kpoints - bravais.f (source / functions) Hit Total Coverage
Test: combined.info Lines: 30 76 39.5 %
Date: 2019-09-08 04:53:50 Functions: 1 1 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             : 
       7             :       MODULE m_bravais
       8             :       use m_juDFT
       9             : !----------------------------------------------------------------------!
      10             : ! given a Bravais-matrix amat, determine the lattice system and type   !
      11             : ! (idsyst,idtype)                                              gb`05   !
      12             : !----------------------------------------------------------------------!
      13             :       CONTAINS
      14           6 :       SUBROUTINE bravais(
      15             :      >                   amat,
      16             :      <                   idsyst,idtype)
      17             : 
      18             :       IMPLICIT NONE
      19             : 
      20             :       REAL,    INTENT (IN)  :: amat(3,3)
      21             :       INTEGER, INTENT (OUT) :: idsyst,idtype
      22             : 
      23             :       REAL a(3),b(3),c(3),g(3),e(3),f(3)
      24             :       REAL sa, sb, sc, al, be, ga
      25             :       REAL, PARAMETER :: eps = 1.0e-5
      26             :       REAL, PARAMETER :: thrd = -1./3.
      27             :       INTEGER i,j,k
      28             :       LOGICAL l_ab, l_bc, l_ac, al_be, be_ga, al_ga
      29             : 
      30             :       CHARACTER (len=12) :: c_sy(7)
      31             :       CHARACTER (len=15) :: c_ty(6)
      32             :       c_sy = (/'cubic       ','tetragonal  ','orthorhombic',
      33             :      +         'hexagonal   ','trigonal    ','monoclinic  ',
      34          48 :      +         'triclinic   '/)
      35             :       c_ty = (/'primitive      ','body centered  ','face centered  ',
      36          42 :      +         'A-face centered','B-face centered','C-face centered'/)
      37             : 
      38          24 :       a(:) = amat(:,1) ; b(:) = amat(:,2) ; c(:) = amat(:,3)
      39          24 :       sa = SQRT( DOT_PRODUCT( a, a) )
      40          24 :       sb = SQRT( DOT_PRODUCT( b, b) )
      41          24 :       sc = SQRT( DOT_PRODUCT( c, c) ) 
      42          24 :       al = DOT_PRODUCT( b, c) / ( sb * sc )
      43          24 :       be = DOT_PRODUCT( a, c) / ( sa * sc )
      44          24 :       ga = DOT_PRODUCT( b, a) / ( sb * sa )
      45           6 :       write (6,*) sa,sb,sc,al,be,ga
      46             : 
      47           6 :       l_ab = .false. ; l_bc = .false. ; l_ac = .false.
      48           6 :       al_be = .false. ; be_ga = .false. ; al_ga = .false.
      49           6 :       IF ( ABS(sa-sb) < eps ) l_ab = .true.
      50           6 :       IF ( ABS(sb-sc) < eps ) l_bc = .true.
      51           6 :       IF ( ABS(sa-sc) < eps ) l_ac = .true.
      52           6 :       IF ( ABS(al-be) < eps ) al_be = .true.
      53           6 :       IF ( ABS(be-ga) < eps ) be_ga = .true.
      54           6 :       IF ( ABS(al-ga) < eps ) al_ga = .true.
      55             :       
      56           6 :       idsyst = 99 ; idtype = 99
      57             : 
      58           6 :       IF (l_ab.AND.l_bc)  THEN                ! all sides equal
      59           6 :         IF (al_be.AND.be_ga) THEN             ! all angles equal
      60           6 :           IF ( ABS(al) < eps )  THEN          ! alpha = 90 deg
      61           0 :             idsyst = 1 ; idtype = 1           !       --> simple cubic
      62           6 :           ELSEIF ( ABS(al-thrd) < eps ) THEN  ! alpha = 109 deg
      63           0 :             idsyst = 1 ; idtype = 2           !       --> bcc
      64           6 :           ELSEIF ( ABS(al-0.5) < eps ) THEN   ! alpha = 60  deg
      65           6 :             idsyst = 1 ; idtype = 3           !       --> fcc
      66             :           ELSE
      67           0 :             idsyst = 5 ; idtype = 1           ! -->  trigonal (rhomboedric) 
      68             :           ENDIF
      69           0 :         ELSEIF (al_be.OR.be_ga.OR.al_ga) THEN ! two angles equal
      70           0 :           idsyst = 2 ; idtype = 2             !  -->  tetragonal - I
      71             :         ELSE
      72           0 :           idsyst = 3 ; idtype = 2             !  -->  orthorhombic - I
      73             :         ENDIF
      74             :       ENDIF
      75             : 
      76           6 :       IF (idsyst == 99) THEN                  ! continue the search
      77             : 
      78           0 :       IF (l_ab.OR.l_bc.OR.l_ac)  THEN         ! two sides equal
      79             :                                               ! hexagonal or tetragonal or base-centered
      80           0 :         IF (al_be.AND.be_ga) THEN             ! all angles equal
      81           0 :           IF ( ABS(al) < eps )  THEN          ! alpha = 90  deg
      82           0 :             idsyst = 2 ; idtype = 1           !       --> simple tetragonal
      83             :           ELSE
      84           0 :             IF (l_ab) THEN
      85           0 :              idsyst = 6 ; idtype = 6          ! special monoclinic - C
      86           0 :             ELSEIF (l_bc) THEN
      87           0 :              idsyst = 6 ; idtype = 4          ! special monoclinic - A
      88           0 :             ELSEIF (l_ac) THEN
      89           0 :              idsyst = 6 ; idtype = 5          ! special monoclinic - B
      90             :             ENDIF
      91             :           ENDIF
      92           0 :         ELSEIF (.NOT.(al_be.OR.be_ga.OR.al_ga)) THEN  ! all angles different
      93           0 :           idsyst = 7 ; idtype = 1                     ! triclinic
      94             :         ELSE
      95           0 :           IF ( al_be.AND.( ABS(ABS(ga)-0.5) < eps ) ) THEN
      96           0 :             idsyst = 4 ; idtype = 1 ! hexagonal
      97           0 :           ELSEIF ((ABS(al)<eps).OR.(ABS(be)<eps).OR.(ABS(ga)<eps)) THEN  ! one is 90 deg
      98           0 :             IF ( (ABS(al)<eps).AND.(ABS(be)<eps) ) THEN
      99           0 :               idsyst = 3 ; idtype = 6                         ! orthorhombic - C
     100           0 :             ELSEIF ( (ABS(ga)<eps).AND.(ABS(be)<eps) ) THEN
     101           0 :               idsyst = 3 ; idtype = 4                         ! orthorhombic - A
     102           0 :             ELSEIF ( (ABS(al)<eps).AND.(ABS(ga)<eps) ) THEN
     103           0 :               idsyst = 3 ; idtype = 5                         ! orthorhombic - B
     104             :             ELSE
     105           0 :               idsyst = 6 ; idtype = 1            ! simple monoclinic
     106             :             ENDIF
     107             :           ELSE                                                           ! none is 90 deg
     108           0 :             IF (al_be) THEN
     109           0 :              idsyst = 6 ; idtype = 6             ! monoclinic - C
     110           0 :             ELSEIF (be_ga) THEN
     111           0 :              idsyst = 6 ; idtype = 4             ! monoclinic - A
     112           0 :             ELSEIF (al_ga) THEN
     113           0 :              idsyst = 6 ; idtype = 5             ! monoclinic - B
     114             :             ELSE
     115           0 :               idsyst = 6 ; idtype = 1            ! simple monoclinic
     116             :             ENDIF
     117             :           ENDIF
     118             :         ENDIF
     119             : 
     120             :       ELSE                                    ! orthorhombic or tricinic or monoclinic
     121             : 
     122           0 :         IF (al_be.AND.be_ga) THEN             ! all angles equal
     123           0 :           IF ( ABS(al) < eps )  THEN          ! angles 90 deg
     124           0 :            idsyst = 3 ; idtype = 1            ! --> simple orthorhombic
     125             :           ELSE
     126           0 :            idsyst = 7 ; idtype = 1            ! triclinic
     127             :           ENDIF
     128           0 :         ELSEIF (.NOT.(al_be.OR.be_ga.OR.al_ga)) THEN ! all angles different
     129           0 :           e = a + b - c ; f = b + c - a ; g = a + c - b
     130             :           IF ( (DOT_PRODUCT( e, f) == 0).AND.
     131           0 :      +         (DOT_PRODUCT( e, g) == 0).AND.
     132             :      +         (DOT_PRODUCT( g, f) == 0) )  THEN
     133           0 :              idsyst = 3 ; idtype = 3          ! --> face-centered orthorhombic
     134             :           ELSE
     135           0 :              idsyst = 7 ; idtype = 1         ! triclinic
     136             :           ENDIF
     137             :         ELSE
     138           0 :           idsyst = 6 ; idtype = 1   ! simple monoclinic 
     139             :         ENDIF
     140             : 
     141             :       ENDIF
     142             : 
     143             :       ENDIF
     144             :      
     145           6 :       IF ((idsyst == 99).OR.(idtype == 99) ) CALL juDFT_error("bravais!"
     146           0 :      +     ,calledby ="bravais")
     147           6 :  10   WRITE(6,*) c_ty(idtype),' ',c_sy(idsyst)
     148             : 
     149           6 :       END SUBROUTINE bravais
     150             :       END MODULE m_bravais

Generated by: LCOV version 1.13