subroutine init_part
  use amr_commons
  use pm_commons
  use clfind_commons
#ifdef RT
  use rt_parameters,only: convert_birth_times
#endif
  implicit none
#ifndef WITHOUTMPI
  include 'mpif.h'
#endif
  !------------------------------------------------------------
  ! Allocate particle-based arrays.
  ! Read particles positions and velocities from grafic files
  !------------------------------------------------------------
  real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v,scale_m
  integer::npart2,ndim2,ncpu2
  integer::ipart,jpart,ipart_old,ilevel,idim
  integer::i,igrid,ncache,ngrid,iskip,isink
  integer::ind,ix,iy,iz,ilun,info,icpu,nx_loc
  integer::i1,i2,i3,i1_min,i1_max,i2_min,i2_max,i3_min,i3_max
  integer::buf_count,indglob,npart_new
  real(dp)::dx,xx1,xx2,xx3,vv1,vv2,vv3,mm1,ll1,ll2,ll3
  real(dp)::scale,dx_loc,rr,rmax,dx_min
  integer::ncode,bit_length,temp
  real(kind=8)::bscale
  real(dp),dimension(1:twotondim,1:3)::xc
  integer ,dimension(1:nvector)::ind_grid,ind_cell,cc,ii
  integer ,dimension(1:ncpu)::npart_cpu,npart_all
  real(dp),allocatable,dimension(:)::xdp
  integer ,allocatable,dimension(:)::isp

  real(kind=4),allocatable,dimension(:,:)::init_plane,init_plane_x
  real(dp),allocatable,dimension(:,:,:)::init_array,init_array_x
  real(kind=8),dimension(1:nvector,1:3)::xx,vv,xs
  real(dp),dimension(1:nvector,1:3)::xx_dp
  integer,dimension(1:nvector)::ixx,iyy,izz
  real(qdp),dimension(1:nvector)::order
  real(kind=8),dimension(1:nvector)::mm
  real(kind=8)::dispmax=0.0,dispall
  real(dp),dimension(1:3)::skip_loc
  real(dp),dimension(1:3)::centerofmass

  integer::ibuf,tag=101,tagf=102,tagu=102
  integer::countsend,countrecv
#ifndef WITHOUTMPI
  integer,dimension(MPI_STATUS_SIZE,2*ncpu)::statuses
  integer,dimension(2*ncpu)::reqsend,reqrecv
  integer,dimension(ncpu)::sendbuf,recvbuf
#endif

  logical::error,keep_part,eof,jumped,ic_sink=.false.,read_pos=.false.,ok
  character(LEN=80)::filename,filename_x
  character(LEN=80)::fileloc
  character(LEN=20)::filetype_loc
  character(LEN=5)::nchar

  if(verbose)write(*,*)'Entering init_part'

  if(allocated(xp))then
     if(verbose)write(*,*)'Initial conditions already set'
     return
  end if

  ! Allocate particle variables
  allocate(xp    (npartmax,ndim))
  allocate(vp    (npartmax,ndim))
  allocate(mp    (npartmax))
  allocate(nextp (npartmax))
  allocate(prevp (npartmax))
  allocate(levelp(npartmax))
  allocate(idp   (npartmax))
  xp=0.0; vp=0.0; mp=0.0; levelp=0; idp=0
  if(star.or.sink)then
     allocate(tp(npartmax))
     tp=0.0
     if(metal)then
        allocate(zp(npartmax))
        zp=0.0
     end if
  end if
  if(sink)then
     ! Important persistent sink variables
     allocate(msink(1:nsinkmax))
     allocate(tsink(1:nsinkmax))
     allocate(idsink(1:nsinkmax))
     idsink=0 ! Important: need to set idsink to zero
     nindsink=MAXVAL(idsink) ! Reset max index
     allocate(xsink(1:nsinkmax,1:ndim))
     allocate(vsink(1:nsinkmax,1:ndim))
     allocate(vsold(1:nsinkmax,1:ndim,levelmin:nlevelmax))
     allocate(vsnew(1:nsinkmax,1:ndim,levelmin:nlevelmax))
     allocate(fsink_partial(1:nsinkmax,1:ndim,levelmin:nlevelmax))
     allocate(fsink(1:nsinkmax,1:ndim))
     allocate(acc_rate(1:nsinkmax))
     acc_rate=0.
     allocate(acc_lum(1:nsinkmax))
     acc_lum=0.
     allocate(lsink(1:nsinkmax,1:3))
     lsink=0.d0
     allocate(level_sink(1:nsinkmax))
     allocate(delta_mass(1:nsinkmax))
     ! Temporary sink variables
     allocate(total_volume(1:nsinkmax))
     allocate(wden(1:nsinkmax))
     allocate(wmom(1:nsinkmax,1:ndim))
     allocate(weth(1:nsinkmax))
     allocate(wvol(1:nsinkmax))
     allocate(wden_new(1:nsinkmax))
     allocate(wmom_new(1:nsinkmax,1:ndim))
     allocate(weth_new(1:nsinkmax))
     allocate(wvol_new(1:nsinkmax))
     allocate(divsink(1:nsinkmax,1:nlevelmax))
     allocate(divsink_new(1:nsinkmax,1:nlevelmax))
     divsink=0.;  divsink_new=0.
     allocate(msink_new(1:nsinkmax))
     allocate(msink_all(1:nsinkmax))
     allocate(tsink_new(1:nsinkmax))
     allocate(tsink_all(1:nsinkmax))
     allocate(idsink_new(1:nsinkmax))
     allocate(idsink_all(1:nsinkmax))
     allocate(idsink_old(1:nsinkmax))
     allocate(vsink_new(1:nsinkmax,1:ndim))
     allocate(vsink_all(1:nsinkmax,1:ndim))
     allocate(fsink_new(1:nsinkmax,1:ndim))
     allocate(fsink_all(1:nsinkmax,1:ndim))
     allocate(lsink_new(1:nsinkmax,1:3))
     allocate(lsink_all(1:nsinkmax,1:3))
     allocate(xsink_new(1:nsinkmax,1:ndim))
     allocate(xsink_all(1:nsinkmax,1:ndim))
     allocate(sink_jump(1:nsinkmax,1:ndim,levelmin:nlevelmax))
     sink_jump=0.d0
     allocate(level_sink_all(1:nsinkmax))
     allocate(level_sink_new(1:nsinkmax))
     allocate(dMsink_overdt(1:nsinkmax))
     allocate(r2sink(1:nsinkmax))
     allocate(r2k(1:nsinkmax))
     allocate(v2sink(1:nsinkmax))
     allocate(c2sink(1:nsinkmax))
     allocate(v2sink_new(1:nsinkmax))
     allocate(c2sink_new(1:nsinkmax))
     allocate(v2sink_all(1:nsinkmax))
     allocate(c2sink_all(1:nsinkmax))
     allocate(weighted_density(1:nsinkmax,1:nlevelmax))
     allocate(weighted_volume(1:nsinkmax,1:nlevelmax))
     allocate(weighted_ethermal(1:nsinkmax,1:nlevelmax))
     allocate(weighted_momentum(1:nsinkmax,1:nlevelmax,1:ndim))
     allocate(oksink_new(1:nsinkmax))
     allocate(oksink_all(1:nsinkmax))
     allocate(idsink_sort(1:nsinkmax))
     allocate(xmsink(1:nsinkmax))
     allocate(delta_mass_new(1:nsinkmax),delta_mass_all(1:nsinkmax))
     allocate(vol_gas_agn(1:nsinkmax),mass_gas_agn(1:nsinkmax))
     allocate(ind_blast_agn(1:nsinkmax),mass_blast_agn(1:nsinkmax),vol_blast_agn(1:nsinkmax))
     allocate(p_agn(1:nsinkmax),vol_gas_agn_all(1:nsinkmax),mass_gas_agn_all(1:nsinkmax))
     allocate(ok_blast_agn(1:nsinkmax),ok_blast_agn_all(1:nsinkmax))
     allocate(new_born(1:nsinkmax),new_born_all(1:nsinkmax))
  endif

  !--------------------
  ! Read part.tmp file
  !--------------------
  if(nrestart>0)then

     ilun=2*ncpu+myid+10
     call title(nrestart,nchar)
     fileloc='output_'//TRIM(nchar)//'/part_'//TRIM(nchar)//'.out'
     call title(myid,nchar)
     fileloc=TRIM(fileloc)//TRIM(nchar)

     open(unit=ilun,file=fileloc,form='unformatted')
     rewind(ilun)
     read(ilun)ncpu2
     read(ilun)ndim2
     read(ilun)npart2
     read(ilun)localseed
     read(ilun)nstar_tot
     read(ilun)mstar_tot
     read(ilun)mstar_lost
     read(ilun)nsink
     if(ncpu2.ne.ncpu.or.ndim2.ne.ndim.or.npart2.gt.npartmax)then
        write(*,*)'File part.tmp not compatible'
        write(*,*)'Found   =',ncpu2,ndim2,npart2
        write(*,*)'Expected=',ncpu,ndim,npartmax
        call clean_stop
     end if
     ! Read position
     allocate(xdp(1:npart2))
     do idim=1,ndim
        read(ilun)xdp
        xp(1:npart2,idim)=xdp
     end do
     ! Read velocity
     do idim=1,ndim
        read(ilun)xdp
        vp(1:npart2,idim)=xdp
     end do
     ! Read mass
     read(ilun)xdp
     mp(1:npart2)=xdp
     deallocate(xdp)
     ! Read identity
     allocate(isp(1:npart2))
     read(ilun)isp
     idp(1:npart2)=isp
     ! Read level
     read(ilun)isp
     levelp(1:npart2)=isp
     deallocate(isp)
     if(star.or.sink)then
        ! Read birth epoch
        allocate(xdp(1:npart2))
        read(ilun)xdp
        tp(1:npart2)=xdp
#ifdef RT
        if(convert_birth_times) then
           do i = 1, npart2 ! Convert birth time to proper for RT postpr.
              call getProperTime(tp(i),tp(i))
           enddo
        endif
#endif
        if(metal)then
           ! Read metallicity
           read(ilun)xdp
           zp(1:npart2)=xdp
        end if
        deallocate(xdp)
     end if
     ! Read sink properties
     if(sink)then
        if(nsink>0)then
           allocate(xdp(1:nsink))
           read(ilun)xdp ! Read sink mass
           msink(1:nsink)=xdp
           read(ilun)xdp ! Read sink birth epoch
           tsink(1:nsink)=xdp
           do idim=1,ndim
              read(ilun)xdp ! Read sink position
              xsink(1:nsink,idim)=xdp
           end do
           do idim=1,ndim
              read(ilun)xdp ! Read sink velocity
              vsink(1:nsink,idim)=xdp
           end do
           do idim=1,3
              read(ilun)xdp ! Read sink angular momentum
              lsink(1:nsink,idim)=xdp
           end do
           read(ilun)xdp ! Read sink accumulated rest mass energy
           delta_mass(1:nsink)=xdp
           read(ilun)xdp ! Read sink accretion rate
           acc_rate(1:nsink)=xdp
           deallocate(xdp)
           allocate(isp(1:nsink))
           read(ilun)isp ! Read sink index
           idsink(1:nsink)=isp
           read(ilun)isp ! Read sink level
           level_sink(1:nsink)=isp
           nindsink=MAXVAL(idsink) ! Reset max index
           deallocate(isp)
           read(ilun)ncloud_sink
        end if
     endif
     close(ilun)
     if(debug)write(*,*)'part.tmp read for processor ',myid
     npart=npart2

     !allow for ncloud_sink to change at restart
     call compute_ncloud_sink

     call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2)
     if(sink .and. ir_feedback)then
        do i=1,nsink
           acc_lum(i)=ir_eff*acc_rate(i)*msink(i)/(5*6.955d10/scale_l)
        end do
     end if
  else

     filetype_loc=filetype
     if(.not. cosmo)filetype_loc='ascii'

     select case (filetype_loc)

     case ('grafic')

        !----------------------------------------------------
        ! Reading initial conditions GRAFIC2 multigrid arrays
        !----------------------------------------------------
        ipart=0
        ! Loop over initial condition levels
        do ilevel=levelmin,nlevelmax

           if(initfile(ilevel)==' ')cycle

           ! Mesh size at level ilevel in coarse cell units
           dx=0.5D0**ilevel

           ! Set position of cell centers relative to grid center
           do ind=1,twotondim
              iz=(ind-1)/4
              iy=(ind-1-4*iz)/2
              ix=(ind-1-2*iy-4*iz)
              if(ndim>0)xc(ind,1)=(dble(ix)-0.5D0)*dx
              if(ndim>1)xc(ind,2)=(dble(iy)-0.5D0)*dx
              if(ndim>2)xc(ind,3)=(dble(iz)-0.5D0)*dx
           end do

           !--------------------------------------------------------------
           ! First step: compute level boundaries and particle positions
           !--------------------------------------------------------------
           i1_min=n1(ilevel)+1; i1_max=0
           i2_min=n2(ilevel)+1; i2_max=0
           i3_min=n3(ilevel)+1; i3_max=0
           ipart_old=ipart

           ! Loop over grids by vector sweeps
           ncache=active(ilevel)%ngrid
           do igrid=1,ncache,nvector
              ngrid=MIN(nvector,ncache-igrid+1)
              do i=1,ngrid
                 ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
              end do

              ! Loop over cells
              do ind=1,twotondim
                 iskip=ncoarse+(ind-1)*ngridmax
                 do i=1,ngrid
                    ind_cell(i)=iskip+ind_grid(i)
                 end do
                 do i=1,ngrid
                    xx1=xg(ind_grid(i),1)+xc(ind,1)
                    xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel)
                    xx2=xg(ind_grid(i),2)+xc(ind,2)
                    xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel)
                    xx3=xg(ind_grid(i),3)+xc(ind,3)
                    xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel)
                    i1_min=MIN(i1_min,int(xx1)+1)
                    i1_max=MAX(i1_max,int(xx1)+1)
                    i2_min=MIN(i2_min,int(xx2)+1)
                    i2_max=MAX(i2_max,int(xx2)+1)
                    i3_min=MIN(i3_min,int(xx3)+1)
                    i3_max=MAX(i3_max,int(xx3)+1)
                    keep_part=son(ind_cell(i))==0
                    if(keep_part)then
                       ipart=ipart+1
                       if(ipart>npartmax)then
                          write(*,*)'Maximum number of particles incorrect'
                          write(*,*)'npartmax should be greater than',ipart
                          call clean_stop
                       endif
                       if(ndim>0)xp(ipart,1)=xg(ind_grid(i),1)+xc(ind,1)
                       if(ndim>1)xp(ipart,2)=xg(ind_grid(i),2)+xc(ind,2)
                       if(ndim>2)xp(ipart,3)=xg(ind_grid(i),3)+xc(ind,3)
                       mp(ipart)=0.5d0**(3*ilevel)*(1.0d0-omega_b/omega_m)
                    end if
                 end do
              end do
              ! End loop over cells
           end do
           ! End loop over grids

           ! Check that all grids are within initial condition region
           error=.false.
           if(active(ilevel)%ngrid>0)then
              if(i1_min<1.or.i1_max>n1(ilevel))error=.true.
              if(i2_min<1.or.i2_max>n2(ilevel))error=.true.
              if(i3_min<1.or.i3_max>n3(ilevel))error=.true.
           end if
           if(error) then
              write(*,*)'Some grid are outside initial conditions sub-volume'
              write(*,*)'for ilevel=',ilevel
              write(*,*)i1_min,i1_max
              write(*,*)i2_min,i2_max
              write(*,*)i3_min,i3_max
              write(*,*)n1(ilevel),n2(ilevel),n3(ilevel)
              call clean_stop
           end if
           if(debug)then
              write(*,*)myid,i1_min,i1_max,i2_min,i2_max,i3_min,i3_max
           endif

           !---------------------------------------------------------------------
           ! Second step: read initial condition file and set particle velocities
           !---------------------------------------------------------------------
           ! Allocate initial conditions array
           if(active(ilevel)%ngrid>0)then
              allocate(init_array(i1_min:i1_max,i2_min:i2_max,i3_min:i3_max))
              allocate(init_array_x(i1_min:i1_max,i2_min:i2_max,i3_min:i3_max))
              init_array=0d0
              init_array_x=0d0
           end if
           allocate(init_plane(1:n1(ilevel),1:n2(ilevel)))
           allocate(init_plane_x(1:n1(ilevel),1:n2(ilevel)))

           ! Loop over input variables
           do idim=1,ndim

              ! Read dark matter initial displacement field
              if(multiple)then
                 call title(myid,nchar)
                 if(idim==1)filename=TRIM(initfile(ilevel))//'/dir_velcx/ic_velcx.'//TRIM(nchar)
                 if(idim==2)filename=TRIM(initfile(ilevel))//'/dir_velcy/ic_velcy.'//TRIM(nchar)
                 if(idim==3)filename=TRIM(initfile(ilevel))//'/dir_velcz/ic_velcz.'//TRIM(nchar)
              else
                 if(idim==1)filename=TRIM(initfile(ilevel))//'/ic_velcx'
                 if(idim==2)filename=TRIM(initfile(ilevel))//'/ic_velcy'
                 if(idim==3)filename=TRIM(initfile(ilevel))//'/ic_velcz'

                 if(idim==1)filename_x=TRIM(initfile(ilevel))//'/ic_poscx'
                 if(idim==2)filename_x=TRIM(initfile(ilevel))//'/ic_poscy'
                 if(idim==3)filename_x=TRIM(initfile(ilevel))//'/ic_poscz'

                 INQUIRE(file=filename_x,exist=ok)
                 if(.not.ok)then
                    read_pos = .false.
                 else
                    read_pos = .true.
                    if(myid==1)write(*,*)'Reading file '//TRIM(filename_x)
                 end if

              endif

              if(myid==1)write(*,*)'Reading file '//TRIM(filename)

              if(multiple)then
                 ilun=myid+10
                 open(ilun,file=filename,form='unformatted')
                 rewind ilun
                 read(ilun) ! skip first line
                 do i3=1,n3(ilevel)
                    read(ilun)((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel))
                    if(active(ilevel)%ngrid>0)then
                       if(i3.ge.i3_min.and.i3.le.i3_max)then
                          init_array(i1_min:i1_max,i2_min:i2_max,i3) = &
                               & init_plane(i1_min:i1_max,i2_min:i2_max)
                       end if
                    endif
                 end do
                 close(ilun)
              else
                 if(myid==1)then
                    open(10,file=filename,form='unformatted')
                    rewind 10
                    read(10) ! skip first line
                 end if
                 do i3=1,n3(ilevel)
                    if(myid==1)then
                       if(debug.and.mod(i3,10)==0)write(*,*)'Reading plane ',i3
                       read(10)((init_plane(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel))
                    else
                       init_plane=0.0
                    endif
                    buf_count=n1(ilevel)*n2(ilevel)
#ifndef WITHOUTMPI
                    call MPI_BCAST(init_plane,buf_count,MPI_REAL,0,MPI_COMM_WORLD,info)
#endif

                    if(active(ilevel)%ngrid>0)then
                       if(i3.ge.i3_min.and.i3.le.i3_max)then
                          init_array(i1_min:i1_max,i2_min:i2_max,i3) = &
                               & init_plane(i1_min:i1_max,i2_min:i2_max)
                       end if
                    endif
                 end do
                 if(myid==1)close(10)

                 if(read_pos) then
                    if(myid==1)then
                       open(10,file=filename_x,form='unformatted')
                       rewind 10
                       read(10) ! skip first line
                    end if
                    do i3=1,n3(ilevel)
                       if(myid==1)then
                          if(debug.and.mod(i3,10)==0)write(*,*)'Reading plane ',i3
                          read(10)((init_plane_x(i1,i2),i1=1,n1(ilevel)),i2=1,n2(ilevel))
                       else
                          init_plane_x=0.0
                       endif
                       buf_count=n1(ilevel)*n2(ilevel)
#ifndef WITHOUTMPI
                       call MPI_BCAST(init_plane_x,buf_count,MPI_REAL,0,MPI_COMM_WORLD,info)
#endif
                       if(active(ilevel)%ngrid>0)then
                          if(i3.ge.i3_min.and.i3.le.i3_max)then
                             init_array_x(i1_min:i1_max,i2_min:i2_max,i3) = &
                                  & init_plane_x(i1_min:i1_max,i2_min:i2_max)
                          end if
                       endif
                    end do
                    if(myid==1)close(10)
                 end if

              endif

              if(active(ilevel)%ngrid>0)then
                 ! Rescale initial displacement field to code units
                 init_array=dfact(ilevel)*dx/dxini(ilevel)*init_array/vfact(ilevel)
                 if(read_pos)then
                    init_array_x = init_array_x/boxlen_ini
                 endif
                 ! Loop over grids by vector sweeps
                 ipart=ipart_old
                 ncache=active(ilevel)%ngrid
                 do igrid=1,ncache,nvector
                    ngrid=MIN(nvector,ncache-igrid+1)
                    do i=1,ngrid
                       ind_grid(i)=active(ilevel)%igrid(igrid+i-1)
                    end do

                    ! Loop over cells
                    do ind=1,twotondim
                       iskip=ncoarse+(ind-1)*ngridmax
                       do i=1,ngrid
                          ind_cell(i)=iskip+ind_grid(i)
                       end do
                       do i=1,ngrid
                          xx1=xg(ind_grid(i),1)+xc(ind,1)
                          xx1=(xx1*(dxini(ilevel)/dx)-xoff1(ilevel))/dxini(ilevel)
                          xx2=xg(ind_grid(i),2)+xc(ind,2)
                          xx2=(xx2*(dxini(ilevel)/dx)-xoff2(ilevel))/dxini(ilevel)
                          xx3=xg(ind_grid(i),3)+xc(ind,3)
                          xx3=(xx3*(dxini(ilevel)/dx)-xoff3(ilevel))/dxini(ilevel)
                          i1=int(xx1)+1
                          i1=int(xx1)+1
                          i2=int(xx2)+1
                          i2=int(xx2)+1
                          i3=int(xx3)+1
                          i3=int(xx3)+1
                          keep_part=son(ind_cell(i))==0
                          if(keep_part)then
                             ipart=ipart+1
                             vp(ipart,idim)=init_array(i1,i2,i3)
                             if(.not. read_pos)then
                                dispmax=max(dispmax,abs(init_array(i1,i2,i3)/dx))
                             else
                                xp(ipart,idim)=xg(ind_grid(i),idim)+xc(ind,idim)+init_array_x(i1,i2,i3)
                                dispmax=max(dispmax,abs(init_array_x(i1,i2,i3)/dx))
                             endif
                          end if
                       end do
                    end do
                    ! End loop over cells
                 end do
                 ! End loop over grids
              endif

           end do
           ! End loop over input variables

           ! Deallocate initial conditions array
           if(active(ilevel)%ngrid>0)then
              deallocate(init_array,init_array_x)
           end if
           deallocate(init_plane,init_plane_x)

           if(debug)write(*,*)'npart=',ipart,'/',npartmax,' for PE=',myid

        end do
        ! End loop over levels

        ! Initial particle number
        npart=ipart

        ! Move particle according to Zeldovich approximation
        if(.not. read_pos)then
           xp(1:npart,1:ndim)=xp(1:npart,1:ndim)+vp(1:npart,1:ndim)
        endif

        ! Scale displacement to velocity
        vp(1:npart,1:ndim)=vfact(1)*vp(1:npart,1:ndim)

        ! Periodic box
        do ipart=1,npart
#if NDIM>0
           if(xp(ipart,1)<  0.0d0  )xp(ipart,1)=xp(ipart,1)+dble(nx)
           if(xp(ipart,1)>=dble(nx))xp(ipart,1)=xp(ipart,1)-dble(nx)
#endif
#if NDIM>1
           if(xp(ipart,2)<  0.0d0  )xp(ipart,2)=xp(ipart,2)+dble(ny)
           if(xp(ipart,2)>=dble(ny))xp(ipart,2)=xp(ipart,2)-dble(ny)
#endif
#if NDIM>2
           if(xp(ipart,3)<  0.0d0  )xp(ipart,3)=xp(ipart,3)+dble(nz)
           if(xp(ipart,3)>=dble(nz))xp(ipart,3)=xp(ipart,3)-dble(nz)
#endif
        end do

#ifndef WITHOUTMPI
        ! Compute particle Hilbert ordering
        sendbuf=0
        do ipart=1,npart
           xx(1,1:3)=xp(ipart,1:3)
           xx_dp(1,1:3)=xx(1,1:3)
           call cmp_cpumap(xx_dp,cc,1)
           if(cc(1).ne.myid)sendbuf(cc(1))=sendbuf(cc(1))+1
        end do

        ! Allocate communication buffer in emission
        do icpu=1,ncpu
           ncache=sendbuf(icpu)
           if(ncache>0)then
              allocate(emission(icpu,1)%up(1:ncache,1:twondim+1))
           end if
        end do

        ! Fill communicators
        jpart=0
        sendbuf=0
        do ipart=1,npart
           xx(1,1:3)=xp(ipart,1:3)
           xx_dp(1,1:3)=xx(1,1:3)
           call cmp_cpumap(xx_dp,cc,1)
           if(cc(1).ne.myid)then
              icpu=cc(1)
              sendbuf(icpu)=sendbuf(icpu)+1
              ibuf=sendbuf(icpu)
              emission(icpu,1)%up(ibuf,1)=xp(ipart,1)
              emission(icpu,1)%up(ibuf,2)=xp(ipart,2)
              emission(icpu,1)%up(ibuf,3)=xp(ipart,3)
              emission(icpu,1)%up(ibuf,4)=vp(ipart,1)
              emission(icpu,1)%up(ibuf,5)=vp(ipart,2)
              emission(icpu,1)%up(ibuf,6)=vp(ipart,3)
              emission(icpu,1)%up(ibuf,7)=mp(ipart)
           else
              jpart=jpart+1
              xp(jpart,1:3)=xp(ipart,1:3)
              vp(jpart,1:3)=vp(ipart,1:3)
              mp(jpart)    =mp(ipart)
           endif
        end do

        ! Communicate virtual particle number to parent cpu
        call MPI_ALLTOALL(sendbuf,1,MPI_INTEGER,recvbuf,1,MPI_INTEGER,MPI_COMM_WORLD,info)

        ! Compute total number of newly created particles
        npart_new=0
        do icpu=1,ncpu
           npart_new=npart_new+recvbuf(icpu)
        end do

        if(jpart+npart_new.gt.npartmax)then
           write(*,*)'No more free memory for particles'
           write(*,*)'Increase npartmax'
           write(*,*)myid
           write(*,*)jpart,npart_new
           write(*,*)bound_key
           call MPI_ABORT(MPI_COMM_WORLD,1,info)
        end if

        ! Allocate communication buffer in reception
        do icpu=1,ncpu
           ncache=recvbuf(icpu)
           if(ncache>0)then
              allocate(reception(icpu,1)%up(1:ncache,1:twondim+1))
           end if
        end do

        ! Receive particles
        countrecv=0
        do icpu=1,ncpu
           ncache=recvbuf(icpu)
           if(ncache>0)then
              buf_count=ncache*(twondim+1)
              countrecv=countrecv+1
              call MPI_IRECV(reception(icpu,1)%up,buf_count, &
                   & MPI_DOUBLE_PRECISION,icpu-1,&
                   & tagu,MPI_COMM_WORLD,reqrecv(countrecv),info)
           end if
        end do

        ! Send particles
        countsend=0
        do icpu=1,ncpu
           ncache=sendbuf(icpu)
           if(ncache>0)then
              buf_count=ncache*(twondim+1)
              countsend=countsend+1
              call MPI_ISEND(emission(icpu,1)%up,buf_count, &
                   & MPI_DOUBLE_PRECISION,icpu-1,&
                   & tagu,MPI_COMM_WORLD,reqsend(countsend),info)
           end if
        end do

        ! Wait for full completion of receives
        call MPI_WAITALL(countrecv,reqrecv,statuses,info)

        ! Wait for full completion of sends
        call MPI_WAITALL(countsend,reqsend,statuses,info)

        ! Create new particles
        do icpu=1,ncpu
           do ibuf=1,recvbuf(icpu)
              jpart=jpart+1
              xp(jpart,1)=reception(icpu,1)%up(ibuf,1)
              xp(jpart,2)=reception(icpu,1)%up(ibuf,2)
              xp(jpart,3)=reception(icpu,1)%up(ibuf,3)
              vp(jpart,1)=reception(icpu,1)%up(ibuf,4)
              vp(jpart,2)=reception(icpu,1)%up(ibuf,5)
              vp(jpart,3)=reception(icpu,1)%up(ibuf,6)
              mp(jpart)  =reception(icpu,1)%up(ibuf,7)
           end do
        end do

        ! Erase old particles
        do ipart=jpart+1,npart
           xp(ipart,1)=0d0
           xp(ipart,2)=0d0
           xp(ipart,3)=0d0
           vp(ipart,1)=0d0
           vp(ipart,2)=0d0
           vp(ipart,3)=0d0
           mp(ipart)  =0d0
        end do
        npart=jpart

        ! Deallocate communicators
        do icpu=1,ncpu
           if(sendbuf(icpu)>0)deallocate(emission(icpu,1)%up)
           if(recvbuf(icpu)>0)deallocate(reception(icpu,1)%up)
        end do

        write(*,*)'npart=',ipart,'/',npartmax,' for PE=',myid
#endif

        ! Compute particle initial level
        do ipart=1,npart
           levelp(ipart)=levelmin
        end do

        ! Compute particle initial age and metallicity
        if(star.or.sink)then
           do ipart=1,npart
              tp(ipart)=0d0
              if(metal)then
                 zp(ipart)=0d0
              end if
           end do
        end if

        ! Compute particle initial identity
        npart_cpu=0; npart_all=0
        npart_cpu(myid)=npart
#ifndef WITHOUTMPI
        call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info)
        npart_cpu(1)=npart_all(1)
#endif
        do icpu=2,ncpu
           npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu)
        end do
        if(myid==1)then
           do ipart=1,npart
              idp(ipart)=ipart
           end do
        else
           do ipart=1,npart
              idp(ipart)=npart_cpu(myid-1)+ipart
           end do
        end if

     case ('ascii')

        ! Local particle count
        ipart=0

        if(TRIM(initfile(levelmin)).NE.' ')then

        filename=TRIM(initfile(levelmin))//'/ic_part'
        if(myid==1)then
           open(10,file=filename,form='formatted')
           indglob=0
        end if
        eof=.false.

        do while (.not.eof)
           xx=0.0
           if(myid==1)then
              jpart=0
              do i=1,nvector
                 read(10,*,end=100)xx1,xx2,xx3,vv1,vv2,vv3,mm1
                 jpart=jpart+1
                 indglob=indglob+1
                 xx(i,1)=xx1+boxlen/2.0
                 xx(i,2)=xx2+boxlen/2.0
                 xx(i,3)=xx3+boxlen/2.0
                 vv(i,1)=vv1
                 vv(i,2)=vv2
                 vv(i,3)=vv3
                 mm(i  )=mm1
                 ii(i  )=indglob
              end do
100           continue
              if(jpart<nvector)eof=.true.
           endif
           buf_count=nvector*3
#ifndef WITHOUTMPI
           call MPI_BCAST(xx,buf_count,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info)
           call MPI_BCAST(vv,buf_count,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info)
           call MPI_BCAST(mm,nvector  ,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,info)
           call MPI_BCAST(ii,nvector  ,MPI_INTEGER         ,0,MPI_COMM_WORLD,info)
           call MPI_BCAST(eof,1       ,MPI_LOGICAL         ,0,MPI_COMM_WORLD,info)
           call MPI_BCAST(jpart,1     ,MPI_INTEGER         ,0,MPI_COMM_WORLD,info)
           call cmp_cpumap(xx,cc,jpart)
#endif

           do i=1,jpart
#ifndef WITHOUTMPI
              if(cc(i)==myid)then
#endif
                 ipart=ipart+1
                 xp(ipart,1:3)=xx(i,1:3)
                 vp(ipart,1:3)=vv(i,1:3)
                 mp(ipart)    =mm(i)
                 levelp(ipart)=levelmin
                 idp(ipart)   =ii(i)
#ifndef WITHOUTMPI
              endif
#endif
           enddo

        end do
        if(myid==1)close(10)

        end if
        npart=ipart

        ! Compute total number of particle
        npart_cpu=0; npart_all=0
        npart_cpu(myid)=npart
#ifndef WITHOUTMPI
        call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info)
        npart_cpu(1)=npart_all(1)
#endif
        do icpu=2,ncpu
           npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu)
        end do
        if(debug)write(*,*)'npart=',npart,'/',npart_cpu(ncpu)

     case ('gadget')
        call load_gadget

     case DEFAULT
        write(*,*) 'Unsupported format file ' // filetype
        call clean_stop

     end select

     ! Read initial sink particles
     ! Sink particles that exist at the beginning of the simu are always (independent of the type of
     ! the other ic files) read from a text file.
     if(sink)then
        call compute_ncloud_sink

        nx_loc=(icoarse_max-icoarse_min+1)
        scale=boxlen/dble(nx_loc)
        dx_min=scale*0.5D0**nlevelmax/aexp

        nsink=0
        if(TRIM(initfile(levelmin)).NE.' ')then
           filename=TRIM(initfile(levelmin))//'/ic_sink'
        else
           filename='ic_sink'
        end if
        INQUIRE(FILE=filename, EXIST=ic_sink)
        if (myid==1)write(*,*),'Looking for file ic_sink: ',filename
        if (ic_sink)then
           open(10,file=filename,form='formatted')
           eof=.false.
           if (myid==1)write(*,*)'Reading_file ',filename
           do
              read(10,*,end=102)mm1,xx1,xx2,xx3,vv1,vv2,vv3,ll1,ll2,ll3
              nsink=nsink+1
              idsink(nsink)=nsink
              msink(nsink)=mm1
              xsink(nsink,1)=xx1
              xsink(nsink,2)=xx2
              xsink(nsink,3)=xx3
              vsink(nsink,1)=vv1
              vsink(nsink,2)=vv2
              vsink(nsink,3)=vv3
              lsink(nsink,1)=ll1
              lsink(nsink,2)=ll2
              lsink(nsink,3)=ll3
              tsink(nsink)=0.
              level_sink(nsink)=levelmin
           end do
102        continue
           close(10)
        end if
        nindsink=MAXVAL(idsink) ! Reset max index
        if (myid==1.and.nsink==0)write(*,*)'File ic_sink not found: starting without sink particles!'
        if (myid==1.and.nsink>0.and.verbose)then
           write(*,*),'sinks read from file ic_sink'
           write(*,*),'   id    m       x       y       z       vx      vy      vz      lx      ly      lz  '
           write(*,*),'====================================================================================='
           do isink=1,nsink
              write(*,'(I6,X,F7.3,3(X,F7.3),3(X,F7.3),3(X,F7.3))'),idsink(isink),msink(isink),xsink(isink,1:ndim),&
                   vsink(isink,1:ndim),lsink(isink,1:ndim)
           end do
        end if

        ! Loop over sinks
        do isink=1,nsink
           xs(1,1:ndim)=xsink(isink,1:ndim)
           call cmp_cpumap(xs,cc,1)

           ! Create central cloud particles (negative index)
           if(cc(1).eq.myid)then
              npart=npart+1
              tp(npart)=1d-10
              mp(npart)=msink(isink)     ! Mass
              levelp(npart)=levelmin
              idp(npart)=-isink          ! Identity
              xp(npart,1)=xsink(isink,1) ! Position
              xp(npart,2)=xsink(isink,2)
              xp(npart,3)=xsink(isink,3)
              vp(npart,1)=vsink(isink,1) ! Velocity
              vp(npart,2)=vsink(isink,2)
              vp(npart,3)=vsink(isink,3)
           endif

        end do

     end if
  end if

end subroutine init_part
#define TIME_START(cs) call SYSTEM_CLOCK(COUNT=cs)
#define TIME_END(ce) call SYSTEM_CLOCK(COUNT=ce)
#define TIME_SPENT(cs,ce,cr) REAL((ce-cs)/cr)
subroutine load_gadget
  use amr_commons
  use pm_commons
  use gadgetreadfilemod
  implicit none
#ifndef WITHOUTMPI
  include 'mpif.h'
#endif

  logical::ok
  TYPE(gadgetheadertype) :: gadgetheader
  integer::numfiles
  integer::ifile
  real(dp),dimension(1:nvector,1:3)::xx_dp
  real, dimension(:, :), allocatable:: pos, vel
  integer, dimension(:), allocatable:: ids
  integer::nparticles, arraysize
  integer::i, icpu, ipart, info, np, start
  integer ,dimension(1:ncpu)::npart_cpu,npart_all
  character(LEN=256)::filename
  integer ,dimension(1:nvector)::cc
  integer :: clock_start, clock_end, clock_rate
  integer :: mpi_cs, mpi_ce
  real:: gadgetvfact
  ! Local particle count
  ipart=0
  call SYSTEM_CLOCK(COUNT_RATE=clock_rate)

  if(TRIM(initfile(levelmin)).NE.' ')then
     filename=TRIM(initfile(levelmin))
     ! read first header to get information
     call gadgetreadheader(filename, 0, gadgetheader, ok)
     if(.not.ok) call clean_stop
     numfiles = gadgetheader%numfiles
     gadgetvfact = SQRT(aexp) / gadgetheader%boxsize * aexp / 100.
     do ifile=0,numfiles-1
        call gadgetreadheader(filename, ifile, gadgetheader, ok)
        nparticles = gadgetheader%npart(2)
        allocate(pos(3,nparticles))
        allocate(vel(3,nparticles))
        allocate(ids(nparticles))
        TIME_START(clock_start)
        call gadgetreadfile(filename,ifile,gadgetheader, pos, vel, ids)
        TIME_END(clock_end)
        if(debug) write(*,*) myid, ':Read ', nparticles, ' from gadget file ', ifile, ' in ', &
        TIME_SPENT(clock_start, clock_end, clock_rate)
        start = 1
        TIME_START(clock_start)
#ifndef WITHOUTMPI
        do i=1,nparticles
           xx_dp(1,1) = pos(1,i)/gadgetheader%boxsize
           xx_dp(1,2) = pos(2,i)/gadgetheader%boxsize
           xx_dp(1,3) = pos(3,i)/gadgetheader%boxsize
           call cmp_cpumap(xx_dp,cc,1)
           if(cc(1)==myid)then
#endif
              ipart=ipart+1
              if (ipart .ge. size(mp)) then
                 write(*,*) "For ", myid, ipart, " exceeds ", size(mp)
                 call clean_stop
              end if
              xp(ipart,1:3)=xx_dp(1,1:3)
              vp(ipart,1)=vel(1, i) * gadgetvfact
              vp(ipart,2)=vel(2, i) * gadgetvfact
              vp(ipart,3)=vel(3, i) * gadgetvfact
              mp(ipart)    = 1.d0/gadgetheader%nparttotal(2)
              levelp(ipart)=levelmin
              idp(ipart)   =ids(i)
#ifndef WITHOUTMPI
            endif
        enddo
        TIME_END(clock_end)
        if(debug) write(*,*) myid, ':Processed ', nparticles, ' in ', TIME_SPENT(clock_start, clock_end, clock_rate), " ipart now ", ipart
#endif
        deallocate(pos,vel,ids)
     end do

  end if
  npart=ipart
  ! Compute total number of particleclock_rate
  npart_cpu=0; npart_all=0
  npart_cpu(myid)=npart
#ifndef WITHOUTMPI
  call MPI_ALLREDUCE(npart_cpu,npart_all,ncpu,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,info)
  npart_cpu(1)=npart_all(1)
#endif
  do icpu=2,ncpu
     npart_cpu(icpu)=npart_cpu(icpu-1)+npart_all(icpu)
  end do
  write(*,*)'npart=',npart,'/',npart_cpu(ncpu)

end subroutine load_gadget

!################################################################
!################################################################
!################################################################
!################################################################
subroutine compute_ncloud_sink
  use amr_commons, only:dp
  use pm_commons, only:ir_cloud,ncloud_sink
  real(dp)::xx,yy,zz,rr
  integer::ii,jj,kk
  ! Compute number of cloud particles
  ncloud_sink=0
  do kk=-2*ir_cloud,2*ir_cloud
     zz=dble(kk)/2.0
     do jj=-2*ir_cloud,2*ir_cloud
        yy=dble(jj)/2.0
        do ii=-2*ir_cloud,2*ir_cloud
           xx=dble(ii)/2.0
           rr=sqrt(xx*xx+yy*yy+zz*zz)
           if(rr<=dble(ir_cloud))ncloud_sink=ncloud_sink+1
        end do
     end do
  end do

end subroutine compute_ncloud_sink


      SUBROUTINE OUTPUT1
C*****THIS SUBROUTINE WILL PRINT A CODEV LENS DECK
C
C  LOCAL DECLARATION OF VARIABLES.
      LOGICAL*1 FBBC     ! LOCAL FLAG FOR TORIC PRINTOUT. BBC 11/84.
C*****COMMON BLOCK BBC DECLARATIONS
C ADD COMMON BLOCK TO STORE THE F() ARRAY FOR APERTURE DATA.
C BBC 12/84.
	REAL*4 TEMPBBC(225)
C*****COMMON BLOCK CODEV DECLARATIONS
      CHARACTER*4 DIM,APERT(225)
      INTEGER*4 ICCY(0:225),ITHC(0:225),IGLC(0:225),IWTW1,IWTW2,IWTW3
      INTEGER*4 IWTW4,IWTW5,IWTW6,IWTW7,ICCX(30),KC(66),IAC(66),IBC(66)
      INTEGER*4 ICC(66),IDC(66),IXDC(100),IYDC(100),IADC(100),IBDC(100)
      INTEGER*4 ICDC(100),ICCF(66)
      REAL*4 ORDER(66),WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,WLF7
      REAL*4 F(225),AL(66),AM(66),AN(66)
      REAL*8 RFND1(99),RFND2(99),RFND3(99),RFND4(99),RFND5(99)
C*****COMMON BLOCK BOTH DECLARATIONS
      CHARACTER*4 SOLVE(40)
      CHARACTER*3 CPARM(30)
      CHARACTER*13 GLASS(0:225)
      CHARACTER*64 TITLE
      INTEGER*4 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,M,ISTOP,IREF,ISURF
      INTEGER*4 NAPERT(225),NDECE(100),NSOLVE(40),NUMA,MESSAGE(20)
      REAL*4 DIF(66)
      REAL*8 ADE(100),BDE(100),CDE(100),XDE(100),YDE(100),CURVEY(0:225)
      REAL*8 THICKNS(0:225),RK(66),A(66),B(66),C(66),D(66),SOLVF1(40)
      REAL*8 F1(225),REF_OBJ_HT
      LOGICAL AFO,IC(66),CUF(66)
C*****COMMON BLOCK ACONLY DECLARATIONS
      CHARACTER*4 TORIC(10),COMMAND(100),PIKUP(200),SHAPE(225),CASE(10)
      CHARACTER*4 SPECSF(225)
      CHARACTER*36 SUBMES1(20)
      CHARACTER*40 SUBMES2(20)
      CHARACTER*48 SUBMES3(20)
      INTEGER*4 INDEX(20),NTORIC(10),NCASE(10),NUMBER(10),IPIKTO(200)
      INTEGER*4 IPIKFR(200),NASP(66),J10,K1,NGRT(10),NSHAPE(225)
      REAL*4 PIKA(200),DDIST(10),RNUMBER(10),RIC1(225),RIC2(225)
      REAL*4 RCUF1(225),RCUF2(225)
      REAL*8 TCVR(10),PY,PUCY,RADIUS(0:225),PIKB(200),NAO,YAN
      LOGICAL OB(225)

      COMMON /CODEV/DIM,APERT,ICCY,ITHC,IGLC,IWTW1,IWTW2,IWTW3,IWTW4,
     *        IWTW5,IWTW6,ILWTW7,ICCX,KC,IAC,IBC,ICC,IDC,ORDER,IXDC,
     *        IYDC,IADC,IBDC,ICDC,ICCF,WLF1,WLF2,WLF3,WLF4,WLF5,WLF6,
     *        WLF7,RFND1,RFND2,RFND3,RFND4,RFND5,F,AL,AM,AN
      COMMON /BOTH/I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,GLASS,MESSAGE,M,
     *        ISTOP,IREF,ISURF,AFO,NAPERT,NDECE,F1,DIF,ADE,BDE,CDE,XDE,
     *        YDE,CURVEY,THICKNS,RK,A,B,C,D,IC,CUF,NSOLVE,SOLVF1,SOLVE,
     *        TITLE,NUMA,REF_OBJ_HT
      COMMON /ACONLY/TCVR,PY,PUCY,INDEX,NTORIC,DDIST,SUBMES1,SUBMES2,
     *        SUBMES3,TORIC,NCASE,COMMAND,NUMBER,RADIUS,PIKA,PIKB,
     *        IPIKTO,IPIKFR,PIKUP,SHAPE,CASE,NASP,OB,SPECSF,NAO,YAN,
     *        J10,K1,NGRT,RIC1,RIC2,RCUF1,RCUF2,RNUMBER,NSHAPE
      COMMON /BBC/ TEMPBBC
C******************************************************************************
C*****FORMAT STATEMENTS
C REMOVED EXTRA SPACE AT BEGINNING OF FORMATS TO FIT CODE V. BBC 9/84.
  1   FORMAT(A12)
  2   FORMAT(A64)
  4   FORMAT(A4,6X,F10.5,F10.5,F10.5,F10.5,F10.5)
  5   FORMAT(A13)
  6   FORMAT(A4,6X,I4,6X,I4,6X,I4,6X,I4,6X,I4)
  8   FORMAT(G15.8,I4,1X,G15.8,I4,1X,A13,2X,I4,16X,A1,1X,A4)
  9   FORMAT(A6)
 10   FORMAT(G15.8,I4,1X,G15.8,I4,1X,A13,2X,I4,18X,A4)
 11   FORMAT(A3)
 12   FORMAT(G15.8,I4,1X,G15.8,5X,G15.8,I4)
 13   FORMAT(A4)
 14   FORMAT(G15.8,I4,1X,G15.8,I4,1X,G15.8,I4,1X,G15.8,I4)
 16   FORMAT(F15.8,I4)
 18   FORMAT(F8.5,2X,F9.6,2X,F5.2,5X,F5.2,5X,F5.2)
 20   FORMAT(A3,7X,G10.4)
 22   FORMAT(A3,7X,A4)
 24   FORMAT(A2,8X,F9.3,1X,F9.3,1X,F9.3,1X,F9.3,1X,F9.3)
 26   FORMAT(A3,6X,I4,6X,I4,6X,I4,6X,I4,6X,I4)
 28   FORMAT(A3,6X,I4)
 30   FORMAT(A3,I3,4X,G15.8)
 32   FORMAT(A10,F9.6,1X,F9.6,1X,F9.6,1X,F9.6,1X,F9.6)
 34   FORMAT(A3,I3,1X,A3,F10.5)
 36   FORMAT(A46)
 37   FORMAT(A1,A36)
 38   FORMAT(A31)
 39   FORMAT(A44,A32)
 40   FORMAT(A1,A40)
 41   FORMAT(A49)
 42   FORMAT(A42)
 43   FORMAT(A1,A48)
 44   FORMAT(A44,A36)
 45   FORMAT(A3)
C******************************************************************************
C*****MAIN PROGRAM
C*****SURFACE DATA
      WRITE(5,13)'DATA'
      WRITE(5,2)TITLE
      WRITE(5,1)'SURFACE DATA'
      DO 300,I=0,ISURF
        DO 125,J=1,I2
          IF (NDECE(J) .EQ. I) THEN
            WRITE(5,4)'DECE',XDE(J),YDE(J),ADE(J),BDE(J),CDE(J)
            WRITE(5,6)'DECC',IXDC(J),IYDC(J),IADC(J),IBDC(J),ICDC(J)
          END IF
125     CONTINUE
        IF (ISTOP .EQ. I) THEN
          WRITE(5,8)CURVEY(I),ICCY(I),THICKNS(I),ITHC(I),GLASS(I),
     *      IGLC(I),'S',SPECSF(I)
        ELSE
          WRITE(5,10)CURVEY(I),ICCY(I),THICKNS(I),ITHC(I),GLASS(I),
     *      IGLC(I),SPECSF(I)
        END IF
        IF ((SPECSF(I) .EQ. 'ASP') .OR. (SPECSF(I) .EQ. 'YTO') .OR.
     *      (SPECSF(I) .EQ. 'GRT')) THEN
C FLAG ON WHETHER WE NEED EXTRA SET OF LINES FOR TORICS.  BBC 11/84.
	  FBBC = .FALSE.
          DO 130,K=1,I4
            IF (NASP(K) .EQ. I) THEN
	      FBBC = .TRUE.
              WRITE(5,12)RK(K),KC(K),RIC2(K),RCUF2(K),100
              WRITE(5,14)A(K),IAC(K),B(K),IBC(K),C(K),ICC(K),D(K),
     *          IDC(K)
            END IF
130       CONTINUE
          IF (.NOT. FBBC .AND. (SPECSF(I) .EQ. 'YTO'))  THEN
C WRITE EXTRA SET OF LINES FOR TORICS. BBC 11/84.
            WRITE (5,12) 0.,100,0.,0.,100
            WRITE (5,14) 0.,100,0.,100,0.,100,0.,100
          END IF
        END IF
        IF ((SPECSF(I) .EQ. 'YTO') .OR. (SPECSF(I) .EQ. 'CYL')) THEN
          DO 135,K=1,I4
            IF (NTORIC(K) .EQ. I) WRITE(5,16)TCVR(K),ICCX(K)
135       CONTINUE
        END IF
        IF (SPECSF(I) .EQ. 'GRT') THEN
          DO 140,K=1,J10
            IF (NGRT(K) .EQ. I) WRITE(5,18)RNUMBER(K),DDIST(K),
     *        1.0,0.0,0.0
140       CONTINUE
        END IF
300   CONTINUE
C******************************************************************************
C*****SPECIFICATION DATA
      WRITE(5,11)'SPC'
      WRITE(5,20)'NAO',NAO
      WRITE(5,22)'DIM',DIM
      WRITE(5,24)'WL',WLF1,WLF2,WLF3,WLF4,WLF5
      WRITE(5,26)'WTW',IWTW1,IWTW2,IWTW3,IWTW4,IWTW5
      WRITE(5,28)'REF',IREF
      IF (AFO) WRITE(5,11)'AFO'
      WRITE(5,20)'YAN',YAN
      WRITE(5,45) 'RDO'		! MORE SPEC DATA FOR CODEV. BBC 10/84.
C******************************************************************************
C*****APERTURES
      IF (NUMA .GT. 0) WRITE(5,5)'APERTURE DATA'
      DO 325,I=1,NUMA
        WRITE(5,30)APERT(I),NAPERT(I),TEMPBBC(I)	! INSTEAD OF F() ARRAY.
							! BBC. 12/84.
325   CONTINUE
C******************************************************************************
C*****PRIVATE CATALOG
      IF (I7 .GT. 0) THEN
        WRITE(5,11)'PRV'
        WRITE(5,24)'WL',WLF1,WLF2,WLF3,WLF4,WLF5
      END IF
      DO 350,I=1,I7
C CHANGED .OR.'S TO .AND.'S. THE STATEMENT WAS ALWAYS LOGICALLY TRUE BEFORE.
C BBC 9/84.
        IF ((GLASS(INDEX(I))(1:4) .NE. 'HOYA') .AND.
     *      (GLASS(INDEX(I))(1:6) .NE. 'SCHOTT') .AND.
     *      (GLASS(INDEX(I))(1:5) .NE. 'OHARA') .AND.
     *      (GLASS(INDEX(I))(1:3) .NE. 'AIR') .AND.
     *      (GLASS(INDEX(I))(1:4) .NE. 'REFL') .AND.
     *      (GLASS(INDEX(I))(1:1) .NE. ' ')) THEN
           WRITE(5,32)GLASS(INDEX(I)),RFND1(I),RFND2(I),RFND3(I),
     *       RFND4(I),RFND5(I)
        END IF
350   CONTINUE
C******************************************************************************
C*****SOLVES
      IF (I6 .GT. 0) WRITE(5,9)'SOLVES'
      DO 375,I=1,I6
        IF (SOLVE(I) .EQ. '1   ') THEN
          WRITE(5,34)'THI',NSOLVE(I),'MRY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '2   ') THEN
          WRITE(5,34)'THI',NSOLVE(I),'CRY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '3   ') THEN
          WRITE(5,34)'THI',NSOLVE(I),'MRX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '4   ') THEN
          WRITE(5,34)'THI',NSOLVE(I),'CRX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '5   ') THEN
          WRITE(5,34)'CUY',NSOLVE(I),'MRY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '6   ') THEN
          WRITE(5,34)'CUY',NSOLVE(I),'CRY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '7   ') THEN
          WRITE(5,34)'CUY',NSOLVE(I),'AMY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '8   ') THEN
          WRITE(5,34)'CUY',NSOLVE(I),'IMY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '9   ') THEN
          WRITE(5,34)'CUY',NSOLVE(I),'ACY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '10  ') THEN
          WRITE(5,34)'CUY',NSOLVE(I),'ICY',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '11  ') THEN
          WRITE(5,34)'CUX',NSOLVE(I),'MRX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '12  ') THEN
          WRITE(5,34)'CUX',NSOLVE(I),'CRX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '13  ') THEN
          WRITE(5,34)'CUX',NSOLVE(I),'AMX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '14  ') THEN
          WRITE(5,34)'CUX',NSOLVE(I),'IMX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '15  ') THEN
          WRITE(5,34)'CUX',NSOLVE(I),'ACX',SOLVF1(I)
        ELSE IF (SOLVE(I) .EQ. '16  ') THEN
          WRITE(5,34)'CUX',NSOLVE(I),'ICX',SOLVF1(I)
        END IF
375   CONTINUE
C******************************************************************************
C*****MESSAGES
      DO 400,I=1,M
      IF (MESSAGE(I) .EQ. 1) THEN
        WRITE(5,36)':The following data type cannot be translated.'
        WRITE(5,37)':',SUBMES1(I)
      ELSE IF (MESSAGE(I) .EQ. 2) THEN
        WRITE(5,38)':X-torics cannot be translated.'
      ELSE IF (MESSAGE(I) .EQ. 3) THEN
        WRITE(5,39)':The following pick up cannot be translated ',
     *    'due to the non-zero B value.'
        WRITE(5,40)':',SUBMES2(I)
      ELSE IF (MESSAGE(I) .EQ. 4) THEN
        WRITE(5,41)':The following pick up type cannot be translated.'
        WRITE(5,40)':',SUBMES2(I)
      ELSE IF (MESSAGE(I) .EQ. 5) THEN
        WRITE(5,42)':The following solve cannot be translated.'
        WRITE(5,43)':',SUBMES3(I)
      ELSE IF (MESSAGE(I) .EQ. 6) THEN
        WRITE(5,44)':The following pick up cannot be translated ',
     *    'because the A value must equal +-1.0'
        WRITE(5,40)':',SUBMES2(I)
      END IF
400   CONTINUE
      RETURN
      END


!******************************************************
! This example program is part of HiggsSignals (TS 05/03/2013).
!******************************************************
program HBandHSwithSLHA
!
! In this example we run both HiggsBounds and HiggsSignals simultaneously
! on SLHA file(s). NOTE: The feature of selecting different experimental
! data in HiggsBounds is not fully supported here. In particular, the onlyL
! option of HiggsBounds does not work (it will be turned into LandH).
! If you want to take into account only LEP limits in HiggsBounds, you have
! to run both programs separately, using e.g. the example programs
! HBwithSLHA and HSwithSLHA.
!
! The SLHA file(s) has to contain the two HiggsBounds SLHA
! input blocks
!	HiggsBoundsInputHiggsCouplingsBosons
!	HiggsBoundsInputHiggsCouplingsFermions
! (see HiggsBounds (version 3 or more) manual for more details)
!
! Run with
!   ./HSwithSLHA npoints <stem>
! where npoints is the number of parameter points you would like to
! look at and each parameter point has a corresponding SLHA file
! e.g. the corresponding SLHA for the 5th point should be found at
!   <stem>.5
!
! Output
! The block HiggsSignalsResults will be added to each SLHA file.
!
!******************************************************
  use io, only : HiggsSignals_SLHA_output, get_peakinfo_from_HSresults

  implicit none
  integer :: nH,nHplus,ndf,iter,HBresult,chan,ncombined
  double precision :: obsratio
  double precision :: Chisq, Chisq_mu, Chisq_mh, Pvalue
  double precision, allocatable :: dMh(:), dCS(:), dBR(:)
  integer :: i,npoints
  integer,parameter :: fileid=78, fileid2=79
  character(len=8) :: istring
  character(len=300) :: inputfilename,outputfilename
  character(len=300) :: stem
  character(LEN=300) :: temp, tmpstring
  integer :: number_args, ios

  nH=3
  nHplus=1

  allocate(dMh(nH))
!--Give estimates on (relative!) systematic uncertainties for:
!  dCS(1) - singleH				dBR(1) - gamma gamma
!  dCS(2) - VBF					dBR(2) - W W
!  dCS(3) - HW					dBR(3) - Z Z
!  dCS(4) - HZ					dBR(4) - tau tau
!  dCS(5) - ttH					dBR(5) - b bbar
  allocate(dCS(5),dBR(5))
!--Enter now the rate uncertainties for your model (typical MSSM estimates):
  dCS = (/ 0.20D0, 0.028D0, 0.037D0, 0.051D0, 0.12D0 /)
  dBR = (/ 0.054D0, 0.048D0, 0.048D0, 0.061D0, 0.028D0 /)
!--n.b. have to set theoretical uncertainties on Higgs masses dMh (in GeV) for h,H,A:
  dMh = (/ 2.0D0, 2.0D0, 0.0D0 /)
!-------------------------- preprocessing ------------------------------!
  number_args = IARGC()
  if( number_args .ne. 2)then
   stop "Incorrect number of arguments given to HSwithSLHA"
  endif
  ! Read arguments into text strings.
  i=1
  temp=""
  call GETARG(i,temp)
  read(temp,*) npoints
  i=i+1
  temp=""
  call GETARG(i,temp)
  stem = ""
  stem = trim(temp)
!---------------------------- HiggsBounds and HiggsSignals ------------------------------!
!---- Initialize HiggsBounds and specify the dataset it should use 				     ----!
 call initialize_HiggsBounds(nH,nHplus,'LandH')
!---- Initialize HiggsSignals and pass the name of the experimental analysis folder  ----!
 call initialize_HiggsSignals(nH,nHplus,"latestresults")
!------------------------------ HiggsSignals options ------------------------------------!
!---- Set the output level (0: silent, 1: screen output, 2: even more output,...) 	 ----!
 call setup_output_level(1)
!---- Set the Higgs mass parametrization (1: box, 2:gaussian, 3:box+gaussian)	 	 ----!
 call setup_pdf(2)
!---- Set number of iterations to find the (best) Higgs-to-peaks assignment		 	 ----!
 call setup_Higgs_to_peaks_assignment_iterations(0)
!---- If the mass-centered chi^2 method is used, can specify the dm_theory treatment ----!
!     1: mass variation, 2: smearing of mu-plot with mass pdf
 call setup_mcmethod_dm_theory(1)

  outputfilename=trim(adjustl(stem))//'-fromHBandHS'

  open(fileid, file=trim(outputfilename))

  do i=1,npoints

   if(i.gt.99999999)stop'need to increase the size of istring in HSwithSLHA'
   write(istring,'(I8)')i

   inputfilename=trim(adjustl(stem))//'.'//trim(adjustl(istring))

!--Test if input file exists and is non-empty
   open(fileid2, file=inputfilename, form='formatted')
   read(fileid2,'(A)',iostat=ios) tmpstring

   if(ios.eq.0) then
    close(fileid2)

!---------------------- HiggsBounds and HiggsSignals run --------------------------------!
!---- Feed HiggsBounds/Signals with the the model input using HiggsBounds subroutine ----!
    call HiggsBounds_input_SLHA(inputfilename)
!---- We want to use the mass variation treatment for the theoretical uncertainty    ----!
!	  HiggsBounds. Thus we set the mass uncertainties here (neutral Higgses mass errors
!     set to dMh, charged Higgs mass error set to 0.0D0)
    call HiggsBounds_set_mass_uncertainties(dMh,0.0D0)
!---- First, run HiggsBounds														 ----!
    call run_HiggsBounds(HBresult, chan, obsratio, ncombined)
!---- Now, we have to fill again the input for the HiggsSignals run	 	 			 ----!
    call HiggsBounds_input_SLHA(inputfilename)
!---- Pass the Higgs mass uncertainty to HiggsSignals							 	 ----!
	call HiggsSignals_neutral_input_MassUncertainty(dMh)
!---- Set the production and decay rate uncertainties for the model			 	 	 ----!
    call setup_rate_uncertainties(dCS, dBR)
!---- Run HiggsSignals																 ----!
    call run_HiggsSignals(1, Chisq_mu, Chisq_mh, Chisq, ndf, Pvalue)
!----------------------------- HiggsSignals output --------------------------------------!
!---- Attach HiggsBounds SLHA output block to SLHA file  							 ----!
    call HiggsBounds_SLHA_output
!---- Attach HiggsSignals SLHA output blocks to SLHA file							 ----!
!   integer argument gives level of details:
!   0 : writes only HiggsSignalsResults block
!   else : writes all blocks
    call HiggsSignals_SLHA_output(1)
!---- This will collect the main HiggsSignals results together into one file		 ----!
    write(fileid,*)i,Pvalue,Chisq,ndf,HBresult,chan,obsratio,ncombined
   else
    close(fileid2)
    call system("rm -f "//inputfilename)
   endif
  enddo

  close(fileid)

  call finish_HiggsBounds
  call finish_HiggsSignals

end program HBandHSwithSLHA


      subroutine mgt_harvtuber (jj, iplant, iharvop)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine performs the harvest grain only operation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units          |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

      use basin_module
      use hru_module, only : ipl
      use plant_module
      use plant_data_module
      use mgt_operations_module
      use carbon_module
      use organic_mineral_mass_module

      implicit none

      integer :: j                      !none           |HRU number
      integer, intent (in) :: jj        !none           |hru number
      integer, intent (in) :: iplant    !               |plant number from plant community
      integer, intent (in) :: iharvop   !               |harvest operation type
      real :: harveff                   !0-1            |harvest efficiency
      integer :: idp                    !none           |plant number from plants.plt
      real :: harveff1                  !0-1            |1.-harveff

      j = jj
      ipl = iplant
      idp = pcom(j)%plcur(ipl)%idplt
      harveff = harvop_db(iharvop)%eff

      !! remove seed mass from total plant mass and calculate yield
      pl_mass(j)%tot(ipl) = pl_mass(j)%tot(ipl) - pl_mass(j)%seed(ipl)

      !! tuber yield = harvest index * above ground biomass
      pl_yield = harveff * pl_mass(j)%seed(ipl)

      !! apply pest stress to harvest index - mass lost due to pests - don't add to residue
      pl_yield = (1. - pcom(j)%plcur(ipl)%pest_stress) * pl_yield

      !! add remaining tuber (seed) mass to slow humus pool of soil - to preserve balances
      harveff1 = 1. - harveff
      soil1(j)%hs(1) = harveff1 * pl_mass(j)%seed(ipl) + soil1(j)%hs(1)

      !! zero seed mass
      pl_mass(j)%seed(ipl) = plt_mass_z

      return
      end  subroutine mgt_harvtuber


      SUBROUTINE HELEFI( NOUT, AVGPOT, CVECT, SHORTO,
     &             STRMAX, STRNOP, STRNON, STRC1, STRC2,
     &             ATMAX, ATNO, ATBRK, ATRES,
     &             ATCHN, ATRNO, ATXYZ, ATVDW, ATBND)
      IMPLICIT NONE
C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 11/96 O.S. Smart      First version
C
C 5/11/96 Routine to work out the electrostatic potential created along
C pore centre line by formal charges in the system

C passed variables *************

C output stream no. (usually set to 6) RETURN UNCHANGED
      INTEGER			NOUT

C average electrostatic potential as calculated by HELEFI
C excluding HIS - needed for conductance prediction algorithm contained
C in s/r HCAPGR
      DOUBLE PRECISION		AVGPOT

C The channel vector - already united
      DOUBLE PRECISION		CVECT(3)

C store for sphere centres and radii
C store the initial point as no 0 and subseqently points in the +ve
C bit. Points below the initial point are stored in -ve bit.
C maximum number of entries
      INTEGER                   STRMAX
C the no. of entries, +Ve entries -Ve entries
      INTEGER                   STRNOP, STRNON
C the sphere centres or ends of capsule
C n.b. this routine has to work just the same for
C normal spheres (when strc1 = strc2 for each element)
C and capsule option when the centre line is given by (strc1+strc2)/2
      DOUBLE PRECISION          STRC1(3,-STRMAX:STRMAX),
     &                          STRC2(3,-STRMAX:STRMAX)

C 11/95 introduce new variable to reduce text output -
C if oshort =
C 0: full text output
C 1: no in run progress reported
C 2: ditto plus no graph type output - only leaving
C    Minimum radius & conductance calculations.
C 3: All text output other than input card mirroring
C    and error messages turned off
      INTEGER                   SHORTO

C maximum no. of atoms
      INTEGER                   ATMAX

C number of atoms read in from each file:
      INTEGER                   ATNO

C atom names found in Brookhaven file:
      CHARACTER*4               ATBRK(ATMAX)

C residue name in brook
      CHARACTER*3               ATRES(ATMAX)

C chain identifier in brookhaven pdb file
      CHARACTER*1               ATCHN(ATMAX)

C integer residue no.
      INTEGER                   ATRNO(ATMAX)

C co-ordinates
      DOUBLE PRECISION          ATXYZ( 3, ATMAX)

C vdw and bond radii of each atoms
      DOUBLE PRECISION          ATVDW(ATMAX), ATBND(ATMAX)

C internal vbles ***************

C formal charge store
C maximum number of entries
      INTEGER			FCHMAX
      PARAMETER(		FCHMAX = 5000)
C the actual number of entries
      INTEGER			FCHNUM
C value of the charge in |electron| charge units
      DOUBLE PRECISION          FCHVAL( FCHMAX)
C coordinates of the charge
      DOUBLE PRECISION          FCHXYZ( 3, FCHMAX)
C is this charge a his?
C (do 2calc's one with his +ve the other with his neutral)
      LOGICAL 			FCHHIS( FCHMAX)

C loop count for atoms, for sphere centres, field calc
      INTEGER			ACOUNT, LCOUNT, FCOUNT

C temporary charge
      DOUBLE PRECISION		TCHARG

C keep count of total charge (a) on his's (b) on every thing else
      DOUBLE PRECISION		TOTHIS, TOTNOR

C test centre, the coord
      DOUBLE PRECISION		TSTCEN(3), CCOORD

C electrostatic field due to normal groups, and due to +1HIS
      DOUBLE PRECISION		FELNOR, FELHIS

C vble for distance calc
      DOUBLE PRECISION		DIST

C end of decs ******************

C initialize avg pot
      AVGPOT = 0.

C only produce graph info if shorto = 0 or 1
      IF (SHORTO.LE.1) THEN
        WRITE( NOUT, '(A)')
     &' ',
     &' This is routine helefi: will work out electrostatic potential',
     &' produced by formal charges of molecule down the pore centre',
     &' in vacuo',
     &' ',
     &' Identifying formal charges on the molecule:'

C write header
        WRITE( NOUT, '(5X,A4,8X,A8,1X,A1,5X,A5)')
     &     'atom', 'charge', 'H?', ' coords '
      ENDIF

C initialize the charge store array
      FCHNUM = 0.
      TOTHIS = 0.
      TOTNOR = 0.

C go thru atoms finding the formal charges:
      DO 10 ACOUNT = 1, ATNO

C default charge is zero - no charge
        TCHARG = 0.0

C do we have an ASP?
        IF     (ATRES(ACOUNT).EQ.'ASP') THEN
C is the atom OD1 or OD2 - if so give it a charge of -0.5
          IF (ATBRK(ACOUNT)(1:2).EQ.'OD') TCHARG = -0.5

C do we have an GLU?
        ELSEIF (ATRES(ACOUNT).EQ.'GLU') THEN
C is the atom OE1 or OE2 - if so give it a charge of -0.5
          IF (ATBRK(ACOUNT)(1:2).EQ.'OE') TCHARG = -0.5

C do we have an ARG?
        ELSEIF (ATRES(ACOUNT).EQ.'ARG') THEN
C is the atom NE, NH1 or NH2 - if so give it a charge of +0.333333
          IF (ATBRK(ACOUNT)(1:2).EQ.'NE') TCHARG = +0.333333
          IF (ATBRK(ACOUNT)(1:2).EQ.'NH') TCHARG = +0.333333

C do we have an LYS?
        ELSEIF (ATRES(ACOUNT).EQ.'LYS') THEN
C is the atom NZ  - if so give it a charge of +1.0
          IF (ATBRK(ACOUNT)(1:2).EQ.'NZ') TCHARG = +1.0

C do we have an HIS/HID/HIE?
        ELSEIF ( (ATRES(ACOUNT).EQ.'HIS') .OR.
     &           (ATRES(ACOUNT).EQ.'HIE') .OR.
     &           (ATRES(ACOUNT).EQ.'HID')     ) THEN
C is the atom ND1 or NE  -  if so give it a charge of +0.5
C and indicate it should be regarded as a HIS by multiplying by 1E10
          IF (ATBRK(ACOUNT)(1:2).EQ.'ND') TCHARG = +0.5E10
          IF (ATBRK(ACOUNT)(1:2).EQ.'NE') TCHARG = +0.5E10

        ENDIF

C if TCHARG is not zero then have formal charge so should make another list
C entry
        IF (ABS(TCHARG).GT.0.005) THEN
C do we have enough room?
          IF (FCHNUM.GE.FCHMAX) THEN
            WRITE( NOUT, '(A/ A,I5,A/ A)')
     &' ERROR in s/r helefi',
     &' Have hit array bound limit FCHMAX=', FCHMAX,
     &     ' for number of formal charges identified',
     &' Cannot continue with routine. '
            GOTO 55555
          ENDIF
C we have enough room so make this entry
          FCHNUM = FCHNUM + 1
C an a very big positive value for charge indicates HIS
C change to +0.5 and log
          IF (TCHARG.GT.1E9) THEN
            FCHVAL(FCHNUM) = +0.5
            FCHHIS(FCHNUM) = .TRUE.
C keep count of total formal charge with and without HIS
            TOTHIS = TOTHIS + FCHVAL(FCHNUM)
          ELSE
C normal non-his charge
            FCHVAL(FCHNUM) = TCHARG
            FCHHIS(FCHNUM) = .FALSE.
C keep count of total formal charge with and without HIS
            TOTNOR = TOTNOR + FCHVAL(FCHNUM)
          ENDIF
C coordinates of the charge
          FCHXYZ( 1, FCHNUM) = ATXYZ( 1, ACOUNT)
          FCHXYZ( 2, FCHNUM) = ATXYZ( 2, ACOUNT)
          FCHXYZ( 3, FCHNUM) = ATXYZ( 3, ACOUNT)
C echo to screen
          IF (SHORTO.LE.1)
     &      WRITE( NOUT, '(A4,1X,A3,1X,A1,I5,F8.3,2X,L1,3F8.3)')
     &      ATBRK(ACOUNT), ATRES(ACOUNT), ATCHN(ACOUNT), ATRNO(ACOUNT),
     &      FCHVAL(FCHNUM), FCHHIS(FCHNUM),
     &      FCHXYZ( 1, FCHNUM), FCHXYZ( 2, FCHNUM), FCHXYZ( 3, FCHNUM)
        ENDIF

C end of going thru atoms.
10    CONTINUE

      IF (SHORTO.LE.1) THEN
        WRITE( NOUT, '(A/2(A,F8.3/))' )
     &' ',
     &' Total charge  excluding HIS = ', TOTNOR,
     &'               including HIS = ', TOTNOR+TOTHIS

C write header of data
        WRITE( NOUT, '(A)')
     &' ',
     &' Data for graph of potential versus channel coordinate',
     &' potential given in units of kcal/mol per proton charge'
        WRITE( NOUT, '(3A12)') 'ch_coord', 'potexclHIS', 'potinclHIS'
      ENDIF

C Have got all the charges set up in the appropriate array
C now go up sphere centre line
      DO 20 LCOUNT = -STRNON, STRNOP
C load the mid-point into tstcen
        TSTCEN(1) = 0.5*(STRC1(1,LCOUNT)+STRC2(1,LCOUNT))
        TSTCEN(2) = 0.5*(STRC1(2,LCOUNT)+STRC2(2,LCOUNT))
        TSTCEN(3) = 0.5*(STRC1(3,LCOUNT)+STRC2(3,LCOUNT))
C coordinate of point
        CALL DDOT( TSTCEN, CVECT, CCOORD)

C find electrostatic field at point tstcen caused by charges
C held in array FCH***
        FELNOR = 0D0
        FELHIS = 0D0
        DO 30 FCOUNT = 1, FCHNUM
C find distance between charge centre and tstcen
          DIST = (TSTCEN(1)-FCHXYZ(1,FCOUNT))**2 +
     &           (TSTCEN(2)-FCHXYZ(2,FCOUNT))**2 +
     &           (TSTCEN(3)-FCHXYZ(3,FCOUNT))**2
          DIST = SQRT(DIST)
C add potential component to either the histidine count or the normal
          IF (FCHHIS(FCOUNT)) THEN
C n.b. units of potential are kcal/mol per proton charge
C (value of constant taken from tic)
            FELHIS = FELHIS + 331.850*FCHVAL(FCOUNT)/DIST
          ELSE
C normal charge
            FELNOR = FELNOR + 331.850*FCHVAL(FCOUNT)/DIST
          ENDIF
30      CONTINUE

C have worked out potential so write it out
        IF (SHORTO.LE.1)
     &    WRITE( NOUT, '(3F12.5)') CCOORD, FELNOR, FELNOR+FELHIS

C keep total so we can work out the average
        AVGPOT = AVGPOT + FELNOR

20    CONTINUE

C work out average potential
      AVGPOT = AVGPOT/(STRNON+STRNOP+1)

C return here
55555 CONTINUE
C flush output stream
      IF (NOUT.EQ.6) CALL FLUSH6

      RETURN
      END


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine vervlu ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Atmospheric exchange OMPs (volatilization/intake)

!
!     Description of the module :
!
! Name    T   L I/O   Description                                    Uni
! ----    --- -  -    -------------------                             --
! ATMC    R*4 1 I  Concentration OMV in atmosphere                [g.m3]
! CONC    R*4 1 I  Total concentration OMV in water               [g.m3]
! C1      R*4 1 I  Constant in temperature dependance of Henrys
!                  value represents delta S0 (entropy) / R           [-]
! C2      R*4 1 L  Constant in temperature dependence of Henrys
!                  value represents delta H0 (enthalpy) / R          [-]
! DEPTH   R*4 1 I  Depth                                             [m]
! E       R*4 1 LC Natural logaritmic                                [-]
! FDIS    R*4 1 I  Fraction omive free dissolved                     [-]
! FL      R*4 1 O  Calculated volatilizatioin flux              [g/m3/d]
! H0TREF  R*4 1 I  Henrys constant at reference temperature  [Pa.m3\mol]
! H2TREF  R*4 1 L  Dimensionless Henry at Tref
!                  on a basis of moelfraction      [molefracG/molefracL]
! H1TEMP  R*4 1 I  Dimensionless Henry at any TEMP     [mol/m3/(mol.m3)]
! KL      R*4 1 I  Mass transport coefficient liquid phase         [m/d]
! KG      R*4 1 I  Mass transport coefficient gas phase            [m/d]
! KV      R*4 1 O  volatilization rate constant                    [m/d]
! KELVIN  R*4 1 LC absolute temperature reference                    [-]
! NG      R*4 1 L  amount moles in 1m3 gas                     [mole/m3]
! NL      R*4 1 LC amount moles in 1m3 water                   [mole/m3]
! P       R*4 1 LC atmospheric pressure                             [Pa]
! R       R*4 1 LC universal gas constant                  [Pa.m3/mol/K]
! TREF    R*4 1 I  Reference temperature for H0                  [gradC]
! TEMP    R*4 1 I  Temperature                                   [gradC]
!-----------------------------------------------------------------------

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------
      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4
!
!     Local declarations, constants in source
!
      PARAMETER ( E      =     2.718  ,
     +            KELVIN =   273.15   ,
     +            NL     = 55510.     ,
     +            P      =     1.01E+5,
     +            R      =     8.314    )
!
      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
!
      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF (IKMRK1.EQ.1) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0).OR.(IKMRK2.EQ.1)) THEN
!
!
!     Map PMSA on local variables
!
      CONC   = MAX ( 0.0, PMSA(IP1 ) )
      ATMC   = PMSA(IP2 )
      KL     = PMSA(IP3 )
      KG     = PMSA(IP4 )
      H0TREF = PMSA(IP5 )
      TREF   = PMSA(IP6 )
      C1     = PMSA(IP7 )
      TEMP   = PMSA(IP8 )
      DEPTH  = PMSA(IP9 )
!
!
!     Error messages
      IF (H0TREF .LT. 1E-30)  CALL ERRSYS ('H0TREF in VERVLU =<0', 1 )
      IF ( TEMP .LE. -KELVIN) CALL
     &                 ERRSYS ('TEMP in VERVLU < 0 DEG KELVIN', 1 )
      IF (KL .LT. 1E-30) CALL ERRSYS ('KL in VERVLU zero', 1 )
      IF (KG .LT. 1E-30) CALL ERRSYS ('KG in VERVLU zero', 1 )
!
!     Calculation of temperarure dependence of Henry
      H2TREF = H0TREF * NL / P
!
      C2     = ( KELVIN + TREF ) * ( LOG(H2TREF) - C1 )
!
      NG     = P / ( R * (KELVIN + TEMP) )
!
      H1TEMP = NG/NL * E**(C2/(KELVIN + TEMP) + C1 )
!
!     Calculation of volatilization rate constant
!
      KV     = 1./(1./KL + 1./(H1TEMP*KG))
!
!     Calculation of volatilization flux
!
      FL (1 + IFLUX) = (CONC - ATMC / H1TEMP ) * KV / DEPTH
!
!     Output
      PMSA(IP10) = KV
      PMSA(IP11) = H1TEMP
!
      ENDIF
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + INCREM (  1 )
      IP2   = IP2   + INCREM (  2 )
      IP3   = IP3   + INCREM (  3 )
      IP4   = IP4   + INCREM (  4 )
      IP5   = IP5   + INCREM (  5 )
      IP6   = IP6   + INCREM (  6 )
      IP7   = IP7   + INCREM (  7 )
      IP8   = IP8   + INCREM (  8 )
      IP9   = IP9   + INCREM (  9 )
      IP10  = IP10  + INCREM ( 10 )
      IP11  = IP11  + INCREM ( 11 )
!
 9000 CONTINUE
!
!
      RETURN
      END


      module driver_module

c***********************************************************************
c
c     dl_poly module for defining simulation driver routines
c     copyright - daresbury laboratory
c     author    - w. smith    sep 2003
c     adapted   - d.quigley   nov 2010 metadynamics
c
c***********************************************************************

      use config_module
      use forces_module
      use nlist_builders_module
      use optimiser_module
      use temp_scalers_module

      implicit none

      integer, parameter :: mxpass=250

      contains

      subroutine molecular_dynamics
     x  (lfcap,lgofr,lneut,lnsq,loglnk,loptim,lzeql,lzero,newlst,
     x  stropt,cycle,ltad,lsolva,lfree,lghost,lpimd,idnode,imcon,
     x  keyfce,keyfld,keyshl,keystr,keytol,kmax1,kmax2,kmax3,multt,
     x  mxnode,natms,ngrp,nhko,nlatt,nneut,nospl,nscons,nstbgr,nstep,
     x  nsteql,ntangl,ntbond,ntdihd,ntfree,ntinv,ntpfbp,ntpmet,ntptbp,
     x  ntpter,ntpvdw,ntshl,ntteth,ntcons,numrdf,nsolva,isolva,nbeads,
     x  alpha,delr,dlrpot,drewd,elrc,engang,engbnd,engcpe,engdih,
     x  engfbp,engfld,enginv,engshl,engsrp,engtbp,engter,engtet,
     x  epsq,fmax,opttol,rctter,rcut,rcutfb,rcuttb,rprim,rvdw,shlke,
     x  engcfg,temp,tstep,virang,virbnd,vircpe,virdih,virfbp,virfld,
     x  virinv,virlrc,virmet,virshl,virsrp,virtbp,virter,virtet,volm,
     x  engmet,virtot,engord,virord,engrng,virrng,qmsbnd)

c***********************************************************************
c
c     dl_poly subroutine for controlling subroutine calls in a standard
c     molecular dynamics simulation
c
c     copyright - daresbury laboratory
c     author    - w. smith    aug 2006
c     adapted   - d.quigley   nov 2010 metadynamics
c
c***********************************************************************

      implicit none

      logical lfcap,lgofr,lneut,lnsq,loglnk,loptim,lzeql,lzero
      logical newlst,stropt,cycle,ltad,lsolva,lfree,lghost,lpimd

      integer idnode,imcon,keyfce,keyfld,keyshl,keytol,ntcons
      integer keystr,kmax1,kmax2,kmax3,multt,mxnode,natms,ngrp
      integer nhko,nlatt,nneut,nospl,nscons,nstbgr,nstep,nsteql
      integer ntangl,ntbond,ntdihd,ntfree,ntinv,ntpfbp,ntpmet
      integer ntptbp,ntpter,ntpvdw,ntshl,ntteth,numrdf,nsolva
      integer isolva,nbeads

      real(8) alpha,delr,dlrpot,drewd,elrc,engang,engbnd
      real(8) engcpe,engdih,engfbp,engfld,enginv,engshl,engsrp
      real(8) engtbp,engter,engtet,epsq,fmax,opttol,rctter
      real(8) rcut,rcutfb,rcuttb,rprim,rvdw,shlke,engcfg,temp
      real(8) tstep,virang,virbnd,vircpe,virdih,virfbp
      real(8) virfld,virinv,virlrc,virmet,virshl,virsrp
      real(8) virtbp,virter,virtet,volm,engmet,virtot
      real(8) engord,virord,engrng,virrng,qmsbnd

c     construct verlet neighbour list

      call nlist_driver
     x  (newlst,lneut,lnsq,loglnk,ltad,natms,nbeads,idnode,mxnode,
     x  imcon,nneut,keyfce,rcut,delr,tstep)

c     calculate atomic forces

      call force_manager
     x  (newlst,lneut,lnsq,lgofr,lzeql,loglnk,lfcap,lsolva,lfree,
     x  lghost,lpimd,idnode,mxnode,natms,imcon,nstep,nstbgr,nsteql,
     x  numrdf,keyfce,kmax1,kmax2,kmax3,nhko,nlatt,ntpvdw,
     x  ntpmet,nospl,multt,nneut,ntptbp,ntpfbp,ntpter,keyshl,
     x  keyfld,ntbond,ntangl,ntdihd,ntinv,ntteth,ntshl,nsolva,
     x  isolva,nbeads,delr,dlrpot,engcpe,engsrp,epsq,rcut,rprim,rvdw,
     x  vircpe,virsrp,alpha,drewd,volm,engmet,virmet,elrc,virlrc,
     x  rcuttb,engtbp,virtbp,rcutfb,engfbp,virfbp,rctter,engter,
     x  virter,engbnd,virbnd,engang,virang,engdih,virdih,enginv,
     x  virinv,engtet,virtet,engshl,shlke,virshl,engfld,virfld,
     x  engcfg,fmax,temp,engord,virord,engrng,virrng,qmsbnd)

c     frozen atoms option

      call freeze(natms)

c     structure optimisation

      if(loptim.or.lzero)then

        call optimisation_selector
     x    (loptim,stropt,lzero,idnode,mxnode,natms,imcon,ntcons,
     x    nscons,ngrp,ntfree,keystr,keytol,engcfg,tstep,opttol)

        if(stropt.and.idnode.eq.0)
     x    write(nrite,"(/,/,1x,'structure optimisation converged ',
     x    'at step ',i6,/,/,/,1x,120('-'))") nstep

        cycle=(cycle.and.(.not.stropt))

      endif

c     total virial (excluding constraint virial and c.o.m virial)
c     for npt routines     note: virsrp already includes virlrc

      virtot=vircpe+virsrp+virbnd+virtbp+virter+virfld+
     x  virang+virshl+virtet+virmet+virord+virrng

      return
      end subroutine molecular_dynamics

      subroutine shell_relaxation
     x  (lfcap,lgofr,lneut,lnsq,loglnk,lzeql,newlst,ltad,lsolva,
     x  lfree,lghost,idnode,imcon,keyfce,keyfld,keyshl,
     x  kmax1,kmax2,kmax3,multt,mxnode,natms,nhko,nlatt,nneut,
     x  nospl,nstbgr,nstep,nsteql,ntangl,ntbond,ntdihd,ntinv,
     x  ntpfbp,ntpmet,ntptbp,ntpter,ntpvdw,ntshl,ntteth,numrdf,
     x  ntpmls,nsolva,isolva,alpha,delr,dlrpot,drewd,elrc,engang,
     x  engbnd,engcpe,engdih,engfbp,engfld,enginv,engshl,engsrp,
     x  engtbp,engter,engtet,epsq,fmax,rctter,rcut,rcutfb,rcuttb,
     x  rprim,rvdw,shlke,engcfg,temp,tstep,virang,virbnd,vircpe,
     x  virdih,virfbp,virfld,virinv,virlrc,virmet,virshl,virsrp,
     x  virtbp,virter,virtet,volm,engmet,virtot,rlxtol,pass0,
     x  pass1,pass2,engord,virord)

c***********************************************************************
c
c     dl_poly subroutine for controlling subroutine calls in a
c     relaxed shell molecular dynamics simulation
c
c     copyright - daresbury laboratory
c     author    - w. smith    aug 2006
c     adapted   - d.quigley   nov 2010 metadynamics
c
c***********************************************************************

      implicit none

      logical,save :: lfirst = .true.
      logical lfcap,lgofr,lneut,lnsq,loglnk,lzeql,ltad,lpimd
      logical newlst,relaxed,shgofr,lsolva,lfree,lghost

      integer idnode,imcon,keyfce,keyfld,keyshl,nbeads
      integer kmax1,kmax2,kmax3,multt,mxnode,natms,l1,l2
      integer nhko,nlatt,nneut,nospl,nstbgr,nstep,nsteql
      integer ntangl,ntbond,ntdihd,ntinv,ntpfbp,ntpmet
      integer ntptbp,ntpter,ntpvdw,ntshl,ntteth,numrdf
      integer keyrlx,ntpmls,pass,nsolva,isolva,ia,ib,ishl
      integer mtshl

      real(8) alpha,delr,dlrpot,drewd,elrc,engang,engbnd
      real(8) engcpe,engdih,engfbp,engfld,enginv,engshl,engsrp
      real(8) engtbp,engter,engtet,epsq,fmax,rctter
      real(8) rcut,rcutfb,rcuttb,rprim,rvdw,shlke,engcfg,temp
      real(8) tstep,virang,virbnd,vircpe,virdih,virfbp
      real(8) virfld,virinv,virlrc,virmet,virshl,virsrp
      real(8) virtbp,virter,virtet,volm,engmet,virtot,rlxtol
      real(8) pass0,pass1,pass2,engord,virord,engrng,virrng
      real(8) qmsbnd

      real(8),allocatable,dimension(:),save :: xdcs,ydcs,zdcs

      pass=0
      keyrlx=0
      shgofr=lgofr
      relaxed=.false.
c     dummy variables for pimd option
      lpimd=.false.
      nbeads=1
      engrng=0.d0
      virrng=0.d0
      qmsbnd=0.d0

      l1=(idnode*ntshl)/mxnode
      l2=((idnode+1)*ntshl)/mxnode
      mtshl=l2-l1

      if(lfirst)then

        allocate(xdcs(1:mtshl))
        allocate(ydcs(1:mtshl))
        allocate(zdcs(1:mtshl))
        lfirst = .false.

      else

        do ishl=1,mtshl

          ia=listshl(ishl,2)
          ib=listshl(ishl,3)
          xxx(ib)=xxx(ia)+xdcs(ishl)
          yyy(ib)=yyy(ia)+ydcs(ishl)
          zzz(ib)=zzz(ia)+zdcs(ishl)

        enddo

      endif

      do while(.not.relaxed.and.pass.le.mxpass)

c     construct verlet neighbour list

        call nlist_driver
     x    (newlst,lneut,lnsq,loglnk,ltad,natms,nbeads,idnode,mxnode,
     x    imcon,nneut,keyfce,rcut,delr,tstep)

c     calculate atomic forces

        call force_manager
     x    (newlst,lneut,lnsq,shgofr,lzeql,loglnk,lfcap,lsolva,lfree,
     x    lghost,lpimd,idnode,mxnode,natms,imcon,nstep,nstbgr,nsteql,
     x    numrdf,keyfce,kmax1,kmax2,kmax3,nhko,nlatt,ntpvdw,
     x    ntpmet,nospl,multt,nneut,ntptbp,ntpfbp,ntpter,keyshl,
     x    keyfld,ntbond,ntangl,ntdihd,ntinv,ntteth,ntshl,nsolva,
     x    isolva,nbeads,delr,dlrpot,engcpe,engsrp,epsq,rcut,rprim,rvdw,
     x    vircpe,virsrp,alpha,drewd,volm,engmet,virmet,elrc,virlrc,
     x    rcuttb,engtbp,virtbp,rcutfb,engfbp,virfbp,rctter,engter,
     x    virter,engbnd,virbnd,engang,virang,engdih,virdih,enginv,
     x    virinv,engtet,virtet,engshl,shlke,virshl,engfld,virfld,
     x    engcfg,fmax,temp,engord,virord,engrng,virrng,qmsbnd)

c     frozen atoms option

        call freeze(natms)

c     total virial (excluding constraint virial and c.o.m virial)
c     for npt routines     note: virsrp already includes virlrc

        virtot=vircpe+virsrp+virbnd+virtbp+virter+virfld+
     x    virang+virshl+virtet+virmet+virord+virrng

c     relaxed shell option

        call relax_shells
     x    (relaxed,keyrlx,idnode,mxnode,natms,ntpmls,tstep,
     x    rlxtol)

        if(relaxed)then

          pass1=pass0*pass1
          pass0=pass0+1.d0
          pass1=pass1/pass0+pass/pass0
          pass2=max(dble(pass),pass2)

        endif

        pass=pass+1
        if(pass.gt.mxpass)call error(idnode,1950)
        shgofr=.false.

c     end of shell relaxation

      enddo

c     store vector connecting the cores to the shells

      do ishl=1,mtshl

        ia=listshl(ishl,2)
        ib=listshl(ishl,3)
        xdcs(ishl)=xxx(ib)-xxx(ia)
        ydcs(ishl)=yyy(ib)-yyy(ia)
        zdcs(ishl)=zzz(ib)-zzz(ia)

      enddo

      call images(imcon,0,1,mtshl,cell,xdcs,ydcs,zdcs)

      return
      end subroutine shell_relaxation

      subroutine minimiser
     x  (lfcap,lneut,lnsq,loglnk,lzeql,newlst,idnode,imcon,keyfce,
     x  keyfld,keyshl,keytol,kmax1,kmax2,kmax3,multt,mxnode,natms,
     x  ngrp,nhko,nlatt,nneut,nospl,nscons,ntcons,nstbgr,nstep,
     x  nsteql,ntangl,ntbond,ntdihd,ntfree,ntinv,ntpfbp,ntpmet,
     x  ntptbp,ntpter,ntpvdw,ntshl,ntteth,numrdf,alpha,delr,dlrpot,
     x  drewd,elrc,engang,engbnd,engcpe,engdih,engfbp,engfld,enginv,
     x  engshl,engsrp,engtbp,engter,engtet,epsq,fmax,opttol,rctter,
     x  rcut,rcutfb,rcuttb,rprim,rvdw,shlke,engcfg,temp,tstep,
     x  virang,virbnd,vircpe,virdih,virfbp,virfld,virinv,virlrc,
     x  virmet,virshl,virsrp,virtbp,virter,virtet,volm,engmet,
     x  virtot,sigma,tolnce,engunit,engord,virord)

c***********************************************************************
c
c     dl_poly subroutine for controlling subroutine calls in a
c     minimisation simulation
c
c     copyright - daresbury laboratory
c     author    - w. smith    may 2007
c     adapted   - d.quigley   nov 2010 metadynamics
c
c***********************************************************************

      implicit none

      logical lfcap,lneut,lnsq,loglnk,lzeql,newlst,stropt,shgofr
      logical conopt,newjob,ltad,lsolva,lfree,lghost,lpimd,safe

      integer idnode,imcon,keyfce,keyfld,keyshl,keystr,pass,i
      integer kmax1,kmax2,kmax3,multt,mxnode,natms,ngrp,keytol
      integer nhko,nlatt,nneut,nospl,nscons,nstbgr,nstep,nsteql
      integer ntangl,ntbond,ntdihd,ntfree,ntinv,ntpfbp,ntpmet
      integer ntptbp,ntpter,ntpvdw,ntshl,ntteth,numrdf,ntcons
      integer fail,nsolva,isolva,nbeads

      real(8) alpha,delr,dlrpot,drewd,elrc,engang,engbnd
      real(8) engcpe,engdih,engfbp,engfld,enginv,engshl,engsrp
      real(8) engtbp,engter,engtet,epsq,fmax,opttol,rctter,sigma
      real(8) rcut,rcutfb,rcuttb,rprim,rvdw,shlke,engcfg,temp
      real(8) tstep,virang,virbnd,vircpe,virdih,virfbp
      real(8) virfld,virinv,virlrc,virmet,virshl,virsrp,tolnce
      real(8) virtbp,virter,virtet,volm,engmet,virtot,engcon
      real(8) cfgmin,engunit,hnorm,grad0,grad1,ff1,sgn
      real(8) engord,virord,engrng,virrng,qmsbnd

      real(8), allocatable :: sxx(:),syy(:),szz(:)

      save cfgmin,newjob

      data newjob/.true./

      pass=0
      keystr=0
      shgofr=.false.
      stropt=.false.

c     dummy variables

      ltad=.false.
      lsolva=.false.
      lfree=.false.
      lghost=.false.
      nsolva=0
      isolva=1
c     dummy variables for pimd option
      lpimd=.false.
      nbeads=1
      engrng=0.d0
      virrng=0.d0
      qmsbnd=0.d0

c$$$c     diagnostic printing (not usually active)
c$$$
c$$$      if(idnode.eq.0)then
c$$$
c$$$        write(nrite,"(1x,120('-'),
c$$$     x    /,/,1x,'    pass',5x,'eng_cfg',5x,'eng_vdw',5x,'eng_cou',
c$$$     x    5x,'eng_bnd',5x,'eng_ang',5x,'eng_dih',5x,'eng_tet',
c$$$     x    5x,'eng_met',/,1x,120('-'))")
c$$$
c$$$      endif

      do while(.not.stropt.and.pass.lt.mxpass)

        pass=pass+1

c     construct verlet neighbour list

        call nlist_driver
     x    (newlst,lneut,lnsq,loglnk,ltad,natms,nbeads,idnode,mxnode,
     x    imcon,nneut,keyfce,rcut,delr,tstep)

c     calculate atomic forces

        call force_manager
     x    (newlst,lneut,lnsq,shgofr,lzeql,loglnk,lfcap,lsolva,lfree,
     x    lghost,lpimd,idnode,mxnode,natms,imcon,nstep,nstbgr,nsteql,
     x    numrdf,keyfce,kmax1,kmax2,kmax3,nhko,nlatt,ntpvdw,
     x    ntpmet,nospl,multt,nneut,ntptbp,ntpfbp,ntpter,keyshl,
     x    keyfld,ntbond,ntangl,ntdihd,ntinv,ntteth,ntshl,nsolva,
     x    isolva,nbeads,delr,dlrpot,engcpe,engsrp,epsq,rcut,rprim,rvdw,
     x    vircpe,virsrp,alpha,drewd,volm,engmet,virmet,elrc,virlrc,
     x    rcuttb,engtbp,virtbp,rcutfb,engfbp,virfbp,rctter,engter,
     x    virter,engbnd,virbnd,engang,virang,engdih,virdih,enginv,
     x    virinv,engtet,virtet,engshl,shlke,virshl,engfld,virfld,
     x    engcfg,fmax,temp,engord,virord,engrng,virrng,qmsbnd)

c     frozen atoms option

        call freeze(natms)

c     total virial (excluding constraint virial and c.o.m virial)
c     for npt routines     note: virsrp already includes virlrc

        virtot=vircpe+virsrp+virbnd+virtbp+virter+virfld+
     x    virang+virshl+virtet+virmet+virord+virrng

c     conjugate gradient structure optimisation

        call strucopt
     x    (stropt,keystr,keytol,idnode,mxnode,natms,ntcons,nscons,
     x    imcon,ngrp,ntfree,tstep,opttol,engcfg,hnorm,grad0,grad1,
     x    ff1,sgn)

c$$$c     diagnostic printing (not usually active)
c$$$
c$$$        if(idnode.eq.0)then
c$$$
c$$$          write(nrite,"(1x,i8,1p,8e12.4)")
c$$$     x      pass,engcfg/engunit,engsrp/engunit,engcpe/engunit,
c$$$     x      engbnd/engunit,engang/engunit,engdih/engunit,engtet/
c$$$     x      engunit,engmet/engunit
c$$$          write(nrite,"(1x,120('-'))")
c$$$
c$$$        endif

c     end of structure minimisation

      enddo

c     ensure constraints are satisfied

      if(stropt.and.ntcons.gt.0)then

        fail=0
        safe=.true.
        allocate(sxx(mxatms),syy(mxatms),szz(mxatms),stat=fail)
        if(fail.ne.0)safe=.false.
        if(mxnode.gt.1)call gstate(safe)
        if(.not.safe)call error(idnode,74)

c     store current forces

        do i=1,natms

          sxx(i)=fxx(i)
          syy(i)=fyy(i)
          szz(i)=fzz(i)

        enddo

        keystr=0
        conopt=.false.

        do while(.not.conopt.and.pass.lt.mxpass)

          pass=pass+1
          engcon=0.d0

          do i=1,natms

            fxx(i)=0.d0
            fyy(i)=0.d0
            fzz(i)=0.d0

          enddo

c     conjugate gradient structure optimisation of constraint bonds

          call strucopt
     x      (conopt,keystr,keytol,idnode,mxnode,natms,ntcons,nscons,
     x      imcon,ngrp,ntfree,tstep,opttol,engcon,hnorm,grad0,grad1,
     x      ff1,sgn)

        enddo

c     restore current forces

        do i=1,natms

          fxx(i)=sxx(i)
          fyy(i)=syy(i)
          fzz(i)=szz(i)

        enddo

        deallocate(sxx,syy,szz,stat=fail)

      endif

c     write data summary

      if(idnode.eq.0)then

        if(stropt)then

          write(nrite,'(1x,"minimisation converged after ",i6," cycles"
     x      ," energy minimum: ",1pe12.4)')pass,engcfg/engunit

        else

          write(nrite,'(1x,"minimisation NOT converged after ",i6,
     x      " cycles")')pass

        endif

        write(nrite,"(1x,120('-'))")

      endif

c     reset velocities after structure optimisation

      call regauss(idnode,imcon,mxnode,natms,ngrp,nscons,ntcons,
     x  ntshl,keyshl,sigma,temp,tolnce)

c     write out minimised structure if lowest obtained so far

      if(newjob.or.cfgmin.gt.engcfg)then

        if(idnode.eq.0)call config_write('CFGMIN',0,imcon,natms,engcfg)
        cfgmin=engcfg
        newjob=.false.

      endif

      return
      end subroutine minimiser

      end module driver_module


C    Copyright(C) 2014-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: boxit.f,v 1.4 2004/01/26 17:28:18 gdsjaar Exp $
C $Log: boxit.f,v $
C Revision 1.4  2004/01/26 17:28:18  gdsjaar
C Removed several unused variables from getang subroutine.
C
C Initialized a variable
C
C Revision 1.3  1998/07/14 18:18:25  gdsjaar
C Removed unused variables, cleaned up a little.
C
C Changed BLUE labels to GREEN to help visibility on black background
C (indirectly requested by a couple users)
C
C Revision 1.2  1991/03/21 15:44:19  gdsjaar
C Changed all 3.14159... to atan2(0.0, -1.0)
C
c Revision 1.1.1.1  1990/11/30  11:04:09  gdsjaar
c FASTQ Version 2.0X
c
c Revision 1.1  90/11/30  11:04:07  gdsjaar
c Initial revision
c
C
CC* FILE: [.MAIN]BOXIT.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
      SUBROUTINE BOXIT (MP, ML, MS, MR, N, IPOINT, COOR, ILINE, LTYPE,
     &   LCON, IREGN, IMAT, NSPR, IFSIDE, ISLIST, LINKP, LINKL, LINKR,
     &   LINKM, NHOLDR, IHOLDR, NHOLDM, IHOLDM, IRGFLG, X, Y, Y1, Y2,
     &   BOXED, MERGE, NOROOM)
C***********************************************************************
C
C  SUBROUTINE BOXIT = BOXES IN A REGION SURROUNDING A POINT
C
C***********************************************************************
C
C  SUBROUTINE CALLED BY:
C     INPUT  = INPUTS MESH DEFINITIONS FROM THE LIGHT TABLE
C
C***********************************************************************
C
C  SUBROUTINES CALLED:
C     DLPARA = DETERMINES LINE PARAMETERS FROM TWO POINTS
C
C***********************************************************************
C
      PARAMETER (MHOLD = 50)
C
      DIMENSION IPOINT (MP)
      DIMENSION COOR (2, MP), ILINE (ML), LTYPE (ML), LCON (3, ML)
      DIMENSION IREGN (MR), IMAT (MR), NSPR (MR), IFSIDE (MR)
      DIMENSION ISLIST (MR * 4)
      DIMENSION LINKP (2, MP), LINKL (2, ML), LINKR (2, MR)
      DIMENSION LINKM (2, (MS + MR))
      DIMENSION IHOLDR (2, MR), IHOLDM (2, (MS + MR))
      DIMENSION IHOLD (MHOLD, 2), JHOLD (MHOLD), IRGFLG (MR), N (29)
C
      LOGICAL BOXED, NOROOM, ADDLNK, MERGE, ERR, CIRCLE
C
      PI = ATAN2(0.0, -1.0)
      TWOPI = PI + PI
      BOXED = .FALSE.
      NOROOM = .FALSE.
      ADDLNK = .FALSE.
      CIRCLE = .FALSE.
      IFIND = 0
      SUMTH = 0.
      THETMX = 0.0
C
C  FIND THE CLOSEST LINE ABOVE THE POINT INPUT
C
      CALL LABOVE  (MP, ML, N, IPOINT, COOR, ILINE, LTYPE, LCON, LINKP,
     &   LINKL, X, Y, Y1, Y2, IFIND, JFIND1, ISTART, NP)
      IF (IFIND .LE. 0) RETURN
      IFHOLD = IFIND
C
C  SET UP REGION CHECKING CONNECTIVITY
C
      DO 100 I = 1, MHOLD
         JHOLD (I) = 0
         IHOLD (I, 1) = 0
         IHOLD (I, 2) = 0
  100 CONTINUE
      IFOUND = 0
      LASTP = ISTART
C
      CALL LTSORT (ML, LINKL, IFIND, JFIND1, ADDLNK)
      JHOLD (1) = IFIND
C
      DO 130 I = 1, N (2) + 2
         JKOUNT = 0
C
C  GET ALL LINES CONTAINING THE NEW POINT "NP"
C
         DO 110 J = 1, N (19)
            CALL LTSORT (ML, LINKL, J, JJ, ADDLNK)
            IF (JJ .GT. 0) THEN
               J1 = LCON (1, JJ)
               J2 = LCON (2, JJ)
               IF ( ( (J1 .EQ. NP) .OR. (J2 .EQ. NP)) .AND.
     &            (JJ .NE. JFIND1)) THEN
                  JKOUNT = JKOUNT + 1
                  IHOLD (JKOUNT, 1) = JJ
                  IF (J1 .EQ. NP) THEN
                     IHOLD (JKOUNT, 2) = 2
                  ELSE
                     IHOLD (JKOUNT, 2) = 1
                  ENDIF
               ENDIF
            ENDIF
  110    CONTINUE
C
C  CHECK FOR A CLOSED CIRCLE WITH NO LINES ATTACHED
C
         IF  ( (JKOUNT .EQ. 0) .AND.  (NP .EQ. LASTP) ) THEN
            IFOUND = 1
            GOTO 140
C
C  CHECK FOR NO ADDITIONAL LINES ATTACHED
C
         ELSEIF  (JKOUNT .EQ. 0) THEN
            RETURN
C
C  CHECK FOR A CLOSED CIRCLE ATTACHED TO NP
C
         ELSEIF  (  (JKOUNT .EQ. 1) .AND.
     &      (LCON (1, IHOLD (1, 1)) .EQ. LCON (2, IHOLD (1, 1))) )
     &      THEN
            JFIND1 = IHOLD (1, 1)
            SUMTH = SUMTH + THETMX
            LASTP = NP
            NP = LCON (1, JFIND1)
            IFIND = ILINE (JFIND1)
            JHOLD (I + 1) = ILINE (JFIND1)
            IFOUND = IFOUND + 1
C
C  CHECK FOR CLOSING OF THE REGION
C
            IF  ( IFIND .EQ. IFHOLD ) THEN
               IF  (  (LASTP .EQ. ISTART) .AND.
     &            (IFIND .EQ. IFHOLD) .AND.
     &            (I  .NE.  1) ) THEN
                  GOTO 140
               ENDIF
            ENDIF
C
C  SET THE FLAG THAT WE ARE RETURNING FROM THIS CLOSED CIRCLE
C
            CIRCLE = .TRUE.
C
C  USING THE NP COORDINATES AS A NEW CENTER
C  CHECK TO SEE WHICH LINE HAS THE SMALLEST INTERIOR ANGLE
C   (ASSUMES WE ARE PROGRESSING IN CLOCKWISE ORDER)
C
         ELSE
            CALL ENDTAN (MP, ML, N, IPOINT, COOR, LTYPE, LCON, LINKP,
     &         LINKL, IFIND, JFIND1, NP, THETA1, ERR)
C
C  SET THE SPECIAL CASE OF A CLOSED CIRCLE WITH ATTACHED LINES
C  AND NOT A RETURN FROM A CIRCLE AS HAVING A THETMX OF PI.
C  A CLOSED CIRCLE RETURN GETS THE ENDTANGENT FLIPPED TO GET THE
C  RIGHT INTERIOR ANGLE.
C
            IF  ( NP .EQ. LASTP ) THEN
               IF  (CIRCLE) THEN
                  THETA1 = THETA1 - PI
                  IF (THETA1 .LT. 0.) THEN
                     THETA1 = THETA1 + TWOPI
                  ELSEIF (THETA1 .GT. TWOPI) THEN
                     THETA1 = THETA1 - TWOPI
                  ENDIF
                  THETMX = TWOPI * 2.
               ELSE
                  THETMX = PI
               ENDIF
            ELSE
               THETMX = TWOPI * 2.
            ENDIF
C
            DO 120 J = 1, JKOUNT
C
C  JJ = THE POINTER TO THE ATTACHED POINT OF THE LINE BEING TESTED
C
               CALL ENDTAN  (MP, ML, N, IPOINT, COOR, LTYPE, LCON,
     &            LINKP, LINKL, ILINE (IHOLD (J, 1)), IHOLD (J, 1), NP,
     &            THETA2, ERR)
C
               TESTTH = THETA2 - THETA1
               IF (TESTTH .LT. 0) THEN
                  TESTTH = TESTTH + TWOPI
               ELSEIF (TESTTH .GT. TWOPI) THEN
                  TESTTH = TESTTH - TWOPI
               ENDIF
               IF (  (.NOT.ERR) .AND.
     &            (  (TESTTH .LE. THETMX) .OR.
     &            (ABS (THETMX - TESTTH) .LT. .0001) ) ) THEN
                  THETMX = TESTTH
                  JFIND1 = IHOLD (J, 1)
                  JFIND2 = IHOLD (J, 2)
               ENDIF
  120       CONTINUE
C
C  CHECK FOR CLOSING OF THE REGION
C
            IF (IFIND .EQ. IFHOLD) THEN
C
C  FIRST THE SINGLE LINE REGION WITH LINES ATTACHED OUTSIDE THE CIRCLE
C
               IF  (  (NP .EQ. LASTP) .AND.
     &            ( IFIND .EQ. ILINE ( JFIND1 ) ) ) THEN
                  IFOUND = 1
                  GOTO 140
C
C  SECOND TEST FOR THE NORMAL CLOSING
C
               ELSEIF  (  (LASTP .EQ. ISTART) .AND.
     &            (IFIND .EQ. IFHOLD) .AND.
     &            (I .NE. 1) ) THEN
                  GOTO 140
               ENDIF
            ENDIF
C
            SUMTH = SUMTH + THETMX
            LASTP = NP
            NP = LCON (JFIND2, JFIND1)
            IFIND = ILINE (JFIND1)
            JHOLD (I + 1) = ILINE (JFIND1)
            IFOUND = IFOUND + 1
            CIRCLE = .FALSE.
         ENDIF
  130 CONTINUE
      RETURN
C
C  CHECK TO MAKE SURE THE REGION CLOSED CORRECTLY
C
C      AVETH = SUMTH / FLOAT (IFOUND)
C      IF (AVETH .GT. 180.) THEN
C         CALL VDBELL
C         CALL VDBUFL
C         RETURN
C      ENDIF
C
C  INPUT THE REGION
C
  140 CONTINUE
      JJ = N (22) + 1
      IMTRL = 0
      CALL IREVER (JHOLD, IFOUND)
      DO 150 J = 1, IFOUND
         JHOLD (J) =  - JHOLD (J)
  150 CONTINUE
      CALL INREGN (MS, MR, N (7), N (8), N (22), N (23), JJ, IMTRL,
     &   JHOLD, IFOUND, IREGN, IMAT, NSPR, IFSIDE, ISLIST, LINKR,
     &   LINKM, NHOLDR, IHOLDR, NHOLDM, IHOLDM, IRGFLG, MERGE, NOROOM)
      IF (NOROOM)RETURN
      BOXED = .TRUE.
      RETURN
      END


      SUBROUTINE FSASA(NRES,IEPS,DEBUG,IDB,INGRP,NATM,
     *VEPS,BFS,NGRP,PCOD)
C
C	calculate solvent accessible surface area of charged groups and
C	fraction relative to group in H2O
C
C	elm, Feb 10, 1997
C
C	DGS Fraction solvent accessible surface area
C	1.-DGS is fraction buried in protein
C	DG2 transfer energy for unit charge
C	ITYPE =2 for titratable group, =1 otherwise
C
      IMPLICIT REAL*8 (A-H,O-Z)
c     parameter (DST=78.4)
c     CHARACTER RES*3,line*80,EPSTYP(2)*4,PCOD*(*)!,temp*4
      CHARACTER PCOD*(*)
c     REAL*8 NTERM,MTOTSA
      integer lres
      LOGICAL DEBUG,INGRP(1),VEPS
      include 'esp.inc'
      include 'chd.inc'
      include 'screen.inc'
c     DATA EPSTYP/'D 1 ','D 2 '/
       write(*,*)'inside FSASA'
      TRF=0
      FRF=0
      DO I=1,NATM
      DG2(I)=0.
      ENDDO
C
      LRESO=0
      ITYP=0
      itypo=ityp
      IATM=0
      LGR=0
      LLGR=0
c     lres=1 !residue number
C
C	get atom SASA's and calculate microenvironment properties
C
       write (6,1101)
 1101   FORMAT(/8x,'RES NO      RES  GRP NO      FB  ',
     *  '       RFHP ',
     *  '     RFHT      RFHT/RFW')
      IST=1
      write(*,*)"in resfsa, ngrp",ngrp
      DO I=1,NGRP
        lres = ares(ist)
        ISTP=IST+NGRPS(2,I)-1
        ITYP=NGRPS(3,I)
        write(*,*)"Within resfsa ITYP, NGRPS(3,I)",
     *  ITYP, NGRPS(3,I)
        if (lres.eq.lreso) then
         llgr=llgr+1
        else
         llgr=1
         lreso = lres
        endif
        write(*,*)"NGRPS(3,I),(2,I),(1,I)",NGRPS(3,I),NGRPS(2,I)
     *  ,NGRPS(1,I)
 1100  FORMAT (2(I10,2x),3(I2,3x),2x,F8.4)
        FB=1.-DGS(IST)
        TRF=DGS(IST)*SMENV(LLGR,ITYP)+FB*RKRH(I)
        IF (SMENV(LLGR,ITYP).NE.0) THEN
          write(*,*)"LLGR,ITYP,SMENV(LLGR,ITYP),RKRH(I)",
     *    LLGR,ITYP,SMENV(LLGR,ITYP),RKRH(I)
          FRF=TRF/SMENV(LLGR,ITYP)
        ELSE
          FRF=-1.
        ENDIF
        WRITE (30,1103) PCOD,LRES,RESGRP(LNRES(LRES)),LLGR,
     *  GTYP(LLGR,LNRES(LRES)),FB,
     *  RKRH(I),TRF,FRF
 1103   FORMAT(A4,',  ',I4,',  ',A3,',  ',I6,',  ',
     *  A2,',  ',F6.3,',  ',2(F7.3,',  '),F7.3)
c     IST=ISTP+1
      ist=ist+ngrps(2,i)
      ENDDO
      CLOSE(30)
c     RETURN
 9001 WRITE (*,*) ' end of file on unit 2 in resfsa'
      RETURN
 9002 WRITE (*,*) 'NOTHING IN UNIT 3'
      STOP 2
      END