MODULE mo_salsa_driver
  USE classSection, ONLY : Section
  USE util, ONLY : getMassIndex !!! IS it good to import this here??? The function is anyway handy here too.
  USE mo_salsa_types, ONLY : aero, cloud, precp, ice, snow, allSALSA
  USE mo_submctl
  IMPLICIT NONE

   !---------------------------------------------------------------
   !
   ! MO_SALSA_DRIVER:
   ! Contains the primary SALSA input/output variables as well as
   ! Subroutines used to call the main SALSA routine.
   !
   ! Juha Tonttila, FMI, 2014
   !
   !---------------------------------------------------------------

   ! JT: Variables from SALSA
   ! --------------------------------------------
   ! grid points for SALSA
   INTEGER, PARAMETER :: kproma = 1
   INTEGER, PARAMETER :: kbdim = 1
   INTEGER, PARAMETER :: klev = 1
   INTEGER, PARAMETER :: krow = 1

   REAL, PARAMETER    :: init_rh(kbdim,klev) = 0.3

   ! -- Local gas compound tracers [# m-3]
   REAL :: zgso4(kbdim,klev),   &
           zghno3(kbdim,klev),  &
           zgnh3(kbdim,klev),   &
           zgocnv(kbdim,klev),  &
           zgocsv(kbdim,klev)

 ! --------------------------------------------

CONTAINS

   !
   !----------------------------------------------------
   ! RUN_SALSA
   ! Performs necessary unit and dimension conversion between
   ! the host model and SALSA module, and calls the main SALSA
   ! routine
   !
   ! Partially adobted form the original SALSA boxmodel version.
   !
   ! Now takes masses in as kg/kg from LES!! Converted to m3/m3 for SALSA
   !
   ! 05/2016 Juha: This routine is still pretty much in its original shape.
   !               It's dumb as a mule and twice as ugly, so implementation of
   !               an improved solution is necessary sooner or later.
   !
   ! Juha Tonttila, FMI, 2014
   ! Jaakko Ahola, FMI, 2016
   !
   SUBROUTINE run_SALSA(pnx, pny, pnz, n4, press, tk, rv, rt, rs, rsi, wp, pdn,   &
                        pa_naerop,  pa_naerot,  pa_maerop,  pa_maerot,   &
                        pa_ncloudp, pa_ncloudt, pa_mcloudp, pa_mcloudt,  &
                        pa_nprecpp, pa_nprecpt, pa_mprecpp, pa_mprecpt,  &
                        pa_nicep,   pa_nicet,   pa_micep,   pa_micet,    &
                        pa_nsnowp,  pa_nsnowt,  pa_msnowp,  pa_msnowt,   &
                        pa_nactd,   pa_vactd,   pa_gaerop,  pa_gaerot,   &
                        tstep, time, level, initialize)

      USE mo_salsa, ONLY : salsa
      USE mo_salsa_properties, ONLY  : equilibration
      IMPLICIT NONE

      INTEGER, INTENT(in) :: pnx,pny,pnz,n4                       ! dimensions: x,y,z,number of chemical species
      REAL, INTENT(in)    :: tstep                                ! Model timestep length
      REAL, INTENT(in)    :: time

      LOGICAL, INTENT(in) :: initialize

      REAL, INTENT(in)    :: press(pnz,pnx,pny), &            ! Pressure (Pa)
                             tk(pnz,pnx,pny),    &            ! Temperature (K)
                             rv(pnz,pnx,pny),    &            ! Water vapor mixing ratio
                             rs(pnz,pnx,pny),    &            ! Water vapour saturation mixing ratio
                             rsi(pnz,pnx,pny),   &            ! water vapour sat mix rat over ice
                             wp(pnz,pnx,pny)                  ! Vertical velocity (m s-1)

      REAL, INTENT(in)    :: pdn(pnz,pnx,pny)             ! Air density (for normalizing concentrations)

      REAL, INTENT(in)    :: pa_naerop(pnz,pnx,pny,nbins),        & ! aerosol number concentration (# kg-1)
                             pa_maerop(pnz,pnx,pny,n4*nbins),     & ! aerosol mass concentration (kg kg-1)
                             pa_ncloudp(pnz,pnx,pny,ncld),        & ! Cloud droplet number concentration (# kg-1)
                             pa_mcloudp(pnz,pnx,pny,n4*ncld),     & ! Cloud droplet mass concentration (kg kg-1)
                             pa_nprecpp(pnz,pnx,pny,nprc),        & ! Rain drop number concentration (# kg-1)
                             pa_mprecpp(pnz,pnx,pny,n4*nprc),     & ! Rain drop mass concentration (kg kg-1)
                             pa_nicep(pnz,pnx,pny,nice),          & ! ice number concentration (# kg-1)
                             pa_micep(pnz,pnx,pny,n4*nice),       & ! ice mass concentration (kg kg-1)
                             pa_nsnowp(pnz,pnx,pny,nsnw),         & ! snow number concentration (# kg-1)
                             pa_msnowp(pnz,pnx,pny,n4*nsnw)        ! snow mass concentration (kg kg-1)

      REAL, INTENT(in)    :: pa_gaerop(pnz,pnx,pny,5)         ! Gaseous tracers [# kg]

      INTEGER, INTENT(in) :: level                         ! thermodynamical level

      REAL, INTENT(inout) :: pa_naerot(pnz,pnx,pny,nbins),      & ! Aerosol number tendency
                             pa_maerot(pnz,pnx,pny,n4*nbins),   & ! Aerosol mass tendency
                             pa_ncloudt(pnz,pnx,pny,ncld),      & ! Cloud droplet number tendency
                             pa_mcloudt(pnz,pnx,pny,n4*ncld),   & ! Cloud droplet mass tendency
                             pa_nprecpt(pnz,pnx,pny,nprc),      & ! Rain drop number tendency
                             pa_mprecpt(pnz,pnx,pny,n4*nprc),   &  ! Rain drop mass tendency
                             pa_nicet(pnz,pnx,pny,nice),        & ! Ice particle number tendency
                             pa_micet(pnz,pnx,pny,n4*nice),     & ! Ice particle mass tendency
                             pa_nsnowt(pnz,pnx,pny,nsnw),       & ! snow flake number tendency
                             pa_msnowt(pnz,pnx,pny,n4*nsnw)     ! snow flake mass tendecy

      REAL, INTENT(inout) :: pa_gaerot(pnz,pnx,pny,5)         ! Gaseous tracer tendency
      REAL, INTENT(inout) :: rt(pnz,pnx,pny)                  ! Water vapour tendency

      REAL, INTENT(out) :: pa_vactd(pnz,pnx,pny,n4*ncld) ! Volume concentrations of newly activated droplets for calculating the
                                                           ! actual tendency due to new droplet formation.
      REAL, INTENT(out) :: pa_nactd(pnz,pnx,pny,ncld)   ! Same for number concentration

      TYPE(Section) :: actd(kbdim,klev,ncld) ! Activated droplets - for interfacing with SALSA

      ! Helper arrays for calculating the rates of change
      TYPE(Section) :: aero_old(kbdim,klev,nbins), cloud_old(kbdim,klev,ncld),    &
                       precp_old(kbdim,klev,nprc), ice_old(kbdim,klev,nice),      &
                       snow_old(kbdim,klev,nsnw)

      INTEGER :: jj,ii,kk,ss,str,end, nc,vc, ndry, nwet
      REAL :: in_p(kbdim,klev), in_t(kbdim,klev), in_rv(kbdim,klev), in_rs(kbdim,klev),&
              in_w(kbdim,klev), in_rsi(kbdim,klev)
      REAL :: rv_old(kbdim,klev)

      ndry = spec%getNSpec(type="dry")
      nwet = spec%getNSpec(type="wet")

      actd(:,:,:) = Section(2,nlim,dlcloud)
      aero_old(:,:,:) = Section(1,nlim,dlaero)
      cloud_old(:,:,:) = Section(2,nlim,dlcloud)
      precp_old(:,:,:) = Section(3,prlim,dlprecp)
      IF (level == 5) THEN
         ice_old(:,:,:) = Section(4,prlim,dlice)
         snow_old(:,:,:) = Section(5,prlim,dlsnow)
      END IF

      str = getMassIndex(nprc,1,nwet)
      end = getMassIndex(nprc,nprc,nwet)

      ! Set the SALSA runtime config
      CALL set_salsa_runtime(time)

      ! Convert input concentrations for SALSA into #/m3 or m3/m3 instead of kg/kg (multiplied by pdn/divided by substance density)
      DO jj = 3, pny-2
         DO ii = 3, pnx-2
            DO kk = pnz-1, 2, -1

               ! Set inputs
               in_p(1,1) = press(kk,ii,jj)
               in_t(1,1) = tk(kk,ii,jj)
               in_rs(1,1) = rs(kk,ii,jj)
               in_rsi(1,1) = rsi(kk,ii,jj)
               in_w(1,1) = wp(kk,ii,jj)

               ! For initialization and spinup, limit the RH with the parameter rhlim (assign in namelist.salsa)
               IF ( lsfreeRH%state ) THEN
                  in_rv(1,1) = rv(kk,ii,jj)
               ELSE
                  in_rv(1,1) = MIN(rv(kk,ii,jj), rs(kk,ii,jj)*rhlim)
               END IF
               rv_old(1,1) = in_rv(1,1)

               ! Update volume concentrations
               ! ---------------------------------------------------------------------------------------------------
               DO nc = 1,nwet
                  str = getMassIndex(nbins,1,nc)
                  end = getMassIndex(nbins,nbins,nc)
                  aero(1,1,1:nbins)%volc(nc) =  pa_maerop(kk,ii,jj,str:end)*pdn(kk,ii,jj)/spec%rholiq(nc)

                  str = getMassIndex(ncld,1,nc)
                  end = getMassIndex(ncld,ncld,nc)
                  cloud(1,1,1:ncld)%volc(nc) = pa_mcloudp(kk,ii,jj,str:end)*pdn(kk,ii,jj)/spec%rholiq(nc)

                  str = getMassIndex(nprc,1,nc)
                  end = getMassIndex(nprc,nprc,nc)
                  precp(1,1,1:nprc)%volc(nc) = pa_mprecpp(kk,ii,jj,str:end)*pdn(kk,ii,jj)/spec%rholiq(nc)

                  IF (level == 5) THEN
                     str = getMassIndex(nice,1,nc)
                     end = getMassIndex(nice,nice,nc)
                     ice(1,1,1:nice)%volc(nc) = pa_micep(kk,ii,jj,str:end)*pdn(kk,ii,jj)/spec%rhoice(nc)

                     str = getMassIndex(nsnw,1,nc)
                     end = getMassIndex(nsnw,nsnw,nc)
                     snow(1,1,1:nsnw)%volc(nc) = pa_msnowp(kk,ii,jj,str:end)*pdn(kk,ii,jj)/spec%rhosnow(nc)
                  ELSE
                     ice(1,1,1:nice)%volc(nc) = 0.
                     snow(1,1,1:nsnw)%volc(nc) = 0.
                  END IF
               END DO
               ! -------------------------------

               ! Update number concentrations and particle sizes
               ! ----------------------------------------------------------------------------
               aero(1,1,1:nbins)%numc = pa_naerop(kk,ii,jj,1:nbins)*pdn(kk,ii,jj)
               cloud(1,1,1:ncld)%numc = pa_ncloudp(kk,ii,jj,1:ncld)*pdn(kk,ii,jj)
               precp(1,1,1:nprc)%numc = pa_nprecpp(kk,ii,jj,1:nprc)*pdn(kk,ii,jj)
               IF (level > 4) THEN
                  ice(1,1,1:nice)%numc = pa_nicep(kk,ii,jj,1:nice)*pdn(kk,ii,jj)
                  snow(1,1,1:nsnw)%numc = pa_nsnowp(kk,ii,jj,1:nsnw)*pdn(kk,ii,jj)
               ELSE
                  ice(1,1,1:nice)%numc = 0.
                  snow(1,1,1:nsnw)%numc = 0.
               END IF

               ! Need the number of dry species below
               DO ss = 1,ntotal
                  ! For simplicity use prlim here? Doesn't matter so much in this part whether it's prlim or nlim?
                  IF (allSALSA(1,1,ss)%numc > prlim) THEN
                     allSALSA(1,1,ss)%core = SUM(allSALSA(1,1,ss)%volc(1:ndry))/allSALSA(1,1,ss)%numc
                     allSALSA(1,1,ss)%dwet = (SUM(allSALSA(1,1,ss)%volc(1:nwet))/allSALSA(1,1,ss)%numc/pi6 )**(1./3.)
                  ELSE
                     allSALSA(1,1,ss)%dwet = allSALSA(1,1,ss)%dmid
                     allSALSA(1,1,ss)%core = pi6*(allSALSA(1,1,ss)%dmid)**3
                  END IF
               END DO
               ! --------------------------------

               ! Take a copy of current concentrations to convert to tendencies after SALSA call
               aero_old = aero; cloud_old = cloud; precp_old = precp
               IF (level > 4) THEN
                  ice_old = ice; snow_old = snow
               END IF

               ! If this is an initialization call, calculate the equilibrium particle
               If (initialize) CALL equilibration(kproma,kbdim,klev,   &
                                                     init_rh,in_t,.TRUE.)

               ! Convert to #/m3
               zgso4(1,1) = pa_gaerop(kk,ii,jj,1)*pdn(kk,ii,jj)
               zghno3(1,1) = pa_gaerop(kk,ii,jj,2)*pdn(kk,ii,jj)
               zgnh3(1,1) = pa_gaerop(kk,ii,jj,3)*pdn(kk,ii,jj)
               zgocnv(1,1) = pa_gaerop(kk,ii,jj,4)*pdn(kk,ii,jj)
               zgocsv(1,1) = pa_gaerop(kk,ii,jj,5)*pdn(kk,ii,jj)

               ! ***************************************!
               !                Run SALSA               !
               ! ***************************************!
               CALL salsa(kproma, kbdim,  klev,   krow,     &
                          in_p,   in_rv,  in_rs,  in_rsi,   &
                          in_t,   tstep,                    &
                          zgso4,  zgocnv, zgocsv, zghno3,   &
                          zgnh3, aero,   cloud,  precp,         &
                        ice,    snow,                          &
                          actd,   in_w, level               )

               ! Calculate tendencies (convert back to #/kg or kg/kg)
               pa_naerot(kk,ii,jj,1:nbins) = pa_naerot(kk,ii,jj,1:nbins) + &
                    ( aero(1,1,1:nbins)%numc - aero_old(1,1,1:nbins)%numc )/pdn(kk,ii,jj)/tstep
               pa_ncloudt(kk,ii,jj,1:ncld) = pa_ncloudt(kk,ii,jj,1:ncld) + &
                    ( cloud(1,1,1:ncld)%numc - cloud_old(1,1,1:ncld)%numc )/pdn(kk,ii,jj)/tstep
               pa_nprecpt(kk,ii,jj,1:nprc) = pa_nprecpt(kk,ii,jj,1:nprc) + &
                    ( precp(1,1,1:nprc)%numc - precp_old(1,1,1:nprc)%numc )/pdn(kk,ii,jj)/tstep

               IF ( level == 5 ) THEN
                  pa_nicet(kk,ii,jj,1:nice) = pa_nicet(kk,ii,jj,1:nice) + &
                       ( ice(1,1,1:nice)%numc - ice_old(1,1,1:nice)%numc )/pdn(kk,ii,jj)/tstep
                  pa_nsnowt(kk,ii,jj,1:nsnw) = pa_nsnowt(kk,ii,jj,1:nsnw) + &
                       ( snow(1,1,1:nsnw)%numc - snow_old(1,1,1:nsnw)%numc )/pdn(kk,ii,jj)/tstep
               END IF

               ! Activated droplets
               pa_nactd(kk,ii,jj,1:ncld) = actd(1,1,1:ncld)%numc/pdn(kk,ii,jj)

               ! Get mass tendencies
               DO nc = 1,nwet

                  str = getMassIndex(nbins,1,nc)
                  end = getMassIndex(nbins,nbins,nc)
                  pa_maerot(kk,ii,jj,str:end) = pa_maerot(kk,ii,jj,str:end) + &
                       ( aero(1,1,1:nbins)%volc(nc) - aero_old(1,1,1:nbins)%volc(nc) )*spec%rholiq(nc)/pdn(kk,ii,jj)/tstep

                  str = getMassIndex(ncld,1,nc)
                  end = getMassIndex(ncld,ncld,nc)
                  pa_mcloudt(kk,ii,jj,str:end) = pa_mcloudt(kk,ii,jj,str:end) + &
                       ( cloud(1,1,1:ncld)%volc(nc) - cloud_old(1,1,1:ncld)%volc(nc) )*spec%rholiq(nc)/pdn(kk,ii,jj)/tstep

                  ! Activated droplets (in case of cloud base activation)
                  pa_vactd(kk,ii,jj,str:end) = actd(1,1,1:ncld)%volc(nc)*spec%rholiq(nc)/pdn(kk,ii,jj)

                  str = getMassIndex(nprc,1,nc)
                  end = getMassIndex(nprc,nprc,nc)
                  pa_mprecpt(kk,ii,jj,str:end) = pa_mprecpt(kk,ii,jj,str:end) + &
                       ( precp(1,1,1:nprc)%volc(nc) - precp_old(1,1,1:nprc)%volc(nc) )*spec%rholiq(nc)/pdn(kk,ii,jj)/tstep

                  IF ( level == 5 ) THEN
                     str = getMassIndex(nice,1,nc)
                     end = getMassIndex(nice,nice,nc)
                     pa_micet(kk,ii,jj,str:end) = pa_micet(kk,ii,jj,str:end) + &
                          ( ice(1,1,1:nice)%volc(nc) - ice_old(1,1,1:nice)%volc(nc) )*spec%rhoice(nc)/pdn(kk,ii,jj)/tstep

                     str = getMassIndex(nsnw,1,nc)
                     end = getMassIndex(nsnw,nsnw,nc)
                     pa_msnowt(kk,ii,jj,str:end) = pa_msnowt(kk,ii,jj,str:end) + &
                          ( snow(1,1,1:nsnw)%volc(nc) - snow_old(1,1,1:nsnw)%volc(nc) )*spec%rhosnow(nc)/pdn(kk,ii,jj)/tstep
                  END IF

               END DO

               IF (lscndgas) THEN
                  pa_gaerot(kk,ii,jj,1) = pa_gaerot(kk,ii,jj,1) + &
                                          ( zgso4(1,1)/pdn(kk,ii,jj) - pa_gaerop(kk,ii,jj,1) )/tstep

                  pa_gaerot(kk,ii,jj,2) = pa_gaerot(kk,ii,jj,2) + &
                                          ( zghno3(1,1)/pdn(kk,ii,jj) - pa_gaerop(kk,ii,jj,2) )/tstep

                  pa_gaerot(kk,ii,jj,3) = pa_gaerot(kk,ii,jj,3) + &
                                          ( zgnh3(1,1)/pdn(kk,ii,jj) - pa_gaerop(kk,ii,jj,3) )/tstep

                  pa_gaerot(kk,ii,jj,4) = pa_gaerot(kk,ii,jj,4) + &
                                          ( zgocnv(1,1)/pdn(kk,ii,jj) - pa_gaerop(kk,ii,jj,4) )/tstep

                  pa_gaerot(kk,ii,jj,5) = pa_gaerot(kk,ii,jj,5) + &
                                          ( zgocsv(1,1)/pdn(kk,ii,jj) - pa_gaerop(kk,ii,jj,5) )/tstep
               END IF

               ! Tendency of water vapour mixing ratio
               rt(kk,ii,jj) = rt(kk,ii,jj) + &
                  ( in_rv(1,1) - rv_old(1,1) )/tstep

            END DO ! kk
         END DO ! ii
      END DO ! jj

   END SUBROUTINE run_SALSA

   !
   !---------------------------------------------------------------
   ! SET_SALSA_RUNTIME
   ! Set the master process %state:s based on the values of %switch and %delay
   !
   ! Juha Tonttila, FMI, 2014
   !
   SUBROUTINE set_SALSA_runtime(time)
     USE mo_submctl, ONLY : Nmaster, lsmaster, lsfreeRH
     IMPLICIT NONE
     REAL, INTENT(in) :: time
     INTEGER :: i

     DO i = 1,Nmaster
        IF( lsmaster(i)%switch .AND. time > lsmaster(i)%delay ) lsmaster(i)%state = .TRUE.
     END DO

     ! Some other switches
     IF ( lsfreeRH%switch .AND. time > lsfreeRH%delay ) lsfreeRH%state = .TRUE.

   END SUBROUTINE set_SALSA_runtime

END MODULE mo_salsa_driver


      subroutine prjs (neq,y,yh,nyh,ewt,ftem,savf,wk,iwk,f,jac)
clll. optimize
      external f,jac
      integer neq, nyh, iwk
      integer iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     2   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
     1   ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
     2   lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
     3   nslj, ngp, nlu, nnz, nsp, nzl, nzu
      integer i, imul, j, jj, jok, jmax, jmin, k, kmax, kmin, ng
      double precision y, yh, ewt, ftem, savf, wk
      double precision rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      double precision con0, conmin, ccmxj, psmall, rbig, seth
      double precision con, di, fac, hl0, pij, r, r0, rcon, rcont,
     1   srur, vnorm
      dimension neq(1), y(1), yh(nyh,*), ewt(1), ftem(1), savf(1),
     1   wk(*), iwk(*)
      common /ls0001/ rowns(209),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(14), iowns(6),
     4   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth,
     1   iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
     2   ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
     3   lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
     4   nslj, ngp, nlu, nnz, nsp, nzl, nzu
c-----------------------------------------------------------------------
c prjs is called to compute and process the matrix
c p = i - h*el(1)*j , where j is an approximation to the jacobian.
c j is computed by columns, either by the user-supplied routine jac
c if miter = 1, or by finite differencing if miter = 2.
c if miter = 3, a diagonal approximation to j is used.
c if miter = 1 or 2, and if the existing value of the jacobian
c (as contained in p) is considered acceptable, then a new value of
c p is reconstructed from the old value.  in any case, when miter
c is 1 or 2, the p matrix is subjected to lu decomposition in cdrv.
c p and its lu decomposition are stored (separately) in wk.
c
c in addition to variables described previously, communication
c with prjs uses the following..
c y     = array containing predicted values on entry.
c ftem  = work array of length n (acor in stode).
c savf  = array containing f evaluated at predicted y.
c wk    = real work space for matrices.  on output it contains the
c         inverse diagonal matrix if miter = 3, and p and its sparse
c         lu decomposition if miter is 1 or 2.
c         storage of matrix elements starts at wk(3).
c         wk also contains the following matrix-related data..
c         wk(1) = sqrt(uround), used in numerical jacobian increments.
c         wk(2) = h*el0, saved for later use if miter = 3.
c iwk   = integer work space for matrix-related data, assumed to
c         be equivalenced to wk.  in addition, wk(iprsp) and iwk(ipisp)
c         are assumed to have identical locations.
c el0   = el(1) (input).
c ierpj = output error flag (in common).
c       = 0 if no error.
c       = 1  if zero pivot found in cdrv.
c       = 2  if a singular matrix arose with miter = 3.
c       = -1 if insufficient storage for cdrv (should not occur here).
c       = -2 if other error found in cdrv (should not occur here).
c jcur  = output flag = 1 to indicate that the jacobian matrix
c         (or approximation) is now current.
c this routine also uses other variables in common.
c-----------------------------------------------------------------------
      hl0 = h*el0
      con = -hl0
      if (miter .eq. 3) go to 300
c see whether j should be reevaluated (jok = 0) or not (jok = 1). ------
      jok = 1
      if (nst .eq. 0 .or. nst .ge. nslj+msbj) jok = 0
      if (icf .eq. 1 .and. dabs(rc - 1.0d0) .lt. ccmxj) jok = 0
      if (icf .eq. 2) jok = 0
      if (jok .eq. 1) go to 250
c
c miter = 1 or 2, and the jacobian is to be reevaluated. ---------------
 20   jcur = 1
      nje = nje + 1
      nslj = nst
      iplost = 0
      conmin = dabs(con)
      go to (100, 200), miter
c
c if miter = 1, call jac, multiply by scalar, and add identity. --------
 100  continue
      kmin = iwk(ipian)
      do 130 j = 1, n
        kmax = iwk(ipian+j) - 1
        do 110 i = 1,n
 110      ftem(i) = 0.0d0
        call jac (neq, tn, y, j, iwk(ipian), iwk(ipjan), ftem)
        do 120 k = kmin, kmax
          i = iwk(ibjan+k)
          wk(iba+k) = ftem(i)*con
          if (i .eq. j) wk(iba+k) = wk(iba+k) + 1.0d0
 120      continue
        kmin = kmax + 1
 130    continue
      go to 290
c
c if miter = 2, make ngp calls to f to approximate j and p. ------------
 200  continue
      fac = vnorm(n, savf, ewt)
      r0 = 1000.0d0 * dabs(h) * uround * dfloat(n) * fac
      if (r0 .eq. 0.0d0) r0 = 1.0d0
      srur = wk(1)
      jmin = iwk(ipigp)
      do 240 ng = 1,ngp
        jmax = iwk(ipigp+ng) - 1
        do 210 j = jmin,jmax
          jj = iwk(ibjgp+j)
          r = dmax1(srur*dabs(y(jj)),r0/ewt(jj))
 210      y(jj) = y(jj) + r
        call f (neq, tn, y, ftem)
        do 230 j = jmin,jmax
          jj = iwk(ibjgp+j)
          y(jj) = yh(jj,1)
          r = dmax1(srur*dabs(y(jj)),r0/ewt(jj))
          fac = -hl0/r
          kmin =iwk(ibian+jj)
          kmax =iwk(ibian+jj+1) - 1
          do 220 k = kmin,kmax
            i = iwk(ibjan+k)
            wk(iba+k) = (ftem(i) - savf(i))*fac
            if (i .eq. jj) wk(iba+k) = wk(iba+k) + 1.0d0
 220        continue
 230      continue
        jmin = jmax + 1
 240    continue
      nfe = nfe + ngp
      go to 290
c
c if jok = 1, reconstruct new p from old p. ----------------------------
 250  jcur = 0
      rcon = con/con0
      rcont = dabs(con)/conmin
      if (rcont .gt. rbig .and. iplost .eq. 1) go to 20
      kmin = iwk(ipian)
      do 275 j = 1,n
        kmax = iwk(ipian+j) - 1
        do 270 k = kmin,kmax
          i = iwk(ibjan+k)
          pij = wk(iba+k)
          if (i .ne. j) go to 260
          pij = pij - 1.0d0
          if (dabs(pij) .ge. psmall) go to 260
            iplost = 1
            conmin = dmin1(dabs(con0),conmin)
 260      pij = pij*rcon
          if (i .eq. j) pij = pij + 1.0d0
          wk(iba+k) = pij
 270      continue
        kmin = kmax + 1
 275    continue
c
c do numerical factorization of p matrix. ------------------------------
 290  nlu = nlu + 1
      con0 = con
      ierpj = 0
      do 295 i = 1,n
 295    ftem(i) = 0.0d0
      call cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1   wk(ipa),ftem,ftem,nsp,iwk(ipisp),wk(iprsp),iesp,2,iys)
      if (iys .eq. 0) return
      imul = (iys - 1)/n
      ierpj = -2
      if (imul .eq. 8) ierpj = 1
      if (imul .eq. 10) ierpj = -1
      return
c
c if miter = 3, construct a diagonal approximation to j and p. ---------
 300  continue
      jcur = 1
      nje = nje + 1
      wk(2) = hl0
      ierpj = 0
      r = el0*0.1d0
      do 310 i = 1,n
 310    y(i) = y(i) + r*(h*savf(i) - yh(i,2))
      call f (neq, tn, y, wk(3))
      nfe = nfe + 1
      do 320 i = 1,n
        r0 = h*savf(i) - yh(i,2)
        di = 0.1d0*r0 - h*(wk(i+2) - savf(i))
        wk(i+2) = 1.0d0
        if (dabs(r0) .lt. uround/ewt(i)) go to 320
        if (dabs(di) .eq. 0.0d0) go to 330
        wk(i+2) = 0.1d0*r0/di
 320    continue
      return
 330  ierpj = 2
      return
c----------------------- end of subroutine prjs ------------------------
      end


      SUBROUTINE spline_bkp_distance
      USE saddle_coils
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: i, n
      REAL(rprec), PARAMETER :: vs1 = 1, us1 = 1
      REAL(rprec) :: bkp_tst
!-----------------------------------------------

      bkp_min=1000

      DO i = 1, nsmid

         IF (nsad_v .gt. 5) THEN
            DO n = 4, nsad_v - 1
               bkp_tst = sad_v_s(i,n+1) - sad_v_s(i,n)
               bkp_min = MIN(bkp_min, bkp_tst)
            END DO
            bkp_tst = vs1 - sad_v_s(i,nsad_v)
            bkp_min = MIN(bkp_min, bkp_tst)
         END IF

         IF (nsad_u .gt. 5) THEN
            DO n = 4, nsad_u - 1
               bkp_tst = sad_u_s(i,n+1) - sad_u_s(i,n)
               bkp_min = MIN(bkp_min, bkp_tst)
            END DO
            bkp_tst = us1 - sad_u_s(i,nsad_u)
            bkp_min = MIN(bkp_min, bkp_tst)
         END IF

      END DO

      END SUBROUTINE spline_bkp_distance


      SUBROUTINE G3GRIN(ICOMND,XLOCV,YLOCV,XLOCN,YLOCN,NREPC)
C
C          ------------------------------------------------
C          ROUTINE NO. (3004)   VERSION (A8.2B)   09:FEB:90
C          ------------------------------------------------
C
C          THIS PROVIDES GRAPHICAL INPUT FACILITIES.
C          (THIS VERSION IS FOR DEVICES WITH GRAPHICAL INPUT).
C
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          <ICOMND> SETS THE INPUT ACTION:
C                   = 1, THE DEVICE CURSOR IS ACTIVATED,
C                   = 2, THE LOCATOR POSITIONS ARE RETURNED;
C          <XLOCV>  IS THE LOCATOR X-COORDINATE IN VECTOR SPACE;
C          <YLOCV>  IS THE LOCATOR Y-COORDINATE IN VECTOR SPACE;
C          <XLOCN>  IS THE LOCATOR X-COORDINATE IN ND-SPACE;
C          <YLOCN>  IS THE LOCATOR Y-COORDINATE IN ND-SPACE;
C          <NREPC>  IS THE (GHOST) REPLY CHARACTER NUMBER.
C
C
      LOGICAL CURTRA,GFOPEN,PPOPEN
C
      COMMON /T1LOCD/ XLOCAD,YLOCAD
      COMMON /T1LOCV/ XLOCAV,YLOCAV
      COMMON /T1REPN/ NREPLC
      COMMON /T1TCOC/ XCCX,XCCY,YCCX,YCCY,RPICXC,RPICYC,RDEVXC,RDEVYC,
     &                CURTRA
      COMMON /T1TCOR/ XRVX,XRVY,YRVX,YRVY,RPICXR,RPICYR,RDEVXR,RDEVYR
      COMMON /T3OUTS/ GFOPEN,PPOPEN
C
C
      IF (.NOT.PPOPEN) RETURN
      IF (ICOMND.NE.1) GO TO 1
C
C          THIS CALL ACTIVATES THE DEVICE CURSOR.
C
      CALL G1FILB(0,0,-83,0)
      RETURN
C
C          THE BACK-TRANSFORMATION COEFFICIENTS ARE CALCULATED
C          AND APPLIED TO THE ND-SPACE COORDINATES. THE ND-SPACE
C          VALUES ARE THEN CONVERTED TO NEW DEVICE COORDINATES
C          AND <G1MARV> CONVERTS THESE BACK INTO VECTOR SPACE.
C
    1 IF (ICOMND.NE.2) GO TO 3
C
      XPOS= XLOCAD
      YPOS= YLOCAD
      IF (.NOT.CURTRA) GO TO 2
C
      XPOS= XRVX*(XLOCAD-RDEVXR)+XRVY*(YLOCAD-RDEVYR)+RPICXR
      YPOS= YRVX*(XLOCAD-RDEVXR)+YRVY*(YLOCAD-RDEVYR)+RPICYR
    2 CALL G1MARV(XPOS,YPOS,XLOCAV,YLOCAV)
C
      XLOCV= XLOCAV
      YLOCV= YLOCAV
      XLOCN= XLOCAD
      YLOCN= YLOCAD
      NREPC= NREPLC
      RETURN
C
C          THIS CALL ACTIVATES THE TABLET.
C
    3 CALL G1FILB(0,0,-88,0)
      RETURN
      END


	PROGRAM TDSPRO
C
C	PLOTS TDS AND FREQUENCY
C
	include		'wind_examples:wind_tm_routine_def.for'
	include		'wind_examples:wind_return_code_def.for'
	integer*4	ok
	integer*4	i,j,k,n,itemp,il,ilp,iz
	integer*4	get_stream_name
	integer*4	wait_for_events			! an entry point
	integer*4	err_count
	integer*4	ichpa(6),ipacal(6,4)
	character*80	stream
	character*4	event
	character*4	pa(6,4)
	parameter	size=2048
	integer*4	return_size
	integer*4	tds_channel,ifilf,ifils,ifil,ifsps,issps,isps
	integer*4	temp_waves
	character*32	s
	integer*4	s_scet(2)
	real*8		scet,scettds,scetfill
	integer*4	major, minor
	character*80	file
	character*32	item
	integer*4	ios,ms,doy,msday
	integer*4	NREM,NHRMN,IHRMN,yyyy,mon,dd,hh,mm,ss,IFASTSLOW
	real 		ffilter,sfilter,fsps,ssps,sps
	REAL 		S1,S2,SPECT(1025)
!
	common /nrblk/ nrem,NHRMN,IFASTSLOW
	common /headblk/ major,minor,tds_channel,s_scet

C
	CHARACTER*16 PTITLE(20)
	INTEGER*4 TDSCH,hkch,fillch,ch
	COMPLEX CGAIN,FCOEF,FCOEFT,CCORR
c	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
c     1   NDATA(2060),DATA(2050)
	integer*4   NDATA(2050)
	real DATA(2050)
	COMMON /HEADBL/ PTITLE,EVENT
	COMMON /GAINBLK/ PHASE,CGAIN                   ! PHASE IS IN RADIANS
	COMMON /FITBLK/ NPT,VOLTIN(2048),TM(2048)
	COMMON /PLOTDT/ SPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
	DATA TWOPI /6.2831853/
	DATA FFILTER /50000.,12500.,3125.,781./
	DATA SFILTER /3125.,781.,195.,49./
	DATA FSPS /120.,30.,7.5,1.875/
	DATA SSPS /7500.,1875.,468.75,117.2/
	DATA PA /'EXAC','EXAC','EXDC',' BX ',' BY ',' BZ ',
     1           'EXDC','EYAC','EYDC','EXDC','EYDC','EZDC',
     2           '    ','EZAC','EZDC','    ','    ','    ',
     3           '    ','EZAC','EZDC','    ','    ','    '/
	DATA IPACAL /1,    1,     4,     7,     8,     9,
     1               4,    2,     5,     4,     5,     6,
     2               0,    3,     6,     0,     0,     0,
     3               0,    3,     6,     0,     0,     0/
	DATA IFASTSLOW /0/
C
	PTITLE(1) = 'WIND-WAVES'
	PTITLE(2) = 'TIME DOMAIN'
	PTITLE(3) = 'SAMPLER'
	PTITLE(4) = 'EVENT NO.'
	PTITLE(8) = 'SAMPLE RATE'
	PTITLE(10) = 'L.P.FILTER'
	PTITLE(12) = 'TRIGGERS'
	PTITLE(15) = 'SCET'
	PRINT*,' '
C
 1001	FORMAT(I4,1X,20I5)
 1002	FORMAT(A)
C
C	GET STARTED
C
!
	ok = get_stream_name(stream)
	if (.not. ok) stop 'no file supplied.'
C
        if(stream.ne.'realtime') then
 10	  write(6,*)  'type hr,min to start, e.g. 0412'
	  read(5,3,err=10) iq, NHRMN
	  type*,NHRMN
	  HH = NHRMN/100
	  MM = MOD(NHRMN,100)
	  write(6,4)
	  read(5,3,err=10,end=20) iq, NREM
	  type*,nrem
	endif
	type*,'type desired process level,0=raw,1=raw volts,2=fft,fft-1'
	read(5,3) iq,iprocess
	type*,' '
	if(iprocess.eq.0) type*,'ok, plot data in tm numbers - 128'
	if(iprocess.eq.1) type*,'ok, plot in volts, unity freq. response.'
	if(iprocess.eq.2) type*,'ok, plot volts, corrected for freq. response.'
	type*,' '
c
  5	format(q,a)
  4	format(1x,'enter number of events to find and process')
  3	format(q,i10)
c

	ok = w_channel_open(tdsch,stream)
	if (.not. ok) stop 'Cannot open tds channel'
	scettds = 0.
	call w_channel_position(tdsch,scettds)
	print*,'tds file starts at scettds',scettds
	dd = scettds
	scettds = float(dd) + hh/24. + mm/1440.
	print*,'set tds channel position to',scettds
	call w_channel_position(tdsch,scettds)
	print*,'tds channel position set to',scettds

	ok = w_channel_open(fillch,stream)
	if (.not. ok) stop 'Cannot open fill channel'
	scetfill = 0.
	call w_channel_position(fillch,scetfill)
	print*,'scetfill',scetfill
	dd = scetfill
	scetfill = float(dd) + hh/24. + mm/1440.
	print*,'set channel position to',scetfill
	call w_channel_position(fillch,scetfill)
	print*,'fill channel position set to',scetfill

        ok = w_event(tdsch,'TDSF')
        if(IFASTSLOW.NE.0) ok = w_event(tdsch,'TDSS')
	if(ok.eq.82) stop 'end of file on tdsch'
	if (.not. ok) stop 'cannot get tds event'
c	item = 'EVENT_SCET_R8'
c	  ok = w_item_r8(tdsch, item, scet, 2, return_size)
	item = 'EVENT_SCET'
	  ok = w_item_i4(tdsch, item, s_scet, 2, return_size)
	print*,'initial tdsch time',s_scet
c	  scetfill = s_scet(2)
c
        ok = w_event(fillch,'FILL')
	if(ok.eq.82) stop 'end of file on tdsch'
	if (.not. ok) stop 'cannot get fill event'
c	item = 'EVENT_SCET_R8'
c	  ok = w_item_r8(fillch, item, scet, 2, return_size)
	item = 'EVENT_SCET'
	  ok = w_item_i4(fillch, item, s_scet, 2, return_size)
	print*,'initial fillch time',s_scet

c
	ok = w_channel_filename(tdsch,file)
c	print*,file
c
	get_tm_stream = 1
c
c           ok = wind_tm_get_next_event(tdsch,major,minor,'HK')
c	   item = 'TEMP_WAVES2'
c	   ok = wind_tm_get_item(tdsch, item, temp_waves, 1, return_size)
c
C
C	GET NEXT EVENT
C
 110    continue
C
	! this is the main program loop

        if( wind_tm_eof(tdsch,major,minor)) stop 'end of file on tdsch'
        if( wind_tm_eof(fillch,major,minor)) stop 'end of file, fillch'

	type*,'going to get next tds event'

	if(scettds.lt.scetfill) then
	  event = 'TDSF'
	  IF(IFASTSLOW.NE.0)event = 'TDSS'
	  ch = tdsch
	else
	  event = 'FILL'
	  ch = fillch
	endif

	ok = w_event(ch,event)
	   if (.not. ok) then
	      type *, char(7), '******** missing packet in event ********'
	   end if
C
	     item = 'EVENT_SCET'
	     ok = w_item_i4(ch, item, s_scet, 2, return_size)
		ss = mod(s_scet(2),100)
		mm = s_scet(2)/100
		mm = mod(mm,100)
		hh = s_scet(2)/10000
		scett = float(dd) + hh/24. + mm/1440. + ss/86400.
	     if(scettds.lt.scetfill) then
	       scettds = scett
	     else
	       scetfill = scett
	     endif

	     item = 'EVENT_NUMBER'
	     ok = wind_tm_get_item(ch, item, itemp, 1, return_size)
	     TYPE *,itemp,YYYY,MON,DD,IHRMN
		write(26,*) itemp,YYYY,MON,DD,IHRMN
c 1016	   format(I5,'/',I2,'/',I2)
	   ihrmn = 100*hh+mm
	   WRITE(PTITLE(17),1017) s_scet(1)
	   WRITE(PTITLE(18),1018) s_scet(2)/100, MOD(s_scet(2),100)
c	   WRITE(PTITLE(17),1017) ihrmm,ss
 1017	   FORMAT('YMD',I9)
C 1017	   FORMAT(I10.6)
c 1017	   FORMAT('doy ',I3,I5.4)
 1018	   FORMAT(I6.4,I3.2)
	   item = 'CHANNEL'
	   ok = wind_tm_get_item(ch, item, tds_channel, 1, return_size)
	TYPE*,'CHANNEL',tds_channel
	   WRITE(PTITLE(6),1019) TDS_CHANNEL
 1019	   FORMAT('CHANNEL',I2)
	   item = 'EVENT_NUMBER'
	   ok = wind_tm_get_item(ch, item, itemp, 1, return_size)
	   type*,'event number',itemp
	   WRITE(PTITLE(5),1012) ITEMP
 1012	   FORMAT(I10)
c
c	   item = 'SLOW_RX_SPEED'
c	   ok = wind_tm_get_item(ch, item, issps, 1, return_size)
c	   type*,'slow rx speed',issps
c	   item = 'FAST_RX_SPEED'
c	   ok = wind_tm_get_item(ch, item, ifsps, 1, return_size)
c	   type*,'fast rx speed',ifsps
c	   item = 'SLOW_RX_FILTER'
c	   ok = wind_tm_get_item(ch, item, ifils, 1, return_size)
c	   type*,'slow rx filter',ifils
c	   item = 'FAST_RX_FILTER'
c	   ok = wind_tm_get_item(ch, item, ifilf, 1, return_size)
c	   type*,'fast rx filter',ifilf
c	   item = 'SOURCE_CHAN_1'
c	   ok = wind_tm_get_item(ch, item, ichpa(1), 1, return_size)
c	   item = 'SOURCE_CHAN_2'
c	   ok = wind_tm_get_item(ch, item, ichpa(2), 1, return_size)
c	   item = 'SOURCE_CHAN_3'
c	   ok = wind_tm_get_item(ch, item, ichpa(3), 1, return_size)
c	   item = 'SOURCE_CHAN_4'
c	   ok = wind_tm_get_item(ch, item, ichpa(4), 1, return_size)
c	   item = 'SOURCE_CHAN_5'
c	   ok = wind_tm_get_item(ch, item, ichpa(5), 1, return_size)
c	   item = 'SOURCE_CHAN_6'
c	   ok = wind_tm_get_item(ch, item, ichpa(6), 1, return_size)
C
	   WRITE(PTITLE(2),1009)  TDS_CHANNEL
	   ipa = ichpa(tds_channel)
	   WRITE(PTITLE(7),1007) pa(tds_channel,ipa+1)
 1007	   FORMAT('P/A ',A4)
	   IRX = IPACAL(TDS_CHANNEL,IPA+1)
	   IF(TDS_CHANNEL.LE.2) THEN
	      WRITE(PTITLE(9),1004) FSPS(IFSPS+1)
	      SPS = 1000.*FSPS(IFSPS+1)
	      WRITE(PTITLE(11),1008) FFILTER(IFILF+1)
	      IFIL = IFILF
	   ELSE
	      WRITE(PTITLE(9),1008) SSPS(ISSPS+1)
	      SPS = SSPS(ISSPS+1)
	      WRITE(PTITLE(11),1008) SFILTER(IFILS+1)
	      IFIL = IFILS
	   ENDIF
 1004	   FORMAT(F7.2,' kHZ')
 1008	   FORMAT(F7.0,' HZ')
 1009	   FORMAT('TDS CHANNEL',I4)

C
	print*,' call tds_phys,iprocess=',iprocess
	call tds_phys(ch,iprocess,data,spect)
C
c	ITEM = 'DATA'
c	OK = WIND_TM_GET_ITEM(CH,ITEM,NDATA,SIZE,RETURN_SIZE)
c	IF(.NOT.OK) TYPE*,'CANNOT GET ITEM = DATA'
c	  PRINT*,'DATA, SIZE=',RETURN_SIZE
C	  PRINT 222, (NDATA(J),J=1,2048)
c 222	FORMAT(10I6)
c	IF(IPROCESS.EQ.0) THEN
c	  DO IK = 1,2048
c	    NDATA(IK) = NDATA(IK)-128
c	  ENDDO
c	ELSE
c	  DO IK = 1,2048
c	    DATA(IK) = TDSCAL(TDS_CHANNEL,ISPS,NDATA(IK))
c	    NDATA(IK) = NDATA(IK)-128
c	  ENDDO
c	ENDIF
C
C	FIND ZERO CROSSING
C
ce means emergency to try to get the damn thng to run
	IZCNT = 0
ce	DO IL = 1,2047
ce	  IZ = IL
ce	print*,' il',iz
ce	  ilp = max0(il,2)
ce	  IF(NDATA(ILp).EQ.0) PRINT*,'ZERO DATA',ILp,
ce     1   NDATA(ILp-1), NDATA(ILp),NDATA(ILp+1)
C		COUNT ALL CROSSINGS, POS TO NEG AND NEG TO POS
C	  IF(NDATA(IL)*NDATA(IL+1).LE.0) THEN
C	        IZCNT = IZCNT+1
C		S1 = NDATA(IL)
C		S2 = NDATA(IL+1)
C		ZCROSS(IZCNT) = IL + S1/(S1 - S2)
C	  ENDIF
C		COUNT ONLY POS TO NEG
ce	  IF(DATA(IL).GT.0.AND.DATA(IL+1).LE.0) THEN
ce	        IZCNT = IZCNT+1
ce		  S1 = DATA(IL)
ce		  S2 = DATA(IL+1)
ce		ZCROSS(IZCNT) = IL + S1/(S1 - S2)
ce	  ENDIF
ce	ENDDO
ce	DO N = 1,IZCNT-1
ce	  ZINT(N) = ZCROSS(N+1) - ZCROSS(N)
ce	  IF(ZINT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
ce	  IF(ZINT(N).EQ.0.) ZINT(N) = 1.E-6
ce	ENDDO
ce	print*,'zero crossings found',izcnt
ce	print*,'first 5',(zcross(kk),kk=1,5)
C
	IF(IPROCESS.EQ.2) THEN
	TYPE*,'TDSTEST'
	TYPE*,(DATA(I),I=1,10)
	TYPE*,(DATA(I),I=2040,2049)
	     CALL SPPLOT(-2,SPECT)
	ENDIF
C
 20	CONTINUE
C
 1003	FORMAT(3(I9,E11.3,I5))
C

	CALL PLTDSFR(-2)
	IF(IPROCESS.LE.1) CALL DETAIL(-2,900,1100)
	CALL DETAIL(-2,900,1100)
	NPLOTS=NPLOTS+1
	IF(NPLOTS.LT.NREM) GO TO 110
	STOP
	END
	SUBROUTINE PLTDSFR(ITERM)
C
C	PLOT TDS DATA AND FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	COMMON /HEADBL/ TITLE,EVENT
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2060),DATA(2050)
	COMMON /PLOTDT/ SPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
C
	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PSDEF,PYDEF,COFF,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PI,USERVAR(10),AUTODOT
	INTEGER*4 LX1,LX2,LY1,LY2,LTYPE,LWEIGHT,NUMDEV
C
	DIMENSION YY(2048),PP(2048)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PLOT TDS DATA
C
	XEND = 2750.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,1100.,XEND,2230.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C	  CALL MGOPUTLABEL(53,STR,9)
c	  WRITE(STR,704) SAA()
c 704	  FORMAT('\\tSOLAR ASPECT',F6.1,' DEG.')
c	  CALL MGOPUTLABEL(55,STR,9)
	  CALL MGOSETEXPAND(1.)
C
	IF(IPROCESS.EQ.0) THEN
	  DO N = 1,2048
  	    PP(N) = N
	    YY(N) = NDATA(N)
	  ENDDO
	ELSE
	  YMAX = 0.
	  DO N = 1,2048
  	    PP(N) = N
	    YY(N) = DATA(N)
	    YMAX = AMAX1(YY(N),YMAX)
	    YMAX = AMAX1(-YY(N),YMAX)
	  ENDDO
	ENDIF
C
	PRINT*,'MAX VOLTS',YMAX
	IF(IPROCESS.EQ.0) THEN
		CALL MGOTICKSIZE(0.,0.,5.6,28.)
		CALL MGOSETLIM(-2.,-130.,2050.,130.)
	ELSE
		CALL MGOSETLIM(-2.,-YMAX,2050.,YMAX)
	ENDIF
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,2048)
	CALL MGOSETEXPAND(.8)
	CALL MGOBOX(0,2)
	IF(IPROCESS.EQ.0) THEN
		CALL MGOYLABEL(14,'T/M NUMBER-128')
	ELSE
		CALL MGOYLABEL(14,'VOLTS or nT')
	ENDIF
	CALL MGOSETEXPAND(1.)
	TRANGE = GY2-GY1
	TINC = .08*TRANGE
	XTITLE = GX2 +.005*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSPRO')
	CALL MGOSETEXPAND(1.)
C
C	PLOT FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C		OR 1./INT FOR POS TO NEG
C
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,200.,XEND,1050.)
	ENDIF
	SPSKHZ = .001*SPS
	YMIN = .5*SPSKHZ
	YMAX = 0.
	PRINT*,'IZCNT',IZCNT
	DO N = 1,IZCNT-1
	IF(ZINT(N).EQ.0.) PRINT*,'IN PLOT, ZINT=0 AT',N
C	  YY(N) = .5*SPSKHZ/ZINT(N)
	  YY(N) = SPSKHZ/ZINT(N)
	  PP(N) = .5*(ZCROSS(N)+ZCROSS(N+1))
	  YMIN = AMIN1(YY(N),YMIN)
	  YMAX = AMAX1(YY(N),YMAX)
	ENDDO
  	YMAX = AMIN1(.5*SPSKHZ,1.1*YMAX)
	PRINT*,'YMIN,YMAX',YMIN,YMAX
	CALL MGOSETEXPAND(.8)
	CALL MGOSETLIM(-2.,YMIN,2050.,YMAX)
	CALL MGOTICKSIZE(0.,0.,0.,0.)
	CALL MGOCONNECT(PP,YY,IZCNT-1)
	CALL MGOBOX(1,2)
	CALL MGOXLABEL(10,'SAMPLE NO.')
	CALL MGOYLABEL(10,'FREQ (kHZ)')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	  NPLOTS = NPLOTS + 1
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END
	SUBROUTINE DETAIL(ITERM,N1,N2)
C
C	PLOT TDS DATA AND FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	COMMON /HEADBL/ TITLE,EVENT
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2060),DATA(2050)
	COMMON /PLOTDT/ SPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
C
	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PSDEF,PYDEF,COFF,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PI,USERVAR(10),AUTODOT
	INTEGER*4 LX1,LX2,LY1,LY2,LTYPE,LWEIGHT,NUMDEV
C
	DIMENSION YY(2048),PP(2048)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PLOT TDS DATA
C
	XEND = 2750.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,400.,XEND,2230.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C	  CALL MGOPUTLABEL(53,STR,9)
c	  WRITE(STR,704) SAA()
c 704	  FORMAT('\\tSOLAR ASPECT',F6.1,' DEG.')
c	  CALL MGOPUTLABEL(55,STR,9)
	  CALL MGOSETEXPAND(1.)
C
	DO N = N1,N2
	  NP = N
	  PP(N) = N
	  YY(N) = NDATA(N)
	ENDDO
C
	CALL MGOTICKSIZE(0.,0.,5.6,28.)
	XN1 = N1-2
	XN2 = N2+2
	CALL MGOSETLIM(XN1,-130.,XN2,130.)
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,NP)
	CALL MGOPOINTS(60.,1,PP,YY,NP)
	CALL MGOSETEXPAND(.8)
	  CALL MGOBOX(1,2)
	  CALL MGOYLABEL(14,'T/M NUMBER-128')
	  CALL MGOSETEXPAND(1.)
	TRANGE = GY2-GY1
	TINC = .04*TRANGE
	XTITLE = GX2 +.005*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSPRO')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	  NPLOTS = NPLOTS + 1
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END
	SUBROUTINE SPPLOT(ITERM,SPECT)
C
C	PLOT TDS DATA AND FREQUENCY = .5/(INTERVAL BETWEEN ZEROS)
C
	CHARACTER*12 TITLE(20)
	CHARACTER*120 STR
	CHARACTER*4 EVENT
	COMMON /HEADBL/ TITLE,EVENT
	COMMON /PLTBLK/ IZCNT,IPROCESS,ZCROSS(2048),ZINT(2048),
     1   NDATA(2060),DATA(2050)
	COMMON /PLOTDT/ SPS
	COMMON /STATUS/ FFILTER(4),SFILTER(4),FSPS(4),SSPS(4)
	common /headblk/ major,minor,tds_channel,s_scet
C
	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PSDEF,PYDEF,COFF,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PI,USERVAR(10),AUTODOT
	INTEGER*4 LX1,LX2,LY1,LY2,LTYPE,LWEIGHT,NUMDEV
C
	DIMENSION YY(2048),PP(2048),SPECT(1500)
C
	CALL MGOINIT
	CALL MGOSETUP(ITERM)
	CALL MGOERASE
C
C	PLOT TDS DATA
C
	XEND = 2750.
	IF(ITERM.LT.0) THEN
	  CALL MGOSETLOC(300.,400.,XEND,2230.)
	ENDIF
C
	  CALL MGOSETEXPAND(.85)
	  IF(ITERM.GT.0) THEN
	    CALL MGOGRELOCATE(10.,0.)                      ! maxch, crt
	  ELSE
	    CALL MGOGRELOCATE(400.,50.)                      ! hardcopy
	  ENDIF
C
	  CALL MGOSETEXPAND(1.)
C
	N1 = 3
	N2 = 2048
	YMAX = -500.
	YMIN =  500.
	XMAX = 0.
	SPSUSE = SPS
	IF(FFT_CHANNEL.LE.2) SPSUSE = .001*SPS
	DO NP = 1,1024
C	  NP = (N-1)/2
	  PP(NP) = (NP-1)*SPSUSE/2048.
	  YY(NP) = SPECT(NP)
	  XMAX = AMAX1(XMAX,PP(NP))
	  YMAX = AMAX1(YMAX,YY(NP))
	  YMIN = AMIN1(YMIN,YY(NP))
	ENDDO
C
	PRINT*,'YMAX,YMIN',YMAX,YMIN
C	CALL MGOTICKSIZE(10.,10.,5.6,28.)
	XN1 = N1-2
	XN2 = N2+2
	YRANGE = YMAX-YMIN
	YMAX = YMAX + .05*RANGE
	YMIN = YMIN - .05*RANGE
	CALL MGOSETLIM(0.,YMIN,XMAX,YMAX)
c	CALL MGOGRID(0)
C	CALL MGOSETLTYPE(1)
c	CALL MGOGRID(1)
	CALL MGOSETLTYPE(0)
	CALL MGOSETEXPAND(.6)
	CALL MGOCONNECT(PP,YY,NP)
	CALL MGOPOINTS(60.,1,PP,YY,NP)
	CALL MGOSETEXPAND(.8)
	CALL MGOBOX(1,2)
	CALL MGOYLABEL(14,'POWER, DB')
	IF(FFT_CHANNEL.GT.2) CALL MGOXLABEL(9,'FREQ, HZ')
	IF(FFT_CHANNEL.LE.2) CALL MGOXLABEL(9,'FREQ, kHZ')
	CALL MGOSETEXPAND(1.)
	TRANGE = GY2-GY1
	TINC = .04*TRANGE
	XTITLE = GX2 +.005*(GX2-GX1)
	YTITLE = GY2
	CALL MGOSETEXPAND(.8)
	AVRFREQ=0.
	IF(IZCNT.GT.1) THEN
	  AVRPER = (ZCROSS(IZCNT)-ZCROSS(1))/(IZCNT-1)
	  AVRFREQ = .001*SPS/AVRPER
	ENDIF
	TITLE(19) = 'AVR.FREQ.'
	WRITE(TITLE(20),1020) AVRFREQ
 1020	FORMAT(F8.2,' kHZ')
	DO N = 1,20
	  YTITLE = YTITLE - TINC
	  IF(N.EQ.4) YTITLE = YTITLE - TINC
	  IF(N.EQ.6) YTITLE = YTITLE - TINC
	  CALL MGOGRELOCATE(XTITLE,YTITLE)
	  CALL MGOLABEL(12,TITLE(N))
	ENDDO
	CALL MGOSETEXPAND(1.)
	CALL MGOSETEXPAND(.8)
	CALL MGOPLOTID(EVENT,'[.WIND]TDSPRO')
	CALL MGOSETEXPAND(1.)
C
	IF(ITERM.LT.0) THEN
	  CALL MGOPRNTPLOT(NVEC)
	  PRINT*,' NO. VECTORS PLOTTED',NVEC
	  NPLOTS = NPLOTS + 1
	ELSE
	  CALL MGOTCLOSE
	ENDIF
C
	RETURN
C
	END
	options/extend_source
!------------------------------------------------------------------------------
	integer*4	function	get_stream_name(stream)
! This routine gets the user's TM stream type specification.
!
	implicit	none
	character*(*)	stream
	common /nrblk/ nrem,NHRMN,IFASTSLOW
	integer*4	iq,NREM,NHRMN,IFASTSLOW

10	  write(6,6)
	  read(5,5,err=10,end=20) iq, stream

 	if (iq .lt. 1) then
	   stream = 'offline'
	else if (stream(1:1) .eq. 'o' .or. stream(1:1) .eq. 'O') then
	   stream = 'offline'
	else if (stream(1:1) .eq. 'r' .or. stream(1:1) .eq. 'R') then
	   stream = 'realtime'
	else
	   ! assume the user entered the name of an offline file
	end if

	get_stream_name = 1

 20	return
c
  5	format(q,a)
  6	format(1x,'Enter TM stream type [O=offline (default), R=realtime ]: ',$)
c
	end


      subroutine tdlat(latt,ls,le,pos,posa,
     1                                icomp,patt,exist,lfnd)
      use tfstk
      use ffs
      use tffitcode
      use ffs_pointer, only:pnamec,lpnamec,idtypec,idvalc
      implicit real*8 (a-h,o-z)
      parameter (dh=.08,qh=.8,bh=.4,sh=.6,ch=.3,oh=.2,width=.2d0)
      real*4 xc,yc,dx,dy,xs
      integer*8 latt(nlat)
      dimension pos(nlat),posa(nlat),icomp(nlat)
      dimension height(7)
      logical tmatch,exist,fin
      character*8 name
      character*(*) patt
      data height /dh,bh,dh,qh,dh,sh,ch/
      exist=.false.
      if(ls.gt.le) then
        call tmov(pos(ls),posa(ls),nlat-ls+1)
        do 20 i=1,min(le+1,nlat)
20        posa(i)=pos(i)+pos(nlat)
      else
        call tmov(pos(ls),posa(ls),le-ls+1)
      endif
      xlen=posa(le)-posa(ls)
      write(lfnd,*)
     1'SET WINDOW X 2.5 11.0 Y 1.30 2.2'
      write(lfnd,*)
     1'SET LIMITS X ',sngl(posa(ls)),sngl(posa(le)),' Y -1 1'
      write(lfnd,*)
     1'SET OUTLINE ALL OFF;SET TICK ALL OFF;SET LABEL ALL OFF'
      write(lfnd,*)
     1'SET TITLE SIZE -1.6'
      xscale=8.5d0/xlen
      yscale=0.90d0/2.d0
      pa=posa(ls)
      ps=-width/xscale
      istart=ls
      if(ls.gt.le) then
        iend=nlat-1
      else
        iend=le-1
      endif
      do i=istart,iend
        if(idtypec(i) .eq. icMARK)then
          posa(i)=posa(i-1)
        endif
      enddo
      fin=.false.
11    do 10 i=istart,iend
        id=idtypec(i)
        if(id .ge. 41)then
          go to 12
        endif
        if(id .eq. 19)then
          yc=0.d0
          dy=height(2)*2.d0*yscale
        elseif(id .eq. 31)then
          yc=0.d0
          dy=height(7)*2.d0*yscale
        elseif(id .eq. icmult)then
          yc=sign(height(4)-oh,rlist(latt(i)+13))*.5d0
          dy=(height(4)+oh)*yscale
        elseif(icomp(i) .eq. 0 .or. id .eq. 1 .or.
     1          id .gt. icdodeca)then
          yc=0.d0
          dy=dh*2.d0*yscale
        else
          yc=sign(height(min(id,6))-oh,rlist(latt(i)+2))*.5d0
          dy=(height(min(id,6))+oh)*yscale
        endif
 12     if(kytbl(kwL,id) .gt. 0)then
          al=rlist(latt(i)+kytbl(kwL,id))
        else
          al=0.d0
        endif
        xc=pa+al*.5d0
        dx=al*xscale
        if( tmatch(pnamec(i),patt) )then
          exist=.true.
          ln=min(8,lene(pnamec(i)))
          name=' '
          name(9-ln:8)=pnamec(i)
c          xs=max(xc,REAL(ps))
          xs=REAL(ps)
          xs=max(xc,xs)
          if(xs .lt. posa(i+1)+width/xscale)then
            write(lfnd,9002)
     1      'TITLE ',xs,' 0.4  XDATA ANGLE 90 ''',name,''''
9002        format(1x,a,1p,g14.6,a,a,a)
            ps=xs+width/xscale
          endif
        endif
        if(id .ne. icMARK)then
          pa=max(pa+al,posa(i+1))
c     write(*,*)'tdlat ',pnamec(i),xc,yc,dx,dy
          write(lfnd,9001)
     1         'BOX ',xc,yc,' DATA SIZE ',dx,dy
 9001     format(1x,a,1p,2g14.6,a,2g14.6)
        endif
10    continue
      if(fin) return
      if(le.lt.ls) then
        istart=1
        iend=le-1
        fin=.true.
        goto 11
      endif
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine thermocal: calculate partition function and with it
!           thermodynamical properties
!
!     part of QMDFF
!

SUBROUTINE THERMOCAL(A,B,C,avmom, &
   &       LINEAR,ATOM,SYM,WT,VIBS,NVIBS,ESCF, &
   &       tempinput,sthr,et,g298,ts,zp)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DIMENSION VIBS(*)
LOGICAL::LINEAR,ATOM,pr
!
!     THE FOLLOWING CONSTANTS ARE NOW DEFINED:
!          PI  = CIRCUMFERENCE TO DIAMETER OF A CIRCLE
!          R   = GAS CONSTANT IN CALORIES/MOLE
!          H   = PLANCK'S CONSTANT IN ERG-SECONDS
!          AK  = BOLTZMANN CONSTANT IN ERG/DEGREE
!          AC  = SPEED OF LIGHT IN CM/SEC
!
PI =3.14159D0
R=1.98726D0
H=6.626176D-27
AK=1.3807D-16
AC=2.99792458D+10
siK=1.38066D-23
siH=6.626076D-34
siNA=6.022137D+23

pr=.false.

T=tempinput
!
!   ***   INITIALISE SOME VARIABLES   ***
!
C1=H*AC/AK/T
QV=1.0D0
HV=0.0D0
E0=0.0D0
CPV=0.0D0
SV=0.0D0
ZP =0.0D0
!
!   ***   CONSTRUCT THE FREQUENCY DEPENDENT PARTS OF PARTITION FUNCTION
!
DO 50 I=1,NVIBS
   WI=VIBS(I)
   ZP=ZP+WI*1.4295718D-3
   EWJ=EXP(-WI*C1)
   QV=QV/(1-EWJ)
   HV=HV+WI*EWJ/(1.-EWJ)
   E0=E0+WI
   CPV=CPV+WI*WI*EWJ/(1.-EWJ)/(1.-EWJ)
!
!     replace low-lying vibs for S by rotor approx.
!              E in J (wi in cm-1)
!
   e=(1.d-14+wi)*0.01196266D+3/siNA
!
!     mom of intertia corresponding to the rotor with frequency wi
!
   xxmom=(siH/(2.0d0*PI))**2.0d0/(2.0d0*e)
!
!     write(*,*) xxmom,avmom,xxmom*avmom/(xxmom+avmom)
!     this reduced moment limits the rotational moment of
!     inertia for this vib to that of the total molecule
!     rotation/3
!
   xmom=xxmom*avmom/(xxmom+avmom)
!
!     free rotor entropy
!     Cramer, page 328 for one degree of freedom or
!     http://cccbdb.nist.gov/thermo.asp, eq. 35, sigma=1
!
   SV3=R*(0.5d0+LOG(SQRT(8.*PI**3.*XMOM*siK*T)/siH))
!
!     harm. osc. entropy
!
   if(wi.gt.0)then
      SV1=LOG(1.0D0-EWJ)
      SV2=WI*EWJ/(1.0d0-EWJ)
   else
      SV1=0
      SV2=0
   end if
!
!     fermi weigthing
!     wofrot=1./(1.+exp( (wi-sthr)/20.0 ) )
!     Head-Gordon weighting
!
   wofrot=1-1./(1.+(sthr/(wi+1.d-14))**4.0)
   if (sthr.lt.0) wofrot=0.0d0
   SV=SV+(1.-wofrot)*(SV2*R*C1-R*SV1)+wofrot*SV3
   if (wi.lt.300.and.pr) &
      &    write(10,'(''omega='',F6.2,5x,''Svib='',F10.3, &
      &       5x,''Srot='',F10.3,5x,''Sused='',F10.3)') &
      &       wi,(SV2*R*C1-R*SV1)*t/1000.,SV3*t/1000., &
      &       t*((1.-wofrot)*(SV2*R*C1-R*SV1)+wofrot*SV3)/1000.
50    CONTINUE
!
!   ***   FINISH CALCULATION OF VIBRATIONAL PARTS   ***
!
HV=HV*R*H*AC/AK
E0=E0*1.4295D0
CPV=CPV*R*C1*C1
!   ***   NOW CALCULATE THE ROTATIONAL PARTS  (FIRST LINEAR MOLECULES
IF (ATOM       ) GOTO 70
IF (.NOT.LINEAR) GOTO 60
QR=1/(C1*A*SYM)
HR=R*T
CPR=R
SR=R*(LOG(T*AK/(H*AC*A*SYM)))+R
GOTO 70
60  QR=SQRT(PI/(A*B*C*C1*C1*C1))/SYM
HR=3.0D0*R*T/2.0D0
CPR=3.0D0*R/2.0D0
SR=0.5D0*R*(3.D0*LOG(T*AK/(H*AC)) &
    &  -2.D0*LOG(SYM)+LOG(PI/(A*B*C))+3.D0)
70    CONTINUE
!
!   ***   CALCULATE INTERNAL CONTRIBUTIONS   ***
!
QINT=QV*QR
HINT=HV+HR
CPINT=CPV+CPR
SINT=SV+SR
!
!   ***   CONSTRUCT TRANSLATION CONTRIBUTIONS   ***
!
QTR=(SQRT(2.D0*PI*WT*T*AK*1.6606D-24)/H)**3
!
!     this is 3/2RT+PV=5/2RT
!
HTR=5.0D0*R*T/2.0D0
CPTR=5.0D0*R/2.0D0
STR=2.2868D0*(5.0D0*LOG10(T)+3.0D0*LOG10(WT))-2.3135D0
!
!   ***   CONSTRUCT TOTALS   ***
!
CPTOT=CPTR+CPINT
STOT=STR+SINT
HTOT=HTR+HINT

autokcal=627.509541
autokj  =2625.49
caltoj  =autokj/autokcal

!if (pr)then
   write(10,*)
   WRITE(10,'('' Calculated thermodynamic properties: '')')
   write(10,*) "-------------------------------------------", &
           & "------------------------"
   WRITE(10,'(''   T (K)   part. function  '', &
      & ''    enthalpy   heat capacity  entropy'')')
   WRITE(10,'(  ''                             '', &
      & ''   cal/mole    cal/K/mol   cal/K/mol'')')
   write(10,*) "-------------------------------------------", &
           & "------------------------"
   WRITE(10,'(f7.2,''  vib.'',G15.4 &
      & , 2X,3F11.5        )')T,QV,  HV,  CPV,  SV
   WRITE(10,'(7X,''  rot.'',G13.3 &
      &  ,2X,3F11.3        )')      QR,  HR,  CPR,  SR
   WRITE(10,'(7X,''  int.'',G13.3 &
      &  ,2X,3F11.3        )')      QINT,HINT,CPINT,SINT
   WRITE(10,'(7X,''  tra.'',G13.3 &
      &  , 2X,3F11.3)') QTR, HTR, CPTR, STR
   WRITE(10,'(7X,''  tot.'',13X,3x  ,F11.4,3F11.4)') &
      &   HTOT,CPTOT,STOT
   write(10,*) "-------------------------------------------", &
           & "------------------------"
!end if

ht=htot/1000.
et=ht+zp
ts=stot*t/1000.

g298=et-ts

!if (pr) then
   write(10,*)
   write(10,*) "-------------------------------------------", &
           & "----------------"
   WRITE(10,'(20x,''[au]       [kcal/mol]        [kJ/mol]'')')
   write(10,*) "-------------------------------------------", &
           & "----------------"
   WRITE(10,'('' ZPVE        '',3G16.6)')zp/autokcal,zp,zp*caltoj
   WRITE(10,'('' H(0)-H(T)+PV'',3G16.6)')ht/autokcal,ht,ht*caltoj
   write(10,*) "--------------------------------------------", &
       &     "----------------"
   WRITE(10,'('' H(T)        '',3G16.6)')et/autokcal,et,et*caltoj
   WRITE(10,'('' T*S         '',3G16.6)')ts/autokcal,ts,ts*caltoj
   WRITE(10,'('' G(T)        '',3G16.6)')g298/autokcal,g298,g298*caltoj
   write(10,*) "--------------------------------------------", &
       &     "----------------"

!end if

return
end subroutine thermocal


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ff_nonb: calculate the nonbonded part of energy and gradient of the FF
!
!     part of QMDFF
!
subroutine ff_nonb(n,at,xyz,q,r0ab,zab,r0094,sr42,c66ab,enb,g)
use qmdff
use debug
implicit none
integer n,at(*)
real(kind=8)::xyz(3,n),enb,g(3,n),q(n)
real(kind=8)::r0ab(94,94),zab(94,94),r0094(94,94),sr42(94,94),c66ab(n,n)

integer::i1,i2,iz1,iz2,k,nk,i,j
real(kind=8)::r2,r,r4,r6,r06,R0,t6,t8,c6t6,c6t8,t27,drij,e
real(kind=8)::dx,dy,dz,c6,x,alpha,oner,aa,damp,damp2,e0
!  for smooth cutoff
real(kind=8)::switch,exp_switch
!  for the Ewald summation
real(kind=8)::k_ew_cut  ! adjustable scaling parameters
real(kind=8)::f12,erfterm
real(kind=8)::medium
real(kind=8)::de,dedx,dedy,dedz
real(kind=8)::r_ewald
real(kind=8)::e_ew  ! the Ewald sum Coulomb energy
real(kind=8)::de_ew(3,n)  ! the Ewald sum Coulomb gradient
real(kind=8)::e_rec ! the reciprocal Ewald Coulomb energy
real(kind=8)::de_rec(3,n)  ! the reciprocal Ewald sum Coulomb gradient
real(kind=8)::xd,yd,zd  ! cell dipole correction
real(kind=8)::e_local,r_buf,r_buf2
real(kind=8)::fs_par,term
real(kind=8)::bohr
real(kind=8)::e_brute ! energy of the brute force Ewald method
integer::nbox,xbox,ybox,zbox  ! for brute force Ewald
integer::nbox_sq,rbox,rbox_sq
real(kind=8),allocatable::pot_shell(:)  ! energy for shells
real(kind=8)::rbox_vec(3)
!   The newly added gradient components
real(kind=8)::g_local_a(3),g_local_b(3)
real(kind=8)::vab(3)  ! for periodic image calculation

bohr=0.52917721092d0
e=0.d0
!
!     if no nonbonded terms are existent
!
if (nnci.le.1 .and. nmols.eq.0) return
!
!     For nonperiodic systems, set the VDW cutoff always to 10 Angstroms
!
if (.not. periodic) then
   vdw_cut=10.d0/bohr
end if
!
!     loop over dispersion/Lennard-Jones energy terms
!
do k=1,nnci
   i1=nci(1,k)
   i2=nci(2,k)
   nk=nci(3,k)
   vab=xyz(1:3,i1)-xyz(1:3,i2)
!
!     apply periodic boundaries, if needed
!
   if (periodic) then
      call box_image(vab)
   end if

   r2=dot_product(vab,vab)

   r =sqrt(r2)

!
!     only proceed if the distance is below the cutoff
!
   if (periodic .and. r .gt. vdw_cut) then
      cycle
   end if
   oner =1.0d0/r

   iz1=at(i1)
   iz2=at(i2)
   R0=r0094(iz1,iz2)
   c6=c66ab(i2,i1)

   r4=r2*r2
   r6=r4*r2
   r06=R0**6
   t6=r6+r06
   t8=r6*r2+r06*R0*R0
   c6t6=c6/t6
   c6t8=c6/t8
   t27=sr42(iz1,iz2)*c6t8
   e0=c6t6+t27
   e=e-e0*eps2(nk)
!   write(*,*) "e",e,r,k,i1,i2,e0,eps2(nk),nk

   drij=eps2(nk)*(c6t6*6.0d0*r4/t6+8.0d0*t27*r6/t8)

!
!     determine gradient vector entries
!
   g_local_a(1:3)=vab(1:3)*drij

   if (r .lt. 25) then
      x    =zab(iz1,iz2)
      alpha=r0ab(iz1,iz2)
      t27  =x*dexp(-alpha*r)
      e0   =t27*oner
      e    =e + e0*eps2(nk)
      drij=eps2(nk)*t27*(alpha*r+1.0d0)*oner/r2
      g_local_a(1:3)=g_local_a(1:3)-vab(1:3)*drij
   end if

   g(1:3,i1)=g(1:3,i1)+g_local_a(1:3)
   g(1:3,i2)=g(1:3,i2)-g_local_a(1:3)

!
!     the components of the virial tensor, if needed
!
   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)
      vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)
      vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)
      vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)
      vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)
      vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)
      vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)
      vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)
      vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)
   end if

end do

!
!    Add a second component for the inter-molecule interaction for solvent QMDFFs
!
if (nmols .gt. 1) then
!
!    Loop over all atoms and calculate all Van der Waals and Coulomb terms to all atoms
!    of other molecules
!
   do i=1,n-1   ! Loop to n or n-1?
      do j=i+1,n
         if (molnum(i) .ne. molnum(j)) then
            i1=i
            i2=j

            vab=xyz(1:3,i1)-xyz(1:3,i2)
!
!     apply periodic boundaries, if needed
!
            if (periodic) then
               call box_image(vab)
            end if

            r2=dot_product(vab,vab)

            r =sqrt(r2)
!
!     only proceed if the distance is below cutoff
!
            if (periodic .and. r .gt. vdw_cut) cycle

            oner =1.0d0/r

            iz1=at(i1)
            iz2=at(i2)
!
!     If noncovalent parameters were optimized separately, apply the factors
!
            if (ff_mod_noncov) then
               R0=r0094(iz1,iz2)*mn_par((i-1)*7+2)*mn_par((j-1)*7+2)
               c6=c66ab(i2,i1)*mn_par((i-1)*7+3)*mn_par((j-1)*7+3)
               r4=r2*r2
               r6=r4*r2
               r06=R0**6
               t6=r6+r06
               t8=r6*r2+r06*R0*R0
               c6t6=c6/t6
               c6t8=c6/t8
               t27=sr42(iz1,iz2)*c6t8*mn_par((i-1)*7+4)*mn_par((j-1)*7+4)
            else
               R0=r0094(iz1,iz2)
               c6=c66ab(i2,i1)
               r4=r2*r2
               r6=r4*r2
               r06=R0**6
               t6=r6+r06
               t8=r6*r2+r06*R0*R0
               c6t6=c6/t6
               c6t8=c6/t8
               t27=sr42(iz1,iz2)*c6t8
            end if
            e0=c6t6+t27
            e=e-e0
            drij=(c6t6*6.0d0*r4/t6+8.0d0*t27*r6/t8)

!
!     determine gradient vector entries
!
            g_local_a(1:3)=vab(1:3)*drij

!
!    Van der Waals energy: only, if distance is below the 25 bohr cutoff!
!
            if (r .lt. 25) then
               if (ff_mod_noncov) then
                  x    =zab(iz1,iz2)*mn_par((i-1)*7+5)*mn_par((j-1)*7+5)
                  alpha=r0ab(iz1,iz2)*mn_par((i-1)*7+6)*mn_par((j-1)*7+6)
               else
                  x    =zab(iz1,iz2)
                  alpha=r0ab(iz1,iz2)
               end if
               t27  =x*dexp(-alpha*r)
               e0   =t27*oner
               e    =e + e0
               drij=t27*(alpha*r+1.0d0)*oner/r2
               g_local_a(1:3)=g_local_a(1:3)-vab(1:3)*drij
            end if
!            write(*,*) "eges",e

            g(1:3,i1)=g(1:3,i1)+g_local_a(1:3)
            g(1:3,i2)=g(1:3,i2)-g_local_a(1:3)

!
!     the components of the virial tensor, if needed
!
            if (calc_vir) then
               vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)
               vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)
               vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)
               vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)
               vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)
               vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)
               vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)
               vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)
               vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)
            end if
         end if
      end do
   end do
end if
!
!     The Coulomb energy: Do usual summation for nonperiodic system over
!      QMDFF and (if existent) multi-molecule parts
!
ewald=.false.
if (.not. ewald) then
   do k=1,nnci
      i1=nci(1,k)
      i2=nci(2,k)
      nk=nci(3,k)

      vab=xyz(1:3,i1)-xyz(1:3,i2)
!
!     apply periodic boundaries, if needed
!
      if (periodic) then
         call box_image(vab)
      end if

      r2=dot_product(vab,vab)

      r =sqrt(r2)
!
!     For periodic systems: proceed only for distances below cutoff
!      for distances between cutoff and lower cutoff, perform a
!      switching function approach
!
      switch=1.d0
      if (periodic) then
         if (r .gt. coul_cut) cycle
         if (.not. zahn) then
            if (r .gt. cut_low) then
               switch=exp_switch(cut_low,coul_cut,r)
            end if
         end if
      end if

      oner =1.0d0/r
!
!     Use the Zahn smooth cutoff method, if ordered
!
      if (zahn) then
         e0=q(i1)*q(i2)*((erfc(zahn_a*r)*oner)-zahn_par*(r-coul_cut))
      else
         e0=q(i1)*q(i2)*oner*eps1(nk)*switch
      end if
      e=e+e0
      drij=e0/r2

      g_local_a(1:3)=-vab(1:3)*drij

      g(1:3,i1)=g(1:3,i1)+g_local_a(1:3)
      g(1:3,i2)=g(1:3,i2)-g_local_a(1:3)

!
!     the components of the virial tensor, if needed
!
!
!     the components of the virial tensor, if needed
!
      if (calc_vir) then
         vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)
         vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)
         vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)
         vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)
         vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)
         vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)
         vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)
         vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)
         vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)
      end if

   end do

!
!    Add a second component for the inter-molecule interaction for solvent QMDFFs
!
!   e=0
   if (nmols .gt. 1) then

      do i=1,n-1
         do j=i+1,n
            if (molnum(i) .ne. molnum(j)) then
               i1=i
               i2=j

               vab=xyz(1:3,i1)-xyz(1:3,i2)
!
!     apply periodic boundaries, if needed
!
               if (periodic) then
                  call box_image(vab)
               end if

               r2=dot_product(vab,vab)

               r =sqrt(r2)
!
!     For periodic systems: proceed only for distances below cutoff
!
               switch=1.d0
               if (periodic) then
                  if (r .gt. coul_cut) cycle
                  if (.not. zahn) then
                     if (r .gt. cut_low) then
                        switch=exp_switch(cut_low,coul_cut,r)
                     end if
                  end if
               end if

               oner =1.0d0/r

!
!     Use the Zahn smooth cutoff method, if ordered
!
               if (zahn) then
                  e0=q(i1)*q(i2)*((erfc(zahn_a*r)*oner)-zahn_par*(r-coul_cut))
               else
                  e0=q(i1)*q(i2)*oner*switch
                  write(*,*) "e01",e0
               end if

!
!     If local optimization of parameters was done
!
               if (ff_mod_noncov) then
                  e0=e0*mn_par(1)*mn_par(1)
               end if
               e=e+e0

               drij=e0/r2

               g_local_a(1:3)=-vab(1:3)*drij

               g(1:3,i1)=g(1:3,i1)+g_local_a(1:3)
               g(1:3,i2)=g(1:3,i2)-g_local_a(1:3)

!
!     the components of the virial tensor, if needed
!
!
!     the components of the virial tensor, if needed
!
               if (calc_vir) then
                  vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)
                  vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)
                  vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)
                  vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)
                  vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)
                  vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)
                  vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)
                  vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)
                  vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)
               end if
            end if
         end do
      end do
   end if
!
!     The Coulomb energy: for a periodic system, apply the particle mesh
!      Ewald summation technique!
!     Implemented is the Smooth Particle Mesh Ewald Method according to
!      J. Chem. Phys. 103, 8577 (1995)
!
else if (ewald) then
!
!     Recalculate the different adjustable parameter, mainly for scaling
!     and accuracy
!
!   if (n .lt. 200) then
!      a_ewald=spi*(trtf*200/volbox**2)**(1d0/6d0)
!   else
!      a_ewald=spi*(trtf*n/volbox**2)**(1d0/6d0)
!   end if

!   r_ew_cut=sqrt_p/a_ewald
!   k_ew_cut=2d0*sqrt_p*a_ewald
   coul_cut=r_ew_cut**2

   if (r_ew_cut .gt. min(boxlen_x2,boxlen_y2,boxlen_z2)) then

      write(*,*) "The Ewald cutoff distance is larger than the half of the "
      write(*,*) "periodic box! This would cause problems!"
      write(*,'(a,f14.7,a,f14.7)') " Half of periodic box: ",boxlen_x2*0.52917721092d0, &
              & " Ewald cutoff: ",r_ew_cut*0.52917721092d0
      write(*,*) "Increase the system size or decrease the Ewald accuracy!"
      call fatal
   end if

!
!     Reset the values of Ewald energy and gradient
!
   e_ew=0.d0
   do i=1,n
      de_ew(1,i)=0.d0
      de_ew(2,i)=0.d0
      de_ew(3,i)=0.d0
   end do

!
!     Auxiliary parameter
!
   fs_par=-a_ewald/spi
   write(*,*) "fspar",fs_par
!
!     Calculate the Ewald self-energy term over all charges/atoms
!     --> constant term, no derivative!
!
   do i=1,n
      e_ew=e_ew - fs_par*q(i)**2
    end do

   write(*,*) "self enrergy",e_ew
!
!     Compute the cell dipole boundary correction term
!     --> not needed for usual Ewald sums..
!
!   xd = 0.0d0
!   yd = 0.0d0
!   zd = 0.0d0
!   do i = 1, n
!      xd = xd + q(i)*xyz(1,i)
!      yd = yd + q(i)*xyz(2,i)
!      zd = zd + q(i)*xyz(3,i)
!   end do
!   term = (2.0d0/3.0d0) * (pi/volbox)
!   e_ew = e_ew + term * (xd*xd+yd*yd+zd*zd)

   do i = 1, n
      de = 2.0d0 * term * q(i)
      dedx = de * xd
      dedy = de * yd
      dedz = de * zd
      de_ew(1,i) = de_ew(1,i) + dedx
      de_ew(2,i) = de_ew(2,i) + dedy
      de_ew(3,i) = de_ew(3,i) + dedz
   end do

 !  write(*,*) "energy dop",e_ew
!
!     Compute the reciprocal space Ewald energy and gradient
!     In a separate subroutine for the full system of interest!
!
   call ewald_recip(n,xyz,q,e_rec,de_rec)
   write(*,*) "after rec",e_rec

!
!     Compute the real space Ewald energy and gradient for the
!     local intramolecule interactions
!
!   e_ew=0
   do k=1,nnci
      i1=nci(1,k)
      i2=nci(2,k)
      nk=nci(3,k)
      dx=xyz(1,i1)-xyz(1,i2)
      dy=xyz(2,i1)-xyz(2,i2)
      dz=xyz(3,i1)-xyz(3,i2)

      call box_image(dx,dy,dz)

      r2=dx*dx+dy*dy+dz*dz
!
!     Proceed only if the squared distance is smaller than the cutoff
!
      if (r2 .gt. coul_cut) cycle

      r =sqrt(r2)
      oner =1.0d0/r
      r_buf=r

      r_buf2=r_buf*r_buf
      f12=q(i1)*q(i2)
      r_ewald=r*a_ewald

      erfterm=erfc(r_ewald)

      e_local=(f12/r_buf)*erfterm
      de=-f12*(erfterm/r_buf2+(2d0*a_ewald/spi)*exp(-r_ewald**2)/r)

      de=de/r
      dedx=de*dx
      dedy=de*dy
      dedz=de*dz

      e_ew=e_ew+e_local
      de_ew(1,i1)=de_ew(1,i1)+dedx
      de_ew(2,i1)=de_ew(2,i1)+dedy
      de_ew(3,i1)=de_ew(3,i1)+dedz
      de_ew(1,i2)=de_ew(1,i2)-dedx
      de_ew(2,i2)=de_ew(2,i2)-dedy
      de_ew(3,i2)=de_ew(3,i2)-dedz
   end do

!
!     Compute the real space Ewald energy for the intermolecule
!     interactions, if a solvent system is present
!     see eq. (2.3) in paper
!
!    e_ew=0.d0
    if (nmols .gt. 1) then

      do i=1,n
         do j=i+1,n
            if (molnum(i) .ne. molnum(j)) then
               i1=i
               i2=j
               dx=xyz(1,i1)-xyz(1,i2)
               dy=xyz(2,i1)-xyz(2,i2)
               dz=xyz(3,i1)-xyz(3,i2)
               if (periodic) then
                  call box_image(dx,dy,dz)
               end if

               r2=dx*dx+dy*dy+dz*dz
!
!     Proceed only if the squared distance is smaller than the cutoff
!
               if (r2 .gt. coul_cut) cycle

               r =sqrt(r2)
               oner =1.0d0/r

               e_ew=e_ew+q(i1)*q(i2)*erfc(a_ewald*r)*oner

    !           r_buf=r+ebuffer

    !           r_buf2=r_buf*r_buf
    !           f12=q(i1)*q(i2)
!               write(*,*) "f12",f12
    !           r_ewald=r*a_ewald
!               write(*,*) "REW",r_ewald
    !           erfterm=erfc(r_ewald)

    !           e_local=(f12/r_buf)*(erfterm)
             !  write(*,*) "ewald",k,e_local
    !           de=-f12*((erfterm)/r_buf2+(2d0*a_ewald/spi)*exp(-r_ewald**2)/r)

      !         de=de/r
      !         dedx=de*dx
      !         dedy=de*dy
      !         dedz=de*dz

      !         e_ew=e_ew+e_local
!               write(*,*) "eew",e_ew/bohr
         !      stop "GupgpU"
      !         de_ew(1,i1)=de_ew(1,i1)+dedx
      !         de_ew(2,i1)=de_ew(2,i1)+dedy
      !         de_ew(3,i1)=de_ew(3,i1)+dedz
      !         de_ew(1,i2)=de_ew(1,i2)-dedx
      !         de_ew(2,i2)=de_ew(2,i2)-dedy
      !         de_ew(3,i2)=de_ew(3,i2)-dedz
         !   else
         !      i1=i
         !      i2=j
         !      dx=xyz(1,i1)-xyz(1,i2)
         !      dy=xyz(2,i1)-xyz(2,i2)
         !      dz=xyz(3,i1)-xyz(3,i2)
         !      if (periodic) then
         !         call box_image(dx,dy,dz)
         !      end if

         !      r2=dx*dx+dy*dy+dz*dz
!
!     Proceed only if the squared distance is smaller than the cutoff
!
              ! if (r2 .gt. coul_cut) cycle

         !      r =sqrt(r2)
         !      oner =1.0d0/r
             !  e_ew=e_ew-0.5*q(i1)*q(i2)*erf(a_ewald*r)*oner

            end if
         end do
      end do
   end if
   write(*,*) "energy Reciproc",e_rec
   e_ew=e_ew-e_rec
   write(*,*) "energy Ewald",e_ew!/bohr

   if (ewald_brute) then
      write(*,'(a,f18.9,a)') " The SPME-energy of the system is ",e_ew," Hartrees."
   end if
!   stop "in Ewald!"

end if
!
!    Benchmark for Smooth particle mesh Ewald method: calculate the
!    brute force direct Ewald sum!
!
ewald_brute=.false.
if (ewald_brute) then
   e_brute=0.d0
   write(*,*)
   write(*,*) "The brute force Ewald method will be applied for the Coulomb"
   write(*,*) " energy. This might take some time..."

!
!    Part 1: the usual Coulomb energy with all particles in the box
!
!    1A: The intramolecular energy contribution
!
   do k=1,nnci
      i1=nci(1,k)
      i2=nci(2,k)
      nk=nci(3,k)
      dx=xyz(1,i1)-xyz(1,i2)
      dy=xyz(2,i1)-xyz(2,i2)
      dz=xyz(3,i1)-xyz(3,i2)

      r2=dx*dx+dy*dy+dz*dz
      r =sqrt(r2)
      oner =1.0d0/r

      e0=q(i1)*q(i2)*oner*eps1(nk)

      e_brute=e_brute+e0
   end do
!
!   1B: The intermolecular energy contribution (if existent)
!
   if (nmols .gt. 1) then

      do i=1,n
         do j=i+1,n
            if (molnum(i) .ne. molnum(j)) then
               i1=i
               i2=j
               dx=xyz(1,i1)-xyz(1,i2)
               dy=xyz(2,i1)-xyz(2,i2)
               dz=xyz(3,i1)-xyz(3,i2)

               r2=dx*dx+dy*dy+dz*dz
               r =sqrt(r2)
               oner =1.0d0/r

               e0=q(i1)*q(i2)*oner

               e_brute=e_brute+e0
            end if
         end do
      end do
   end if
!
!    Part 2: The interaction to all cell replicas in the environment
!
   nbox=3
   nbox_sq=(nbox+1)**2
   allocate(pot_shell(nbox+1))
   pot_shell = 0.0d0
   do xbox = -nbox, nbox
      do ybox = -nbox, nbox
         do zbox = -nbox, nbox
            rbox_sq = xbox**2 + ybox**2 + zbox**2
            if ( rbox_sq > nbox_sq ) cycle ! Skip if outside maximum sphere of boxes
            rbox_vec = REAL ( [xbox,ybox,zbox] )*boxlen_x
            do i = 1, n
               do j = 1, n
                  if (rbox_sq .eq. 0 ) cycle ! Skip only for central box
                  ! Bare Coulomb term, including box vector, no periodic box correction
                  dx=xyz(1,i)-xyz(1,j)-rbox_vec(1)
                  dy=xyz(2,i)-xyz(2,j)-rbox_vec(2)
                  dz=xyz(3,i)-xyz(3,j)-rbox_vec(3)

                  r2=dx*dx+dy*dy+dz*dz
                  r =sqrt(r2)
                  oner =1.0d0/r

                  e0=q(i)*q(j)*oner
                  pot_shell(rbox_sq+1) = pot_shell(rbox_sq+1) + e0
               end do
            end do
         end do
      end do
   end do
   pot_shell=pot_shell/2.d0
  ! Convert to cumulative sum

   pot_shell(1) = e_brute
   do rbox_sq = 1, nbox_sq
      pot_shell(rbox_sq+1) = pot_shell(rbox_sq+1) + pot_shell(rbox_sq)
   end do

!
!     Write out the energies for the increasing shells to show convergence
!
   write(*,*) "The results for the full Ewald sum are:"
   write (*, fmt='(a)' ) ' Shell(box replicas) Energy (Hartree)'
   do rbox = 1, nbox
      write (*, fmt='(i5,f18.9)' ) rbox-1, pot_shell(rbox)
   end do

   write(*,*) "The calculation will be stopped here."
   stop
end if

!do i=1,n
!   write(*,*) "grad",g(:,i)
!end do

enb = enb + e

return
end subroutine ff_nonb


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

program xyz_to_SPECSYM_start
use libatoms_module
implicit none
  type(Atoms) :: at
  integer i
  real(dp) :: dipole_mom(3)

  call system_initialise()
  call read(at, "stdin")

  mainlog%prefix = "SPECSYM"

  call print(at%N//" 0.02 0.005 0.0 0.0")
  call print("300.0 0.0 1 6.0")
  do i=1, at%N
    call print(ElementMass(at%Z(i))/MASSCONVERT)
  end do
  call print("0.0 0")
  do i=1, at%N
    call print (at%pos(:,i)/BOHR // " " // at%Z(i) // " " // at%Z(i))
    call print ("0.0 0.0 0.0")
  end do

  if (.not. get_value(at%params, 'Dipole_Moment', dipole_mom)) dipole_mom = 0.0_dp

  call print (dipole_mom/BOHR)
  call print ("0.0 0.0 0.0")

  mainlog%prefix = ""

  call system_finalise()
end program