	subroutine crgarr(ncrgmx,cqplus,cqmin,xn1,igrid,natom,
     &	nqass,nqgrd,qmin,qnet,qplus,nmedia,ndistr,scale,cmid,nobject,
     &  radpolext,extracrg,realsiz,verbose)

	include "pointer.h"
c
	dimension xn2(3,natom),xn1(3,natom)
        integer extracrg
	dimension chrgv2(natom+extracrg)
c b++++++++++++
      integer nqgrdtonqass(natom+extracrg),ncrgmx,realsiz
      real atmeps(natom+extracrg),atmcrg(4,1),chgpos(3,ncrgmx)
      dimension iatmmed(natom+nobject),iepsmp(igrid,igrid,igrid,3)
      real medeps(0:nmedia),rx,ry,rz,cmid(3)
      real rad3(natom)
      integer imed,jx,jy,jz,epsdim
      logical ipassed,verbose
	character*15 atinf(natom)
c e++++++++++++
	dimension xo(3),chrgv4(natom),cqplus(3),cqmin(3)
	integer crgatn(natom+extracrg)
c
	ic1=0
c
c atmcrg contains grid positions of all charges AND the charge in the 4th field
c atmeps6 contains 6*epsilon/epkt as a function of ic2-th charge internal
c atmeps6  to the grid NO LONGER USED
c nqgrdtonqass maps ic2 to ic1
c atmeps contains epsilon/epkt as a funcion of ic1-th general charge
c
c b+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        i_atmcrg=memalloc(i_atmcrg,realsiz,4*ncrgmx)
        epsdim=nobject+natom+2
c find charge moments for dipole approximation
c
	qnet=0.0
	qplus=0.0
	qmin=0.0
	do 2106 ix=1,3
	  cqplus(ix)=0.0
	  cqmin(ix)=0.0
2106	continue

	do 3104 ix=1,natom
	  if(abs(chrgv4(ix)).gt.1.e-6) then
	    ic1=ic1+1
	    chrg=chrgv4(ix)
	    atmcrg(1,ic1)=xn2(1,ix)
	    atmcrg(2,ic1)=xn2(2,ix)
	    atmcrg(3,ic1)=xn2(3,ix)
	    chgpos(1,ic1)=xn1(1,ix)
	    chgpos(2,ic1)=xn1(2,ix)
	    chgpos(3,ic1)=xn1(3,ix)
	    atmcrg(4,ic1)=chrg
	    crgatn(ic1)=ix

          qnet=qnet + chrg
          if(chrg.gt.0.) then
            qplus=qplus + chrg
	      cqplus(1)=cqplus(1) + chrg*atmcrg(1,ic1)
	      cqplus(2)=cqplus(2) + chrg*atmcrg(2,ic1)
	      cqplus(3)=cqplus(3) + chrg*atmcrg(3,ic1)
	    else
	      qmin=qmin + chrg
	      cqmin(1) =cqmin(1)  + chrg*atmcrg(1,ic1)
	      cqmin(2) =cqmin(2)  + chrg*atmcrg(2,ic1)
	      cqmin(3) =cqmin(3)  + chrg*atmcrg(3,ic1)
	    end if

	  end if
3104	continue

      if(verbose)
     &   write(6,*)"number of charges coming from molecules ",ic1

c insert charges from charge distributions
      if (ndistr.gt.0) call distrTOpoint(igrid,scale,ncrgmx,ndistr,ic1
     &  ,cmid,natom,qplus,qmin,cqplus,cqmin,qnet)

c debug++++++++++++++++++++++++WWW
      if (.false.) then
        open(52,file='Charges.txt',form='formatted')
        do iiii=1,ic1
          write(52,*) iiii,chgpos(1,iiii),chgpos(2,iiii),chgpos(3,iiii)
        end do
        close (52)
      end if
c end debug+++++++++++++++++++
c e+++++++++++++++
c
c assign charges for boundary conditions
c
c ic1 = number of charges

c divide by charge totals
c
	if(qplus.gt.1.e-6) then
	  do 2110 k = 1,3
	    cqplus(k) = cqplus(k)/qplus
2110	  continue
	end if
	if(abs(qmin).gt.1.e-6) then
	  do 2111 k = 1,3
	    cqmin(k) = cqmin(k)/qmin
2111	  continue
	end if
c
c select those charges which will be charging the grid
c
	nqass=ic1
c b+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        i_atmcrg=memalloc(i_atmcrg,realsiz,4*nqass)
c e+++++++++++++++++++++++++++++++++++++++++++++++++++++++
	rgrid=igrid
	ic2=0

	do 2102 ix=1,nqass
c b++++++++++
c crgatn(crg number)=atom number or natom+objectnumber or -distr.number
          ii=crgatn(ix)

          if(ii.lt.0) then
c now we have to consider charge distributions
c in this case the distribution is not linked to any object
c (jx,jy,jz)=coordinates of closest grid point to charge
c (rx,ry,rz)=coordinates of the charge relatives to the current grid point
              jx=int(atmcrg(1,ix)+0.5)
              jy=int(atmcrg(2,ix)+0.5)
              jz=int(atmcrg(3,ix)+0.5)
              rx=atmcrg(1,ix)-jx
              ry=atmcrg(1,ix)-jy
              rz=atmcrg(1,ix)-jz
              if (rz.gt.rx) then
                if (rz.gt.-rx) then
                  if (rz.gt.ry) then
                    if (rz.gt.-ry) then
                      imed=iepsmp(jx,jy,jz,3)
                    else
                      imed=iepsmp(jx,jy-1,jz,2)
                    end if
                  else
                    imed=iepsmp(jx,jy,jz,2)
                  end if
                else
                  if (ry.gt.rx) then
                    if (ry.gt.-rx) then
                      imed=iepsmp(jx,jy,jz,2)
                    else
                      imed=iepsmp(jx-1,jy,jz,1)
                    end if
                  else
                    imed=iepsmp(jx,jy-1,jz,2)
                  end if
                end if
              else
                if (rz.gt.-rx) then
                  if(ry.gt.rx) then
                    imed=iepsmp(jx,jy,jz,2)
                  else
                    if (ry.gt.-rx) then
                      imed=iepsmp(jx,jy,jz,1)
                    else
                      imed=iepsmp(jx,jy-1,jz,2)
                    end if
                  end if
                else
                  if (rz.gt.ry) then
                    imed=iepsmp(jx,jy-1,jz,2)
                  else
                    if (rz.gt.-ry) then
                      imed=iepsmp(jx,jy,jz,2)
                    else
                      imed=iepsmp(jx,jy,jz-1,3)
                    end if
                  end if
                end if
              end if
            imed=imed/epsdim
          else
            imed=iatmmed(ii)
          end if
          atmeps(ix)=medeps(imed)
c e+++++++++++++++++++++++++++++++++

	  if((atmcrg(1,ix).gt.1.).and.(atmcrg(1,ix).lt.rgrid)) then
	  if((atmcrg(2,ix).gt.1.).and.(atmcrg(2,ix).lt.rgrid)) then
	  if((atmcrg(3,ix).gt.1.).and.(atmcrg(3,ix).lt.rgrid)) then
	    ic2=ic2+1
            chrgv2(4*ic2-3)=atmcrg(1,ix)
	    chrgv2(4*ic2-2)=atmcrg(2,ix)
	    chrgv2(4*ic2-1)=atmcrg(3,ix)
	    chrgv2(4*ic2)=atmcrg(4,ix)
c b+++++++++++++++++++++++++++++++++
            nqgrdtonqass(ic2)=ix
c           atmeps6(ic2)=6.0*atmeps(ix)
c e+++++++++++++++++++++++++++++++++
          end if
          end if
	  end if
2102	continue
	nqgrd=ic2

        ipassed=.false.
        do i=1,nqass
          ii=crgatn(i)
          if(ii.gt.0.and.ii.le.natom) then
            if (rad3(ii).le.0.) then
             ipassed=.true.
             write(6,'(I4,A16,'' is charged! Radius moved from zero to''
     &            ,f5.1)')ii,atinf(ii),radpolext
             rad3(ii)=radpolext
            end if
          end if
        end do
	  if(ipassed) write(6,*)'BE CAREFUL!! A WRONG ASSIGNMENT FOR THE
     &RADIUS MIGHT LEAD TO INACCURATE REACTION FIELD ENERGY !!!'

	return
	end


MODULE scf_module

  use aa_module
  use parallel_module
  use electron_module
  use localpot_module
  use mixing_module, only: init_mixing, perform_mixing, calc_sqerr_mixing &
                         , finalize_mixing, imix, beta
  use sqerr_module
  use xc_hybrid_module, only: control_xc_hybrid, get_flag_xc_hybrid
  use xc_module
  use hartree_variables, only: Vh
  use hartree_module, only: calc_hartree
  use ps_local_module
  use bz_module
  use wf_module
  use cg_module
  use array_bound_module
  use gram_schmidt_module
  use io_module
  use total_energy_module, only: calc_total_energy,calc_with_rhoIn_total_energy
  use fermi_module
  use fermi_ncol_module
  use subspace_diag_module
  use esp_gather_module
  use density_module
  use watch_module
  use ggrid_module, only: Ecut
  use rgrid_module, only: dV, Ngrid
  use esp_calc_module
  use force_module, only: get_fmax_force
  use hamiltonian_module
  use io_tools_module
  use eigenvalues_module
  use rsdft_mpi_module
  use noncollinear_module
  use phase_control_module

  implicit none

  PRIVATE
  PUBLIC :: calc_scf, read_scf, Diter_scf

  integer :: Diter_scf   = 100
  integer :: Ndiag       = 1
  integer :: second_diag = 2
  real(8) :: scf_conv(2) = 0.0d0
  real(8) :: fmax_conv   = 0.0d0
  real(8) :: etot_conv   = 0.0d0
  logical :: errlog_scf  = .false.
  logical :: nodiag_scf  = .false.
  integer,parameter :: unit_err=40

  real(8),allocatable :: Vloc0(:,:)
  real(8),allocatable :: rho_0(:,:),vxc_0(:,:),vht_0(:)
  real(8) :: diff_vrho(7)
  real(8) :: time_scf(4)
  real(8) :: fmax,fmax0,fdiff

CONTAINS

  SUBROUTINE read_scf
    implicit none
    integer :: itmp(2)
    call IOTools_readReal8Keyword( "SCFCONV" , scf_conv )
    call IOTools_readReal8Keyword( "FMAXCONV", fmax_conv )
    call IOTools_readReal8Keyword( "ETOTCONV", etot_conv )
    call IOTools_readIntegerKeyword( "DITER", Diter_scf )
    call IOTools_findKeyword( "ERRLOG", errlog_scf )
    call IOTools_findKeyword( "NODIAG", nodiag_scf )
    itmp=-1
    call IOTools_readIntegerKeyword( "NDIAG", itmp )
    if ( itmp(1) > 0 ) Ndiag=itmp(1)
    if ( itmp(2) > 0 ) second_diag=itmp(2)
  END SUBROUTINE read_scf

  SUBROUTINE calc_scf(ierr_out,Diter_in,tol_force_in,outer_loop_info,Etot_out)
    implicit none
    integer,intent(OUT) :: ierr_out
    integer,optional,intent(IN) :: Diter_in
    real(8),optional,intent(IN) :: tol_force_in
    character(*),optional,intent(IN)  :: outer_loop_info
    real(8),optional,intent(OUT) :: Etot_out
    real(8),allocatable :: v(:,:,:)
    real(8) :: tol_force,tmp
    real(8) :: Etot, Ehwf, diff_etot
    real(8) :: Ntot(4), sqerr_out(4), t_out(2,14), t_ini(2), t_tmp(2)
    integer :: iter,s,k,n,m,ierr,idiag,i,j,Diter
    integer :: ML01,MSP01,ib1,ib2,iflag_hybrid,iflag_hybrid_0
    logical :: flag_exit,flag_conv,flag_conv_f,flag_conv_e
    logical :: flag_end, flag_end1, flag_end2
    logical :: flag_recalc_esp = .false.
    logical :: disp_switch
    logical,external :: exit_program
    character(40) :: chr_iter
    character(22) :: add_info
    type(eigv) :: eval
    type(time) :: etime, etime_tot, etime_lap(10)
    type(time) :: tt

    call write_border( 0, "" )
    call write_border( 0, " SCF START -----------" )

    call check_disp_switch( disp_switch, 0 )

    call init_time_watch( etime_tot )
    call init_time_watch( etime_lap(1) )

    flag_end    = .false.
    flag_end1   = .false.
    flag_end2   = .false.
    flag_exit   = .false.
    flag_conv   = .false.
    flag_conv_f = .false.
    flag_conv_e = .false.
    ierr_out    = 0
    fmax0       =-1.d10
    fdiff       =-1.d10
    tol_force   = 0.0d0 ; if ( present(tol_force_in) ) tol_force=tol_force_in
    Diter       = Diter_scf ; if ( present(Diter_in) ) Diter=Diter_in
    Etot        = 0.0d0
    time_scf(:) = 0.0d0
    t_out       = 0.0d0

    add_info ="" ; if ( present(outer_loop_info) ) add_info=outer_loop_info

    ML01        = ML_1-ML_0+1
    MSP01       = MSP_1-MSP_0+1
    ib1         = max(1,nint(Nelectron/2)-10)
    ib2         = min(nint(Nelectron/2)+10,Nband)

    if ( flag_noncollinear ) then
       !call calc_xc_noncollinear( unk, occ(:,:,1), vxc_out=Vxc )
       !occ(:,:,2) = occ(:,:,1)
!       Vxc=0.0d0
       E_exchange=0.0d0
       E_correlation=0.0d0
    end if

    do s=MSP_0,MSP_1
       Vloc(:,s) = Vion(:) + Vh(:) + Vxc(:,s)
    end do

    call init_mixing(ML01,MSP,MSP_0,MSP_1,comm_grid,comm_spin &
                    ,dV,rho(ML_0,MSP_0),Vloc(ML_0,MSP_0) &
                    ,ir_grid,id_grid,myrank)

    call init_sqerr( ML01, MSP01, MSP, Vloc(ML_0,MSP_0), rho(ML_0,MSP_0) )

    rho_in = rho

    allocate( esp0(Nband,Nbzsm,Nspin) ) ; esp0=0.0d0

    if ( iflag_hunk == 1 ) then

       hunk(:,:,:,:)=0.0d0

       do s=MSP_0,MSP_1
       do k=MBZ_0,MBZ_1
          do m=MB_0,MB_1,MB_d
             n=min(m+MB_d-1,MB_1)
             call hamiltonian( unk(:,m:n,k,s), hunk(:,m:n,k,s), m,k,s )
          end do
       end do
       end do

       allocate( Vloc0(ML_0:ML_1,MSP_0:MSP_1) ) ; Vloc0=0.0d0
       Vloc0(:,:)=Vloc(:,:)

    end if

    call calc_time_watch( etime_lap(1) )

    do iter=1,Diter

       write(chr_iter,'(" scf_iter=",i4,1x,a)') iter, add_info
       call write_border( 0, chr_iter(1:len_trim(chr_iter)) )

       call start_timer( t_out=tt )
       call init_time_watch( etime )
       call init_time_watch( etime_lap(2) )
       call watchb( t_ini(1) ) ; t_out=0.0d0

       esp0=esp

       call get_flag_xc_hybrid( iflag_hybrid_0 )

       do s=MSP_0,MSP_1
       do k=MBZ_0,MBZ_1

          call watchb( t_tmp )

          call control_xc_hybrid( iflag_hybrid_0 )

          if ( iflag_hunk == 1 ) then

             do n=MB_0,MB_1
                hunk(:,n,k,s) = hunk(:,n,k,s) &
                     + ( Vloc(:,s)-Vloc0(:,s) )*unk(:,n,k,s)
             end do

          else if ( iflag_hunk == 2 ) then

             call get_flag_xc_hybrid( iflag_hybrid )

             if ( iflag_hybrid == 2 ) then
                call control_xc_hybrid(0)
                allocate( workwf(ML_0:ML_1,MB_d) ) ; workwf=0.0d0
                do m=MB_0,MB_1,MB_d
                   n=min(m+MB_d-1,MB_1)
                   workwf(:,1:n-m+1)=hunk(:,m:n,k,s)
                   call hamiltonian( unk(:,m:n,k,s), hunk(:,m:n,k,s), m,k,s )
                   hunk(:,m:n,k,s)=hunk(:,m:n,k,s)+workwf(:,1:n-m+1)
                end do
                deallocate( workwf )
             end if

          end if

          call watchb( t_tmp, t_out(:,1) )

          if ( .not.nodiag_scf ) call subspace_diag( k, s, unk(:,:,k,s), esp(:,k,s) )

          call watchb( t_tmp, t_out(:,2) )

#ifdef _DRSDFT_
          call mpi_bcast( unk,size(unk),MPI_REAL8,0,comm_fkmb,ierr )
#else
          call mpi_bcast( unk,size(unk),RSDFT_MPI_COMPLEX16,0,comm_fkmb,ierr )
#endif
          call mpi_bcast( esp,size(esp),MPI_REAL8, 0, comm_fkmb,ierr )

          call control_xc_hybrid(1)

          call watchb( t_tmp, t_out(:,3) )

          do idiag=1,Ndiag

             if ( Ndiag > 1 .and. disp_switch ) then
                write(*,'(a5," idiag=",i4)') repeat("-",5),idiag
             end if

             call watchb( t_tmp )

             call conjugate_gradient(ML_0,ML_1,k,s,unk,esp,res)

             call watchb( t_tmp, t_out(:,4) )

             call gram_schmidt(1,Nband,k,s)

             call watchb( t_tmp, t_out(:,5) )

             if ( second_diag == 1 .or. idiag < Ndiag ) then
                call subspace_diag( k, s, unk(:,:,k,s), esp(:,k,s) )
                ! if ( flag_noncollinear ) then
                !   call subspace_diag_ncol
                ! end if
                call watchb( t_tmp, t_out(:,2) )
             else if ( second_diag == 2 .and. idiag == Ndiag ) then
                call esp_calc( unk(:,MB_0:MB_1,k,s), esp(MB_0:MB_1,k,s), MB_0,k,s )
                ! if ( flag_noncollinear ) then
                !   call esp_calc_ncol( k,n1,n2,wf,e )
                ! end if
                call watchb( t_tmp, t_out(:,6) )
             end if

          end do ! idiag

       end do ! k

       if ( flag_noncollinear ) exit

       if ( iflag_hunk == 1 ) Vloc0(:,s)=Vloc(:,s)

       end do ! s

       !call phase_control( ML_0, ML_1, unk )

       call calc_time_watch( etime_lap(2) )
       call init_time_watch( etime_lap(3) )
       call watchb( t_tmp )

       call esp_gather(Nband,Nbzsm,Nspin,esp)

#ifdef _DRSDFT_
       call mpi_bcast( unk,size(unk),MPI_REAL8,0,comm_fkmb,ierr )
#else
       call mpi_bcast( unk,size(unk),RSDFT_MPI_COMPLEX16,0,comm_fkmb,ierr )
#endif
       call mpi_bcast( esp,size(esp),MPI_REAL8, 0, comm_fkmb,ierr )

       if ( flag_noncollinear ) then
          call calc_fermi_ncol(iter,Nfixed,Nband,Nbzsm,Nspin &
               ,Nelectron,Ndspin,esp,weight_bz,occ )
       else
          call calc_fermi(iter,Nfixed,Nelectron,Ndspin,esp,weight_bz,occ)
       end if

       call calc_time_watch( etime_lap(3) )
       call init_time_watch( etime_lap(4) )
       call watchb( t_tmp, t_out(:,7) )

! --- total energy ---

       call calc_with_rhoIN_total_energy( Ehwf, flag_noncollinear )

       if ( flag_noncollinear ) then
#ifndef _DRSDFT_
          call calc_xc_noncollinear( unk, occ(:,:,1), rho, Vxc )
#endif
          occ(:,:,2)=occ(:,:,1)
!          Vxc=0.0d0
          E_exchange=0.0d0
          E_correlation=0.0d0
          call calc_hartree( rho )
          call calc_spin_density( rho, Ntot )
       else
          call calc_density( Ntot )
          call calc_hartree( rho )
          call calc_xc
       end if
       call calc_total_energy( flag_recalc_esp, Etot, &
                               flag_ncol=flag_noncollinear )
       if ( present(Etot_out) ) Etot_out = Etot

! --- convergence check by total energy ---

       diff_etot = Etot - Ehwf

       if ( abs(diff_etot) < etot_conv ) flag_conv_e = .true.

! ---

       if ( disp_switch ) then
          write(*,*)
          write(*,'(1x,"Total Energy :",f26.8,2x,"(Hartree)")') Etot
          write(*,'(1x,"Harris Energy:",f26.8,2x,"(Hartree)")') Ehwf
          write(*,'(1x," ( diff/tol =",es13.5," /",es12.5," )",l5)') &
               diff_etot,etot_conv,flag_conv_e
       end if
       if ( disp_switch ) then
          write(*,*)
          write(*,'(1x,"Charge:",2f22.15)') (Ntot(s),s=1,Nspin)
          if ( Nspin == 2 ) then
             write(*,'(1x,"N_up - N_down        :",f22.15)') Ntot(3)
             write(*,'(1x,"sum|rho_up-rho_down| :",f22.15)') Ntot(4)
          end if
       end if

       call calc_time_watch( etime_lap(4) )
       call init_time_watch( etime_lap(5) )
       call watchb( t_tmp, t_out(:,8) )

! --- convergence check by density & potential ---

       allocate( v(ML_0:ML_1,MSP_0:MSP_1,2) ) ; v=0.0d0
       do s=MSP_0,MSP_1
          v(:,s,1) = Vion(:) + Vh(:) + Vxc(:,s)
          v(:,s,2) = rho(:,s)
       end do
       call calc_sqerr( size(v,1), size(v,2), MSP, 2, v, sqerr_out )
       deallocate( v )

       if ( maxval( sqerr_out(1:MSP) ) <= scf_conv(1) .or. &
            maxval( sqerr_out(MSP+1:2*MSP) ) <= scf_conv(2) ) flag_conv=.true.

       if ( disp_switch ) then
          write(*,*)
          if ( Nspin == 1 ) then
             write(*,'(1x,"|Vloc-Vloc0|^2/tol =",es14.5,2x," /",es12.5,l5)') &
                  (sqerr_out(i),i=1,MSP),scf_conv(1),flag_conv
             write(*,'(1x,"|rho -rho0 |^2/tol =",es14.5,2x," /",es12.5)') &
                  (sqerr_out(i),i=MSP+1,2*MSP),scf_conv(2)
          else if ( Nspin == 2 ) then
             write(*,'(1x,"|Vloc-Vloc0|^2/tol =",2es14.5,2x," /",es12.5,l5)') &
                  (sqerr_out(i),i=1,MSP),scf_conv(1),flag_conv
             write(*,'(1x,"|rho -rho0 |^2/tol =",2es14.5,2x," /",es12.5)') &
                  (sqerr_out(i),i=MSP+1,2*MSP),scf_conv(2)
          end if
       end if

       call calc_time_watch( etime_lap(5) )
       call init_time_watch( etime_lap(6) )
       call watchb( t_tmp, t_out(:,9) )

! --- convergence check by Fmax ---

       if ( fmax_conv > 0.0d0 ) then
          call get_fmax_force( fmax )
          fdiff=fmax-fmax0
          if ( fmax > tol_force .and. abs(fdiff) < fmax_conv ) then
             flag_conv_f=.true.
          else
             fmax0 = fmax
          end if
          if ( disp_switch ) then
             write(*,*)
             write(*,'(1x,"Fmax/fmax_tol:",es12.5," /",es12.5,4x,"(Hartree/bohr)")') &
                  fmax, tol_force
             write(*,'(1x," ( diff/tol =",es13.5," /",es12.5," )",l5)') &
                  fdiff,fmax_conv,flag_conv_f
             !write(11,*) iter,fmax
          end if
       end if

       flag_conv = ( flag_conv .or. flag_conv_f .or. flag_conv_e )

       call calc_time_watch( etime_lap(6) )
       call watchb( t_tmp, t_out(:,10) )

! ---

       call global_watch( .false., flag_end1 )

       flag_end2 = exit_program()

       flag_end = ( flag_end1 .or. flag_end2 )

       flag_exit = (flag_conv.or.flag_end.or.(iter==Diter))

       call init_time_watch( etime_lap(7) )
       call watchb( t_tmp, t_out(:,11) )

! --- mixing ---

       if ( .not.flag_exit ) then

          do s=MSP_0,MSP_1
             Vloc(:,s) = Vion(:) + Vh(:) + Vxc(:,s)
          end do

          if ( .not.flag_noncollinear ) then
             call perform_mixing( ML01, MSP_0, MSP_1, rho(ML_0,MSP_0) &
                                 ,Vloc(ML_0,MSP_0), disp_switch )
          end if

          if ( mod(imix,2) == 0 ) then
             if ( flag_noncollinear ) then
             else
                call normalize_density( rho )
                m=(ML_1-ML_0+1)*(MSP_1-MSP_0+1)
                call rsdft_allgather( rho(:,MSP_0:MSP_1), rho, comm_spin )
                call calc_hartree( rho )
                call calc_xc
             end if
             do s=MSP_0,MSP_1
                Vloc(:,s) = Vion(:) + Vh(:) + Vxc(:,s)
             end do
          end if

          rho_in = rho

       end if

       call calc_time_watch( etime_lap(7) )
       call watchb( t_tmp, t_out(:,12) )

! ---

       do n=1,Nband
          tmp = sum( occ(1:n,:,:) )
          if ( abs(tmp-Nelectron) < 1.d-8 ) exit
       end do

       call write_esp_wf( index_vbm=n )
       call construct_eigenvalues( Nband, Nbzsm, Nspin, esp, eval )
       if ( myrank == 0 ) call write_eigenvalues( eval )

       call calc_time_watch( etime )
       call watchb( t_tmp, t_out(:,13) )

       call write_data(disp_switch,flag_exit)
       if ( flag_noncollinear ) call io_write_noncollinear( myrank,flag_exit )
       call write_info_scf( (myrank==0) )
       call write_err_info(iter,sqerr_out(1:2*Nspin),diff_etot,flag_exit,(myrank==0) )

       call result_timer( "scf", tt )

       call watchb( t_ini, t_out(:,14) )

       if ( disp_switch ) then
       write(*,'(1x,"elapsed_time ",f8.3,"(scf)" &
                                   ,f8.3,"(sd) " &
                                   ,f8.3,"(esp)" &
                                   ,f8.3,"(cg) " &
                                   ,f8.3,"(gs) " &
                                   ,f8.3,"(for)" &
                                   ,f8.3,"(eto)" &
                                   ,f8.3,"(pot)" &
                                   ,f8.3,"(oth)")') &
                                    t_out(2,14) &
                                   ,t_out(2,2) &
                                   ,t_out(2,6) &
                                   ,t_out(2,4),t_out(2,5) &
                                   ,t_out(2,10) &
                                   ,t_out(2,8) &
                                   ,t_out(2,12) &
                                   ,( t_out(2,1)+t_out(2,3) &
                                     +t_out(2,7)+t_out(2,9) &
                                     +t_out(2,11)+t_out(2,13) )
       end if

       if ( flag_exit ) then
          call finalize_mixing
          exit
       end if

    end do ! iter

    if ( allocated(Vloc0) ) deallocate( Vloc0 )
    deallocate( esp0 )

    if ( .not.flag_conv ) then
       ierr_out = -2
    else
       ierr_out = iter
    end if

    if ( flag_end1 ) then
       ierr_out = -1
    else if ( flag_end2 ) then
       ierr_out = -3
    else
       call gather_wf
    end if

    call calc_time_watch( etime_tot )

    call write_border( 0, " SCF END -----" )
    if ( disp_switch ) then
       if ( ierr_out >= 0 ) then
          write(*,'(1x,"scf converged ( total # of iteration =",i4," )")') &
               ierr_out
       else if ( ierr_out == -1 ) then
          write(*,*) "Exit SCF loop due to the time limit"
       else if ( ierr_out == -2 ) then
          write(*,'(1x,"scf not converged !!!")')
       else if ( ierr_out == -3 ) then
          write(*,*) "'EXIT' file was found"
       end if
       write(*,'(1x,"Total SCF time :",f10.3,"(rank0)",f10.3,"(min)",f10.3,"(max)")') &
       etime_tot%t0, etime_tot%tmin, etime_tot%tmax
    end if
    call write_border( 0, "" )

  END SUBROUTINE calc_scf

  SUBROUTINE write_info_scf( flag )
    implicit none
    logical,intent(IN) :: flag
    integer :: s,k,n
    integer,parameter :: u=99
    call write_border( 1, " write_info_scf(start)" )
    if ( flag ) then
       write(u,*) "Eigenvalues"
       write(u,'(a4,a6,a20,2a13,1x)') &
            "k","n","esp(n,k,s)","esp_err  ","occ(n,k,s)  "
       do k=1,Nbzsm
       do n=1,Nband
          write(u,'(i4,i6,2(f20.15,2g13.5,1x))') k,n &
               ,(esp(n,k,s),esp(n,k,s)-esp0(n,k,s),occ(n,k,s),s=1,Nspin)
       end do
       end do
    end if
    call write_border( 1, " write_info_scf(end)" )
  END SUBROUTINE write_info_scf

  SUBROUTINE write_err_info( iter, sqerr, dEtot, flag_finalize, flag )
    implicit none
    integer,intent(IN) :: iter
    real(8),intent(IN) :: sqerr(:), dEtot
    logical,intent(IN) :: flag_finalize, flag
    logical :: flag_new=.true.
    if ( .not.errlog_scf .or. .not.flag ) return
    if ( flag_new ) then
       open(unit_err,file="errlog_scf")
       flag_new=.false.
    else
       open(unit_err,file="errlog_scf",position="append")
    end if
    write(unit_err,'(1x,i6,5f18.10)') iter,log10(sqerr(:)),dEtot
    if ( flag_finalize ) write(unit_err,'(/)')
    close(unit_err)
  END SUBROUTINE write_err_info

!  SUBROUTINE sub_localpot2_scf( disp_switch )
!    implicit none
!    logical,intent(IN) :: disp_switch
!    integer :: mm1,mm2,mm3
!    real(8) :: eion_tmp,eh_tmp,exc_tmp
!    call localpot2_density( rho_nl )
!    call localpot2_calc_eion( vion_nl, rho_nl, eion_tmp )
!    call localpot2_vh( Ecut, rho_nl, vh_nl, eh_tmp )
!    call localpot2_xc( rho_nl, vxc_nl, exc_tmp )
!    vloc_dense=vion_nl+vh_nl+vxc_nl
!    vloc_dense=beta*vloc_dense+(1.d0-beta)*vloc_dense_old
!    vloc_dense_old=vloc_dense
!    call test2_localpot2( vloc_dense )
!    call localpot2_te( eion_tmp, eh_tmp, exc_tmp, disp_switch )
!  END SUBROUTINE sub_localpot2_scf

  SUBROUTINE init_diff_vrho_scf
    implicit none
    allocate( rho_0(ML_0:ML_1,MSP)         ) ; rho_0=0.0d0
    allocate( vxc_0(ML_0:ML_1,MSP_0:MSP_1) ) ; vxc_0=0.0d0
    allocate( vht_0(ML_0:ML_1)             ) ; vht_0=0.0d0
  END SUBROUTINE init_diff_vrho_scf

  SUBROUTINE diff_vrho_scf( disp_switch )
    implicit none
    logical,intent(IN) :: disp_switch
    integer :: i,j,m,ierr
    real(8) :: dtmp_0,dtmp_1

    diff_vrho(:)=0.0d0

    do i=MSP_0,MSP_1
       diff_vrho(i+0) = sum( (rho(:,i)-rho_0(:,i))**2 )
       diff_vrho(i+2) = sum( (Vxc(:,i)-vxc_0(:,i))**2 )
    end do

    m=MSP_1-MSP_0+1
    call rsdft_allgather( diff_vrho(MSP_0:MSP_1), diff_vrho, comm_spin )
    call rsdft_allgather( diff_vrho(MSP_0+2:MSP_1+2),diff_vrho(3:4),comm_spin )

    diff_vrho(5) = sum( (Vh(:)-vht_0(:))**2 )

    do i=ML_0,ML_1

       dtmp_1=0.0d0
       dtmp_0=0.0d0
       do j=1,MSP
          dtmp_1 = dtmp_1 + rho(i,j)
          dtmp_0 = dtmp_0 + rho_0(i,j)
       end do
       diff_vrho(6) = diff_vrho(6) + (dtmp_1-dtmp_0)**2

       dtmp_1=0.0d0
       dtmp_0=0.0d0
       do j=1,MSP
          dtmp_1 = dtmp_1 - rho(i,j)
          dtmp_0 = dtmp_0 - rho_0(i,j)
       end do
       diff_vrho(7) = diff_vrho(7) + (dtmp_1-dtmp_0)**2

    end do ! i

    diff_vrho(:)=diff_vrho(:)/ML
    call rsdft_allreduce_sum( diff_vrho, comm_grid )

    if ( disp_switch ) then
       do i=1,MSP
          write(*,'(1x,"diff_rho(",i1,"/",i1,")=",g12.5)') i,MSP,diff_vrho(i)
       end do
       write(*,'(1x,"diff_tod     =",g12.5)') diff_vrho(6)
       write(*,'(1x,"diff_spd     =",g12.5)') diff_vrho(7)
       do i=1,MSP
          write(*,'(1x,"diff_vxc(",i1,"/",i1,")=",g12.5)') i,MSP,diff_vrho(2+i)
       end do
       write(*,'(1x,"diff_vht     =",g12.5)') diff_vrho(5)
    end if

    do i=MSP_0,MSP_1
       rho_0(:,i) = rho(:,i)
       vxc_0(:,i) = Vxc(:,i)
    end do
    vht_0(:) = Vh(:)

  END SUBROUTINE diff_vrho_scf

  SUBROUTINE end_diff_vrho_scf
    implicit none
    deallocate( vht_0 )
    deallocate( vxc_0 )
    deallocate( rho_0 )
  END SUBROUTINE end_diff_vrho_scf

END MODULE scf_module


      SUBROUTINE ITER  (H, W, EE, FULSCF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES/NOLIST'
      PARAMETER (MPULAY=MPACK)
*
* MPULAY IS USED IN THE PULAY CONVERGER. IT SHOULD BE AS LARGE AS
*        CONVENIENT, PREFERABLY 10 TO 20 TIMES SIZE OF A NORMAL
*        DENSITY MATRIX. IF SPACE IS LIMITED, 2 TIMES MPACK WILL
*        SUFFICE.
*
      DIMENSION H(*), W(*)
      COMMON /FOKMAT/ F(MPACK), FB(MPACK)
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB)
      COMMON /GRADNT/ DUMY(MAXPAR),GNORM
      COMMON /LAST  / LAST
      COMMON /MESAGE/ IFLEPO,IITER
      COMMON /CITERM/ XI,XJ,XK
      COMMON /PATH  / LATOM,LPARAM,REACT(100)
      COMMON /NUMCAL/ NUMCAL
      COMMON /TIME  / TIME0
      LOGICAL FULSCF
C***********************************************************************
C
C     ITER GENERATES A SCF FIELD AND RETURNS THE ENERGY IN "ENERGY"
C
C THE MAIN ARRAYS USED IN ITER ARE:
C            P      ONLY EVER CONTAINS THE TOTAL DENSITY MATRIX
C            PA     ONLY EVER CONTAINS THE ALPHA DENSITY MATRIX
C            PB     ONLY EVER CONTAINS THE BETA DENSITY MATRIX
C            C      ONLY EVER CONTAINS THE EIGENVECTORS
C            H      ONLY EVER CONTAINS THE ONE-ELECTRON MATRIX
C            F      STARTS OFF CONTAINING THE ONE-ELECTRON MATRIX,
C                   AND IS USED TO HOLD THE FOCK MATRIX
C            W      ONLY EVER CONTAINS THE TWO-ELECTRON MATRIX
C
C THE MAIN INTEGERS CONSTANTS IN ITER ARE:
C
C            LINEAR SIZE OF PACKED TRIANGLE = NORBS*(NORBS+1)/2
C
C THE MAIN INTEGER VARIABLES ARE
C            NITER  NUMBER OF ITERATIONS EXECUTED
C
C  PRINCIPAL REFERENCES:
C
C   ON MNDO: "GROUND STATES OF MOLECULES. 38. THE MNDO METHOD.
C             APPROXIMATIONS AND PARAMETERS."
C             DEWAR, M.J.S., THIEL,W., J. AM. CHEM. SOC., 99, 4899, (1977).
C   ON SHIFT: "UNCONDITIONAL CONVERGENCE IN SCF THEORY: A GENERAL LEVEL
C             SHIFT TECHNIQUE"
C             CARBO, R., HERNANDEZ, J.A., SANZ, F., CHEM. PHYS. LETT.,
C             47, 581, (1977)
C   ON HALF-ELECTRON: "MINDO/3 COMPARISON OF THE GENERALISED S.C.F. COUPLING
C             OPERATOR AND "HALF-ELECTRON" METHODS FOR CALCULATING THE
C             ENERGIES AND GEOMETRIES OF OPEN SHELL SYSTEMS"
C             DEWAR, M.J.S., OLIVELLA, S., J. AM. CHEM. SOC., 75, 829, (1979).
C   ON PULAY'S CONVERGER: "CONVERGANCE ACCELERATION OF ITERATIVE SEQUENCES.
C             THE CASE OF SCF ITERATION", PULAY, P., CHEM. PHYS. LETT,
C             73, 393, (1980).
C   ON PSEUDODIAGONALISATION: "FAST SEMIEMPIRICAL CALCULATIONS",
C             STEWART. J.J.P., CSASZAR, P., PULAY, P., J. COMP. CHEM.,
C             3, 227, (1982)
C
C***********************************************************************
      DIMENSION POLD(MPULAY), POLD2(MPULAY), POLD3(400)
      DIMENSION PBOLD(MPULAY), PBOLD2(MPULAY), PBOLD3(400)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     +                NLAST(NUMATM), NORBS, NELECS,
     1                NALPHA, NBETA, NCLOSE, NOPEN
     2      /MOLORB/ DUMMY(MAXORB),PDIAG(MAXORB)
     3      /KEYWRD/ KEYWRD
     4      /NUMSCF/ NSCF
      CHARACTER KEYWRD*80, ABPRT(3)*5
      LOGICAL PRTFOK,PRTEIG,PRTDEN, DEBUG, PRTENG, TIMES, CI
     +,UHF, NEWDG, SCF1, HALFE, TRIPLT, FORCE, PRT1EL,PRTPL, OKNEWD
     1,EXCITD, MINPRT, FRST, BFRST, OKPULY, READY, PRTVEC
      DATA ICALCN/0/, DEBUG/.FALSE./, PRTFOK/.FALSE./
      DATA PRTEIG/.FALSE./,PRTDEN,PRTENG/.FALSE.,.FALSE./
      DATA PRT1EL/.FALSE./
      DATA ABPRT/'     ','ALPHA',' BETA'/
C
C  INITIALIZE
C
      NITER=0
      EEOLD=1.D8
      READY=.FALSE.
      IITER=1
            IF (ICALCN.NE.NUMCAL) THEN
            ICALCN=NUMCAL
C    SET UP INITITAL DENSITY MATRIX
            LINEAR=(NORBS*(NORBS+1))/2
            IF( INDEX(KEYWRD,'ITER') .NE. 0 ) DEBUG  = .TRUE.
            MINPRT=(INDEX(KEYWRD,'SADDLE')+
     +      LATOM .EQ.0 .OR. DEBUG)
                IF( INDEX(KEYWRD,'EIGS') .NE. 0 ) PRTEIG = .TRUE.
                IF( INDEX(KEYWRD,'ENERGY').NE.0 ) PRTENG = .TRUE.
                IF( INDEX(KEYWRD,' PL ')  .NE.0 ) PRTPL  = .TRUE.
            IF( INDEX(KEYWRD,'DEBUG').NE. 0 ) THEN
                IF( INDEX(KEYWRD,'1ELEC') .NE.0 ) PRT1EL = .TRUE.
                IF( INDEX(KEYWRD,'DENSITY').NE.0) PRTDEN = .TRUE.
                IF( INDEX(KEYWRD,'FOCK') .NE. 0 ) PRTFOK = .TRUE.
                IF( INDEX(KEYWRD,'VECT') .NE. 0 ) PRTVEC = .TRUE.
            END IF
            NEWDG=.FALSE.
            PL=1.D0
            I=INDEX(KEYWRD,'FILL=')
            IF(I.NE.0) IFILL=-READA(KEYWRD,I)
            I=INDEX(KEYWRD,'SHIFT')
            IF(I.NE.0) BSHIFT=-READA(KEYWRD,I)
            BSHIFT=0.D0
            OKNEWD=ABS(BSHIFT) .LT. 0.001D0
            CI=(INDEX(KEYWRD,'C.I.') .NE. 0)
            OKPULY=(INDEX(KEYWRD,'PULAY').NE.0)
            UHF=(INDEX(KEYWRD,'UHF') .NE. 0)
            TRANS=0.1D0
          I=0
          IF(INDEX(KEYWRD,'RESTART')+INDEX(KEYWRD,'OLDENS')
     +      .NE. 0) THEN
              REWIND 10
              READ(10)(PA(I),I=1,LINEAR)
              IF(UHF)READ(10)(PB(I),I=1,LINEAR)
              I=1
          ENDIF
          IF(I.EQ.1.OR.INDEX(KEYWRD,'RESTART') .NE. 0) THEN
              IF( UHF) THEN
                  DO 11 I=1,LINEAR
  11                  P(I)=PA(I)+PB(I)
              ELSE
                  DO 10 I=1,LINEAR
  10                  P(I)=PA(I)*2.D0
              ENDIF
          ELSE
          IF(INDEX(KEYWRD,'PARAM') .EQ. 0)THEN
                  DO 12 I=1,LINEAR
                    P(I)=0.D0
                    PA(I)=0.D0
  12                PB(I)=0.D0
                    W1=NALPHA/(NALPHA+1.D-6+NBETA)
                    W2=NBETA/(NALPHA+1.D-6+NBETA)
                    IF(W1.LT.1.D-6)W1=0.5D0
                    IF(W2.LT.1.D-6)W2=0.5D0
                    RANDOM=1.0D0
                    IF(UHF .AND. NALPHA.EQ.NBETA) RANDOM=1.02D0
                  DO 14 I=1,NORBS
                    J=(I*(I+1))/2
                    P(J)=PDIAG(I)
                    PA(J)=P(J)*W1*RANDOM
                  RANDOM=1.D0/RANDOM
  14              PB(J)=P(J)*W2*RANDOM
                  DO 18 I=1,LINEAR
                    PBOLD(I)=PB(I)
  18                POLD(I)=PA(I)
             ENDIF
          ENDIF
            SCF1=(INDEX(KEYWRD,'1SCF') .NE. 0)
            IF( .NOT. SCF1) SCF1=(INDEX(KEYWRD,'PARAM') .NE. 0)
            HALFE=(NOPEN .NE. NCLOSE)
            TRIPLT=(INDEX(KEYWRD,'TRIPLET') .NE. 0)
            EXCITD=(INDEX(KEYWRD,'EXCITED') .NE. 0)
            IF( HALFE ) THEN
                IF(NOPEN-NCLOSE.EQ.1) THEN
                    IHOMO=(NCLOSE-1)*NORBS+1
                    ILUMO=IHOMO+NORBS
                    ELSE
                    IPART1=NCLOSE*NORBS+1
                    IPART2=IPART1+NORBS
                ENDIF
        ENDIF
            SCFCRT=1.D-7
            PLTEST=0.00001D0
            IF(HALFE)SCFCRT=SCFCRT*0.0001D0
            FORCE=(INDEX(KEYWRD,'FORCE') .NE. 0)
            IF( FORCE ) SCFCRT=SCFCRT*0.01D0
            IF(INDEX(KEYWRD,'PREC') .NE. 0)SCFCRT=SCFCRT*0.01D0
            IF(SCFCRT.LT.1.D-9)SCFCRT=1.D-9
            I=INDEX(KEYWRD,'SCFCRT')
            IF(I.NE.0) THEN
                SCFCRT=READA(KEYWRD,I)
                WRITE(6,'(''  SCF CRITERION ='',F13.9)')SCFCRT
                ELSE
                IF(DEBUG)WRITE(6,'(''  SCF CRITERION ='',F13.9)')SCFCRT
            ENDIF
            TIMES=(INDEX(KEYWRD,'TIMES') .NE. 0)
            NSCF=0
            ITRMAX = 200
            IF( UHF ) THEN
                NOCC = NALPHA
                NVIR = NORBS-NALPHA
                NOCCB= NBETA
                NVIRB= NORBS-NOCCB
                IF(DEBUG)WRITE(6,'('' NALPHA,NBETA'',2I6)')NALPHA,NBETA
            ELSE
                PLB=0.D0
                NOCC=NCLOSE
            ENDIF
      LAST=0
      END IF
      IF(NEWDG) NEWDG=(ABS(BSHIFT).LT.0.001D0)
      IF(LAST.EQ.1) NEWDG=.FALSE.
      SELCON=SCFCRT
      IF(.NOT. HALFE) THEN
      IF(GNORM.GT.5.D0) SELCON=SCFCRT*GNORM*0.2D0
      IF(GNORM.GT.200.D0) SELCON=SCFCRT*50.D0
      ENDIF
      IF(DEBUG)WRITE(6,'(''  SELCON, GNORM'',2F16.7)')SELCON,GNORM
      TITER1=SECOND()
      IF(PRT1EL) THEN
          WRITE(6,'(//10X,''ONE-ELECTRON MATRIX AT ENTRANCE TO ITER'')')
          CALL VECPRT(H,NORBS)
      ENDIF
      TIME1=SECOND()
      FRST=.TRUE.
      BFRST=.TRUE.
**********************************************************************
*                                                                    *
*                                                                    *
*                START THE SCF LOOP HERE                             *
*                                                                    *
*                                                                    *
**********************************************************************
   40 NITER=NITER+1
C
      IF(BSHIFT .NE. 0.D0) THEN
          L=0
        SHIFT=BSHIFT*(NITER+1.D0)**(-1.5D0)+2.D0*COS
          DO 49 I=1,NORBS
              DO 53 J=1,I
                  L=L+1
  53          F(L)=H(L)+SHIFT*PA(L)
  49      F(L)=F(L)-SHIFT
      ELSE
          DO 50 I=1,LINEAR
   50         F(I)=H(I)
      ENDIF
C
C *** CONSTRUCT THE F-MATRIX.
C
      IF (UHF) THEN
          CALL FOCK2(F,P,PA,W,NUMAT,NFIRST,NLAST)
          CALL FOCK1(F,P,PA,PB)
          IF(SHIFT .NE. 0.D0) THEN
              L=0
              DO 58 I=1,NORBS
                  DO 59 J=1,I
                      L=L+1
  59              FB(L)=H(L)+SHIFT*PB(L)
  58          FB(L)=FB(L)-SHIFT
          ELSE
              DO 57 I=1,LINEAR
   57             FB(I)=H(I)
          ENDIF
          CALL FOCK2(FB,P,PB,W,NUMAT,NFIRST,NLAST)
          CALL FOCK1(FB,P,PB,PA)
      ELSE
          CALL FOCK2(F,P,PA,W,NUMAT,NFIRST,NLAST)
          CALL FOCK1(F,P,PA,PA)
      ENDIF
      IF( .NOT. FULSCF) GOTO 63
      IF(PRTFOK) THEN
            WRITE(6,308)NITER
  308       FORMAT('   FOCK MATRIX ON ITERATION',I3)
            CALL VECPRT (F,NORBS)
      END IF
C
C
C *** DIAGONALISE THE F-MATRIX.
C
C#         IF(FRST)WRITE(6,'('' SWITCHING TO PULAY'')')
      EE=HELECT(NORBS,PA,H,F)
      IF(UHF)THEN
      SUM2=HELECT(NORBS,PB,H,FB)
C#      WRITE(6,'('' ELECTRONIC ENERGY:'',3E20.12)')EE,SUM2,EE+SUM2
      EE=EE+SUM2
      ELSE
C#      WRITE(6,'('' ELECTRONIC ENERGY:'', E22.14)')EE*2.D0
      ENDIF
      IF(PL.LT.PLTEST.AND.ABS(EE-EEOLD).LT.SELCON .AND. READY) GOTO 63
      READY=(ABS(EE-EEOLD).LT.SELCON*10.D0)
      EEOLD=EE
      IF( NEWDG ) THEN
      IF(OKPULY)
     +CALL PULAY(F,PA,NORBS,POLD,POLD2,POLD3,JALP,IALP,MPULAY,FRST,PL)
*
*   TEST PL TO SEE IF SCF FIELD ACCEPTABLE. EXIT IF O.K. SO THAT
*   DENSITY MATRICES ARE THOSE THAT GIVE RISE TO THE FOCK MATRICES,
*   AND NOT VICE-VERSA.
*
C#      IF(PRTPL)
C#     +WRITE(6,'('' ITERATION'',I3,'' PLS='',2E12.4)')NITER,PL
C#      IF(PL.LT.SELCON) GOTO 63
            IF (HALFE) THEN
                CALL HQRII(F,NORBS,NORBS,EIGS,C)
            ELSE
                CALL DIAG (F,C,NOCC,EIGS,NORBS,NORBS)
            ENDIF
C#      WRITE(6,'('' ELECTRONIC ENERGY AFTER DIAG:'',F19.12)')
C#     +HELECT(NORBS,PA,H,F)
            ELSE
            CALL HQRII(F,NORBS,NORBS,EIGS,C)
      END IF
C
      IF(PRTVEC) THEN
      J=1
      IF(UHF)J=2
      WRITE(6,'(//10X,A,
     +'' EIGENVECTORS AND EIGNEVALUES ON ITERATION'',I3)')
     +   ABPRT(J),NITER
      CALL MATOUT(C,EIGS,NORBS,NORBS,NORBS)
      ELSE
      IF (PRTEIG) WRITE(6,311)ABPRT(J),NITER,(EIGS(I),I=1,NORBS)
      ENDIF
  311       FORMAT(10X,A,'  EIGENVALUES ON ITERATION',I3,/10(6F13.6,/))
C
C *** COMPUTE THE BOND-ORDERS
C
      IF( UHF ) THEN
          I=0
          CALL DENSTY( C,NORBS, NORBS, I, NALPHA, PA)
          IF(.NOT. (NEWDG.AND.OKPULY))
     +    CALL CNVG(PA, POLD, POLD2, NORBS, NITER, PL)
          IF (NEWDG.AND.OKPULY) THEN
          CALL PULAY(FB,PB,NORBS,PBOLD,PBOLD2,
     +               PBOLD3,JBET,IBET,MPULAY,BFRST,PLB)
                CALL DIAG (FB,CBETA,NOCCB,EIGB,NORBS,NORBS)
                ELSE
                CALL HQRII(FB,NORBS,NORBS,EIGB,CBETA)
          END IF
      IF(PRTVEC) THEN
      J=1
      IF(UHF) J=3
      WRITE(6,'(//10X,A,
     +'' EIGENVECTORS AND EIGNEVALUES ON ITERATION'',I3)')
     +   ABPRT(J),NITER
      CALL MATOUT(CBETA,EIGB,NORBS,NORBS,NORBS)
      ELSE
      IF (PRTEIG) WRITE(6,311)ABPRT(J),NITER,(EIGB(I),I=1,NORBS)
      ENDIF
          I=0
          CALL DENSTY( CBETA,NORBS, NORBS, I, NBETA, PB)
          IF( .NOT. (NEWDG.AND.OKPULY))
     +      CALL CNVG(PB, PBOLD, PBOLD2, NORBS, NITER, PLB)
          DO 60 I=1,LINEAR
  60           P(I)=PA(I)+PB(I)
      ELSE
          IF(IFILL.NE.0)CALL SWAP(C,NORBS,NORBS,NCLOSE,IFILL)
          CALL DENSTY( C,NORBS, NORBS, NCLOSE, NOPEN, P)
          IF(.NOT.(NEWDG.AND.OKPULY)) THEN
              CALL CNVG(P, POLD, POLD2, NORBS, NITER, PL)
          ENDIF
          DO 51 I=1,LINEAR
  51      PA(I)=P(I)*0.5D0
C#      WRITE(6,'('' ELECTRONIC ENERGY AFTER DENSITY:'',F19.12)')
C#     +HELECT(NORBS,PA,H,F)
      ENDIF
      IF(PRTDEN) THEN
            WRITE(6,'('' DENSITY MATRIX ON ITERATION'',I4)')NITER
            CALL VECPRT (P,NORBS)
      END IF
              IF(PRTPL)
     +        WRITE(6,'('' ITERATION'',I3,'' PLS='',2E12.4)')
     +        NITER,PL,PLB
      OKNEWD=(PL.LT.SELCON .OR. OKNEWD)
      NEWDG=(PL.LT.TRANS .AND. OKNEWD .OR. NEWDG)
      IF(PL.LT.TRANS*0.3333D0)THEN
      OKNEWD=.TRUE.
      ENDIF
C
      IF (NITER .GE. ITRMAX) THEN
            IF(MINPRT)WRITE (6,260)
  260 FORMAT (//10X,'"""""""""""""UNABLE TO ACHIEVE SELF-CONSISTENCE'
     1,/)
            WRITE (6,270) DELTA,PL
  270       FORMAT (//,10X,  8HDELTAE= ,F15.7,5X,  8HDELTAP= ,F15.7,///)
C#          IF(PL .GT. 0.1D0) THEN
              IFLEPO=9
              IITER=2
              CALL WRITE (TIME0,ESCF)
              STOP
C#          ENDIF
C#      GOTO 63
      END IF
      GO TO 40
**********************************************************************
*                                                                    *
*                                                                    *
*                      END THE SCF LOOP HERE                         *
*                NOW CALCULATE THE ELECTRONIC ENERGY                 *
*                                                                    *
*                                                                    *
**********************************************************************
*          SELF-CONSISTENCE ACHEIVED.
*
  63  EE=HELECT(NORBS,PA,H,F)
C#      WRITE(6,'(''  EE AFTER SCF'',F19.11)')EE
      IF(UHF) THEN
          EE=EE+HELECT(NORBS,PB,H,FB)
          ELSE
          EE=EE*2.D0
          ENDIF
      IF( CI .OR. SCF1 .OR. HALFE ) THEN
C
C  PUT F AND FB INTO POLD IN ORDER TO NOT DESTROY F AND FB
C  AND DO EXACT DIAGONALISATIONS
            DO 65 I=1,LINEAR
  65        POLD(I)=F(I)
            CALL HQRII(POLD,NORBS,NORBS,EIGS,C)
            IF(UHF) THEN
                DO 66 I=1,LINEAR
  66            POLD(I)=FB(I)
                CALL HQRII(POLD,NORBS,NORBS,EIGB,CBETA)
            ENDIF
       ENDIF
       IF( HALFE ) THEN
          IF(NOPEN-NCLOSE.EQ.1) THEN
              XI=SPCG(C(ILUMO),C(ILUMO),C(ILUMO),C(ILUMO),W)
              EE=EE-0.25D0*XI
              ELSE
              XI=SPCG(C(IPART1),C(IPART1),C(IPART1),C(IPART1),W)
              XJ=SPCG(C(IPART2),C(IPART2),C(IPART2),C(IPART2),W)
              XK=SPCG(C(IPART1),C(IPART2),C(IPART2),C(IPART1),W)
              IF( TRIPLT )THEN
                EE=EE-0.25D0*(XI+XJ) -0.5D0 *XK
                ELSE
*
*  C.I. MUST BE USED WITH BIRADICAL SINGLETS.
*
                  EE=EE-0.25D0*(XI+XJ) +1.5D0 *XK
                  EE=OPCI(EE,XI,XJ,XK)
                ENDIF
          ENDIF
          ELSE
          IF( CI ) EE=OPCI(EE,XI,XJ,XK)
C#      WRITE(6,'(/10X,''  EE AFTER C.I.:'',F19.12)')EE
      ENDIF
            NSCF=NSCF+1
            TITER2=SECOND()
            IF(TIMES) WRITE(6,'('' TIME FOR SCF CALCULATION'',F8.2,
     +''    INTEGRAL'',F8.2)')TITER2-TITER1,TITER2-TIME0
            IF(DEBUG)WRITE(6,'('' NO. OF ITERATIONS ='',I3)')NITER
C            IF(FORCE)  SCFCRT=1.D-5
      IF(HALFE) BSHIFT=0.D0
      RETURN
C
      END


      SUBROUTINE outpd(I,NT,NE,NAX,NDX,NTX,NEX,NHW,NHE,NVN,NVS)
C
C     THIS SUBROUTINE WRITES DAILY OUTPUT FOR PLANT
C     C, N, P, WATER AND HEAT TO OUTPUT FILES DEPENDING
C     ON SELECTIONS MADE IN OUTPUT CONTROL FILES IN
C     THE RUN SCRIPT
C
      include "parameters.h"
      include "filec.h"
      include "files.h"
      include "blkc.h"
      include "blk1cp.h"
      include "blk1cr.h"
      include "blk1g.h"
      include "blk1n.h"
      include "blk1p.h"
      include "blk3.h"
      include "blk8a.h"
      include "blk8b.h"
      include "blk9a.h"
      include "blk9b.h"
      include "blk9c.h"
      include "blk12a.h"
      include "blk12b.h"
      include "blk14.h"
      CHARACTER*16 DATA(30),DATAC(30,250,250),DATAP(JP,JY,JX)
     2,DATAM(JP,JY,JX),DATAX(JP),DATAY(JP),DATAZ(JP,JY,JX)
     3,OUTS(10),OUTP(10),OUTFILS(10,JY,JX),OUTFILP(10,JP,JY,JX)
      CHARACTER*3 CHOICE(102,20)
      CHARACTER*8 CDATE
      CHARACTER*16 CHEAD
      DIMENSION HEAD(50)
      DO 1040 N=26,30
      IF(DATAC(N,NE,NEX).NE.'NO')THEN
      DO 1010 M=1,50
      HEAD(M)=0.0
1010  CONTINUE
      LUN=N+20
      DO 9995 NX=NHW,NHE
      DO 9990 NY=NVN,NVS
      DO 9985 NZ=1,NP0(NY,NX)
      IF(IFLGC(NZ,NY,NX).EQ.1)THEN
C
C     WRITE DAILY CROP DATA TO OUTPUT FILES
C
      M=0
C
C     DAILY PLANT C OUTPUT
C
      IF(N.EQ.26)THEN
      IF(I.GE.IDATA(N).AND.I.LE.IDATA(N+20))THEN
      DO 1026 K=51,100
      IF(CHOICE(K,N-20).EQ.'YES')THEN
      M=M+1
      IF(K.EQ.51)HEAD(M)=WTSHT(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.52)HEAD(M)=WTLF(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.53)HEAD(M)=WTSHE(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.54)HEAD(M)=WTSTK(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.55)HEAD(M)=WTRSV(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.56)HEAD(M)=(WTHSK(NZ,NY,NX)+WTEAR(NZ,NY,NX))
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.57)HEAD(M)=WTGR(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.58)HEAD(M)=WTRT(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.59)HEAD(M)=WTND(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.60)HEAD(M)=WTRVC(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.61)HEAD(M)=GRNO(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.62)HEAD(M)=ARLFS(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.63)HEAD(M)=CARBN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.64)HEAD(M)=TCUPTK(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.65)HEAD(M)=TCSNC(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.66)HEAD(M)=TCSN0(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.67)HEAD(M)=TCO2T(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.68)HEAD(M)=TCO2A(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.69)HEAD(M)=CCPOLP(NZ,NY,NX)
      IF(K.EQ.70)HEAD(M)=HVSTC(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.71)HEAD(M)=RTDNP(1,1,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.72)HEAD(M)=RTDNP(1,2,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.73)HEAD(M)=RTDNP(1,3,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.74)HEAD(M)=RTDNP(1,4,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.75)HEAD(M)=RTDNP(1,5,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.76)HEAD(M)=RTDNP(1,6,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.77)HEAD(M)=RTDNP(1,7,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.78)HEAD(M)=RTDNP(1,8,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.79)HEAD(M)=RTDNP(1,9,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.80)HEAD(M)=RTDNP(1,10,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.81)HEAD(M)=RTDNP(1,11,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.82)HEAD(M)=RTDNP(1,12,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.83)HEAD(M)=RTDNP(1,13,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.84)HEAD(M)=RTDNP(1,14,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.85)HEAD(M)=RTDNP(1,15,NZ,NY,NX)*PP(NZ,NY,NX)
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.86)HEAD(M)=BALC(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.87)HEAD(M)=WTSTG(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.88)HEAD(M)=VCO2F(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.89)HEAD(M)=VCH4F(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.90)HEAD(M)=ZNPP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.91)HEAD(M)=ZC(NZ,NY,NX)
      IF(K.EQ.92)HEAD(M)=PP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      ENDIF
1026  CONTINUE
      WRITE(LUN,'(A16,F8.3,4X,A8,50E16.7E3)')OUTFILP(N-20,NZ,NY,NX)
     2,DOY,CDATE,(HEAD(K),K=1,M)
      ENDIF
      ENDIF
C
C     DAILY PLANT WATER OUTPUT
C
      IF(N.EQ.27)THEN
      IF(I.GE.IDATA(N).AND.I.LE.IDATA(N+20))THEN
      DO 1027 K=51,100
      IF(CHOICE(K,N-20).EQ.'YES')THEN
      M=M+1
      IF(K.EQ.51)HEAD(M)=-CTRAN(NZ,NY,NX)
     2*1000.0/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.52)HEAD(M)=WSTR(NZ,NY,NX)
      IF(K.EQ.53)HEAD(M)=OSTR(NZ,NY,NX)
      ENDIF
1027  CONTINUE
      WRITE(LUN,'(A16,F8.3,4X,A8,50E16.7E3)')OUTFILP(N-20,NZ,NY,NX)
     2,DOY,CDATE,(HEAD(K),K=1,M)
      ENDIF
      ENDIF
C
C     DAILY PLANT N OUTPUT
C
      IF(N.EQ.28)THEN
      IF(I.GE.IDATA(N).AND.I.LE.IDATA(N+20))THEN
      DO 1028 K=51,100
      IF(CHOICE(K,N-20).EQ.'YES')THEN
      M=M+1
      IF(K.EQ.51)HEAD(M)=WTSHN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.52)HEAD(M)=WTLFN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.53)HEAD(M)=WTSHEN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.54)HEAD(M)=WTSTKN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.55)HEAD(M)=WTRSVN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.56)HEAD(M)=(WTHSKN(NZ,NY,NX)+WTEARN(NZ,NY,NX))
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.57)HEAD(M)=WTGRNN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.58)HEAD(M)=WTRTN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.59)HEAD(M)=WTNDN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.60)HEAD(M)=WTRVN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.61)HEAD(M)=TZUPTK(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.62)HEAD(M)=TZSNC(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.63)HEAD(M)=TZUPFX(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.64)HEAD(M)=CZPOLP(NZ,NY,NX)
      IF(K.EQ.65)THEN
      IF(WTLF(NZ,NY,NX).GT.ZEROP(NZ,NY,NX))THEN
      HEAD(M)=(WTLFN(NZ,NY,NX)+ZPOOLP(NZ,NY,NX))
     2/(WTLF(NZ,NY,NX)+CPOOLP(NZ,NY,NX))
      ELSE
      HEAD(M)=0.0
      ENDIF
      ENDIF
      IF(K.EQ.66)HEAD(M)=CPPOLP(NZ,NY,NX)
      IF(K.EQ.67)THEN
      IF(WTLF(NZ,NY,NX).GT.ZEROP(NZ,NY,NX))THEN
      HEAD(M)=(WTLFP(NZ,NY,NX)+PPOOLP(NZ,NY,NX))
     2/(WTLF(NZ,NY,NX)+CPOOLP(NZ,NY,NX))
      ELSE
      HEAD(M)=0.0
      ENDIF
      ENDIF
      IF(K.EQ.68)HEAD(M)=TNH3C(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.69)HEAD(M)=HVSTN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.70)HEAD(M)=BALN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.71)HEAD(M)=WTSTGN(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.72)HEAD(M)=VNH3F(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.73)HEAD(M)=TZSN0(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      ENDIF
1028  CONTINUE
      WRITE(LUN,'(A16,F8.3,4X,A8,50E16.7E3)')OUTFILP(N-20,NZ,NY,NX)
     2,DOY,CDATE,(HEAD(K),K=1,M)
      ENDIF
      ENDIF
C
C     DAILY PLANT P OUTPUT
C
      IF(N.EQ.29)THEN
      IF(I.GE.IDATA(N).AND.I.LE.IDATA(N+20))THEN
      DO 1029 K=51,100
      IF(CHOICE(K,N-20).EQ.'YES')THEN
      M=M+1
      IF(K.EQ.51)HEAD(M)=WTSHP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.52)HEAD(M)=WTLFP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.53)HEAD(M)=WTSHEP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.54)HEAD(M)=WTSTKP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.55)HEAD(M)=WTRSVP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.56)HEAD(M)=(WTHSKP(NZ,NY,NX)+WTEARP(NZ,NY,NX))
     2/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.57)HEAD(M)=WTGRNP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.58)HEAD(M)=WTRTP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.59)HEAD(M)=WTNDP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.60)HEAD(M)=WTRVP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.61)HEAD(M)=TPUPTK(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.62)HEAD(M)=TPSNC(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.63)HEAD(M)=CPPOLP(NZ,NY,NX)
      IF(K.EQ.64)THEN
      IF(WTLF(NZ,NY,NX).GT.ZEROP(NZ,NY,NX))THEN
      HEAD(M)=(WTLFP(NZ,NY,NX)+PPOOLP(NZ,NY,NX))
     2/(WTLF(NZ,NY,NX)+CPOOLP(NZ,NY,NX))
      ELSE
      HEAD(M)=0.0
      ENDIF
      ENDIF
      IF(K.EQ.65)HEAD(M)=HVSTP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.66)HEAD(M)=BALP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.67)HEAD(M)=WTSTGP(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.68)HEAD(M)=VPO4F(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      IF(K.EQ.69)HEAD(M)=TPSN0(NZ,NY,NX)/AREA(3,NU(NY,NX),NY,NX)
      ENDIF
1029  CONTINUE
      WRITE(LUN,'(A16,F8.3,4X,A8,50E16.7E3)')OUTFILP(N-20,NZ,NY,NX)
     2,DOY,CDATE,(HEAD(K),K=1,M)
      ENDIF
      ENDIF
C
C     DAILY PLANT HEAT OUTPUT
C
      IF(N.EQ.30)THEN
      IF(I.GE.IDATA(N).AND.I.LE.IDATA(N+20))THEN
      CHEAD=' '
      DO 1030 K=51,100
      IF(CHOICE(K,N-20).EQ.'YES')THEN
      M=M+1
      IF(K.EQ.51)THEN
      DO 2030 KN=10,0,-1
      IF(KN.EQ.0)THEN
      CHEAD='  PLANTING'
      GO TO 1030
      ELSE
      IF(IDAY(KN,NB1(NZ,NY,NX),NZ,NY,NX).EQ.0)THEN
      GO TO 2030
      ELSE
      IF(KN.EQ.1)CHEAD='  EMERGENCE'
      IF(KN.EQ.2)CHEAD='  FLORAL_INIT.'
      IF(KN.EQ.3)CHEAD='  JOINTING'
      IF(KN.EQ.4)CHEAD='  ELONGATION'
      IF(KN.EQ.5)CHEAD='  HEADING'
      IF(KN.EQ.6)CHEAD='  ANTHESIS'
      IF(KN.EQ.7)CHEAD='  SEED_FILL'
      IF(KN.EQ.8)CHEAD='  SEED_NO._SET'
      IF(KN.EQ.9)CHEAD='  SEED_MASS_SET'
      IF(KN.EQ.10)CHEAD='  END_SEED_FILL'
      GO TO 1030
      ENDIF
      ENDIF
2030  CONTINUE
      ENDIF
      IF(K.EQ.52)IHEAD=NBR(NZ,NY,NX)
      IF(K.EQ.53)HEAD(M)=VSTG(NB1(NZ,NY,NX),NZ,NY,NX)
      IF(K.EQ.54)HEAD(M)=FDBK(NB1(NZ,NY,NX),NZ,NY,NX)
      IF(K.EQ.55)THEN
      IF(WTLF(NZ,NY,NX).GT.ZEROP(NZ,NY,NX))THEN
      HEAD(M)=(WTLFN(NZ,NY,NX)+ZPOOLP(NZ,NY,NX))
     2/(WTLF(NZ,NY,NX)+CPOOLP(NZ,NY,NX))
      ELSE
      HEAD(M)=0.0
      ENDIF
      ENDIF
      IF(K.EQ.56)THEN
      IF(WTLF(NZ,NY,NX).GT.ZEROP(NZ,NY,NX))THEN
      HEAD(M)=(WTLFP(NZ,NY,NX)+PPOOLP(NZ,NY,NX))
     2/(WTLF(NZ,NY,NX)+CPOOLP(NZ,NY,NX))
      ELSE
      HEAD(M)=0.0
      ENDIF
      ENDIF
      IF(K.EQ.57)HEAD(M)=PSILZ(NZ,NY,NX)
      IF(K.EQ.58)HEAD(M)=OSTR(NZ,NY,NX)
      IF(K.EQ.59)HEAD(M)=TFN3(NZ,NY,NX)
      ENDIF
1030  CONTINUE
      WRITE(LUN,'(A16,F8.3,4X,A8,A16,I16,50E16.7E3)')
     2OUTFILP(N-20,NZ,NY,NX),DOY,CDATE,CHEAD,IHEAD,(HEAD(K),K=3,M)
      ENDIF
      ENDIF
      ENDIF
9985  CONTINUE
9990  CONTINUE
9995  CONTINUE
      ENDIF
1040  CONTINUE
      RETURN
      END