!-----------------------------------------------------------------------
!    Module:       prb_cntl_module
!    Author:       S. W. Bruenn
!    Date:         8/16/02
!-----------------------------------------------------------------------

MODULE prb_cntl_module

USE kind_module

!-----------------------------------------------------------------------
!
!             \\\\\ ZERO TRANSVERSE VELOCITY OPTION /////
!
!-----------------------------------------------------------------------
!  v_trans_0      : zero transverse velocity above shock switch
!
!     v_trans_0 = ye : transverse velocities 0 above shock
!     v_trans_0 = no : transverse velocities 0 above shock computed
!-----------------------------------------------------------------------

CHARACTER(LEN=2)                           :: v_trans_0

!-----------------------------------------------------------------------
!  Hydrodynamic Controls
!-----------------------------------------------------------------------
!  ihydro   : Hydrodynamics switch.
!
!     ihydro = 0   : hydrodynamics bypassed.
!     ihydro = 1   : hydrodynamics included.
!
!  irelhy   : Newtonian - GR hydrodynamics toggle.
!
!     irelhy = 0   : Newtonian hydrodynamics.
!     irelhy = 1   : PN hydrodynamics.
!     irelhy = 2   : general relativistic hydrodynamics.
!
!  ilapsehy : Newtonian - PN - GR lapse toggle.
!
!     ilapsehy = 0 : lapse = 1 in the hydrodynamics and transport.
!     ilapsehy = 1 : lapse computed to PN approximation in the /; b4..040
!      hydrodynamics if irelhy = 1, and in the transport if ireltrns = 1.
!     ilapsehy = 2 : lapse computed with full GR in the
!      hydrodynamics if irelhy = 1, and in the transport if ireltrns = 1.
!
!-----------------------------------------------------------------------

INTEGER                                    :: ihydro
INTEGER                                    :: irelhy
INTEGER                                    :: ilapsehy

!-----------------------------------------------------------------------
!  Hydrodynamic Mode Control
!-----------------------------------------------------------------------
!
!     e_mode = 'e  ' : evolve total energy (internal + gravitational + kinetic)
!     e_mode = 'e-g' : evolve partial energy (internal + kinetic)
!-----------------------------------------------------------------------

CHARACTER(LEN=3)                           :: e_mode

!-----------------------------------------------------------------------
!  Gravitation Options
!-----------------------------------------------------------------------
!  i_grav     : gravitation key
!
!     i_grav = 1 : spherical symmetric gravity
!     i_grav = 2 : nonspherical components computed from by a Newtonian
!                   Poisson solver
!
!-----------------------------------------------------------------------

INTEGER                                    :: i_grav

!-----------------------------------------------------------------------
!
!                     \\\\\ MOVING GRID OPTION /////
!
!-----------------------------------------------------------------------
!  m_grid_1 = la : Radial grid above the inner-outer grid boundary
!                   is Lagrangian if lagr and eul = no. (Control)
!  m_grid_1 = no : Radial grid above the inner-outer grid boundary
!                   is Eulerian if lagr and eul = no. (Control)
!
!  m_grid_2       This option is not currently functional
!
!-----------------------------------------------------------------------

CHARACTER(LEN=2)                           :: m_grid_1
CHARACTER(LEN=2)                           :: m_grid_2

!-----------------------------------------------------------------------
!  Transport controls
!-----------------------------------------------------------------------
!  inutrn   : Transport switch.
!
!     inutrn = 0 : neutrino transport bypassed.
!     inutrn = 1 : neutrino transport included.
!
!  ireltrns : Newtonian - GR transport toggle.
!
!     ireltrns = 0 : Newtonian neutrino transport.
!     ireltrns = 1 : general relativistic neutrino transport.
!
!  idiff    : Transport boundary conditions toggle.
!
!     idiff = 0 : dc(i,k,n) computed normally at each iteration.
!     idiff = 1 : dc(i,k,n) is the average of the current and preceding
!      timestep value.
!     idiff = 2 : dc(i,k,n) = 0 for i = inumax, dc(i,k,n) computed normally
!      at each iteration for
!      i /= inumax.
!     idiff = 3 : dc(i,k,n) = 0 for i = imax, dc(i,k,n) as in idiff = 1
!      for i /= imax
!     idiff = 4 : dc(i,k,n) = 0 for all i.
!     idiff = 5 : dc(i,k,n) is computed only on the first iteration
!     idiff = 6 : dc(i,k,n) = 0 for i = imax, computed only on the first
!      iteration for i /= imax
!
!  inumin   : inner radial zone for which neutrino transport is computed.
!  inumax   : outer radial zone for which neutrino transport is computed.
!
!  itnu(n)  : transport temperature change switch.
!
!     itnu(n) = 0 : temperature change due to n-type neutrinos bypassed.
!     itnu(n) = 1 : temperature change due to n-type neutrinos included.
!
!  jexect   : transport temperature change for zone jexect switch.
!
!     jexect = 0 : computation of the temperature is normal.
!     jexect = j : if itnu = 0, computation of temperature is normal for
!      j = jexect.
!
!  iyenu    : transport electron fraction change switch.
!
!     iyenu = 0 : electron fraction change due to n-type neutrinos bypassed.
!     iyenu = 1 : electron fraction change due to n-type neutrinos included.
!
!  jexecy   : transport electron fraction change for zone jexect switch.
!
!     jexecy = 0 : computation of the temperature is normal.
!     jexecy = j : if iyenu = 0, computation of temperature is normal for
!      j = jexecy.
!-----------------------------------------------------------------------

INTEGER                                    :: inutrn
INTEGER                                    :: ireltrns
INTEGER                                    :: idiff
INTEGER                                    :: inumin
INTEGER                                    :: inumax
INTEGER, ALLOCATABLE, DIMENSION(:)         :: itnu
INTEGER                                    :: jexect
INTEGER                                    :: iyenu
INTEGER                                    :: jexecy

!-----------------------------------------------------------------------
!
!         \\\\\ LAGRANGIAN - EULERIAN TRANSPORT SWITCHES /////
!
!-----------------------------------------------------------------------
!     lag_tr  = ye:
!     eul_tr  = ye:
!  Lagrangian transport when moving grid option on, otherwise Eulerian
!   transport. (Control)
!
!     lag_tr  = ye:
!     eul_tr  = no:
!  Lagrangian transport always. (Control)
!
!     lag_tr  = no:
!     eul_tr  = ye:
!  Eulerian transport always. (Control)
!-----------------------------------------------------------------------

CHARACTER(LEN=2)                           :: lag_tr
CHARACTER(LEN=2)                           :: eul_tr

!-----------------------------------------------------------------------
!
!        \\\\\ TEMPERATURE AND ELECTRON FRACTION UPDATES /////
!
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!  t_chg   = ye: compute matter temperature change due to source and
!                transport
!  t_chg   = no: temperature change to source and transport bypassed
!
!  ye_chg  = ye: compute electron fraction change due to source and
!                transport
!  ye_chg  = no: electron fraction change to source and transport
!                bypassed
!-----------------------------------------------------------------------

CHARACTER(LEN=2)                           :: t_chg
CHARACTER(LEN=2)                           :: ye_chg

!-----------------------------------------------------------------------
!  Absorption and emission controls
!-----------------------------------------------------------------------
!  iaefnp   : emission and absorption of e-neutrinos and e-antineutrinos
!   on free neutrons and protons switch.
!
!     iaefnp = 0: emission and absorption of e-neutrinos and
!      e-antineutrinos on free neutrons and protons turned off.
!     iaefnp = 1: emission and absorption of e-neutrinos and
!      e-antineutrinos on free neutrons and protons turned on.
!
!  i_aeps   : emission and aborption of e-neutrinos and e-antineutrinos
!   on free neutrons and protons phase space switch.
!
!     i_aeps = 0: emission and absorption of e-neutrinos and
!      e-antineutrinos on free neutrons and protons are computed
!      assuming no recoil, or thermal motions, and approximate
!      nucleon phase space blocking.
!     iaefnp = 1: emission and absorption of e-neutrinos and
!      e-antineutrinos on free neutrons and protons are computed
!      taking into account recoil, thermal motions, and nucleon
!      phase space blocking.
!
!  rhoaefnp : density above which emission and absorption of e-neutrinos
!   and e-antineutrinos on free neutrons and protons is turned off.
!
!  iaence   : emission and absorption of e-neutrinos on nuclei as given
!   by the FFN prescription  switch
!
!     iaence = 0: emission and absorption of e-neutrinos on nuclei as
!      given by the FFN prescription turned off.
!     iaence = 1: emission and absorption of e-neutrinos on nuclei as
!      given by the FFN prescription turned on.
!
!  edmpe    : difference between the mean excited state energy of the
!   daughter nucleus and that of the parent nucleus [MeV].
!
!  iaenca   : emission and absorption of e-antineutrinos on nuclei as
!   given by the FFN prescription  switch
!
!     iaenca = 0: emission and absorption of e-antineutrinos on nuclei as
!      given by the FFN prescription turned off.
!     iaenca = 1: emission and absorption of e-antineutrinos on nuclei as
!      given by the FFN prescription turned on.
!
!  edmpa    : difference between the mean excited state energy of the
!   daughter nucleus and that of  the parent nucleus [MeV].
!
!  iaenct: emission and absorption of e-neutrinos on nuclei as given by
!   the NSE-folded tabular data for Hix et al (2003)
!
!     iaenct  = 0: emission and absorption of e-neutrinos on nuclei as
!      given by the tabular data is turned off.
!     iaenct  = 1: emission and absorption of e-neutrinos on nuclei as
!      given by the tabular data is turned on.
!
!  roaenct: density above which emission and absorption of e-neutrinos on
!   nuclei as given by Hix et al (2003) is turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: iaefnp
INTEGER                                    :: i_aeps
INTEGER                                    :: iaence
INTEGER                                    :: iaenca
INTEGER                                    :: iaenct

REAL(double)                               :: rhoaefnp
REAL(double)                               :: edmpe
REAL(double)                               :: edmpa
REAL(double)                               :: roaenct

!-----------------------------------------------------------------------
!  Weak magnetism correction for charged current interactions
!-----------------------------------------------------------------------
!  icc_wm : charged current weak magnetism switch.
!
!     icc_wm = 0: weak magnetism correction for charged current
!      interactions turned off.
!     icc_wm = 1: weak magnetism correction for charged current
!      interactions turned on.
!-----------------------------------------------------------------------

INTEGER                                    :: icc_wm

!-----------------------------------------------------------------------
!  General scattering switch
!-----------------------------------------------------------------------
!  iscat : general scattering switch.
!
!     iscat = 0 : all scattering processes turned off.
!     iscat = 1 : any scattering process is allowed to proceed if its
!      key is turned on.
!-----------------------------------------------------------------------

INTEGER                                    :: iscat

!-----------------------------------------------------------------------
!  Neutrino nucleon scattering controls
!-----------------------------------------------------------------------
!  in     : neutrino-neutron scattering switch
!
!     in = 0 : neutrino-neutron isoenergetic scattering turned off.
!     in = 1 : neutrino-neutron isoenergetic scattering turned on.
!
!  ip     : neutrino-proton scattering switch
!
!     ip = 0: neutrino-proton isoenergetic scattering turned off.
!     ip = 1: neutrino-proton isoenergetic scattering turned on.
!
!  ietann : final state blocking switch
!
!     ietann = 0 : final state blocking due to neutron or proton final
!      state occupancy in neutrino-neutron and neutrino-proton
!      isoenergetic scattering turned off.
!     ietann = 1 : final state blocking due to neutron or proton final
!      state occupancy in neutrino-neutron and neutrino-proton
!      isoenergetic scattering turned on.
!-----------------------------------------------------------------------

INTEGER                                    :: in
INTEGER                                    :: ip
INTEGER                                    :: ietann

!-----------------------------------------------------------------------
!  Neutrino nuclei scattering controls
!-----------------------------------------------------------------------
!  ihe    : neutrino-helium isoenergetic scattering switch
!
!     ihe = 0: neutrino-helium isoenergetic scattering turned off.
!     ihe = 1: neutrino-helium isoenergetic scattering turned on.
!
!  iheavy : neutrino-heavy nucleus isoenergetic scattering switch
!
!     iheavy = 0: neutrino-heavy nucleus isoenergetic scattering turned off.
!     iheavy = 1: neutrino-heavy nucleus isoenergetic scattering turned on.
!
!  iicor  : ion-ion correlation switch.
!
!     iicor = 0: neutrino-heavy nucleus isoenergetic scattering
!      correction due to ion-ion correlation effects turned off.
!     iicor = 1: neutrino-heavy nucleus isoenergetic scattering
!      correction due to ion-ion correlation effects turned on.
!-----------------------------------------------------------------------

INTEGER                                    :: ihe
INTEGER                                    :: iheavy
INTEGER                                    :: iicor

!-----------------------------------------------------------------------
!  Weak magnetism correction for neutral current interactions
!-----------------------------------------------------------------------
!  inc_wm : neutral current weak magnetism switch.
!
!     inc_wm = 0: weak magnetism correction for neutral current
!      interactions turned off.
!     inc_wm = 1: weak magnetism correction for neutral current
!      interactions turned on.
!-----------------------------------------------------------------------

INTEGER                                    :: inc_wm

!-----------------------------------------------------------------------
!  Neutrino-electron scattering controls
!-----------------------------------------------------------------------
!  nes      : neutrino-electron scattering switch.
!
!     nes = 0 : neutrino-electron scattering turned off.
!     nes = 1 : neutrino-electron scattering turned on.
!
!  rhonesmn : density below which n-neutrino-electron scattering is
!   turned off.
!
!  rhonesmx : density above which n-neutrino-electron scattering is
!   turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: nes

REAL(double)                               :: rhonesmn
REAL(double)                               :: rhonesmx

!-----------------------------------------------------------------------
!  Neutrino-positron scattering controls
!-----------------------------------------------------------------------
!  nps      : neutrino-positron scattering switch.
!
!     nes = 0 : neutrino-positron scattering turned off.
!     nes = 1 : neutrino-positron scattering turned on.
!
!  rhonpsmn : density below which n-neutrino-positron scattering is
!              turned off.
!
!  rhonpsmx : density above which n-neutrino-positron scattering is
!              turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: nps

REAL(double)                               :: rhonpsmn
REAL(double)                               :: rhonpsmx

!-----------------------------------------------------------------------
!  Neutrino-nucleon elastic scattering controls
!-----------------------------------------------------------------------
!  isctn      : neutrino-nucleon inelastic scattering switch.
!
!     isctn = 0: neutrino-nucleon inelastic scattering turned off.
!     isctn = 1: neutrino-nucleon inelastic scattering turned on.
!                Reddy et al.
!     isctn = 2: neutrino-nucleon inelastic scattering turned on.
!                Hannested & Raffelt
!
!  rhosctnemn : density below which n-neutrino-neutrino-nucleon,
!                elastic scattering is turned off.
!
!  rhosctnemx : density above which n-neutrino-neutrino-nucleon,
!                elastic scattering is turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: isctn

REAL(double)                               :: rhosctnmn
REAL(double)                               :: rhosctnmx

!-----------------------------------------------------------------------
!  Neutrino-nucleus inelastic scattering controls
!-----------------------------------------------------------------------
!  isctnA      : neutrino-nuclei inelastic scattering switch.
!
!     isctnA = 0 : neutrino-nucleus inelastic scattering turned off.
!     isctnA = 1 : neutrino-nucleus inelastic scattering turned on.
!
!  rhosctnAemn : density below which e-neutrino-neutrino-nucleus,
!   e-antineutrino-neutrino-nucleus  inelastic scattering is turned off.
!
!  rhosctnAemx : density above which e-neutrino-neutrino-nucleus,
!   e-antineutrino-neutrino-nucleus inelastic scattering is turned off.
!
!  rhosctnAtmn : density below which x-neutrino-neutrino-nucleus,
!   x-antineutrino-neutrino-nucleus  inelastic scattering is turned off.
!
!  rhosctnAtmx : density above which x-neutrino-neutrino-nucleus,
!   x-antineutrino-neutrino-nucleus scattering is turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: isctnA

REAL(double)                               :: rhosctnAemn
REAL(double)                               :: rhosctnAemx
REAL(double)                               :: rhosctnAtmn
REAL(double)                               :: rhosctnAtmx

!-----------------------------------------------------------------------
!  Electron-positron pair annihilation controls
!-----------------------------------------------------------------------
!  ipair      : electron-positron pair annihilation switch.
!
!     ipair = 0 : electron-positron pair annihilation process turned off.
!     ipair = 1 : electron-positron pair annihilation process turned on.
!
!  rhopairemn : density below which e-neutrino - e-antineutrino pair
!   production by electron-positron pair annihilation is turned off.
!
!  rhopairemx : density above which e-neutrino - e-antineutrino pair
!   production by electron-positron pair annihilation is turned off.
!
!  rhopairtmn : density below which x-neutrino - x-antineutrino pair
!   production by electron-positron pair annihilation is turned off..
!
!  rhopairtmx : density above which x-neutrino - x-antineutrino pair
!   production by electron-positron pair annihilation is turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: ipair

REAL(double)                               :: rhopairemn
REAL(double)                               :: rhopairemx
REAL(double)                               :: rhopairtmn
REAL(double)                               :: rhopairtmx

!-----------------------------------------------------------------------
!  Bremsstrahlung pair annihilation controls
!-----------------------------------------------------------------------
!  ibrem      : bremsstrahlung pair annihilation switch.
!
!     ibrem = 0 : bremsstrahlung pair annihilation process turned off.
!     ibrem = 1 : bremsstrahlung pair annihilation process turned on.
!
!  rhobrememn : density below which e-neutrino - e-antineutrino pair
!   production by bremsstrahlung pair annihilation is turned off.
!
!  rhobrememx : density above which e-neutrino - e-antineutrino pair
!   production by bremsstrahlung pair annihilation is turned off.
!-----------------------------------------------------------------------

INTEGER                                    :: ibrem

REAL(double)                               :: rhobrememn
REAL(double)                               :: rhobrememx

!-----------------------------------------------------------------------
!  NSE flashing and deflashing controls
!-----------------------------------------------------------------------
!  tnse  : temperature at which material is flashed to nse [K]
!
!  tdnse : temperature at which material is deflashed from nse [K]
!
!  deflash_pre_bounce : deflashing permitted before bounce
!-----------------------------------------------------------------------

REAL(double)                               :: tnse
REAL(double)                               :: tdnse

LOGICAL                                    :: deflash_pre_bounce

!-----------------------------------------------------------------------
!  Time window averaging of the GR pseudo-potential
!-----------------------------------------------------------------------
!  t_wndw_grpot  : time window for averaging the GR pseudo-potential
!   [micro-seconds]
!
!  t_apply_gr_ave: time after bounce at which time-window averaging
!   is to be applied [milli-seconds]
!-----------------------------------------------------------------------

REAL(double)                               :: t_wndw_grpot
REAL(double)                               :: t_apply_gr_ave

!-----------------------------------------------------------------------
!  ave_pole: pole average width
!-----------------------------------------------------------------------

INTEGER                                    :: ave_pole

END module prb_cntl_module


	SUBROUTINE RU_RTIM  ( isdtar, irday, irhour, iodtar, iret )
C************************************************************************
C* RU_RTIM								*
C*									*
C* This subroutine combines an integer system time and the report	*
C* day and hour into an observation time.  It is assumed that the	*
C* system time accurately reflects the time at which the report was	*
C* received, and is later than the actual report time (i.e., the time	*
C* the observation was made).						*
C*									*
C* RU_RTIM  ( ISDTAR, IRDAY, IRHOUR, IODTAR, IRET )			*
C*									*
C* Input parameters:							*
C*	ISDTAR (5)	INTEGER		System time			*
C*	IRDAY		INTEGER		Report day			*
C*	IRHOUR		INTEGER		Report hour			*
C*									*
C* Output parameters:							*
C*	IODTAR (5)	INTEGER		Observation date/time		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = invalid time              *
C**									*
C* Log:									*
C* M. desJardins/GSFC	 8/87						*
C* M. desJardins/GSFC	12/87	Changed TI subroutines			*
C* D. Kidwell/NCEP	10/98	Error return if report hour gt 24       *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		isdtar (*), iodtar (*)
C*
	LOGICAL		addday
C------------------------------------------------------------------------
	iret = 0
C
C*	Use the system time for the observation time for the year and
C*	month.
C
	ioyear = isdtar (1)
	iomnth = isdtar (2)
C
C*	Use the report time for the day and hour.
C
	ioday  = irday
	iohour = irhour
C
C*	If the report hour was 24, set addday flag and reset time.
C*	If the report hour was greater than 24 or less than zero,
C*      error return.
C
	IF  ( iohour .eq. 24 )  THEN
	    iohour = 0
	    addday = .true.
	  ELSE IF ( iohour .lt. 24 .and. iohour .ge. 0 ) THEN
	    addday = .false.
	  ELSE
	    iret = -1
	    RETURN
	END IF
C
C*	Change the month and year if the report day is after the system
C*	day assuming that the report day was in the previous month.
C
	isday = isdtar ( 3 )
	IF  ( ( ioday .gt. 27 ) .and. ( isday .eq. 1 ) )  THEN
	    iomnth = iomnth - 1
	    IF  ( iomnth .eq. 0 )  THEN
		iomnth = 12
		ioyear = ioyear - 1
	    END IF
	END IF
C
C*	Fill output observation time array.
C
	iodtar (1) = ioyear
	iodtar (2) = iomnth
	iodtar (3) = ioday
	iodtar (4) = iohour
	iodtar (5) = 0
C
C*	Add a day if necessary.
C
	IF  ( addday )  THEN
	    CALL TI_ADDD ( iodtar, iodtar, ier )
	END IF
C
	RETURN
	END


      program L1L1elect
      implicit double precision(a-h,o-z)

c theis program operates just like Electro_Mac, except
c that it only calculates the electrostatic interaction
c between charged groups that are far apart.
c It reverses the sign of the interaction, so that these
c interactions are subtracted from the energy, as they are double
c counted in the FRAG part.

c reads in the cat OUT_L1L1_data file which contains lines like
c       k1     k2    nsign
c where k1 and k2 identify the L1 fragments that will be
c interacted electrostatically
c nsign is the sign coefficient

c We will read OUT_L1L1_data one line at a time
c we will open the
c nb.k1.0.cart
c nb.k2.0.cart
c files, and read in the multipole moments etc
c Then we simply call the elect subroutine to evalaute the
c multipole-multipole interactions

      real*8, allocatable    ::ch1(:),c1(:,:),d1(:,:),q1(:,:,:)
      real*8, allocatable    ::o1(:,:,:,:),h1(:,:,:,:,:)

      real*8, allocatable    ::ch2(:),c2(:,:),d2(:,:),q2(:,:,:)
      real*8, allocatable    ::o2(:,:,:,:),h2(:,:,:,:,:)

      real*8, allocatable    ::del1(:,:),del2(:,:)
      real*8, allocatable    ::secd1(:,:,:,:),secd2(:,:,:,:),
     .                         secd3(:,:,:,:)

      character*20 ca, ca1

      integer, allocatable  ::nat0(:)
      integer, allocatable  ::numchggrps(:)
      real*8, allocatable   ::c0(:,:,:)
      integer, allocatable  ::numat(:),natstore(:,:)
      character*2, lab0

      real*8, allocatable   :: g(:,:),h(:,:),w1(:,:,:)
      integer, allocatable   :: nat1(:),num1(:,:),natnum1(:,:,:)

      dimension totk(3)

c     integer, allocatable   :: num(:),natnum(:,:)
c     real*8, allocatable   :: w(:,:)

c get the jobtype
      open(unit=1,file='IN_JOBTYPE',status='old')
      read(1,*)
      read(1,*)jobtype
      close(unit=1)

c the IN_COMBINE file specifies whether electrostatic forces are
c used
c     open(unit=1,file='IN_COMBINE',status='old')
c     read(1,*)
c     read(1,*)nforce
c     close(unit=1)
c DO NOT USE GRADIENTS
c     if(nforce.lt.3)jobtype=0

      tote=0

      numcharges=0
c we will need to know which groups contain charges
      open(unit=1,file='OUT_CHARGEDGROUPS',status='unknown')
      read(1,*,end=333)
      read(1,*)numcharges
      if(numcharges.gt.0)then
       allocate(numchggrps(numcharges))
       read(1,*)
       do k=1,numcharges
        read(1,*)numchggrps(k)
        read(1,*)
        read(1,*)
        read(1,*)
       enddo
      endif
333   continue
      close(unit=1)

c if there are less than 2 charges, there is nothing to do
      if(numcharges.lt.2)go to 999

c we need the number of groups
      open(unit=1,file='frags.out_Lev0',status='old')
      read(1,*)
      read(1,*)ngroups
      allocate(nat0(ngroups))
      allocate(c0(ngroups,60,3))
      close(unit=1)
c if there are charges, we will need the coordinates of the groups
c which contain charges

c read in the Level 0 (group) coordinates
      do n=1,ngroups
       call filelabel(n,ca)
       ca1='Lev0_COORD'//ca
       open(unit=1,file=ca1,status='old')
       read(1,*)
       m=1
15     continue
       read(1,*,end=25)lab0,(c0(n,m,k),k=1,3)
       m=m+1
       go to 15
25     continue
       nat0(n)=m-1
       close(unit=1)
      enddo
100   format(a2,3f13.6)
c we will need the L1 fragment group numbers
      open(unit=8,file='OUT_FINAL_L1_DATA',status='unknown')
      read(8,*)
      read(8,*)
      read(8,*)nL1frags
      allocate(numat(nL1frags))
      allocate(natstore(nL1frags,8))

      read(8,*)
      do n=1,nL1frags
       read(8,*)n1,numat(n)
       read(8,*)(natstore(n,j),j=1,numat(n))
      enddo
      close(unit=8)

c if jobtype > 0, we need data to allocate gradients and
c second derivatives
      if(jobtype.gt.0)then
c get the number of atoms
       open(unit=1,file='name.xyz',status='old')
       read(1,*)natom
       close(unit=1)

       allocate(g(natom,3))
       g=0
      endif
       if(jobtype.eq.2)then
        allocate(h(3*natom,3*natom))
c       allocate(num(natom))
c       allocate(natnum(natom,6))
c       allocate(w(natom,6))
        h=0
       endif

c get the Lev1 identities
       open(unit=1,file='OUT_Lev1_ATOMALLOCATION',status='old')
       read(1,*)
       read(1,*)NL1
       read(1,*)
       read(1,*)

       allocate(nat1(NL1))
       allocate(num1(NL1,200))
       allocate(natnum1(NL1,200,6))
       allocate(w1(NL1,200,6))

       do n=1,NL1
        read(1,*)i1,nat1(n)
        do m=1,nat1(n)
         read(1,*)num1(n,m),
     .           (natnum1(n,m,k),w1(n,m,k),k=1,num1(n,m))
        enddo
       enddo

       close(unit=1)

       do n=1,NL1
       do m=1,nat1(n)
        if(num1(n,m).eq.1)w1(n,m,1)=1.d0
        if(num1(n,m).eq.2)w1(n,m,2)=1.d0-w1(n,m,1)
       enddo
       enddo
c now we read in the electrostatic interactions L1..L1, one at a time

      open(unit=2,file='OUT_CHARGE_CHARGE',status='unknown')
c OUT_CHARGE_CHARGE replaces OUT_L1L1_data in Electro_Mac

c begin the line by line loop
1     continue
      read(2,*,end=2)m1,m2,nsign
c     write(6,*)m1,m2,nsign

c make the file name, first k1
       call filelabel(m1,ca1)
       n1=index(ca1,' ')-1
       ca='nb.'//ca1(1:n1)//'.0'//'.cart'
       open(unit=1,file=ca,status='old')
       read(1,*)
c read the number of atoms
       read(1,*)natom1
        if(natom1.ne.nat1(m1))then
         write(6,*)' problem with natom1 ',m1,nat1(m1),natom1
         stop
        endif
       allocate(ch1(natom1))
       allocate(c1(natom1,3))
       allocate(d1(natom1,3))
       allocate(q1(natom1,3,3))
       allocate(o1(natom1,3,3,3))
       allocate(h1(natom1,3,3,3,3))
       allocate(del1(natom1,3))

c start reading the data
      do n=1,natom1
       read(1,*)
       do k=1,3
        read(1,*)c1(n,k)
       enddo
       read(1,*)
       read(1,*)ch1(n)
       read(1,*)
       do k=1,3
        read(1,*)d1(n,k)
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       read(1,*)q1(n,k1,k2)
       enddo
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       do k3=k2,3
       read(1,*)o1(n,k1,k2,k3)
       enddo
       enddo
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       do k3=k2,3
       do k4=k3,3
       read(1,*)h1(n,k1,k2,k3,k4)
       enddo
       enddo
       enddo
       enddo
       call symm(q1(n,:,:),o1(n,:,:,:),h1(n,:,:,:,:))
c end the n loop
      enddo

      close(unit=1)
c In Electro_Mac
c  if there are charges, we need to see if this L1 frag contains
c  group with charges. The electrostatic interaction of charged
c  groups will all other groups has already been done, so the
c  moments of such groups must be set to zero
c here
c  the charge-neutral interactions should also not be done
c  but we zero the neutral groups

      if(numcharges.gt.0)then

       do j=1,numat(m1)
        nmatch=0
        do k=1,numcharges
         if(numchggrps(k).eq.natstore(m1,j))nmatch=1
        enddo
        if(nmatch.eq.0)then
c       write(6,*)m1,natstore(m1,j)
         call zero(natom1,c1,ch1,d1,q1,o1,h1,
     .             nat0(natstore(m1,j)),c0(natstore(m1,j),:,:))
        endif
       enddo
      endif
c make the file name, now k2
       call filelabel(m2,ca1)
       n1=index(ca1,' ')-1
       ca='nb.'//ca1(1:n1)//'.0'//'.cart'
       open(unit=1,file=ca,status='old')

       read(1,*)
c read the number of atoms
       read(1,*)natom2
        if(natom2.ne.nat1(m2))then
         write(6,*)' problem with natom2 ',m2,nat1(m2),natom2
         stop
        endif
       allocate(ch2(natom2))
       allocate(c2(natom2,3))
       allocate(d2(natom2,3))
       allocate(q2(natom2,3,3))
       allocate(o2(natom2,3,3,3))
       allocate(h2(natom2,3,3,3,3))
       allocate(del2(natom2,3))

c start reading the data
      do n=1,natom2
       read(1,*)
       do k=1,3
        read(1,*)c2(n,k)
       enddo
       read(1,*)
       read(1,*)ch2(n)
       read(1,*)
       do k=1,3
        read(1,*)d2(n,k)
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       read(1,*)q2(n,k1,k2)
       enddo
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       do k3=k2,3
       read(1,*)o2(n,k1,k2,k3)
       enddo
       enddo
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       do k3=k2,3
       do k4=k3,3
       read(1,*)h2(n,k1,k2,k3,k4)
       enddo
       enddo
       enddo
       enddo

       call symm(q2(n,:,:),o2(n,:,:,:),h2(n,:,:,:,:))
c end the n loop
      enddo

      close(unit=1)
c if there are charges, we need to see if this L1 frag contains
c group with charges. The electrostatic interaction of charged
c groups will all other groups has already been done, so the
c moments of such groups must be set to zero

c here the neutral groups are zeroed
      if(numcharges.gt.0)then

       do j=1,numat(m2)
        nmatch=0
       do k=1,numcharges
        if(numchggrps(k).eq.natstore(m2,j))nmatch=1
       enddo
        if(nmatch.eq.0)then
         call zero(natom2,c2,ch2,d2,q2,o2,h2,
     .             nat0(natstore(m2,j)),c0(natstore(m2,j),:,:))
        endif
       enddo
      endif
c       write(6,*)m2,natstore(m2,j)
c now we have all the multipoles

c convert coordinates to Bohr
      Bohr=1.88972598860
      do n=1,natom1
      do k=1,3
       c1(n,k)=c1(n,k)*Bohr
      enddo
      enddo
      do n=1,natom2
      do k=1,3
       c2(n,k)=c2(n,k)*Bohr
      enddo
      enddo

c we use only up to quadrupoles for the fast code
c the multipole tensors do not have to be symmetrized

c simply call subroutine elect
c jobtype=0, energies only
c jobtype=1, also gradients
c jobtype=2 second derivatives

        allocate(secd1(natom1,3,natom1,3))
        allocate(secd2(natom1,3,natom2,3))
        allocate(secd3(natom2,3,natom2,3))

      call elect(natom1,c1,ch1,d1,q1,o1,h1,
     .           natom2,c2,ch2,d2,q2,o2,h2,
     .           elen,del1,del2,secd1,secd2,secd3,jobtype)
      write(66,*)m1,m2,nsign,elen

c     do n=1,natom1
c      write(50,*)(del1(n,k),k=1,3)
c     enddo
c      write(50,*)
c     do n=1,natom2
c      write(50,*)(del2(n,k),k=1,3)
c     enddo

      tote=tote+elen*nsign

      if(jobtype.gt.0)then

c make the gradients sum to zero
      do k=1,3
       totk(k)=0.d0
      enddo

c allocate the gradients
       do k=1,3
       do m=1,nat1(m1)
        totk(k)=totk(k)+del1(m,k)
       do j=1,num1(m1,m)
        g(natnum1(m1,m,j),k)=g(natnum1(m1,m,j),k)+
     .                      del1(m,k)*w1(m1,m,j)*nsign
c       totk(k)=totk(k)+del1(m,k)*w1(m1,m,j)
       enddo
       enddo
       enddo

       do k=1,3
       do m=1,nat1(m2)
        totk(k)=totk(k)+del2(m,k)
       do j=1,num1(m2,m)
        g(natnum1(m2,m,j),k)=g(natnum1(m2,m,j),k)+
     .                      del2(m,k)*w1(m2,m,j)*nsign
c       totk(k)=totk(k)+del2(m,k)*w1(m2,m,j)
       enddo
       enddo
       enddo

c      write(34,*)(totk(k),k=1,3)
c end the jobtype if
      endif

      if(jobtype.eq.2)then

        do k1=1,3
        do k2=1,3
        do i1=1,natom1
c       do i2=1,natom1
        i2=i1
        do j1=1,num1(m1,i1)
        do j2=1,num1(m1,i2)
         l1=3*(natnum1(m1,i1,j1)-1)+k1
         l2=3*(natnum1(m1,i2,j2)-1)+k2
         h(l1,l2)=h(l1,l2)+secd1(i1,k1,i2,k2)*w1(m1,i1,j1)*
     .                     w1(m1,i2,j2)*nsign
        enddo
        enddo
c       enddo
        enddo
        enddo
        enddo

        do k1=1,3
        do k2=1,3
        do i1=1,natom2
c       do i2=1,natom2
        i2=i1
        do j1=1,num1(m2,i1)
        do j2=1,num1(m2,i2)
         l1=3*(natnum1(m2,i1,j1)-1)+k1
         l2=3*(natnum1(m2,i2,j2)-1)+k2
         h(l1,l2)=h(l1,l2)+secd3(i1,k1,i2,k2)*w1(m2,i1,j1)*
     .                     w1(m2,i2,j2)*nsign
        enddo
        enddo
c       enddo
        enddo
        enddo
        enddo

        do k1=1,3
        do k2=1,3
        do i1=1,natom1
        do i2=1,natom2
        do j1=1,num1(m1,i1)
        do j2=1,num1(m2,i2)
         l1=3*(natnum1(m1,i1,j1)-1)+k1
         l2=3*(natnum1(m2,i2,j2)-1)+k2
         h(l1,l2)=h(l1,l2)+secd2(i1,k1,i2,k2)*w1(m1,i1,j1)*
     .                     w1(m2,i2,j2)*nsign
         h(l2,l1)=h(l2,l1)+secd2(i1,k1,i2,k2)*w1(m1,i1,j1)*
     .                     w1(m2,i2,j2)*nsign
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo

c end the jobtype=2 if
      endif

c deallocate the arrays
       deallocate(ch1)
       deallocate(c1)
       deallocate(d1)
       deallocate(q1)
       deallocate(o1)
       deallocate(h1)
       deallocate(del1)

       deallocate(ch2)
       deallocate(c2)
       deallocate(d2)
       deallocate(q2)
       deallocate(o2)
       deallocate(h2)
       deallocate(del2)

       deallocate(secd1)
       deallocate(secd2)
       deallocate(secd3)

      go to 1
2     continue
      close(unit=2)

c check sums
c      do n1=1,natom
c      do k1=1,3
c      do k2=1,3
c       sumk=0.d0
c       do n2=1,natom
c        i1=3*(n1-1)+k1
c        i2=3*(n2-1)+k2
c        sumk=sumk+h(i1,i2)
c       enddo
c       write(34,*)sumk
c      enddo
c      enddo
c      enddo

c output
      if(jobtype.gt.0)then

c remove centre of mass forces
      do k=1,3
       sumk=0.d0
       do n=1,natom
        sumk=sumk+g(n,k)
       enddo
c      write(6,*)sumk,natom
       sumk=sumk/dble(float(natom))
       do n=1,natom
        g(n,k)=g(n,k)-sumk
       enddo
      enddo

      endif

      open(unit=1,file='Doublecount_derivs',status='unknown')
      write(1,*)-tote
c sign reversed to remove double counting
      write(1,*)jobtype
      if(jobtype.gt.0)then
      write(1,*)natom
      do n=1,natom
       write(1,*)(-g(n,k),k=1,3)
c sign reversed to remove double counting
      enddo
      endif
101   format(6f10.6)
      if(jobtype.eq.2)then
        n3=3*natom
        write(1,101)((-h(i,j),j=1,i),i=1,n3)
c sign reversed to remove double counting
c      do i=1,n3
c      do j=1,i
c       write(1,*)h(i,j)
c      enddo
c      enddo
      endif
      close(unit=1)

999   continue
      end