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