C SUBROUTINE OCCUP2 ====*====3====*====4====*====5====*====6====*====7
C
C          1984.05.17 :   NORIAKI HAMADA
C
C---*----1----*----2----*----3----*----4----*----5----*----6----*----7
C
      SUBROUTINE FERMI(TOTCH,QWGT,WIDTH)
      IMPLICIT REAL(A-H,O-Y)                                          
      IMPLICIT COMPLEX(Z)                                            
      INCLUDE 'PACVPP'
!XOCL SUBPROCESSOR PS(IPARA)=PQ(1:IPARA)
!XOCL INDEX PARTITION IP=(PS,INDEX=1:KNV3,PART=BAND)
      DIMENSION EKK(KEG,KNV3),OCCUU(KEG,KNV3)
!XOCL LOCAL EKK(:,/IP),OCCUU(:,/IP)
      EQUIVALENCE (EKO,EKK),(OCCUP,OCCUU)
      DIMENSION QWGT(KNV3)
      dimension totsum2(256)
      save totsum2 
c
      IF (ITER.EQ.1) WRITE(6,*) ' OCCUP2 :    WIDTH=',WIDTH
      EMIN=EKO(NBD1,1)
      EMAX=EKO(NBD1,1)
C!XOCL SPREAD DO /IP
      DO 10 K=1,KV3
      DO 10 I=NBD1,NBD2
        IF(EKO(I,K).LT.EMIN) EMIN=EKO(I,K)
        IF(EKO(I,K).GT.EMAX) EMAX=EKO(I,K)
   10 CONTINUE
C!XOCL END SPREAD 
      WSPIN  = 1.0D0
      EFERMI = EMAX
      E1     = EMIN
      E2     = EMAX
      JCOUNT = 1
C     WRITE(6,*) JCOUNT,TOT,EFERMI
    1 CONTINUE
C!XOCL SPREAD DO /IP 
*pardo 
      DO 20 K=1,KV3
      totsum2(k) = 0.d0 
      DO 20 I=NBD1,NBD2
        E = EKK(I,K)
        CALL WIDTH2(E,EFERMI,WIDTH,DOS,WEIGHT) 
        OCCUU(I,K) = (WEIGHT*WSPIN)*DBLE(KV3)*QWGT(K)
c        TOT = TOT + 2.0D0*OCCUU(I,K)
        totsum2(k) = totsum2(k) + 2.0D0*OCCUU(I,K) 
   20 CONTINUE
c
      TOT = 0.0D0
*pardo 
      do k=1,KV3
         TOT = TOT + totsum2(k) 
      enddo
c
!XOCL END SPREAD SUM(TOT) 
      TOT=TOT/DFLOAT(KV3)
C     WRITE(6,*) JCOUNT,TOT,EFERMI
      IF(JCOUNT.EQ.1 .AND. TOT .LT. TOTCH) THEN
        WRITE(6,*) ' EMIN=',EMIN,'    EMAX=',EMAX
        WRITE(6,*) ' TOT=',TOT, '   TOTCH =', TOTCH
        STOP ' === STOP IN SUB.OCCUP2. (TOO FEW OF STATES) =='
      END IF
C
      IF(DABS(TOT-TOTCH).LT.1.0D-10) GO TO 2
C                                     ----------------------->
      IF(TOT.LT.TOTCH) THEN
        E1     = EFERMI
        EFERMI = EFERMI + (E2-EFERMI)/2.0D0
      ELSE
        E2     = EFERMI
        EFERMI = EFERMI + (E1-EFERMI)/2.0D0
      END IF 
      JCOUNT = JCOUNT + 1
      GO TO 1
C                                     <----------------------
    2 CONTINUE 
C
      EF = EFERMI
      WRITE( 6,100) EFERMI,TOT
  100 FORMAT(1H ,'---------- THE FERMI ENERGY =',D23.16,F12.6)
      RETURN
      END