C--------1---------2---------3---------4---------5---------6---------7---------8
C    Main for fitting of Bands energies and components
       CALL TSPPRP
	   WRITE(6,*) ' End of TSPPRP'
	   CALL FITPRM
	   WRITE(6,*) ' End of FITPRM'
	   CALL ENRRED
	   WRITE(6,*) ' End of ENRRED'
	   CALL SSSLAT
	   WRITE(6,*) ' End of SSSLAT'
 	   CALL FNNMAT
	   WRITE(6,*) ' End of FNNMAT'
	   CALL FUEINT
	   WRITE(6,*) ' End of FUEINT'
	   STOP
	   END
C--------1---------2---------3---------4---------5---------6---------7---------8
      SUBROUTINE TSPPRP
C***********************************************************************
C PREPERATION TO CALL TSPACE                                           *
C***********************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/SCL/NATOM,NKAT,IPR,ISO,E0,DE,NNEE,NELEC,ENEND
      DIMENSION JB(2,3)
      READ(1,*)
      READ(1,*) IL,NGEN,INV
      CALL TSPACE(IL)
      DO 1 I=1,NGEN
      READ(1,*) JA,((JB(J,K),J=1,2),K=1,3)
C	  write(6,*) JA,((JB(J,K),J=1,2),K=1,3)
      CALL TSGENR(JA,JB)
    1 CONTINUE
      CALL TSPGRP(INV)
      CALL TSPGDS
      READ(1,104) A,B,C
      READ(1,104) CA,CB,CC
  104 FORMAT(3D23.16)
      CALL TSLATC(A,B,C,CA,CB,CC)
      READ(1,*) NATOM,NKAT
	  WRITE(6,*) NATOM,NKAT
      RETURN
      END
C--------1---------2---------3---------4---------5---------6---------7---------8
      SUBROUTINE FITPRM
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'prmfit.f'
c      PARAMETER (MAXCMP=20,MAXKPT=5000,MAXEIG=200)
      CHARACTER*4 NCCHR
      COMMON/SPG2/IL,NG,IG(48),JV(2,3,48)
      COMMON/SCL/NATOM,NKAT,IPR,ISO,E0,DE,NNEE,NELEC,ENEND,AM
      COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
     &   ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT,NBAND,NB1,NB2
      COMMON/LCM/COMP(MAXEIG,MAXKPT,MAXCMP),NCOMP,
     $           NKCOMP(MAXCMP),NCCHR(MAXCMP)
      COMMON/NXYZ/NX,NY,NZ,N64,NBLOCK,JS
      CHARACTER*4 CHARA4
      CHARACTER*10 MAGNET
C
      READ(5,150) MAGNET
 150  format(A10)
      CHARA4=MAGNET
      IF(CHARA4.EQ.'NONM') ISO=1
      IF(CHARA4.EQ.'MAGN') ISO=2
      IF(CHARA4.EQ.'SPIN') ISO=3
      NDFAC=1
      IF(ISO.EQ.3) THEN
         DO 10 I=1,NG
            IF(IL.GE.1.AND.IG(I).EQ.25
     &  .OR.IL.LE.0.AND.IG(I).EQ.13) NDFAC=2
   10    CONTINUE
      END IF
      IF(ISO.EQ.3.AND.NDFAC.EQ.1) ISO=4
      write(6,*) 'NDFAC=',NDFAC,'ISO CODE=',ISO
      READ(5,*) NELEC,NB1,NB2
	  READ(5,*) AM
	  READ(5,*) IPR
	  READ(5,*) NX,NY,NZ,N64,JS
	  NBLOCK=1
      RETURN
      END
C--------1---------2---------3---------4---------5---------6---------7---------8
      SUBROUTINE ENRRED
      INCLUDE 'prmfit.f'
c      PARAMETER (MAXKPT=5000,MAXEIG=200,MAXCMP=20)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*2 MRR
      CHARACTER*4 NCCAR
      COMMON/SPG2/IL,NG,IG(48),JV(2,3,48)
      COMMON/SCL/NATOM,NKAT,IPR,ISO,E0,DE,NNEE,NELEC,ENEND
      COMMON/ENR/KXM(3,MAXKPT),ICM(MAXKPT),IUDM(MAXKPT)
     &   ,NEIGM(MAXKPT),EIGM(MAXEIG,MAXKPT),NKPINT,NBAND,NB1,NB2
      COMMON/LCM/COMP(MAXEIG,MAXKPT,MAXCMP),NCOMP,
     $           NKCOMP(MAXCMP),NCCAR(MAXCMP)
      DIMENSION CLPM(100,MAXEIG)
      DIMENSION KX(3),EIG(MAXEIG)
      REWIND 2 
C
      NKPINT=0
      IFRAG=0
   40 READ(2,150,END=41) (KX(J),J=1,3),IC,IUD,MRR,MRN,NDEG,NST,NEIG
  150 FORMAT(5X,3I3,1X,2I3,2X,A2,I2,3I3)
      IF(NEIG.EQ.0) GO TO 40
      IF(NEIG.GT.MAXEIG) THEN
         WRITE(6,*) ' MAXEIG=',MAXEIG,' NEIG=',NEIG
         STOP ' STOP IN ENRRED' 
      END IF
c
c modified by H.Funashima for ifort
c
      READ(2,151) (EIG(J),J=1,NEIG)
  151 FORMAT(8F9.5)
      DO 39 J=1,NEIG
           READ(2,152) (CLPM(I,J),I=1,NKAT*4)
   39 CONTINUE
  152      FORMAT(4F7.4,1X,4F7.4)
      IF(ISO.EQ.3) THEN
         IF(MOD(NDEG,2).NE.0) THEN
            WRITE(6,*) ' THE SPACE GROUP MAYBE INCORRECT'
            STOP' THE SPACE GROUP MAYBE INCORRECT'
         END IF
         NDEG=NDEG/2
      END IF
C	  IF(MOD(IABS(KX(1)),2).NE.0) GO TO 40
C	  IF(MOD(IABS(KX(2)),2).NE.0) GO TO 40
C	  IF(MOD(IABS(KX(3)),2).NE.0) GO TO 40
      IF(NKPINT.EQ.0) GO TO 5
      DO 11 IK=1,NKPINT
      IF(KXM(1,IK)*IC.EQ.KX(1)*ICM(IK).AND.
     &   KXM(2,IK)*IC.EQ.KX(2)*ICM(IK).AND.
     &   KXM(3,IK)*IC.EQ.KX(3)*ICM(IK).AND.
     &   IUDM(IK).EQ.IUD) GO TO 7
   11 CONTINUE
    5 NKPINT=NKPINT+1
C       write(6,*) NKPINT,KX,IUD
      IF(IFRAG.EQ.1) GO TO 40
      IF(NKPINT.GT.MAXKPT) THEN
         IFRAG=1
         GO TO 40
      END IF
      NEIGM(NKPINT)=0
      IK=NKPINT
      DO 8 K=1,3
        KXM(K,NKPINT)=KX(K)
    8 CONTINUE
      ICM(NKPINT)=IC
      IUDM(NKPINT)=IUD
    7 CONTINUE
      IF(NEIGM(IK)+NEIG*NDEG.GT.MAXEIG) THEN
	     WRITE(6,*) KX,NEIG,NDEG
         WRITE(6,*) ' NUMBER OF ENERGY IS',NEIGM(IK)+NEIG*NDEG
         STOP 
      END IF
      DO 20 K=1,NEIG
      IF(NEIGM(IK).EQ.0) GO TO 21
      DO 22 JJ=1,NEIGM(IK)
      J=NEIGM(IK)-JJ+1
      IF(EIGM(J,IK).GT.EIG(K)) THEN
          EIGM(J+NDEG,IK)=EIGM(J,IK)
          DO 23 L=1,NCOMP
          COMP(J+NDEG,IK,L)=COMP(J,IK,L)
   23     CONTINUE
      ELSE 
          GO TO 24
      END IF
   22 CONTINUE
   21 J=0
   24 CONTINUE
      DO 30 I=1,NDEG
      EIGM(J+I,IK)=EIG(K)
      DO 30 L=1,NCOMP
      COMP(J+I,IK,L)=CLPM(NKCOMP(L),K)
   30 CONTINUE
      NEIGM(IK)=NEIGM(IK)+NDEG
C      write(6,*) IK,NDEG,NEIG,NEIGM(IK)
   20 CONTINUE
      GO TO 40
   41 CONTINUE
      IF(IFRAG.EQ.1) THEN
         WRITE(6,*) ' MAXKPT=',MAXKPT,' NKPINT=',NKPINT
         STOP
      END IF
      NBAND=9999
      DO 51 IK=1,NKPINT
         IF(NEIGM(IK).LT.NBAND) NBAND=NEIGM(IK)
         WRITE(6,6000) IK,(KXM(K,IK),K=1,3),ICM(IK),IUDM(IK),NEIGM(IK)
 6000    FORMAT(I4,3I3,'/',I4,2I6)		 
         WRITE(6,6001) (EIGM(I,IK),I=1,NEIGM(IK))
 6001    FORMAT(10F7.4)
 51   CONTINUE
      IF(NB1.LT.1) NB1=1
      IF(NB2.GT.NBAND.OR.NB1.LT.1) NB2=NBAND   
      WRITE(6,*) ' NBAND=',NBAND,NB1,NB2 
      RETURN
      END
