C
C $Id: frmchk.F,v 1.2 1998/07/16 16:39:48 jjv5 Exp $
C
C------------------------------------------------------------------------
      SUBROUTINE FRMCHK
C
C     DIAGNOSTIC TOOL FOR TRACKING FERMI LEVEL.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#include "divcon.dim"
#include "divcon.h"
C
C     LOCAL:
C
      LOGICAL FIRST
      DATA FIRST /.TRUE./
      DIMENSION IHOMO(MAXSUB),IOLD(MAXSUB)
      SAVE FIRST,IHOMO,IOLD
C
C
C     STORE OLD HOMO LEVELS.
C
      IF(.NOT.FIRST)THEN
        DO 100 I=1,NSUB
          IOLD(I) = IHOMO(I)
 100    CONTINUE
      ENDIF
C
C     DETERMINE NEW HOMO LEVELS.
C
      if (setch) then
         kk = 1
         DO 120 I=1,NSUB
            K1 = IORBPT(I)
            K2 = IORBPT(I+1)-1
            if (i.gt.isubend(kk)) kk = kk + 1
            efermix = efermi(kk)
            DO 110 K=K1,K2
               IF(EVAL(K).GT.EFERMIx)THEN
                  IHOMO(I) = K - K1
                  GO TO 120
               ENDIF
 110        CONTINUE
 120     CONTINUE

      else
         DO 200 I=1,NSUB
            K1 = IORBPT(I)
            K2 = IORBPT(I+1)-1
            DO 150 K=K1,K2
               IF(EVAL(K).GT.EFERMI(1))THEN
                  IHOMO(I) = K - K1
                  GO TO 200
               ENDIF
 150        CONTINUE
 200     CONTINUE
      endif
C
C     CHECK TO SEE IF HOMO LEVEL HAS CHANGED FOR ANY SUBSYSTEMS.
C
      IF(.NOT.FIRST)THEN
C-RDC         NWRITE = 0
        DO 300 I=1,NSUB
          IF(IHOMO(I).NE.IOLD(I))THEN
C-RDC             WRITE(IOUT,'(" <SUB",I3,": ",I3,"-->",I3,">",$)')
C-RDC      .            I,IOLD(I),IHOMO(I)
C-RDC             WRITE(ISCR,'(" <SUB",I3,": ",I3,"-->",I3,">",$)')
C-RDC      .            I,IOLD(I),IHOMO(I)
C-RDC             NWRITE = NWRITE + 1
             IF(NWRITE.EQ.4)THEN
C-RDC               NWRITE = 0
C-RDC               WRITE(IOUT,*)
C-RDC               WRITE(ISCR,*)
            ENDIF
          ENDIF
 300    CONTINUE
C-RDC         IF(NWRITE.GT.0) WRITE(IOUT,*)
C-RDC         IF(NWRITE.GT.0) WRITE(ISCR,*)
       ENDIF
      FIRST = .FALSE.
      RETURN
      END