LCOV - code coverage report
Current view: top level - kpoints - ordstar.f (source / functions) Hit Total Coverage
Test: combined.info Lines: 170 227 74.9 %
Date: 2019-09-08 04:53:50 Functions: 1 1 100.0 %

          Line data    Source code
       1             :       MODULE m_ordstar
       2             :       use m_juDFT
       3             : c-----------------------------------------------------------------------
       4             : c
       5             : c --->   this program sorts
       6             : c        generated k-points in (not necessary full) stars
       7             : c        using the provided symmetry elements
       8             : c
       9             : c --->   order generated k-points in stars by applying symmetry:
      10             : c        - determine number of different stars nkstar .le. nkpt
      11             : c        - determine order of star iostar(kpn) .le. nsym
      12             : c        - assign pointer ikpn(i,ik); i=1,iostar(ik); ik=1,nkstar
      13             : c        - determine representative vector vkrep(3,ik); ik=1,nkstar
      14             : c        - for nreg=0:
      15             : c                    - assign nkpt= nkstar
      16             : c                    - assign vkxyz(ix,ik) = vkrep(ix,ik); ik=1,nkpt
      17             : c                                                          ix=1,3
      18             : c
      19             : c-----------------------------------------------------------------------
      20             :       CONTAINS
      21          25 :       SUBROUTINE  ordstar(
      22             :      >                    iokpt,kpri,ktest,
      23          25 :      >                    fnorm,fdist,nface,iside,
      24             :      >                    nsym,ccr,rltv,mkpt,mface,mdir,
      25          25 :      =                    nkpt,vkxyz,
      26          25 :      <                    nkstar,iostar,ikpn,vkrep,nkrep)
      27             : cc
      28             : c    Meaning of variables:
      29             : c    INPUT:
      30             : c
      31             : c    Symmetry of lattice:
      32             : c    rltv     : cartesian coordinates of basis vectors for
      33             : c               reciprocal lattice rltv(ix,jn), ix=1,3; jn=1,3
      34             : c    nsym     : number of symmetry elements of points group
      35             : c    ccr     : rotation matrix for symmetry element
      36             : c                   in cartesian representation
      37             : c
      38             : c    representation of the irreducible part of the BZ:
      39             : c    fnorm    : normal vector of the planes bordering the irrBZ
      40             : c    fdist    : distance vector of the planes bordering the irrBZ
      41             : c    iside    : characterizing the inner side of each face of the irrBZ
      42             : c    nface    : number of faces of the irrBZ
      43             : c
      44             : c    k-point set:
      45             : c    nkpt     : number of k-points generated in set
      46             : c    vkxyz    : vector of kpoint generated; in cartesian representation
      47             : c
      48             : c    OUTPUT: Characteristics of k-point stars
      49             : c    nkstar   : number of stars for k-points generated by MOP
      50             : c    iostar   : number of k-points in each star
      51             : c    ikpn     : index field for the k-points in each star
      52             : c    vkrep    : representative k-vector in irrBZ for each star
      53             : c    nkrep    : index for each star;
      54             : c               1 if representative k-vector vkrep has been found
      55             : c-----------------------------------------------------------------------
      56             :       USE m_kprep
      57             :       IMPLICIT NONE
      58             : C
      59             : C-----> PARAMETER STATEMENTS
      60             : C
      61             : c
      62             :       INTEGER, INTENT (IN) :: mface,mkpt,mdir
      63             : c
      64             : c
      65             : c ---> file number for read and write
      66             : c
      67             :       integer  iofile,iokpt
      68             : c
      69             : c ---> running mode parameter
      70             : c
      71             :       integer  kpri,ktest
      72             : C
      73             : C----->  Symmetry information
      74             : C
      75             :       integer  nsym
      76             :       real     ccr(3,3,48)
      77             : C
      78             : C----->  RECIPROCAL LATTICE INFORMATION
      79             : C
      80             :       integer  nface
      81             :       real     rltv(3,3),fnorm(3,mface),fdist(mface)
      82             : C
      83             : C----->  BRILLOUINE ZONE INTEGRATION
      84             : C
      85             :       integer  nkpt,nkstar,iostar(mkpt)
      86             :       real     vkxyz(3,mkpt)
      87             : C
      88             : C --->  local variables
      89             : c
      90             :       character*80 blank
      91             :       integer  i,idim,i1,i2,i3,ii,ij,ik,is,isym,ifac, iik,iiik
      92             :       integer  ikc, i1red,nred
      93             :       integer  dirmin,dirmax,ndir1,ndir2,idir,lim(3)
      94             :       integer  kpl,kpm,kpn,nstnew
      95             :       integer  iplus,iminus,iside(mface),nkrep(mkpt),isi(7)
      96             :       real     orient,vkrep(3,mkpt),vktra(3)
      97             :       integer  ikpn(48,mkpt),irrkpn(mkpt),nfract(3),nleft,nirrbz
      98             :       real     fract(mkpt,3),fsig(2),vktes(3),vk_bzb(3)
      99             :       real     aivnkpt, sum,denom, t_bzb, t_len
     100             :       integer  isumkpt, iosub, ix, iy, iz, is1
     101             :       real     invtpi, zero,one,half, eps,eps1
     102             :       real     vkstar(3,48)
     103             : C
     104             : C --->  intrinsic functions
     105             : c
     106             :       intrinsic   abs,real
     107             : C
     108             : C --->  save and data statements
     109             : c
     110             :       save     one,zero,half,eps,eps1,iplus,iminus
     111             :       data     zero/0.0/,one/1.0/,half/0.5/,
     112             :      +         eps/1e-8/,eps1/1e-5/,iplus/1/,iminus/-1/
     113             : c
     114             : c-----------------------------------------------------------------------
     115             : c
     116             : c --->   set file numbers
     117             : c
     118             : c     iokpt  = 15
     119          25 :       iofile = 9
     120          25 :       OPEN (iofile,form='formatted',status='scratch')
     121          25 :       if (kpri .ge. 1) then
     122             : c       write(iofile,'(/)')
     123           0 :         write(iofile,'(3x,'' *<* ordstar *>* '')')
     124           0 :         write(iofile,'(3x,'' orders generated k-vectors'')')
     125           0 :         write(iofile,'(3x,'' ~~~~~~~~~~~~~~~~~~~~~~~~~~'')')
     126           0 :         write(iofile,'(3x,'' in (not neccessary full) stars'')')
     127           0 :         write(iofile,'(3x,'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'')')
     128             :       end if
     129             : c
     130             : c --->   start calculation
     131             : c =====================================================================
     132             : c
     133             : c ---> set sign constants
     134          25 :        isi(1) = 0
     135          25 :        isi(2) = iminus
     136          25 :        isi(3) = iplus
     137          25 :        isi(4) = -2
     138          25 :        isi(5) =  2
     139          25 :        isi(6) = -3
     140          25 :        isi(7) =  3
     141             : c
     142          25 :           nkstar = 0
     143             : c
     144             : c --->   initialize pointers ikpn(ii,kpn) = 0
     145             : c               and          iostar(kpn) = 0
     146             : c
     147        6061 :       do 10 kpn = 1,mkpt
     148        6036 :        iostar(kpn) = 0
     149          25 :   10  continue
     150         428 :       do 15 ii = 1,nsym
     151      269583 :        do 16 kpn = 1,mkpt
     152      269180 :          ikpn(ii,kpn) = 0
     153         403 :   16   continue
     154          25 :   15  continue
     155             : c
     156             : c --->   screen over all kpoints
     157             : c
     158        6061 :           do 100 kpn = 1,nkpt
     159             : c
     160             : c --->  check if given kpoint is assigned to the star of a previous one;
     161             : c             then skip
     162             : c
     163      701727 :               do 105 ik = 1,nkstar
     164    12923356 :                do 106 is = 1,iostar(ik)
     165    12227665 :                  if(ikpn(is,ik) .eq. kpn) go to 100
     166      695691 :  106           continue
     167         442 :  105          continue
     168             : c
     169             : c --->   new star is started for kpoint kpn: assign counters
     170             : c                            and set representative vkrep = zero
     171             : c
     172         442 :                nkstar = nkstar + 1
     173         442 :                is= 1
     174         442 :                iostar(nkstar)= 1
     175         442 :                ikpn(is,nkstar) = kpn
     176         442 :                nkrep(nkstar)= 0
     177         442 :                vkrep(1,nkstar) = zero
     178         442 :                vkrep(2,nkstar) = zero
     179         442 :                vkrep(3,nkstar) = zero
     180         442 :          if (ktest.ge.1) then
     181           0 :         write(iofile,'(/,1x,''start new star for vkxyz'')')
     182             :         write(iofile,'(1x,i4,1x,3(f10.7,1x),10x,''vkxyz'')')
     183           0 :      +                 is,(vkxyz(ii,kpn),ii=1,3)
     184             :          end if
     185             : c
     186             : c --->   generate kpoints establishing the star of vkxyz(kpn)
     187             : c
     188       18178 :              do 110 isym = 1,nsym
     189             :                vktes(1) = ccr(1,1,isym)*vkxyz(1,kpn)
     190             :      +                    + ccr(1,2,isym)*vkxyz(2,kpn)
     191       17736 :      +                      + ccr(1,3,isym)*vkxyz(3,kpn)
     192             :                vktes(2) = ccr(2,1,isym)*vkxyz(1,kpn)
     193             :      +                    + ccr(2,2,isym)*vkxyz(2,kpn)
     194       17736 :      +                      + ccr(2,3,isym)*vkxyz(3,kpn)
     195             :                vktes(3) = ccr(3,1,isym)*vkxyz(1,kpn)
     196             :      +                    + ccr(3,2,isym)*vkxyz(2,kpn)
     197       17736 :      +                      + ccr(3,3,isym)*vkxyz(3,kpn)
     198       17736 :          if (ktest.ge.4) then
     199             :               write(iofile,'(1x,i4,1x,3(f10.7,1x),10x,''vktes'')')
     200           0 :      +                                           isym,(vktes(ii),ii=1,3)
     201             :          end if
     202             : c
     203             : c
     204             : c --->   check if any other kpoints belong to the star of vkxyz(kpn);
     205             : c              if so, assign new values to counters and pointers
     206             : c
     207    62663248 :                do 120 ik = kpn+1,nkpt
     208             :                if(abs(vktes(1)-vkxyz(1,ik)).le.eps1
     209             :      +           .and. abs(vktes(2)-vkxyz(2,ik)).le.eps1
     210    62645512 :      +             .and. abs(vktes(3)-vkxyz(3,ik)).le.eps1) then
     211             : c
     212             : c --->   -  make sure we have found a new point within current star
     213             : c
     214       92234 :                     do 125 i1 = 1,is
     215       86640 :                      if(ikpn(i1,nkstar) .eq. ik) go to 120
     216        5594 :  125                continue
     217        5594 :                      is= is+1
     218        5594 :                      iostar(nkstar)= iostar(nkstar)+1
     219        5594 :                      ikpn(is,nkstar) = ik
     220             :                end if
     221       17736 :  120         continue
     222             : c
     223             : c --->   check, if vktes is representative k-point in irrBZ
     224             : c                                   for current star
     225             :             CALL kprep(
     226             :      >                 iofile,iokpt,kpri,ktest,
     227             :      >                 nface,fnorm,fdist,iside,
     228             :      >                 vktes,nkstar,mkpt,mface,mdir,
     229       17736 :      =                 nkrep(nkstar),vkrep(1,nkstar))
     230             : c
     231        6036 :  110         continue
     232          25 :  100      continue
     233             : c
     234             : c --->   ordering of kpoints into stars partly finished:
     235             : c
     236             : c          there are nkstar different k-stars of order iostar(ik);
     237             : c          the k-points belonging to the star are assigned to the
     238             : c          index-field ikpn(is,ik)
     239             : c          for the stars which lie inside the BZ a representative
     240             : c          vektor vkrep out of the irrBZ has been assigned.
     241             : c          We have to work on the points outside of the 1. BZ
     242             : c
     243          25 :       if (ktest.ge.2) then
     244             : c
     245             : c --->   printout of ordered k-points
     246             : c
     247           0 :         write(iofile,'(/,1x,i4,10x,''nkstar: number of stars'')') nkstar
     248           0 :       do 140 ik = 1,nkstar
     249             :         write(iofile,'(1x,i4,1x,i4,43x,
     250             :      +  ''ik, iostar(kpn): index and order of k-star'')')
     251           0 :      +       ik, iostar(ik)
     252           0 :         write(iofile,'(1x,''k-points in star:'')')
     253           0 :        do 150 is = 1,iostar(ik)
     254             :         write(iofile,'(1x,i4,3(1x,f10.7),1x,i4,10x,
     255             :      +         ''ikpn, vkxyz(kpn),is: kpoint and index in star'',/)')
     256           0 :      +          ikpn(is,ik), (vkxyz(i1,ikpn(is,ik)),i1=1,3), is
     257           0 :  150   continue
     258             : c
     259             : c       printout of representative vector vkrep of star
     260             : c
     261           0 :           if (nkrep(ik) .lt. 1)
     262             :      +      write(iofile,'(1x,''WARNING: we have found no '',
     263           0 :      +          ''k-point of star no '',i4, ''  inside irr BZ'')') ik
     264           0 :           if (nkrep(ik) .gt. 1)
     265             :      +      write(iofile,'(1x,''WARNING: we have found more than '',
     266           0 :      +      ''one k-point of star no '',i4, ''  inside irr BZ'')') ik
     267             :             write(iofile,'(1x,i4,3(1x,f10.7),1x,i4,10x,
     268             :      +         ''nkstar,vkrep(kpn),nkrep: repr k-point in irr BZ'',/)')
     269           0 :      +            ik,(vkrep(i1,ik),i1=1,3),nkrep(ik)
     270             : c
     271           0 :  140  continue
     272             : c
     273             :       end if
     274             : c
     275             : c --->   for those stars whose representative point in irrBZ have
     276             : c        not been found (nrep(ik)=0)
     277             : c        find representative point by shifting the first vector in star
     278             : c        by multiples of reciprocal latice vectors
     279             : c
     280         467 :       do 151 ik = 1,nkstar
     281         442 :           if (nkrep(ik) .eq. 0) then
     282             : c
     283         138 :            if (ktest.ge.2) then
     284             :              write(iofile,'(1x,i4,1x,i4,43x,
     285             :      +                ''ik, iostar(ik): index and order of k-star'')')
     286           0 :      +                                                    ik, iostar(ik)
     287             :            end if
     288             : c
     289         466 :       do 152 i3 = 1,7
     290        2662 :         do 153 i2 = 1,7
     291       17950 :           do 154 i1 = 1,7
     292             :                 if (isi(i1).ne.0 .or. isi(i2).ne.0
     293        8454 :      +                           .or. isi(i3).ne.0) then
     294             :                   vktra(1) = vkxyz(1,ikpn(1,ik)) + rltv(1,1)*isi(i1)
     295             :      +                                           + rltv(1,2)*isi(i2)
     296        8316 :      +                                           + rltv(1,3)*isi(i3)
     297             :                   vktra(2) = vkxyz(2,ikpn(1,ik)) + rltv(2,1)*isi(i1)
     298             :      +                                           + rltv(2,2)*isi(i2)
     299        8316 :      +                                           + rltv(2,3)*isi(i3)
     300             :                   vktra(3) = vkxyz(3,ikpn(1,ik)) + rltv(3,1)*isi(i1)
     301             :      +                                           + rltv(3,2)*isi(i2)
     302        8316 :      +                                           + rltv(3,3)*isi(i3)
     303             : c
     304             : c --->   create star of vktra
     305             : c
     306      402203 :          do 155 isym = 1,nsym
     307             :                vktes(1) = ccr(1,1,isym)*vktra(1)
     308             :      +                    + ccr(1,2,isym)*vktra(2)
     309      394025 :      +                      + ccr(1,3,isym)*vktra(3)
     310             :                vktes(2) = ccr(2,1,isym)*vktra(1)
     311             :      +                    + ccr(2,2,isym)*vktra(2)
     312      394025 :      +                      + ccr(2,3,isym)*vktra(3)
     313             :                vktes(3) = ccr(3,1,isym)*vktra(1)
     314             :      +                    + ccr(3,2,isym)*vktra(2)
     315      394025 :      +                      + ccr(3,3,isym)*vktra(3)
     316      394025 :               if (ktest.ge.4) then
     317             :                    write(iofile,'(1x,i4,1x,3(f10.7,1x),10x,''vktes'')')
     318           0 :      +                                           isym,(vktes(ii),ii=1,3)
     319             :               end if
     320             : c
     321             : c
     322             : c --->   check if vkrep of any other star coincides with vktes{vktra}
     323             : c              if so, assign new values to counters and pointers
     324             : c
     325   103949244 :          do 156 iik = 1,nkstar
     326   103555339 :             if (nkrep(iik) .ne. 0) then
     327             :                if(abs(vktes(1)-vkrep(1,iik)).le.eps1
     328             :      +              .and. abs(vktes(2)-vkrep(2,iik)).le.eps1
     329    60644524 :      +                .and. abs(vktes(3)-vkrep(3,iik)).le.eps1) then
     330             : c
     331             : c --->   -  assign k-point indices of star ik to star iik
     332             : c           and change counter
     333             : c
     334        1464 :                     do 157 idir = 1,iostar(ik)
     335        1344 :                      ikpn(iostar(iik)+idir,iik) = ikpn(idir,ik)
     336         120 :  157                continue
     337         120 :                      iostar(iik)= iostar(iik) + iostar(ik)
     338             : c
     339         120 :            if (ktest.ge.2) then
     340             :              write(iofile,'(1x,i4,1x,i4,43x,
     341             :      +              ''iik, iostar(iik): index and order of k-star'')')
     342           0 :      +                                                  iik, iostar(iik)
     343             :            end if
     344             : c
     345             :                 go to 151
     346             :                end if
     347             :             end if
     348             : c
     349      393905 :  156     continue
     350             : c
     351             : c --->   check, if vktes is in irrBZ
     352             : c               then vktes is representative k-point and
     353             : c                    current star remains a distinct star
     354             : c
     355             :             CALL kprep(
     356             :      >                 iofile,iokpt,kpri,ktest,
     357             :      >                 nface,fnorm,fdist,iside,
     358             :      >                 vktes,ik,mkpt,mface,mdir,
     359      393905 :      =                 nkrep(ik),vkrep(1,ik))
     360             : c
     361      393905 :                   if (nkrep(ik) .gt. 0) go to 151
     362             : c
     363        8178 :  155     continue
     364             : c
     365             :                 end if
     366        1180 :  154      continue
     367         164 :  153    continue
     368           0 :  152  continue
     369             :           end if
     370          25 :  151  continue
     371             : c
     372             : c --->   -  reshuffle numbering of stars with nkrep > 0
     373             : c
     374          25 :                      nstnew = 0
     375          25 :                      isumkpt = 0
     376         467 :          do 158 iiik = 1,nkstar
     377         442 :               if (nkrep(iiik) .ne. 0) then
     378         322 :                      nstnew = nstnew + 1
     379         322 :                      isumkpt = isumkpt + iostar(iiik)
     380             : c
     381        6358 :                    do 159 i1 = 1,iostar(iiik)
     382        6036 :                      ikpn(i1,nstnew) = ikpn(i1,iiik)
     383         322 :  159               continue
     384         322 :                      iostar(nstnew)= iostar(iiik)
     385         322 :                      nkrep(nstnew) = nkrep(iiik)
     386         322 :                      vkrep(1,nstnew) = vkrep(1,iiik)
     387         322 :                      vkrep(2,nstnew) = vkrep(2,iiik)
     388         322 :                      vkrep(3,nstnew) = vkrep(3,iiik)
     389             :               end if
     390          25 :  158     continue
     391             : c
     392          25 :            if (ktest.ge.2) then
     393           0 :              write(iofile,'(/,'' result of ordering :'')')
     394             :              write(iofile,'(1x,i4,1x,i4,2x,
     395             :      +              ''no of stars, no of k-points contained in them'')')
     396           0 :      +                                                   nstnew, isumkpt
     397             :            end if
     398             : c
     399             : c --->   reduce number of stars
     400             : c
     401          25 :                 nkstar = nstnew
     402             : c
     403             : c --->   final step:
     404             : c        check, if all representative vectors are distinct;
     405             : c        (sometimes in the previous step a different, but aquivalent vkrep
     406             : c        has been assigned) whose equivalence is found by translation 
     407             : c        and rotation the representative vectors vkrep
     408             : c
     409         347 :       do 1151 ik = nkstar,1,-1
     410             : ctest     if (nkrep(ik) .eq. 0) then
     411             : c
     412         322 :            if (ktest.ge.2) then
     413             :              write(iofile,'(1x,i4,1x,i4,43x,
     414             :      +                ''ik, iostar(ik): index and order of k-star'')')
     415           0 :      +                                                    ik, iostar(ik)
     416             :            end if
     417             : c
     418        2254 :       do 1152 i3 = 1,3
     419        6762 :         do 1153 i2 = 1,3
     420       20286 :           do 1154 i1 = 1,3
     421             :                 if (isi(i1).ne.0 .or. isi(i2).ne.0
     422        8694 :      +                           .or. isi(i3).ne.0) then
     423             :                   vktra(1) = vkrep(1,ik) + rltv(1,1)*isi(i1)
     424             :      +                                           + rltv(1,2)*isi(i2)
     425        8372 :      +                                           + rltv(1,3)*isi(i3)
     426             :                   vktra(2) = vkrep(2,ik) + rltv(2,1)*isi(i1)
     427             :      +                                           + rltv(2,2)*isi(i2)
     428        8372 :      +                                           + rltv(2,3)*isi(i3)
     429             :                   vktra(3) = vkrep(3,ik) + rltv(3,1)*isi(i1)
     430             :      +                                           + rltv(3,2)*isi(i2)
     431        8372 :      +                                           + rltv(3,3)*isi(i3)
     432             : c
     433             : c --->   create star of vktra
     434             : c
     435      319748 :          do 1155 isym = 1,nsym
     436             :                vktes(1) = ccr(1,1,isym)*vktra(1)
     437             :      +                    + ccr(1,2,isym)*vktra(2)
     438      311376 :      +                      + ccr(1,3,isym)*vktra(3)
     439             :                vktes(2) = ccr(2,1,isym)*vktra(1)
     440             :      +                    + ccr(2,2,isym)*vktra(2)
     441      311376 :      +                      + ccr(2,3,isym)*vktra(3)
     442             :                vktes(3) = ccr(3,1,isym)*vktra(1)
     443             :      +                    + ccr(3,2,isym)*vktra(2)
     444      311376 :      +                      + ccr(3,3,isym)*vktra(3)
     445      311376 :               if (ktest.ge.4) then
     446             :                    write(iofile,'(1x,i4,1x,3(f10.7,1x),10x,''vktes'')')
     447           0 :      +                                           isym,(vktes(ii),ii=1,3)
     448             :               end if
     449             : c
     450             : c
     451             : c --->   check if vkrep of any other star coincides with vktes{vktra}
     452             : c              if so, assign new values to counters and pointers
     453             : c
     454    38981280 :          do 1156 iik = 1,nkstar
     455    38669904 :             if (iik .lt. ik) then
     456             :                if(abs(vktes(1)-vkrep(1,iik)).le.eps1
     457             :      +              .and. abs(vktes(2)-vkrep(2,iik)).le.eps1
     458    19179264 :      +                .and. abs(vktes(3)-vkrep(3,iik)).le.eps1) then
     459             : c
     460             : c --->   -  assign k-point indices of star ik to star iik
     461             : c           and change counter
     462             : c
     463           0 :                     do 1157 idir = 1,iostar(ik)
     464           0 :                      ikpn(iostar(iik)+idir,iik) = ikpn(idir,ik)
     465           0 :  1157                continue
     466           0 :                      iostar(iik)= iostar(iik) + iostar(ik)
     467             : c
     468           0 :            if (ktest.ge.2) then
     469             :              write(iofile,'(1x,i4,1x,i4,43x,
     470             :      +              ''iik, iostar(iik): index and order of k-star'')')
     471           0 :      +                                                  iik, iostar(iik)
     472             :            end if
     473             : c
     474           0 :                 nkrep(ik) = 0
     475           0 :                 go to 1151
     476             :                end if
     477             :             end if
     478             : c
     479      311376 :  1156     continue
     480             : c
     481             : c --->   check, if vktes is in irrBZ
     482             : c               then vktes is representative k-point and
     483             : c                    current star remains a distinct star
     484             : c NOT NECESSARY ANYMORE
     485             : ctest            call  k p r e p
     486             : ctest     >                     (iofile,iokpt,kpri,ktest,
     487             : ctest     >                      nface,fnorm,fdist,iside,
     488             : ctest     >                      vktes,ik,
     489             : ctest     =                      nkrep(ik),vkrep(1,ik))
     490             : c
     491             : ctest                  if (nkrep(ik) .gt. 0) go to 1151
     492             : c
     493        8372 :  1155     continue
     494             : c
     495             :                 end if
     496        2898 :  1154      continue
     497         966 :  1153    continue
     498         322 :  1152  continue
     499             : ctest     end if
     500          25 :  1151  continue
     501             : c
     502             : c --->   -  reshuffle numbering of stars with nkrep > 0
     503             : c
     504          25 :                      nstnew = 0
     505          25 :                      isumkpt = 0
     506         347 :          do 1158 iiik = 1,nkstar
     507         322 :               if (nkrep(iiik) .ne. 0) then
     508         322 :                      nstnew = nstnew + 1
     509         322 :                      isumkpt = isumkpt + iostar(iiik)
     510             : c
     511        6358 :                    do 1159 i1 = 1,iostar(iiik)
     512        6036 :                      ikpn(i1,nstnew) = ikpn(i1,iiik)
     513         322 :  1159               continue
     514         322 :                      iostar(nstnew)= iostar(iiik)
     515         322 :                      nkrep(nstnew) = nkrep(iiik)
     516         322 :                      vkrep(1,nstnew) = vkrep(1,iiik)
     517         322 :                      vkrep(2,nstnew) = vkrep(2,iiik)
     518         322 :                      vkrep(3,nstnew) = vkrep(3,iiik)
     519             :               end if
     520          25 :  1158     continue
     521             : c
     522          25 :            if (ktest.ge.2) then
     523           0 :              write(iofile,'(/,'' result of ordering :'')')
     524             :              write(iofile,'(1x,i4,1x,i4,2x,
     525             :      +              ''no of stars, no of k-points contained in them'')')
     526           0 :      +                                                   nstnew, isumkpt
     527             :            end if
     528             : c
     529             : c --->   reduce number of stars
     530             : c
     531          25 :                 nkstar = nstnew
     532             : c
     533             : c --->   ordering of kpoints into stars totally finished:
     534             : c
     535             : c        - there are nkstar different k-stars of order iostar(ik);
     536             : c        - the k-points belonging to the star are assigned to the
     537             : c          index-field ikpn(is,ik)
     538             : c        - for every star a representative
     539             : c          vektor vkrep in the irrBZ has been assigned.
     540             : c
     541          25 :       if (ktest.ge.1) then
     542             : c
     543             : c    printout of ordered k-points
     544             : c
     545           0 :         write(iofile,'(/,1x,i4,10x,''nkstar: number of stars'')') nkstar
     546           0 :       do 1140 ik = 1,nkstar
     547             :         write(iofile,'(1x,i4,1x,i4,43x,
     548             :      +  ''ik, iostar(kpn): index and order of k-star'')')
     549           0 :      +       ik, iostar(ik)
     550           0 :         write(iofile,'(1x,''k-points in star:'')')
     551           0 :        do 1150 is = 1,iostar(ik)
     552             :         write(iofile,'(1x,i4,3(1x,f10.7),1x,i4,10x,
     553             :      +         ''ikpn, vkxyz(kpn),is: kpoint and index in star'',/)')
     554           0 :      +          ikpn(is,ik), (vkxyz(i1,ikpn(is,ik)),i1=1,3), is
     555           0 : 1150   continue
     556             : c
     557             : c --->  printout of representative vector vkrep of star
     558             : c
     559           0 :           if (nkrep(ik) .lt. 1)
     560             :      +      write(iofile,'(1x,''WARNING: we have found no '',
     561             :      +          ''k-point of star no '',i4, ''  inside irr BZ; '',
     562           0 :      +          ''vkrep set to zero'')') ik
     563           0 :           if (nkrep(ik) .gt. 1)
     564             :      +      write(iofile,'(1x,''WARNING: we have found more than '',
     565             :      +      ''one k-point of star no '',i4, ''  inside irr BZ; '',
     566           0 :      +      ''last vkrep shown'')') ik
     567             :             write(iofile,'(1x,i4,3(1x,f10.7),1x,i4,10x,
     568             :      +           ''nkstar,vkrep(kpn),nkrep: repr k-point in irr BZ'')')
     569           0 :      +            ik,(vkrep(i1,ik),i1=1,3),nkrep(ik)
     570             : c
     571           0 : 1140  continue
     572             : c
     573             :       end if
     574             : c
     575             : c --->   the index of every kpoint is contained in one of the stars.
     576             : c
     577             : c           check for ''left over'' k-points
     578             : c
     579          25 :       nleft = 0
     580             :       write(iofile,'(1x,''the following kpoints are not included'',
     581          25 :      + '' in any star'')')
     582        6061 :       do 160 kpn = 1,nkpt
     583      393123 :         do 165 ik = 1,nkstar
     584    12615194 :           do 166 is = 1,iostar(ik)
     585    12228107 :             if (kpn .eq. ikpn(is,ik)) go to 160
     586      387087 :  166      continue
     587           0 :  165    continue
     588             :             write(iofile,'(1x,i4,3(1x,f10.7),15x,
     589             :      +                       ''kpn, vkxyz(kpn): kpoint '')')
     590           0 :      +                         kpn, (vkxyz(i1,kpn),i1=1,3)
     591        6036 :              nleft = nleft+1
     592          25 :  160  continue
     593          25 :          if(nleft.eq.0) then
     594             :              write(iofile,'(/,1x,i4,20x,
     595          25 :      +                      ''no leftover points found'',/)')  nleft
     596             : c
     597             :          else
     598             :              write(iofile,'(/,1x,i4,20x,''WARNING: '',
     599           0 :      +      ''number of leftover points not equal zero'',/)')  nleft
     600             : !          CALL juDFT_error("leftover points",calledby="ordstar")
     601             :          end if
     602             : c
     603          25 :       CLOSE (iofile)
     604             :       
     605             : !
     606             : !-> check for bz-boundaries
     607             : !
     608         347 :       DO ik = 1, nkstar
     609             : !        write(*,'(a5,i3,a5,3f10.5)') 'star ',ik,' rep:',vkrep(:,ik)
     610         322 :         iosub = 0
     611        6358 :         members: DO is = 1, iostar(ik)
     612        6036 :          vk_bzb(:) = vkxyz(:,ikpn(is,ik))
     613             : 
     614       66718 :          DO ix = -2,2
     615      338016 :          DO iy = -2,2
     616     1690080 :          DO iz = -2,2
     617    12444775 :          DO is1 = is+1, iostar(ik)
     618             :          vk_bzb(:) = vkxyz(:,ikpn(is,ik)) + 
     619    11539375 :      +              ix * rltv(:,1) + iy * rltv(:,2) + iz * rltv(:,3)
     620    11539375 :          vk_bzb(:) = vk_bzb(:) - vkxyz(:,ikpn(is1,ik))  ! vkrep(:,ik)
     621    46157500 :          t_len = DOT_PRODUCT( vk_bzb, vk_bzb )
     622    12293875 :          IF (ABS(t_len) < 0.00001 ) THEN
     623           0 :            iosub = iosub + 1
     624           0 :            CYCLE members
     625             :          ENDIF
     626             :          ENDDO
     627             :          ENDDO
     628             :          ENDDO
     629             :          ENDDO
     630             : 
     631             :         ENDDO members
     632             : !        WRITE (*,*) 'iosub =',iosub
     633         347 :         iostar(ik) = iostar(ik)-iosub
     634             :       ENDDO
     635             : 
     636          25 :       RETURN
     637             :       END SUBROUTINE  ordstar
     638             :       END MODULE m_ordstar

Generated by: LCOV version 1.13