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)                                              
      IF (ITER.EQ.1) WRITE(6,*) ' OCCUP2 :    WIDTH=',WIDTH             
      EMIN=EKO(NBD1,1)                                                  
      EMAX=EKO(NBD1,1)                                                  
!XOCL SPREAD DO /IP
      DO 10 K=1,KV3                                                     
      DO 10 I=NBD1,NBD2                                                 
        IF(EKK(I,K).LT.EMIN) EMIN=EKK(I,K)                              
        IF(EKK(I,K).GT.EMAX) EMAX=EKK(I,K)                              
   10 CONTINUE                                                          
!XOCL END SPREAD
      WSPIN  = 1.0D0                                                    
      EFERMI = EMAX                                                     
      E1     = EMIN                                                     
      E2     = EMAX                                                     
      JCOUNT = 1                                                        
C     WRITE(6,*) JCOUNT,TOT,EFERMI                                      
    1 CONTINUE                                                          
      TOT = 0.0D0                                                       
!XOCL SPREAD DO /IP
      DO 20 K=1,KV3                                                     
      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)                   
        TOT = TOT + 2.0D0*OCCUU(I,K)                                    
   20 CONTINUE                                                          
!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