LCOV - code coverage report
Current view: top level - init - strgn_dim.F (source / functions) Hit Total Coverage
Test: combined.info Lines: 106 128 82.8 %
Date: 2019-09-08 04:53:50 Functions: 2 2 100.0 %

          Line data    Source code
       1             :       MODULE m_strgndim
       2             :       use m_juDFT
       3             :       CONTAINS
       4          18 :       SUBROUTINE strgn1_dim(
       5          18 :      >                  gmax,bmat,invs,zrfs,mrot,tau,nop,nop2,
       6             :      <                  k1d,k2d,k3d,n3d,n2d,odd)
       7             : c
       8             : c     *********************************************************
       9             : c     generate two- and three-dimensional stars
      10             : c     for slab geometry
      11             : c     e. wimmer   nov.1984    c.l.fu  1987
      12             : c     *********************************************************
      13             :       USE m_boxdim
      14             :       USE m_spgrot
      15             :       USE m_types, ONLY : od_dim
      16             :       USE m_ifft, ONLY : i2357
      17             :       IMPLICIT NONE
      18             : 
      19             :       INTEGER, INTENT (IN)  :: nop,nop2
      20             :       REAL,    INTENT (IN)  :: gmax
      21             :       INTEGER, INTENT (OUT) :: k1d,k2d,k3d,n3d,n2d
      22             : 
      23             :       INTEGER, INTENT (IN) :: mrot(3,3,nop)
      24             :       REAL,    INTENT (IN) :: tau(3,nop),bmat(3,3)
      25             :       LOGICAL, INTENT (IN) :: invs,zrfs
      26             : c
      27             :       INTEGER mx1,mx2,mx3
      28             :       INTEGER m
      29             :       INTEGER ng2,ng3,n,j,k,k1,k2,k3,m0,mxx1,mxx2
      30             :       REAL    arltv1,arltv2,arltv3,s
      31          36 :       INTEGER kv(3),kr(3,nop),inv_du(nop)
      32             :       REAL    g(3)
      33          18 :       INTEGER , ALLOCATABLE :: kv2(:,:)
      34             : c-odim
      35             :       TYPE (od_dim), INTENT (INOUT) :: odd
      36             : c+odim
      37             :       INTRINSIC int
      38             : 
      39             : C---> Determine Gmax box of size mx1, mx2, mx3,
      40             : c     for which |G(mx1,mx2,mx3)| < Gmax
      41             : c     arltv(i) length of reciprical lattice vector along direction (i)
      42             : C
      43          18 :       CALL boxdim(bmat,arltv1,arltv2,arltv3)
      44             : 
      45          18 :       mx1 = int(gmax/arltv1) + 1
      46          18 :       mx2 = int(gmax/arltv2) + 1
      47          18 :       mx3 = int(gmax/arltv3) + 1
      48          18 :       ALLOCATE ( kv2(2,(2*mx1+1)*(2*mx2+1)) )
      49         448 :       DO n=1,nop
      50         233 :          inv_du(n) = n ! dummy array for spgrot
      51             :       ENDDO
      52             : c
      53             : c     two-dimensional stars
      54             : c
      55          18 :       mxx1 = 0
      56          18 :       mxx2 = 0
      57          18 :       ng2 = 0
      58          18 :       kv(3) = 0
      59         494 :       DO 40 k1 = mx1,-mx1,-1
      60         476 :          kv(1) = k1
      61       13742 :          DO 30 k2 = mx2,-mx2,-1
      62       13266 :             kv(2) = k2
      63       39798 :             DO j = 1,2
      64       39798 :                g(j) = kv(1)*bmat(1,j) + kv(2)*bmat(2,j)
      65             :             END DO
      66       13266 :             s = sqrt(g(1)**2+g(2)**2)
      67             : c
      68             : c--->   stars should be within the g_max-sphere !   (Oct.97) sbluegel
      69       13266 :             IF (s.LE.gmax) THEN
      70             : c
      71             :                CALL spgrot(nop,.true.,mrot,tau,inv_du,
      72             :      >                     kv,
      73        8430 :      <                     kr)
      74       52590 :                DO n = 1,nop2
      75       44160 :                   IF (mxx1.lt.kr(1,n)) mxx1 = kr(1,n)
      76       52590 :                   IF (mxx2.lt.kr(2,n)) mxx2 = kr(2,n)
      77             :                ENDDO
      78     4147062 :                DO k = 1,ng2 
      79     8379490 :                   DO n = 1,nop2
      80     3155558 :                      IF (kr(1,n).EQ.kv2(1,k) .AND.
      81     2069316 :      +                   kr(2,n).EQ.kv2(2,k)) GOTO 30
      82             :                   ENDDO
      83             :                ENDDO
      84             : c--->    new representative found
      85        3744 :                ng2 = ng2 + 1
      86             : c               IF (ng2.GT.n2dd)  CALL juDFT_error("n2dd",calledby="strgn_dim")
      87       11232 :                DO j = 1,2
      88       11232 :                   kv2(j,ng2) = kv(j)
      89             :                END DO
      90             :             END IF
      91         476 :    30    CONTINUE
      92          18 :    40 CONTINUE
      93             : c
      94          18 :       n2d = ng2
      95             : #ifdef CPP_AIX
      96             :       k1d = i2357(mxx1)
      97             :       k2d = i2357(mxx2)
      98             :       k3d = i2357(mx3)
      99             : #else
     100          18 :       k1d = mxx1
     101          18 :       k2d = mxx2
     102          18 :       k3d = mx3
     103             : #endif
     104          18 :       IF (odd%d1) THEN
     105           0 :         k1d = max(k1d,mx1)
     106           0 :         k2d = max(k2d,mx2)
     107             :       ENDIF
     108             : c
     109             : c     three dimensional stars
     110          18 :       ng3 = 0
     111          18 :       m0 = -mx3
     112          18 :       IF (zrfs .OR. invs) m0 = 0
     113          18 :       IF (odd%d1 .and. odd%zrfs) m0 = 0
     114        3762 :       DO k2 = 1,ng2
     115      276930 :          DO k3 = m0,mx3
     116      956088 :             DO j = 1,3
     117             :                g(j) = kv2(1,k2)*bmat(1,j) + kv2(2,k2)*bmat(2,j) +
     118      546336 :      +                k3*bmat(3,j)
     119             :             END DO
     120      136584 :             s = sqrt(g(1)**2+g(2)**2+g(3)**2)
     121      140328 :             IF (s.LE.gmax) THEN
     122       87717 :                ng3 = ng3 + 1
     123             :             END IF
     124             :          END DO
     125             :       END DO
     126          18 :       n3d = ng3
     127             : c-odim    modifications due to one-dimensionality, YM
     128          18 :       IF (odd%d1) THEN
     129           0 :          j = 0
     130           0 :          m0 = k3d
     131           0 :          IF (odd%chi.NE.1 .AND. (odd%invs .OR. odd%zrfs))
     132             :      &        CALL juDFT_error
     133             :      +        ("chiral symmetries are not consistent with invs or zrfs"
     134           0 :      +        ,calledby ="strgn_dim")
     135           0 :          IF (odd%zrfs) m0 = 0
     136           0 :          IF (odd%chi.EQ.1) THEN
     137           0 :             odd%nop = odd%rot
     138           0 :             IF (odd%invs .OR. odd%zrfs) odd%nop = odd%nop*2
     139           0 :             DO k3 = -m0,k3d
     140           0 :                DO m = -odd%M,odd%M
     141           0 :                   IF (MOD(m,odd%rot).EQ.0) THEN
     142           0 :                      j = j+1
     143             :                   END IF
     144             :                END DO
     145             :             END DO
     146             :          ELSEIF (odd%chi.NE.1) THEN
     147           0 :             odd%nop = odd%chi
     148           0 :             DO k3 = -m0,k3d
     149           0 :                DO m = -odd%M,odd%M
     150           0 :                   IF (MOD(m+(odd%rot)*k3,odd%chi).EQ.0) THEN
     151           0 :                      j = j+1
     152             :                   END IF
     153             :                END DO
     154             :             END DO
     155             :          END IF
     156           0 :          odd%n2d = j
     157           0 :          odd%nq2 = j
     158           0 :          odd%kimax2 = odd%n2d - 1
     159             :       ELSE
     160          18 :          odd%n2d = ng2
     161          18 :          odd%nq2 = ng2
     162          18 :          odd%nop = nop
     163             :       END IF
     164             : c+odim
     165             : c     listing
     166          18 :       WRITE (6,8000) gmax,n3d,n2d,k1d,k2d,k3d
     167             :  8000 FORMAT (' gmax=',f10.6/' n3d=  ',i10/' n2d=  ',i5/' k1d=  ',
     168             :      +       i5/' k2d=  ',i5/' k3d=  ',i5/)
     169             : 
     170          18 :       DEALLOCATE (kv2)
     171          18 :       END SUBROUTINE strgn1_dim
     172             : !---------------------------------------------------------------------
     173          20 :       SUBROUTINE strgn2_dim(
     174          20 :      >                  gmax,bmat,invs,zrfs,mrot,tau,nop,
     175             :      <                  k1d,k2d,k3d,n3d,n2d)
     176             : c
     177             : c     *********************************************************
     178             : c     generate three-dimensional stars for bulk
     179             : c     based on  e. wimmer   nov.1984    c.l.fu  1987
     180             : c     *********************************************************
     181             :       USE m_boxdim
     182             :       USE m_spgrot
     183             :       USE m_ifft, ONLY : i2357
     184             :       IMPLICIT NONE
     185             : 
     186             :       INTEGER, INTENT (IN)  :: nop
     187             :       REAL,    INTENT (IN)  :: gmax
     188             :       INTEGER, INTENT (OUT) :: k1d,k2d,k3d,n3d,n2d
     189             : 
     190             :       INTEGER, INTENT (IN) :: mrot(3,3,nop)
     191             :       REAL,    INTENT (IN) :: tau(3,nop),bmat(3,3)
     192             :       LOGICAL, INTENT (IN) :: invs,zrfs
     193             : c
     194             :       INTEGER mx1,mx2,mx3,ng3,n,j,k,k1,k2,k3,mxx1,mxx2,mxx3
     195             :       REAL arltv1,arltv2,arltv3,s,gmax2
     196          40 :       INTEGER kr(3,nop),kv(3),inv_du(nop)
     197             : 
     198             :       REAL    g(3)
     199          40 :       INTEGER , ALLOCATABLE :: kv3(:,:),ig(:,:,:)
     200             : 
     201             :       INTRINSIC int
     202             : 
     203             : C---> Determine Gmax box of size mx1, mx2, mx3,
     204             : c     for which |G(mx1,mx2,mx3)| < Gmax
     205             : c     arltv(i) length of reciprical lattice vector along direction (i)
     206             : C
     207          20 :       CALL boxdim(bmat,arltv1,arltv2,arltv3)
     208             : 
     209          20 :       mx1 = int(gmax/arltv1) + 1
     210          20 :       mx2 = int(gmax/arltv2) + 1
     211          20 :       mx3 = int(gmax/arltv3) + 1
     212          20 :       ALLOCATE ( kv3(3,(2*mx1+1)*(2*mx2+1)*(2*mx3+1)) )
     213          20 :       ALLOCATE ( ig(-mx1:mx1,-mx2:mx2,-mx3:mx3) )
     214         514 :       DO n=1,nop
     215         267 :          inv_du(n) = n ! dummy array for spgrot
     216             :       ENDDO
     217             : c
     218             : c     three dimensional stars
     219             : c
     220          20 :       mxx1 = 0
     221          20 :       mxx2 = 0
     222          20 :       mxx3 = 0
     223          20 :       ng3 = 0
     224          20 :       gmax2 = gmax * gmax
     225         632 :       ig = 0
     226         928 :       x_dim: DO k1 = mx1,-mx1,-1
     227         454 :         kv(1) = k1
     228       11526 :         y_dim: DO k2 = mx2,-mx2,-1
     229       11052 :           kv(2) = k2
     230      360910 :           z_dim: DO k3 = mx3,-mx3,-1
     231      349404 :             IF ( ig(k1,k2,k3) .NE. 0 ) CYCLE z_dim
     232      235528 :             kv(3) = k3
     233             : 
     234      942112 :             DO j = 1,3
     235             :                g(j) = kv(1)*bmat(1,j) + kv(2)*bmat(2,j) +
     236      942112 :      +                kv(3)*bmat(3,j)
     237             :             END DO
     238      235528 :             s = g(1)**2 + g(2)**2 + g(3)**2
     239             : c
     240             : c--->   stars should be within the g_max-sphere !   (Oct.97) sbluegel
     241      246580 :             IF (s.LE.gmax2) THEN
     242             : c--->    new representative found
     243             : c
     244             :                CALL spgrot(nop,.true.,mrot,tau,inv_du,
     245             :      >                     kv,
     246       19148 :      <                     kr)
     247       19148 :                ng3 = ng3 + 1
     248       76592 :                DO j = 1,3
     249       19148 :                   kv3(j,ng3) = kv(j)
     250             :                END DO
     251      351678 :                DO n = 1,nop
     252      166265 :                   IF (mxx1.lt.kr(1,n)) mxx1 = kr(1,n)
     253      166265 :                   IF (mxx2.lt.kr(2,n)) mxx2 = kr(2,n)
     254      166265 :                   IF (mxx3.lt.kr(3,n)) mxx3 = kr(3,n)
     255      185413 :                   ig(kr(1,n),kr(2,n),kr(3,n)) = ng3
     256             :                ENDDO
     257             :             END IF
     258             :           ENDDO z_dim
     259             :         ENDDO y_dim
     260             :       ENDDO x_dim
     261             : c
     262          20 :       n2d = 2
     263          20 :       n3d = ng3
     264             : #ifdef CPP_AIX
     265             :       k1d = i2357(mxx1)
     266             :       k2d = i2357(mxx2)
     267             :       k3d = i2357(mxx3)
     268             :       !write(*,*) k1d,mxx1
     269             : #else
     270          20 :       k1d = mxx1
     271          20 :       k2d = mxx2
     272          20 :       k3d = mxx3
     273             : #endif
     274             : c
     275             : c     listing
     276          20 :       WRITE (6,8000) gmax,n3d,n2d,k1d,k2d,k3d
     277             :  8000 FORMAT (' gmax=',f10.6/' n3d=  ',i7/' n2d=  ',i7/' k1d=  ',
     278             :      +       i7/' k2d=  ',i7/' k3d=  ',i7/)
     279             : 
     280          20 :       DEALLOCATE (kv3,ig)
     281          20 :       END SUBROUTINE strgn2_dim
     282             :       END MODULE m_strgndim

Generated by: LCOV version 1.13