C
C $Id: wrtchg.F,v 1.4 1998/07/16 16:40:51 jjv5 Exp $
C
C------------------------------------------------------------------------
      SUBROUTINE WRTCHG
C
C-RDC C     WRITES OUT ATOMIC CHARGES TO UNIT IOUT.
C
C     The following table shows which charges are assigned to
C     which array (* is wildcard, valid for both T(rue) and F(false),
C     - is not calculated) [this routine won't be called when
C     mcsim is True]
C
C     no.|mcsim | pme | cm1 | cm2  | Mulliken | CM1    | CM2
C     4   F       F     *     *      atchg      atchg2   atchg3
C     5   F       T     F     F      atchg      atchg2   atchg3
C     6   F       T     T     F      atchg2     atchg    atchg3
C     7   F       T     F     T      atchg3     atchg2   atchg
C

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#include "divcon.dim"
#include "divcon.h"
C
      logical sw1, sw2
      dimension pch(maxsub), pch2(maxsub), pch3(maxsub)
C
C
C-RDC       WRITE(IOUT,'(//"   ATOMIC CHARGES:",
C-RDC      .     //"   ATOM   ELEMENTAL  PARTIAL    ",
C-RDC      .       "PARTIAL    PARTIAL",
C-RDC      .     /"    NO.    SYMBOL    MULLIKEN   ",
C-RDC      .      "CM1        CM2",
C-RDC      .     /"                     CHARGE     ",
C-RDC      .      "CHARGE     CHARGE"/)')
C
      do icr=1,ncores
         pch(icr) = 0.0
         pch2(icr) = 0.0
         pch3(icr) = 0.0

C     .  i0 is the offset for the residue list and nresn is the
C     .  number of residues with ncore=ncore(icr)
         i0 = icorel1(icr)-1
         nresn = icorel1(icr+1)-icorel1(icr)
         do ir=1,nresn
            ires = icorel(ir+i0)
            i1 = irpnt(ires)
            i2 = irpnt(ires+1)-1
            do i=i1,i2
               pch(icr) = pch(icr) + atchg(i)
               pch2(icr) = pch2(icr) + atchg2(i)
               pch3(icr) = pch3(icr) + atchg3(i)
            enddo
         enddo
      enddo

      totmul = 0.0
      totcm1 = 0.0
      totcm2 = 0.0
      sw1 = cm1
      sw2 = cm2
      DO 100 I=1,NATOMS
        IAI = IATNUM(I)
        IF(IAI.EQ.0) GO TO 100
        if (sw1) then
C-RDC            WRITE(IOUT,'(1X,I5,7X,A2,3X,F9.5,3x,F9.5,3X,F9.5)')
C-RDC      &          I,SYMBOL(IAI),atchg2(i),atchg(i),atchg3(i)
           totmul = totmul + atchg2(i)
           totcm1 = totcm1 + atchg(i)
           totcm2 = totcm2 + atchg3(i)
        elseif (sw2) then
C-RDC            WRITE(IOUT,'(1X,I5,7X,A2,3X,F9.5,3x,F9.5,3X,F9.5)')
C-RDC      &          I,SYMBOL(IAI),atchg3(i),atchg2(i),atchg(i)
           totmul = totmul + atchg3(i)
           totcm1 = totcm1 + atchg2(i)
           totcm2 = totcm2 + atchg(i)
        else
C-RDC            WRITE(IOUT,'(1X,I5,7X,A2,3X,F9.5,3x,F9.5,3X,F9.5)')
C-RDC      &          I,SYMBOL(IAI),atchg(i),atchg2(i),atchg3(i)
           totmul = totmul + atchg(i)
           totcm1 = totcm1 + atchg2(i)
           totcm2 = totcm2 + atchg3(i)
        endif
 100  CONTINUE

      if (ncores.ge.1) then
C-RDC          write(iout,'(/34x,"MULLIKEN    CM1         CM2")')
      endif
      do icr=1,ncores
         if (sw1) then
C-RDC             write(iout,'(" CHARGE ON CLUSTSUB GROUP ",I4,": ",F9.5,3x,
C-RDC      &        F9.5,3x,F9.5)') icr, pch2(icr), pch(icr), pch3(icr)
         elseif (sw2) then
C-RDC             write(iout,'(" CHARGE ON CLUSTSUB GROUP ",I4,": ",F9.5,3x,
C-RDC      &        F9.5,3x,F9.5)') icr, pch3(icr), pch2(icr), pch(icr)
         else
C-RDC             write(iout,'(" CHARGE ON CLUSTSUB GROUP ",I4,": ",F9.5,3x,
C-RDC      &        F9.5,3x,F9.5)') icr, pch(icr), pch2(icr), pch3(icr)
         endif
      enddo
C-RDC       WRITE(IOUT,'(/" TOTAL MULLIKEN CHARGE = ",F8.4,
C-RDC      &     /" TOTAL CM1 CHARGE      = ",F8.4,
C-RDC      &     /" TOTAL CM2 CHARGE      = ",F8.4)')
C-RDC      &     totmul, totcm1, totcm2

      RETURN
      END

CC-------------------------------------------------------------CC

      subroutine wrtch
C
C-RDC C     computes and writes out atomic charges during mc run
C
      IMPLICIT double precision (A-H,O-Z)
#include "divcon.dim"
#include "divcon.h"
C
C     syntax: ch1 ch2 ch3 .. chn
C             totch
C
C     chi partial charge atom 1
C
      TOTCHG = 0.0D0
      DO 100 I=1,NATOMS
        IAI = IATNUM(I)
        IF(IAI.EQ.0) GO TO 100
        TOTCHG = TOTCHG + ATCHG(I)
 100  CONTINUE
C-RDC       write(ich,'(10f9.5)')
C-RDC      &     (atchg(i),i=1,natoms)
C-RDC       write(ich,'(f9.5)') totchg
      RETURN
      END