********************************************************************************
*                                                                              * 
*  2DHF version 1-2003                                                         *
*  Copyright (C) 1996  Jacek Kobus, Leif Laaksonen, Dage Sundholm              *
*                                                                              *
*  This software may be used and distributed according to the terms            *
*  of the GNU General Public License, see README and COPYING.                  *
*                                                                              *
********************************************************************************
c ### wtdisk ### 
c     
c     Writes orbitals, potenials, Lagrange multipliers (diagonal 
c     and off-diagonal) and multipole expansion coefficients to a disk 
c     in an unformatted form

c     dump contains:  psi, pot, excp, eng, engo, 
c                     cmulti, excdi, excqm, excoc, exche
c
      subroutine wtdisk (cw_orb,cw_coul,cw_exch)
      implicit integer*4 (i-n)
      implicit real*8 (a-h,o-z)
      character*15 csub
      character*75 cmess
      include 'commons8.inc'
      dimension cw_orb(*),cw_coul(*),cw_exch(*)

      write(iout6,1050)

c     write a header into the orbital output file

      write(iout21,err=1000) header
      write(iout21,err=1000) datetime

      write(iout21,err=1000) ngrids,nni,nmu
      write(iout21,err=1000) r,rgrid
      write(iout21,err=1000) z1,z2	
      write(iout21,err=1000) norb,nel,nexch
      
      write (iout21,err=1000) i1b,i2b,i3b,i1e,i2e,i3e,
     &     i1si,i2si,i3si,i1ng,i2ng,i3ng,
     &     i1mu,i2mu,i3mu	
      
c     add orbitals

      do i=1,norb
         call writea(iout21,i1si(i),cw_orb(i1b(i)),ierr)
         if (ierr.ne.0) then
            write(iout6,*) 'error detected when writing orbital',i
            stop 'wtdisk'
         endif				   	
      enddo	   

c     append the following arrays to the output orbital file 

      write(iout21,err=1020) area
      write(iout21,err=1020) eng
      write(iout21,err=1020) engo
      write(iout21,err=1020) cmulti
      write(iout21,err=1020) excdi
      write(iout21,err=1020) excqu
      write(iout21,err=1020) excoc
      write(iout21,err=1020) exche
      write(iout21,err=1020) exc5
      write(iout21,err=1020) exc6
      write(iout21,err=1020) exc7
      write(iout21,err=1020) exc8

c     write out Coulomb potentials

      do i=1,norb
         call writea(iout22,i2si(i),cw_coul(i2b(i)),ierr)
         if (ierr.ne.0) then
            write(iout6,*) 'error detected when writing coulomb',
     &           ' potential',i
            stop 'wtdisk'
         endif				   	
      enddo	   

c     write out exchange potentials

      if (imethod.eq.1) then  
         if (iform.eq.2.or.iform.eq.3) then
            
            do iorb1=1,norb
               do iorb2=iorb1,norb
                  k=iorb1+iorb2*(iorb2-1)/2
                  if (iorb1.eq.iorb2.and.ll(iorb1).eq.0) goto 50
                  call writea(iout23,i3si(k),cw_exch(i3b(k)),ierr)
                  if (ierr.ne.0) then
                     write(iout6,*) 'error detected when writing ', 
     &                    'exchange potential',iorb1,iorb2,k
                     stop 'wtdisk'
                  endif				   	
                  if (iorb1.eq.iorb2) goto 50
                  if (ll(iorb1).eq.0.or.ll(iorb2).eq.0) goto 50
                  call writea(iout23,i3si(k),cw_exch(i3b(k)+i3si(k)),
     &                 ierr)
                  if (ierr.ne.0) then
                     write(iout6,*) 'error detected when writing ',
     &                    ' exchange potential',iorb1,iorb2,k
                     stop 'wtdisk'
                  endif				   	
 50               continue
               enddo
            enddo
            rewind(iout23)
            
c           if iform=0 exchange potentials do not have to be saved since 
c           they are continually updated during the scf process
            
         elseif (iform.eq.0.or.iform.eq.1) then
            if (iform.eq.1) then
               call wtdexch1(cw_exch)
            endif
         endif
         
      elseif (imethod.eq.3) then
         call writea(iout23,i3si(1),cw_exch(i3b(1)),ierr)
      endif

      rewind(iout21)
      rewind(iout22)
      rewind(iout23)

      csub='wtdisk'
      if(idbg(59).ne.0) then
c        print orbitals and coulomb potentials
	 do i=1,norb
            cmess='orbital '
            call dbgp (59,csub,cmess,cw_orb(i1b(i)),nni,i1mu(i))
	 enddo	   

	 do i=1,norb
            cmess='coulomb potential '
	    call dbgp (59,csub,cmess,cw_coul(i2b(i)),nni,i2mu(i))
	 enddo	   
         
c        print exchange potentials
	 do i=1,nexch
            cmess='exchange potential '       	 
	    call dbgp (59,csub,cmess,cw_exch(i3b(i)),nni,i3mu(i))
	 enddo	   
      endif
      return

 1000 continue
      write(iout6,1070)
      stop 'wtdisk'	
      
 1020 continue
      write(*,*) 'wtdisk: error has been encountered when writing ',
     &     'extension to disk file'
      write(*,*) '      '
      stop 'wtdisk'
 1050 format(1x,'... writing functions to disk ...')
 1070 format(//1x,'error! can not write data to disk'//)     
      end