C SUBROUTINE SSSLAT ====*====3====*====4====*====5====*====6====*====7 C LATTICE VECTORS OF LATOM ARE GENERATED IN LATOM(3,) C ALM() HAS A LENGTH OF WAVE VECTOR IN A UNIT C MP() HAS A NUMBER WHICH INDICATES CHANGE POINT C OF SYMMETRIZED VECTORS IN THE TABLE OF LATOM(,) C NLAT :NUMBER OF LATTICE VECTOR IN LATOM(3,) C NSHEL :NUMBER OF SHELL C ICD :COMMON DENOMINATOR C C by A.YANASE 2006/12/XX C C---*----1----*----2----*----3----*----4----*----5----*----6----*----7 C SUBROUTINE SSSLAT C IMPLICIT REAL*8(A-H,O-Z) C INCLUDE 'prmfit.f' C PARAMETER(MAXLP=19894) COMMON/LATVC/LATOM(3,MAXLP),ALM(MAXLP),MP(MAXLP),NLAT,NSHEL,ICD COMMON/LAT/AA,B,C,CA,CB,CC,A1,B1,C1 COMMON/SPG1/IT(3,48),IM(48,48),IV(48) COMMON/SPG2/IL,NG,IG(48),JV(2,3,48) COMMON/SCL/NATOM,NKAT,IPR,ISO,E0,DE,NNEE,NELEC,ENEND,AM SAVE /LATVC/,/LAT/,/SPG2/ INTEGER IBAS(3,3),IFLA(MAXLP),ML(MAXLP),LATF(3),LATT(3) REAL*8 V(3),DC(3),BASL(3) IF(IL.EQ.-1) THEN IBAS(1,1)=2 IBAS(2,1)=1 IBAS(3,1)=1 IBAS(1,2)=-1 IBAS(2,2)=1 IBAS(3,2)=1 IBAS(1,3)=-1 IBAS(2,3)=-2 IBAS(3,3)=1 ICD=3 ELSE IF(IL.EQ.0.OR.IL.EQ.1) THEN IBAS(1,1)=1 IBAS(2,1)=0 IBAS(3,1)=0 IBAS(1,2)=0 IBAS(2,2)=1 IBAS(3,2)=0 IBAS(1,3)=0 IBAS(2,3)=0 IBAS(3,3)=1 ICD=1 ELSE IF(IL.EQ.2) THEN IBAS(1,1)=0 IBAS(2,1)=1 IBAS(3,1)=1 IBAS(1,2)=1 IBAS(2,2)=0 IBAS(3,2)=1 IBAS(1,3)=1 IBAS(2,3)=1 IBAS(3,3)=0 ICD=2 ELSE IF(IL.EQ.3) THEN IBAS(1,1)=-1 IBAS(2,1)=1 IBAS(3,1)=1 IBAS(1,2)=1 IBAS(2,2)=-1 IBAS(3,2)=1 IBAS(1,3)=1 IBAS(2,3)=1 IBAS(3,3)=-1 ICD=2 ELSE IF(IL.EQ.4) THEN IBAS(1,1)=1 IBAS(2,1)=1 IBAS(3,1)=0 IBAS(1,2)=1 IBAS(2,2)=-1 IBAS(3,2)=0 IBAS(1,3)=0 IBAS(2,3)=0 IBAS(3,3)=2 ICD=2 END IF DO 1 I=1,3 DO 2 J=1,3 V(J)=IBAS(J,I) V(J)=V(J)/ICD 2 CONTINUE CALL ZZZY43(V,DC,S) BASL(I)=S 1 CONTINUE KXM=AM/BASL(1)*5+1 KYM=AM/BASL(2)*5+1 KZM=AM/BASL(3)*5+1 IF(IPR.GE.3) WRITE(6,*) ' IN SSSLAT KXM=',KXM NLAT=1 LATOM(1,1)=0 LATOM(2,1)=0 LATOM(3,1)=0 ALM(1)=0.0D0 DO 41 IX=1,KXM IF(IPR.GE.3) WRITE(6,*) ' IX=',IX,' NLAT=',NLAT KX=IX-1 DO 42 I1=1,2 DO 43 IY=1,KYM KY=IY-1 DO 44 I2=1,2 DO 45 IZ=1,KZM IF(IX*IY*IZ.EQ.1) GO TO 45 KZ=IZ-1 DO 46 I3=1,2 L1=KX*IBAS(1,1)+KY*IBAS(1,2)+KZ*IBAS(1,3) V(1)=L1 V(1)=V(1)/ICD L2=KX*IBAS(2,1)+KY*IBAS(2,2)+KZ*IBAS(2,3) V(2)=L2 V(2)=V(2)/ICD L3=KX*IBAS(3,1)+KY*IBAS(3,2)+KZ*IBAS(3,3) IF(KX.NE.0) GO TO 63 DO 61 JJ=1,NLAT IF((L1.EQ.-LATOM(1,JJ)).AND.(L2.EQ.-LATOM(2,JJ)) & .AND.(L3.EQ.-LATOM(3,JJ))) GO TO 47 61 CONTINUE 63 CONTINUE V(3)=L3 V(3)=V(3)/ICD CALL ZZZY43(V,DC,W) IF(W.GT.AM) GO TO 47 DO 48 JK=1,NLAT JJK=NLAT-JK+1 IF(ALM(JJK).LT.W) GO TO 49 DO 50 I=1,3 50 LATOM(I,JJK+1)=LATOM(I,JJK) ALM(JJK+1)=ALM(JJK) 48 CONTINUE JJK=0 49 LATOM(1,JJK+1)=L1 LATOM(2,JJK+1)=L2 LATOM(3,JJK+1)=L3 ALM(JJK+1)=W NLAT=NLAT+1 IF(NLAT.GT.MAXLP) GO TO 53 47 IF(KZ.EQ.0) GO TO 45 KZ=-KZ 46 CONTINUE 45 CONTINUE IF(KY.EQ.0) GO TO 43 KY=-KY 44 CONTINUE 43 CONTINUE GO TO 41 C KX=-KX 42 CONTINUE 41 CONTINUE DO 71 II=2,NLAT IFLA(II)=0 71 CONTINUE IE=1 IFLA(1)=1 W=ALM(1) DO 52 II=2,NLAT IF(ABS(ALM(II)-W).LT.1.0D-8) GO TO 52 ML(IE)=II-1 IE=IE+1 W=ALM(II) 52 CONTINUE MSHEL=IE ML(IE)=NLAT IP=1 MP(1)=1 write(6,*) ' MSHEL=',MSHEL,' NLAT=',NLAT DO 81 IE=2,MSHEL ISTA=ML(IE-1)+1 IEND=ML(IE) C IF(IPR.GE.3) WRITE(6,*) ' IE=',IE,ISTA,IEND,IP DO 72 JFLA=1,50 IF(JFLA.EQ.1) THEN ISAR=ISTA ELSE DO 73 I1=ISTA,IEND IF(IFLA(I1).EQ.0) GO TO 74 73 CONTINUE GO TO 72 74 ISAR=I1 END IF LATF(1)=LATOM(1,ISAR) LATF(2)=LATOM(2,ISAR) LATF(3)=LATOM(3,ISAR) IFLA(ISAR)=JFLA C IF(JFLA.GT.21) write(6,*) ' IE=',IE,' JFLA=',JFLA DO 22 I1=2,NG DO 23 K=1,3 IF(IABS(IT(K,IG(I1))).EQ.4) THEN LATT(K)=LATF(1)-LATF(2) IF(IT(K,IG(I1)).LT.0) LATT(K)=-LATT(K) ELSE M=IABS(IT(K,IG(I1))) LATT(K)=LATF(M) IF(IT(K,IG(I1)).LT.0) LATT(K)=-LATT(K) ENDIF 23 CONTINUE DO 26 ID=1,2 DO 24 I2=ISAR,IEND IF(IFLA(I2).NE.0.AND.IFLA(I2).LT.JFLA) GO TO 24 DO 25 K=1,3 IF(LATT(K).NE.LATOM(K,I2)) GO TO 24 25 CONTINUE IF(IFLA(I2).EQ.0) IFLA(I2)=JFLA GO TO 22 24 CONTINUE LATT(1)=-LATT(1) LATT(2)=-LATT(2) LATT(3)=-LATT(3) 26 CONTINUE WRITE(6,*) IE,I1,ISTA,IEND,ISAR,LATF,LATT,' STOP AT 26' STOP 22 CONTINUE 72 CONTINUE DO 78 JFLA=1,50 NFLA=0 ISTAT=MP(IP)+1 IF(ISTAT.GT.IEND) GO TO 78 DO 75 I1=ISTAT,IEND IF(IFLA(I1).NE.JFLA.AND.I1.LT.IEND) THEN DO 76 I2=I1+1,IEND IF(IFLA(I2).EQ.JFLA) THEN DO 77 K=1,3 IW=LATOM(K,I1) LATOM(K,I1)=LATOM(K,I2) LATOM(K,I2)=IW 77 CONTINUE IW=IFLA(I1) IFLA(I1)=IFLA(I2) IFLA(I2)=IW NFLA=NFLA+1 C write(6,*) I1,I2,JFLA,NFLA GO TO 75 END IF 76 CONTINUE ELSE IF(IFLA(I1).EQ.JFLA) THEN NFLA=NFLA+1 C write(6,*) JFLA,I1,NFLA END IF 75 CONTINUE IF(NFLA.NE.0) THEN IP=IP+1 MP(IP)=MP(IP-1)+NFLA END IF 78 CONTINUE 81 CONTINUE NSHEL=IP IP=1 IF(IPR.GE.4) THEN DO 51 II=1,NLAT WRITE(6,601) II,(LATOM(K,II),K=1,3),ICD,ALM(II),IFLA(II),'P' 601 FORMAT(I5,2H (,3I4,2H)/,I3,F10.5,I3,A1) IF(II.EQ.MP(IP)) THEN IF(IP.EQ.1) THEN WRITE(6,*) IP,II ELSE WRITE(6,*) IP,II-MP(IP-1),II END IF IP=IP+1 END IF 51 CONTINUE END IF WRITE(6,*) ' NSHEL=',NSHEL,' NLAT=',NLAT RETURN 53 WRITE(6,660) MAXLP,NSHEL 660 FORMAT(' STOP AT 53 IN SSSLAT AM IS TOO LARGE',2I7) STOP ' STOP IN SSSLAT ' END