!!  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 dldifu(icreep    ,timest    ,lundia    ,nst       ,icx       ,
     &                  icy       ,j         ,nmmaxj    ,nmmax     ,kmax      ,
     &                  lstsci    ,lstsc     ,lsal      ,ltem      ,lsecfl    ,
     &                  lsec      ,lsed      ,lsts      ,norow     ,irocol    ,
     &                  kcs       ,kcu       ,kfs       ,kfu       ,kfv       ,
     &                  kadu      ,kadv      ,s0        ,s1        ,hu        ,
     &                  hv        ,dps       ,qxk       ,qyk       ,qzk       ,
     &                  guu       ,gvv       ,guv       ,gvu       ,gsqs      ,
     &                  rbnd      ,sigdif    ,sigmol    ,r0        ,r1        ,
     &                  sour      ,sink      ,ws        ,sedtyp    ,thick     ,
     &                  sig       ,dicuv     ,dicww     ,dsdksi    ,dsdeta    ,
     &                  dtdksi    ,dtdeta    ,aak       ,bbk       ,cck       ,
     &                  bdddx     ,bddx      ,bdx       ,bux       ,buux      ,
     &                  buuux     ,uvdwk     ,vvdwk     ,areau     ,areav     ,
     &                  aakl      ,bbkl      ,cckl      ,ddkl      ,kmxsed    ,
     &                  eqmbcsand ,eqmbcmud  ,seddif    ,volum0    ,volum1    ,
     &                  rscale    ,bruvai    ,
!                 this comes out of the gdp tree in the FLOW code
     &                                        eps       ,vicmol    ,
!                 this is WAQ specific
     &                                                              difx      ,
     &                  dify      , intsrt   , dfluxx   , dfluxy              )

!     Deltares - Delft Software Centre

!     Created   : Early '90s by Team around Guus Stelling / Jan van Kester

!     Function  : Performs ADI integration in an advanced way (3rd order)

!     Subroutines called: difacr performs horizontal diffusion with anti-creep

!     Modified  : July     2008, Leo Postma  : WAQ performance timers
!                 Januari  2010, Leo Postma  : Update to recent version

!     The problem with holding this routine up-to-date is in the fact that
!         it has its own dynamics in the Delft3D-FLOW environment with a
!         complete team working at the software
!         furthermore the following aspect prevent a one to one correspondence
!         1) the rigorous wish to use a free formatted source code for FLOW
!            that is substantially incompatible with fixed form sources
!            where DELWAQ tries to maintain similarity where possible
!         2) the wish to have all DELWAQ variables documented in the subroutine
!            header whereas FLOW refers to other specific files for this
!         3) the incorporation of the global data pointer gdp that is not
!            available in DELWAQ (this affects all array declarations)
!         4) the use of the 'precision' file that is not available in DELWAQ
!         5) the domain decomposition feature and the associated include file
!            flow_steps_f.inc that are not available in DELWAQ
!         6) the whish to include numereous subtimers where DELWAQ only times
!            the total

      use timers
      implicit none

!     Arguments           :

!     Kind        Function         Name                             Description

      integer  (4), intent(in   ) :: icreep                       ! If not 0 then anticreep
      real     (4), intent(in   ) :: timest                       ! Half Integration time step [sec.]
      integer  (4), intent(in   ) :: lundia                       ! Unit number of diagnostic file
      integer  (4), intent(in   ) :: nst                          ! Time step number for error message only
      integer  (4), intent(in   ) :: icx                          ! Array increment = nmax in x-direction
      integer  (4), intent(in   ) :: icy                          !                 = 1    in y-direction
      integer  (4), intent(in   ) :: j                            ! Begin pointer for arrays  (=-2*nmax+1)
      integer  (4), intent(in   ) :: nmmaxj                       ! End pointer for arrays    (=nmmax+2*nmax)
      integer  (4), intent(in   ) :: nmmax                        ! Total number of grid pts. (=nmax*mmax)
      integer  (4), intent(in   ) :: kmax                         ! Number of layers in the z-dir.
      integer  (4), intent(in   ) :: lstsci                       ! Total number of constituents
      integer  (4), intent(in   ) :: lstsc                        ! = lstsci without secondary flow
      integer  (4), intent(in   ) :: lsal                         ! Substance nr salinity, 0 or 1
      integer  (4), intent(in   ) :: ltem                         ! Substance nr temperature, 0 or lsal + 1
      integer  (4), intent(in   ) :: lsecfl                       ! Substance nr first secondary flow subst.
      integer  (4), intent(in   ) :: lsec                         ! 1: no equilib; 2 eqiulib. sec flow
      integer  (4), intent(in   ) :: lsed                         ! Number of sediment constituents
      integer  (4), intent(in   ) :: lsts                         ! Total number constituents
      integer  (4), intent(in   ) :: norow                        ! Number of comp. rows  in IROCOL-array
      integer  (4), intent(in   ) :: irocol(5, norow)             ! For boundary cells and boundary types
      integer  (4), intent(in   ) :: kcs   (j:nmmaxj)             ! Constant mask array zeta points (2=bnd)
      integer  (4), intent(in   ) :: kcu   (j:nmmaxj)             ! Constant mask array U-velocity points
      integer  (4), intent(in   ) :: kfs   (j:nmmaxj)             ! Variable mask array zeta points
      integer  (4), intent(in   ) :: kfu   (j:nmmaxj)             ! Variable mask array U-velocity points
      integer  (4), intent(in   ) :: kfv   (j:nmmaxj)             ! Variable mask array V-velocity points
      integer  (4), intent(in   ) :: kadu  (j:nmmaxj,  kmax)      ! Structures in U-velocity points 1 is NOT
      integer  (4), intent(in   ) :: kadv  (j:nmmaxj,  kmax)      ! Structures in V-velocity points 1 is NOT
      real     (4), intent(in   ) :: s0    (j:nmmaxj)             ! Zeta at old time level
      real     (4), intent(in   ) :: s1    (j:nmmaxj)             ! Zeta at new time level
      real     (4), intent(in   ) :: hu    (j:nmmaxj)             ! Total water depth in u-point [m]
      real     (4), intent(in   ) :: hv    (j:nmmaxj)             ! Total water depth in v-point [m]
      real     (4), intent(in   ) :: dps   (j:nmmaxj)             ! Water depth below ref. in zeta-point [m]
      real     (4), intent(in   ) :: qxk   (j:nmmaxj,  kmax)      ! Flow in the X-dir. through U-surface
      real     (4), intent(in   ) :: qyk   (j:nmmaxj,  kmax)      ! Flow in the Y-dir. through V-surface
      real     (4), intent(in   ) :: qzk   (j:nmmaxj,0:kmax)      ! Flow in the Z-dir. through zeta-surface
      real     (4), intent(in   ) :: guu   (j:nmmaxj)             ! Grid distance in y-direction over U-point
      real     (4), intent(in   ) :: gvv   (j:nmmaxj)             ! Grid distance in x-direction over V-point
      real     (4), intent(in   ) :: guv   (j:nmmaxj)             ! Grid distance in y-direction over V-point
      real     (4), intent(in   ) :: gvu   (j:nmmaxj)             ! Grid distance in x-direction over U-point
      real     (4), intent(in   ) :: gsqs  (j:nmmaxj)             ! Horizontal surface area of the grid cell
      real     (4), intent(in   ) :: rbnd  (kmax,lstsc,2,norow)   ! Boundary conditions
      real     (4), intent(in   ) :: sigdif( lstsci )             ! Prandtl/schmidt-numbers for const.
      real     (4), intent(in   ) :: sigmol( lstsci )             ! Moleculair Prandtl-numbers for const.
      real     (4), intent(inout) :: r0    (j:nmmaxj,kmax,lstsci) ! Concentrations at old time level
      real     (4), intent(  out) :: r1    (j:nmmaxj,kmax,lstsci) ! Concentrations at new time level
      real     (4), intent(in   ) :: sour  (j:nmmaxj,kmax,lstsci) ! Source terms
      real     (4), intent(in   ) :: sink  (j:nmmaxj,kmax,lstsci) ! Sink terms
      real     (4), intent(in   ) :: ws    (j:nmmaxj,0:kmax,lsed) ! Settling velocities sediments
      character(4), intent(in   ) :: sedtyp( lsed   )             ! Sediment type: Sand/Floc/User def.
      real     (4), intent(in   ) :: thick ( kmax   )             ! Relative layer thickness
      real     (4), intent(in   ) :: sig   ( kmax   )             ! Sigma coordinate gravity point
      real     (4), intent(in   ) :: dicuv (j:nmmaxj,  kmax)      ! Horizontal Diffusion coeff. [m2/s]
      real     (4), intent(in   ) :: dicww (j:nmmaxj,0:kmax)      ! Vertical   Diffusion coeff. [m2/s]
      real     (4), intent(in   ) :: dsdksi(j:nmmaxj,  kmax)      ! Horizontal gradient salinity (ksi-dir)
      real     (4), intent(in   ) :: dsdeta(j:nmmaxj,  kmax)      ! Horizontal gradient salinity (eta-dir)
      real     (4), intent(in   ) :: dtdksi(j:nmmaxj,  kmax)      ! Horizontal gradient temperature (ksi-dir)
      real     (4), intent(in   ) :: dtdeta(j:nmmaxj,  kmax)      ! Horizontal gradient temperature (eta-dir)
      real     (4), intent(inout) :: aak   (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: bbk   (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: cck   (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: bdddx (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: bddx  (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: bdx   (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: bux   (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: buux  (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: buuux (j:nmmaxj,  kmax)      ! Internal work array
      real     (4), intent(inout) :: uvdwk (j:nmmaxj,  kmax)      ! Internal work array Jacobi iteration
      real     (4), intent(inout) :: vvdwk (j:nmmaxj,  kmax)      ! Internal work array Jacobi iteration
      real     (4), intent(in   ) :: areau (j:nmmaxj,  kmax)      ! Vertical exchange areas through u-point
      real     (4), intent(in   ) :: areav (j:nmmaxj,  kmax)      ! Vertical exchange areas through v-point
      real     (4), intent(inout) :: aakl  (j:nmmaxj,  kmax,lstsci) ! Internal first lower diagonal
      real     (4), intent(inout) :: bbkl  (j:nmmaxj,  kmax,lstsci) ! Internal diagonal
      real     (4), intent(inout) :: cckl  (j:nmmaxj,  kmax,lstsci) ! Internal first upper diagonal
      real     (4), intent(inout) :: ddkl  (j:nmmaxj,  kmax,lstsci) ! Internal ???
      real     (4), intent(inout) :: kmxsed(j:nmmaxj,  lsed)      ! ???
      logical     , intent(in   ) :: eqmbcsand                    !
      logical     , intent(in   ) :: eqmbcmud                     !
      real     (4), intent(in   ) :: seddif(j:nmmaxj,0:kmax,lsed  ) ! Vertical sediment diffusion coeff.
      real     (4), intent(in   ) :: volum0(j:nmmaxj,  kmax)      ! Volumes at the old time level
      real     (4), intent(in   ) :: volum1(j:nmmaxj,  kmax)      ! Volumes at the new time level
      real     (4), intent(inout) :: rscale(j:nmmaxj,  kmax)      ! Internal work array, row scaling parameter in difu
      real     (4), intent(inout) :: bruvai(j:nmmaxj,0:kmax)      ! Probably an internal wave effect
      real     (4), intent(in   ) :: eps                          ! Error criterium
      real     (4), intent(in   ) :: vicmol                       ! Moleculair viscosity of water
      real     (4), intent(in   ) :: difx  (j:nmmaxj,  kmax)      ! diffusion in x direction
      real     (4), intent(in   ) :: dify  (j:nmmaxj,  kmax)      ! diffusion in y direction
      integer  (4), intent(in   ) :: intsrt                       ! upwind (1) or central (0) differences *WAQ*

      real     (4), intent(  out) :: dfluxx(j:nmmaxj,kmax,lstsci) ! Diffusive flux for anticreep, x direction
      real     (4), intent(  out) :: dfluxy(j:nmmaxj,kmax,lstsci) ! Diffusive flux for anticreep, y direction

!     Local declaration

      integer  (4)  icxy        !  is the maximu of icx and icy
      real     (4)  timesti     !  is 1.0 / timest
      integer  (4)  k           !  loop counter for layers
      integer  (4)  nm          !  loop counter for horizontal gridcells
      integer  (4)  l           !  loop counter for substances
      integer  (4)  nmd         !  accumulation counter within loops
      integer  (4)  nmdd        !  accumulation counter within loops
      integer  (4)  nmu         !  accumulation counter within loops
      integer  (4)  nmuu        !  accumulation counter within loops
      real     (4)  qxu         !  help variable = qxk / 6.0
      real     (4)  qyv         !  help variable = qyk
      real     (4)  qzw         !  help variable = qzk
      integer  (4)  iad1        !  help integer first  term upwind weight
      integer  (4)  iad2        !  help integer second term upwind weight
      integer  (4)  iad3        !  help integer third  term upwind weight
      integer  (4)  j1          !  help integer first  term upwind weight
      integer  (4)  j2          !  help integer second term upwind weight
      integer  (4)  j3          !  help integer third  term upwind weight
      integer  (4)  ndm         !  accumulation counter within loops
      integer  (4)  num         !  accumulation counter within loops
      real     (4)  d0k         !  help variable offdiagonal terms y-direction
      real     (4)  cl          !  help variable concentration of from cell
      real     (4)  cr          !  help variable concentration of to   cell
      real     (4)  flux        !  help variable transport flux
      integer  (4)  maskval     !  help variable 0 if no flux wanted
      integer  (4)  kfw         !  help variable central or backward differences
      real     (4)  adza        !  help variable vertical transport flux from
      real     (4)  adzc        !  help variable vertical transport flux to
      real     (4)  tsg         !  help variable sum of two vertical half distances
      real     (4)  h0          !  help variable waterdepth at old time level
      real     (4)  h1          !  help variable waterdepth at new time level
      real     (4)  h0i         !  help variable 1.0 /h0
      real     (4)  h0new       !  help variable waterdepth at old time level
      real     (4)  h0old       !  help variable waterdepth at new time level
      real     (4)  diz1        !  help variable vertical diffusion
      real     (4)  ddzc        !  help variable vertical diffusion flux
      real     (4)  bi          !  help variable for the double sweep solver
      integer  (4)  ddb         !  domain decomposition effect, set to zero
      integer  (4)  ls          !  help variable for sediment substance nr
      integer  (4)  lst         !  help variable for last non-sediment substance nr
      integer  (4)  ll          !  help variable for accumulation of sediment substance nr
      integer  (4)  n           !  help variable for boundary condition determination
      integer  (4)  mf          !  help variable for boundary condition determination
      integer  (4)  ml          !  help variable for boundary condition determination
      integer  (4)  nmf         !  help variable for boundary condition determination
      integer  (4)  nml         !  help variable for boundary condition determination
      integer  (4)  nmfu        !  help variable for boundary condition determination
      integer  (4)  nmlu        !  help variable for boundary condition determination
      integer  (4)  ic          !  loop counter in the irocol table
      integer  (4)  iter        !  outer iteration counter
      integer  (4)  itr         !  inner iteration counter
      real     (4)  epsitr      !  iteration stop criterion, concentration dependent

      integer(4) ithandl /0/
      if ( timon ) call timstrt ( "dldifu", ithandl )

      icxy  = max (icx,icy)
    !
    !  INITIALIZE
    !
!   call timer_start(timer_difu_ini, gdp)
    !
    ! Initialise arrays aak - cck for all (nm,k)
    !
      aak   = 0.0
      buuux = 0.0
      buux  = 0.0
      bux   = 0.0
      bdx   = 0.0
      bddx  = 0.0
      bdddx = 0.0
      cck   = 0.0
    !
      timesti = 1.0 / timest
      do k = 1, kmax
         do nm = 1, nmmax
            if (kfs(nm) == 1 ) then
               bbk(nm, k) = volum1(nm, k) * timesti
            else
               bbk(nm, k) = 1.0
               if (lsec > 0) r0(nm, k, lsecfl) = 0.0
            endif
         enddo
      enddo
      do l = 1, lstsci
         if (lsec==2 .and. l==lsecfl) then
            cycle
         endif
         do k = 1, kmax
            do nm = 1, nmmax
               if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
!1st difference: WAQ gives the right hand side (WQ processes) to difu through ddkl !!!!
                  ddkl(nm, k, l) = ddkl(nm, k, l) + volum0(nm, k) * r0(nm, k, l) * timesti
               else
                  ddkl(nm, k, l) = r0(nm, k, l)
               endif
            enddo
         enddo
      enddo
!   call timer_stop(timer_difu_ini, gdp)
    !
    ! CONTRIBUTION OF ADVECTION IN X-DIRECTION
    !
!   call timer_start(timer_difu_horadv, gdp)
      do k = 1, kmax
       !
       ! CONTRIBUTION TO VOLUME NM AND NMU
       !
         nmd  = -icx
         nmdd = -icx - icx
         nmu  =  icx
         nmuu =  icx + icx
         do nm = 1, nmmax
            nmd  = nmd  + 1
            nmdd = nmdd + 1
            nmu  = nmu  + 1
            nmuu = nmuu + 1
            qxu  = qxk(nm, k)/6.0
            if (qxu > 0.0) then
               iad1 =      kfu(nm)  *kadu(nm, k)
               iad2 = iad1*kfu(nmd) *kadu(nmd, k)
               iad3 = iad2*kfu(nmdd)*kadu(nmdd, k)
             !
               j1 = 6*iad1 + 3*iad2 +   iad3
               j2 =        - 3*iad2 - 2*iad3
               j3 =                     iad3
             !
               bbk  (nm , k) = bbk  (nm , k) + qxu*j1
               bdx  (nm , k) = bdx  (nm , k) + qxu*j2
               bddx (nm , k) = bddx (nm , k) + qxu*j3
               bdx  (nmu, k) = bdx  (nmu, k) - qxu*j1
               bddx (nmu, k) = bddx (nmu, k) - qxu*j2
               bdddx(nmu, k) = bdddx(nmu, k) - qxu*j3
            else
               iad1 =        kfu(nm)   * kadu(nm  , k)
               iad2 = iad1 * kfu(nmu)  * kadu(nmu , k)
               iad3 = iad2 * kfu(nmuu) * kadu(nmuu, k)
             !
               j1 = 6*iad1 + 3*iad2 +   iad3
               j2 =        - 3*iad2 - 2*iad3
               j3 =                     iad3
             !
               bux  (nm , k) = bux  (nm , k) + qxu*j1
               buux (nm , k) = buux (nm , k) + qxu*j2
               buuux(nm , k) = buuux(nm , k) + qxu*j3
               bbk  (nmu, k) = bbk  (nmu, k) - qxu*j1
               bux  (nmu, k) = bux  (nmu, k) - qxu*j2
               buux (nmu, k) = buux (nmu, k) - qxu*j3
            endif
         enddo
      enddo
    !
    ! CONTRIBUTION OF ADVECTION IN Y-DIRECTION
    !
      do l = 1, lstsci
         if (lsec==2 .and. l==lsecfl) then
            cycle
         endif
         do k = 1, kmax
          !
          ! CONTRIBUTION TO VOLUME NM AND NUM
          !
            ndm = -icy
            num =  icy
            do nm = 1, nmmax
               ndm = ndm + 1
               num = num + 1
               qyv  = qyk(nm, k)
               iad1 = kfv(nm)*kadv(nm, k)
               iad2 = iad1*kfv(num)*kadv(num, k)*kfv(ndm)*kadv(ndm, k)
               if (qyv > 0.0) then
                  d0k = 0.5*qyv*( (2*iad1 - iad2)*r0(nm , k, l)
     &                           +          iad2 *r0(num, k, l))
               else
                  d0k = 0.5*qyv*( (2*iad1 - iad2)*r0(num, k, l)
     &                           +          iad2 *r0(nm , k, l))
               endif
               if (kcs(nm)  == 1) ddkl(nm , k, l) = ddkl(nm , k, l) - d0k
               if (kcs(num) == 1) ddkl(num, k, l) = ddkl(num, k, l) + d0k
            enddo
         enddo
      enddo
!   call timer_stop(timer_difu_horadv, gdp)
    !
    !
    ! Explicit algoritm (call DIFACR) leads to extra stablity criterium
    ! DT <= (DX**2)/(2*DICUV)
    !
    ! This diffusion part (loop 410) is constituent independent.
    ! The value of SIGDIF(L) = 0.7 (see TKECOF) for all LSTSCI
    !
!   call timer_start(timer_difu_hordiff, gdp)
      if (icreep==0 .or. kmax==1) then
       !
       ! HORIZONTAL DIFFUSION IN X-DIRECTION ALONG SIGMA PLANES
       !
         do k = 1, kmax
            !
            ! CONTRIBUTION TO VOLUME NM AND NMU
            !
            nmu = icx
            do nm = 1, nmmax
               nmu = nmu + 1
               if (kfu(nm)*kadu(nm, k) /= 0) then
!2nd difference, WAQ gives diffusion per exchange area directly
!                 difl    = dicuv(nm, k)                      ! WAQ gives values per area
!                 difr    = dicuv(nmu, k)
!                 flux    = 0.5*(difl + difr)/(0.7*gvu(nm))
                  flux    = difx(nm,k)/(0.7*gvu(nm))        ! check on 0.7 is still pending
                  maskval = max(0, 2 - kcs(nm))
                  bbk(nm, k) = bbk(nm, k) + areau(nm, k)*flux*maskval
                  bux(nm, k) = bux(nm, k) - areau(nm, k)*flux*maskval
                  maskval = max(0, 2 - kcs(nmu))
                  bbk(nmu, k) = bbk(nmu, k) + areau(nm, k)*flux*maskval
                  bdx(nmu, k) = bdx(nmu, k) - areau(nm, k)*flux*maskval
               endif
            enddo
         enddo
       !
       ! HORIZONTAL DIFFUSION IN Y-DIRECTION ALONG SIGMA PLANES
       !
         do l = 1, lstsci
            if (lsec==2 .and. l==lsecfl) then
               cycle
            endif
            do k = 1, kmax
               !
               ! CONTRIBUTION TO VOLUME NM AND NUM
               !
               num = icy
               do nm = 1, nmmax
                  num = num + 1
                  if (kfv(nm)*kadv(nm, k) /= 0) then
                     cl      = r0(nm, k, l)
!3rd difference, WAQ gives values per area directly
!                    difl    = dicuv(nm, k)                              ! WAQ gives values per area
                     cr      = r0(num, k, l)
!                    difr    = dicuv(num, k)
!                    flux    = 0.5*(cr - cl)*(difl + difr)/(0.7*guv(nm))
                     flux    = (cr-cl)* dify(nm,k)/(0.7*guv(nm))   ! check on 0.7 is still pending
                     maskval = max(0, 2 - kcs(nm))
                     ddkl(nm, k, l) = ddkl(nm, k, l) + areav(nm, k)*flux*maskval
                     maskval = max(0, 2 - kcs(num))
                     ddkl(num, k, l) = ddkl(num, k, l) - areav(nm, k)*flux*maskval
                  endif
               enddo
            enddo
         enddo
      else
       !
       ! Explicit algoritm (call DIFACR) leads to extra stablity criterium
       ! dt <= (dx**2)/(2*dicuv)
       !
       ! HORIZONTAL DIFFUSION ALONG Z-PLANES (only if KMAX > 1 and Anti Creep)
       !
         call difacr(icx       ,icy       ,j         ,nmmaxj    ,nmmax     ,
     &               kmax      ,lstsci    ,lsal      ,ltem      ,kcs       ,
     &               kfu       ,kfv       ,kadu      ,kadv      ,s0        ,
     &               dps       ,r0        ,ddkl      ,guu       ,gvv       ,
     &               guv       ,gvu       ,thick     ,sig       ,dicuv     ,
     &               sigdif    ,dsdksi    ,dtdksi    ,dsdeta    ,dtdeta    ,
!4th difference, WAQ has no gdp and dfluxx and dfluxy have been added for mass balances
     &               dfluxx    ,dfluxy                                     )
!                  & gdp       )                             WAQ has no gdp
      endif
!   call timer_stop(timer_difu_hordiff, gdp)
!   call timer_start(timer_difu_vertadv, gdp)
      if (kmax > 1) then
         do k = 1, kmax - 1
            if (k==1 .or. k==kmax - 1) then
               kfw = 1
            else
               kfw = 0
            endif
            kfw = max ( kfw , intsrt )    !  WAQ to distinguish backward 1 or central 0 differences
            do nm = 1, nmmax
               !
               ! ADVECTION IN VERTICAL DIRECTION; W*DC/DZ
               !
               if (kfs(nm) == 1) then
                  qzw = qzk(nm, k)
                  if (qzw > 0.0) then
                     adza = 0.5*qzw*(1 - kfw)
                     adzc = 0.5*qzw*(1 + kfw)
                  else
                     adza = 0.5*qzw*(1 + kfw)
                     adzc = 0.5*qzw*(1 - kfw)
                  endif
                  aak(nm, k + 1) = aak(nm, k + 1) + adza
                  bbk(nm, k + 1) = bbk(nm, k + 1) + adzc
                  bbk(nm, k    ) = bbk(nm, k    ) - adza
                  cck(nm, k    ) = cck(nm, k    ) - adzc
               endif
            enddo
         enddo
      endif
      do l = 1, lstsci
         if (lsec==2 .and. l==lsecfl) then
            cycle
         endif
         do k = 1, kmax
            do nm = 1, nmmax
               if (kfs(nm)==1) then
!5th difference WAQ initializes these arrays outside with vertical fluxes per substance
                  aakl(nm, k, l) = aak(nm, k) + aakl(nm, k, l)   ! WAQ initialises these arrays
                  bbkl(nm, k, l) = bbk(nm, k) + bbkl(nm, k, l)   ! with vertical fluxes per substance
                  cckl(nm, k, l) = cck(nm, k) + cckl(nm, k, l)   ! like settling velocities
               endif
!6th difference, WAQ still has processes in temporally dry points
               if ( kfs(nm) .eq. 0 .and. kcs(nm) .eq. 1 ) then
                  bbkl(nm,k,l)=bbkl(nm,k,l) + bbk(nm,k)          ! WAQ still has processes in temp
               endif                                             ! dry points
            enddo
         enddo
      enddo
!   call timer_stop(timer_difu_vertadv, gdp)
    !
    ! DIFFUSION IN VERTICAL DIRECTION
    !
!   call timer_start(timer_difu_vertdiff, gdp)
      if (kmax > 1) then
         do l = 1, lstsci
          !
          ! l = sediment: ls > 0
          ! else        : ls = 0
          !
            ls = 0
            if ((l>max(lsal, ltem)) .and. (l<=lsts)) ls = l - max(lsal, ltem)
            do k = 1, kmax - 1
               tsg = 0.5 * (thick(k) + thick(k+1))
               do nm = 1, nmmax
                  if (kfs(nm) == 1) then
                     h0  = max(0.1, s0(nm) + dps(nm) )   ! NB. for WAQ at call s0(nm) is 0 and h0 = dps
                     h0i = 1.0 / h0                      !     because WAQ does not know dps
                   !
                   ! Internal wave contribution
                   !
!                  sqrtbv = max(0.0_fp, bruvai(nm, k))      ! WAQ has no sediments in difu
!                  sqrtbv = sqrt(sqrtbv)
!                  difiwe = 0.2 * sqrtbv * xlo**2
!                  if (ls > 0) then
                      !
                      ! sediment constituent:
                      ! No dicoww-restriction in reddic
                      !
!                     diz1 = vicmol/sigmol(l) + difiwe + seddif(nm, k, ls)/sigdif(l)
!                  else
                      !
                      ! all other constituents:
                      ! dicoww-restriction is moved from TURCLO to here (in reddic)
                      ! vicww is used instead of dicww
                      !
                        diz1 = vicmol/sigmol(l) + dicww(nm, k)/sigdif(l)
!                     diz1 = vicmol/sigmol(l) + reddic(difiwe + vicww(nm,k)/sigdif(l), gdp)
!                  endif
                     ddzc             = gsqs(nm) * diz1 * h0i / tsg
                     aakl(nm, k+1, l) = aakl(nm, k+1, l) - ddzc
                     bbkl(nm, k+1, l) = bbkl(nm, k+1, l) + ddzc
                     bbkl(nm, k  , l) = bbkl(nm, k  , l) + ddzc
                     cckl(nm, k  , l) = cckl(nm, k  , l) - ddzc
                  endif
               enddo
            enddo
         enddo
      endif
!   call timer_stop(timer_difu_vertdiff, gdp)
    !
    ! Include settling velocities and Dirichlet BC for sediments in
    ! matrices AAKL/BBKL/CCKL/DDKL
    !
!   if (lsed > 0) then                   not applicable for WAQ
!      call timer_start(timer_difu_difws, gdp)
!      call dif_ws(j         ,nmmaxj    ,nmmax     ,kmax      ,lsal      , &
!                & ltem      ,lstsci    ,lsed      ,kcs       ,kfs       , &
!                & gsqs      ,ws        ,aakl      ,bbkl      ,cckl      , &
!                & kmxsed    ,gdp       )
!      call timer_stop(timer_difu_difws, gdp)
!   endif
    !
    ! SET VALUES IN OPEN BOUNDARY POINTS (IN PART. FOR Y-DIRECTION)
    !     On open boundary no seconday flow (=> loop over LSTSC)
    !
!   call timer_start(timer_difu_bounopen, gdp)
      do nm = 1, nmmax
         if (kcs(nm) == 2) then
            do l = 1, lstsc
               do k = 1, kmax
                  ddkl(nm, k, l) = r0(nm, k, l)
                  aakl(nm, k, l) = 0.0
                  bbkl(nm, k, l) = 1.0
                  cckl(nm, k, l) = 0.0
               enddo
            enddo
         endif
      enddo
    !
    ! BOUNDARY CONDITIONS
    !     On open boundary no seconday flow (=> loop over LSTSC)
    !
!7th difference: WAQ has no DD features included
      ddb = 0
      do ic = 1, norow
         n    = irocol(1, ic)
         mf   = irocol(2, ic) - 1
         ml   = irocol(3, ic)
         nmf  = (n + ddb)*icy + (mf + ddb)*icx - icxy
         nml  = (n + ddb)*icy + (ml + ddb)*icx - icxy
         nmfu = nmf + icx
         nmlu = nml + icx
         !
         ! IMPLEMENTATION OF BOUNDARY CONDITIONS
         !
         if (kcu(nmf) == 1) then
            do k = 1, kmax
               do l = 1, lstsc
                  ddkl(nmf, k, l) = rbnd(k, l, 1, ic)
               enddo
            enddo
         endif
         if (kcu(nml) == 1) then
            do k = 1, kmax
               do l = 1, lstsc
                  ddkl(nmlu, k, l) = rbnd(k, l, 2, ic)
               enddo
            enddo
         endif
       !
       ! optional Neumann boundary condition for suspended sediment fractions
       !
!      lst = max(lsal, ltem)                      NO specific sed in WAQ
!      do l = 1, lsed
!         ll = lst + l
!         if ((eqmbcsand .and. sedtyp(l) == 'sand') .or. &
!           & (eqmbcmud  .and. sedtyp(l) == 'mud' )       ) then
!            if (kcu(nmf) == 1) then
!               do k = 1, kmax
!                  ddkl(nmf, k, ll) = r0(nmfu, k, ll)
!               enddo
!            endif
!            if (kcu(nml) == 1) then
!               do k = 1, kmax
!                  ddkl(nmlu, k, ll) = r0(nml, k, ll)
!               enddo
!            endif
!         endif
!      enddo
      enddo
!   call timer_stop(timer_difu_bounopen, gdp)
      do l = 1, lstsci
       !
       ! SOURCES AND SINK TERMS
       !
       ! SINKS ARE TREATED IMPLICITLY
       !
!      call timer_start(timer_difu_sourcesink, gdp)
       if (lsec==2 .and. l==lsecfl) then
          !
          ! secondary flow (equilibrium equals to new intensity)
          !       start-up problems SINK might be 0.0 when
          !       UMOD = 0.0 in SECRHS
          !
            do k = 1, kmax
               do nm = 1, nmmax
                  if (kfs(nm)*kcs(nm) == 1) then
                     h0new = s1(nm) +      dps(nm)
                     if (abs(sink(nm,k,l)*h0new) > eps) then
                        h0old = s0(nm) +      dps(nm)
                        r1(nm, k, l) = sour(nm, k, l)*h0old/(sink(nm, k, l)*h0new)
                     else
                        r1(nm, k, l) = 0.0
                     endif
                  endif
               enddo
            enddo
         else
            do k = 1, kmax
               do nm = 1, nmmax
                  if (kfs(nm)*kcs(nm) == 1) then
                     bbkl(nm, k, l) = bbkl(nm, k, l) + sink(nm, k, l)*volum1(nm, k)
                     ddkl(nm, k, l) = ddkl(nm, k, l) + sour(nm, k, l)*volum0(nm, k)
                  endif
               enddo
            enddo
          !
          ! set concentrations in dry points and in open boundary points
          !
            do k = 1, kmax
               do nm = 1, nmmax
                  if ((kfs(nm)==0 .and. kcs(nm)==1) .or. kcs(nm)==2) then
                     r1(nm, k, l) = ddkl(nm, k, l)
                  endif
               enddo
            enddo
         endif
!      call timer_stop(timer_difu_sourcesink, gdp)
       !
!      if (l == lsecfl) then             Not applicable for WAQ
          !
          ! boundary conditions secondary flow (spiral motion intensity)
          !
!         call timer_start(timer_difu_secbou, gdp)
!         call secbou(j         ,nmmaxj    ,kmax      ,icx       ,icy       , &
!                   & lstsci    ,lsecfl    ,kfu       ,irocol    ,norow     , &
!                   & s0        ,s1        ,dps       ,r1        ,sour      , &
!                   & sink      ,gdp       )
!         call timer_stop(timer_difu_secbou, gdp)
!         if (lsec == 2) then
             !
             ! exchange r1 with neighbours for parallel runs
             !
!            call dfexchg ( r1(:,:,l), 1, kmax, dfloat, gdp )
             !
!            cycle
!         endif
!      endif
       !
       ! DD code added:
       !
       ! left hand-side is now set by Delft3D-FLOW instead of the mapper
       !
!      call timer_start(timer_difu_lhs, gdp)
!      do nm = 1, nmmax
!         if (kcs(nm) == 3 ) then
!            do k = 1, kmax
!               aakl(nm,k,l) = 0.0
!               bbkl(nm,k,l) = 1.0
!               cckl(nm,k,l) = 0.0
!               ddkl(nm,k,l) = r0(nm,k,l)
!            enddo
!         endif
!      enddo
!      call timer_stop(timer_difu_lhs, gdp)
       !
       !
       !        D3dFlow_Build_ADI_Conc: poke the coupling equations into system
       !
!      nhystp = nxtstp(d3dflow_build_adi_conc, gdp)
       !
       ! DD code added end
       !
       !***SCALE ROWS OF MATRIX/RIGHT HAND SIDE VECTOR
       !
       !   Store scale factor in array rscale
       !   They are used for the constituent independent flux arrays b[d/u][d/u][d/u]x
       !
!      call timer_start(timer_difu_rowsc, gdp)
         do k = 1, kmax
            do nm = 1, nmmax
               if (kfs(nm)==1) then
                  rscale(nm, k)    = 1.0    / bbkl(nm, k, l)
                  aakl  (nm, k, l) = aakl(nm, k, l) * rscale(nm, k)
                  bbkl  (nm, k, l) = 1.0
                  cckl  (nm, k, l) = cckl(nm, k, l) * rscale(nm, k)
                  ddkl  (nm, k, l) = ddkl(nm, k, l) * rscale(nm, k)
               endif
            enddo
         enddo
!      call timer_stop(timer_difu_rowsc, gdp)
       !
       !***SOLUTION PROCEDURE SYSTEM OF EQUATIONS
       !
       ! Division by the pivot for k=1 is not needed anymore
       ! because of row scaling
       !
!      call timer_start(timer_difu_solve1, gdp)
         do nm = 1, nmmax
            if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
               do k = 2, kmax
                  bi             = 1.0/(bbkl(nm, k, l) - aakl(nm, k, l)*cckl(nm, k - 1, l))
                  bbkl(nm, k, l) = bi
                  cckl(nm, k, l) = cckl(nm, k, l)*bi
               enddo
            endif
         enddo
!      call timer_stop(timer_difu_solve1, gdp)
       !
       ! ITERATION LOOP
       !
!      call timer_start(timer_difu_solve2, gdp)
         iter = 0
         do k = 1, kmax
            do nm = 1, nmmax
               if (kfs(nm)*kcs(nm) == 1) then
                  r1(nm, k, l) = r0(nm, k, l)
                  uvdwk(nm, k) = r0(nm, k, l)
               endif
            enddo
         enddo
!      call timer_stop(timer_difu_solve2, gdp)
       !
       ! exchange r1 with neighbours for parallel runs
       !
!      call dfexchg ( r1(:,:,l), 1, kmax, dfloat, gdp )
       !
       ! assure that loop starts at point of correct color in own subdomain
       !
!      if (mod(mfg+nfg,2) == 1) then
          ! red points
!         nmsta = 1
!      else
          ! black points
!         nmsta = 2
!      endif
       !
       ! DD code added:
       !
       !
       !       (re)solve system of equations
       !
! 111  continue
!      gdp%dd%difuiter = gdp%dd%difuiter + 1
       !
       ! DD code added end
       !
 1100    continue
         iter = iter + 1
       !
       ! ITERATIVE SOLUTION METHOD USING CHECKERBOARD JACOBI
       ! IN HORIZONTAL DIRECTION
       !
         itr = 0
       !
       !   set concentrations in coupling points
       !
!      call timer_start(timer_difu_solve3, gdp)
         do k = 1, kmax
            do nm = 1, nmmax
               if (kcs(nm) == 3) then
                  r1(nm, k, l) = ddkl(nm, k, l)
               endif
            enddo
         enddo
!      call timer_stop(timer_difu_solve3, gdp)
!      if(icx == 1) then
!        call timer_start(timer_difu_solve4u, gdp)
!      else
!        call timer_start(timer_difu_solve6v, gdp)
!      end if
       !
       ! loop starts at red or black point depending on own subdomain
       !
!      nmsta = 3 - nmsta
       !
         do k = 1, kmax
            do nm = 1, nmmax, 2
             !
             ! COMPUTE RIGHT HAND SIDE
             ! ( CHECK FOR KCS TO AVOID AN ARRAY INDEX OUT OF BOUNDS )
             !
               if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                  uvdwk(nm, k) =   bdddx(nm, k) * r1(nm - icx - icx - icx, k, l)
     &                           + bddx (nm, k) * r1(nm - icx - icx, k, l)
     &                           + bdx  (nm, k) * r1(nm - icx, k, l)
     &                           + bux  (nm, k) * r1(nm + icx, k, l)
     &                           + buux (nm, k) * r1(nm + icx + icx, k, l)
     &                           + buuux(nm, k) * r1(nm + icx + icx + icx, k, l)
                  uvdwk(nm, k) = ddkl(nm, k, l) - rscale(nm, k)*uvdwk(nm, k)
               endif
            enddo
         enddo
!      if(icx == 1) then
!        call timer_stop(timer_difu_solve4u, gdp)
!        call timer_start(timer_difu_solve5u, gdp)
!      else
!        call timer_stop(timer_difu_solve6v, gdp)
!        call timer_start(timer_difu_solve7v, gdp)
!      end if
         do nm = 1, nmmax, 2
            if (kfs(nm)*kcs(nm) == 1) vvdwk(nm, 1) = uvdwk(nm, 1)*bbkl(nm, 1, l)
         enddo
         do k = 2, kmax
            do nm = 1, nmmax, 2
               if (kfs(nm)*kcs(nm) == 1)
     &            vvdwk(nm, k) = (uvdwk(nm, k) - aakl(nm, k, l)*vvdwk(nm, k - 1))
     &            *bbkl(nm, k, l)
            enddo
         enddo
         do k = kmax - 1, 1, -1
            do nm = 1, nmmax, 2
               if (kfs(nm)*kcs(nm) == 1)
     &            vvdwk(nm, k) = vvdwk(nm, k) - cckl(nm, k, l) *vvdwk(nm, k + 1)
            enddo
         enddo
       !
       ! CHECK FOR CONVERGENCE
       !
         do k = 1, kmax
            do nm = 1, nmmax, 2
               if (kfs(nm)*kcs(nm) == 1) then
                  epsitr = max(1.e-8   , 0.5e-3*abs(r1(nm, k, l)))
                  if (abs(vvdwk(nm, k) - r1(nm, k, l)) > epsitr) itr = 1
                  r1(nm, k, l) = vvdwk(nm, k)
               endif
            enddo
         enddo
!      if(icx == 1) then
!        call timer_stop(timer_difu_solve5u, gdp)
!        call timer_start(timer_difu_solve4u, gdp)
!      else
!        call timer_stop(timer_difu_solve7v, gdp)
!        call timer_start(timer_difu_solve6v, gdp)
!      end if
       !
!      call dfexchg ( r1(:,:,l), 1, kmax, dfloat, gdp )
       !
       ! loop starts at point of other color now (black respectively red)
       !
!      nmsta = 3 - nmsta
       !
         do k = 1, kmax
            do nm = 2, nmmax, 2
             !
             ! COMPUTE RIGHT HAND SIDE
             !
               if (kfs(nm)*kcs(nm) == 1) then
                  uvdwk(nm, k) =   bdddx(nm, k) * r1(nm - icx - icx - icx, k, l)
     &                           + bddx (nm, k) * r1(nm - icx - icx, k, l)
     &                           + bdx  (nm, k) * r1(nm - icx, k, l)
     &                           + bux  (nm, k) * r1(nm + icx, k, l)
     &                           + buux (nm, k) * r1(nm + icx + icx, k, l)
     &                           + buuux(nm, k) * r1(nm + icx + icx + icx, k, l)
                  uvdwk(nm, k) = ddkl(nm, k, l) - rscale(nm, k)*uvdwk(nm, k)
               endif
            enddo
         enddo
!      if(icx == 1) then
!        call timer_stop(timer_difu_solve4u, gdp)
!        call timer_start(timer_difu_solve5u, gdp)
!      else
!        call timer_stop(timer_difu_solve6v, gdp)
!        call timer_start(timer_difu_solve7v, gdp)
!      end if
         do nm = 2, nmmax, 2
            if (kfs(nm)==1 .and. kcs(nm) == 1) then
               vvdwk(nm, 1) = uvdwk(nm, 1)*bbkl(nm, 1, l)
            endif
         enddo
         do k = 2, kmax
            do nm = 2, nmmax, 2
               if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                  vvdwk(nm, k) = (uvdwk(nm,k) -  aakl(nm,k,l)*vvdwk(nm,k-1)) * bbkl(nm,k,l)
               endif
            enddo
         enddo
         do k = kmax - 1, 1, -1
            do nm = 2, nmmax, 2
               if ( (kfs(nm)==1) .and. (kcs(nm)==1) ) then
                  vvdwk(nm, k) = vvdwk(nm, k) - cckl(nm, k, l) *vvdwk(nm, k + 1)
               endif
            enddo
         enddo
       !
       ! CHECK FOR CONVERGENCE
       !
         do k = 1, kmax
            do nm = 2, nmmax, 2
               if (kfs(nm)*kcs(nm) == 1) then
                  epsitr = max(1.e-8   , 0.5e-3*abs(r1(nm, k, l)))
                  if (abs(vvdwk(nm, k) - r1(nm, k, l)) > epsitr) itr = 1
                  r1(nm, k, l) = vvdwk(nm, k)
               endif
            enddo
         enddo
!      if(icx == 1) then
!        call timer_stop(timer_difu_solve5u, gdp)
!      else
!        call timer_stop(timer_difu_solve7v, gdp)
!      end if
!      call dfexchg ( r1(:,:,l), 1, kmax, dfloat, gdp )
       !
       ! determine global maximum of 'itr' over all nodes
       ! Note: this enables to synchronize the iteration process
       !
!      call dfreduce_gdp( itr, 1, dfint, dfmax, gdp )
       !
         if (itr>0 .and. iter<50) goto 1100

         WRITE(LUNDIA,*) ' NUMBER OF ITERATIONS IN DLDIFU: ',
     &                   ITER,'   FOR CONST. NO. ',L
       !
         if ( iter .ge. 50 ) then                  ! special WAQ version
            write ( lundia, * ) 'max number of iterations exceeded'
            stop                'max number of iterations exceeded'
         endif
       !
       ! DD code added:
       !
       !
       !       D3dFlow_Solve_ADI_Conc: Check for convergence
       !
!      nhystp = nxtstp(d3dflow_solve_adi_conc, gdp)
!      if (nhystp == d3dflow_solve_adi_conc) goto 111
       !
       ! DD code added end
       !
      enddo

      if ( timon ) call timstop ( ithandl )
      return
      end subroutine dldifu


      subroutine jmem(ncfg,j,nze,ind_jj,nij,istart,njv,nze_c,nze_t)

      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NOD=220,NTERMD=31,NWD=60)
*     MPI stuff ***********************************************
*
        INCLUDE 'mpif.h'
        parameter (MAXPROC=9999)
        common /MPI/ myid, nprocs, ierr, istat(MPI_STATUS_SIZE)
****************************************************************
      LOGICAL  SKIP
      POINTER (qh,h(ncfg,3)),(qjan,jan(ncfg,3))
      COMMON /buffer/qh, qjan, nrow(3), iflag(3)
      POINTER (IQLSP,LSP(ncfg))
      COMMON /NCFGS/ IQLSP,index(ntermd),IJK,nterm,termsh(ntermd)
      COMMON /INOUT/IREAD,IWRITE,ISCW,iuc,iuw,ioul,iouj,iout,
     :             iouhn,iouhz,iouhs,iouhm,iLS,idisk
*
      INTEGER cptr
      POINTER (iqhmx,hmx(1)),(iqjptr,jptr(1)),(iqimx,imx(1)),
     :        (iqeigvec,eigvec(1)),(iqkval,kval(1)),(iqcptr,cptr(1)),
     :        (qtm,tm(1)),(qtp,tp(1)),(qdiag,hii(1)),(qiwork,iwork(1))
      COMMON /MX/iqhmx, iqjptr, iqimx, iqeigvec, iqkval, iqcptr,
     :           qtm,qtp,qdiag,qiwork
      INTEGER   q(8), ipos(3),iselec(NTERMD)
      LOGICAL iupper,hiend
      DATA iupper/.false./
      DATA crite,critc,critr,trhold,ortho/
     :       0.d-17,1.d-8,1.d-8,1.d-10,1.d-15/
!     :       0.d-17,1.d-12,1.d-20,1.d0,1.d0/
      pointer(pflsj,flsj(nterm,nterm,2,njv))
      double precision flsj;
      logical lhmx_memory,lhmx_disk
      integer ind_jj
*
      rewind(iouhn)
      rewind(iouhz)
      rewind(iouhs)
      mycol = 0;
      nze_t = 0;
      nze_c = 0;
      nij = 0
      do j = myid+1,ncfg,nprocs
         mycol = mycol + 1
         if (idisk .eq. 1) then
	    nij = 0
	 end if
	 if (mod(lsp(j),2) .eq. 0) then
*            .. csf does not contribute
	    nij = nij+1
	    jptr(mycol) = nij
	    if (j .eq. 1) then
	       read(iouhn) jb,m1,(h(i,1),i=1,m1),
     :                           (jan(i,1),i=1,m1)
	    else
	       read(iouhn) jb
	    end if
	    read(iouhz) jb
	    read(iouhs) jb
 	 else
            ipos(1:3) = 0
	    ntermj = mod(lsp(j),64)/2
	    read(iouhn) jb,m1,(h(i,1),i=1,m1),
     :                        (jan(i,1),i=1,m1)
	    read(iouhz) jb,m2,(h(i,2),i=1,m2),
     :                        (jan(i,2),i=1,m2)
            read(iouhs) jb,m3,(h(i,3),i=1,m3),
     :                        (jan(i,3),i=1,m3)
            call advance(1,m1,ipos,ncfg)
	    call advance(2,m2,ipos,ncfg)
	    call advance(3,m3,ipos,ncfg)
*           .. while there is more data
*             find which file has lowest row
            iipos = min(ipos(1),ipos(2),ipos(3))
            do while (iipos <= ncfg)
*             .. there is more data
	       nij = nij + 1
	       irow = min(nrow(1),nrow(2),nrow(3))
	       if (nrow(1) .eq. irow) then
	          call advance(1,m1,ipos,ncfg)
	       end if
	       if (nrow(2) .eq. irow) then
	          ntermi = mod(lsp(j),64)/2
	          call advance(2,m2,ipos,ncfg)
	       end if
	       if (nrow(3) .eq. irow) then
	          ntermi = mod(lsp(j),64)/2
	          call advance(3,m3,ipos,ncfg)
	       end if
               iipos = min(ipos(1),ipos(2),ipos(3));
            end do
	 end if
         nze_ctem = nij - nze_t
         if (nze_ctem > nze_c) nze_c = nze_ctem
         nze_t = nij;
      end do
      return
      end subroutine


      SUBROUTINE ALG10
C
      REAL LOSS,LAMI,LAMIP1,LAMIM1
C
      COMMON /UD300C/ NSTNS,NSTRMS,NMAX,NFORCE,NBL,NCASE,NSPLIT,NREAD,
     1NPUNCH,NPAGE,NSET1,NSET2,ISTAG,ICASE,IFAILO,IPASS,I,IVFAIL,IFFAIL,
     2NMIX,NTRANS,NPLOT,ILOSS,LNCT,ITUB,IMID,IFAIL,ITER,LOG1,LOG2,LOG3,
     3LOG4,LOG5,LOG6,IPRINT,NMANY,NSTPLT,NEQN,NSPEC(30),NWORK(30),
     4NLOSS(30),NDATA(30),NTERP(30),NMACH(30),NL1(30),NL2(30),NDIMEN(30)
     5,IS1(30),IS2(30),IS3(30),NEVAL(30),NDIFF(4),NDEL(30),NLITER(30),
     6NM(2),NRAD(2),NCURVE(30),NWHICH(30),NOUT1(30),NOUT2(30),NOUT3(30),
     7NBLADE(30),DM(11,5,2),WFRAC(11,5,2),R(21,30),XL(21,30),X(21,30),
     8H(21,30),S(21,30),VM(21,30),VW(21,30),TBETA(21,30),DIFF(15,4),
     9FDHUB(15,4),FDMID(15,4),FDTIP(15,4),TERAD(5,2),DATAC(100),
     1DATA1(100),DATA2(100),DATA3(100),DATA4(100),DATA5(100),DATA6(100),
     2DATA7(100),DATA8(100),DATA9(100),FLOW(10),SPEED(30),SPDFAC(10),
     3BBLOCK(30),BDIST(30),WBLOCK(30),WWBL(30),XSTN(150),RSTN(150),
     4DELF(30),DELC(100),DELTA(100),TITLE(18),DRDM2(30),RIM1(30),
     5XIM1(30),WORK(21),LOSS(21),TANEPS(21),XI(21),VV(21),DELW(21),
     6LAMI(21),LAMIM1(21),LAMIP1(21),PHI(21),CR(21),GAMA(21),SPPG(21),
     7CPPG(21),HKEEP(21),SKEEP(21),VWKEEP(21),DELH(30),DELT(30),VISK,
     8SHAPE,SCLFAC,EJ,G,TOLNCE,XSCALE,PSCALE,PLOW,RLOW,XMMAX,RCONST,
     9FM2,HMIN,C1,PI,CONTR,CONMX
C
      IF(I.GT.1)GO TO 130
      V5=VISK**0.2
      VINH=0.0
      VINT=0.0
      IF(WWBL(1).GT.0.0)GO TO 100
      C1H=0.0
      C1T=0.0
      DELH(1)=0.0
      DELT(1)=0.0
      GO TO 150
100   IF(ISTAG.GT.0)GO TO 110
      X1=WWBL(1)*XL(NSTRMS,1)*(CPPG(1)+CPPG(NSTRMS))/4.0
      DELH(1)=X1
      DELT(1)=X1
      X1=X1/(SCLFAC*SHAPE)
      C1H=(X1*VM(1,1)**3.4/V5)**1.25
      C1T=(X1*VM(NSTRMS,1)**3.4/V5)**1.25
      GO TO 150
110   DELH(1)=0.0
      C1H=0.0
      IF(ABS(PHI(NSTRMS)).GT.PI/2.0-0.00015.AND.ABS(PHI(NSTRMS)).LT.PI/2
     1.0+0.00015)GO TO 120
      X1=(R(NSTRMS,1)-SQRT(R(NSTRMS,1)**2-COS(PHI(NSTRMS))*CPPG(NSTRMS)*
     1WWBL(1)*(R(NSTRMS,1)+R(1,1))*XL(NSTRMS,I)))/COS(PHI(NSTRMS))
      DELT(1)=X1
      C1T=(X1/(SHAPE*SCLFAC*V5)*VM(NSTRMS,1)**3.4)**1.25
      GO TO 150
120   DELT(1)=WWBL(1)*XL(NSTRMS,1)/CPPG(NSTRMS)
      C1T=(DELT(1)*VM(NSTRMS,1)**3.4/(V5*SCLFAC*SHAPE))**1.25
      GO TO 150
130   VINT=VINT+SQRT((X(NSTRMS,I)-X(NSTRMS,I-1))**2+(R(NSTRMS,I)-R(NSTRM
     1S,I-1))**2)*((VM(NSTRMS,I)+VM(NSTRMS,I-1))/2.0)**4/SCLFAC
      DELT(I)=V5*(C1T+0.016*VINT)**0.8/VM(NSTRMS,I)**3.4*SCLFAC*SHAPE
      DELH(I)=0.0
      IF(I.LE.ISTAG)GO TO 140
      VINH=VINH+SQRT((X(1,I)-X(1,I-1))**2+(R(1,I)-R(1,I-1))**2)*((VM(1,I
     1)+VM(1,I-1))/2.0)**4/SCLFAC
      DELH(I)=V5*(C1H+0.016*VINH)**0.8/VM(1,I)**3.4*SCLFAC*SHAPE
140   WWBL(I)=0.5*WWBL(I)+0.5*(((2.0*R(NSTRMS,I)-DELT(I)*COS(PHI(NSTRMS)
     1))*DELT(I)/CPPG(NSTRMS)+(2.0*R(1,I)+DELH(I)*COS(PHI(1)))*DELH(I)/C
     2PPG(1))/((R(NSTRMS,I)+R(1,I))*XL(NSTRMS,I)))
      IF(WWBL(I).GT.0.3)WWBL(I)=0.3
      IF(WWBL(I).LT.0.0)WWBL(I)=0.3
150   CONTINUE
      RETURN
      END


      module setup_module

c***********************************************************************
c
c     dl_poly module for defining default array sizes
c     copyright - daresbury laboratory
c     author    - w. smith    sep 2003
c
c     note the following internal units apply everywhere
c
c     unit of time      (to)    =          1 x 10**(-12) seconds
c     unit of length    (lo)    =          1 x 10**(-10) metres
c     unit of mass      (mo)    = 1.6605402  x 10**(-27) kilograms
c     unit of charge    (qo)    = 1.60217733 x 10**(-19) coulombs
c     unit of energy    (eo)    = 1.6605402  x 10**(-23) joules
c     unit of pressure  (po)    = 1.6605402  x 10**(  7) pascals
c
c*********************************************************************

      use parse_module

      implicit none

c     FIXED PARAMETERS

c     standard pi values

      real(8), parameter :: pi=3.141592653589793d0
      real(8), parameter :: sqrpi=1.7724538509055159d0

c     conversion factor for coulombic terms in internal units
c     i.e. (unit(charge)**2/(4 pi eps0 unit(length))/unit(energy)

      real(8), parameter :: r4pie0=138935.4835d0

c     boltzmann constant in internal units

      real(8), parameter :: boltz=8.31451115d-1

c     planck's constant in internal units

      real(8), parameter :: hbar=6.350780719d0

c     conversion factor for pressure from internal units to katm

      real(8), parameter :: prsunt=0.163882576d0

c     main input channel

      integer, parameter :: nread=5

c     main output channel

      integer, parameter :: nrite=6

c     force field input channel

      integer, parameter :: nfield=9

c     configuration file input channel

      integer, parameter :: nconf=10

c     statistical data file output channel

      integer, parameter :: nstats=20

c     trajectory history file channel

      integer, parameter :: nhist=21

c     acummulators restart dump file

      integer, parameter :: nrest=22

c     tabulated potential file channel

      integer, parameter :: ntable=23

c     rdf file channel number

      integer, parameter :: nrdfdt=24

c     z density file channel number

      integer, parameter :: nzdndt=25

c     hyperdynamics reference basin file

      integer, parameter :: nbsn=30

c     neb reaction path profile file

      integer, parameter :: npro=31

c     hyperdynamics events journal file

      integer, parameter :: nevnt=33

c     hyperdynamics tracking file

      integer, parameter :: ntrk=32

c     hyperdynamics restart file

      integer, parameter :: nhrs=35

c     free energy data file

      integer, parameter :: nfrnwr=41

c     solvation data file

      integer, parameter :: nsolwr=43

c     pimd thermostats file

      integer, parameter :: ntherm=45

c     pimd random number restart data

      integer, parameter :: npuni=46

c     data dumping interval in event of system crash

      integer, parameter :: ndump=1000

c     maximum number of neb calculations

      integer, parameter :: maxneb=10

c     pimd defaults

      integer, parameter :: num_beads_default=10

c     array allocation parameters (set by subroutine parset)

      integer kmaxa,kmaxb,kmaxc,msatms,msbad,msgrp
      integer mspmf,msteth,mxangl,mxatms,mxbond,mxbuff,mxcell
      integer mxcons,mxdihd,mxewld,mxexcl,mxfbp,mxfld,mxgatm,mxgrid
      integer mxgrp,mxinv,mxlist,mxlshp,mxneut,mxngp,mxnstk,mxpang
      integer mxpbnd,mxpdih,mxpfbp,mxpinv,mxpmf,mxptbp,mxpvdw
      integer mxrdf,mxzdn,mxshl,mxsite,mxspmf,mxstak,mxtang,mxtbnd
      integer mxtbp,mxtcon,mxtdih,mxteth,mxtinv,mxtmls,mxtshl,mxungp
      integer mxvdw,mxxdf,mx2tbp,mx3fbp,mxebuf,mxquat,mxshak,mxspl
      integer kmaxd,kmaxe,kmaxf,mxspme,mxftab,mxhko,mxegrd,mxhke
      integer mxmet,mxsmet,mxpmet,mxter,mxpter,mxatyp,mxxtyp
      integer mxtmls_fre,mxewld_fre,mxebuf_fre,mxatms_fre,mxatyp_exc
      integer mxtmls_exc,mxtmls_sol,mxebuf_sol,mxatms_sol
      integer nbeads,nchain,mslist,mspimd

      save kmaxa,kmaxb,kmaxc,msatms,msbad,msgrp
      save mspmf,msteth,mxangl,mxatms,mxbond,mxbuff,mxcell
      save mxcons,mxdihd,mxewld,mxexcl,mxfbp,mxfld,mxgatm,mxgrid
      save mxgrp,mxinv,mxlist,mxlshp,mxneut,mxngp,mxnstk,mxpang
      save mxpbnd,mxpdih,mxpfbp,mxpinv,mxpmf,mxptbp,mxpvdw
      save mxrdf,mxzdn,mxshl,mxsite,mxspmf,mxstak,mxtang,mxtbnd
      save mxtbp,mxtcon,mxtdih,mxteth,mxtinv,mxtmls,mxtshl,mxungp
      save mxvdw,mxxdf,mx2tbp,mx3fbp,mxebuf,mxquat,mxshak,mxspl
      save kmaxd,kmaxe,kmaxf,mxspme,mxftab,mxhko,mxegrd,mxhke
      save mxmet,mxsmet,mxpmet,mxter,mxpter,mxatyp,mxxtyp
      save mxtmls_fre,mxewld_fre,mxebuf_fre,mxatms_fre,mxatyp_exc
      save mxtmls_exc,mxtmls_sol,mxebuf_sol,mxatms_sol
      save nbeads,nchain,mslist,mspimd

      contains

      subroutine parset(redirect,idnode,mxnode,buffer)

c***********************************************************************
c
c     dl_poly subroutine to determine required array sizes for
c     allocation of memory manager
c
c     copyright daresbury laboratory 1997
c     author - w.smith june 1997
c
c***********************************************************************

      logical loglnk,lewald,lspme,lhke,nolink,lcshft
      logical lsolva,lfree,lfrmas,lghost,redirect,lpimd
      real(8) cell,celprp,rctbp,rcfbp,volm,xhi,yhi,zhi,rcut,rvdw
      real(8) densvar,delr,cut,dens,ratio,drdf,dzdn,rcter,buffer
      real(8) zlen
      integer imcon,nhko,ilx,ily,ilz,ncells,numatm,keyres
      integer idnode,mxnode,mxn1

      dimension cell(9),celprp(10),buffer(10)

      lhke=.false.
      lpimd=.false.
      lspme=.false.
      lewald=.false.
      lcshft=.false.
      nolink=.false.
      redirect=.false.
      mxtmls_sol=1
      mxebuf_sol=1
      mxatms_sol=1
      mxtmls_fre=1
      mxewld_fre=1
      mxebuf_fre=1
      mxatms_fre=1
      mxatyp_exc=1
      mxtmls_exc=1

c     scan the FIELD file data

      call fldscan(idnode,mxn1,rctbp,rcfbp,rcter)

c     scan CONFIG file data

      call cfgscan
     x  (idnode,nconf,imcon,numatm,volm,xhi,yhi,zhi,cell,buffer)

c     scan CONTROL file data

      call conscan
     x  (redirect,lewald,lspme,lhke,nolink,lcshft,lsolva,lfree,lfrmas,
     x  lghost,lpimd,idnode,imcon,nhko,keyres,rcut,rvdw,delr,densvar,
     x  drdf,dzdn,zlen,cell)

      if(lpimd.and.keyres.gt.0)then
        if(numatm.ne.nbeads*mxatms)call abortscan(56,idnode)
      else
        if(numatm.ne.mxatms)call abortscan(56,idnode)
      endif
      if(lpimd)numatm=nbeads*mxatms

c     set dimension of working coordinate arrays

      msatms=max(1,(mxatms-1)/mxnode+1)
      if(lsolva)mxatms_sol=mxatms
      if(lfree.or.lghost)mxatms_fre=mxatms

c     maximum number of molecule types

      mxtmls=max(mxtmls,1)
      if(lsolva)mxtmls_sol=mxtmls
      if(lfree)mxtmls_fre=mxtmls
      if(lghost)then

        mxtmls_exc=mxtmls
        mxtmls_fre=mxtmls

      endif

c     maximum number of specified bondlength constraints

      mxtcon=max(mxtcon,1)

c     maximum number of chemical bond potentials

      mxtbnd=max(mxtbnd,1)

c     maximum number of different bond angle potentials

      mxtang=max(mxtang,1)

c     maximum number of different torsional potentials

      mxtdih=max(mxtdih,1)

c     maximum number of different inversion potentials

      mxtinv=max(mxtinv,1)

c     maximum number of unique rigid body units

      mxungp=max(mxungp,1)

c     maximum number of tethered atom potentials

      mxteth=max(mxteth,1)

c     maximum number of core-shell units

      mxshl=max(mxshl,1)

c     set maximum number of unique atom types

      mxatyp=max(1,mxatyp)
      mxxtyp=(mxatyp*(mxatyp+1))/2
      if(lghost)mxatyp_exc=mxatyp

c     maximum number of vdw potentials

      mxvdw=max(mxvdw,1)+1

c     maximum number of metal potentials

      mxmet=max(mxmet,1)+1
      mxsmet=mxatyp

c     maximum number of tersoff potentials

      if(mxter.gt.0)then

        mxter=mxatyp

      endif

c     maximum number of three body potentials

      if(mxtbp.eq.0)then

        mx2tbp=0

      else

        mx2tbp=(mxatyp*(mxatyp+1))/2
        mxtbp=mx2tbp*mxatyp

      endif

c     maximum number of four body potentials

      if(mxfbp.eq.0)then

        mx3fbp=0

      else

        mx3fbp=(mxatyp*(mxatyp+1)*(mxatyp+2))/6
        mxfbp=mxatyp*mx3fbp

      endif

c     maximum number of angular potential parameters

      mxpang=6

c     maximum number of three body potential parameters

      mxptbp=mxpang+1

c     maximum number of four body potential parameters

      mxpfbp=3

c     maximum number of parameters for dihedrals

      mxpdih=5

c     maximum number of parameters for inversion potentials

      mxpinv=2

c     maximum number of parameters for bond potentials

      mxpbnd=4

c     maximum number of parameters for vdw potentials

      mxpvdw=6

c     maximum number of parameters for metal potentials

      mxpmet=7

c     maximum number of parameters for tersoff potential

      mxpter=11

c     maximum number of external field parameters

      mxfld=10

c     maximum number of excluded atoms per atom

      mxexcl=max(mxexcl,1)

c     maximum number of different sites in system

      mxsite=max(mxsite,1)

c     maximum number of chemical bonds per node

      mxbond=max(1,(mxbond-1)/mxnode+1)

c     maximum number of bond angles per node

      mxangl=max(1,(mxangl-1)/mxnode+1)

c     maximum number of torsion angles per node

      mxdihd=max(1,(mxdihd-1)/mxnode+1)

c     maximum number of inversion potentials per node

      mxinv=max(1,(mxinv-1)/mxnode+1)

c     maximum number of constraints per node

      mxcons=max(1,2*((mxcons-1)/mxnode+1))

c     maximum number of tethered atoms per node

      msteth=max(1,(msteth-1)/mxnode+1)

c     maximum size for working arrays for bonds, angles, dihedrals
c     inversion potentials, tethers and core-shell units

      msbad=max(mxbond,mxangl,mxdihd,mxinv,msteth,mxshl)

c     maximum number of grid points in potentials arrays

      if(mxgrid.eq.0)then

        mxgrid=max(1000,int(rvdw/0.01d0+0.5d0)+4)

      endif

      mxegrd=0
      if(lewald.or.lspme.or.lhke.or.lcshft)mxegrd=mxgrid

c     maximum dimension of rdf arrays

      mxrdf=max(128,int(rcut/drdf))

c     maximum dimension of zdensity arrays

      mxzdn=max(128,int(zlen/dzdn))

c     maximum number of rigid groups in system

      mxgrp=max(mxgrp,1)

c     maximum number of rigid groups per node

      msgrp=max(1,(mxgrp-1)/mxnode+1)

c     maximum number of sites per rigid unit

      mxngp=max(mxngp,3)

c     maximum number of sites in rigid units

      mxgatm=max(1,mxgatm)

c     maximum number of timesteps in stack arrays

      mxstak=max(100,mxstak)

c     maximum number of variables in stack arrays

      mxnstk=52+mxatyp

c     dimension of shake shared atoms array

      mxlshp=max(mxcons*2,1)

c     set dimension of working arrays in ewald sum

      mxewld=1
      mxebuf=1
      if(lewald)then

        mxftab=1
        mxewld=msatms
        mxebuf=(2*kmaxa+1)*(2*kmaxb+1)*(2*kmaxc+1)-1
        if(lfree.or.lghost)mxebuf=3*mxebuf
        if(mxnode.le.16.and.mxebuf.le.5000)mxebuf=1

      endif

c     set dimension of working arrays in spme

      mxspme=1
      if(lspme)then

        mxspme=mxatms
        mxftab=2*(kmaxd+kmaxe+kmaxf)

      endif

c     set dimension of working arrays for HK ewald

      mxhko=1
      mxhke=1
      if(lhke)then

        mxhko=2
        mxewld=msatms
        mxhke=msatms
        if(nhko.gt.0)mxhko=max(2,nhko)
        mxebuf=(2*kmaxa+1)*(2*kmaxb+1)-1
        if(mxnode.le.16.and.mxebuf.le.5000)mxebuf=1

      endif

      if(lsolva)mxebuf_sol=mxebuf
      if(lfree.or.lghost)then

        mxebuf_fre=mxebuf
        mxewld_fre=mxewld

      endif

c     maximum dimension of principal transfer buffer

      mxbuff=max(6*numatm,8*(mxcons+1),8*(mxgrp+1),mxnstk*mxstak,
     x  mxebuf,mxgrid,2*kmaxa*kmaxb*kmaxc,2*kmaxd*kmaxe*kmaxf,
     x  10000)

c     maximum size of verlet neighbour/link cell list for each atom
c     decide if link-cells in use or not

      cut=rcut+delr
      dens=dble(mxatms)/volm
      ratio=1.5d0*dens*(4.d0*pi/3.d0)*cut**3
      mxlist=min(nint(ratio),(mxatms+1)/2)
      mslist=nbeads*((mxatms-1)/mxnode+1)
      mspimd=nbeads*((mxatms-1)/mxnode+1)
      if(imcon.eq.0) then

        cell(1)=max(xhi+2.d0*cut,3.d0*cut)
        cell(5)=max(yhi+2.d0*cut,3.d0*cut)
        cell(9)=max(zhi+2.d0*cut,3.d0*cut)

      endif
      if(imcon.eq.6)then

        cell(9)=max(zhi+2.d0*cut,3.d0*cut,cell(9))

      endif

      if(nolink)then

        loglnk=.false.

      else

        loglnk=.true.
        call dcell(cell,celprp)
        ilx=int(celprp(7)/cut)
        ily=int(celprp(8)/cut)
        ilz=int(celprp(9)/cut)
        if(ilx.lt.3.or.ily.lt.3.or.ilz.lt.3)loglnk=.false.
        ncells=ilx*ily*ilz
        if(imcon.eq.4.or.imcon.eq.5.or.imcon.eq.7)loglnk=.false.
        if(mxneut.gt.0.and.ncells.le.36) loglnk=.false.

      endif

      mxcell=1
      if(loglnk)then

        mxlist=14*nint(1.5d0*dens*celprp(10)/dble(ncells))
        mxcell=(ilx+2)*(ily+2)*(ilz+2)

      endif

      if(mxneut.gt.0)mxlist=(mxneut+1)/2
      mxlist=2*mxlist
      if(mxtbp.gt.0.or.mxfbp.gt.0.or.mxter.gt.0)then

        if(mxtbp.gt.0)cut=min(cut,rctbp)
        if(mxfbp.gt.0)cut=min(cut,rcfbp)
        if(mxter.gt.0)cut=min(cut,rcter)
        ilx=max(3,int(celprp(7)/cut))
        ily=max(3,int(celprp(8)/cut))
        ilz=max(3,int(celprp(9)/cut))
        mxcell=max(mxcell,(ilx+2)*(ily+2)*(ilz+2))

      endif
      mxcell=int(dble(mxcell)*densvar/100.d0)
      mxlist=int(dble(mxlist)*densvar/100.d0)
      mxlist=max(500,mxlist)

c     maximum size for coordinate difference arrays

      mxxdf=max(mxlist,mxatms,mxcons,mxn1*mxn1*(mxneut+1)/2)

c     maximum number of core-shell unit types

      mxtshl=max(mxtshl,1)

c     potential of mean force array parameter

      mxpmf=max(1,mxpmf)

c     number of pmf constraints on a processor

      mspmf=max(1,(mxpmf-1)/mxnode+1)

c     maximum number of sites to define pmf units

      mxspmf=max(mxspmf,1)

c     maximum iterations in quaternion integration

      mxquat=100

c     maximum number of shake cycles

      mxshak=100

c     maximum b-spline interpolation order

      mxspl=12

c     increment mxneut

      if(mxneut.gt.0)mxneut=mxneut+1

      return

      end subroutine parset

      subroutine fldscan(idnode,mxn1,rctbp,rcfbp,rcter)

c***********************************************************************
c
c     dl_poly routine for scanning the field file to determine the
c     required parameters
c
c     copyright - daresbury laboratory 1994
c     author    - w. smith  november   1994
c
c***********************************************************************

      integer, parameter :: mmk=1000

      character*8 name,keyword,chr(mmk)
      logical check,ltable,lmetab,safe,lneut,loop1,loop2
      real(8) rctbp,rcter,rcfbp,rct,ppp
      integer mxn1,nxn1,idnode,nold
      integer itmols,ksite,numsit,isite,nrept,ifrz,i,j
      integer ishls,ibonds,numcon,numang,icon,iang,idih,numdih
      integer numinv,iinv,numgrp,kgrp,numgsit,numteth,iteth
      integer ipmf,jpmf,npmf,itpvdw,itptbp,itpfbp
      integer itpter,k,nfld,nummols,idum,numshl,nneu
      integer numbonds,itpmet,iii,ngrid

      mxtmls=0
      mxatms=0
      mxgrp=0
      mxtcon=0
      mxtbnd=0
      mxtang=0
      mxtdih=0
      mxtinv=0
      mxpmf=0
      mxspmf=0
      mxungp=0
      mxngp=0
      mxneut=0
      mxmet=0
      mxatyp=0
      mxn1=0
      nxn1=0
      nold=-1
      mxgatm=0
      mxteth=0
      msteth=0
      mxvdw=0
      mxtbp=0
      mxter=0
      mxexcl=0
      mxsite=0
      mxbond=0
      mxcons=0
      mxangl=0
      mxdihd=0
      mxinv=0
      mxshl=0
      mxtshl=0
      mxfbp=0
      mxgrid=0
      rctbp=0.d0
      rcter=0.d0
      rcfbp=0.d0
      safe=.true.
      loop1=.true.
      loop2=.true.
      lneut=.false.
      ltable=.false.
      lmetab=.false.

c     open force field data file

      if(idnode.eq.0)open (nfield,file='FIELD')

      call getrec(safe,idnode,nfield)
      if(.not.safe)call abortscan(52,idnode)

c     read and process directives from field file

      do while(loop1)

        call getrec(safe,idnode,nfield)
        if(.not.safe)call abortscan(52,idnode)
        call lowcase(record,lenrec)

        if(findstring('neut',record,idum))then

          lneut=.true.

        elseif(findstring('molecu',record,idum))then

          mxtmls=intstr(record,lenrec,idum)

          do itmols=1,mxtmls

            loop2=.true.
            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)

            do while(loop2)

              call getrec(safe,idnode,nfield)
              if(.not.safe)call abortscan(52,idnode)
              call lowcase(record,lenrec)

              ksite=0

              if(findstring('nummol',record,idum))then

                nummols=intstr(record,lenrec,idum)

              elseif(findstring('atoms',record,idum))then

                numsit=intstr(record,lenrec,idum)
                mxatms=mxatms+numsit*nummols
                mxsite=mxsite+numsit
                ksite=0
                do isite=1,numsit

                  if(ksite.lt.numsit)then

                    call getrec(safe,idnode,nfield)
                    if(.not.safe)call abortscan(52,idnode)

                    call getword(name,record,8,lenrec)
                    ppp=dblstr(record,lenrec,idum)
                    ppp=dblstr(record,lenrec,idum)
                    nrept=intstr(record,lenrec,idum)
                    ifrz=intstr(record,lenrec,idum)
                    nneu=intstr(record,lenrec,idum)
                    if(nrept.eq.0)nrept=1
                    if(lneut)then
                      if(nneu.ne.nold) nxn1=0
                      nxn1=nxn1+nrept
                      mxn1=max(mxn1,nxn1)
                      nold=nneu
                    endif

                    if(mxatyp.eq.0)then

                      mxatyp=1
                      chr(1)=name

                    else

                      check=.true.
                      do j=1,mxatyp

                        if(name.eq.chr(j))check=.false.

                      enddo
                      if(check)then

                        mxatyp=mxatyp+1
                        if(mxatyp.le.mmk)chr(mxatyp)=name

                      endif

                    endif
                    if(nrept.eq.0)nrept=1
                    ksite=ksite+nrept

                  endif

                enddo

                if(mmk.lt.mxatyp)call abortscan(34,idnode)

                if(lneut)mxneut=mxneut+nneu*nummols

              elseif(findstring('shell',record,idum))then

                numshl=intstr(record,40,idum)
                mxtshl=mxtshl+numshl
                mxshl=mxshl+nummols*numshl

                do ishls=1,numshl

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('bonds',record,idum))then

                numbonds=intstr(record,lenrec,idum)
                mxtbnd=mxtbnd+numbonds
                mxbond=mxbond+nummols*numbonds

                do ibonds=1,numbonds

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('constr',record,idum))then

                numcon=intstr(record,lenrec,idum)
                mxtcon=mxtcon+numcon
                mxcons=mxcons+nummols*numcon

                do icon=1,numcon

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('angles',record,idum))then

                numang=intstr(record,lenrec,idum)
                mxtang=mxtang+numang
                mxangl=mxangl+nummols*numang

                do iang=1,numang

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('dihedr',record,idum))then

                numdih=intstr(record,lenrec,idum)
                mxtdih=mxtdih+numdih
                mxdihd=mxdihd+nummols*numdih

                do idih=1,numdih

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('invers',record,idum))then

                numinv=intstr(record,lenrec,idum)
                mxtinv=mxtinv+numinv
                mxinv=mxinv+nummols*numinv

                do iinv=1,numinv

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('rigid',record,idum))then

                numgrp=intstr(record,lenrec,idum)
                mxungp=mxungp+numgrp
                mxgrp=mxgrp+numgrp*nummols

                do kgrp=1,numgrp

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                  numgsit=intstr(record,lenrec,idum)
                  mxgatm=mxgatm+numgsit*nummols
                  mxngp=max(mxngp,numgsit)
                  do j=1,numgsit

                    iii=intstr(record,lenrec,idum)
                    if(iii.eq.0)then
                      call getrec(safe,idnode,nfield)
                      if(.not.safe)call abortscan(52,idnode)
                      iii=intstr(record,lenrec,idum)
                    endif

                  enddo

                enddo

              elseif(findstring('teth',record,idum))then

                numteth=intstr(record,lenrec,idum)
                mxteth=mxteth+numteth
                msteth=msteth+numteth*nummols

                do iteth=1,numteth

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)

                enddo

              elseif(findstring('pmf',record,idum))then

                do ipmf=1,2

                  call getrec(safe,idnode,nfield)
                  if(.not.safe)call abortscan(52,idnode)
                  call lowcase(record,lenrec)
                  npmf=intstr(record,lenrec,idum)
                  mxspmf=mxspmf+npmf

                  do jpmf=1,npmf

                    call getrec(safe,idnode,nfield)
                    if(.not.safe)call abortscan(52,idnode)

                  enddo

                enddo

                mxpmf=mxpmf+nummols

              elseif(findstring('finish',record,idum))then

                loop2=.false.

              endif

            enddo

          enddo

        elseif(findstring('vdw',record,idum))then

          if(findstring('tab',record,idum))ltable=.true.
          mxvdw=intstr(record,lenrec,idum)
          do itpvdw=1,mxvdw

            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)
            call lowcase(record,lenrec)
            if(findstring('tab',record,idum))ltable=.true.

          enddo
          mxvdw=max(mxvdw,(mxatyp*(mxatyp+1))/2)

          if(ltable)then

            if(idnode.eq.0)open(ntable,file='TABLE')

            call getrec(safe,idnode,ntable)
            if(.not.safe)call abortscan(24,idnode)
            call getrec(safe,idnode,ntable)
            if(.not.safe)call abortscan(24,idnode)
            ppp=dblstr(record,lenrec,idum)
            ppp=dblstr(record,lenrec,idum)
            mxgrid=max(mxgrid,intstr(record,lenrec,idum))

            close (ntable)

          endif

        elseif(findstring('metal',record,idum))then

          if(findstring('eam',record,idum))lmetab=.true.
          mxmet=intstr(record,lenrec,idum)
          do itpmet=1,mxmet

            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)
            call lowcase(record,lenrec)
            if(findstring('eam',record,idum))lmetab=.true.

          enddo
          mxmet=max(mxmet,(mxatyp*(mxatyp+1))/2)

          if(lmetab)then

            if(idnode.eq.0)open(ntable,file='TABEAM')

            call getrec(safe,idnode,ntable)
            if(.not.safe)call abortscan(24,idnode)
            call getrec(safe,idnode,ntable)
            if(.not.safe)call abortscan(24,idnode)
            do i=1,intstr(record,lenrec,idum)

              call getrec(safe,idnode,ntable)
              if(.not.safe)call abortscan(24,idnode)
              ngrid=intstr(record,lenrec,idum)
              mxgrid=max(mxgrid,ngrid+4)
              do j=1,(ngrid+3)/4

                call getrec(safe,idnode,ntable)
                if(.not.safe)call abortscan(24,idnode)

              enddo

            enddo

            close (ntable)

          endif

        elseif(findstring('tbp',record,idum))then

          mxtbp=intstr(record,lenrec,idum)

          do itptbp=1,mxtbp

            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)
            call getword(name,record,8,lenrec)
            call getword(name,record,8,lenrec)
            call getword(name,record,8,lenrec)
            call getword(keyword,record,4,lenrec)
            ppp=dblstr(record,lenrec,idum)
            ppp=dblstr(record,lenrec,idum)
            ppp=dblstr(record,lenrec,idum)
            ppp=dblstr(record,lenrec,idum)
            rct=dblstr(record,lenrec,idum)
            rctbp=max(rctbp,rct)

          enddo

        elseif(findstring('fbp',record,idum))then

          mxfbp=intstr(record,lenrec,idum)
          do itpfbp=1,mxfbp

            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)
            call getword(name,record,8,lenrec)
            call getword(name,record,8,lenrec)
            call getword(name,record,8,lenrec)
            call getword(name,record,8,lenrec)
            call getword(keyword,record,4,lenrec)
            ppp=dblstr(record,lenrec,idum)
            ppp=dblstr(record,lenrec,idum)
            rct=dblstr(record,lenrec,idum)
            rcfbp=max(rcfbp,rct)

          enddo

        elseif(findstring('tersof',record,idum))then

          mxter=intstr(record,lenrec,idum)

          do itpter=1,mxter

            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)
            call getrec(safe,idnode,nfield)
            if(.not.safe)call abortscan(52,idnode)
            rct=dblstr(record,lenrec,idum)
            rcter=max(rcter,rct)

          enddo

        elseif(findstring('extern',record,idum))then

          call getrec(safe,idnode,nfield)
          if(.not.safe)call abortscan(52,idnode)
          nfld=intstr(record,lenrec,idum)
          if(nfld.eq.0)nfld=5
          call getrec(safe,idnode,nfield)
          if(.not.safe)call abortscan(52,idnode)

          do k=1,nfld

            ppp=dblstr(record,lenrec,idum)
            if(idum.gt.lenrec.and.k.lt.nfld)then
              call getrec(safe,idnode,nfield)
              if(.not.safe)call abortscan(52,idnode)
            endif

          enddo

        elseif(findstring('close',record,idum))then

          loop1=.false.

        endif

      enddo

      if(idnode.eq.0)close (nfield)

      if(mxtcon.gt.0)mxexcl=max(mxexcl,6)
      if(mxtbnd.gt.0)mxexcl=max(mxexcl,6)
      if(mxtang.gt.0)mxexcl=max(mxexcl,16)
      if(mxtdih.gt.0)mxexcl=max(mxexcl,50)
      if(mxtinv.gt.0)mxexcl=max(mxexcl,50)
      if(mxneut.gt.0)mxexcl=max(mxexcl,10*mxn1*mxn1)
      if(mxgrp.gt.0)mxexcl=max(mxexcl,mxngp)

      return

      end subroutine fldscan

      subroutine cfgscan
     x  (idnode,nconf,imcon,numatm,volm,xhi,yhi,zhi,cell,buffer)

c***********************************************************************
c
c     dl_poly subroutine for scanning the initial configuration
c     file to determine the number of atoms present
c
c     copyright - daresbury laboratory 1997
c     author    - w. smith  june       1997
c
c     note: volm is volume containing all particles, not system volume
c
c***********************************************************************

      character*80 header
      character*8 name
      logical lvolm
      real(8) cell,celprp,buffer,extra,volm,xhi,yhi,zhi,xlo,ylo,zlo
      real(8) xxx,yyy,zzz,uuu,vvv,www,coz
      integer idnode,nconf,imcon,levcfg,numatm
      dimension cell(9),celprp(10),buffer(10),extra(6)

      imcon=0
      numatm=0
      levcfg=0
      volm=0.d0
      cell(:)=0.d0
      xhi=0.d0
      yhi=0.d0
      zhi=0.d0

      if(idnode.eq.0)then

        open (nconf,file='CONFIG')

c     read the CONFIG file header

        read(nconf,'(a80)')header
        read(nconf,'(3i10)')levcfg,imcon,numatm

c     specify molecular dynamics simulation cell

        if(imcon.gt.0)then

          read(nconf,'(3f20.0)')cell(1),cell(2),cell(3)
          read(nconf,'(3f20.0)')cell(4),cell(5),cell(6)
          read(nconf,'(3f20.0)')cell(7),cell(8),cell(9)
          call dcell(cell,celprp)

        endif

        if(imcon.eq.0.or.imcon.eq.6.or.numatm.eq.0)then

          numatm=0
          xlo=1.d9
          ylo=1.d9
          zlo=1.d9
          xhi=-1.d9
          yhi=-1.d9
          zhi=-1.d9

          do while(.true.)

            read(nconf,'(a8)',end=100) name
            read(nconf,'(3f20.0)')xxx,yyy,zzz
            if(levcfg.gt.0)read(nconf,*)
            if(levcfg.gt.1)read(nconf,*)
            xhi=max(xhi,xxx)
            yhi=max(yhi,yyy)
            zhi=max(zhi,zzz)
            xlo=min(xlo,xxx)
            ylo=min(ylo,yyy)
            zlo=min(zlo,zzz)
            numatm=numatm+1

          enddo

 100      continue

          xhi=xhi-xlo+2.d0
          yhi=yhi-ylo+2.d0
          zhi=zhi-zlo+2.d0

        endif

        if(imcon.eq.0)then

          volm=xhi*yhi*zhi

        elseif(imcon.eq.6)then

          coz=(cell(1)*cell(4)+cell(2)*cell(5)+cell(3)*cell(6))/
     x      (celprp(1)*celprp(2))
          volm=zhi*celprp(1)*celprp(2)*sqrt(1.d0-coz**2)

        elseif(imcon.eq.4.or.imcon.eq.5.or.imcon.eq.7)then

          volm=0.5d0*celprp(10)

        else

          volm=celprp(10)

        endif

        close (nconf)

      endif

      extra(1)=dble(imcon)
      extra(2)=xhi
      extra(3)=yhi
      extra(4)=zhi
      extra(5)=volm
      extra(6)=dble(numatm)
      call gdsum(extra,6,buffer)
      call gdsum(cell,9,buffer)
      imcon=nint(extra(1))
      xhi=extra(2)
      yhi=extra(3)
      zhi=extra(4)
      volm=extra(5)
      numatm=nint(extra(6))

      return

      end subroutine cfgscan

      subroutine conscan
     x  (redirect,lewald,lspme,lhke,nolink,lcshft,lsolva,lfree,lfrmas,
     x  lghost,lpimd,idnode,imcon,nhko,keyres,rcut,rvdw,delr,densvar,
     x  drdf,dzdn,zlen,cell)

c***********************************************************************
c
c     dl_poly subroutine for scanning the contents of the control file
c
c     copyright - daresbury laboratory 1997
c     author    - w. smith  june       1997
c
c***********************************************************************

      logical safe,lewald,lspme,lhke,peek,nolink,lcshft,lmetad
      logical lsolva,lfree,lfrmas,lghost,redirect,lpimd
      real(8) cell,celprp,rcut,rvdw,delr,eps,alpha,fac,tol,tol1
      real(8) densvar,drdf,dzdn,zlen
      integer nhko,idnode,imcon,idum,jmp
      integer nlatt,kmax1,kmax2,kmax3,kmaxpow2,keyres
      dimension celprp(10),cell(9)

      nhko=0
      mxstak=0
      kmaxa=0
      kmaxb=1
      kmaxc=1
      kmaxd=1
      kmaxe=1
      kmaxf=1
      nbeads=1
      nchain=1
      keyres=0
      rcut=0.d0
      rvdw=0.d0
      delr=0.d0
      drdf=0.05d0
      dzdn=0.05d0
      zlen=0.d0
      densvar=1.d2
      peek=.true.
      lpimd=.false.
      lhke=.false.
      lspme=.false.
      lewald=.false.
      lcshft=.false.
      nolink=.false.
      lghost=.false.
      lfree=.false.
      lfrmas=.false.
      lsolva=.false.
      lmetad=.false.
      redirect=.false.

c     open the simulation input file

      if(idnode.eq.0)open (nread,file='CONTROL')

      call getrec(safe,idnode,nread)
      if(.not.safe)call abortscan(17,idnode)

      do while(peek)

        call getrec(safe,idnode,nread)
        if(.not.safe)call abortscan(17,idnode)
        call lowcase(record,lenrec)
        if(record(1).ne.'#')then

          if(findstring('stack',record,idum))then

            mxstak=intstr(record,lenrec,idum)

          elseif(findstring('no link',record,idum))then

            nolink=.true.

          elseif(findstring('pimd',record,idum))then

            lpimd = .true.
            if(findstring('nhc',record,idum))then
              nbeads=intstr(record,lenrec,idum)
              nchain=intstr(record,lenrec,idum)
              nchain=max(nchain,1)
            else
              nbeads=intstr(record,lenrec,idum)
            endif
            if(nbeads.eq.0)nbeads=num_beads_default

          elseif(findstring('metafreeze',record,idum))then

            lmetad=.true.
            do while(lmetad)
              call getrec(safe,idnode,nread)
              if(.not.safe)call abortscan(17,idnode)
              call lowcase(record,lenrec)
              lmetad=.not.findstring('endmet',record,idum)
            enddo

          elseif(findstring('restart',record,idum))then

            keyres=1
            if(findstring('noscale',record,idum))keyres = 3
            if(findstring('scale',record,idum))keyres = 2

          elseif(findstring('redirect',record,idum))then

            redirect=.true.

          elseif(findstring('densvar',record,idum))then

            densvar=dblstr(record,lenrec,idum)

          elseif(findstring('shift',record,idum).or.
     x        findstring('reaction',record,idum))then

            lcshft=.true.

          elseif(findstring('ewald',record,idum).or.
     x        findstring('spme',record,idum).or.
     x        findstring('hke',record,idum))then

c     read Ewald or HK-Ewald or SPM-Ewald sum parameters

            lhke=findstring('hke',record,idum)
            lspme=findstring('spme',record,idum)
            lewald=findstring('ewald',record,idum)

            if(findstring('precision',record,idum))then

              eps=dblstr(record,lenrec,idum)
              if(lhke) then

                nhko=intstr(record,lenrec,idum)
                nlatt=intstr(record,lenrec,idum)
                nlatt=min(nlatt,2)

              endif

              if(rcut.lt.1.d-6)rcut=10.d0

c     compute alpha and the kmax

              if(lewald.or.lspme)then

                call dcell(cell,celprp)
                eps=min(abs(eps),0.5d0)
                tol=sqrt(abs(log(eps*rcut)))
                alpha=sqrt(abs(log(eps*rcut*tol)))/rcut
                tol1=sqrt(-log(eps*rcut*(2.d0*tol*alpha)**2))
                fac=1.d0
                if(imcon.eq.4.or.imcon.eq.5.or.imcon.eq.7)
     x            fac=2.d0**(1.d0/3.d0)
                kmax1=nint(0.25d0+fac*celprp(1)*alpha*tol1/pi)
                kmax2=nint(0.25d0+fac*celprp(2)*alpha*tol1/pi)
                kmax3=nint(0.25d0+fac*celprp(3)*alpha*tol1/pi)

              elseif(lhke)then

                if(nhko.eq.0)then
                  if(eps.le.1.d-6)then
                    alpha=3.46d0/rcut
                  elseif(eps.le.1.d-5)then
                    alpha=3.14d0/rcut
                  else
                    alpha=2.76d0/rcut
                  endif
                elseif(nhko.eq.1)then
                  if(eps.le.1.d-6)then
                    alpha=4.37d0/rcut
                  elseif(eps.le.1.d-5)then
                    alpha=4.08d0/rcut
                  else
                    alpha=3.75d0/rcut
                  endif
                elseif(nhko.eq.2)then
                  if(eps.le.1.d-6)then
                    alpha=5.01d0/rcut
                  elseif(eps.le.1.d-5)then
                    alpha=4.74d0/rcut
                  else
                    alpha=4.44d0/rcut
                  endif
                elseif(nhko.eq.3)then
                  if(eps.le.1.d-6)then
                    alpha=5.55d0/rcut
                  elseif(eps.le.1.d-5)then
                    alpha=5.28d0/rcut
                  else
                    alpha=5.00d0/rcut
                  endif
                endif
                alpha=alpha/dble(2*nlatt+1)
                if(abs(cell(9)).lt.1.d-8)cell(9)=1.d0
                call dcell(cell,celprp)
                tol=2.d0*alpha*sqrt(abs(log(eps*alpha)))
                tol1=2.d0*alpha*sqrt(abs(log(eps*alpha*tol)))
                kmax1=nint(0.25d0+0.5d0*celprp(1)*tol1/pi)
                kmax2=nint(0.25d0+0.5d0*celprp(2)*tol1/pi)
                kmax3=1

              endif

            else

              alpha=dblstr(record,lenrec,idum)
              kmax1=intstr(record,lenrec,idum)
              kmax2=intstr(record,lenrec,idum)

              if(lhke)then

                kmax3=1
                nhko=intstr(record,lenrec,idum)

              else

                kmax3=intstr(record,lenrec,idum)

              endif

            endif

c     for spme double kmax and set to next power of 2, with current
c     upper limit of 512

            if(lspme)then

              kmaxpow2=1
              do while (kmax1.gt.kmaxpow2.and.kmaxpow2.lt.256)
                kmaxpow2=kmaxpow2*2
              end do
              kmaxd=2*kmaxpow2

              kmaxpow2=1
              do while (kmax2.gt.kmaxpow2.and.kmaxpow2.lt.256)
                kmaxpow2=kmaxpow2*2
              end do
              kmaxe=2*kmaxpow2

              kmaxpow2=1
              do while (kmax3.gt.kmaxpow2.and.kmaxpow2.lt.256)
                kmaxpow2=kmaxpow2*2
              end do
              kmaxf=2*kmaxpow2

            elseif(lhke) then

              kmaxa=kmax1
              kmaxb=kmax2
              kmaxc=1

            else

              kmaxa=kmax1
              kmaxb=kmax2
              kmaxc=kmax3

            endif

          elseif(findstring('cut',record,idum))then

            rcut=dblstr(record,lenrec,idum)

          elseif(findstring('rvdw',record,idum))then

            rvdw=dblstr(record,lenrec,idum)

          elseif(findstring('delr',record,idum))then

            delr=dblstr(record,100,idum)

          elseif(findstring('rdf',record,idum))then

            if(.not.findstring('print',record,idum))then

              jmp=intstr(record,lenrec,idum)
              drdf=dblstr(record,lenrec,idum)

            endif

          elseif(findstring('zden',record,idum))then

            jmp=intstr(record,lenrec,idum)
            dzdn=dblstr(record,lenrec,idum)
            zlen=dblstr(record,lenrec,idum)
            if(dzdn.lt.1.d-8)then

              dzdn=0.1d0
              zlen=0.1d0*dble(128)

            elseif(zlen.lt.1.d-8)then

              zlen=dzdn*dble(128)

            endif

          elseif(findstring('solva',record,idum))then

            lsolva=.true.

          elseif(findstring('decomp',record,idum))then

            lsolva=.true.

          elseif(findstring('free',record,idum))then

            lfree=.true.

          elseif(findstring('excit',record,idum))then

            lghost=.true.
            lsolva=.true.

          elseif(findstring('reset_mass',record,idum))then

            lfrmas=.true.

          elseif(findstring('switch',record,idum))then

            lghost=.true.
            lsolva=.true.

          elseif(findstring('finish',record,idum))then

            peek=.false.

          endif

        endif

      enddo

      if(idnode.eq.0)close (nread)
      if(abs(rvdw).le.1.d-10)rvdw=rcut
      if(drdf.lt.1.d-8)drdf=0.05d0
      if(dzdn.lt.1.d-8)dzdn=0.05d0

      return

      end subroutine conscan

      subroutine abortscan(key,idnode)

c*********************************************************************
c
c     dl_poly subroutine for controlled exit of file scan
c
c     copyright - daresbury laboratory
c     author    - w. smith    sep 2003
c
c*********************************************************************

      integer key,idnode

      if(idnode.eq.0)then

        write(nrite,'(/,/,1x,a,i5)')
     x    'DL_POLY terminated due to error ', key

        if(key.eq.17)then

          write(nrite,'(/,/,1x,a)')
     x      'error - strange exit from CONTROL file processing'

        elseif(key.eq.24)then

          write(nrite,'(/,/,1x,a)')
     x      'error - end of file encountered in TABLE file'

        elseif(key.eq.34)then

          write(nrite,'(/,/,1x,a)')
     x      'error - character array memory allocation failure'

        elseif(key.eq.52)then

          write(nrite,'(/,/,1x,a)')
     x      'error - end of FIELD file encountered'

        elseif(key.eq.56)then

          write(nrite,'(/,/,1x,a)')
     x      'error - incorrect atom numbers in CONFIG file'

        endif

        close (nrite)
        close (nhist)
        close (nread)
        close (nconf)
        close (nstats)
        close (nrest)
        close (nfield)
        close (ntable)
      endif

      call gsync()
      call exitcomms()

      return
      end subroutine abortscan

      subroutine dcell(aaa,bbb)

c***********************************************************************
c
c     dl_poly subroutine to calculate the dimensional properties of
c     a simulation cell specified by the input matrix aaa.
c     the results are returned in the array bbb, with :
c
c     bbb(1 to 3) - lengths of cell vectors
c     bbb(4 to 6) - cosines of cell angles
c     bbb(7 to 9) - perpendicular cell widths
c     bbb(10)     - cell volume
c
c     copyright daresbury laboratory 1992
c     author - w. smith         july 1992
c
c***********************************************************************

      real(8) aaa,bbb,axb1,axb2,axb3,bxc1,bxc2,bxc3,cxa1,cxa2,cxa3

      dimension aaa(9),bbb(10)

c     calculate lengths of cell vectors

      bbb(1)=sqrt(aaa(1)*aaa(1)+aaa(2)*aaa(2)+aaa(3)*aaa(3))
      bbb(2)=sqrt(aaa(4)*aaa(4)+aaa(5)*aaa(5)+aaa(6)*aaa(6))
      bbb(3)=sqrt(aaa(7)*aaa(7)+aaa(8)*aaa(8)+aaa(9)*aaa(9))

c     calculate cosines of cell angles

      bbb(4)=(aaa(1)*aaa(4)+aaa(2)*aaa(5)+aaa(3)*aaa(6))/(bbb(1)*bbb(2))
      bbb(5)=(aaa(1)*aaa(7)+aaa(2)*aaa(8)+aaa(3)*aaa(9))/(bbb(1)*bbb(3))
      bbb(6)=(aaa(4)*aaa(7)+aaa(5)*aaa(8)+aaa(6)*aaa(9))/(bbb(2)*bbb(3))

c     calculate vector products of cell vectors

      axb1=aaa(2)*aaa(6)-aaa(3)*aaa(5)
      axb2=aaa(3)*aaa(4)-aaa(1)*aaa(6)
      axb3=aaa(1)*aaa(5)-aaa(2)*aaa(4)
      bxc1=aaa(5)*aaa(9)-aaa(6)*aaa(8)
      bxc2=aaa(6)*aaa(7)-aaa(4)*aaa(9)
      bxc3=aaa(4)*aaa(8)-aaa(5)*aaa(7)
      cxa1=aaa(8)*aaa(3)-aaa(2)*aaa(9)
      cxa2=aaa(1)*aaa(9)-aaa(3)*aaa(7)
      cxa3=aaa(2)*aaa(7)-aaa(1)*aaa(8)

c     calculate volume of cell

      bbb(10)=abs(aaa(1)*bxc1+aaa(2)*bxc2+aaa(3)*bxc3)

c     calculate cell perpendicular widths

      bbb(7)=bbb(10)/sqrt(bxc1*bxc1+bxc2*bxc2+bxc3*bxc3)
      bbb(8)=bbb(10)/sqrt(cxa1*cxa1+cxa2*cxa2+cxa3*cxa3)
      bbb(9)=bbb(10)/sqrt(axb1*axb1+axb2*axb2+axb3*axb3)

      return
      end subroutine dcell

      end module setup_module