C----------------------------------------------------------------------
C The program monte.f simulates the population of white dwarfs in the
C solar environment. It distributes randomly n points following a
C uniform distribution in the galactic plane and an exponential
C distribution in the perpendicular plane. It adds velocity distribution
C at each point. From the cooling tables it interpolates brightness and
C cooling times. Version B: In this version, the SFR function, within
C each interval in which the time of the galaxy is divided, determines
C the mass of stars to share. Each mass that is generated, following
C the IMF, is assigned with a birth time according to the SFR. Finally
C the maximum volume method is used to calculate the density function of
C white dwarfs.
C----------------------------------------------------------------------

C     adding FileInfo type which carries all the info about
C     files of cooling and color tables: fort.xx links, numbers of rows
C     and columns, metallicities
C     NOTE: modules are better than includes
      include 'code/external_types.f'

      program monte
      use external_types
      implicit real (a-h,m,o-z)

C     'external' statement specifies that 'ran' function is no longer
C     intrinsic and must be defined in program
      external ran
      real ran

C     thin_disk_age (Gyr)
C     parameterOfSFR (taus): Y=exp(-t/taus)
C     solarGalactocentricDistance: distance from Sun to Galaxy center;
C     parameterIMF (alpha): M^{alpha}
C     Initial-to-Final Mass Relation (IFMR) :
C         mfinal_new=parameterIFMR*mfinal_old
      integer numberOfStars
      real :: thin_disk_age,
     &        parameterOfSFR,
     &        parameterIMF,
     &        scaleLength,
     &        pi,
     &        thick_disk_age,
     &        halo_age,
     &        halo_stars_formation_time,
     &        thick_disk_sfr_param
      double precision :: solarGalactocentricDistance
      parameter (numberOfStars=6000000)
      parameter (solarGalactocentricDistance=8.5d0)
      parameter (parameterOfSFR=25.0)
      parameter (scaleLength=3.5)
      integer i,j,k,ISEED1,ISEED2,iseed,numberOfStarsInSample
      real randomNumber,fractionOfDB
      real parameterIFMR, burst_age
C     For terminal:
      integer :: num_args
      character(len = 30) :: arg
      character(len = 30) :: temp_string
      real :: massReductionFactor
      real :: thick_disk_stars_fraction,
     &        halo_stars_fraction,
     &        radius
      character(len = 100) :: output_filename
      character(len = 6) :: geometry
      real :: cone_height_longitude,
     &        cone_height_latitude
      real, allocatable :: cone_height_longitudes(:),
     &                     cone_height_latitudes(:)
      real :: min_longitude, max_longitude,
     &        min_latitude, max_latitude
      real :: u_ubvrij(numberOfStars),
     &        b_ubvrij(numberOfStars),
     &        v_ubvrij(numberOfStars),
     &        r_ubvrij(numberOfStars),
     &        i_ubvrij(numberOfStars),
     &        j_ubvrij(numberOfStars)
      logical :: is_numeric, longitudes_from_csv, latitudes_from_csv
      integer :: iterations_count, getNumberOfLines

          character(len=:), allocatable :: filename
          character(len=:), allocatable :: longitude_filename,
     &                                     latitude_filename
          character(len=:), allocatable :: column_number_str
          character(len=50), allocatable :: junk(:)
          integer :: dash_index
          integer :: column_number
          integer :: lines_count, longitude_column, latitude_column

      TYPE(FileGroupInfo),DIMENSION(11) :: table

      common /RSEED/ ISEED1,ISEED2
      common /param/ fractionOfDB,thin_disk_age,parameterIMF,
     &               parameterIFMR,burst_age

C     Filling info about groups of files (cooling, color tables)
      call fillTable(table)

C     Terminal reading
      num_args = iargc()

      if (num_args .eq. 0) then
        fractionOfDB = 0.20
        thin_disk_age = 9.2
        parameterIMF = -2.35
        parameterIFMR = 1.0
        burst_age = 0.6
      else
        do i = 1, num_args
C           call get_command_argument(i, args(i))
          call getarg(i, arg)
          select case(arg)
            case ("-db")
              call getarg(i + 1, temp_string)
              read(temp_string, *) fractionOfDB
            case ("-g")
              call getarg(i + 1, temp_string)
              read(temp_string, *) thin_disk_age
            case ("-tda")
              call getarg(i + 1, temp_string)
              read(temp_string, *) thick_disk_age
            case ("-ha")
              call getarg(i + 1, temp_string)
              read(temp_string, *) halo_age
            case ("-hsft")
              call getarg(i + 1, temp_string)
              read(temp_string, *) halo_stars_formation_time
            case ("-tde")
              call getarg(i + 1, temp_string)
              read(temp_string, *) thick_disk_sfr_param
            case ("-mf")
              call getarg(i + 1, temp_string)
              read(temp_string, *) parameterIMF
            case ("-ifr")
              call getarg(i + 1, temp_string)
              read(temp_string, *) parameterIFMR
            case ("-bt")
              call getarg(i + 1, temp_string)
              read(temp_string, *) burst_age
            case ("-mr")
              call getarg(i + 1, temp_string)
              read(temp_string, *) massReductionFactor
            case ("-tdsf")
              call getarg(i + 1, temp_string)
              read(temp_string, *) thick_disk_stars_fraction
            case ("-hsf")
              call getarg(i + 1, temp_string)
              read(temp_string, *) halo_stars_fraction
            case ("-rad")
              call getarg(i + 1, temp_string)
              read(temp_string, *) radius
            case ("-o")
              call getarg(i + 1, output_filename)
            case ('-geom')
              call getarg(i + 1, geometry)
            case('-cl')
              call getarg(i + 1, temp_string)
              longitudes_from_csv = .FALSE.
              allocate(cone_height_longitudes(1))
              read(temp_string, *) cone_height_longitudes(1)
            case ('-clcsv')
              call getarg(i + 1, temp_string)
              longitudes_from_csv = .TRUE.
              longitude_filename = trim(temp_string)
            case ('-clcol')
              call getarg(i + 1, temp_string)
              longitudes_from_csv = .TRUE.
              read(temp_string, *) longitude_column
            case('-cb')
              call getarg(i + 1, temp_string)
              latitudes_from_csv = .FALSE.
              allocate(cone_height_latitudes(1))
              read(temp_string, *) cone_height_latitudes(1)
            case ('-cbcsv')
              call getarg(i + 1, temp_string)
              latitudes_from_csv = .TRUE.
              latitude_filename = trim(temp_string)
            case ('-cbcol')
              call getarg(i + 1, temp_string)
              latitudes_from_csv = .TRUE.
              read(temp_string, *) latitude_column
            end select
        end do
      end if

      if (longitudes_from_csv .eqv. .true.) then
        allocate(junk(longitude_column - 1))
        lines_count = getNumberOfLines(longitude_filename)
        allocate(cone_height_longitudes(lines_count))
        open(597, file = longitude_filename)
        do j = 1, lines_count
            read(597, *) junk, cone_height_longitudes(j)
        end do
        close(597)
        deallocate(junk)
      end if
      if (latitudes_from_csv .eqv. .true.) then
        allocate(junk(latitude_column - 1))
        lines_count = getNumberOfLines(latitude_filename)
        allocate(cone_height_latitudes(lines_count))
        open(597, file = latitude_filename)
        do j = 1, lines_count
            read(597, *) junk, cone_height_latitudes(j)
        end do
        close(597)
        deallocate(junk)
      end if

      if (geometry == 'sphere') then
          allocate(cone_height_latitudes(1))
          allocate(cone_height_longitudes(1))
      end if

      write(6,*) '=========================================='
      write(6,*) ' '
      write(6,*) '            Program monte.f'
      write(6,*) '          by S.Torres, 14.02.11 '
      write(6,*) ' '
      write(6,*) '            Used parameters:'
      write(6,*) 'numberOfStars=    ',numberOfStars
      write(6,*) 'SFR: parameterOfSFR=',parameterOfSFR,'Gyr'
      write(6,*) 'thin disk age=      ',thin_disk_age,'Gyr'
      write(6,*) 'area radius=        ',radius,'kpc'
      write(6,*) ' '
      write(6,*) '=========================================='
      write(6,*) ' '
      write(6,*) '          Start of calculations:'
      write(6,*) ' '
      write(6,*) 'Initializing random number generator and reading the s
     &eeds'
      write(6,*) ' '

C     Reading seeds line from $temporary_files/seeds_line.in
      iseed = -9
C     This is done for cone geometry and 5000 plates as we don't want
C     the sequence of RNs to repeat itself(init:805577 133547):
      open(unit=772, file='input_data/seeds_line.in')
      read(unit=772, fmt=*) iseed1, iseed2
      close(unit=772)
      if (geometry == 'cones') then
          iseed1 = iseed1 - 1
          iseed2 = iseed2 + 1
      end if
      open(unit=772, file='input_data/seeds_line.in', status='replace')
      write(unit=772, fmt=100) iseed1,iseed2
      close(unit=772)
 100  format(I6,2x,I6)
      write(6,*) 'iseed1=', iseed1
      write(6,*) 'iseed2=', iseed2
C     QUESTION: why do we need this part?
      do i=1,10
        randomNumber=ran(iseed)
        write (6,*) i,randomNumber
      end do

      pi=4.0*atan(1.0)

      write(6,*) '1. Reading the cooling tables (1/9)'

      write(6,*) '   1.1 Tracks of CO DA WD Z=0.001;0.01;0.03;0.06'
C     Calling the function 'incoolda' for 4 metalicities that we have
      call incoolda(table(1))
      call incoolda(table(2))
      call incoolda(table(3))
      call incoolda(table(4))

      write(6,*) '   1.2 Tracks of CO non-DA (DB) WD'
C     Calling the function 'incooldb' for 3 metalicities that we have
      call incooldb(table(5))
      call incooldb(table(6))
      call incooldb(table(7))

      write(6,*) '   1.3 Tracks of ONe DA WD'
      call incoolone

      write(6,*) '   1.4 Reading the colors table of Rene(DAs) and Berge
     &ron(DBs)'
      call color(table(11))
      call colordb(table(10))

      if ((longitudes_from_csv .eqv. .false.) .and.
     &      (latitudes_from_csv .eqv. .false.)) then
          iterations_count = 1
      else if ((longitudes_from_csv .eqv. .true.) .and.
     &         (latitudes_from_csv .eqv. .false.)) then
          iterations_count = size(cone_height_longitudes)
      else if ((longitudes_from_csv .eqv. .false.) .and.
     &         (latitudes_from_csv .eqv. .true.)) then
          iterations_count = size(cone_height_latitudes)
      else
          iterations_count = size(cone_height_latitudes)
          if (size(cone_height_latitudes)
     &        /= size(cone_height_longitudes)) then
          end if
      end if

C     TODO: add choosing what output we want to get
      open(421, file = output_filename)
      if (geometry == 'sphere') then
          write(421, *) 'mass ',
     &                  'luminosity ',
     &                  'r_galactocentric ',
     &                  'th_galactocentric ',
     &                  'z_coordinate ',
     &                  'galactic_longitude ',
     &                  'galactic_latitude ',
     &                  'right_ascension ',
     &                  'declination ',
     &                  'j_abs_magnitude ',
     &                  'b_abs_magnitude ',
     &                  'v_abs_magnitude ',
     &                  'r_abs_magnitude ',
     &                  'i_abs_magnitude ',
     &                  'u_velocity ',
     &                  'v_velocity ',
     &                  'w_velocity ',
     &                  'proper_motion_component_b ',
     &                  'proper_motion_component_l ',
     &                  'proper_motion ',
     &                  'distance ',
     &                  'birth_time ',
     &                  'spectral_type ',
     &                  'galactic_disk_type '
      else if (geometry == 'cones') then
          write(421, *) 'u_velocity ',
     &                  'v_velocity ',
     &                  'w_velocity ',
     &                  'distance ',
     &                  'galactic_longitude ',
     &                  'galactic_latitude ',
     &                  'galactic_disk_type ',
     &                  'spectral_type'
      end if
      close(421)

      do i = 1, iterations_count
          print *, 'Iteration Nº', i
C         converting cone height parameters from deg to rad
          if (geometry == 'cones') then
              cone_height_longitudes(i) = cone_height_longitudes(i)
     &                                    * pi / 180.0
              cone_height_latitudes(i) = cone_height_latitudes(i)
     &                                   * pi / 180.0
          end if

          write(6,*) '2. Calling the IMF and SFR (2/9)'
          if (geometry == 'sphere') then
              call gen(iseed,parameterOfSFR,radius,
     &                 numberOfStarsInSample,thin_disk_age,
     &                 burst_age,massReductionFactor,
     &                 thick_disk_stars_fraction,
     &                 halo_stars_fraction, thick_disk_age,
     &                 thick_disk_sfr_param,
     &                 halo_age, halo_stars_formation_time)
          else if (geometry == 'cones') then
              call generate_cone_stars(cone_height_longitudes(i),
     &                                 cone_height_latitudes(i),
     &                                 numberOfStarsInSample,iseed,
     &                                 thick_disk_stars_fraction,
     &                                 thin_disk_age,
     &                                 min_longitude, max_longitude,
     &                                 min_latitude, max_latitude,
     &                                 massReductionFactor)
          else
              write(6,*) "wrong geometry name, use 'sphere' or 'cones'"
          end if
          write(6,*) "numberOfStarsInSample=", numberOfStarsInSample

          write(6,*) '3. Calculating luminosities (3/9)'
          call lumx(numberOfStarsInSample, thick_disk_age, halo_age)

          ! if cone then we already calculated them
          if (geometry == 'sphere') then
              write(6,*) '4. Calculating polar coordinates (4/9)'
              call polar(iseed, radius,
     &                   solarGalactocentricDistance, scaleLength)
          end if

          write(6,*) '5. Generating heliocentric velocities (5/9)'
          call velh(iseed,numberOfStarsInSample,geometry)

C         TODO: find out why we are missing the next step
          goto 7
C         Calculating the trajectories according to/along z-coordinate
          write(6,*) '6. Integrating trajectories (6/9)'
          call traject(thin_disk_age)

7         write(6,*) '7. Calculating coordinates (7/9)'
          call coor(solarGalactocentricDistance)

          write(6,*) '8. Determinating visual magnitudes (8/9)'
          call magi(fractionOfDB,
     &              table,
     &              u_ubvrij,
     &              b_ubvrij,
     &              v_ubvrij,
     &              r_ubvrij,
     &              i_ubvrij,
     &              j_ubvrij)

C         TODO: redo checking processed cones
          call printForProcessing(output_filename, geometry, iseed,
     &         min_longitude, max_longitude, min_latitude, max_latitude,
     &         solarGalactocentricDistance,cone_height_longitudes(i),
     &         cone_height_latitudes(i),
     &         u_ubvrij, b_ubvrij, v_ubvrij, r_ubvrij, i_ubvrij,
     &         j_ubvrij)
          open(765, file='processed_cones.txt')
          write(unit=765,fmt=*) cone_height_longitudes(i),
     &                          cone_height_latitudes(i)
          close(765)
          print *, "_______________END OF ITERATION____________________"
      end do
      open  (unit=765, file="processed_cones.txt", status="old")
      close (unit=765, status="delete")

      write (6,*) 'End'

      stop
      end
C***********************************************************************
      include 'code/star_generation/generator.f'

      include 'code/star_generation/cone.f'

      include 'code/cooling/DA/DA_cooling.f'

      include 'code/colors/DA/byRenedo.f'

      include 'code/luminosities/luminosities.f'

      include 'code/coordinates/polar.f'

      include 'code/velocities/velocities.f'

      include 'code/math/random_number_generators.f'

      include 'code/trajectories/trajectories.f'

      include 'code/coordinates/coor.f'

      include 'code/magnitudes/magi.f'

      include 'code/magnitudes/DA/interlumda.f'

      include 'code/DA_DB_fraction/dbd_fid.f'

      include 'code/magnitudes/DA/intermag.f'

      include 'code/magnitudes/DB/interlumdb.f'

      include 'code/colors/DB/byBergeron.f'

      include 'code/cooling/ONe/incoolone.f'

      include 'code/cooling/DB/incooldb.f'

      include 'code/magnitudes/ONe/interlumONe.f'

      include 'code/magnitudes/interp.f'

      include 'code/colors/chanco.f'

      include 'code/math/toSort.f'

      include 'code/tables_linking.f'

      include 'code/extinction/extinc.f'

      include 'code/colors/errors/errfot.f'

      subroutine printForProcessing(output_filename, geometry, iseed,
     &         min_longitude, max_longitude, min_latitude, max_latitude,
     &         solarGalactocentricDistance,cone_height_longitude,
     &         cone_height_latitude, u_ubvrij, b_ubvrij, v_ubvrij,
     &         r_ubvrij, i_ubvrij, j_ubvrij)
      implicit none
      external ran
      real ran
      character(len = 100), intent(in) :: output_filename
      character(len = 6) :: geometry
      integer i,j, iseed
      logical eleminationFlag
      integer numberOfStars,numberOfWDs
      integer eleminatedByParallax,eleminatedByDeclination,
     &        eleminatedByProperMotion,eleminatedByApparentMagn,
     &        eleminatedByReducedPropM
      real parameterIFMR
      real minimumProperMotion,declinationLimit,
     &                 minimumParallax
      real mbolmin,mbolinc,mbolmax
      real errinfa,errsupa,mbol
      real fnora,fnor,pi,vvv,x,xx,xya
      real min_longitude, max_longitude, min_latitude,
     &                 max_latitude
      double precision :: solarGalactocentricDistance
      real prev_min_longitude, prev_max_longitude,
     &                 prev_min_latitude, prev_max_latitude

      parameter (numberOfStars=6000000)
C     (Only northern hemisphere)
      parameter (declinationLimit=0.0)
C     Minimum parallax below which we discard results (0.025<=>40 pc)
      parameter (minimumParallax=0.025)
C     Binning of Luminosity Function
      parameter (mbolmin=5.75,mbolmax=20.75,mbolinc=0.5)
C     Minimum proper motion
      parameter (minimumProperMotion=0.04)
C     Parameters of mass histograms

      real :: u_ubvrij(numberOfStars),
     &        b_ubvrij(numberOfStars),
     &        v_ubvrij(numberOfStars),
     &        r_ubvrij(numberOfStars),
     &        i_ubvrij(numberOfStars),
     &        j_ubvrij(numberOfStars)
      double precision :: properMotion(numberOfStars),
     &                    rightAscension(numberOfStars),
     &                    declination(numberOfStars)
      real luminosityOfWD(numberOfStars),
     &                 massOfWD(numberOfStars),
     &                 metallicityOfWD(numberOfStars),
     &                 effTempOfWD(numberOfStars)
      integer :: flagOfWD(numberOfStars)
C     rgac - galactocentric distance to WD TODO: give a better name
      real rgac(numberOfStars)
      double precision :: lgac(numberOfStars),
     &                    bgac(numberOfStars)
      real :: coolingTime(numberOfStars)
C     NOTE: this 70 comes from nowhere
      integer numberOfWDsInBin(70),numberOfBins
      double precision :: coordinate_R(numberOfStars),
     &                    coordinate_Theta(numberOfStars),
     &                    coordinate_Zcylindr(numberOfStars)
      real parallax(numberOfStars)
      real tangenVelo(numberOfStars)
      real longitude_proper_motion(numberOfStars),
     &     latitude_proper_motion(numberOfStars),
     &     radial_velocity(numberOfStars)
      real errora(70),ndfa(70)
      real massInBin(70)
      integer :: typeOfWD(numberOfStars)
C     values of LF in each bin. o-observational
      real xfl(19),xflo(19),xflcut(3),xflocut(3)
      real xflhot(11),xflohot(11)
C     bins for max-region: for synthetic and observational samples
      real xflMaxRegion(6), xfloMaxRegion(6)
C     number of WDs in bin of mass histogram
      real nbinmass(26)
C     WDs velocities. QUESTION: relative to what?
      real uu(numberOfStars), vv(numberOfStars),
     &                 ww(numberOfStars)
C     sum of WDs velocities in specific bin, _u/_v/_w - components
      real sumOfWDVelocitiesInBin_u(70),
     &                 sumOfWDVelocitiesInBin_v(70),
     &                 sumOfWDVelocitiesInBin_w(70)
C     average velocity for WDs in specific bin
      real averageWDVelocityInBin_u(70),
     &                 averageWDVelocityInBin_v(70),
     &                 averageWDVelocityInBin_w(70)
C     this is used to calculate sigma (SD)
      real sumOfSquareDifferences_u,
     &                 sumOfSquareDifferences_v,
     &                 sumOfSquareDifferences_w
C     SD for velocities in each bin
      real standardDeviation_u(70),standardDeviation_v(70),
     &                 standardDeviation_w(70)
C     2D-array of velocities (nº of bin; newly assigned to WD nº in bin)
C     needed to calculate Standart Deviation (SD) for velocities in each
C     bin
      real arrayOfVelocitiesForSD_u(25,50000)
      real arrayOfVelocitiesForSD_v(25,50000)
      real arrayOfVelocitiesForSD_w(25,50000)
C     2D-array of bolometric magnitudes for each WD; indexes are the
C     same as for arrayOfVelocitiesForSD_u/v/w. (For cloud)
      real arrayOfMagnitudes(25,50000)
      real x_coordinate,y_coordinate,z_coordinate,
     & star_longitude, star_latitude
      integer disk_belonging(numberOfStars)
      logical :: overlapping_cone
      integer :: getNumberOfLines, overlapping_cones_count, lines_count
      real, allocatable :: overlap_min_longitudes(:)
      real, allocatable :: overlap_max_longitudes(:)
      real, allocatable :: overlap_min_latitudes(:)
      real, allocatable :: overlap_max_latitudes(:)
      real latitude, longitude,zzx,cone_height_longitude
      double precision :: ros
      real cone_height_latitude
      logical :: with_overlapping_checking = .true.
      integer processed_cones_count, overlappings, stars_counter,
     & eliminations_counter
      real DELTA_LATITUDE,delta_longitude,prev_cone_latitude
      real prev_cone_longitude
      logical longitude_overlapping, latitude_overlapping,
     &  star_in_intersection
      character(len=:), allocatable :: disk_str
      real :: gal_to_equat_angle = 2.147
      real :: right_ascension_prop_motion,
     &        declination_prop_motion,
     &        total_prop_motion
      real :: m(numberOfStars),
     &        starBirthTime(numberOfStars)
      common /enanas/ luminosityOfWD,massOfWD,metallicityOfWD,
     &                effTempOfWD
      common /index/ flagOfWD,numberOfWDs,disk_belonging
      common /mad/ properMotion,rightAscension,declination
      common /mopro/ latitude_proper_motion,
     &               longitude_proper_motion,
     &               radial_velocity
      common /paral/ rgac
      common /lb/ lgac,bgac
      common /coorcil/ coordinate_R,coordinate_Theta,coordinate_Zcylindr
      common /cool/ coolingTime
      common /indexdb/ typeOfWD
      common /vel/ uu,vv,ww
      common /tm/ starBirthTime,
     &            m

      pi = 4.0 * atan(1.0)
      DELTA_LATITUDE = 2.64 * pi / 180.0
      overlappings = 0
      stars_counter = 0
      eliminations_counter = 0

      open(421, file = output_filename, access='append')
      if (geometry == 'sphere') then
          do i = 1, numberOfWDs
              if (disk_belonging(i) == 1) then
                  disk_str = 'thin'
              else if (disk_belonging(i) == 2) then
                  disk_str = 'thick'
              else if (disk_belonging(i) == 3) then
                  disk_str = 'halo'
              end if

              right_ascension_prop_motion = (
     &            sin(gal_to_equat_angle)
     &            * longitude_proper_motion(i)
     &            - cos(gal_to_equat_angle)
     &              * latitude_proper_motion(i))
              declination_prop_motion = (cos(gal_to_equat_angle)
     &                                   * longitude_proper_motion(i)
     &                                   + sin(gal_to_equat_angle)
     &                                     * latitude_proper_motion(i))
              total_prop_motion = real(
     &            sqrt(right_ascension_prop_motion ** 2
     &                 * cos(declination(i)) ** 2
     &                 + declination_prop_motion ** 2))

              write(421, *) massOfWD(i),
     &                      luminosityOfWD(i),
     &                      coordinate_R(i),
     &                      coordinate_Theta(i),
     &                      coordinate_Zcylindr(i),
     &                      lgac(i),
     &                      bgac(i),
     &                      rightAscension(i),
     &                      declination(i),
     &                      j_ubvrij(i),
     &                      b_ubvrij(i),
     &                      v_ubvrij(i),
     &                      r_ubvrij(i),
     &                      i_ubvrij(i),
     &                      uu(i),
     &                      vv(i),
     &                      ww(i),
     &                      latitude_proper_motion(i),
     &                      longitude_proper_motion(i),
     &                      properMotion(i),
     &                      rgac(i),
     &                      starBirthTime(i),
     &                      typeOfWD(i),
     &                      disk_str
          end do
      else if (geometry == 'cones') then
         if (with_overlapping_checking .eqv. .true.) then
             delta_longitude = DELTA_LATITUDE
     &                         / cos(cone_height_latitude)
             min_longitude = cone_height_longitude - delta_longitude/2.0
             max_longitude = cone_height_longitude + delta_longitude/2.0
             min_latitude = cone_height_latitude - DELTA_LATITUDE/2.0
             max_latitude = cone_height_latitude + DELTA_LATITUDE/2.0

             processed_cones_count
     &           = getNumberOfLines('processed_cones.txt')
             write(6,*) 'Processed cones: ', processed_cones_count
             allocate(overlap_min_longitudes(processed_cones_count))
             allocate(overlap_max_longitudes(processed_cones_count))
             allocate(overlap_min_latitudes(processed_cones_count))
             allocate(overlap_max_latitudes(processed_cones_count))

             open(765, file='processed_cones.txt')
             do i = 1, processed_cones_count
                 read(765,*) prev_cone_longitude, prev_cone_latitude

                 delta_longitude=DELTA_LATITUDE/cos(prev_cone_latitude)
                 prev_min_longitude
     &               = prev_cone_longitude-delta_longitude / 2.0
                 prev_max_longitude = prev_cone_longitude
     &                                + delta_longitude / 2.0
                 prev_min_latitude = prev_cone_latitude
     &                               - DELTA_LATITUDE / 2.0
                 prev_max_latitude = prev_cone_latitude
     &                               + DELTA_LATITUDE / 2.0

                 if (min_longitude < (prev_max_longitude - 2.0*pi)
     &                   .and. min_longitude < 0.0) then
                     prev_min_longitude = prev_min_longitude - 2.0*pi
                     prev_max_longitude = prev_max_longitude - 2.0*pi
                 end if
                 if (prev_min_longitude < (max_longitude - 2.0*pi)
     &                   .and. prev_min_longitude < 0.0) then
                     min_longitude = min_longitude - 2.0*pi
                     max_longitude = max_longitude - 2.0*pi
                 end if

                 longitude_overlapping = .false.
                 latitude_overlapping = .false.

                 if (((prev_min_longitude <= min_longitude) .and.
     &                (min_longitude <= prev_max_longitude))
     &               .or. ((prev_min_longitude <= max_longitude) .and.
     &                     (max_longitude <= prev_max_longitude))
     &               .or. ((min_longitude <= prev_min_longitude) .and.
     &                     (prev_min_longitude<= max_longitude))
     &               .or. ((min_longitude <= prev_max_longitude) .and.
     &                     (prev_max_longitude<= max_longitude))) then
                         longitude_overlapping = .true.
                 end if

                 if (((prev_min_latitude <= min_latitude) .and.
     &                 (min_latitude <= prev_max_latitude))
     &                .or. ((prev_min_latitude <= max_latitude) .and.
     &                 (max_latitude <= prev_max_latitude))
     &                .or. ((min_latitude <= prev_min_latitude) .and.
     &                 (prev_min_latitude <= max_latitude))
     &                .or. ((min_latitude <= prev_max_latitude) .and.
     &                 (prev_max_latitude <= max_latitude))) then
                         latitude_overlapping = .true.
                 end if

                 if ((longitude_overlapping .eqv. .true.)
     &                   .and. (latitude_overlapping .eqv. .true.)) then
                     overlappings = overlappings + 1

                     overlap_min_longitudes(overlappings)
     &                   = prev_min_longitude
                     overlap_max_longitudes(overlappings)
     &                   = prev_max_longitude
                     overlap_min_latitudes(overlappings)
     &                   = prev_min_latitude
                     overlap_max_latitudes(overlappings)
     &                   = prev_max_latitude

                     write(6,*) 'Overlapping with cone: ', i
                 end if
             end do

             write(6,*) 'Overlappings count:', overlappings

             do i = 1, numberOfWDs
                 ros = solarGalactocentricDistance
     &                 * solarGalactocentricDistance + coordinate_R(i)
     &                                                 * coordinate_R(i)
     &                 - 2.d0 * coordinate_R(i)
     &                   * solarGalactocentricDistance
     &                   * dcos(coordinate_Theta(i))
                 ros = dsqrt(ros)
C                TODO: figure out what to do with ill-conditioned cases
                 if ((solarGalactocentricDistance ** 2 + ros**2
     &                - coordinate_R(i) ** 2)
     &               / (2.0 * solarGalactocentricDistance * ros) > 1.0)
     &           then
                     longitude = 0.0
                 else
                     longitude = real(
     &                   dacos((solarGalactocentricDistance ** 2
     &                          + ros**2 - coordinate_R(i) ** 2)
     &                         / (2.0d0 * solarGalactocentricDistance
     &                            * ros)))
                 end if
                 zzx = real(coordinate_Zcylindr(i) / ros)
                 latitude = atan(zzx)
C                TODO: i am confused about how all this works now.
C                the reason for these conditions is that for angles > pi
C                longitude is simmetrically reflected on the top half-plane
                 if (coordinate_Theta(i) < 0
     &                  .and. cone_height_longitude > 3.0 * pi / 2) then
                     longitude = 2.0 * pi - longitude
                 end if
                 if (coordinate_Theta(i) > 0
     &                  .and. cone_height_longitude > 3.0 * pi / 2) then
                     longitude = 2.0 * pi + longitude
                 end if
                 if (coordinate_Theta(i) < 0
     &                   .and. cone_height_longitude < pi / 2) then
                     longitude = -longitude
                 end if
                 if (coordinate_Theta(i) < 0
     &                   .and. cone_height_longitude < 3.0 * pi / 2
     &                   .and. cone_height_longitude > pi / 2) then
                     longitude = 2.0 * pi - longitude
                 end if
C                if cone crosses 2pi, move it -2pi
                 if (max_longitude > 2 * pi) then
                     longitude = longitude - 2 * pi
                 end if

                 star_in_intersection = .false.
                 if (overlappings > 0) then
                     do j = 1, overlappings
                         if (((overlap_min_longitudes(j) < longitude)
     &                        .and. (longitude
     &                               < overlap_max_longitudes(j)))
     &                       .and. ((overlap_min_latitudes(j)
     &                                    < latitude) .and.
     &                              (latitude
     &                               < overlap_max_latitudes(j)))) then
                             star_in_intersection = .true.
                         end if
                     end do
                 end if
                 if (star_in_intersection .eqv. .false.) then
                     stars_counter = stars_counter + 1
                     if (disk_belonging(i) == 1) then
                         disk_str = 'thin'
                     else if (disk_belonging(i) == 2) then
                         disk_str = 'thick'
                     end if
                     write(421,*) uu(i),
     &                            vv(i),
     &                            ww(i),
     &                            rgac(i),
     &                            longitude,
     &                            latitude,
     &                            disk_str,
     &                            typeOfWD(i)
                 else
                     eliminations_counter = eliminations_counter + 1
                 end if
             end do
             deallocate(overlap_min_longitudes)
             deallocate(overlap_max_longitudes)
             deallocate(overlap_min_latitudes)
             deallocate(overlap_max_latitudes)
             write(6, *) 'Recorded stars: ', stars_counter
             write(6, *) 'Eliminated stars: ', eliminations_counter
         else

         do i = 1, numberOfWDs
C              x_coordinate=8.5-coordinate_R(i) * cos(coordinate_Theta(i))
C              y_coordinate = coordinate_R(i) * sin(coordinate_Theta(i))
C              z_coordinate = coordinate_Zcylindr(i)

C              star_longitude = atan(y_coordinate / x_coordinate)
C              star_latitude =atan(z_coordinate/sqrt(x_coordinate ** 2
C    &                                             + y_coordinate ** 2))
C           TODO: i took this from coor.f
            ros = solarGalactocentricDistance
     &            * solarGalactocentricDistance
     &            + coordinate_R(i) * coordinate_R(i)
     &            -2.0 * coordinate_R(i) * solarGalactocentricDistance
     &             * cos(coordinate_Theta(i))
            ros = sqrt(ros)
C           TODO: figurre out what to do with ill-conditioned cases
            if ((solarGalactocentricDistance ** 2 + ros**2
     &           - coordinate_R(i) ** 2)
     &          /(2.d0 * solarGalactocentricDistance * ros) > 1.0) then
              longitude = 0.0
            else
            longitude = dacos((solarGalactocentricDistance ** 2 + ros**2
     &                         - coordinate_R(i) ** 2)
     &                      /(2.d0 * solarGalactocentricDistance * ros))
            end if
            zzx=coordinate_Zcylindr(i)/ros
            latitude = atan(zzx)
C           TODO: i am confused about how all this works now.
C           the reason for these conditions is that for angles > pi
C           longitude is simmetrically reflected on the top half-plane
            if (coordinate_Theta(i) < 0
     &          .and. cone_height_longitude > 3.0 * pi / 2) then
                longitude = 2.0 * pi - longitude
            end if
            if (coordinate_Theta(i) > 0
     &          .and. cone_height_longitude > 3.0 * pi / 2) then
                longitude = 2.0 * pi + longitude
            end if
            if (coordinate_Theta(i) < 0
     &          .and. cone_height_longitude < pi / 2) then
                longitude = -longitude
            end if
            if (coordinate_Theta(i) < 0
     &          .and. cone_height_longitude < 3.0 * pi / 2
     &          .and. cone_height_longitude > pi / 2) then
                longitude = 2.0 * pi - longitude
            end if
C           if cone crosses 2pi, move it -2pi
            if (max_longitude > 2 * pi) then
                longitude = longitude - 2 * pi
            end if
            if (disk_belonging(i) == 1) then
                disk_str = 'thin'
            else if (disk_belonging(i) == 2) then
                disk_str = 'thick'
            end if
            write(421,*) uu(i),
     &                   vv(i),
     &                   ww(i),
     &                   rgac(i),
     &                   longitude,
     &                   latitude,
     &                   disk_str,
     &                   typeOfWD(i)
         end do
         end if
      end if
      end subroutine

      function getNumberOfLines(filePath) result(n)
        character(len = *), intent(in) :: filePath
        integer :: n, ioStatus
        n = 0
        open(532, file = filePath)
        do
            read(532, *, iostat = ioStatus)
            if(is_iostat_end(ioStatus)) exit
            n = n + 1
        end do
        close(532)
      end function

      function is_numeric(string)
          implicit none
          character(len=*), intent(in) :: string
          logical :: is_numeric
          real :: x
          integer :: e
          read(string,'(F50.0)',iostat=e) x
          is_numeric = e == 0
      end function

      subroutine read_angles(string, angles)
          implicit none
          character(len=*), intent(in) :: string
          real, allocatable, intent(out) :: angles(:)
          character(len=:), allocatable :: filename
          character(len=:), allocatable :: column_number_str
          character(len=50), allocatable :: junk(:)
          integer :: dash_index
          integer :: column_number
          integer :: lines_count, getNumberOfLines
          integer :: i

          dash_index = index(string=string, substring='-', back=.true.)
          filename = string(1 : dash_index - 1)
          column_number_str = string(dash_index + 1 : len(string))
          read(column_number_str, *) column_number
          allocate(junk(column_number - 1))
          lines_count = getNumberOfLines(filename)
          allocate(angles(lines_count))
          open(597, file = filename)
          do i = 1, lines_count
              read(597, *) junk, angles(i)
          end do
          close(597)
          deallocate(angles)
          deallocate(junk)
      end subroutine


module m_VYukawaFilm

  ! Computation of the film-case Yukawa potential for the preconditioning of the
  ! residual charge density in 5 steps:
  ! 1. pseudo-charge density generation
  ! 2. vacuum potential generation
  ! 3. interstitial potential generation
  ! 4. muffin-tin potential generation
  ! 5. modification for charge neutrality

  ! The Yukawa potential is the solution to the modified Helmholtz equation
  ! ( Delta - lambda^2 ) V_lambda = -4 pi ( rho_out - rho_in )
  ! subject to some conditions.
  ! The general scheme (steps 1 to 4) is the same as for the Poisson equation --
  ! we use Green function methods for the z-dependent vacuum and interstitial
  ! potentials as well as for the muffin-tin potential and apply Weinert's
  ! method.
  ! You can choose between two variants:
  ! 1. variant:
  ! zero Dirichlet boundary conditions at +/- infinity;
  ! multiplication with a decaying exponential in vacuum;
  ! modification in the film for charge neutrality (step 5)
  ! 2. variant:
  ! zero Dirichlet boundary conditions near the film boundary in vacuum (D/2+2R);
  ! modification in the film for charge neutrality (step 5)
  ! In both cases charge neutrality is broken.
  ! To restore charge neutrality, we need the integral over the potential to be
  ! zero.
  ! In step 5 we therefore solve the modified Helmholtz equation again with
  ! constant right-hand side, for an additive correction to the potential.
  ! The constant is chosen such that the integral over the final potential is
  ! zero.

  contains

  subroutine VYukawaFilm( stars, vacuum, cell, sym, input, fmpi, atoms, sphhar, oneD, noco, den, &
                          VYukawa )

    use m_constants
    use m_types
    use m_psqpw
    use m_vmts
    implicit none

    type(t_stars),      intent(in)    :: stars
    type(t_vacuum),     intent(in)    :: vacuum
    type(t_cell),       intent(in)    :: cell
    type(t_sym),        intent(in)    :: sym
    type(t_input),      intent(in)    :: input
    type(t_mpi),        intent(in)    :: fmpi
    type(t_atoms),      intent(in)    :: atoms
    type(t_sphhar),     intent(in)    :: sphhar
    type(t_oneD),       intent(in)    :: oneD
    type(t_noco),       intent(in)    :: noco
    type(t_potden),     intent(inout) :: den

    type(t_potden),     intent(inout) :: VYukawa

    complex                           :: psq(stars%ng3)
    complex                           :: alphm(stars%ng2,2)
    real                              :: dh_prec
    real                              :: coshdh(stars%ng2)

    ! PSEUDO-CHARGE DENSITY

    call psqpw( fmpi, atoms, sphhar, stars, vacuum, cell, input, sym, oneD, &
                den%pw(:,1), den%mt(:,:,:,1), den%vacz(:,:,1), .false., VYukawa%potdenType, &
                psq )

    ChooseVariant: if ( .true. ) then

      ! VACUUM POTENTIAL

      call VYukawaFilmVacuumVariant1( &
              stars, vacuum, cell, sym, input, atoms%rmt(1), &
              psq, den%vacxy(:,:,:,1), den%vacz(:,:,1), &
              VYukawa%vacxy, VYukawa%vacz, alphm )

      ! INTERSTITIAL POTENTIAL

      call VYukawaFilmInterstitialVariant1( &
              stars, vacuum, cell, sym, input, &
              psq, VYukawa%vacxy, VYukawa%vacz, alphm, &
              VYukawa%pw(:,1) )

    else ChooseVariant

      ! VACUUM POTENTIAL

      call VYukawaFilmVacuumVariant2( &
              stars, vacuum, cell, sym, input, 2*atoms%rmt(1), &
              psq, den%vacxy(:,:,:,1), den%vacz(:,:,1), &
              VYukawa%vacxy, VYukawa%vacz, alphm, dh_prec, coshdh )

      ! INTERSTITIAL POTENTIAL

      call VYukawaFilmInterstitialVariant2( &
              stars, vacuum, cell, sym, input, &
              psq, VYukawa%vacxy, VYukawa%vacz, alphm, dh_prec, coshdh, &
              VYukawa%pw(:,1) )

    end if ChooseVariant

    ! MUFFIN-TIN POTENTIAL

    call Vmts( input, fmpi, stars, sphhar, atoms, sym, cell, oneD, .FALSE., &
               VYukawa%pw(:,1), den%mt(:,0:,:,1), VYukawa%potdenType, &
               VYukawa%mt(:,0:,:,1) )

    ! MODIFICATION FOR CHARGE NEUTRALITY

    call VYukawaModify( stars, vacuum, cell, sym, input, fmpi, atoms, sphhar, oneD, noco, &
                        den, &
                        VYukawa )

  end subroutine VYukawaFilm

  subroutine VYukawaFilmVacuumVariant1( &
                stars, vacuum, cell, sym, input, rmt, &
                psq, rhtxy, rht, &
                VVxy, VVz, alphm )

    ! 1. part: Compute the contribution from the interstitial charge density to the vacuum potential as a function of q_xy and z (analytic expression for integral)
    ! 2. part: Compute the contribution from the vacuum charge density to the vacuum potential as a function of q_xy and z by numerical integration

    use m_ExpSave
    use m_constants
    use m_types
    use m_intgr, only: intgz1Reverse
    use m_qsf
    implicit none

    type(t_stars),  intent(in)  :: stars
    type(t_vacuum), intent(in)  :: vacuum
    type(t_cell),   intent(in)  :: cell
    type(t_sym),    intent(in)  :: sym
    type(t_input),  intent(in)  :: input
    real,           intent(in)  :: rmt
    complex,        intent(in)  :: psq(stars%ng3)
    complex,        intent(in)  :: rhtxy(vacuum%nmzxyd,stars%ng2-1,2)
    real,           intent(in)  :: rht(vacuum%nmzd,2)

    complex,        intent(out) :: VVxy(vacuum%nmzxyd,2:stars%ng2,2) ! this is the qxy /= 0 part of the vacuum potential
    real,           intent(out) :: VVz(vacuum%nmzd,2)                ! this is the qxy  = 0 part of the vacuum potential
    complex,        intent(out) :: alphm(stars%ng2,2)                ! these are the integrals in upper and lower vacuum, now including the first star---integral for star ig2 is in alphm(ig2,ivac)

    complex                     :: sum_qz(2,stars%ng2)
    complex                     :: c_ph(-stars%mx3:stars%mx3,stars%ng2)
    complex                     :: signIqz
    real                        :: g_damped(stars%ng2), qz, sign, vcons(stars%ng2)
    real                        :: exp_m(vacuum%nmzd,stars%ng2), exp_p(vacuum%nmzd,stars%ng2)
    real                        :: expDhg(stars%ng2), expDg(stars%ng2)
    real                        :: z(vacuum%nmzd)
    integer                     :: iz, irec2, irec3, ivac, iqz
    complex                     :: fa(vacuum%nmzxyd,2:stars%ng2), fb(vacuum%nmzxyd,2:stars%ng2)
    complex                     :: alpha(vacuum%nmzxyd,2:stars%ng2,2), beta(vacuum%nmzxyd,2:stars%ng2,2), gamma(vacuum%nmzxyd,2:stars%ng2)
    real                        :: ga(vacuum%nmzd), gb(vacuum%nmzd)
    real                        :: delta(vacuum%nmzd,2), epsilon(vacuum%nmzd,2), zeta(vacuum%nmzd)

    ! DEFINITIONS / ALLOCATIONS / INITIALISATIONS

    do iz = 1, vacuum%nmz
      z(iz) = ( iz - 1 ) * vacuum%delz
    end do
    do irec2 = 1, stars%ng2
      g_damped(irec2) = sqrt( stars%sk2(irec2) ** 2 + input%preconditioning_param ** 2 )
      vcons(irec2) = tpi_const / g_damped(irec2)
      do iz = 1, vacuum%nmz
        exp_m(iz,irec2) = exp_save( - g_damped(irec2) * z(iz) )
        exp_p(iz,irec2) = exp_save(   g_damped(irec2) * z(iz) )
      end do
      expDhg(irec2) = exp_save( - cell%z1 * g_damped(irec2) )
      expDg(irec2)  = exp_save( -2 * cell%z1 * g_damped(irec2) )
    end do
    sum_qz = (0.,0.)
    VVxy = (0.,0.)
    VVz = 0.

    ! CONTRIBUTION FROM THE INTERSTITIAL CHARGE DENSITY

    do irec2 = 1, stars%ng2
      do ivac = 1, vacuum%nvac
        sign = 3. - 2. * ivac
        do iqz = -stars%mx3, stars%mx3
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
          ! use only stars within the g_max sphere -> stars outside the sphere have per definition index ig3n = 0
          if ( irec3 /= 0 ) then
            c_ph(iqz,irec2) = stars%rgphs(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
            qz = iqz * cell%bmat(3,3)
            signIqz = sign * ImagUnit * qz
            sum_qz(ivac,irec2) = sum_qz(ivac,irec2) + c_ph(iqz,irec2) * psq(irec3) * ( exp( signIqz * cell%z1 ) - exp( - signIqz * cell%z1 ) * expDg(irec2) ) / ( signIqz + g_damped(irec2) )
          endif
        enddo
        if( irec2 /= 1 ) then
          VVxy(1:vacuum%nmzxy,irec2,ivac) = vcons(irec2) * sum_qz(ivac,irec2) * exp_m(1:vacuum%nmzxy,irec2)
        else
          VVz(1:vacuum%nmz,ivac)          = vcons(1)     * sum_qz(ivac,1)     * exp_m(1:vacuum%nmz,1)
        end if
      enddo
    enddo

    ! CONTRIBUTION FROM THE VACUUM CHARGE DENSITY

    ! shifting z:
    do irec2 = 1, stars%ng2
      exp_m(1:vacuum%nmz,irec2) = exp_m(1:vacuum%nmz,irec2) * expDhg(irec2)
      exp_p(1:vacuum%nmz,irec2) = exp_p(1:vacuum%nmz,irec2) / expDhg(irec2)
    end do

    ! case irec2 > 1:
    do irec2 = 2, stars%ng2
      do ivac = 1, vacuum%nvac
        ! integrands:
        fa(1:vacuum%nmzxy,irec2) = rhtxy(1:vacuum%nmzxy,irec2-1,ivac) * exp_m(1:vacuum%nmzxy,irec2)
        fb(1:vacuum%nmzxy,irec2) = rhtxy(1:vacuum%nmzxy,irec2-1,ivac) * exp_p(1:vacuum%nmzxy,irec2)
        ! integrals:
        ! alpha(z,q_xy,ivac) = int_z^infty rho(z',q_xy,ivac) exp(-sqrt(q_xy**2+prec_param**2)*z') dz'
        ! beta (z,q_xy,ivac) = int_{D/2}^z rho(z',q_xy,ivac) exp(+sqrt(q_xy**2+prec_param**2)*z') dz'
        ! where for z < 0 the lower vacuum charge density (ivac=2) is defined by rho(q_xy,z,ivac=2) := rho(q_xy,-z,ivac=2)
        call intgz1Reverse( fa(:,irec2), vacuum%delz, vacuum%nmzxy, alpha(:,irec2,ivac), .true. )
        call qsfComplex( vacuum%delz, fb(:,irec2), beta(:,irec2,ivac), vacuum%nmzxy, 1 )
        ! alphm(q_xy,ivac) = alpha(D/2,q_xy,ivac) --- these integrals are also needed for the interstitial potential
        alphm(irec2,ivac) = alpha(1,irec2,ivac)
      end do
      if ( vacuum%nvac == 1 ) then
        if ( sym%invs ) then
          alphm(irec2,2) = conjg( alphm(irec2,1) )
        else
          alphm(irec2,2) = alphm(irec2,1)
        end if
      end if
      do ivac = 1, vacuum%nvac
        gamma(1:vacuum%nmzxy,irec2) = exp_m(1:vacuum%nmzxy,irec2) * ( alphm(irec2,mod(ivac,2)+1) + beta(1:vacuum%nmzxy,irec2,ivac) ) &
                                    + exp_p(1:vacuum%nmzxy,irec2) *                               alpha(1:vacuum%nmzxy,irec2,ivac) ! mod(ivac,2)+1 outputs the other ivac value
        where ( 2. * gamma(:,irec2) == gamma(:,irec2) ) gamma(:,irec2) = cmplx( 0., 0. )
        VVxy(1:vacuum%nmzxy,irec2,ivac) = VVxy(1:vacuum%nmzxy,irec2,ivac) + vcons(irec2) * gamma(1:vacuum%nmzxy,irec2)
      end do
    end do

    ! case irec2 = 1:
    do ivac = 1, vacuum%nvac
      ga(1:vacuum%nmz) = rht(1:vacuum%nmz,ivac) * exp_m(1:vacuum%nmz,1)
      gb(1:vacuum%nmz) = rht(1:vacuum%nmz,ivac) * exp_p(1:vacuum%nmz,1)
      call intgz1Reverse( ga(:), vacuum%delz, vacuum%nmz, delta(:,ivac), .true. ) ! integrals
      call qsf( vacuum%delz, gb(:), epsilon(:,ivac), vacuum%nmz, 1 )
      alphm(1,ivac) = delta(1,ivac)
    end do
    if ( vacuum%nvac == 1 ) alphm(1,2) = alphm(1,1)
    do ivac = 1, vacuum%nvac
      zeta(1:vacuum%nmz) = exp_m(1:vacuum%nmz,1) * ( alphm(1,mod(ivac,2)+1) + epsilon(1:vacuum%nmz,ivac) ) &
                         + exp_p(1:vacuum%nmz,1) *                              delta(1:vacuum%nmz,ivac)
      where ( 2. * zeta == zeta ) zeta = 0.
      VVz(1:vacuum%nmz,ivac) = VVz(1:vacuum%nmz,ivac) + vcons(1) * zeta(1:vacuum%nmz)
    end do

    ! damping in vacuum:
    do ivac = 1, vacuum%nvac
      VVz(1:vacuum%nmz,ivac) = VVz(1:vacuum%nmz,ivac) * exp( -0.1 / rmt * z(1:vacuum%nmz) )
      do irec2 = 2, stars%ng2
        VVxy(1:vacuum%nmzxy,irec2,ivac) = VVxy(1:vacuum%nmzxy,irec2,ivac) * exp( -0.1 / rmt * z(1:vacuum%nmzxy) )
      end do
    end do

  end subroutine VYukawaFilmVacuumVariant1

  subroutine VYukawaFilmInterstitialVariant1( &
                stars, vacuum, cell, sym, input, &
                psq, VVxy, VVz, alphm, &
                VIq )

    ! main parts:
    ! 1. part: Compute the contribution from the interstitial charge density to the interstitial potential as a function of q_xy and z (analytic expression for integral)
    ! 2. part: Add the contribution from the vacuum charge density to the interstitial potential, which had already been computed earlier for the vacuum potential

    ! 4. part: Compute the coefficients V^I(q_xy,q_z) from the function V^I(q_xy,z) by a 1D Fourier transform:
    !          V^I(q_xy,z) = sum_{q_z} V^I(q_xy,q_z) * exp( ImagUnit * q_z * z )
    ! In order to be able to match the interstitial and vacuum potentials smoothly at the interface, the Fourier transform is done
    ! in a slightly larger region. -> 3. part
    ! 3. part: Interpolate the vacuum potential in a small region surrounding the slab

    use m_ExpSave
    use m_constants
    use m_types
    use m_cfft
    implicit none

    type(t_stars),  intent(in)  :: stars
    type(t_vacuum), intent(in)  :: vacuum
    type(t_cell),   intent(in)  :: cell
    type(t_sym),    intent(in)  :: sym
    type(t_input),  intent(in)  :: input
    complex,        intent(in)  :: psq(stars%ng3)
    complex,        intent(in)  :: VVxy(vacuum%nmzxyd,2:stars%ng2,2)
    real,           intent(in)  :: VVz(vacuum%nmzd,2)
    complex,        intent(in)  :: alphm(stars%ng2,2)

    complex,        intent(out) :: VIq(stars%ng3)

    real                        :: partitioning, rz, qz, q
    integer                     :: irec2, irec3, iz, jz, ivac, iqz, nfft, nzmax, nzmin, nzdh, nLower, nUpper, jvac
    complex, allocatable        :: VIz(:,:), eta(:,:)
    complex                     :: VIqz(-stars%mx3:stars%mx3,stars%ng2), c_ph(-stars%mx3:stars%mx3,stars%ng2)
    complex                     :: vcons1(stars%ng3)
    real                        :: VIzReal(3*stars%mx3,stars%ng2), VIzImag(3*stars%mx3,stars%ng2)
    real, allocatable           :: exp_m(:,:), exp_p(:,:)
    real, allocatable           :: z(:)
    real                        :: g_damped(stars%ng2), vcons2(stars%ng2), expDhg(stars%ng2)

    ! DEFINITIONS / ALLOCATIONS / INITIALISATIONS

    ! grid points z_i:
    nfft = 3 * stars%mx3                                  ! number of grid points for Fourier transform
    partitioning = 1. / real( nfft )
    nzmax = nfft / 2                                      ! index of maximal z below D~/2
    nzmin = nzmax - nfft + 1                              ! index of minimal z above -D~/2
    nzdh = ceiling( cell%z1 / cell%amat(3,3) * nfft ) - 1 ! index of maximal z below D/2
    allocate( z(nzmin:nzmax) )
    ! definition of z_i:        ! indexing: z_0 = 0; positive indices for z > 0; negative indices for z < 0
    do iz = nzmin, nzmax
      z(iz) = cell%amat(3,3) * iz * partitioning
    end do
    ! other variables:
    allocate( VIz(nzmin:nzmax,stars%ng2), eta(nzmin:nzmax,stars%ng2) )
    allocate( exp_m(nzmin:nzmax,stars%ng2), exp_p(nzmin:nzmax,stars%ng2) )
    do irec2 = 1, stars%ng2
      g_damped(irec2) = sqrt( stars%sk2(irec2) ** 2 + input%preconditioning_param ** 2 )
      vcons2(irec2) = -1. / ( 2. * g_damped(irec2) )
      do iz = nzmin, nzmax
        exp_m(iz,irec2) = exp_save( - g_damped(irec2) * z(iz) )
        exp_p(iz,irec2) = exp_save(   g_damped(irec2) * z(iz) )
      end do
      expDhg(irec2) = exp_save( - cell%z1 * g_damped(irec2) )
    end do
    do irec3 = 1, stars%ng3
      vcons1(irec3) = fpi_const * psq(irec3) / ( stars%sk3(irec3) ** 2 + input%preconditioning_param ** 2 )
    end do
    VIz = (0.,0.)
    VIq = (0.,0.)

    ! CONTRIBUTION FROM THE INTERSTITIAL CHARGE DENSITY

    ! compute V^I(q_xy,z) as a function of q_xy and z
    do irec2 = 1, stars%ng2
      do iz = -nzdh, nzdh
        do iqz = -stars%mx3, stars%mx3
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
          if ( irec3 /= 0 ) then ! use only stars within the g_max sphere
            c_ph(iqz,irec2) = stars%rgphs(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
            qz = iqz * cell%bmat(3,3)
            VIz(iz,irec2) = VIz(iz,irec2) &
                          + vcons1(irec3) * c_ph(iqz,irec2) * &
                            ( exp( ImagUnit * qz * z(iz) ) &
                            + vcons2(irec2) * expDhg(irec2) * &
                              ( ( g_damped(irec2) + ImagUnit * qz ) * exp_p(iz,irec2) * exp(   ImagUnit * qz * cell%z1 ) &
                              + ( g_damped(irec2) - ImagUnit * qz ) * exp_m(iz,irec2) * exp( - ImagUnit * qz * cell%z1 ) ) )
          end if
        enddo
      end do
    ! irec2 loop continues

    ! CONTRIBUTION FROM THE VACUUM CHARGE DENSITY

    ! irec2 loop continues
      eta(-nzdh:nzdh,irec2) = exp_m(-nzdh:nzdh,irec2) * alphm(irec2,2) + exp_p(-nzdh:nzdh,irec2) * alphm(irec2,1)
      where ( 2.0 * eta(:,irec2) == eta(:,irec2) ) eta(:,irec2) = cmplx( 0.0, 0.0 )
      VIz(-nzdh:nzdh,irec2) = VIz(-nzdh:nzdh,irec2) + tpi_const / g_damped(irec2) * eta(-nzdh:nzdh,irec2)
    ! irec2 loop continues

    ! INTERPOLATION IN VACUUM REGION

    ! use Lagrange polynomials of order 3 to interpolate the vacuum potential outside I
    ! q, q-1 and q-2 (scaled with +/-1 or +/-0.5) are the factors of the Lagrange basis polynomials
    ! irec2 loop continues
      do ivac = 1, 2
        select case( ivac )
          case( 1 )
            nUpper = nzmax; nLower =  nzdh + 1; jvac = 1
          case( 2 )
            nLower = nzmin; nUpper = -nzdh - 1; jvac = 2; if ( sym%invs .or. sym%zrfs ) jvac = 1
        end select
        do iz = nLower, nUpper
          rz = ( abs( z(iz) ) - cell%z1 ) / vacuum%delz + 1.0
          jz = rz      ! index of maximal vacuum grid point below z_i
          q = rz - jz  ! factor in Lagrange basis polynomials
          if ( irec2 == 1 ) then
            VIz(iz,irec2) = 0.5     * ( q - 1. ) * ( q - 2. ) * VVz(jz,  jvac) &
                          -       q *              ( q - 2. ) * VVz(jz+1,jvac) &
                          + 0.5 * q * ( q - 1. )              * VVz(jz+2,jvac)
          else if ( jz + 2 <= vacuum%nmzxy ) then
            VIz(iz,irec2) = 0.5 *     ( q - 1. ) * ( q - 2. ) * VVxy(jz,  irec2,jvac) &
                          -       q              * ( q - 2. ) * VVxy(jz+1,irec2,jvac) &
                          + 0.5 * q * ( q - 1. )              * VVxy(jz+2,irec2,jvac)
            if ( ( sym%invs .and. .not. sym%zrfs ) .and. ivac == 2 ) VIz(iz,irec2) = conjg( VIz(iz,irec2) )
          end if
        end do
      end do
    end do ! irec2

    ! 1D FOURIER TRANSFORM TO FIND THE COEFFICIENTS V^I(q_xy,q_z)

    ! change the indexing for the subroutine cfft, and split real and imaginary parts
    VIzReal(1:nzmax+1,:) =  real( VIz(0:nzmax,:) ); VIzReal(nzmax+2:nfft,:) =  real( VIz(nzmin:-1,:) )
    VIzImag(1:nzmax+1,:) = aimag( VIz(0:nzmax,:) ); VIzImag(nzmax+2:nfft,:) = aimag( VIz(nzmin:-1,:) )

    ! V^I(q_xy,z) = sum_{q_z} V^I(q_xy,q_z) * exp( ImagUnit * q_z * z )
    do irec2 = 1, stars%ng2
      call cfft( VIzReal(:,irec2), VIzImag(:,irec2), nfft, nfft, nfft, -1 )
    ! irec2 loop continues

    ! reorder
      VIqz(0,irec2) = cmplx( VIzReal(1,irec2), VIzImag(1,irec2) )
      do iqz = 1, stars%mx3
        VIqz( iqz,irec2) = cmplx( VIzReal(iqz+1,     irec2), VIzImag(iqz+1,     irec2) )
        VIqz(-iqz,irec2) = cmplx( VIzReal(nfft+1-iqz,irec2), VIzImag(nfft+1-iqz,irec2) )
      end do

    ! add the computed components to V^I(q_xy,q_z):
      do iqz= -stars%mx3, stars%mx3
        irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
        if ( irec3 /= 0 ) VIq(irec3) = VIq(irec3) + VIqz(iqz,irec2) * partitioning / ( stars%nstr(irec3) / stars%nstr2(irec2) )
      end do
    end do

  end subroutine VYukawaFilmInterstitialVariant1

  subroutine VYukawaFilmVacuumVariant2( &
                stars, vacuum, cell, sym, input, rmt, &
                psq, rhtxy, rht, &
                VVxy, VVz, alphm, dh_prec, coshdh )

    ! 1. part: Compute the contribution from the interstitial charge density to the vacuum potential as a function of q_xy and z (analytic expression for integral)
    ! 2. part: Compute the contribution from the vacuum charge density to the vacuum potential as a function of q_xy and z by numerical integration

    use m_ExpSave
    use m_constants
    use m_types
    use m_intgr, only: intgz1Reverse
    use m_qsf
    implicit none

    type(t_stars),  intent(in)  :: stars
    type(t_vacuum), intent(in)  :: vacuum
    type(t_cell),   intent(in)  :: cell
    type(t_sym),    intent(in)  :: sym
    type(t_input),  intent(in)  :: input
    real,           intent(in)  :: rmt
    complex,        intent(in)  :: psq(stars%ng3)
    complex,        intent(in)  :: rhtxy(vacuum%nmzxyd,stars%ng2-1,2)
    real,           intent(in)  :: rht(vacuum%nmzd,2)

    complex,        intent(out) :: VVxy(vacuum%nmzxyd,2:stars%ng2,2) ! this is the qxy /= 0 part of the vacuum potential
    real,           intent(out) :: VVz(vacuum%nmzd,2)                ! this is the qxy  = 0 part of the vacuum potential
    complex,        intent(out) :: alphm(stars%ng2,2)                ! these are the integrals in upper and lower vacuum, now including the first star---integral for star ig2 is in alphm(ig2,ivac)
    real,           intent(out) :: dh_prec
    real,           intent(out) :: coshdh(stars%ng2)

    integer                                             :: iz, irec2, irec3, ivac, iqz, nzdhprec, sign
    real                                                :: dh, qz, qxy_numerics
    real, allocatable                                   :: z(:)
    complex, dimension(stars%ng2)                       :: sum_qz
    complex, dimension(stars%ng3)                       :: vcons3
    real, dimension(stars%ng2)                          :: g_damped, vcons2
    complex, dimension(-stars%mx3:stars%mx3,stars%ng2)  :: c_ph, quotq
    real, allocatable                                   :: quotz(:,:), sinhz(:,:)
    real, dimension(-1:1,stars%ng2)                     :: quotvardh
    complex, dimension(-stars%mx3:stars%mx3)            :: expdhqz
    complex, allocatable                                :: fa(:,:), fb(:,:)
    complex, allocatable                                :: alpha(:,:,:), beta(:,:,:), gamma(:,:)
    real, allocatable                                   :: ga(:), gb(:)
    real, allocatable                                   :: delta(:,:), epsilon(:,:), zeta(:)

    ! DEFINITIONS / ALLOCATIONS / INITIALISATIONS

    dh = cell%z1 ! half the thickness of the film
    nzdhprec = ceiling( rmt / vacuum%delz ) ! index of dh_prec, see below
    dh_prec = dh + ( nzdhprec - 1 ) * vacuum%delz ! dh_prec is about dh + R; preconditioning boundary
    qxy_numerics = sqrt( ( 100 / dh_prec ) ** 2 - input%preconditioning_param ** 2 )
    allocate( z(nzdhprec) )
    allocate( quotz(-nzdhprec:nzdhprec,stars%ng2) )
    allocate( sinhz(nzdhprec,stars%ng2) )
    do iz = 1, nzdhprec ! new boundary
      z(iz) = ( iz - 1 ) * vacuum%delz + dh
    end do
    do irec2 = 1, stars%ng2
      g_damped(irec2) = sqrt( stars%sk2(irec2) ** 2 + input%preconditioning_param ** 2 )
      vcons2(irec2) = fpi_const / g_damped(irec2)
      coshdh(irec2) = cosh( g_damped(irec2) * ( dh_prec - dh ) )
      if( stars%sk2(irec2) < qxy_numerics ) then ! numerics ok
        do iz = 1, nzdhprec
          quotz( iz,irec2) = ( cosh( g_damped(irec2) * z(iz) ) / cosh( g_damped(irec2) * dh_prec ) &
                             + sinh( g_damped(irec2) * z(iz) ) / sinh( g_damped(irec2) * dh_prec ) ) / 2
          quotz(-iz,irec2) = ( cosh( g_damped(irec2) * z(iz) ) / cosh( g_damped(irec2) * dh_prec ) &
                             - sinh( g_damped(irec2) * z(iz) ) / sinh( g_damped(irec2) * dh_prec ) ) / 2
        end do
        quotvardh( 1,irec2) = ( cosh( g_damped(irec2) * dh ) / sinh( g_damped(irec2) * dh_prec ) &
                              + sinh( g_damped(irec2) * dh ) / cosh( g_damped(irec2) * dh_prec ) ) / 2
        quotvardh(-1,irec2) = ( cosh( g_damped(irec2) * dh ) / sinh( g_damped(irec2) * dh_prec ) &
                              - sinh( g_damped(irec2) * dh ) / cosh( g_damped(irec2) * dh_prec ) ) / 2
      else ! numerical treatment necessary
        do iz = 1, nzdhprec
          quotz( iz,irec2) = exp_save( g_damped(irec2) * (  z(iz) - dh_prec ) )
          quotz(-iz,irec2) = exp_save( g_damped(irec2) * ( -z(iz) - dh_prec ) )
        end do
        quotvardh( 1,irec2) = quotz( 1,irec2)
        quotvardh(-1,irec2) = quotz(-1,irec2)
      end if
      do iz = 1, nzdhprec
        sinhz(iz,irec2) = sinh( g_damped(irec2) * ( dh_prec - z(iz) ) )
      end do
      do iqz = -stars%mx3, stars%mx3
        quotq(iqz,irec2) = ImagUnit * iqz * cell%bmat(3,3) / g_damped(irec2)
      end do
    end do
    sum_qz = (0.,0.)
    VVxy = (0.,0.)
    VVz = 0.
    do irec3 = 1, stars%ng3
      vcons3(irec3) = fpi_const * psq(irec3) / ( stars%sk3(irec3) ** 2 + input%preconditioning_param ** 2 )
    end do
    do iqz = -stars%mx3, stars%mx3
      expdhqz(iqz) = exp( ImagUnit * iqz * cell%bmat(3,3) * dh )
    end do

    ! CONTRIBUTION FROM THE INTERSTITIAL CHARGE DENSITY

    do ivac = 1, vacuum%nvac
      sign = 3 - 2 * ivac
      do irec2 = 1, stars%ng2
        do iqz = -stars%mx3, stars%mx3
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
          ! use only stars within the g_max sphere -> stars outside the sphere have per definition index ig3n = 0
          if ( irec3 /= 0 ) then
            c_ph(iqz,irec2) = stars%rgphs(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
            sum_qz(irec2) = sum_qz(irec2) + &
                            c_ph(iqz,irec2) * vcons3(irec3) * &
                            ( ( quotvardh( 1,irec2) - sign * quotq(iqz,irec2) * quotz( 1,irec2) ) * expdhqz( sign*iqz) &
                            - ( quotvardh(-1,irec2) - sign * quotq(iqz,irec2) * quotz(-1,irec2) ) * expdhqz(-sign*iqz) )
          endif
        enddo
        if( irec2 /= 1 ) then
          VVxy(1:nzdhprec,irec2,ivac) = sum_qz(irec2) * sign * sinhz(1:nzdhprec,irec2)
        else
          VVz( 1:nzdhprec,      ivac) = sum_qz(1)     * sign * sinhz(1:nzdhprec,1)
        end if
      enddo
    enddo

    ! CONTRIBUTION FROM THE VACUUM CHARGE DENSITY

    allocate( fa(nzdhprec,2:stars%ng2), fb(nzdhprec,2:stars%ng2) )
    allocate( alpha(nzdhprec,2:stars%ng2,2), beta(nzdhprec,2:stars%ng2,2), gamma(nzdhprec,2:stars%ng2) )
    ! case irec2 > 1:
    do irec2 = 2, stars%ng2
      do ivac = 1, vacuum%nvac
        ! integrands:
        fa(1:nzdhprec,irec2) = rhtxy(1:nzdhprec,irec2-1,ivac) * sinhz(1:nzdhprec,irec2)
        fb(1:nzdhprec,irec2) = rhtxy(1:nzdhprec,irec2-1,ivac) * quotz(1:nzdhprec,irec2)
        ! integrals:
        ! alpha(z,q_xy,ivac) = int_z^infty rho(z',q_xy,ivac) sinhz dz'
        ! beta (z,q_xy,ivac) = int_{D/2}^z rho(z',q_xy,ivac) quotz dz'
        ! where for z < 0 the lower vacuum charge density (ivac=2) is defined by rho(q_xy,z,ivac=2) := rho(q_xy,-z,ivac=2)
        call intgz1Reverse( fa(:,irec2), vacuum%delz, nzdhprec, alpha(:,irec2,ivac), .false. )
        call qsfComplex( vacuum%delz, fb(:,irec2), beta(:,irec2,ivac), nzdhprec, 1 )
        ! alphm(q_xy,ivac) = alpha(D/2,q_xy,ivac) --- these integrals are also needed for the interstitial potential
        alphm(irec2,ivac) = alpha(1,irec2,ivac)
      end do
      if ( vacuum%nvac == 1 ) then
        if ( sym%invs ) then
          alphm(irec2,2) = conjg( alphm(irec2,1) )
        else
          alphm(irec2,2) = alphm(irec2,1)
        end if
      end if
      do ivac = 1, vacuum%nvac
        gamma(1:nzdhprec,irec2) = quotz(-1:-nzdhprec:-1,irec2) * alphm(irec2,mod(ivac,2)+1) &
                                + quotz(1:nzdhprec,irec2) * alpha(1:nzdhprec,irec2,ivac) &
                                + sinhz(1:nzdhprec,irec2) * beta(1:nzdhprec,irec2,ivac)
        VVxy(1:nzdhprec,irec2,ivac) = VVxy(1:nzdhprec,irec2,ivac) + vcons2(irec2) * gamma(1:nzdhprec,irec2)
      end do
    end do

    allocate( ga(nzdhprec), gb(nzdhprec) )
    allocate( delta(nzdhprec,2), epsilon(nzdhprec,2), zeta(nzdhprec) )
    ! case irec2 = 1:
    do ivac = 1, vacuum%nvac
      ga(1:nzdhprec) = rht(1:nzdhprec,ivac) * sinhz(1:nzdhprec,1)
      gb(1:nzdhprec) = rht(1:nzdhprec,ivac) * quotz(1:nzdhprec,1)
      call intgz1Reverse( ga(:), vacuum%delz, nzdhprec, delta(:,ivac), .false. )
      call qsf( vacuum%delz, gb(:), epsilon(:,ivac), nzdhprec, 1 )
      alphm(1,ivac) = delta(1,ivac)
    end do
    if ( vacuum%nvac == 1 ) alphm(1,2) = alphm(1,1)
    do ivac = 1, vacuum%nvac
      zeta(1:nzdhprec) = quotz(-1:-nzdhprec:-1,1) * alphm(1,mod(ivac,2)+1) &
                       + quotz(1:nzdhprec,1) * delta(1:nzdhprec,ivac) &
                       + sinhz(1:nzdhprec,1) * epsilon(1:nzdhprec,ivac)
      VVz(1:nzdhprec,ivac) = VVz(1:nzdhprec,ivac) + vcons2(1) * zeta(1:nzdhprec)
    end do

  end subroutine VYukawaFilmVacuumVariant2

  subroutine VYukawaFilmInterstitialVariant2( &
                stars, vacuum, cell, sym, input, &
                psq, VVxy, VVz, alphm, dh_prec, coshdh, &
                VIq )

    ! main parts:
    ! 1. part: Compute the contribution from the interstitial charge density to the interstitial potential as a function of q_xy and z (analytic expression for integral)
    ! 2. part: Add the contribution from the vacuum charge density to the interstitial potential, which had already been computed earlier for the vacuum potential

    ! 4. part: Compute the coefficients V^I(q_xy,q_z) from the function V^I(q_xy,z) by a 1D Fourier transform:
    !          V^I(q_xy,z) = sum_{q_z} V^I(q_xy,q_z) * exp( ImagUnit * q_z * z )
    ! In order to be able to match the interstitial and vacuum potentials smoothly at the interface, the Fourier transform is done
    ! in a slightly larger region. -> 3. part
    ! 3. part: Interpolate the vacuum potential in a small region surrounding the slab

    use m_ExpSave
    use m_constants
    use m_types
    use m_cfft
    implicit none

    type(t_stars),  intent(in)  :: stars
    type(t_vacuum), intent(in)  :: vacuum
    type(t_cell),   intent(in)  :: cell
    type(t_sym),    intent(in)  :: sym
    type(t_input),  intent(in)  :: input
    complex,        intent(in)  :: psq(stars%ng3)
    complex,        intent(in)  :: VVxy(vacuum%nmzxyd,2:stars%ng2,2)
    real,           intent(in)  :: VVz(vacuum%nmzd,2)
    complex,        intent(in)  :: alphm(stars%ng2,2)
    real,           intent(in)  :: dh_prec
    real,           intent(in)  :: coshdh(stars%ng2)

    complex,        intent(out) :: VIq(stars%ng3)

    real                                               :: partitioning, rz, qz, q, qxy_numerics
    integer                                            :: irec2, irec3, iz, jz, ivac, iqz, jvac
    integer                                            :: nfft, nzmax, nzmin, nzdh, nLower, nUpper
    complex, allocatable                               :: VIz(:,:), eta(:,:)
    complex, allocatable                               :: expzqz(:,:)
    complex, dimension(-stars%mx3:stars%mx3,stars%ng2) :: VIqz, c_ph
    complex, dimension(-stars%mx3:stars%mx3,stars%ng2) :: qquot, qquottrigp, qquottrigm
    complex, dimension(stars%ng3)                      :: vcons3
    real, dimension(3*stars%mx3,stars%ng2)             :: VIzReal, VIzImag
    real, allocatable                                  :: quotz(:,:), sinhz(:,:)
    real, allocatable                                  :: z(:)
    real, dimension(stars%ng2)                         :: g_damped, vcons2

    ! DEFINITIONS / ALLOCATIONS / INITIALISATIONS

    ! grid points z_i:
    qxy_numerics = sqrt( ( 100 / dh_prec ) ** 2 - input%preconditioning_param ** 2 )
    nfft = 3 * stars%mx3                                  ! number of grid points for Fourier transform
    partitioning = 1. / real( nfft )
    nzmax = nfft / 2                                      ! index of maximal z below D~/2
    nzmin = nzmax - nfft + 1                              ! index of minimal z above -D~/2
    nzdh = ceiling( cell%z1 / cell%amat(3,3) * nfft ) - 1 ! index of maximal z below D/2
    allocate( z(nzmin:nzmax) )
    ! definition of z_i:        ! indexing: z_0 = 0; positive indices for z > 0; negative indices for z < 0
    do iz = nzmin, nzmax
      z(iz) = cell%amat(3,3) * iz * partitioning
    end do
    ! other variables:
    allocate( VIz(nzmin:nzmax,stars%ng2) )
    allocate( eta(-nzdh:nzdh,stars%ng2) )
    allocate( sinhz(-nzdh:nzdh,stars%ng2) )
    allocate( quotz(-nzdh:nzdh,stars%ng2) )
    allocate( expzqz(-nzdh:nzdh,-stars%mx3:stars%mx3) )
    do irec2 = 1, stars%ng2
      g_damped(irec2) = sqrt( stars%sk2(irec2) ** 2 + input%preconditioning_param ** 2 )
      vcons2(irec2) = fpi_const / g_damped(irec2)
      if( stars%sk2(irec2) < qxy_numerics ) then ! numerics ok
        do iz = -nzdh, nzdh
          quotz( iz,irec2) = ( cosh( g_damped(irec2) * z(iz) ) / cosh( g_damped(irec2) * dh_prec ) &
                             + sinh( g_damped(irec2) * z(iz) ) / sinh( g_damped(irec2) * dh_prec ) ) / 2
        end do
      else ! numerical treatment necessary
        do iz = -nzdh, nzdh
          quotz( iz,irec2) = exp_save( g_damped(irec2) * (  z(iz) - dh_prec ) )
        end do
      end if
      do iz = -nzdh, nzdh
        sinhz(iz,irec2) = sinh( g_damped(irec2) * ( dh_prec - z(iz) ) )
        do iqz = -stars%mx3, stars%mx3
          expzqz(iz,iqz) = exp( ImagUnit * iqz * cell%bmat(3,3) * z(iz) )
        end do
      end do
      do iqz = -stars%mx3, stars%mx3
        qquot(iqz,irec2) = ImagUnit * iqz * cell%bmat(3,3) / g_damped(irec2)
        qquottrigp(iqz,irec2) = coshdh(irec2) + sinhz(nzdh,irec2) * qquot(iqz,irec2)
        qquottrigm(iqz,irec2) = coshdh(irec2) - sinhz(nzdh,irec2) * qquot(iqz,irec2)
      end do
    end do
    do irec3 = 1, stars%ng3
      vcons3(irec3) = fpi_const * psq(irec3) / ( stars%sk3(irec3) ** 2 + input%preconditioning_param ** 2 )
    end do
    VIz = (0.,0.)
    VIq = (0.,0.)

    ! CONTRIBUTION FROM THE INTERSTITIAL CHARGE DENSITY

    ! compute V^I(q_xy,z) as a function of q_xy and z
    do irec2 = 1, stars%ng2
      do iz = -nzdh, nzdh
        do iqz = -stars%mx3, stars%mx3
          irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
          if ( irec3 /= 0 ) then ! use only stars within the g_max sphere
            c_ph(iqz,irec2) = stars%rgphs(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
            qz = iqz * cell%bmat(3,3)
            VIz(iz,irec2) = VIz(iz,irec2) &
                          + vcons3(irec3) * c_ph(iqz,irec2) * &
                            ( expzqz(iz,iqz) &
                            - qquottrigp(iqz,irec2) * expzqz( nzdh,iqz) * quotz( iz,irec2) &
                            - qquottrigm(iqz,irec2) * expzqz(-nzdh,iqz) * quotz(-iz,irec2) )
          end if
        enddo
      end do
    ! irec2 loop continues

    ! CONTRIBUTION FROM THE VACUUM CHARGE DENSITY

    ! irec2 loop continues
      eta(-nzdh:nzdh,irec2) = quotz(nzdh:-nzdh:-1,irec2) * alphm(irec2,2) &
                            + quotz(-nzdh:nzdh,   irec2) * alphm(irec2,1)
      VIz(-nzdh:nzdh,irec2) = VIz(-nzdh:nzdh,irec2) + vcons2(irec2) * eta(-nzdh:nzdh,irec2)
    ! irec2 loop continues

    ! INTERPOLATION IN VACUUM REGION

    ! use Lagrange polynomials of order 3 to interpolate the vacuum potential outside I
    ! q, q-1 and q-2 (scaled with +/-1 or +/-0.5) are the factors of the Lagrange basis polynomials
    ! irec2 loop continues
      do ivac = 1, 2
        select case( ivac )
          case( 1 )
            nUpper = nzmax; nLower =  nzdh + 1; jvac = 1
          case( 2 )
            nLower = nzmin; nUpper = -nzdh - 1; jvac = 2; if ( sym%invs .or. sym%zrfs ) jvac = 1
        end select
        do iz = nLower, nUpper
          rz = ( abs( z(iz) ) - cell%z1 ) / vacuum%delz + 1.0
          jz = rz      ! index of maximal vacuum grid point below z_i
          q = rz - jz  ! factor in Lagrange basis polynomials
          if ( irec2 == 1 ) then
            VIz(iz,irec2) = 0.5     * ( q - 1. ) * ( q - 2. ) * VVz(jz,  jvac) &
                          -       q *              ( q - 2. ) * VVz(jz+1,jvac) &
                          + 0.5 * q * ( q - 1. )              * VVz(jz+2,jvac)
          else if ( jz + 2 <= vacuum%nmzxy ) then
            VIz(iz,irec2) = 0.5 *     ( q - 1. ) * ( q - 2. ) * VVxy(jz,  irec2,jvac) &
                          -       q              * ( q - 2. ) * VVxy(jz+1,irec2,jvac) &
                          + 0.5 * q * ( q - 1. )              * VVxy(jz+2,irec2,jvac)
            if ( ( sym%invs .and. .not. sym%zrfs ) .and. ivac == 2 ) VIz(iz,irec2) = conjg( VIz(iz,irec2) )
          end if
        end do
      end do
    end do ! irec2

    ! 1D FOURIER TRANSFORM TO FIND THE COEFFICIENTS V^I(q_xy,q_z)

    ! change the indexing for the subroutine cfft, and split real and imaginary parts
    VIzReal(1:nzmax+1,:) =  real( VIz(0:nzmax,:) ); VIzReal(nzmax+2:nfft,:) =  real( VIz(nzmin:-1,:) )
    VIzImag(1:nzmax+1,:) = aimag( VIz(0:nzmax,:) ); VIzImag(nzmax+2:nfft,:) = aimag( VIz(nzmin:-1,:) )

    ! V^I(q_xy,z) = sum_{q_z} V^I(q_xy,q_z) * exp( ImagUnit * q_z * z )
    do irec2 = 1, stars%ng2
      call cfft( VIzReal(:,irec2), VIzImag(:,irec2), nfft, nfft, nfft, -1 )
    ! irec2 loop continues

    ! reorder
      VIqz(0,irec2) = cmplx( VIzReal(1,irec2), VIzImag(1,irec2) )
      do iqz = 1, stars%mx3
        VIqz( iqz,irec2) = cmplx( VIzReal(iqz+1,     irec2), VIzImag(iqz+1,     irec2) )
        VIqz(-iqz,irec2) = cmplx( VIzReal(nfft+1-iqz,irec2), VIzImag(nfft+1-iqz,irec2) )
      end do

    ! add the computed components to V^I(q_xy,q_z):
      do iqz= -stars%mx3, stars%mx3
        irec3 = stars%ig(stars%kv2(1,irec2),stars%kv2(2,irec2),iqz)
        if ( irec3 /= 0 ) VIq(irec3) = VIq(irec3) + VIqz(iqz,irec2) * partitioning / ( stars%nstr(irec3) / stars%nstr2(irec2) )
      end do
    end do

  end subroutine VYukawaFilmInterstitialVariant2

  subroutine VYukawaModify( stars, vacuum, cell, sym, input, fmpi, atoms, sphhar, oneD, noco, den, &
                            VYukawa )

    ! This subroutine adds a potential to the previously computed Yukawa
    ! potential to ensure charge neutrality.
    ! The added potential itself is a solution to the modified Helmholtz
    ! equation with constant right-hand side, where the constant is chosen such
    ! that charge neutrality is obtained.
    ! The charge is distributed only over the film region, and we therefore
    ! solve the differential equation subject to a boundary condition on the
    ! film surface, in contrast to the basic Yukawa potential above.

    use m_constants
    use m_types
    use m_vmts
    use m_constants
    use m_cdntot
    use m_cfft
    implicit none

    type(t_stars),      intent(in)    :: stars
    type(t_vacuum),     intent(in)    :: vacuum
    type(t_cell),       intent(in)    :: cell
    type(t_sym),        intent(in)    :: sym
    type(t_input),      intent(in)    :: input
    type(t_mpi),        intent(in)    :: fmpi
    type(t_atoms),      intent(in)    :: atoms
    type(t_sphhar),     intent(in)    :: sphhar
    type(t_oneD),       intent(in)    :: oneD
    type(t_noco),       intent(in)    :: noco
    type(t_potden),     intent(inout) :: den
    type(t_potden),     intent(inout) :: VYukawa

    integer                           :: n, lh, irec3, iz, iqz, nfft, nzmax, nzmin, nzdh
    real                              :: q0, qhat, qbar, ldh, partitioning, dh
    real                              :: q(input%jspins), qis(input%jspins), qmt(atoms%ntype,input%jspins),qvac(2,input%jspins), qtot, qistot
    complex                           :: psq(stars%ng3)
    type(t_potden)                    :: VYukawaModification
    real, allocatable                 :: z(:)
    real                              :: VIzReal(3*stars%mx3), VIzImag(3*stars%mx3)
    complex, allocatable              :: VIz(:)
    complex                           :: VIqz(-stars%mx3:stars%mx3)

    ! DEFINITIONS / ALLOCATIONS / INITIALISATIONS

    ! constants:
    dh = cell%z1   ! half the width of the film
    ! indexing of grid points z_i:
    nfft = 3 * stars%mx3   ! number of grid points for Fourier transform
    partitioning = 1. / real( nfft )
    nzmax = nfft / 2           ! index of maximal z below D~/2
    nzmin = nzmax - nfft + 1   ! index of minimal z above -D~/2
    nzdh = ceiling( dh / cell%amat(3,3) * nfft ) - 1   ! index of maximal z below D/2
    allocate( z(nzmin:nzmax) )
    ! definition of grid points z_i:
    ! indexing: z_0 = 0; positive indices for z > 0; negative indices for z < 0
    do iz = nzmin, nzmax
      z(iz) = cell%amat(3,3) * iz * partitioning
    end do

    ! INTEGRATION OF THE PREVIOUSLY COMPUTED YUKAWA POTENTIAL

    ! initialise VYukawaModification with in-going VYukawa and prepare for integration
    call VYukawaModification%init( stars, atoms, sphhar, vacuum, noco, input%jspins, 4 )
    call VYukawaModification%copyPotDen( VYukawa )
    do n = 1, atoms%ntype
      do lh = 0, sphhar%nlhd
        VYukawaModification%mt(1:atoms%jri(n),lh,n,1) = VYukawaModification%mt(1:atoms%jri(n),lh,n,1) * atoms%rmsh(1:atoms%jri(n),n) ** 2
      end do
    end do

    ! integrate the potential over the film region
    call integrate_cdn( stars, atoms, sym, vacuum, input, cell, oneD, VYukawaModification, q, qis, qmt, qvac, qtot, qistot  )
    q0 = qtot / cell%area
    ldh = input%preconditioning_param * dh
    qhat = ( q0 / ( 2 * dh ) ) / ( sinh(ldh) / ( ldh * cosh( ldh ) ) - 1 )
    qbar = input%preconditioning_param ** 2 / fpi_const *  qhat

    ! SET UP CONSTANT CHARGE DENSITY

    ! instead of den%pw(1,1) = qbar we directly set the pseudo charge density
    den%mt = 0; den%pw = 0; den%vacxy = 0; den%vacz = 0
    do n = 1, atoms%ntype
      den%mt(1:atoms%jri(n),0,n,1) = sfp_const * qbar * atoms%rmsh(1:atoms%jri(n),n) ** 2
    end do
    psq = cmplx(0.0,0.0); psq(1) = qbar

    ! CALCULATE THE INTERSTITIAL POTENTIAL AS A FUNCTION OF z

    ! initialise and calculate out-going modification potential; reuse VYukawaModification
    VYukawaModification%mt = 0; VYukawaModification%pw = 0; VYukawaModification%vacxy = 0; VYukawaModification%vacz = 0

    allocate( VIz(nzmin:nzmax) )
    VIz = (0.,0.)
    do iz = -nzdh+1, nzdh-1
      VIz(iz) = qhat * ( 1 - cosh( input%preconditioning_param * z(iz) ) / cosh( ldh ) )
    end do

    ! 1D FOURIER TRANSFORM TO FIND THE 3D-FOURIER COEFFICIENTS

    ! change the indexing for the subroutine cfft, and split real and imaginary parts
    VIzReal(1:nzmax+1) =  real( VIz(0:nzmax) ); VIzReal(nzmax+2:nfft) = real( VIz(nzmin:-1) )
    VIzImag(1:nzmax+1) = aimag( VIz(0:nzmax) ); VIzImag(nzmax+2:nfft) = aimag( VIz(nzmin:-1) )

    call cfft( VIzReal(:), VIzImag(:), nfft, nfft, nfft, -1 )

    ! reorder
    VIqz = 0
    VIqz(0) = cmplx( VIzReal(1), VIzImag(1) )
    do iqz = 1, stars%mx3
      VIqz( iqz) = cmplx( VIzReal(iqz+1     ), VIzImag(iqz+1     ) )
      VIqz(-iqz) = cmplx( VIzReal(nfft+1-iqz), VIzImag(nfft+1-iqz) )
    end do

    ! add the computed components
    do iqz= -stars%mx3, stars%mx3
      irec3 = stars%ig(stars%kv2(1,1),stars%kv2(2,1),iqz)
      if ( irec3 /= 0 ) VYukawaModification%pw(irec3,1) = VYukawaModification%pw(irec3,1) + VIqz(iqz) * partitioning / ( stars%nstr(irec3) / stars%nstr2(1) )
    end do

    ! MUFFIN-TIN POTENTIAL

    call Vmts( input, fmpi, stars, sphhar, atoms, sym, cell, oneD, .FALSE., &
               VYukawaModification%pw(:,1), den%mt(:,0:,:,1), VYukawaModification%potdenType, &
               VYukawaModification%mt(:,0:,:,1) )

    ! APPLYING THE MODIFICATION TO THE YUKAWA POTENTIAL

    call VYukawa%AddPotDen( VYukawa, VYukawaModification )

  end subroutine VYukawaModify

end module m_VYukawaFilm


submodule(forlab_linalg) forlab_linalg_diff

    implicit none

contains

    !> `diff` computes differences of arrays of the real(sp) type.
    pure module function diff_1_sp(x, n) result(result)
        real(sp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: n
        real(sp), dimension(:), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = x
        do i = 1, n_
            result = result(2:) - result(:size(result) - 1)
        end do

    end function diff_1_sp

    !> `diff` computes differences of arrays of the real(sp) type.
    pure module function diff_2_sp(A, n, dim) result(result)
        real(sp), dimension(:, :), intent(in) :: A
        integer, intent(in), optional :: n, dim
        real(sp), dimension(:, :), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = A
        if ((.not. present(dim)) .or. (dim == 1)) then
            do i = 1, n_
                result = result(2:, :) - result(:size(result, 1) - 1, :)
            end do
        elseif (dim == 2) then
            do i = 1, n_
                result = result(:, 2:) - result(:, :size(result, 2) - 1)
            end do
        end if

    end function diff_2_sp
    !> `diff` computes differences of arrays of the real(dp) type.
    pure module function diff_1_dp(x, n) result(result)
        real(dp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: n
        real(dp), dimension(:), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = x
        do i = 1, n_
            result = result(2:) - result(:size(result) - 1)
        end do

    end function diff_1_dp

    !> `diff` computes differences of arrays of the real(dp) type.
    pure module function diff_2_dp(A, n, dim) result(result)
        real(dp), dimension(:, :), intent(in) :: A
        integer, intent(in), optional :: n, dim
        real(dp), dimension(:, :), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = A
        if ((.not. present(dim)) .or. (dim == 1)) then
            do i = 1, n_
                result = result(2:, :) - result(:size(result, 1) - 1, :)
            end do
        elseif (dim == 2) then
            do i = 1, n_
                result = result(:, 2:) - result(:, :size(result, 2) - 1)
            end do
        end if

    end function diff_2_dp
    !> `diff` computes differences of arrays of the integer(int8) type.
    pure module function diff_1_int8(x, n) result(result)
        integer(int8), dimension(:), intent(in) :: x
        integer, intent(in), optional :: n
        integer(int8), dimension(:), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = x
        do i = 1, n_
            result = result(2:) - result(:size(result) - 1)
        end do

    end function diff_1_int8

    !> `diff` computes differences of arrays of the integer(int8) type.
    pure module function diff_2_int8(A, n, dim) result(result)
        integer(int8), dimension(:, :), intent(in) :: A
        integer, intent(in), optional :: n, dim
        integer(int8), dimension(:, :), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = A
        if ((.not. present(dim)) .or. (dim == 1)) then
            do i = 1, n_
                result = result(2:, :) - result(:size(result, 1) - 1, :)
            end do
        elseif (dim == 2) then
            do i = 1, n_
                result = result(:, 2:) - result(:, :size(result, 2) - 1)
            end do
        end if

    end function diff_2_int8
    !> `diff` computes differences of arrays of the integer(int16) type.
    pure module function diff_1_int16(x, n) result(result)
        integer(int16), dimension(:), intent(in) :: x
        integer, intent(in), optional :: n
        integer(int16), dimension(:), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = x
        do i = 1, n_
            result = result(2:) - result(:size(result) - 1)
        end do

    end function diff_1_int16

    !> `diff` computes differences of arrays of the integer(int16) type.
    pure module function diff_2_int16(A, n, dim) result(result)
        integer(int16), dimension(:, :), intent(in) :: A
        integer, intent(in), optional :: n, dim
        integer(int16), dimension(:, :), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = A
        if ((.not. present(dim)) .or. (dim == 1)) then
            do i = 1, n_
                result = result(2:, :) - result(:size(result, 1) - 1, :)
            end do
        elseif (dim == 2) then
            do i = 1, n_
                result = result(:, 2:) - result(:, :size(result, 2) - 1)
            end do
        end if

    end function diff_2_int16
    !> `diff` computes differences of arrays of the integer(int32) type.
    pure module function diff_1_int32(x, n) result(result)
        integer(int32), dimension(:), intent(in) :: x
        integer, intent(in), optional :: n
        integer(int32), dimension(:), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = x
        do i = 1, n_
            result = result(2:) - result(:size(result) - 1)
        end do

    end function diff_1_int32

    !> `diff` computes differences of arrays of the integer(int32) type.
    pure module function diff_2_int32(A, n, dim) result(result)
        integer(int32), dimension(:, :), intent(in) :: A
        integer, intent(in), optional :: n, dim
        integer(int32), dimension(:, :), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = A
        if ((.not. present(dim)) .or. (dim == 1)) then
            do i = 1, n_
                result = result(2:, :) - result(:size(result, 1) - 1, :)
            end do
        elseif (dim == 2) then
            do i = 1, n_
                result = result(:, 2:) - result(:, :size(result, 2) - 1)
            end do
        end if

    end function diff_2_int32
    !> `diff` computes differences of arrays of the integer(int64) type.
    pure module function diff_1_int64(x, n) result(result)
        integer(int64), dimension(:), intent(in) :: x
        integer, intent(in), optional :: n
        integer(int64), dimension(:), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = x
        do i = 1, n_
            result = result(2:) - result(:size(result) - 1)
        end do

    end function diff_1_int64

    !> `diff` computes differences of arrays of the integer(int64) type.
    pure module function diff_2_int64(A, n, dim) result(result)
        integer(int64), dimension(:, :), intent(in) :: A
        integer, intent(in), optional :: n, dim
        integer(int64), dimension(:, :), allocatable :: result
        integer :: n_, i

        n_ = merge(n, 1, present(n))

        result = A
        if ((.not. present(dim)) .or. (dim == 1)) then
            do i = 1, n_
                result = result(2:, :) - result(:size(result, 1) - 1, :)
            end do
        elseif (dim == 2) then
            do i = 1, n_
                result = result(:, 2:) - result(:, :size(result, 2) - 1)
            end do
        end if

    end function diff_2_int64

end submodule forlab_linalg_diff


! this library implements the limiting functions used in the
! reconstruction.  We use F90 for both speed and clarity, since
! the numpy array notations can sometimes be confusing.

!-----------------------------------------------------------------------------
! nolimit
!-----------------------------------------------------------------------------
subroutine nolimit(idir, a, lda, qx, qy, ng)

  ! just to a centered difference -- no limiting
  implicit none

  integer, intent(in) :: idir
  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: a(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: lda(0:qx-1, 0:qy-1)

!f2py intent(in) :: idir
!f2py depend(qx, qy) :: a, lda
!f2py intent(in) :: a
!f2py intent(out) :: lda

! call this as: lda = reconstruction_f.nolimit(1,a,qx,qy,ng)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  lda(:,:) = 0.0d0

  select case (idir)

  case (1)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2
           lda(i,j) = 0.5d0*(a(i+1,j) - a(i-1,j))
        enddo
     enddo

  case (2)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2
           lda(i,j) = 0.5d0*(a(i,j+1) - a(i,j-1))
        enddo
     enddo

  end select

end subroutine nolimit

!-----------------------------------------------------------------------------
! limit2
!-----------------------------------------------------------------------------
subroutine limit2(idir, a, lda, qx, qy, ng)

  ! 2nd order limited centered difference
  implicit none

  integer, intent(in) :: idir
  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: a(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: lda(0:qx-1, 0:qy-1)

!f2py intent(in) :: idir
!f2py depend(qx, qy) :: a, lda
!f2py intent(in) :: a
!f2py intent(out) :: lda

! call this as: lda = reconstruction_f.limit2(1,a,qx,qy,ng)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  double precision :: test

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  lda(:,:) = 0.0d0

  select case (idir)

  case (1)

     do j = jlo-3, jhi+3
        do i = ilo-3, ihi+3

           ! test whether we are at an extremum
           test = (a(i+1,j) - a(i,j))*(a(i,j) - a(i-1,j))

           if (test > 0.0d0) then
              lda(i,j) = min(0.5d0*abs(a(i+1,j) - a(i-1,j)), &
                             min(2.0d0*abs(a(i+1,j) - a(i,j)), &
                                 2.0d0*abs(a(i,j) - a(i-1,j)))) * &
                         sign(1.0d0,a(i+1,j) - a(i-1,j))

           else
              lda(i,j) = 0.0d0
           endif

        enddo
     enddo

  case (2)

     do j = jlo-3, jhi+3
        do i = ilo-3, ihi+3

           ! test whether we are at an extremum
           test = (a(i,j+1) - a(i,j))*(a(i,j) - a(i,j-1))

           if (test > 0.0d0) then
              lda(i,j) = min(0.5d0*abs(a(i,j+1) - a(i,j-1)), &
                             min(2.0d0*abs(a(i,j+1) - a(i,j)), &
                                 2.0d0*abs(a(i,j) - a(i,j-1)))) * &
                         sign(1.0d0,a(i,j+1) - a(i,j-1))

           else
              lda(i,j) = 0.0d0
           endif

        enddo
     enddo

  end select

end subroutine limit2

!-----------------------------------------------------------------------------
! limit4
!-----------------------------------------------------------------------------
subroutine limit4(idir, a, lda, qx, qy, ng)

  ! 4th order limited centered difference
  !
  ! See Colella (1985) Eq. 2.5 and 2.6, Colella (1990) page 191 (with
  ! the delta a terms all equal) or Saltzman 1994, page 156
  implicit none

  integer, intent(in) :: idir
  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: a(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: lda(0:qx-1, 0:qy-1)

!f2py intent(in) :: idir
!f2py depend(qx, qy) :: a, lda
!f2py intent(in) :: a
!f2py intent(out) :: lda

! call this as: lda = reconstruction_f.limit4(1,a,qx,qy,ng)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  double precision :: test
  double precision :: temp(0:qx-1,0:qy-1)

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  lda(:,:) = 0.0d0

  ! first get the 2nd order estimate
  call limit2(idir, a, temp, qx, qy, ng)

  select case (idir)

  case (1)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2

           ! test whether we are at an extremum
           test = (a(i+1,j) - a(i,j))*(a(i,j) - a(i-1,j))

           if (test > 0.0d0) then
              lda(i,j) = &
                   min( (2.0d0/3.0d0)*abs(a(i+1,j) - a(i-1,j) - &
                         0.25d0*(temp(i+1,j) + temp(i-1,j))), &
                       min(2.0d0*abs(a(i+1,j) - a(i  ,j)), &
                           2.0d0*abs(a(i  ,j) - a(i-1,j))) ) * &
                   sign(1.0d0,a(i+1,j) - a(i-1,j))

           else
              lda(i,j) = 0.0d0
           endif

        enddo
     enddo

  case (2)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2

           ! test whether we are at an extremum
           test = (a(i,j+1) - a(i,j))*(a(i,j) - a(i,j-1))

           if (test > 0.0d0) then
              lda(i,j) = &
                   min( (2.0d0/3.0d0)*abs(a(i,j+1) - a(i,j-1) - &
                         0.25d0*(temp(i,j+1) + temp(i,j-1))), &
                       min(2.0d0*abs(a(i,j+1) - a(i,j  )), &
                           2.0d0*abs(a(i,j  ) - a(i,j-1))) ) * &
                   sign(1.0d0,a(i,j+1) - a(i,j-1))

           else
              lda(i,j) = 0.0d0
           endif

        enddo
     enddo

  end select

end subroutine limit4

!-----------------------------------------------------------------------------
! flatten
!-----------------------------------------------------------------------------
subroutine flatten(idir, p, u, xi, qx, qy, ng, smallp, delta, z0, z1)

  ! 1-d flattening near shocks
  !
  ! flattening kicks in behind strong shocks and reduces the
  ! reconstruction to using piecewise constant slopes, making things
  ! first-order.  See Saltzman (1994) page 159 for this
  ! implementation.
  implicit none

  integer, intent(in) :: idir
  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: p(0:qx-1, 0:qy-1), u(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: xi(0:qx-1, 0:qy-1)
  double precision, intent(in   ) :: smallp, delta, z0, z1

!f2py intent(in) :: idir
!f2py depend(qx, qy) :: p, u, xi
!f2py intent(in) :: p, u
!f2py intent(out) :: xi

! call this as: xi = reconstruction_f.flatten(1,p,u,qx,qy,ng,smallp,delta,z0,z1)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  double precision :: test1, test2
  double precision :: dp, dp2, z

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  xi(:,:) = 1.0d0

  select case (idir)

  case (1)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2

           dp  = abs(p(i+1,j) - p(i-1,j))
           dp2 = abs(p(i+2,j) - p(i-2,j))
           z = dp/max(dp2,smallp)

           test1 = u(i-1,j) - u(i+1,j)
           test2 = dp/min(p(i+1,j),p(i-1,j))

           if (test1 > 0.0d0 .and. test2 > delta) then
              xi(i,j) = min(1.0d0, max(0.0d0, 1.0d0 - (z - z0)/(z1 - z0)))
           else
              xi(i,j) = 1.0
           endif

        enddo
     enddo

  case (2)

     do j = jlo-2, jhi+2
        do i = ilo-2, ihi+2

           dp  = abs(p(i,j+1) - p(i,j-1))
           dp2 = abs(p(i,j+2) - p(i,j-2))
           z = dp/max(dp2,smallp)

           test1 = u(i,j-1) - u(i,j+1)
           test2 = dp/min(p(i,j+1),p(i,j-1))

           if (test1 > 0.0d0 .and. test2 > delta) then
              xi(i,j) = min(1.0d0, max(0.0d0, 1.0d0 - (z - z0)/(z1 - z0)))
           else
              xi(i,j) = 1.0
           endif

        enddo
     enddo

  end select

end subroutine flatten

!-----------------------------------------------------------------------------
! flatten_multid
!-----------------------------------------------------------------------------
subroutine flatten_multid(xi_x, xi_y, p, xi, qx, qy, ng)

  ! multi-dimensional flattening
  implicit none

  integer, intent(in) :: qx, qy, ng

  ! 0-based indexing to match python
  double precision, intent(inout) :: xi_x(0:qx-1, 0:qy-1)
  double precision, intent(inout) :: xi_y(0:qx-1, 0:qy-1)
  double precision, intent(inout) :: p(0:qx-1, 0:qy-1)
  double precision, intent(  out) :: xi(0:qx-1, 0:qy-1)

!f2py depend(qx, qy) :: xi_x, xi_y, p, xi
!f2py intent(in) :: xi_x, xi_y, p
!f2py intent(out) :: xi

! call this as: xi = reconstruction_f.flatten_multid(xi_x,xi_y,,p,qx,qy,ng)

  integer :: ilo, ihi, jlo, jhi
  integer :: nx, ny
  integer :: i, j

  integer :: sx, sy

  nx = qx - 2*ng; ny = qy - 2*ng
  ilo = ng; ihi = ng+nx-1; jlo = ng; jhi = ng+ny-1

  xi(:,:) = 1.0d0

  do j = jlo-2, jhi+2
     do i = ilo-2, ihi+2

        sx = int(sign(1.0d0, p(i+1,j) - p(i-1,j)))
        sy = int(sign(1.0d0, p(i,j+1) - p(i,j-1)))

        xi(i,j) = min(min(xi_x(i,j), xi_x(i-sx,j)), &
                      min(xi_y(i,j), xi_y(i,j-sy)))

     enddo
  enddo

end subroutine flatten_multid