*                              D   I   S   C   L   A   I   M   E   R
*
*       You are using a BETA version of the program stellgap.f, which is currently
*       under development by D. A. Spong of the Fusion Energy Division,
*       Oak Ridge National Laboratory.  Please report any problems or comments
*       to him.  As a BETA version, this program is subject to periodic change
*       and improvement without notice.
*
c
c  Note: this code uses normalized toroidal flux (variables: rho, r_pt) as
c        an independent variable. If a radius-like variable is desired
c        (i.e., sqrt(tor_flux) or radius based on sqrt(area/pi)), this must be
c        constructed in subsequent codes that use the AE3D eigenfunction data
c
c   Before running, check that the irads variable is set consistently with the
c   number of surfaces in the tae_boozer_data file. irads should be the number
c   of surfaces in the original VMEC run minus 1 or 2 to avoid edge problems.
c
c  Modified 2/23/2013 to properly treat RFPs where there is a reversal surface
c    (q -> 0, iota -> infinity). This is handled through options controlled by
c    the logical variable lrfp. lrfp is read from the first line of tae_data_boozer,
c    which is written by xmetric. For analysis of systems with lrfp = .true. both
c    updated versions of metric_element_create.f and stellagap.f are required.
c    If using an older tae_data_boozer file, a read error will result since the
c    first line will not have the lrfp logical. One can edit tae_data_boozer
c    and add "F" in the first line to resolve this. However, to treat cases with
c    lrfp = .true. it is necessary to have also used the upgraded xmetric. By
c    default lrfp is set to .false.
c
c  Modified 7/6/2012 making ir_fine_scl and irads to be command-line arguments
c   (if not given, default values of 128 and 41 are used)
c
c  Modified 12/2008 so that ion density profile, ion mass and several other
c   parameters are read in through the plasma.dat file rather than being
c   hardwired into the code. (see explanation below for variables contained
c   in plasma.dat file).
c
c  Modified on 9/18/2008 to offer both parallel or serial options, depending on
c   use of the precompiler.
c
c  This is the stellgap code for calculating Alfven contina in stellarators. The
c  associated publication that describes this calculation is:
c
c   D. A. Spong, R. Sanchez, A. Weller, "Shear Alfven Continua in Stellarators,"
c     Phys. of Plasmas, Vol. 10, pg. 3217, August, 2003.
c
c
c  This version of stellgap.f has been modified to be compatible with ae_solve.f.
c  The frequencies are output in kHz. The mode selection is done using the fourier.dat
c  file. The equilibrium data comes from the tae_data_boozer file. Following the
c  stellgap run, a post-processing code, post_process.f must be run. The gap plot
c  is then made using the results in the alfven_post file.
c  The central ion density, ion density profile, and ion mass are set from the
c  plasma.dat input file.
c  Two other variables that the user should set are irads and ir_fine_scl. These
c  are set througth paramter statements in the beginning of program tae_continua:
c      integer, parameter :: ir_fine_scl = 1000
c      integer, parameter :: irads = 39, irad3 = 3*irads
c  irads = # of flux surfaces in the initial equilibrium (wout file) - 2.
c  The outermost and innermost surfaces from the initial equilibrium
c  are left off to avoid inaccuracies that are sometimes present near
c  these regions.
c  ir_fine_scl = # of surfaces desired in the continuum output. Generally, to
c  resolve fine scale features in the Alfven continua, more surfaces are
c  desireable than in the original equilibrium data. The code performs
c  interpolations to allow this.
c
c
c  Input parameters:   (fourier.dat file).
c
c   ith, izt = number of theta and zeta grid points in the original mesh data
c     (in file tae_data_vmec) calculated by the xmetric code.
c    This file contains data
c    for iota, phipc, |B|, gssup (the psi-psi contra-variant metric element,
c    the Jacobian, and the contravariant poloidal and toroidal components of
c    the magnetic field)
c   nfp = number of field periods (for a tokamak run, set nfp = 1)
c   mpol, ntor = number of poloidal and toroidal modes used in the Fourier
c    expansion of the above gridded quantities suplied by the tae_data_vmec
c    data file.  To avoid anti-aliasing errors, mpol < 0.5*ith and
c    ntor < 0.5*izt.
c   mp_col = number of m,n mode pairs used in the representation of the
c    eigebfunction
c   nt_col = number of toroidal modes used in the representation of the
c    eigenfunction (should be an integral multiple of nfp)
c   mode_family = toroidal mode number about which the toroidal eigenfunction
c     spectrum is built. i.e., for m = 0,
c     n = mode_family, mode_family + nfp, mode_family + 2*nfp,
c         ..., mode_family + nt_col
c      while for m .ne. 0,
c      n = -nt_col + mode_family, -nt_col + nfp + mode_family, -nt_col
c            + 2*nfp + mode_family, ..., nt_col + mode_family
c
c   Input parameters:   (plasma.dat file).
c
c   ion_to_proton_mass = m_ion/m_proton
c   ion_density_0 = n_ion(0) = ion density (in m**-3) at magnetic axis
c   ion_profile = integer parameter that determines form of n_ion(r)/n_ion(0) fit
c      for ion_profile = 0 ion_density = [iota(rho)/iota(0)]**2
c      for ion_profile = 1 ion_density = polynomial fit
c                          = nion(1) + nion(2)*rho + nion(3)*(rho**2)
c                           + nion(4)*(rho**3) + ... + nion(9)*(rho**8) + nion(10)*(rho**9)
c               (here rho = normalized toroidal flux)
c      for ion_profile = 2 ion_density = ion_density = constant = 1.
c      for ion_profile = 3 ion_density = [1 - aion*(rho**bion)]**cion
c
c   nion(10) = array of polynomial fit coefficients for ion_profile = 1
c   aion, bion, cion = parameters for ion_profile = 3 fit
c   jdqz_data = logical variable that is used in ae3d, but not in stellgap.f
c                (included here only so that same plasma.dat file can be used)
c   egnout_form = "binr" or "asci" - like jdqz_data this variable is used in
c                  ae3d, but not stellgap.f
c
c compile: sh bld_stellgap
c
c  This code is can be run in serial or parallel mode, depending on whether
c   is it run through the precompiler with SERIAL or PARALLEL set.
c
c
      module kind_spec
c
c     Double precision
c
      integer, parameter :: rprec = selected_real_kind(12,100)
      integer, parameter :: iprec = selected_int_kind(8)
      end module kind_spec
c
c Variables that need to be set for each time the configuration is changed:
c   ith, izt, nfp, mpol, ntor, mp_col
c
      module fourier_lib
      use kind_spec
      implicit none
      integer::ith, izt, mpol, ntor, nznt, mnmx, ntors, nfp, mode_family
      real(kind=rprec), parameter :: parity_gss = 1.,
     1     parity_bsupth = 1., parity_bsupzt = 1.
      integer :: i, j, lg, nu, nl, m, n, mn, istat, sin_type, cos_type
c   Equilibrium coefficient arrays
      real(kind=rprec), allocatable :: thtgrd(:),ztgrd(:),rn(:),rm(:)
      real(kind=rprec), allocatable :: fnm(:),f(:),anm(:)
      real(kind=rprec), allocatable :: cos_ar(:,:),sin_ar(:,:)
      real(kind=rprec), allocatable :: cos_toF(:,:),sin_toF(:,:)
      real(kind=rprec) twopi, arg
      logical, parameter :: ipos_def_sym=.false.
c    The subset_eq flag allows one to just request a bracketed subset of
c     eigenvalues, rather than all eigenvalues. This option has not been
c     developed beyond the call. Initial tests have not indicated it
c     speeds things up.
      logical, parameter :: subset_eq = .false.
c   Eigenfunction arrays,variables
      integer :: count, mn_col, ith_col, izt_col
      real(kind=rprec), allocatable :: rn_col(:),rm_col(:)
      real(kind=rprec), allocatable :: rn2_col(:),rm2_col(:),rnm_col(:)
      integer, allocatable :: in_col(:), im_col(:)
      integer, allocatable :: nw(:), mwl(:), mwu(:)             !change when modes are added
      contains
c
      subroutine readin
       open(unit=20,file="fourier.dat",status="old")
       read(20,*) nfp, ith, izt, mode_family
       mpol = ith*2/5; ntor = izt*2/5
       nznt=ith*izt; mnmx=(2*ntor+1)*mpol-ntor
       read(20,*) ntors
       allocate(nw(ntors), stat=istat)
       allocate(mwl(ntors), stat=istat)
       allocate(mwu(ntors), stat=istat)
       do i=1,ntors
        read(20,*) nw(i), mwl(i), mwu(i)
       end do
       close(unit=20)
      end subroutine readin
c
c
      subroutine trig_array
      use kind_spec
      implicit none
      real(kind=rprec) :: dum,dnorm
      allocate(thtgrd(nznt), stat=istat)
      allocate(ztgrd(nznt), stat=istat)
      allocate(rm(mnmx), stat=istat)
      allocate(rn(mnmx), stat=istat)
      allocate(fnm(mnmx), stat=istat)
      allocate(f(nznt), stat=istat)
      allocate(anm(mnmx), stat=istat)
      allocate(cos_ar(nznt,mnmx), stat=istat)
      allocate(sin_ar(nznt,mnmx), stat=istat)
      allocate(cos_toF(nznt,mnmx), stat=istat)
      allocate(sin_toF(nznt,mnmx), stat=istat)
      twopi = 8.*atan(1.)
c    Generate theta, zeta grid
      lg = 0
      do i=1,izt
      do j=1,ith
       lg = lg + 1
       ztgrd(lg) = twopi*real(i-1)/(real(nfp*izt))
       thtgrd(lg) = twopi*real(j-1)/real(ith)
      end do
      end do
c    Generate Fourier mode distribution
      mn = 0
      nu = ntor
      do m=0,mpol-1
       nl = -ntor
       if(m .eq. 0) nl = 0
        do n = nl,nu
         mn = mn + 1
         rm(mn) = real(m)
         rn(mn) = real(n*nfp)
        enddo
      enddo
      do i=1,nznt
       do mn=1,mnmx
        arg = -rn(mn)*ztgrd(i) + rm(mn)*thtgrd(i)
        cos_ar(i,mn) = cos(arg)
        sin_ar(i,mn) = sin(arg)
        dnorm = 2./real(nznt)
        dum = abs(rn(mn)) + abs(rm(mn))
        if(nint(dum) .eq. 0) dnorm = .5*dnorm
        cos_toF(i,mn) = cos_ar(i,mn)*dnorm
        sin_toF(i,mn) = sin_ar(i,mn)*dnorm
       end do
      end do
      end subroutine trig_array

      subroutine convolution_array
      use kind_spec
      implicit none
c     First, count the number of modes to be used
      count = 0
      do i=1,ntors
       count = count + mwu(i) - mwl(i) + 1
      end do
      mn_col = count
c     Allocate memory for arrays needed in eigenfunction calculations
      allocate(rm_col(mn_col), stat=istat)
      allocate(rn_col(mn_col), stat=istat)
      allocate(im_col(mn_col), stat=istat)
      allocate(in_col(mn_col), stat=istat)
      allocate(rm2_col(mn_col), stat=istat)
      allocate(rn2_col(mn_col), stat=istat)
      allocate(rnm_col(mn_col), stat=istat)
c     Create mode number arrays needed for eigenfunction
       count = 0
       do n = 1,ntors                           !change when modes are added
        do m = mwl(n), mwu(n)
         count = count + 1
         rm_col(count) = real(m)
         rn_col(count) = real(nw(n))
         im_col(count) = m
         in_col(count) = nw(n)
         rm2_col(count) = rm_col(count)*rm_col(count)
         rn2_col(count) = rn_col(count)*rn_col(count)
         rnm_col(count) = rm_col(count)*rn_col(count)
        end do
      end do
      mn_col = count
c      write(*,*) mn_col, count
      end subroutine convolution_array
c
c
      subroutine scs_convolve(ans,m1,n1,m2,n2,meq,neq)
      use kind_spec
      implicit none
      real(kind=rprec) :: tht_int1, tht_int2, tht_int3, tht_int4,
     1  zeta_int1, zeta_int2, zeta_int3, zeta_int4, ans
      integer :: m1, m2, n1, n2, meq, neq
      integer :: sm1, sm2, sn1, sn2, smeq, sneq
c
c     This subroutine calculates the 2D integral for tht and zeta running
c     from 0 to 2*PI of:
c     sin(m1*tht - n1*zeta)*cos(meq*tht - neq*zeta)*sin(m2*tht - n2*zeta)
c     The value returned is actually (2/PI) times this integral.
c
      sm1=1;sm2=1;sn1=1;sn2=1;smeq=1;sneq=1
      if(m1 .ne. 0) sm1 = m1/abs(m1)
      if(m2 .ne. 0) sm2 = m2/abs(m2)
      if(n1 .ne. 0) sn1 = n1/abs(n1)
      if(n2 .ne. 0) sn2 = n2/abs(n2)
      if(meq .ne. 0) smeq = meq/abs(meq)
      if(neq .ne. 0) sneq = neq/abs(neq)
      m1 = sm1*m1; n1 = sn1*n1
      m2 = sm2*m2; n2 = sn2*n2
      meq = smeq*meq; neq = sneq*neq
      call css(tht_int1, meq, m1, m2)
      call ccc(zeta_int1, n1, n2, neq)
      call ccc(tht_int2, m1, m2, meq)
      call css(zeta_int2, neq, n1, n2)
      call css(tht_int3, m2, m1, meq)
      call css(zeta_int3, n1, n2, neq)
      call css(tht_int4, m1, m2, meq)
      call css(zeta_int4, n2, n1, neq)
      ans = tht_int1*zeta_int1*sm1*sm2
     1    + tht_int2*zeta_int2*sn1*sn2
     2    - tht_int3*zeta_int3*sm1*smeq*sn2*sneq
     3    - tht_int4*zeta_int4*sm2*smeq*sn1*sneq
      m1 = sm1*m1; n1 = sn1*n1
      m2 = sm2*m2; n2 = sn2*n2
      meq = smeq*meq; neq = sneq*neq
      end subroutine scs_convolve
c
c
c
      subroutine ccc_convolve(ans,m1,n1,m2,n2,meq,neq)
      use kind_spec
      implicit none
      real(kind=rprec) :: tht_int1, tht_int2, tht_int3, tht_int4,
     1  zeta_int1, zeta_int2, zeta_int3, zeta_int4, ans
      integer :: m1, m2, n1, n2, meq, neq
      integer :: sm1, sm2, sn1, sn2, smeq, sneq
c
c     This subroutine calculates the 2D integral for tht and zeta running
c     from 0 to 2*PI of:
c     cos(m1*tht - n1*zeta)*cos(meq*tht - neq*zeta)*cos(m2*tht - n2*zeta)
c     The value returned is actually (2/PI) times this integral.
c
      sm1=1;sm2=1;sn1=1;sn2=1;smeq=1;sneq=1
      if(m1 .ne. 0) sm1 = m1/abs(m1)
      if(m2 .ne. 0) sm2 = m2/abs(m2)
      if(n1 .ne. 0) sn1 = n1/abs(n1)
      if(n2 .ne. 0) sn2 = n2/abs(n2)
      if(meq .ne. 0) smeq = meq/abs(meq)
      if(neq .ne. 0) sneq = neq/abs(neq)
      m1 = sm1*m1; n1 = sn1*n1
      m2 = sm2*m2; n2 = sn2*n2
      meq = smeq*meq; neq = sneq*neq
      call ccc(tht_int1, m1, m2, meq)
      call ccc(zeta_int1, n1, n2, neq)
      call css(tht_int2, meq, m1, m2)
      call css(zeta_int2, neq, n1, n2)
      call css(tht_int3, m1, m2, meq)
      call css(zeta_int3, n1, n2, neq)
      call css(tht_int4, m2, m1, meq)
      call css(zeta_int4, n2, n1, neq)
      ans = tht_int1*zeta_int1
     1    + tht_int2*zeta_int2*sm1*sm2*sn1*sn2
     2    + tht_int3*zeta_int3*sm2*smeq*sn2*sneq
     3    + tht_int4*zeta_int4*sm1*smeq*sn1*sneq
      m1 = sm1*m1; n1 = sn1*n1
      m2 = sm2*m2; n2 = sn2*n2
      meq = smeq*meq; neq = sneq*neq
      end subroutine ccc_convolve
c
c
c
      subroutine ccc(result, i, j, k)
      use kind_spec
      real(kind=rprec), parameter :: zero = 0, one = 1,
     1    two = 2, four = 4
      real(kind=rprec) :: result
      integer :: i, j, k, izeros
c
c     This subroutine calculates the 1D integral of
c     cos(i*x)*cos(j*x)*cos(k*x)
c     for x running from 0 to 2*PI.
c     The value returned is actually (2/PI) times this integral.
c
      result = zero
      izeros = 0
      if(i .eq. 0) izeros = izeros + 1
      if(j .eq. 0) izeros = izeros + 1
      if(k .eq. 0) izeros = izeros + 1
      if(izeros .ne. 0) then
       if(izeros .eq. 3) then
        result = four
        return
       else if(izeros .eq. 2) then
        result = zero
        return
       else if(izeros .eq. 1) then
        if(i .eq. 0) then
         result = zero
         if(j*j .eq. k*k) then
          result = two
         endif
         return
        else if(j .eq. 0) then
          result = zero
          if(i*i .eq. k*k) then
          result = two
         endif
         return
        else if(k .eq. 0) then
          result = zero
          if(i*i .eq. j*j) then
          result = two
         endif
         return
        endif
       endif
      else if (izeros .eq. 0) then
       if(k .eq. (i-j)) result = one
       if(k .eq. (i+j)) result = one
       if(k .eq. (j-i)) result = one
       if(k .eq. -(i+j)) result = one
      endif
      end subroutine ccc
c
c
c
      subroutine css(result, k, i, j)
      use kind_spec
      real(kind=rprec), parameter :: one = 1, neg_one = -1, zero = 0,
     1  two = 2, neg_two = -2
      integer :: i, j, k
      real(kind=rprec) :: result
c
c     This subroutine calculates the 1D integral of
c     cos(k*x)*sin(i*x)*sin(j*x)
c     for x running from 0 to 2*PI.
c     The value returned is actually (2/PI) times this integral.
c
      result = zero
      if(i .eq. 0 .or. j .eq. 0) return
      if(k .eq. 0) then
        if(i*i .ne. j*j) then
         return
        else if(i*i .eq. j*j) then
         result = 2
         return
        endif
      endif
      if(k .eq. (i-j)) result = one
      if(k .eq. (i+j)) result = neg_one
      if(k .eq. (j-i)) result = one
      if(k .eq. -(i+j)) result = neg_one
      end subroutine css
c
c
      subroutine trg_deallocate
      deallocate(thtgrd,ztgrd,rm,rn,cos_ar,sin_ar,f,fnm,anm,
     1   rm_col,rn_col,im_col,in_col,
     2   rm2_col,rn2_col,rnm_col)
      end subroutine trg_deallocate

      end module fourier_lib
c-----------------------------------------------------------------
      program tae_continua
      use fourier_lib
      use kind_spec
      implicit none
#if defined (PARALLEL)
      include 'mpif.h'
#endif
c
c      This code is a test of a Fourier xform of a 2D function
c      (f) vs. theta, zeta.  f has cos/sin stellarator-like symmetry.
c      The Fourier xform is done by subroutine toFourier using
c      cos/sin expansions. (use with Fourier_lib.f)
c
c
      integer :: ir_fine_scl, irads, irad3
      integer, parameter :: iopt = 1
      real(kind=rprec), parameter :: R0 = 1.0
      real(kind=rprec), parameter :: mass_proton = 1.67d-27
      real(kind=rprec) :: ion_density_0, mass_ion, ion_to_proton_mass,
     1   aion, bion, cion
      real(kind=rprec) :: nion(10)
      integer :: ir, irr, il, iu, ion_profile
      character*4 :: egnout_form
      logical :: jdqz_data
      real(kind=rprec), dimension(:,:,:), allocatable :: bfield,
     1  gsssup,rjacob, bsupth, bsupzt, bfield_lrg,
     2  gsssup_lrg, bsupth_lrg, bsupzt_lrg, rjacob_lrg
      real(kind=rprec), dimension(:), allocatable :: theta_tae,
     1 zeta_tae, f1_nm, f3a_nm, f3b_nm, f3c_nm, bsupth_tmp, bsupzt_tmp
      real(kind=rprec), dimension(:,:), allocatable :: f1, f3a,
     1 f3b, f3c

      real(kind=rprec), dimension(:), allocatable :: bavg, mu0_rho_ion,
     1                  ion_density, iota_r, iota_r_inv

      real(kind=rprec), allocatable :: beta(:), aux(:), eig_vect(:)
      real(kind=rprec), allocatable :: amat(:,:),
     1           bmat(:,:), z_r(:,:), vr(:,:), vl(:,:)
      real(kind=rprec), allocatable :: bgrad2(:,:,:)
      real(kind=rprec), allocatable :: omega(:), work(:), alfr(:),
     1  alfi(:)
      complex*16, allocatable :: alpha(:)

      real(kind=rprec), dimension(:), allocatable :: nsurf, iotac,
     1                   phipc, rho, sp_fit, b2, iotac_inv

      real(kind=rprec) :: sp1, sp2, sigma_spl, r_pt,
     1  iotac_r, curv2, dum1, dum2, dum3, dum4

      real(kind=rprec), dimension(:), allocatable :: yp, temp,
     1                  ypi, tempi

      real(kind=rprec) :: amat1, amat2, amat3, amat4, amat5
      real(kind=rprec) :: f1_coef, f2a_coef, f3a_coef,
     1  f3b_coef, f3c_coef
      real(kind=rprec) :: dm1,dm2,dm3,dm4,dm5, bfavg, va
      real(kind=rprec) :: f1max, eig_max, mu0, scale_khz,
     1  f3amax, f3bmax, f3cmax, ccci, scsi, test,
     2  egl, egu, abstol, f1_avg, f3_avg
      real(kind=rprec) :: ra, ra2, ra3, ra4, ra5, ra6
      integer :: ispl_opt, ierr_spl, num_eq, naux
      integer :: ier, npes, mype, numrads
      integer :: ni, nj, mi, mj, ieq, meq, neq, ii, jj
      integer :: j_max_index, ios
      integer :: m_emax, n_emax, isym_opt, in, im
      integer :: ldvl, ldvr, lwork, info, nn, m_red
      integer, allocatable :: ifail(:), iwork(:)
      logical :: cyl, lrfp
      character*20 outfile
      character*3 procnum
      character*1 jobz
      character*10 date, time, zone
      character*10 arg1, arg2
      integer values(8)
      namelist /plasma_input/ ion_to_proton_mass, ion_density_0,
     >    ion_profile, jdqz_data, egnout_form, nion,
     >    aion, bion, cion
      cyl = .false.; lrfp = .false.
      call getarg(1,arg1)
      call getarg(2,arg2)
      irads = 41; ir_fine_scl = 128  !default values
      read(arg1,'(i3)') irads
      read(arg2,'(i4)') ir_fine_scl
      irad3 = 3*irads
      write(*,'("irads = ",i4," irads3 = ",i4," ir_fine_scl = ",i5)')
     >       irads, irad3, ir_fine_scl

      allocate(bavg(ir_fine_scl),mu0_rho_ion(ir_fine_scl),
     >  ion_density(ir_fine_scl),iota_r(ir_fine_scl),
     >  iota_r_inv(ir_fine_scl),stat=istat)
      allocate(nsurf(irads),iotac(irads),iotac_inv(irads),
     >  phipc(irads),rho(irads),sp_fit(irads),
     >  b2(irads), stat=istat)
      allocate(yp(irad3),temp(irad3),ypi(irad3),
     >  tempi(irad3), stat=istat)

      open(unit=4,file="plasma.dat",status="old")
      read(4,plasma_input)
      close(unit=4)
      mass_ion = mass_proton*ion_to_proton_mass
#if defined (PARALLEL)
C Get NPES and MYPE.  Requires initialization of MPI.
      call MPI_INIT(ier)
      if (ier .ne. 0) then
        write(*,'("mpi_init returned ier =")') ier
        stop
        endif
      call MPI_COMM_SIZE(MPI_COMM_WORLD, npes, ier)
      if (ier .ne. 0) then
        write(*,'("mpi_comm_size returned ier =")') ier
        stop
        endif
      call MPI_COMM_RANK(MPI_COMM_WORLD, mype, ier)
      if (ier .ne. 0) then
        write(*,'("mpi_comm_rank returned ier =")') ier
        stop
        endif
#endif
#if defined (SERIAL)
       mype = 0
       npes = 1
#endif
c
       jobz = 'V'
c
#if defined (PARALLEL)
       write(procnum,'(i3)') mype
       write(*,*) procnum
       outfile = "alfven_spec" // trim(adjustl(procnum))
#endif
#if defined (SERIAL)
       outfile = "alfven_spec"
#endif
      if(mype .eq. 0) then
       write(*,*) mype, npes
       write(*,*) procnum
       write(*,*) outfile
       call date_and_time(date, time, zone, values)
       write(*,*) time
      endif
       if(ipos_def_sym) isym_opt = 1
       if(.NOT.ipos_def_sym) isym_opt = 0
c
c    Generate Fourier arrays
c
      call readin
      call trig_array
      call convolution_array
      num_eq = mnmx
      naux = 10*mn_col
      mu0 = 2.d-7*twopi
      scale_khz = (1.d+3*twopi)**2
      allocate(aux(naux), stat=istat)
      allocate(alpha(mn_col), stat=istat)
      allocate(beta(mn_col), stat=istat)
      allocate(eig_vect(mn_col), stat=istat)
      allocate(z_r(mn_col,mn_col), stat=istat)
      allocate(omega(mn_col), stat=istat)
      allocate(amat(mn_col,mn_col), stat=istat)
      allocate(bmat(mn_col,mn_col), stat=istat)
      allocate(ifail(mn_col), stat=istat)
      ldvl = mn_col; ldvr = mn_col; lwork = 20*mn_col
      allocate(work(lwork), stat=istat)
      allocate(iwork(lwork), stat=istat)
      allocate(alfr(mn_col), stat=istat)
      allocate(alfi(mn_col), stat=istat)
      allocate(vl(mn_col,mn_col), stat=istat)
      allocate(vr(mn_col,mn_col), stat=istat)
      if(mype .eq. 0)
     >    write(*,*) izt, ith, irads, mnmx, nznt, mn_col
      allocate(bfield(izt,ith,irads), stat=istat)
      allocate(gsssup(izt,ith,irads), stat=istat)
      allocate(rjacob(izt,ith,irads), stat=istat)
      allocate(bsupth(izt,ith,irads), stat=istat)
      allocate(bsupzt(izt,ith,irads), stat=istat)
      allocate(bfield_lrg(izt,ith,ir_fine_scl), stat=istat)
      allocate(gsssup_lrg(izt,ith,ir_fine_scl), stat=istat)
      allocate(bsupth_lrg(izt,ith,ir_fine_scl), stat=istat)
      allocate(bsupzt_lrg(izt,ith,ir_fine_scl), stat=istat)
      allocate(rjacob_lrg(izt,ith,ir_fine_scl), stat=istat)
      allocate(theta_tae(ith), stat=istat)
      allocate(zeta_tae(izt), stat=istat)
      allocate(f1_nm(mnmx), stat=istat)
      allocate(f3a_nm(mnmx), stat=istat)
      allocate(f3b_nm(mnmx), stat=istat)
      allocate(f3c_nm(mnmx), stat=istat)
      allocate(bsupth_tmp(nznt), stat=istat)
      allocate(bsupzt_tmp(nznt), stat=istat)
      allocate(f1(izt,ith), stat=istat)
      allocate(f3a(izt,ith), stat=istat)
      allocate(f3b(izt,ith), stat=istat)
      allocate(f3c(izt,ith), stat=istat)
c
c   Open files for output
c
c      write(*,*) trim(adjustl(outfile))

      open(unit=21,file=trim(adjustl(outfile)),status="unknown")
      open(unit=8,file="coef_arrays",status="unknown")
      if(mype .eq. 0) then
        open(unit=7,file="data_post",status="unknown")
        open(unit=9,file="ion_profile",status="unknown")
      endif
c
c    Boozer coordinates input - new ae-mode-structure input
c
      open(unit=20,file="tae_data_boozer",status="old")
c      read(20,'(L)') lrfp    !uncomment and remove next line if lrfp added to tae_data_boozer
      lrfp = .false.
      if(lrfp) write(*,'("Using RFP settings")')
      if(.not.lrfp) write(*,'("Using tokamak/stellarator settings")')
      do ir = 1,irads
       read(20,'(1x,i3,4(2x,e15.7))') nn,
     1   iotac(ir),phipc(ir),dum1,dum2
       iotac_inv(ir) = 1.d0/iotac(ir)
       nsurf(ir) = dble(nn)
       b2(ir) = 0.d0
       do i = 1,izt
        do j = 1,ith
        read(20,'(1x,4(e24.12,2x),e24.12)') theta_tae(j),
     1   zeta_tae(i),
     1   bfield(i,j,ir), gsssup(i,j,ir),
     2   dm1
       b2(ir)  = b2(ir) + bfield(i,j,ir)/(dble(izt*ith))
       read(20,'(1x,4(e24.12,2x),e24.12)') dm2,
     1   dm3, dm4, dm5,
     2   rjacob(i,j,ir)

       if(lrfp) then
        rjacob(i,j,ir) = rjacob(i,j,ir)
       else
        rjacob(i,j,ir) = rjacob(i,j,ir)/phipc(ir)
       endif
       end do
       end do
c       write(*,*) ir, bfield(izt,ith,ir), rjacob(izt,ith,ir)
       end do
       bfavg = sum(b2)/(dble(irads))
c
c    Record equilibrium and eigenfunction Fourier mode list
c
       if(mype .eq. 0) then
        open(unit=22,file="modes",status="unknown")
        write(22,'("Equilibrium modes:",/)')
        write(22,'("meq    neq")')
       do i=1,mnmx
        meq = rm(i)
        neq = rn(i)
        write(22,'(i3,3x,i3)') meq, neq
        end do
        write(22,'(///,"Eigenvector modes:",/)')
        write(22,'("m    n")')
        do i=1,mn_col
         write(22,'(i3,3x,i3)') im_col(i), in_col(i)
        end do
        close(unit=22)
       endif
c
c   Make spline fits and fill in fine_radius_scale arrays
c
      do ir=1,irads
        rho(ir) = nsurf(ir)/nsurf(irads)
#if defined (SERIAL)
c	 write(*,*) rho(ir)
#endif
      end do
      ispl_opt = 3; ierr_spl = 0; sigma_spl = 0.
      call curv1(irads,rho,iotac,sp1,sp2,ispl_opt,ypi,
     >   tempi,sigma_spl,ierr_spl)
      do irr = 1,ir_fine_scl
       r_pt = rho(1)+real(irr-1)*(rho(irads) - rho(1))
     1           /real(ir_fine_scl-1)
        ra = sqrt(r_pt); ra2 = ra**2; ra3 = ra**3; ra4 = ra**4
	ra5 = ra**5; ra6 = ra**6
        iota_r(irr) = curv2(r_pt,irads,rho,iotac,ypi,sigma_spl)

	if(ion_profile .eq. 0) then
	  ion_density(irr) = (iota_r(irr)/iotac(1))**2   !profile that lines up gaps
	else if(ion_profile .eq. 1) then
	  ion_density(irr) = nion(1) + r_pt*nion(2) + nion(3)*(r_pt**2)
     1     + nion(4)*(r_pt**3) + nion(5)*(r_pt**4) + nion(6)*(r_pt**5)
     2     + nion(7)*(r_pt**6) + nion(8)*(r_pt**7) + nion(9)*(r_pt**8)
     3     + nion(10)*(r_pt**9)
        else if(ion_profile .eq. 2) then
	  ion_density(irr) = 1.d0
	else if(ion_profile .eq. 3) then
	  ion_density(irr) = (1. - aion*(r_pt**bion))**cion
	end if

	mu0_rho_ion(irr)=mu0*mass_ion*ion_density_0
     >    *ion_density(irr)*scale_khz
	va = sqrt(bfavg**2/(mu0_rho_ion(irr)/scale_khz))
	if(mype .eq. 0)
     >     write(9,67) r_pt,ion_density_0*ion_density(irr),
     >     iota_r(irr),va
      end do     !irr = 1,ir_fine_scl
c   Interpolate 1/iota for lrfp = true option
      ispl_opt = 3; ierr_spl = 0; sigma_spl = 0.
      call curv1(irads,rho,iotac_inv,sp1,sp2,ispl_opt,ypi,
     >   tempi,sigma_spl,ierr_spl)
      do irr = 1,ir_fine_scl
       r_pt = rho(1)+real(irr-1)*(rho(irads) - rho(1))
     1           /real(ir_fine_scl-1)
        iota_r_inv(irr) = curv2(r_pt,irads,rho,iotac_inv,ypi,sigma_spl)
      end do     !irr = 1,ir_fine_scl

      if(ierr_spl .ne. 0) write(*,'("spline error 1",i3)') ierr_spl
 67   format(e12.5,3(3x,e12.5))
      do i=1,izt
       do j=1,ith
c
c       Bfield array
c
        do ir=1,irads
         sp_fit(ir) = bfield(i,j,ir)
        end do      !ir=1,irads
        ispl_opt = 3; ierr_spl = 0; sigma_spl = 0
        call curv1(irads,rho,sp_fit,sp1,sp2,ispl_opt,yp,
     >        temp,sigma_spl,ierr_spl)
      if(ierr_spl .ne. 0) write(*,'("spline error 2",i3)') ierr_spl
      do irr = 1,ir_fine_scl
       r_pt = rho(1)+real(irr-1)*(rho(irads) - rho(1))
     1           /real(ir_fine_scl-1)
       bfield_lrg(i,j,irr) = curv2(r_pt,irads,rho,sp_fit,yp,sigma_spl)
      end do     !irr = 1,ir_fine_scl
c
c
c       Jacobian array
c
        do ir=1,irads
         sp_fit(ir) = rjacob(i,j,ir)
        end do      !ir=1,irads
        ispl_opt = 3; ierr_spl = 0; sigma_spl = 0
        call curv1(irads,rho,sp_fit,sp1,sp2,ispl_opt,yp,
     >        temp,sigma_spl,ierr_spl)
      if(ierr_spl .ne. 0) write(*,'("spline error 2",i3)') ierr_spl
      do irr = 1,ir_fine_scl
       r_pt = rho(1)+real(irr-1)*(rho(irads) - rho(1))
     1           /real(ir_fine_scl-1)
       rjacob_lrg(i,j,irr) = curv2(r_pt,irads,rho,sp_fit,yp,sigma_spl)
      end do     !irr = 1,ir_fine_scl
c
c       Gsssup array
c
        do ir=1,irads
         sp_fit(ir) = gsssup(i,j,ir)
        end do
        ispl_opt = 3; ierr_spl = 0; sigma_spl = 0
        call curv1(irads,rho,sp_fit,sp1,sp2,ispl_opt,yp,
     >        temp,sigma_spl,ierr_spl)
      if(ierr_spl .ne. 0) write(*,'("spline error 3",i3)') ierr_spl
      do irr = 1,ir_fine_scl
       r_pt = rho(1)+real(irr-1)*(rho(irads) - rho(1))
     1           /real(ir_fine_scl-1)
       gsssup_lrg(i,j,irr) = curv2(r_pt,irads,rho,sp_fit,yp,sigma_spl)
      end do     !irr = 1,ir_fine_scl
      end do     !j=1,ith
      end do     !i=1,izt
      close(unit=9)
c
c
c     Fine_scale arrays and spline fits finished
c
       numrads = ir_fine_scl/npes
c       write(*,*) numrads
       do ir = (mype*numrads+1),(mype*numrads+numrads)
c       write(*,*) ir
c      do ir=1,ir_fine_scl
         r_pt = rho(1)+real(ir-1)*(rho(irads) - rho(1))
     1           /real(ir_fine_scl-1)
      f1_avg = 0.;f3_avg = 0.
      do i=1,izt
       do j=1,ith
          f1(i,j) = gsssup_lrg(i,j,ir)*rjacob_lrg(i,j,ir)/
     1                 (bfield_lrg(i,j,ir)**2)
          f1_avg = f1_avg + f1(i,j)/real(izt*ith)
	  if(.not.lrfp) then
           f3c(i,j) = gsssup_lrg(i,j,ir)/
     1              (rjacob_lrg(i,j,ir)*(bfield_lrg(i,j,ir)**2))
           f3_avg = f3_avg + f3c(i,j)/real(izt*ith)
           f3b(i,j) = iota_r(ir)*f3c(i,j)
           f3a(i,j) = iota_r(ir)*f3b(i,j)
	  else if(lrfp) then
           f3a(i,j) = gsssup_lrg(i,j,ir)/
     1              (rjacob_lrg(i,j,ir)*(bfield_lrg(i,j,ir)**2))
           f3b(i,j) = f3a(i,j)*iota_r_inv(ir)
           f3c(i,j) = f3b(i,j)*iota_r_inv(ir)
           f3_avg = f3_avg + f3a(i,j)/real(izt*ith)
	  end if
       end do
      end do

      if(cyl) then
       if(.not.lrfp) then
        do i=1,izt
         do j=1,ith
         f1(i,j) = f1_avg
c         f3a(i,j) = f3_avg*iota_r(ir)*iota_r(ir)
c         f3b(i,j) = f3_avg*iota_r(ir)
c         f3c(i,j) = f3_avg
         end do
        end do
       else if(lrfp) then
        do i=1,izt
         do j=1,ith
         f1(i,j) = f1_avg
c         f3a(i,j) = f3_avg
c         f3b(i,j) = f3_avg*iota_r_inv(ir)
c         f3c(i,j) = f3_avg*iota_r_inv(ir)**iota_r_inv(ir)
         end do
        end do
       endif
      endif
c
c
c     Generate Fourier spectra of above gridded coefficients
c
      lg = 0
      do i=1,izt
       do j=1,ith
        lg = lg + 1
        f(lg) = f1(i,j)
       end do
      end do
      sin_type = 0; cos_type = 1
      call toFourier
      f1_nm(:) = fnm(:)
c
      lg = 0
      do i=1,izt
       do j=1,ith
        lg = lg + 1
        f(lg) = f3a(i,j)
       end do
      end do
      sin_type = 0; cos_type = 1
      call toFourier
      f3a_nm(:) = fnm(:)
c
      lg = 0
      do i=1,izt
       do j=1,ith
        lg = lg + 1
        f(lg) = f3b(i,j)
       end do
      end do
      sin_type = 0; cos_type = 1
      call toFourier
      f3b_nm(:) = fnm(:)
c
      lg = 0
      do i=1,izt
       do j=1,ith
        lg = lg + 1
        f(lg) = f3c(i,j)
       end do
      end do
      sin_type = 0; cos_type = 1
      call toFourier
      f3c_nm(:) = fnm(:)
c
c
c     Write out coefficient spectra if half way out in flux
c
      if(ir .eq. ir_fine_scl/2) then
       do mn = 1,mnmx
       write(8,'(f6.1,2x,f6.1,4(2x,e15.7))')rm(mn),rn(mn),
     1   f1_nm(mn),f3a_nm(mn),
     3   f3b_nm(mn),f3c_nm(mn)
       end do
      end if
c
c     Build A and B matrices
c
      do i=1,mn_col
        do j=1,mn_col
         bmat(i,j) = 0
         amat(i,j) = 0
         if(i .lt. j .and. ipos_def_sym) cycle     !i.e. symmetric storage mode: only need bottom half
         ni = in_col(i)
         nj = in_col(j)
         mi = im_col(i)
         mj = im_col(j)
          do ieq = 1,mnmx
            meq = rm(ieq)
            neq = rn(ieq)
            call ccc_convolve(ccci,mi,ni,mj,nj,meq,neq)
            call scs_convolve(scsi,mi,ni,mj,nj,meq,neq)
            bmat(i,j) = bmat(i,j) - ccci*f1_nm(ieq)*mu0_rho_ion(ir)
              amat(i,j) = amat(i,j)
     1         - (scsi*(f3a_nm(ieq)*rm_col(i)*rm_col(j)
     2               - f3b_nm(ieq)*rm_col(j)*rn_col(i)
     3               - f3b_nm(ieq)*rn_col(j)*rm_col(i)
     4               + f3c_nm(ieq)*rn_col(j)*rn_col(i)))
           end do              !ieq = 1,mnmx
        end do                 !j=1,mn_col
       end do                  !i=1,mn_col
c
c     Call matrix eigenvalue solver
c

       egl = 1.d-2; egu = 0.6d0; abstol = 1.d-8
       il = 0; iu = 0

       if(.NOT.ipos_def_sym) then
         call dggev('N','V',mn_col,amat,mn_col,bmat,mn_col,alfr,alfi,
     1     beta,vl,ldvl,vr,ldvr,work,lwork,info)
       else if(ipos_def_sym .and. .not.subset_eq) then
         call dsygv(iopt,jobz,'L',mn_col,amat,mn_col,bmat,mn_col,
     1     omega, work, lwork, info)
       if(info .ne. 0) write(*,'("info = ",i8)') info

       else if(ipos_def_sym .and. subset_eq) then
         call dsygvx(iopt,'V','V','L',mn_col,amat,mn_col,bmat,mn_col,
     1     egl, egu, il, iu, abstol, m_red, omega, vr, mn_col,
     >     work, lwork, iwork, ifail, info)
       if(info .ne. 0) write(*,'("info = ",i8)') info

       endif
c
      do i=1,mn_col
       if(iopt .eq. 1) then
       do j=1,mn_col
        if(ipos_def_sym .and. jobz .eq. 'V' .and. .not.subset_eq)
     1          eig_vect(j) = abs(amat(j,i))
        if(.NOT.ipos_def_sym) eig_vect(j) = abs(vr(j,i))
c	if(ir .eq. 5 .and. i .eq. mn_col/2)
c     >   write(*,'(e15.7,2x,i4,2x,i4)') eig_vect(j),
c     >   im_col(j), in_col(j)
       end do

       eig_max = -1.d+30
       do j=1,mn_col
        if(eig_vect(j) .gt. eig_max) then
	 eig_max = eig_vect(j)
	 j_max_index = j
	end if
       end do
       m_emax = im_col(j_max_index)
       n_emax = in_col(j_max_index)

c       if(ir .eq. 5 .and. i .eq. mn_col/2)
c     >   write(*,'(e15.7,2x,i4,2(2x,i4))') eig_max,m_emax,n_emax,
c     >    j_max_index

       if(ipos_def_sym) then
         write(21,'(2(e15.7,2x),i4,2x,i4)') r_pt,sqrt(abs(omega(i))),
     1     m_emax, n_emax
       else if(.NOT.ipos_def_sym) then
         write(21,'(4(e15.7,2x),i4,2x,i4)') r_pt, alfr(i),
     1     alfi(i),beta(i),m_emax, n_emax
       endif
      else if(iopt .eq. 0) then
       if(ipos_def_sym) then
        write(21,'(e15.7,2x,e15.7)') r_pt,sqrt(abs(omega(i)))
       else if(.NOT.ipos_def_sym) then
        write(21,'(e15.7,3(2x,e15.7))') r_pt,alfr(i),
     1     alfi(i),beta(i)
       endif
      endif
      end do          !do i=1,mn_col

      end do       !ir=1,ir_fine_scl
c
c
      close(unit=20)
      close(unit=21)
      close(unit=8)
      if(mype .eq. 0) write(*,
     > '("modes = ",i5,2x,"no. of radial points = ",i5)')
     >  mn_col,ir_fine_scl
      if(mype .eq. 0) write(7,'(i5,3(2x,i5))') iopt,mn_col,ir_fine_scl,
     >    isym_opt
      if(mype .eq. 0) close(unit=7)
      call trg_deallocate
      deallocate(alpha, beta, aux)
       if(mype .eq. 0) then
         call date_and_time(date, time, zone, values)
         write(*,*) time
       endif
#if defined (PARALLEL)
        call MPI_FINALIZE(ier)
#endif
      stop
      end program tae_continua


! 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 test
use libatoms_module
use potential_module
use vacancy_map_module

implicit none
  type(Atoms) at, at2, bulk, bulk1, bulk2
  type(Potential), target :: pot1, pot2
  type(Potential) :: hybridpot
  type(inoutput) params, out, in
  type(Table)    :: qmlist, core_list
  integer:: it, i, pass
  logical:: status
  integer, pointer :: hybrid_mark(:)
  integer center_i
  real(dp) :: e, ebulk, center(3), d
  real(dp), allocatable :: f(:,:)
  real(dp) :: lat(3,3), virial(3,3)
  character(len=256) arg
  type(MPI_Context) :: mpi
  integer :: imin, imax
  real(dp) :: dmax
  logical :: core_qm, vac_qm
  real(dp) :: core_qm_x, core_qm_z, r2
  type(Dictionary) :: cli_params
  character(len=1024) :: file_suffix
  integer :: n_supercell

  integer :: vac_qm_hops, buffer_hops

  call system_initialise(enable_timing=.true.,verbosity=PRINT_NORMAL)

  call initialise(mpi)

  call initialise(cli_params)
  call param_register(cli_params, "core_qm", "T", core_qm, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "buffer_hops", "1", buffer_hops, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "core_qm_x", "10.0", core_qm_x, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "core_qm_z", "5.0", core_qm_z, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "vac_qm", "F", vac_qm, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "vac_qm_hops", "1", vac_qm_hops, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "n_supercell", "4", n_supercell, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "imin", "0", imin, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "imax", "0", imax, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(cli_params, "dmax", "1.0e38", dmax, help_string="No help yet.  This source file was $LastChangedBy$")
  if (.not. param_read_args(cli_params)) then
    call print("Usage: vacancy_map_hybrid_generate [buffer_hops=i(1)]", PRINT_ALWAYS)
    call print("  [core_qm=l(T)] [core_qm_x=r(10.0)] core_qm_z=r(5.0)]", PRINT_ALWAYS)
    call print("  [vac_qm=l(F)] vac_qm_hops=i(1)] [n_supercell=i(4)]", PRINT_ALWAYS)
    call print("  [imin=i(0)] [imax=i(0)] [dmax=r(1.0e38)]", PRINT_ALWAYS)
    call system_abort("Confused by CLI arguments")
  end if
  call finalise(cli_params)

  call print("Using core_qm " // core_qm // " vac_qm " // vac_qm)
  if (core_qm .or. vac_qm) then
    call print("buffer_hops " // buffer_hops)
    if (core_qm) then
      call print("Using core_qm_x " // core_qm_x // " core_qm_z " // core_qm_z)
    endif
    if (vac_qm) then
      call print("Using vac_qm_hops " // vac_qm_hops)
    endif
  endif

  call Initialise(params, "quip_params_hybrid_generate.xml")
  call Initialise(pot1, 'TB NRL-TB label=Aluminum SCF=GLOBAL_U GLOBAL_U=20', params, mpi)
  call rewind(params)
  call Initialise(pot2, 'IP EAM_Ercolessi_Adams', params)
  call finalise(params)

  call print("Doing init_hybrid")
  call init_hybrid(pot1, pot2, hybridpot)

  ! read initial config
  call initialise(out, 'out.xyz', action=OUTPUT)
  call initialise(in, 'start.xyz')
  call read_xyz(at, in)
  call finalise(in)

  call add_property(at, 'hybrid_mark', 0)
  call add_property(at, 'weight_region1', 0.0_dp)

  !call print("minimizing initial config using mm")
  !call set_cutoff(at, cutoff(pot2)+0.5_dp)
  !call calc_connect(at)
  !it = minim(hybridpot, at, 'cg', 0.01_dp, 100, 'NR_LINMIN', do_print = .false., do_lat = .true., do_pos = .true.)

  allocate(f(3,at%N))
  call set_cutoff(at, cutoff(pot2))
  call calc_connect(at)
  call calc(hybridpot, at, e=e,f=f,virial=virial)
  call print ("Start relaxed E " // e // " max f component " // maxval(abs(f)) // " max virial component " // maxval(abs(virial)))
  deallocate(f)

  call print_xyz(at, out, "Dislocation_relaxed")

  ! compute vacancy starting configs with weights

  call supercell(at2, at, 1,n_supercell,1) ! length along the dislocation
  call set_cutoff(at2, 3.2_dp)
  call calc_connect(at2)

  center(:) = 0.0_dp

  if (.not. assign_pointer(at2, 'hybrid_mark', hybrid_mark)) &
    call system_abort("Couldn't find hybrid_mark in at2")

  hybrid_mark = HYBRID_NO_MARK

  mainlog%default_real_precision=2
  file_suffix = ""
  if (core_qm .or. vac_qm) then
    file_suffix = trim(file_suffix) // "buffer_hops_" // buffer_hops
    if (core_qm) then
      file_suffix = trim(file_suffix) // ".core_qm_x_"//core_qm_x//".core_qm_z_"//core_qm_z
    endif
  endif
  mainlog%default_real_precision=16

  ! core qm region
  if(core_qm) then

     call wipe(core_list)
     do i=1,at2%N
        r2 = (at2%pos(1,i)/core_qm_x)**2+(at2%pos(3,i)/core_qm_z)**2
        if(r2 < 1.0_dp) call append(core_list, (/i, 0, 0 ,0/))
     end do

     call print(core_list, PRINT_VERBOSE)

     hybrid_mark(int_part(core_list, 1)) = HYBRID_ACTIVE_MARK

     call create_local_energy_weights(at2, 1, buffer_hops) ! trans_width, buffer_width

     call print_xyz(at2, "start."//trim(file_suffix)//".xyz", properties="pos:Z:hybrid_mark:weight_region1")
  end if

  if(vac_qm) then

     ! add vacancy qm region
     if (imin <= 0) imin = 1
     if (imax > at2%N) imax = at%N
     do i=imin, imax

        d = distance_min_image(at, i, center)
        if (d > dmax) cycle

        call print("Making config with hybrid centered around atom " // i)

        hybrid_mark = HYBRID_NO_MARK

        call wipe(qmlist)

        call append(qmlist, (/i, 0,0, 0/))
        call bfs_grow(at2, qmlist, vac_qm_hops, nneighb_only = .false.) ! qm region

        hybrid_mark(int_part(qmlist, 1)) = HYBRID_ACTIVE_MARK
        if(core_qm) hybrid_mark(int_part(core_list, 1)) = HYBRID_ACTIVE_MARK

        call create_local_energy_weights(at2, 1, buffer_hops) ! trans_width, buffer_width

        call print_xyz(at2, "start.vac_i_"//i//".vac_qm_hops_"//vac_qm_hops//"."//trim(file_suffix)//".xyz", &
             comment="hybrid_center_i="//i//" hybrid_center='"//at2%pos(:,i)//"'", &
             properties="pos:Z:hybrid_mark:weight_region1")

     end do
  end if

  call system_finalise()
end program


c     Response function factor = 0.96178
      subroutine avhrr33(z0, p0, t0, u0, ux, nlev,
     *co2, n2o, f11, f12, ch4,
     *od, wght, ntau)
      INCLUDE "avhrr.inc"
      real co2, n2o, ch4, f11, f12
      real z0(mm)
      real od(4,mm)
      real wght(4)
      integer ntau,nlev
      real wi(8),xi(8),p0(mq),p(mm),t0(mq),t(mm),bnu(mm),u0(mq),u(mm),
     *uch4(mm),tau(6,mm),tauch4(6,mm),tauf(6,6,mm),x(mm,8),y(mm,8),
     *sx(6,6,mm),sy(6,6,mm),f(6),fch4(6),fac(mm),tsx(mq),tsy(mq)
      data xi /.01986,.10167,.23723,.40828,
     *         .59172,.76277,.89833,.98014/
      data wi /.05062,.11119,.15685,.18134,
     *         .18134,.15685,.11119,.05062/
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c0      omega=2660.5
c0      delw=360.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c1      omega=2525.0
c1      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c2      omega=2595.0
c2      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
      omega=2667.5
      delw=75.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c4      omega=2740.0
c4      delw=70.0
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
c5      omega=2817.5
c5      delw=85.0
      omegas=omega
      sigma=5.67e-05
      sconst=1.368e+06
      tsun=5710.0
      fsun=sigma*tsun**4
      mlv=nlyr
      do 5 m=1,nlyr
        t(m)=(t0(m)+t0(m+1))/2.0
        p(m)=(p0(m)+p0(m+1))/2.0
        call flux_33(bnu(m),omega,t(m))
        fac(m)=z0(m+1)-z0(m)
c       u(m)=fac(m)*(u0(m)+u0(m+1))/2.0*6.023e+23/2.687e+19/18.01534
        u(m)=fac(m)*(u0(m)+u0(m+1))/2.0
        uch4(m)=p(m)*1.01325e+06/(1.3805e-16*t(m))*ch4*1e-6*fac(m)*
     *       1.0e+05/6.023e+23*16.04303
 5    continue
      do 7 m=1,nlev
        tsx(m)=0.0
        tsy(m)=0.0
 7    continue
      call flux_33(back,omega,t0(1))
      call flux_33(bsun,omegas,tsun)
      bsun=bsun/fsun*sconst
      call ck_33(ni,mlv,u,delw,f,p,t,tau)
      call ckch4_33(nch4,mlv,uch4,delw,fch4,p,t,tauch4)
      do 10 m=1,nlyr
        do i=1,ni
          do ia=1,nch4
            tauf(i,ia,m)=tau(i,m)+tauch4(ia,m)
c           tauf(i,ia,m)=tauch4(ia,m)
c           tauf(i,ia,m)=tau(i,m)
          end do
        end do
 10   continue
      do 90 i=1,ni
       do 85 ia=1,nch4
        do 30 m=nlyr,1,-1
          do 20 j=1,8
           if(m.eq.nlyr)then
c           y(m,j)=bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
            y(m,j)=bsun*0.6*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           else
            y(m,j)=y(m+1,j)*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           end if
 20       continue
 30     continue
        do 50 m=1,nlyr
          sx(i,ia,m)=0.0
          sy(i,ia,m)=0.0
          do 40 j=1,8
           if(m.eq.1)then
c            x(m,j)=back*exp(-tauf(i,ia,m)/xi(j))+
c     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
            x(m,j)=(0.10*y(m,j)+0.90*back)*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           else
            x(m,j)=x(m-1,j)*exp(-tauf(i,ia,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tauf(i,ia,m)/xi(j)))
           end if
 40       continue
 50     continue
        do 70 m=1,nlyr
          do 60 j=1,8
            sx(i,ia,m)=sx(i,ia,m)+2.0*x(m,j)*wi(j)*xi(j)
            sy(i,ia,m)=sy(i,ia,m)+2.0*y(m,j)*wi(j)*xi(j)
 60       continue
 70     continue
        do 80 m=1,nlyr
           tsx(m+1)=tsx(m+1)+sx(i,ia,m)*delw*f(i)*fch4(ia)
           tsy(m)=tsy(m)+sy(i,ia,m)*delw*f(i)*fch4(ia)
 80     continue
        tb=tb+back*delw*f(i)*fch4(ia)
        tsx(1)=tb
 85    continue
 90   continue
      tb=0.10*tsy(1)+0.90*tb
      tsx(1)=tb
      tsy(nlev)=tsy(nlev)+bsun*0.60*delw
      do 95 m=1,nlev
cbm         write(6,100)m-1,tsx(m),tb-tsx(m),tsy(m)
 95   continue
      do i1=1,2
       do i2=1,2
        do m=1,nlyr
         od(1+(i2-1)+(i1-1)*2,m) =
     *tauf(i1,i2,m)
         wght(1+(i2-1)+(i1-1)*2) =
     *f(i1) * fch4(i2)
        enddo
       enddo
      enddo
      ntau=4
 100  format(i3,3f15.7)
      end
c *********************************************************************
      subroutine flux_33(bnu,omega,t)
      INCLUDE "avhrr.inc"
      bnu=0.0
      z=3.14159
      bnu=z/1000.0*((2.*6.625e-27)*(2.997925e+10)**2
     *    *omega**3)/(exp(min(88.0,1.4388*omega/t))-1.0)
      return
      end
c *********************************************************************
      subroutine ck_33(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=2
      f(1)=0.933205
      f(2)=0.066795
      k(1)=0.01953061
      do i=2,ni
        k(i)=48.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0386,0.0386,0.0386,0.0386,0.0386,0.0386,0.0386,0.0386,0.0386,
     *0.0599,0.0914,0.1366,0.2010,0.2930,0.4182,0.5861,0.8354,1.1911,
     *1.6361,
     *6.587e-05,6.587e-05,6.587e-05,6.587e-05,6.587e-05,6.587e-05,
     *6.587e-05,6.587e-05,6.587e-05,5.450e-05,3.075e-05,-1.113e-05,
     *-9.463e-05,-2.285e-04,-4.003e-04,-7.846e-04,-1.541e-03,-2.457e-03,
     *-3.263e-03,
     *1.531e-07,1.531e-07,1.531e-07,1.531e-07,1.531e-07,1.531e-07,
     *1.531e-07,1.531e-07,1.531e-07,2.875e-07,3.250e-07,5.469e-07,
     *8.031e-07,7.500e-07,7.875e-07,2.466e-06,3.372e-06,3.375e-06,
     *4.438e-07/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.2684,1.2684,1.2684,1.2684,1.2684,1.2684,1.2684,1.2684,1.2684,
     *1.2613,1.2526,1.2388,1.2195,1.1925,1.1565,1.1065,1.0439,0.9380,
     *0.7896,
     *-1.517e-03,-1.517e-03,-1.517e-03,-1.517e-03,-1.517e-03,-1.517e-03,
     *-1.517e-03,-1.517e-03,-1.517e-03,-1.535e-03,-1.530e-03,-1.501e-03,
     *-1.475e-03,-1.434e-03,-1.397e-03,-1.272e-03,-1.019e-03,-5.909e-04,
     *-3.600e-04,
     *-4.331e-06,-4.331e-06,-4.331e-06,-4.331e-06,-4.331e-06,-4.331e-06,
     *-4.331e-06,-4.331e-06,-4.331e-06,-3.694e-06,-3.491e-06,-3.741e-06,
     *-3.363e-06,-3.316e-06,-3.931e-06,-3.337e-06,-5.700e-06,-5.041e-06,
     *-2.831e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end
c**********************************************************************
      subroutine ckch4_33(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm),coefk(6,3,19),
     *     stp(19),fkg(6,mm),pmb(mm)
      ni=2
      f(1)=0.833250
      f(2)=0.166750
      k(1)=2.7367128
      do i=2,ni
        k(i)=24.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/
     *0.0433,0.0433,0.0433,0.0433,0.0433,0.0433,0.0433,0.0433,0.0433,
     *0.0685,0.1059,0.1605,0.2364,0.3391,0.4776,0.6578,0.8761,1.1501,
     *1.4554,
     *7.837e-05,7.837e-05,7.837e-05,7.837e-05,7.837e-05,7.837e-05,
     *7.837e-05,7.837e-05,7.837e-05,1.093e-04,1.633e-04,2.420e-04,
     *3.453e-04,4.586e-04,6.061e-04,8.044e-04,9.617e-04,1.254e-03,
     *1.535e-03,
     *-2.906e-07,-2.906e-07,-2.906e-07,-2.906e-07,-2.906e-07,-2.906e-07,
     *-2.906e-07,-2.906e-07,-2.906e-07,-6.937e-07,-1.050e-06,-1.369e-06,
     *-1.800e-06,-1.809e-06,-2.691e-06,-3.972e-06,-6.725e-06,-8.666e-06,
     *-9.725e-06/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/
     *1.2130,1.2130,1.2130,1.2130,1.2130,1.2130,1.2130,1.2130,1.2130,
     *1.2074,1.2007,1.1892,1.1737,1.1521,1.1232,1.0850,1.0295,0.9803,
     *0.9205,
     *2.866e-03,2.866e-03,2.866e-03,2.866e-03,2.866e-03,2.866e-03,
     *2.866e-03,2.866e-03,2.866e-03,2.848e-03,2.842e-03,2.821e-03,
     *2.809e-03,2.786e-03,2.761e-03,2.716e-03,2.601e-03,2.579e-03,
     *2.537e-03,
     *1.194e-06,1.194e-06,1.194e-06,1.194e-06,1.194e-06,1.194e-06,
     *1.194e-06,1.194e-06,1.194e-06,1.822e-06,1.103e-06,1.694e-06,
     *1.194e-06,1.356e-06,1.622e-06,1.713e-06,1.700e-06,2.503e-06,
     *2.784e-06/
	data stp / 0.251, 0.398, 0.631, 1.000, 1.58, 2.51,
     *	             3.98, 6.31, 10.0, 15.8, 25.1, 39.8, 63.1,
     *	             100.0, 158.0, 251.0, 398.0, 631.0, 1000.0/
      do i=1,ni
      do m=1,mlv
        ml=1
        pmb(m)=p(m)*1013.25
        if(pmb(m).lt.stp(1))then
         x1=coefk(i,1,1)+coefk(i,2,1)*(t(m)-250.0)
     *   +coefk(i,3,1)*(t(m)-250.0)**2
         fkg(i,m)=x1*pmb(m)/stp(1)
        else if (pmb(m).gt.stp(19)) then
         x1=coefk(i,1,18)+coefk(i,2,18)*(t(m)-250.0)
     *   +coefk(i,3,18)*(t(m)-250.0)**2
         x2=coefk(i,1,19)+coefk(i,2,19)*(t(m)-250.0)
     *   +coefk(i,3,19)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(19)-stp(18))
     *  *(pmb(m)-stp(18))
        else
         do while(pmb(m).ge.stp(ml))
           ml=ml+1
         end do
         x1=coefk(i,1,ml-1)+coefk(i,2,ml-1)*(t(m)-250.0)
     *   + coefk(i,3,ml-1)*(t(m)-250.0)**2
         x2=coefk(i,1,ml)+coefk(i,2,ml)*(t(m)-250.0)
     *   + coefk(i,3,ml)*(t(m)-250.0)**2
         fkg(i,m)=x1+(x2-x1)/(stp(ml)-stp(ml-1))
     *   *(pmb(m)-stp(ml-1))
        end if
      end do
      end do
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)*fkg(i,m)
c         write(6,*)m,i,u(m),k(i),fkg(i,m),tau(i,m)
        end do
      end do
      return
      end


      SUBROUTINE CALTSXY
C
C CHANGE RECORD
C ** SUBROUTINE CALTSXY UPDATES TIME VARIABLE SURFACE WIND STRESS
C
      USE GLOBAL
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::CLOUDTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::EVAPTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::PATMTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RAINTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::RHAT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SOLSWRTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::SVPAT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TATMTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::TWETTT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::VPAT
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDE
      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDN
!      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXX
!      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSXY
!      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYX
!      REAL,SAVE,ALLOCATABLE,DIMENSION(:)::WINDSYY
C
      IF(.NOT.ALLOCATED(CLOUDTT))THEN
        ALLOCATE(CLOUDTT(NASERM))
        ALLOCATE(EVAPTT(NASERM))
        ALLOCATE(PATMTT(NASERM))
        ALLOCATE(RAINTT(NASERM))
        ALLOCATE(RHAT(NASERM))
        ALLOCATE(SOLSWRTT(NASERM))
        ALLOCATE(SVPAT(NASERM))
        ALLOCATE(TATMTT(NASERM))
        ALLOCATE(TWETTT(NASERM))
        ALLOCATE(VPAT(NASERM))
        ALLOCATE(WINDE(NWSERM))
        ALLOCATE(WINDN(NWSERM))
!        ALLOCATE(WINDSXX(LCM))
!        ALLOCATE(WINDSXY(LCM))
!        ALLOCATE(WINDSYX(LCM))
!        ALLOCATE(WINDSYY(LCM))

        CLOUDTT=0.0
        EVAPTT=0.0
        PATMTT=0.0
        RAINTT=0.0
        RHAT=0.0
        SOLSWRTT=0.0
        SVPAT=0.0
        TATMTT=0.0
        TWETTT=0.0
        VPAT=0.0
        WINDE=0.0
        WINDN=0.0
        WINDSXX=0.0
        WINDSXY=0.0
        WINDSYX=0.0
        WINDSYY=0.0

        ! *** ONE TIME SPATIAL DISTRIBUTION,\
C *** OOPS, REVC & RCHC NOT SAVED FOR EACH SERIES
C        DO L=2,LA
C          CLEVAP(L)=0.
C          CCNHTT(L)=0.
C        ENDDO
C        DO NA=1,NASER
C          CLEVAPT=0.001*ABS(REVC)
C          CCNHTTT=0.001*ABS(RCHC)
C          DO L=2,LA
C            CLEVAP(L)=CLEVAP(L)+ATMWHT(L,NA)*CLEVAPT
C            CCNHTT(L)=CCNHTT(L)+ATMWHT(L,NA)*CCNHTTT
C          ENDDO
C        ENDDO
        DO L=2,LA
          CLEVAP(L)=0.001*ABS(REVC)
          CCNHTT(L)=0.001*ABS(RCHC)
        ENDDO
      ENDIF
C
C**********************************************************************C
C
C INITIALIZE WIND SHELTERED SURFACE GAS TRANSFER
C
      IF(N.EQ.-1.AND.NWSER.GT.0)THEN
        IF(DEBUG)THEN
          OPEN(1,FILE='WINDSHELT.OUT')
          CLOSE(1,STATUS='DELETE')
          OPEN(1,FILE='WINDSHELT.OUT')
        ENDIF
        DO L=2,LA
          I=IL(L)
          J=JL(L)
          IF(WINDSTKA(L).GT.0.0)THEN
            ! ** IF WINDSTKA > 0 BOTH X AND Y COMPONENTS ARE APPLIED
            WINDSXX(L)=CVN(L)
            WINDSXY(L)=-CVE(L)
            WINDSYX(L)=-CUN(L)
            WINDSYY(L)=CUE(L)
          ELSE
            ! ** IF WINDSTKA < 0 SLECTIVELY APPLY X AND Y COMPONENTS
            ! ** FIRST CASE IS FULLY OPEN WATER
            WINDSXX(L)=CVN(L)
            WINDSXY(L)=-CVE(L)
            WINDSYX(L)=-CUN(L)
            WINDSYY(L)=CUE(L)
            LS=LSC(L)
            LN=LNC(L)
            ! ** SECOND CASE IS 1D CHANNEL IN COMP X DIRECTION
            IF(SVB(L).LT.0.5.AND.IJCT(I,J-1).NE.5)THEN
              IF(SVB(LN).LT.0.5.AND.IJCT(I,J+1).NE.5)THEN
                WINDSXX(L)=CVN(L)
                WINDSXY(L)=-CVE(L)
                WINDSYX(L)=-1000.
                WINDSYY(L)=0.
              ENDIF
            ENDIF
            ! ** THIRD CASE IS 1D CHANNEL IN COMP Y DIRECTION
            IF(SUB(L).LT.0.5.AND.IJCT(I-1,J).NE.5)THEN
              IF(SUB(LEAST(L)).LT.0.5.AND.IJCT(I+1,J).NE.5)THEN
                WINDSXX(L)=0.
                WINDSXY(L)=-1000.
                WINDSYX(L)=-CUN(L)
                WINDSYY(L)=CUE(L)
              ENDIF
            ENDIF
          ENDIF
          IF(DEBUG)WRITE(1,1111)IL(L),JL(L),WINDSTKA(L),WINDSXX(L),
     &                          WINDSXY(L),WINDSYX(L),WINDSYY(L)
        ENDDO
        IF(DEBUG)CLOSE(1)
      ENDIF
 1111 FORMAT(2I5,10F10.6)
C
C**********************************************************************C
C
      IF(NWSER.GT.0)THEN
        ! *** UPDATE THE FORCING WIND DATA TO THE CURRENT TIME
        DO NA=1,NWSER
          IF(ISDYNSTP.EQ.0)THEN
            TIME=DT*FLOAT(N)/TCWSER(NA)+TBEGIN*(TCON/TCWSER(NA))
          ELSE
            TIME=TIMESEC/TCWSER(NA)
          ENDIF
          M1=MWTLAST(NA)
          MSAVE=M1
  200     CONTINUE
          M2=M1+1
          IF(TIME.GT.TWSER(M2,NA))THEN
            M1=M2
            GOTO 200
          ELSE
            MWTLAST(NA)=M1
          ENDIF
          TDIFF=TWSER(M2,NA)-TWSER(M1,NA)
          WTM1=(TWSER(M2,NA)-TIME)/TDIFF
          WTM2=(TIME-TWSER(M1,NA))/TDIFF
        IF(ISWDINT(NA).LE.1)THEN
          DEGM1=90.-WINDD(M1,NA)
          DEGM2=90.-WINDD(M2,NA)
          WINDS1=WTM1*WINDS(M1,NA)+WTM2*WINDS(M2,NA)
          WINDS2=WTM1*WINDS(M1,NA)+WTM2*WINDS(M2,NA)
          WINDE1=WINDS(M1,NA)*COS(DEGM1/57.29578)
          WINDN1=WINDS(M1,NA)*SIN(DEGM1/57.29578)
          WINDE2=WINDS(M2,NA)*COS(DEGM2/57.29578)
          WINDN2=WINDS(M2,NA)*SIN(DEGM2/57.29578)
          WINDE(NA)=WTM1*WINDE1+WTM2*WINDE2
          WINDN(NA)=WTM1*WINDN1+WTM2*WINDN2
        ELSE
          WINDS1=WTM1*WINDS(M1,NA)+WTM2*WINDS(M2,NA)
          WINDS2=WTM1*WINDS(M1,NA)+WTM2*WINDS(M2,NA)
          WINDE1=WINDS(M1,NA)
          WINDN1=WINDD(M1,NA)
          WINDE2=WINDS(M2,NA)
          WINDN2=WINDD(M2,NA)
          WINDE(NA)=WTM1*WINDE1+WTM2*WINDE2
          WINDN(NA)=WTM1*WINDN1+WTM2*WINDN2
          ENDIF
        ENDDO

        ! *** CALCULATE THE WIND STRESS
        IF(NWSER.GT.1)THEN
          DO L=2,LA
            WNDVELE(L)=0.
            WNDVELN(L)=0.
          ENDDO
          DO NA=1,NWSER
            DO L=2,LA
              WNDVELE(L)=WNDVELE(L)+WNDWHT(L,NA)*WINDE(NA)
              WNDVELN(L)=WNDVELN(L)+WNDWHT(L,NA)*WINDN(NA)
            ENDDO
          ENDDO
        ELSE    !IF(NWSER.EQ.1)THEN
          DO L=2,LA
            WNDVELE(L)=WINDE(1)
            WNDVELN(L)=WINDN(1)
          ENDDO
        ENDIF
C
        DO L=2,LA
          ! ** CASE 0 MAGNITUDE SHELTERING AND NO DIRECTIONAL SHELTERING
          IF(WINDSTKA(L).GT.0.0)THEN
            WNDFAC=ABS(WINDSTKA(L))
            WNDVELE(L)=WNDFAC*WNDVELE(L)
            WNDVELN(L)=WNDFAC*WNDVELN(L)
            WINDST(L)=SQRT( WNDVELE(L)*WNDVELE(L)
     &          +WNDVELN(L)*WNDVELN(L) )
            C2=1.2E-6*(0.8+0.065*WINDST(L))
            TSEAST=C2*WINDST(L)*WNDVELE(L)
            TSNORT=C2*WINDST(L)*WNDVELN(L)
            TSX(L)=WINDSXX(L)*TSEAST+WINDSXY(L)*TSNORT
            TSY(L)=WINDSYX(L)*TSEAST+WINDSYY(L)*TSNORT

          ELSEIF(WINDSTKA(L).LT.0.0)THEN
            ! ** CASE 1 MAGNITUDE SHELTERING AND DIRECTIONAL SHELTERING, OPEN WATER
            IF(WINDSYX(L).GT.-99.0.AND.WINDSXY(L).GT.-99.0)THEN
              WNDFAC=ABS(WINDSTKA(L))
              WNDVELE(L)=WNDFAC*WNDVELE(L)
              WNDVELN(L)=WNDFAC*WNDVELN(L)
              WINDST(L)=SQRT( WNDVELE(L)*WNDVELE(L)
     &            +WNDVELN(L)*WNDVELN(L) )
              C2=1.2E-6*(0.8+0.065*WINDST(L))
              TSEAST=C2*WINDST(L)*WNDVELE(L)
              TSNORT=C2*WINDST(L)*WNDVELN(L)
              TSX(L)=WINDSXX(L)*TSEAST+WINDSXY(L)*TSNORT
              TSY(L)=WINDSYX(L)*TSEAST+WINDSYY(L)*TSNORT
            ENDIF

            ! ** CASE 2 MAGNITUDE SHELTERING AND DIRECTIONAL SHELTERING, X CHANNEL
            IF(WINDSYX(L).LT.-99.0)THEN
              WINDXX=WINDSXX(L)*WNDVELE(L)+WINDSXY(L)*WNDVELN(L)
              WNDFAC=ABS(WINDSTKA(L))
              WINDXX=WNDFAC*WNDVELE(L)
              WINDST(L)=ABS(WINDXX)
              TSX(L)=1.2E-6*(0.8+0.065*WINDST(L))*WINDST(L)*WINDXX
              TSY(L)=0.
            ENDIF

            ! ** CASE 3 MAGNITUDE SHELTERING AND DIRECTIONAL SHELTERING, Y CHANNEL
            IF(WINDSXY(L).LT.-99.0)THEN
              WINDYY=WINDSYX(L)*WNDVELE(L)+WINDSYY(L)*WNDVELN(L)
              WNDFAC=ABS(WINDSTKA(L))
              WINDYY=WNDFAC*WINDYY
              WINDST(L)=ABS(WINDYY)
              TSX(L)=0
              TSY(L)=1.2E-6*(0.8+0.065*WINDST(L))*WINDST(L)*WINDYY
            ENDIF
          ENDIF
        ENDDO
      ENDIF
C
C          CFTSX=1.
C          CFTSY=1.
C          HHUU=2.*HUWET(L)
C          HHVV=2.*HVWET(L)
C
      IF(NASER.GT.0)THEN
        DO NA=1,NASER
          IF(ISDYNSTP.EQ.0)THEN
            TIME=DT*FLOAT(N)/TCASER(NA)+TBEGIN*(TCON/TCASER(NA))
          ELSE
            TIME=TIMESEC/TCASER(NA)
          ENDIF
          M1=MATLAST(NA)
  100     CONTINUE
          M2=M1+1
          IF(TIME.GT.TASER(M2,NA))THEN
            M1=M2
            GOTO 100
          ELSE
            MATLAST(NA)=M1
          ENDIF
          TDIFF=TASER(M2,NA)-TASER(M1,NA)
          WTM1=(TASER(M2,NA)-TIME)/TDIFF
          WTM2=(TIME-TASER(M1,NA))/TDIFF
          PATMTT(NA)=WTM1*PATM(M1,NA)+WTM2*PATM(M2,NA)
          TATMTT(NA)=WTM1*TDRY(M1,NA)+WTM2*TDRY(M2,NA)
          TWETTT(NA)=WTM1*TWET(M1,NA)+WTM2*TWET(M2,NA)
          RAINTT(NA)=WTM1*RAIN(M1,NA)+WTM2*RAIN(M2,NA)
          EVAPTT(NA)=WTM1*EVAP(M1,NA)+WTM2*EVAP(M2,NA)
          SOLSWRTT(NA)=WTM1*SOLSWR(M1,NA)+WTM2*SOLSWR(M2,NA)
          CLOUDTT(NA)=WTM1*CLOUD(M1,NA)+WTM2*CLOUD(M2,NA)
          SVPAT(NA)=
     &       10.**((0.7859+0.03477*TATMTT(NA))/(1.+0.00412*TATMTT(NA)))

          IF(IRELH(NA).EQ.0.AND.ISTOPT(2).NE.4)THEN
C            RHAT(NA)=1.
C     &          -0.00066*(PATMTT(NA)/SVPAT(NA))*(TATMTT(NA)-TWETTT(NA))
            ! *** DSLLC Begin
            ! *** (Correct RHA Computation from wet bulb)
            TMPVAL=0.00066*(1.0+0.00115*TWETTT(NA))
            SVPWET=
     &        10.**((0.7859+0.03477*TWETTT(NA))/(1.+0.00412*TWETTT(NA)))
            TMPVL1=SVPWET-TMPVAL*PATMTT(NA)*(TATMTT(NA)-TWETTT(NA))
            RHAT(NA)=MAX(TMPVL1/ SVPAT(NA),.01)
            ! *** DSLLC End
          ELSE
            RHAT(NA)=TWETTT(NA)
          ENDIF
          VPAT(NA)=RHAT(NA)*SVPAT(NA)
        ENDDO

C      ENDIF
C      IF(NASER.GT.0)THEN

        IF(NASER.GT.1)THEN
          DO L=2,LA
            PATMT(L)=0.
            TATMT(L)=0.
            RAINT(L)=0.
            EVAPT(L)=0.
            SOLSWRT(L)=0.
            CLOUDT(L)=0.
            SVPA(L)=0.
            RHA(L)=0.
            VPA(L)=0.
          ENDDO
          DO NA=1,NASER
            DO L=2,LA
              PATMT(L)=PATMT(L)+ATMWHT(L,NA)*PATMTT(NA)
              TATMT(L)=TATMT(L)+ATMWHT(L,NA)*TATMTT(NA)
              RAINT(L)=RAINT(L)+ATMWHT(L,NA)*RAINTT(NA)
              EVAPT(L)=EVAPT(L)+ATMWHT(L,NA)*EVAPTT(NA)
              SOLSWRT(L)=SOLSWRT(L)+ATMWHT(L,NA)*SOLSWRTT(NA)
              CLOUDT(L)=CLOUDT(L)+ATMWHT(L,NA)*CLOUDTT(NA)
              SVPA(L)=SVPA(L)+ATMWHT(L,NA)*SVPAT(NA)
              RHA(L)=RHA(L)+ATMWHT(L,NA)*RHAT(NA)
              VPA(L)=VPA(L)+ATMWHT(L,NA)*VPAT(NA)
            ENDDO
          ENDDO
        ELSE
          DO L=2,LA
            PATMT(L)=PATMTT(1)
            TATMT(L)=TATMTT(1)
            RAINT(L)=RAINTT(1)
            EVAPT(L)=EVAPTT(1)
            SOLSWRT(L)=SOLSWRTT(1)
            CLOUDT(L)=CLOUDTT(1)
            SVPA(L)=SVPAT(1)
            RHA(L)=RHAT(1)
            VPA(L)=VPAT(1)
          ENDDO
        ENDIF
       ! *** PMC - MOVED ALL TIME INVARIANT PARAMETERS TO KEEP FROM COMPUTING EVERY TIME
        IF(REVC.LT.0.)THEN
          CLEVAPTMP=0.001*ABS(REVC)
          DO L=2,LA
            CLEVAP(L)=1.E-3*(0.8+0.065*WINDST(L))
            CLEVAP(L)=MAX(CLEVAP(L),CLEVAPTMP)
          ENDDO
        ENDIF

        IF(RCHC.LT.0.)THEN
          CCNHTTTMP=0.001*ABS(RCHC)
          DO L=2,LA
            CCNHTT(L)=1.E-3*(0.8+0.065*WINDST(L))
            CCNHTT(L)=MAX(CCNHTT(L),CCNHTTTMP)
          ENDDO
        ENDIF
      ENDIF
C
      RETURN
      END


!-------------------------------------------------------------------------------
!> module SCALE-LES (a main routine of les model)
!!
!! @par Description
!!          SCALE: Scalable Computing by Advanced Library and Environment
!!          Numerical model for LES-scale weather
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2014-12-12 (R.Yoshida)  [mod] from program of scaleles
!!
!<
!-------------------------------------------------------------------------------
module mod_les_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use dc_log, only: &
     LogInit
  use gtool_file, only: &
     FileCloseAll
  use scale_precision
  use scale_stdio
  use scale_prof
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ included parameters
  !
#include "scale-les.h"
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: scaleles

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  character(len=H_MID), private, parameter :: MODELNAME = "SCALE-LES ver. "//VERSION

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine scaleles( &
       comm_world,       &
       intercomm_parent, &
       intercomm_child,  &
       cnf_fname         )
    use scale_process, only: &
       PRC_LOCAL_setup
    use scale_les_process, only: &
       PRC_setup
    use scale_const, only: &
       CONST_setup
    use scale_calendar, only: &
       CALENDAR_setup
    use scale_random, only: &
       RANDOM_setup
    use scale_grid_index, only: &
       GRID_INDEX_setup
    use scale_grid, only: &
       GRID_setup
    use scale_grid_nest, only: &
       NEST_setup
    use scale_land_grid_index, only: &
       LAND_GRID_INDEX_setup
    use scale_land_grid, only: &
       LAND_GRID_setup
    use scale_urban_grid_index, only: &
       URBAN_GRID_INDEX_setup
    use scale_urban_grid, only: &
       URBAN_GRID_setup
    use scale_tracer, only: &
       TRACER_setup
    use scale_fileio, only: &
       FILEIO_setup
    use scale_comm, only: &
       COMM_setup
    use scale_topography, only: &
       TOPO_setup
    use scale_landuse, only: &
       LANDUSE_setup
    use scale_grid_real, only: &
       REAL_setup
    use scale_gridtrans, only: &
       GTRANS_setup
    use scale_interpolation, only: &
       INTERP_setup
    use scale_les_statistics, only: &
       STAT_setup
    use scale_history, only: &
       HIST_setup, &
       HIST_write
    use scale_monitor, only: &
       MONIT_setup, &
       MONIT_write, &
       MONIT_finalize
    use scale_atmos_hydrostatic, only: &
       ATMOS_HYDROSTATIC_setup
    use scale_atmos_thermodyn, only: &
       ATMOS_THERMODYN_setup
    use scale_atmos_saturation, only: &
       ATMOS_SATURATION_setup
    use scale_bulkflux, only: &
       BULKFLUX_setup
    use scale_roughness, only: &
       ROUGHNESS_setup

    use mod_admin_restart, only: &
       ADMIN_restart_setup
    use mod_admin_time, only: &
       ADMIN_TIME_setup,      &
       ADMIN_TIME_checkstate, &
       ADMIN_TIME_advance,    &
       TIME_DOATMOS_step,     &
       TIME_DOLAND_step,      &
       TIME_DOURBAN_step,     &
       TIME_DOOCEAN_step,     &
       TIME_DOATMOS_restart,  &
       TIME_DOLAND_restart,   &
       TIME_DOURBAN_restart,  &
       TIME_DOOCEAN_restart,  &
       TIME_DOend
    use mod_atmos_admin, only: &
       ATMOS_admin_setup, &
       ATMOS_do
    use mod_atmos_vars, only: &
       ATMOS_vars_setup,                         &
       ATMOS_vars_diagnostics,                   &
       ATMOS_vars_monitor,                       &
       ATMOS_vars_restart_read,                  &
       ATMOS_sw_restart => ATMOS_RESTART_OUTPUT, &
       ATMOS_vars_restart_write,                 &
       ATMOS_sw_check => ATMOS_RESTART_CHECK,    &
       ATMOS_vars_restart_check
    use mod_atmos_driver, only: &
       ATMOS_driver_setup1,    &
       ATMOS_driver_setup2,    &
       ATMOS_driver,           &
       ATMOS_driver_firstsend, &
       ATMOS_driver_finalize,  &
       ATMOS_SURFACE_SET
    use mod_ocean_admin, only: &
       OCEAN_admin_setup, &
       OCEAN_do
    use mod_ocean_vars, only: &
       OCEAN_vars_setup,                         &
       OCEAN_vars_restart_read,                  &
       OCEAN_sw_restart => OCEAN_RESTART_OUTPUT, &
       OCEAN_vars_restart_write
    use mod_ocean_driver, only: &
       OCEAN_driver_setup, &
       OCEAN_driver,       &
       OCEAN_SURFACE_SET
    use mod_land_admin, only: &
       LAND_admin_setup, &
       LAND_do
    use mod_land_vars, only: &
       LAND_vars_setup,                        &
       LAND_vars_restart_read,                 &
       LAND_sw_restart => LAND_RESTART_OUTPUT, &
       LAND_vars_restart_write
    use mod_land_driver, only: &
       LAND_driver_setup, &
       LAND_driver,       &
       LAND_SURFACE_SET
    use mod_urban_admin, only: &
       URBAN_admin_setup, &
       URBAN_do
    use mod_urban_vars, only: &
       URBAN_vars_setup,                         &
       URBAN_vars_restart_read,                  &
       URBAN_sw_restart => URBAN_RESTART_OUTPUT, &
       URBAN_vars_restart_write
    use mod_urban_driver, only: &
       URBAN_driver_setup, &
       URBAN_driver,       &
       URBAN_SURFACE_SET
    use mod_cpl_admin, only: &
       CPL_admin_setup
    use mod_cpl_vars, only: &
       CPL_vars_setup
    use mod_user, only: &
       USER_setup0, &
       USER_setup, &
       USER_step
    implicit none

    integer,               intent(in) :: comm_world
    integer,               intent(in) :: intercomm_parent
    integer,               intent(in) :: intercomm_child
    character(len=H_LONG), intent(in) :: cnf_fname

    integer :: myrank
    logical :: ismaster
    !---------------------------------------------------------------------------

    !########## Initial setup ##########

    ! setup standard I/O
    call IO_setup( MODELNAME, .true., cnf_fname )

    ! setup MPI
    call PRC_LOCAL_setup( comm_world, & ! [IN]
                          myrank,     & ! [OUT]
                          ismaster    ) ! [OUT]

    ! setup Log
    call IO_LOG_setup( myrank, ismaster )
    call LogInit( IO_FID_CONF, IO_FID_LOG, IO_L )

    ! setup process
    call PRC_setup

    ! setup PROF
    call PROF_setup

    ! setup constants
    call CONST_setup

    ! setup calendar
    call CALENDAR_setup

    ! setup random number
    call RANDOM_setup

    ! setup time
    call ADMIN_TIME_setup( setup_TimeIntegration = .true. )

    call PROF_setprefx('INIT')
    call PROF_rapstart('Initialize', 0)

    ! setup horizontal/vertical grid coordinates (cartesian,idealized)
    call GRID_INDEX_setup
    call GRID_setup

    call LAND_GRID_INDEX_setup
    call LAND_GRID_setup

    call URBAN_GRID_INDEX_setup
    call URBAN_GRID_setup

    ! setup tracer index
    call TRACER_setup

    ! setup file I/O
    call FILEIO_setup

    ! setup mpi communication
    call COMM_setup

    ! setup topography
    call TOPO_setup
    ! setup land use category index/fraction
    call LANDUSE_setup
    ! setup grid coordinates (real world)
    call REAL_setup

    ! setup grid transfer metrics (uses in ATMOS_dynamics)
    call GTRANS_setup
    ! setup Z-ZS interpolation factor (uses in History)
    call INTERP_setup

    ! setup restart
    call ADMIN_restart_setup
    ! setup statistics
    call STAT_setup
    ! setup history I/O
    call HIST_setup
    ! setup monitor I/O
    call MONIT_setup

    ! setup nesting grid
    call NEST_setup ( intercomm_parent, intercomm_child )

    ! setup common tools
    call ATMOS_HYDROSTATIC_setup
    call ATMOS_THERMODYN_setup
    call ATMOS_SATURATION_setup

    call BULKFLUX_setup
    call ROUGHNESS_setup

    ! setup submodel administrator
    call ATMOS_admin_setup
    call OCEAN_admin_setup
    call LAND_admin_setup
    call URBAN_admin_setup
    call CPL_admin_setup

    ! setup variable container
    call ATMOS_vars_setup
    call OCEAN_vars_setup
    call LAND_vars_setup
    call URBAN_vars_setup
    call CPL_vars_setup

    ! read restart data
    if( ATMOS_do ) call ATMOS_vars_restart_read
    if( OCEAN_do ) call OCEAN_vars_restart_read
    if( LAND_do  ) call LAND_vars_restart_read
    if( URBAN_do ) call URBAN_vars_restart_read

    ! setup user-defined procedure before setup of other components
    call USER_setup0

    ! calc diagnostics
    call ATMOS_vars_diagnostics

    ! first monitor
    call ATMOS_vars_monitor

    ! setup surface condition
    call ATMOS_SURFACE_SET( countup=.false. )
    call OCEAN_SURFACE_SET( countup=.false. )
    call LAND_SURFACE_SET ( countup=.false. )
    call URBAN_SURFACE_SET( countup=.false. )

    ! setup submodel driver
    call ATMOS_driver_setup1
    call OCEAN_driver_setup
    call LAND_driver_setup
    call URBAN_driver_setup
    call ATMOS_driver_setup2

    ! setup user-defined procedure
    call USER_setup

    ! history&monitor file output
    call HIST_write ! if needed
    call MONIT_write('MAIN')

    call PROF_rapend('Initialize', 0)

    !########## main ##########

#ifdef _FIPP_
    call fipp_start
#endif
#ifdef _PAPI_
    call PROF_PAPI_rapstart
#endif

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '++++++ START TIMESTEP ++++++'
    call PROF_setprefx('MAIN')
    call PROF_rapstart('Main_Loop', 0)

    if( ATMOS_do ) call ATMOS_driver_firstsend

    do

      ! report current time
      call ADMIN_TIME_checkstate

      ! time advance
      call ADMIN_TIME_advance

      ! user-defined procedure
      call USER_step

      ! change to next state
      if( OCEAN_do .AND. TIME_DOOCEAN_step ) call OCEAN_driver
      if( LAND_do  .AND. TIME_DOLAND_step  ) call LAND_driver
      if( URBAN_do .AND. TIME_DOURBAN_step ) call URBAN_driver
      if( ATMOS_do .AND. TIME_DOATMOS_step ) call ATMOS_driver

      ! history&monitor file output
      call HIST_write
      call MONIT_write('MAIN')

      ! restart output
      if( OCEAN_sw_restart .AND. TIME_DOOCEAN_restart ) call OCEAN_vars_restart_write
      if( LAND_sw_restart  .AND. TIME_DOLAND_restart  ) call LAND_vars_restart_write
      if( URBAN_sw_restart .AND. TIME_DOURBAN_restart ) call URBAN_vars_restart_write
      if( ATMOS_sw_restart .AND. TIME_DOATMOS_restart ) call ATMOS_vars_restart_write

      if( TIME_DOend ) exit

      if( IO_L ) call flush(IO_FID_LOG)

    enddo

    if( ATMOS_do ) call ATMOS_driver_finalize

    call PROF_rapend('Main_Loop', 0)
    if( IO_L ) write(IO_FID_LOG,*) '++++++ END TIMESTEP ++++++'
    if( IO_L ) write(IO_FID_LOG,*)

#ifdef _FIPP_
    call fipp_stop
#endif
#ifdef _PAPI_
    call PROF_PAPI_rapstop
#endif

    !########## Finalize ##########

    ! check data
    if( ATMOS_sw_check ) call ATMOS_vars_restart_check

    call PROF_rapreport
#ifdef _PAPI_
    call PROF_PAPI_rapreport
#endif

    call MONIT_finalize

    call FileCloseAll

    return
  end subroutine scaleles

end module mod_les_driver