!===================================================== ==============PHYSICSAL & MATHEMATICAL CONSTANTS===!
module constants_mod
!_________________________________________________________________________________________________________!
   real, parameter :: pi = 3.1415926535898      ! Pi
   complex, parameter :: ii = (0.0,1.0)           ! Square root of -1
   real, parameter :: gravConst = 6.67408E-11   ! Gravitational constant (m^3/kg/s^2)
end module constants_mod

!===========================================================================================PLANETS_MOD===!
module planets_mod
!_________________________________________________________________________________________________________!
   use constants_mod

   real :: radius
   real :: mass
   real :: rhoi
   real :: rhow
   real :: gacc
   real :: omega
   real :: acoef, ccoef
   real :: moiA, moiC
   real :: kf

   contains

   ! -------------------------------------------------------------------------
   subroutine earth_init

      radius = 6.371E6              ! Radius of the Earth (m)
      mass = 5.976E24               ! Mass of the Earth (kg)
      rhoi = 920.0                  ! Density of ice (kg/m^3)
      rhow = 1000.0                 ! Density of fresh water (kg/m^3)
      gacc = 9.80665                ! Acceleration due to gravity at the Earth's surface (m/s^2)
      omega = 7.292e-5              ! Rotation rate of the Earth (rad/s)
      moiA = 0.3296145*mass*radius**2 ! Principal moment of inertia of the Earth
      moiC = 0.3307007*mass*radius**2 ! Principal moment of inertia of the Earth
      kf = 0.9342+0.008             ! Fluid (Tidal) Love number

   end subroutine earth_init

   ! -------------------------------------------------------------------------
   subroutine mars_init

      radius = 3.3899E6             ! Radius of Mars (m)
      mass = 6.4185E23              ! Mass of Mars (kg)
      rhoi = 1220.0                 ! Density of ice mix on Mars (kg/m^3)
      rhow = 1000.0                 ! Density of fresh water (kg/m^3)
      gacc = 3.713                  ! Acceleration due to gravity at Mars's surface (m/s^2)
      omega = 7.08819118E-5         ! Rotation rate of Mars (rad/s)
      moiA = 0.363914*mass*radius**2  ! Principal moments of inertia of Mars
      moiC = 0.365905*mass*radius**2  ! Principal moments of inertia of Mars
      !----------------------------------------------------------------------------------!
      ! Lithospheric thickness and corresponding kf (based on Zharkov and Gudkova, 2005)
      !    15    |    48    |    58    |    84    |    110   |    164    |    200    [km]
      ! 1.203959 | 1.127384 | 1.110566 | 1.065899 | 1.023186 | 0.9458358 | 0.8986673
      !----------------------------------------------------------------------------------!
      kf = 0.899                    ! Fluid (Tidal) Love number

   end subroutine mars_init

end module planets_mod

!=====================================================================================netCDF I/O mod===!
module sl_io_mod
!-------------------------------------------------------------------------------------------------------
   use user_specs_mod, only: nglv, ext, fType_in, fType_out, outputfolder, gridfolder, grid_lat, grid_lon, unit_num
   use netCDF
   implicit none

   public :: sl_drive_readnl, sl_readnl

   contains

   subroutine check(status)

      integer, intent ( in) :: status

      if(status /= nf90_noerr) then
         print *, trim(nf90_strerror(status))
         print *, "NetCDF I/O error occurred in the Sea Level Model."
         print *, "Backtrace of calling routines:"
         CALL BACKTRACE
         stop "Stopping Sea Level Model."
      endif

   end subroutine check

   ! -------------------------------------------------------------------------
   subroutine read_sl(data_slm, filename, filepath, suffix, fext)
      character (len = *), intent (in) :: filename, filepath
      real, dimension(nglv,2*nglv), intent(inout) :: data_slm
      character (len = *), optional :: suffix, fext

      if (fType_in == 'text') then
         call read_txt(data_slm, filename, filepath, suffix, fext)
      elseif (fType_in == 'netcdf') then
         call read_nf90(data_slm, filename, filepath, suffix, fext)
      else
         write(unit_num,*) "Error: fType_in should be one of 'netcdf' or 'text'"
         stop
      endif

   end subroutine read_sl

   ! -------------------------------------------------------------------------
   subroutine write_sl(data_slm, filename, filepath, suffix, fext)
      character (len = *), intent (in) :: filename, filepath
      real, dimension(nglv,2*nglv), intent(in) :: data_slm
      character (len = *), optional :: suffix, fext

      if ((fType_out == 'text') .or. (fType_out == 'both')) then
         call write_txt(data_slm, filename, filepath, suffix, fext)
      endif
      if ((fType_out == 'netcdf') .or. (fType_out == 'both')) then
         call write_nf90(data_slm, filename, filepath, suffix, fext='.nc')
      endif
      if ((fType_out /= 'netcdf') .and. (fType_out /= 'text') .and. (fType_out /= 'both')) then
         write(unit_num,*) "Error: fType_out should be one of 'netcdf', 'text', or 'both'"
         stop
      endif

   end subroutine write_sl

   ! -------------------------------------------------------------------------
   subroutine write_nf90(data_slm, filename, filepath, suffix, fext)

      character (len = *), intent(in) :: filename, filepath
      integer :: ncid, varid, lat_varid, lon_varid, lat_dimid, lon_dimid
      integer, dimension(2) :: dimids
      real, dimension(nglv,2*nglv), intent(in) :: data_slm !data in the SLM written to the netCDF file
      character (len = *), optional ::  suffix
      character (len = *), optional :: fext
      real, dimension(nglv)        :: latgrid
      real, dimension(2*nglv)      :: longrid

      ! attribute IDs for I/O in netCDF
      !character (len = *), parameter :: UNITS = "units"
      !character (len = *), parameter :: TOPO_UNITS = "meters"
      !character (len = *), parameter :: SL_UNITS = "meters"
      !character (len = *), parameter :: LAT_UNITS = "degrees"
      !character (len = *), parameter :: LON_UNITS = "degrees_east"

      ! Read in lat-lon grid files
      open(unit = 201, file = trim(gridfolder)//trim(grid_lat), form = 'formatted', &
      & access = 'sequential', status = 'old')
      read(201,*) latgrid
      close(201)

      open(unit = 201, file = trim(gridfolder)//trim(grid_lon), form = 'formatted', &
      & access = 'sequential', status = 'old')
      read(201,*) longrid
      close(201)

       !write out data

      !create file
      if (present (suffix)) then
          if (present (fext)) then
             call check( nf90_create(trim(filepath)//trim(filename)//trim(suffix)//trim(fext), &
            & nf90_clobber, ncid) )
          else
             call check( nf90_create(trim(filepath)//trim(filename)//trim(suffix)//trim(ext), &
            nf90_clobber, ncid) )
          endif
      else
         if (present (fext)) then
            call check( nf90_create(trim(filepath)//trim(filename)//trim(fext), nf90_clobber, &
            & ncid) )
         else
            call check( nf90_create(trim(filepath)//trim(filename)//trim(ext), nf90_clobber, &
            & ncid) )
         endif
      endif

      call check( nf90_def_dim(ncid, 'lon', nglv*2, lon_dimid)  ) ! Define the dimensions of the griddata
      call check( nf90_def_dim(ncid, 'lat', nglv,   lat_dimid)  )

      dimids =  (/ lon_dimid, lat_dimid /)                        ! Define the dimension of the variable

      call check( nf90_def_var(ncid, trim(filename), nf90_double, dimids, varid)) ! Define variable
      call check( nf90_def_var(ncid, 'lat', nf90_double, lat_dimid, lat_varid))
      call check( nf90_def_var(ncid, 'lon', nf90_double, lon_dimid, lon_varid))
      call check( nf90_enddef(ncid)) ! End definition

      call check( nf90_put_var(ncid, varid, reshape(data_slm,[2*nglv,nglv]))) !write data
      call check( nf90_put_var(ncid, lon_varid, longrid))
      call check( nf90_put_var(ncid, lat_varid, latgrid))
      call check( nf90_close(ncid))

   end subroutine write_nf90

   ! -------------------------------------------------------------------------
   subroutine read_nf90(data_slm, filename, filepath, suffix, fext)

      character (len = *), intent(in) :: filename, filepath !file name and path
      real, dimension(2*nglv,nglv) :: data_temp !temp. variable name in the SLM in which nc data will be stored
      real, dimension(nglv,2*nglv), intent(out) :: data_slm
      character (len = *), optional ::  suffix
      character (len = *), optional :: fext
      integer :: ncid, varid

      !open the file
      if (present (suffix)) then
          if (present (fext)) then
             call check( nf90_open(trim(filepath)//trim(filename)//trim(suffix)//trim(fext), &
            & nf90_nowrite, ncid) )
          else
             call check( nf90_open(trim(filepath)//trim(filename)//trim(suffix)//trim(ext), &
            & nf90_nowrite, ncid) )
          endif
      else
         if (present (fext)) then
            call check( nf90_open(trim(filepath)//trim(filename)//trim(fext), nf90_nowrite, ncid) )
         else
            call check( nf90_open(trim(filepath)//trim(filename)//trim(ext), nf90_nowrite, ncid) )
         endif
      endif

      call check( nf90_inq_varid(ncid, trim(filename), varid) ) !get varid of the data variable
      call check( nf90_get_var(ncid, varid, data_temp) ) ! read the data
      call check( nf90_close(ncid) ) ! close the file
      data_slm = reshape(data_temp,[nglv,2*nglv])

   end subroutine read_nf90

   ! -------------------------------------------------------------------------
   subroutine check_ncFile(ncvar, slmvar, varname)

      real, dimension(nglv,2*nglv), intent(in) :: ncvar, slmvar
      character (len = *), intent(in) :: varname

      if (sum(sum(ncvar, dim=1))-sum(sum(slmvar,dim=1)) .NE.0) then
         write(201,*) 'ncFile benchmark test FAILED. Var name is:                              ', varname
      else if (sum(sum(ncvar, dim=1))-sum(sum(slmvar, dim=1)).eq.0) then
         write(201,*) 'ncFile benchmark test PASSED. Var name is:                              ', varname
      endif

   end subroutine check_ncFile

   ! -------------------------------------------------------------------------
   subroutine write_txt(data_slm, filename, filepath, suffix, fext)

   real, dimension(nglv,2*nglv), intent(in) :: data_slm
      character (len = *), intent(in) :: filename, filepath
      character (len = *), optional :: fext, suffix

    if (.not.present (fext)) then
          fext = ext
    end if

   if (present (suffix)) then
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(suffix)//fext, form = 'formatted', &
      & access = 'sequential', status = 'replace')
        write(201,'(ES16.9E2)') data_slm
        close(201)
   else
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(fext), form = 'formatted', &
      & access = 'sequential', status = 'replace')
        write(201,'(ES16.9E2)') data_slm
        close(201)
   endif

   end subroutine write_txt

   ! -------------------------------------------------------------------------
   subroutine read_txt(data_slm, filename, filepath, suffix, fext)

   real, dimension(nglv,2*nglv) :: data_slm
      character (len = *), intent(in) :: filename, filepath
      character (len = *), optional :: fext, suffix

    if (.not.present (fext)) then
          fext = ext
    end if

   if (present (suffix)) then
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(suffix)//trim(fext), &
      & form = 'formatted', access = 'sequential', status = 'old')
      read(201,*) data_slm
      close(201)
   else
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(fext), form = 'formatted', &
      & access = 'sequential', status = 'old')
      read(201,*) data_slm
      close(201)
   endif

   end subroutine read_txt

   ! -------------------------------------------------------------------------
   ! read variables needed to drive the SLM from namelist
   subroutine sl_drive_readnl(itersl, dt1, starttime)

      real, intent(out) :: starttime
      integer, intent(out) :: itersl, dt1

      namelist /time_config/ starttime, itersl, dt1

      open(201, file='namelist.sealevel', status='old')
      read(201, time_config)
      close(201)

   end subroutine sl_drive_readnl

   ! -------------------------------------------------------------------------
   ! read all other variables from namelist
   subroutine sl_readnl(inputfolder_ice, inputfolder, &
                        planetfolder, gridfolder, &
                        outputfolder, outputfolder_ice, &
                        folder_coupled, ext, fType_in, fType_out, &
                        planetmodel, icemodel, icemodel_out, &
                        timearray, topomodel, topo_initial, &
                        grid_lat, grid_lon, checkmarine, &
                        tpw, calcRG, input_times, &
                        initial_topo, iceVolume, coupling, &
                        patch_ice, L_sim, dt1, dt2, &
                        dt3, dt4, Ldt1, Ldt2, &
                        Ldt3, Ldt4, whichplanet)

      character(*), intent(out) :: inputfolder_ice
      character(*), intent(out) :: inputfolder
      character(*), intent(out) :: planetfolder
      character(*), intent(out) :: gridfolder
      character(*), intent(out) :: outputfolder
      character(*), intent(out) :: outputfolder_ice
      character(*), intent(out) :: folder_coupled

      character(*), intent(out) :: ext
      character(*), intent(out) :: fType_in
      character(*), intent(out) :: fType_out

      character(*), intent(out) :: planetmodel
      character(*), intent(out) :: icemodel
      character(*), intent(out) :: icemodel_out
      character(*), intent(out) :: timearray
      character(*), intent(out) :: topomodel
      character(*), intent(out) :: topo_initial
      character(*), intent(out) :: grid_lat
      character(*), intent(out) :: grid_lon

      logical, intent(out)  :: checkmarine
      logical, intent(out)  :: tpw
      logical, intent(out)  :: calcRG
      logical, intent(out)  :: input_times
      logical, intent(out)  :: initial_topo
      logical, intent(out)  :: iceVolume
      logical, intent(out)  :: coupling
      logical, intent(out)  :: patch_ice

      integer, intent(out)  :: L_sim
      integer, intent(out)  :: dt1
      integer, intent(out)  :: dt2
      integer, intent(out)  :: dt3
      integer, intent(out)  :: dt4
      integer, intent(out)  :: Ldt1
      integer, intent(out)  :: Ldt2
      integer, intent(out)  :: Ldt3
      integer, intent(out)  :: Ldt4

      character(*), intent(out) :: whichplanet

      namelist /io_directory/ inputfolder_ice, inputfolder, &
                              planetfolder, gridfolder, &
                              outputfolder, outputfolder_ice, &
                              folder_coupled

      namelist /file_format/ ext, fType_in, fType_out

      namelist   /file_name/ planetmodel, icemodel, icemodel_out, &
                           timearray, topomodel, topo_initial, &
                           grid_lat,grid_lon

      namelist /model_config/ checkmarine, tpw, calcRG, &
                              input_times, initial_topo, iceVolume, &
                              coupling, patch_ice

      namelist /timewindow_config/ L_sim, dt1, dt2, dt3, &
                                   dt4, Ldt1, Ldt2, Ldt3, &
                                   Ldt4

      namelist /others/ whichplanet

      open(201, file='namelist.sealevel', status='old', form='formatted')
      read(201, io_directory)
      read(201, file_format)
      read(201, file_name)
      read(201, model_config)
      read(201, timewindow_config)
      read(201, others)
      close(201)

   end subroutine sl_readnl

end module sl_io_mod


subroutine reftrace(alfa,zlow,zup,ips, time,dist,hmax)

! zstat : starting level
! alfa : dipping angle at the starting level
! zzt : finishing level. It is always above that zstart
! izgib : marker. When 0, the ray goes

real zzz(300),rrr(300),vvv(300)

common/refmod/nrefmod,zref(600),vref(600,2)
common/pi/pi,per
rz=6378.

!write(*,*)alfa,zstat,zzt,izgib

!zup=-5
!zlow=-1
!ips=1
!alfa=60

dist=-999.
time=-999.

rup=rz-zup
rlow=rz-zlow

vup=vrefmod(zup,ips)
vlow=vrefmod(zlow,ips)
!write(*,*)' zzt=',zzt,' vzt=',vzt,' ips=',ips

nref=nrefmod+1
do i=1,nref-1
	rrr(i)=rz-zref(i)
	vvv(i)=vref(i,ips)
end do
rrr(nref)=0
vvv(nref)=15.

!do i=1,nref
!    write(*,*)i,rz-rrr(i),vvv(i)
!end do
!stop

if(abs(alfa-180).lt.1.e-9) then
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Tracing vertical ray from rlow to rup
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    time=0
    hmax=zlow
    dist=0
    do il=1,nref-1
        v1=vvv(il)
        v2=vvv(il+1)
        r1=rrr(il)
        r2=rrr(il+1)
        !write(*,*)' ini: r1=',rz-r1,' r2=',rz-r2
        if(r2.ge.rup-1.e-9) cycle
        if(r1.le.rlow) exit
        if((r1-rup)*(r2-rup).lt.0.)then
            v1=vup
            r1=rup
        end if
        if((r1-rlow)*(r2-rlow).le.0.)then
            v2=vlow
            r2=rlow
        end if
        !write(*,*)' aft: r1=',rz-r1,' r2=',rz-r2
        !write(*,*)' aft: v1=',v1,' v2=',v2
        p2=r2/v2
        if(r2.eq.r1.and.p2.gt.p) cycle
        if(r2.eq.r1.and.p2.le.p) then
            hmax=rz-r2
            exit
        end if

        aaa = (v2-v1) / (r2-r1)
        bbb = v1 - aaa*r1
        dt = (alog(aaa*r1+bbb) - alog(aaa*r2+bbb)) / aaa
        time=time+dt

    end do
    return
end if

sina=sin(alfa*per)
p=rlow*sina/vlow

!write(*,*)' p=',p,' vzt=',vzt

!write(*,*)' rup=',rup,' rlow=',rlow

ep1=0.
time1=0.

k_1_2 = 2

if(abs(alfa-90).lt.1.e-9) then ! The case when ray starts horizontally
    rmax=rlow
    hmax=rz-rmax
    p=rlow/vlow

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Compute the maximal depth of the ray
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!do ilay=1,nref-1
!	v1=vvv(ilay)
!	v2=vvv(ilay+1)
!	r1=rrr(ilay)
!	r2=rrr(ilay+1)
!	p2=r2/v2
!	if(p2.gt.p) cycle
!	if(r2.eq.r1.and.p2.lt.p) exit
!	aaa=(v1-v2)/(r1-r2)
!	bbb=(v2*r1-v1*r2)/(r1-r2)
!	rmax=p*bbb/(1.-p*aaa)
!	if((r1-rmax)*(r2-rmax).le.0.)goto 53
!end do
!ilay=ilay-1
!53 continue
!hmax=rz-rmax
!vmax=vrefmod(hmax,ips)
!
!write(*,*)' hmax=',hmax,' vmax=',vmax

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Tracing from rlow to the turning point
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    time=0
    ep=0
    do il=1,nref-1
	    v1=vvv(il)
	    v2=vvv(il+1)
	    r1=rrr(il)
	    r2=rrr(il+1)
    !write(*,*)' ini: r1=',rz-r1,' r2=',rz-r2
	    if(r2.ge.rup-1.e-9) cycle
	    if(r1.le.rmax) exit
	    if((r1-rup)*(r2-rup).lt.0.)then
		    v1=vup
		    r1=rup
	    end if
	    if(r2.eq.r1) cycle
            !write(*,*)' aft: r1=',rz-r1,' r2=',rz-r2
	    call ray_lay(r1,r2,v1,v2,p,dt,dep)
	    !write(*,*)' v1=',v1,' v2=',v2,' p=',p
	    !write(*,*)' dt=',dt,' dep=',dep*rz
	    time=time+dt
	    ep=ep+dep
    !write(*,*)' dep=',dep,' dt=',dt
    !write(*,*)
    end do
    dist=ep*rz
!write(*,*)' ep2=',ep*rz,' time2=',time

    return
end if

if(abs(rup-rlow).lt.1.e-9) then ! The case when source and receiver are at the same level
    k_1_2 = 2
    goto 883
end if

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Tracing from rlow to rup
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do il=1,nref-1
	v1=vvv(il)
	v2=vvv(il+1)
	r1=rrr(il)
	r2=rrr(il+1)
!write(*,*)' ini: r1=',rz-r1,' r2=',rz-r2
	if(r2.ge.rup-1.e-9) cycle
	if(r1.le.rlow) exit
	if((r1-rup)*(r2-rup).lt.0.)then
		v1=vup
		r1=rup
	end if
	if((r1-rlow)*(r2-rlow).le.0.)then
		v2=vlow
		r2=rlow
	end if
!write(*,*)' aft: r1=',rz-r1,' r2=',rz-r2
!write(*,*)' aft: v1=',v1,' v2=',v2
	p2=r2/v2
	if(r2.eq.r1.and.p2.gt.p) cycle
	if(r2.eq.r1.and.p2.le.p) then
		hmax=rz-r2
		exit
	end if
	call ray_lay(r1,r2,v1,v2,p,dt,dep)
!write(*,*)' z1=',rz-r1,' z2=',rz-r2,dt,dep*rz
	!if(il.eq.16)write(*,*)' v1=',v1,' v2=',v2,' p=',p
	!write(*,*)il,' dt=',dt,' dep=',dep,' dz=',r2-r1
	!if(il.eq.32) pause
	time1=time1+dt
	ep1=ep1+dep
	if(p2.le.p) then
		aaa=(v1-v2)/(r1-r2)
		bbb=(v2*r1-v1*r2)/(r1-r2)
		hmax=rz-p*bbb/(1.-p*aaa)
		!write(*,*)' h1=',rz-r1,' h2=',rz-r2
		!write(*,*)' v1=',v1,' v2=',v2
		!write(*,*)' hmax=',hmax
		return
	end if
	!write(*,*)' il=',il,' h1=',rz-r1,' h2=',rz-r2
	!if(il.eq.16)write(*,*)il,v1,v2,ep1*rz,dep*rz
end do

!write(*,*)' ep1=',ep1*rz,' time1=',time1

883 continue

ep2=0.
time2=0.
hmax=zlow

if(alfa.gt.90+1.e-9)goto 334

!write(*,*)' rup=',rup,' rlw=',rlow
!write(*,*)' vup=',vup,' vlw=',vlow

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the maximal depth of the ray
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do ilay=1,nref-1
	v1=vvv(ilay)
	v2=vvv(ilay+1)
	r1=rrr(ilay)
	r2=rrr(ilay+1)
	p2=r2/v2
!write(*,*)' z1=',rz-r1,' z2=',rz-r2
!write(*,*)' v1=',v1,' v2=',v2
!write(*,*)' p=',p,' p2=',p2
	if(p2.gt.p) cycle
	if(r2.eq.r1.and.p2.lt.p) exit
	aaa=(v1-v2)/(r1-r2)
	bbb=(v2*r1-v1*r2)/(r1-r2)
	rmax=p*bbb/(1.-p*aaa)
        if(rmax.lt.r2) rmax=r2
    !write(*,*)' zmax=',rz-rmax
	!if((r1-rmax)*(r2-rmax).le.0.)goto 3
	goto 3
end do
ilay=ilay-1
3 continue
hmax=rz-rmax
vmax=vrefmod(hmax,ips)

!write(*,*)' hmax=',hmax,' vmax=',vmax

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Tracing from rlow to the turning point
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
884	continue

do il=1,nref-1
	v1=vvv(il)
	v2=vvv(il+1)
	r1=rrr(il)
	r2=rrr(il+1)
!write(*,*)' ini: r1=',rz-r1,' r2=',rz-r2
	if(r2.ge.rlow-1.e-9) cycle
	if(r1.le.rmax) exit
	if((r1-rlow)*(r2-rlow).lt.0.)then
		v1=vlow
		r1=rlow
	end if
	if(r2.eq.r1) cycle
!write(*,*)' aft: r1=',rz-r1,' r2=',rz-r2
	call ray_lay(r1,r2,v1,v2,p,dt,dep)
	!write(*,*)' v1=',v1,' v2=',v2,' p=',p
	!write(*,*)' dt=',dt,' dep=',dep*rz
	time2=time2+dt
	ep2=ep2+dep
!write(*,*)' dep=',dep,' dt=',dt
!write(*,*)
end do

!write(*,*)' ep2=',ep2*rz,' time2=',time2

334 continue

time = time2 * 2 + time1
ep = ep2 * 2 + ep1
dist=ep*rz

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!write(*,*)' time=',time,' dist=',dist
return
end


C$Procedure DVHAT ( Derivative and unit vector "V-hat" of a state)

      SUBROUTINE DVHAT ( S1, SOUT )

C$ Abstract
C
C     Find the unit vector corresponding to a state vector and the
C     derivative of the unit vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C     DERIVATIVE
C     MATH
C
C$ Declarations

      DOUBLE PRECISION   S1   ( 6 )
      DOUBLE PRECISION   SOUT ( 6 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     S1        I     State to be normalized.
C     SOUT      O     Unit vector S1 / |S1|, and its time derivative.
C
C$ Detailed_Input
C
C     S1       This is any double precision state. If the position
C              component of the state is the zero vector, this routine
C              will detect it and will not attempt to divide by zero.
C
C$ Detailed_Output
C
C     SOUT     SOUT is a state containing the unit vector pointing in
C              the direction of position component of S1 and the
C              derivative of the unit vector with respect to time.
C
C              SOUT may overwrite S1.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If S1 represents the zero vector, then the position
C        component of SOUT will also be the zero vector.  The
C        velocity component will be the velocity component
C        of S1.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Let S1 be a state vector with position and velocity components P
C     and V respectively.  From these components one can compute the
C     unit vector parallel to P, call it U and the derivative of U
C     with respect to time, DU.  This pair (U,DU) is the state returned
C     by this routine in SOUT.
C
C$ Examples
C
C   Any numerical results shown for this example may differ between
C   platforms as the results depend on the SPICE kernels used as input
C   and the machine specific arithmetic implementation.
C
C   Suppose that STATE gives the apparent state of a body with
C   respect to an observer.  This routine can be used to compute the
C   instantaneous angular rate of the object across the sky as seen
C   from the observers vantage.
C
C           PROGRAM DVHAT_T
C           IMPLICIT NONE
C
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      LT
C           DOUBLE PRECISION      OMEGA
C           DOUBLE PRECISION      STATE  (6)
C           DOUBLE PRECISION      USTATE (6)
C
C           DOUBLE PRECISION      VNORM
C
C           CHARACTER*(32)        EPOCH
C           CHARACTER*(32)        TARGET
C           CHARACTER*(32)        FRAME
C           CHARACTER*(32)        ABCORR
C           CHARACTER*(32)        OBSRVR
C
C     C
C     C     Load SPK, PCK, and LSK kernels, use a meta kernel for
C     C     convenience.
C     C
C           CALL FURNSH ( 'standard.tm' )
C
C     C
C     C     Define an arbitrary epoch, convert the epoch to ephemeris
C     C     time.
C     C
C           EPOCH = 'Jan 1 2009'
C           CALL STR2ET ( EPOCH, ET )
C
C     C
C     C     Calculate the state of the moon with respect to the
C     C     earth-moon barycenter in J2000, corrected for light time
C     C     and stellar aberration at ET.
C     C
C           TARGET   = 'MOON'
C           FRAME    = 'J2000'
C           ABCORR   = 'LT+S'
C           OBSRVR   = 'EARTH BARYCENTER'
C
C           CALL SPKEZR ( TARGET, ET, FRAME, ABCORR, OBSRVR, STATE, LT )
C
C     C
C     C     Calculate the unit vector of STATE and the derivative of the
C     C     unit vector.
C     C
C           CALL DVHAT ( STATE, USTATE )
C
C     C
C     C     Calculate the instantaneous angular velocity from the
C     C     magnitude of the derivative of the unit vector.
C     C
C     C          v = r x omega
C     C
C     C          ||omega|| = ||v||  for  r . v = 0
C     C                      -----
C     C                      ||r||
C     C
C     C          ||omega|| = ||v||  for  ||r|| = 1
C     C
C           OMEGA = VNORM( USTATE(4) )
C
C           WRITE(*,*) 'Instantaneous angular velocity, rad/sec', OMEGA
C
C           END
C
C   The program outputs:
C
C       Instantaneous angular velocity, rad/sec  2.48106658E-06
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 06-MAY-2010 (EDW)
C
C        Expanded the code example into a complete program.
C
C        Reordered header sections to proper NAIF convention.
C        Removed Revision section, it listed a duplication of a
C        Version section entry.
C
C-    SPICELIB Version 1.1.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VPERP and VSCL calls.
C
C-    SPICELIB Version 1.0.0, 15-JUN-1995 (WLT)
C
C-&

C$ Index_Entries
C
C     State of a unit vector parallel to a state vector
C
C-&

      INTEGER               POS
      PARAMETER           ( POS = 1 )

      INTEGER               VEL
      PARAMETER           ( VEL = 4 )

      DOUBLE PRECISION      LENGTH

C
C     Get the position portion of the output state and the length of
C     the input position.
C
      CALL UNORM ( S1(POS), SOUT(POS), LENGTH )

      IF ( LENGTH .EQ. 0.0D0 ) THEN
C
C        If the length of the input position is zero, just copy
C        the input velocity to the output velocity.
C
         CALL VEQU ( S1(VEL), SOUT(VEL) )

      ELSE
C
C        Otherwise the derivative of the unit vector is just the
C        component of the input velocity perpendicular to the input
C        position, scaled by the reciprocal of the length of the
C        input position.
C
         CALL VPERP  ( S1(VEL),      SOUT(POS), SOUT(VEL) )
         CALL VSCLIP ( 1.0D0/LENGTH,            SOUT(VEL) )

      END IF

      RETURN
      END


*
      SUBROUTINE BICGSTABF( N, B, X, WORK, LDW, ITER, RESID, MATVEC,
     $                     PSOLVE, INFO )
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     Eijkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, LDW, ITER, INFO
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   X( * ), B( * ), WORK( * )
*     ..
*     .. Function Arguments ..
      EXTERNAL           MATVEC, PSOLVE
*     ..
*
*  Purpose
*  =======
*
*  BICGSTAB solves the linear system A*x = b using the
*  BiConjugate Gradient Stabilized iterative method with
*  preconditioning.
*
*  Convergence test: ( norm( b - A*x ) / norm( b ) ) < TOL.
*  For other measures, see the above reference.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER.
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N.
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess. This is commonly set to
*          the zero vector.
*          On exit, if INFO = 0, the iterated approximate solution.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDW,7)
*          Workspace for residual, direction vector, etc.
*          Note that vectors R and S shared the same workspace.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW >= max(1,N).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable convergence measure for
*          norm( b - A*x ) / norm( b ).
*          On output, the final value of this measure.
*
*  MATVEC  (external subroutine)
*          The user must provide a subroutine to perform the
*          matrix-vector product
*
*               y := alpha*A*x + beta*y,
*
*          where alpha and beta are scalars, x and y are vectors,
*          and A is a matrix. Vector x must remain unchanged.
*          The solution is over-written on vector y.
*
*          The call is:
*
*             CALL MATVEC( ALPHA, X, BETA, Y )
*
*          The matrix is passed into the routine in a common block.
*
*  PSOLVE  (external subroutine)
*          The user must provide a subroutine to perform the
*          preconditioner solve routine for the linear system
*
*               M*x = b,
*
*          where x and b are vectors, and M a matrix. Vector b must
*          remain unchanged.
*          The solution is over-written on vector b.
*
*          The call is:
*
*             CALL PSOLVE( X, B )
*
*          The preconditioner is passed into the routine in a common block.
*
*  INFO    (output) INTEGER
*
*          =  0: Successful exit. Iterated approximate solution returned.
*
*          >  0: Convergence to tolerance not achieved. This will be
*                set to the number of iterations performed.
*
*          <  0: Illegal input parameter, or breakdown occurred
*                during iteration.
*
*                Illegal parameter:
*
*                   -1: matrix dimension N < 0
*                   -2: LDW < N
*                   -3: Maximum number of iterations ITER <= 0.
*
*                BREAKDOWN: If parameters RHO or OMEGA become smaller
*                   than some tolerance, the program will terminate.
*                   Here we check against tolerance BREAKTOL.
*
*                  -10: RHO < BREAKTOL: RHO and RTLD have become
*                                       orthogonal.
*                  -11: OMEGA < BREAKTOL: S and T have become
*                                         orthogonal relative to T'*T.
*
*                  BREAKTOL is set in function GETBREAK.
*
*  ==============================================================
*     .. Local Scalars ..
*
*This variable used to communicate requests between BiCGSTAB()
*  and BiCGSTABREVCOM()
*BiCGSTAB -> BiCGSTABREVCOM: 1 = init,
*                            2 = use saved state to resume flow.
*BiCGSTABREVCOM -> BiCGSTAB: -1 = done, return to main,
*                             1 = matvec using SCLR1/2, NDX1/2
*                             2 = solve using NDX1/2
      INTEGER          IJOB
      LOGICAL          FTFLG
*
*     Arg/Result indices into WORK[].
      INTEGER NDX1, NDX2
*     Scalars passed from BiCGSTABREVCOM to BiCGSTAB.
      DOUBLE PRECISION SCLR1, SCLR2
*     Vars reqd for STOPTEST2
      DOUBLE PRECISION TOL, BNRM2
*     ..
*     .. External subroutines ..
      EXTERNAL         BICGSTABREVCOM, STOPTEST2
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
*     Test the input parameters.
*
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSE IF ( LDW.LT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF ( ITER.LE.0 ) THEN
         INFO = -3
      ENDIF
      IF ( INFO.NE.0 ) RETURN
*
*     Stop test may need some indexing info from REVCOM
*     use the init call to send the request across. REVCOM
*     will note these requests, and everytime it asks for
*     stop test to be done, it will provide the indexing info.
*
*     1 == R; 2 == RTLD; 3 == P; 4 == V; 5 == T; 6 == PHAT; 7 == SHAT;
*     8 == S; -1 == ignore; any other == error
      NDX1 = 1
      NDX2 = -1
      TOL = RESID
      FTFLG = .TRUE.
*
*     First time call always init.
*
      IJOB = 1

 1    CONTINUE

      CALL BICGSTABREVCOM(N, B, X, WORK, LDW, ITER, RESID, INFO,
     $                    NDX1, NDX2, SCLR1, SCLR2, IJOB)

      print *, 'BiCGSTABF(): iter ', iter, '  tol ', tol,
     $                                    '  resid ', resid

*     On a return from REVCOM() we use the table (REVCOM -> BiCGSTAB)
*     to decode IJOB.
      IF (IJOB .eq. -1) THEN
*        revcom wants to terminate, so do it.
         GOTO 2
      ELSEIF (IJOB .eq. 1) THEN
*        call matvec.
         CALL MATVEC(SCLR1, WORK(NDX1), SCLR2, WORK(NDX2))
      ELSEIF (IJOB .eq. 2) THEN
*        call solve.
         CALL PSOLVE(WORK(NDX1), WORK(NDX2))
      ELSEIF (IJOB .eq. 3) THEN
*        call matvec with X.
         CALL MATVEC(SCLR1, X, SCLR2, WORK(NDX2))
      ELSEIF (IJOB .EQ. 4) THEN
*        do stopping test 2
*        if first time, set INFO so that BNRM2 is computed.
         IF( FTFLG ) INFO = -1
         CALL STOPTEST2(N, WORK(NDX1), B, BNRM2, RESID, TOL, INFO)
         FTFLG = .FALSE.
      ENDIF
*
*         done what revcom asked, set IJOB & go back to it.
          IJOB = 2
          GOTO 1
*
*     come here to terminate
*
 2    CONTINUE
*
      RETURN
*
*     End of BICGSTABF
*
      END


c     # ---------------------------------------------------------------
      double precision function q0_physical(xp,yp,zp)
      implicit none

      double precision xp, yp, zp

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision x0(2), y0(2), z0(2)
      common /qinit_comm/ x0, y0, z0

      integer example
      common /example_comm/ example

      integer initchoice
      common /initchoice_comm/ initchoice

      double precision b_init, c_init
      common /init_parms/ b_init, c_init

      double precision q0, r0, r, cb(2)
      double precision theta, th, thc(2)
      double precision phi, l, lc(2)
      double precision c,b,cbell, hi, hmax, rarg
      double precision Hsmooth
      integer k

c     # Sphere centered at (0.5,0.5,0) on swirl
      if (initchoice .eq. 1) then
          q0 = 1.d0
      elseif (initchoice .eq. 2) then
          b = b_init
          c = c_init
          x0(1) = cos(pi/6.d0)
          x0(2) = cos(pi/6.d0)
          y0(1) = 0.5d0
          y0(2) = -0.5d0
          z0(1) = 0
          z0(2) = 0

          r0 = 0.35
          q0 = 0
          do  k = 1,2
              r = sqrt((xp - x0(k))**2 + (yp-y0(k))**2
     &                 + (zp-z0(k))**2)
              q0 = q0 + 1 - Hsmooth(r - r0)
          end do
          q0 = b + c*q0
      elseif (initchoice .ge. 3) then
c         # Cosine Bells
          hmax = 1
          b = b_init
          c = c_init
          r0 = 0.5d0

          call map2spherical(xp,yp,zp,theta,phi)
          l = theta
          th = phi

          if (example .eq. 1) then
              lc(1) = pi
              lc(2) = pi
              thc(1) = pi/3.d0
              thc(2) = -pi/3.d0
          elseif (example .eq. 2 .or. example .eq. 4) then
              lc(1) = 5*pi/6.d0
              lc(2) = 7*pi/6.d0
              thc(1) = 0
              thc(2) = 0
          elseif (example .eq. 3) then
              lc(1) = 3*pi/4.d0
              lc(2) = 5*pi/4.d0
              thc(1) = 0
              thc(2) = 0
          endif

          cbell = b
          do k = 1,2
              rarg = sin(thc(k))*sin(th) +
     &                    cos(thc(k))*cos(th)*cos(l-lc(k))
              if (abs(rarg) > 1) then
                   write(6,*)  'rarg > 1'
                   stop
              endif

              r = acos(rarg)
              hi = hmax/2*(1 + cos(pi*r/r0))
              if (r .le. r0) then
                  cbell = b + c*hi
              endif
          end do
          q0 = cbell

      endif
      q0_physical = q0

      end

c     # ---------------------------------------------------------------
      double precision function Hsmooth(r)
      implicit none

      double precision r

      double precision sharpness
      common /hsmooth_parms/ sharpness

      Hsmooth = (tanh(r/sharpness) + 1)/2.d0

      end

      double precision function q0_init(xc,yc)
      implicit none

      double precision xc,yc

      integer example
      common /example_comm/ example

      double precision xp, yp, zp, q0
      double precision q0_physical

      call mapc2m_spherical(xc,yc,xp,yp,zp)

      q0_init = q0_physical(xp,yp,zp)

      end


c
c-----------------------------------------------------------------------
c subroutine: fftsym
c compute dft for real, symmetric, n-point sequence x(m) using
c n/2-point fft
c symmetric sequence means x(m)=x(n-m), m=1,...,n/2-1
c note: index m is sequence index--not fortran index
c-----------------------------------------------------------------------
c
      subroutine fftsym(x, n, y)
      dimension x(1), y(1)
c
c x = real array which on input contains the n/2+1 points of the
c     input sequence (symmetrical)
c     on output x contains the n/2+1 real points of the transform of
c     the input--i.e. the zero valued imaginary parts are not returned
c n = true size of input
c y = scratch array of size n/2+2
c
c
c for n = 2, compute dft directly
c
      if (n.gt.2) go to 10
      t = x(1) + x(2)
      x(2) = x(1) - x(2)
      x(1) = t
      return
  10  twopi = 8.*atan(1.0)
c
c first compute b0 term, where b0=sum of odd values of x(m)
c
      no2 = n/2
      no4 = n/4
      nind = no2 + 1
      b0 = 0.
      do 20 i=2,nind,2
        b0 = b0 + x(i)
  20  continue
      b0 = b0*2.
c
c for n = 4 skip recursion loop
c
      if (n.eq.4) go to 40
c
c form new sequence, y(m)=x(2*m)+(x(2*m+1)-x(2*m-1))
c
      do 30 i=2,no4
        ind = 2*i
        t1 = x(ind) - x(ind-2)
        y(i) = x(ind-1) + t1
        ind1 = no2 + 2 - i
        y(ind1) = x(ind-1) - t1
  30  continue
  40  y(1) = x(1)
      y(no4+1) = x(no2+1)
c
c take n/2 point (real) fft of y
c
      call fast(y, no2)
c
c form original dft by unscrambling y(k)
c use recursion to give sin(tpn*i) multiplier
c
      tpn = twopi/float(n)
      cosi = 2.*cos(tpn)
      sini = 2.*sin(tpn)
      cosd = cosi/2.
      sind = sini/2.
      nind = no4 + 1
      do 50 i=2,nind
        ind = 2*i
        bk = y(ind)/sini
        ak = y(ind-1)
        x(i) = ak + bk
        nind1 = n/2 + 2 - i
        x(nind1) = ak - bk
        temp = cosi*cosd - sini*sind
        sini = cosi*sind + sini*cosd
        cosi = temp
  50  continue
      x(1) = b0 + y(1)
      x(no2+1) = y(1) - b0
      return
      end


module distributions

  use lib_array
  use types
  implicit none
  save

  type size_distribution
     integer :: type
     ! type = 1: power-law
     ! type = 2: numerical
     real(dp) :: amin, amax, apower, aturn
     real(dp),allocatable :: a(:), n(:), m(:)
  end type size_distribution

contains

  subroutine read_distribution(unit, d)

    implicit none

    integer,intent(in) :: unit
    type(size_distribution),intent(out) :: d
    character(len=100) :: distribution_type, filename
    real(dp) :: norm
    integer :: i, ioerr, na

    ! Read in the distribution type
    read(unit,*) distribution_type

    select case(trim(distribution_type))
    case('power')

       d%type = 1

       ! Read in min, max, and power of power-law distribution
       read(unit,*) d%amin, d%amax, d%apower

    case('ped')

       d%type = 2

       ! Read in min, turnoff, and power of PED distribution
       read(unit,*) d%amin, d%aturn, d%apower

       ! Define number of a values to compute the PED for
       na = 1000

       ! Allocate arrays
       allocate(d%a(na), d%n(na), d%m(na))

       do i=1,na
          d%a(i) = 10._dp ** (-5._dp + real(i, dp) / real(na, dp) * 10._dp)
          d%n(i) = d%a(i) ** d%apower * exp(-d%a(i)/d%aturn)
       end do

       ! Compute mass distribution
       d%m = d%n * d%a**3

       ! Set max
       d%amax = d%a(na)

       ! Normalize number distribution
       norm = integral_loglog(d%a, d%n)
       d%n = d%n / norm

       ! Normalize mass distribution
       norm = integral_loglog(d%a, d%m)
       d%m = d%m / norm

    case('table')

       d%type = 2

       ! Read in name of file containing the table
       read(unit,*) filename

       ! Find number of lines in file
       open(unit=35,file=filename,status='old')
       na = 0
       do
          read(35,*,iostat=ioerr)
          if(ioerr.ne.0) exit
          na = na + 1
       end do
       close(unit=35)

       ! Allocate arrays
       allocate(d%a(na), d%n(na), d%m(na))

       ! Read in distribution
       open(unit=35,file=filename,status='old')
       do i=1,na
          read(35,*,iostat=ioerr) d%a(i), d%n(i)
       end do
       close(unit=35)

       ! Compute mass distribution
       d%m = d%n * d%a**3

       ! Set min and max
       d%amin = d%a(1)
       d%amax = d%a(na)

       ! Normalize number distribution
       norm = integral_loglog(d%a, d%n)
       d%n = d%n / norm

       ! Normalize mass distribution
       norm = integral_loglog(d%a, d%m)
       d%m = d%m / norm

    case default
       stop "Not implemented"
    end select

  end subroutine read_distribution

  real(dp) function distribution_weight_number(d, amin, amax)

    implicit none

    type(size_distribution),intent(in) :: d
    real(dp),intent(in) :: amin, amax
    real(dp) :: a1, a2

    if(amax < d%amin .or. amin > d%amax) then
       distribution_weight_number = 0._dp
    else if(amin < d%amin .and. amax > d%amax) then
       distribution_weight_number = 1._dp
    else
       a1 = max(amin, d%amin)
       a2 = min(amax, d%amax)
       select case(d%type)
       case(1)
          distribution_weight_number = (a2**(d%apower+1._dp) - a1**(d%apower+1._dp)) &
               &                     / (d%amax**(d%apower+1._dp) - d%amin**(d%apower+1._dp))
       case(2)
          distribution_weight_number = integral_loglog(d%a, d%n, a1, a2)
       case default
          stop "Not implemented"
       end select
    end if

  end function distribution_weight_number

  real(dp) function average_volume(d)

    implicit none

    type(size_distribution),intent(in) :: d

       select case(d%type)
       case(1)
           average_volume = 4. / 3. * 3.1415926 * (d%amax**(d%apower+4._dp) - d%amin**(d%apower+4._dp)) &
                                                / (d%amax**(d%apower+1._dp) - d%amin**(d%apower+1._dp)) &
                                                * (d%apower + 1._dp) / (d%apower + 4._dp)
       case(2)
           average_volume = integral_loglog(d%a, d%n * 4. / 3. * 3.1415926 * d%a ** 3) / integral_loglog(d%a, d%n)
       case default
          stop "Not implemented"
       end select

  end function average_volume

  real(dp) function distribution_weight_mass(d, amin, amax)

    implicit none

    type(size_distribution),intent(in) :: d
    real(dp),intent(in) :: amin, amax
    real(dp) :: a1, a2

    if(amax < d%amin .or. amin > d%amax) then
       distribution_weight_mass = 0._dp
    else if(amin < d%amin .and. amax > d%amax) then
       distribution_weight_mass = 1._dp
    else
       a1 = max(amin, d%amin)
       a2 = min(amax, d%amax)
       select case(d%type)
       case(1)
          distribution_weight_mass = (a2**(d%apower+4._dp) - a1**(d%apower+4._dp)) &
               &                   / (d%amax**(d%apower+4._dp) - d%amin**(d%apower+4._dp))
       case(2)
          distribution_weight_mass = integral_loglog(d%a, d%m, a1, a2)
       case default
          stop "Not implemented"
       end select

    end if

  end function distribution_weight_mass

end module distributions


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This program computes a distributed 3D FFT using
!   -  2DECOMP&FFT's decomposition
!   -  Global Arrays toolkit for communication
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program ga_test

  use decomp_2d
  use MPI

  implicit none

  ! GA header files
  ! require preprocessing, but not a problem for 2DECOMP applications
#include "mafdecls.fh"
#include "global.fh"

  include "fftw3.f"

  integer, parameter :: nx=16, ny=16, nz=16
  integer, parameter :: p_row=2, p_col=2
  integer, parameter :: NFFT=20   ! number of independent FFTs

  integer :: i,j,k, m, nmax, ierror
  real(mytype) :: tmp1, tmp2
  logical :: status
  double precision :: t1, t2

  integer :: ga1, ga2, ga3

  ! FFTW plans for the 1D forward/backward transforms
  integer*8, save :: x_plan_f, x_plan_b
  integer*8, save :: y_plan_f, y_plan_b
  integer*8, save :: z_plan_f, z_plan_b

  ! dummy array used for planning
  complex(mytype), allocatable, dimension(:,:,:) :: buf1
  complex(mytype), allocatable, dimension(:,:) :: buf2

  ! input/output of the FFT
  complex(mytype), allocatable, dimension(:,:,:) :: in, out, wk2

  ! initialisation
  call MPI_INIT(ierror)
  call ga_initialize()
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  ! Create global arrays that map to 2DECOMP's pencils
  call get_global_array(ga1, 1, ga_complex_type)
  call get_global_array(ga2, 2, ga_complex_type)
  call get_global_array(ga3, 3, ga_complex_type)

  ! ===== planning 1D FFTs in X =====
  allocate(buf1(xsize(1),xsize(2),xsize(3)))

#ifdef DOUBLE_PREC
  call dfftw_plan_many_dft(x_plan_f, 1, xsize(1), &
         xsize(2)*xsize(3), buf1, xsize(1), 1, &
         xsize(1), buf1, xsize(1), 1, xsize(1), &
         FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_many_dft(x_plan_b, 1, xsize(1), &
         xsize(2)*xsize(3), buf1, xsize(1), 1, &
         xsize(1), buf1, xsize(1), 1, xsize(1), &
         FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_many_dft(x_plan_f, 1, xsize(1), &
         xsize(2)*xsize(3), buf1, xsize(1), 1, &
         xsize(1), buf1, xsize(1), 1, xsize(1), &
         FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_many_dft(x_plan_b, 1, xsize(1), &
         xsize(2)*xsize(3), buf1, xsize(1), 1, &
         xsize(1), buf1, xsize(1), 1, xsize(1), &
         FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1)

  ! ===== planning 1D FFTs in Y =====
  allocate(buf2(ysize(1),ysize(2)))

#ifdef DOUBLE_PREC
  call dfftw_plan_many_dft(y_plan_f, 1, ysize(2), ysize(1), &
         buf2, ysize(2), ysize(1), 1, buf2, ysize(2), &
         ysize(1), 1, FFTW_FORWARD,   FFTW_MEASURE)
  call dfftw_plan_many_dft(y_plan_b, 1, ysize(2), ysize(1), &
         buf2, ysize(2), ysize(1), 1, buf2, ysize(2), &
         ysize(1), 1, FFTW_BACKWARD,  FFTW_MEASURE)
#else
  call sfftw_plan_many_dft(y_plan_f, 1, ysize(2), ysize(1), &
         buf2, ysize(2), ysize(1), 1, buf2, ysize(2), &
         ysize(1), 1, FFTW_FORWARD,   FFTW_MEASURE)
  call sfftw_plan_many_dft(y_plan_b, 1, ysize(2), ysize(1), &
         buf2, ysize(2), ysize(1), 1, buf2, ysize(2), &
         ysize(1), 1, FFTW_BACKWARD,  FFTW_MEASURE)
#endif

  deallocate(buf2)

  ! ===== planning 1D FFTs in Z =====
  allocate(buf1(zsize(1),zsize(2),zsize(3)))

#ifdef DOUBLE_PREC
  call dfftw_plan_many_dft(z_plan_f, 1, zsize(3), &
         zsize(1)*zsize(2), buf1, zsize(3), &
         zsize(1)*zsize(2), 1, buf1, zsize(3), &
         zsize(1)*zsize(2), 1, FFTW_FORWARD,  FFTW_MEASURE)
  call dfftw_plan_many_dft(z_plan_b, 1, zsize(3), &
         zsize(1)*zsize(2), buf1, zsize(3), &
         zsize(1)*zsize(2), 1, buf1, zsize(3), &
         zsize(1)*zsize(2), 1, FFTW_BACKWARD, FFTW_MEASURE)
#else
  call sfftw_plan_many_dft(z_plan_f, 1, zsize(3), &
         zsize(1)*zsize(2), buf1, zsize(3), &
         zsize(1)*zsize(2), 1, buf1, zsize(3), &
         zsize(1)*zsize(2), 1, FFTW_FORWARD,  FFTW_MEASURE)
  call sfftw_plan_many_dft(z_plan_b, 1, zsize(3), &
         zsize(1)*zsize(2), buf1, zsize(3), &
         zsize(1)*zsize(2), 1, buf1, zsize(3), &
         zsize(1)*zsize(2), 1, FFTW_BACKWARD, FFTW_MEASURE)
#endif

  deallocate(buf1)

  allocate( in(xsize(1),xsize(2),xsize(3)))   ! x-pencil input
  allocate(out(zsize(1),zsize(2),zsize(3)))   ! z-pencil output
  allocate(wk2(ysize(1),ysize(2),ysize(3)))   ! y-pencil intermediate

  t1 = MPI_WTIME() ! start timer

  do m=1,NFFT

     do k=1,xsize(3)
        do j=1,xsize(2)
           do i=1,xsize(1)
              tmp1 = real(xstart(1)+i-1, mytype) / real(nx, mytype) &
                   * real(xstart(2)+j-1, mytype) / real(ny, mytype) &
                   * real(xstart(3)+k-1, mytype) / real(nz, mytype) &
                   * real(m, mytype) / real(NFFT, mytype)
              in(i,j,k) = cmplx(tmp1, 0._mytype, mytype)
           end do
        end do
     end do

     ! 1D FFT in X
#ifdef DOUBLE_PREC
     call dfftw_execute_dft(x_plan_f, in, in)
#else
     call sfftw_execute_dft(x_plan_f, in, in)
#endif

     ! ===== Swap X --> Y =====
     !call transpose_x_to_y(in,wk2)
     call nga_put(ga1, xstart, xend, in, xsize)
     call ga_copy(ga1, ga2)
     call nga_get(ga2, ystart, yend, wk2, ysize)

     ! ===== 1D FFTs in Y =====
     do k=1,ysize(3)
#ifdef DOUBLE_PREC
        call dfftw_execute_dft(y_plan_f, wk2(:,:,k), wk2(:,:,k))
#else
        call sfftw_execute_dft(y_plan_f, wk2(:,:,k), wk2(:,:,k))
#endif
     end do

     ! ===== Swap Y --> Z =====
     !call transpose_y_to_z(wk2,out)
     call nga_put(ga2, ystart, yend, wk2, ysize)
     call ga_copy(ga2, ga3)
     call nga_get(ga3, zstart, zend, out, zsize)

     ! ===== 1D FFTs in Z =====
#ifdef DOUBLE_PREC
     call dfftw_execute_dft(z_plan_f, out, out)
#else
     call sfftw_execute_dft(z_plan_f, out, out)
#endif

     if (nrank==0) write(*,*) 'TEST ', m, out(1:2,1:2,1:2)

  end do ! NFFT

  t2 = MPI_WTIME() - t1
  call MPI_ALLREDUCE(t2,t1,1,MPI_DOUBLE_PRECISION,MPI_SUM, &
       MPI_COMM_WORLD,ierror)
  t1 = t1 / real(nproc, mytype)

  if (nrank==0) then
     write(*,*) 'Average Forward FFT Time(sec): ', t1
  end if

  ! clean up
#ifdef DOUBLE_PREC
  call dfftw_destroy_plan(x_plan_f)
  call dfftw_destroy_plan(x_plan_b)
  call dfftw_destroy_plan(y_plan_f)
  call dfftw_destroy_plan(y_plan_b)
  call dfftw_destroy_plan(z_plan_f)
  call dfftw_destroy_plan(z_plan_b)
#else
  call sfftw_destroy_plan(x_plan_f)
  call sfftw_destroy_plan(x_plan_b)
  call sfftw_destroy_plan(y_plan_f)
  call sfftw_destroy_plan(y_plan_b)
  call sfftw_destroy_plan(z_plan_f)
  call sfftw_destroy_plan(z_plan_b)
#endif

  status = ga_destroy(ga1)
  status = ga_destroy(ga2)
  status = ga_destroy(ga3)

  call decomp_2d_finalize
  call ga_terminate()
  call MPI_FINALIZE(ierror)
  deallocate(in,out,wk2)

end program ga_test


SUBROUTINE TEST09(m,n)
    REAL, DIMENSION(1:100,1:100) :: a,newa
    REAL w0,w1,w2,change,tolerance
    INTEGER i,j,iters

      change = tolerance + 1
      iters = 0
      do while ( change > tolerance )
         iters = iters + 1
         change = 0
!$xev dir append(copy(a),create(newa))
!$acc kernels
!$acc loop reduction(max:change)
         do j = 2, n-1
            do i = 2, m-1
               newa(i,j) = w0 * a(i,j) + &
               w1 * (a(i-1,j) + a(i,j-1) + a(i+1,j) + a(i,j+1) ) + &
               w2 * (a(i-1,j-1) + a(i-1,j+1) + a(i+1,j-1) + a(i+1,j+1) )
              change = max( change, abs( newa(i,j) - a(i,j) ) )
            end do
         end do
         a(2:m-1,2:n-1) = newa(2:m-1,2:n-1)
!$acc end kernels
      end do

    RETURN
END


SUBROUTINE DiffStencilsZ_modif(k,z,StencilZ,Nz,GhostGridZ,gamma,idxg_c)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
!
INTEGER :: Nz, GhostGridZ, k, gamma
REAL(KIND=long), DIMENSION(1:2*gamma+1,1:2) :: StencilZ
REAL(KIND=long), DIMENSION(1:Nz+GhostGridZ) :: z
!
INTEGER :: Nzp, order, Diff, i
REAL(KIND=long), DIMENSION(:), ALLOCATABLE :: Stencil
INTEGER, DIMENSION(:), ALLOCATABLE :: idx
INTEGER :: idxg_c
!

! TEMPORARY POINTERS/VARIABLES
! Derivatives in z-direction
!    One-sided stencils near free surface.
!    One-side stencils near bottom, and if ghost points
!    are supported then the directional ghost point
!    is included in stencil.
! Correction for correct treatment of corners included through idxg_c
IF (GhostGridZ==0) THEN; Nzp = Nz; ELSE; Nzp = Nz+1; ENDIF
ALLOCATE( Stencil(2*gamma+1) )
ALLOCATE( idx(2*gamma+1) )
DO i=-gamma,gamma,1
	idx(i+gamma+1) = i
END DO
DO order=1,2
  DO i = k,k
	IF (i-1<gamma) THEN
		Diff = gamma-i+1
		CALL TaylorFDStencils1DArbitrary(gamma-Diff-idxg_c,gamma+Diff+idxg_c,order,Stencil,z(i+idx+Diff+idxg_c))
	ELSEIF (i>=Nz-gamma+1) THEN
		Diff = i-(Nzp-gamma)
		CALL TaylorFDStencils1DArbitrary(gamma+Diff-idxg_c,gamma-Diff+idxg_c,order,Stencil,z(i+idx-Diff+idxg_c))
	ELSE
		CALL TaylorFDStencils1DArbitrary(gamma-idxg_c,gamma+idxg_c,order,Stencil,z(i+idx+idxg_c))
	ENDIF
	StencilZ(:,order) = Stencil
  END DO
END DO
DEALLOCATE(Stencil,idx)
END SUBROUTINE DiffStencilsZ_modif


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_orthfact_factorcheck
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks the factorization input into d_orthfact_qr to make sure
! is represents a unitary hessenberg matrix to machine precision.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (N)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                    INFO = 0 implies valid factorization
!                    INFO = -1 implies N is invalid
!                    INFO = -2 implies Q is invalid
!                    INFO = -3 implies D is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_orthfact_factorcheck(N,Q,D,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(inout) :: Q(2*(N-1)), D(N)
  integer, intent(inout) :: INFO

  ! compute variables
  logical :: flg
  integer :: ii

  ! initialize INFO
  INFO = 0

  ! check N
  if (N < 2) then
    INFO = -1
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
    end if
    return
  end if

  ! check Q
  call d_rot2array_check(N-1,Q,flg)
  if (.NOT.flg) then
    INFO = -2
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"Q is invalid",INFO,INFO)
    end if
    return
  end if

  ! check D
  do ii=1,N
    if (abs(D(ii)).NE.1d0) then
      INFO = -3
      ! print error in debug mode
      if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"D is invalid",INFO,INFO)
      end if
      return
    end if
  end do

end subroutine d_orthfact_factorcheck


c
c      l3dterms - determine number of terms in mpole expansions
c
c      l3dterms_list2 - build tables for the number of terms needed
c           for all boxes in list 2
c
c      l3dterms_list2w - build table for the number of terms needed
c           for all boxes in list 2, using worst case error analysis
c
c      l3dterms_list2e - build tables of the number of terms needed
c           for all boxes in extended list 2
c
c      l3dterms_list2ew - build tables of the number of terms needed
c           for all boxes in extended list 2, using worst case analysis
c
c-----------------------------------------------------------------------------
c
c
c
c***********************************************************************
      subroutine l3dterms(eps, nterms)
c***********************************************************************
c
c     Determine number of terms in mpole expansions.
c
c     The method is based on examining the decay of \rho^n / r^{n+1}
c     for \rho a worst case source and r a worst case target.
c
c     INPUT:
c
c     eps   tolerance
c
c     OUTPUT:
c
c     nterms  required expansion order
c-----------------------------------------------------------------------
c
      implicit none
      integer j,nterms
      real *8 xtemp1,eps
      real *8 z1,z2,hfun,jfun
c
      z1 = 1.5d0
      z2 = dsqrt(3d0)/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = jfun*hfun
        if(xtemp1 .lt. eps)then
          nterms = j
          return
        endif
      enddo
      return
      end
c
c
c
c
c***********************************************************************
      subroutine l3dterms_far(eps, nterms)
c***********************************************************************
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk=0.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     This routine assumes slightly larger separation of boxes: the
c     first unit box is located at the origin and the second box is
c     located at (3,0,0).
c
c     INPUT:
c
c     eps   tolerance
c
c     OUTPUT:
c
c     nterms  required expansion order
c-----------------------------------------------------------------------------
c
      implicit none
      integer nterms,j,ier
      real *8 eps,jfun,hfun,z1,z2,xtemp1
c
      ier = 0
c
      z1 = 2.5d0
      z2 = dsqrt(3d0)/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = hfun*jfun
        if(xtemp1 .lt. eps)then
          nterms = j
          return
        endif
      enddo
      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine l3dterms_list2(eps, itable, ier)
c***********************************************************************
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     Build nterms table for all boxes in list 2
c
c     INPUT:
c
c     eps   tolerance
c
c     OUTPUT:
c
c     itable  table of needed  expansion orders in FMM.
c     ier     error flag (0 means correct execution).
c                        (1 means 1000 terms is insufficient).
c
c-----------------------------------------------------------------------------
c
      implicit none
      integer nterms,ier,ii,jj,kk,i,j,k
      real *8 xtemp1,z1,z2,z3,jfun,hfun
      real *8 eps,rr,dx,dy,dz
c
      integer nterms_table(2:3,0:3,0:3)
      integer itable(-3:3,-3:3,-3:3)
c
      ier = 0
c
      do ii=2,3
      do jj=0,3
      do kk=0,3
c
        dx=ii
        dy=jj
        dz=kk
c
        if( dx .gt. 0 ) dx=dx-.5
        if( dy .gt. 0 ) dy=dy-.5
        if( dz .gt. 0 ) dz=dz-.5
c
        rr=sqrt(dx*dx+dy*dy+dz*dz)
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(3.0d0)/2*5,1)
c
      z1 = rr
      z2 = dsqrt(3d0)/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = jfun*hfun
        if(xtemp1 .lt. eps)then
          ier = 0
          nterms = j
          exit
        endif
        ier = 1
      enddo
c
        nterms_table(ii,jj,kk)=nterms
c
      enddo
      enddo
      enddo
c
ccc        call prinf('nterms=*',nterms_table,2*4*4)
c
c       build the rank table for all boxes in list 2
c
        do i=-3,3
        do j=-3,3
        do k=-3,3
        itable(i,j,k)=0
        enddo
        enddo
        enddo
c
        do k=-3,3
        do i=-3,3
        do j=-3,3
c
        if( abs(i) .gt. 1 ) then
        itable(i,j,k)=nterms_table(abs(i),abs(j),abs(k))
        else if( abs(j) .gt. 1) then
        itable(i,j,k)=nterms_table(abs(j),abs(i),abs(k))
        endif
c
        if( abs(i) .le. 1 .and. abs(j) .le. 1) then
        if( abs(k) .gt. 1 ) then
c
        if( abs(i) .ge. abs(j) ) then
        itable(i,j,k)=nterms_table(abs(k),abs(i),abs(j))
        else
        itable(i,j,k)=nterms_table(abs(k),abs(j),abs(i))
        endif
c
        endif
        endif
c
        enddo
        enddo
        enddo
c
      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine l3dterms_list2w(eps, itable, ier)
c***********************************************************************
c
c     Build nterms table for all boxes in list 2
c     Estimate worst case multipole to local translation operator errors.
c
c     INPUT:
c
c     eps   tolerance
c
c     OUTPUT:
c
c     itable  table of needed  expansion orders in FMM.
c     ier     error flag (0 means correct execution).
c                        (1 means 1000 terms is insufficient).
c-----------------------------------------------------------------------------
c
      implicit none
      integer nterms,ier,ii,jj,kk,i,j,k
      real *8 z1,z2,z3,jfun,hfun,xtemp1,eps
      real *8 rr,dx,dy,dz
c
      integer nterms_table(2:3,0:3,0:3)
      integer itable(-3:3,-3:3,-3:3)
c
      ier = 0
c
      do ii=2,3
      do jj=0,3
      do kk=0,3
c
        dx=ii
        dy=jj
        dz=kk
c
c        if( dx .gt. 0 ) dx=dx-.5
c        if( dy .gt. 0 ) dy=dy-.5
c        if( dz .gt. 0 ) dz=dz-.5
c
        rr=sqrt(dx*dx+dy*dy+dz*dz)
        rr=rr-sqrt(3.0d0)/2
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(3.0d0)/2*5,1)
c
      z1 = rr
      z2 = dsqrt(3d0)/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = jfun*hfun
        if(xtemp1 .lt. eps)then
          ier = 0
          nterms = j
          exit
        endif
        ier = 1
      enddo
c
        nterms_table(ii,jj,kk)=nterms
c
      enddo
      enddo
      enddo
c
ccc        call prinf('nterms=*',nterms_table,2*4*4)
c
c       build the rank table for all boxes in list 2
c
        do i=-3,3
        do j=-3,3
        do k=-3,3
        itable(i,j,k)=0
        enddo
        enddo
        enddo
c
        do k=-3,3
        do i=-3,3
        do j=-3,3
c
        if( abs(i) .gt. 1 ) then
        itable(i,j,k)=nterms_table(abs(i),abs(j),abs(k))
        else if( abs(j) .gt. 1) then
        itable(i,j,k)=nterms_table(abs(j),abs(i),abs(k))
        endif
c
        if( abs(i) .le. 1 .and. abs(j) .le. 1) then
        if( abs(k) .gt. 1 ) then
c
        if( abs(i) .ge. abs(j) ) then
        itable(i,j,k)=nterms_table(abs(k),abs(i),abs(j))
        else
        itable(i,j,k)=nterms_table(abs(k),abs(j),abs(i))
        endif
c
        endif
        endif
c
        enddo
        enddo
        enddo
c
      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine l3dterms_list2e(eps, itable, ier)
c***********************************************************************
c
c
c     Build nterms table for all boxes in extended list 2
c
c     INPUT:
c
c     eps   tolerance
c
c     OUTPUT:
c
c     itable  table of needed  expansion orders in FMM.
c     ier     error flag (0 means correct execution).
c                        (1 means 1000 terms is insufficient).
c
c-----------------------------------------------------------------------------
c
      implicit none
      integer nterms,ier,ii,jj,kk,i,j,k
      real *8 z1,z2,z3,jfun,hfun,xtemp1,eps
      real *8 rr,dx,dy,dz
c
      integer nterms_table(2:7,0:7,0:7)
      integer itable(-7:7,-7:7,-7:7)
c
      ier = 0
c
      do ii=2,7
      do jj=0,7
      do kk=0,7
c
        dx=ii
        dy=jj
        dz=kk
c
        if( dx .gt. 0 ) dx=dx-.5
        if( dy .gt. 0 ) dy=dy-.5
        if( dz .gt. 0 ) dz=dz-.5
c
        rr=sqrt(dx*dx+dy*dy+dz*dz)
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(3.0d0)/2*5,1)
c
      z1 = rr
      z2 = dsqrt(3d0)/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = jfun*hfun
        if(xtemp1 .lt. eps)then
          ier = 0
          nterms = j
          exit
        endif
        ier = 1
      enddo
c
        nterms_table(ii,jj,kk)=nterms
c
      enddo
      enddo
      enddo
c
ccc        call prinf('nterms=*',nterms_table,2*6*6)
c
c       build the rank table for all boxes in extended list 2
c
        do i=-7,7
        do j=-7,7
        do k=-7,7
        itable(i,j,k)=0
        enddo
        enddo
        enddo
c
        do k=-7,7
        do i=-7,7
        do j=-7,7
c
        if( abs(i) .gt. 2 ) then
        itable(i,j,k)=nterms_table(abs(i),abs(j),abs(k))
        else if( abs(j) .gt. 2) then
        itable(i,j,k)=nterms_table(abs(j),abs(i),abs(k))
        endif
c
        if( abs(i) .le. 2 .and. abs(j) .le. 2) then
        if( abs(k) .gt. 2 ) then
c
        if( abs(i) .ge. abs(j) ) then
        itable(i,j,k)=nterms_table(abs(k),abs(i),abs(j))
        else
        itable(i,j,k)=nterms_table(abs(k),abs(j),abs(i))
        endif
c
        endif
        endif
c
       enddo
       enddo
       enddo
c
      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine l3dterms_list2ew(eps, itable, ier)
c***********************************************************************
c
c
c     Build nterms table for all boxes in extended list 2
c     Estimate worst case multipole to local translation operator errors.
c
c     INPUT:
c
c     eps   tolerance
c
c     OUTPUT:
c
c     itable  table of needed  expansion orders in FMM.
c     ier     error flag (0 means correct execution).
c                        (1 means 1000 terms is insufficient).
c-----------------------------------------------------------------------------
c
      implicit none
      integer nterms,ier,ii,jj,kk,i,j,k
      real *8 z1,z2,z3,jfun,hfun,xtemp1,eps
      real *8 rr,dx,dy,dz
c
      integer nterms_table(2:7,0:7,0:7)
      integer itable(-7:7,-7:7,-7:7)
c
      ier = 0
c
      do ii=2,7
      do jj=0,7
      do kk=0,7
c
        dx=ii
        dy=jj
        dz=kk
c
c        if( dx .gt. 0 ) dx=dx-.5
c        if( dy .gt. 0 ) dy=dy-.5
c        if( dz .gt. 0 ) dz=dz-.5
c
        rr=sqrt(dx*dx+dy*dy+dz*dz)
        rr=rr-sqrt(3.0d0)/2
ccc        call prin2('rr=*',rr,1)
ccc        call prin2('rr=*',sqrt(3.0d0)/2*5,1)
c
      z1 = rr
      z2 = dsqrt(3d0)/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = jfun*hfun
        if(xtemp1 .lt. eps)then
          ier = 0
          nterms = j
          exit
        endif
        ier = 1
      enddo
c
        nterms_table(ii,jj,kk)=nterms
c
      enddo
      enddo
      enddo
c
ccc        call prinf('nterms=*',nterms_table,2*6*6)
c
c       build the rank table for all boxes in extended list 2
c
        do i=-7,7
        do j=-7,7
        do k=-7,7
        itable(i,j,k)=0
        enddo
        enddo
        enddo
c
        do k=-7,7
        do i=-7,7
        do j=-7,7
c
        if( abs(i) .gt. 2 ) then
        itable(i,j,k)=nterms_table(abs(i),abs(j),abs(k))
        else if( abs(j) .gt. 2) then
        itable(i,j,k)=nterms_table(abs(j),abs(i),abs(k))
        endif
c
        if( abs(i) .le. 2 .and. abs(j) .le. 2) then
        if( abs(k) .gt. 2 ) then
c
        if( abs(i) .ge. abs(j) ) then
        itable(i,j,k)=nterms_table(abs(k),abs(i),abs(j))
        else
        itable(i,j,k)=nterms_table(abs(k),abs(j),abs(i))
        endif
c
        endif
        endif
c
       enddo
       enddo
       enddo
c
      return
      end
c
c
c
c
c
c***********************************************************************
      subroutine l3dterms_eval(itype, eps, nterms, ier)
c***********************************************************************
c
c
c     Determine number of terms in mpole expansions for box of size
c     "size" with Helmholtz parameter zk.
c
c     The method is based on examining the decay of h_n * j_n.
c
c     INPUT:
c
c     itype   flag determining precise geometry (see code below).
c     eps     tolerance
c
c     OUTPUT:
c
c     nterms  required expansion order
c     ier     error flag (0 means correct execution).
c                        (1 means 1000 terms is insufficient).
c-----------------------------------------------------------------------------
c
      implicit none
      integer itype,nterms,ier,ii,jj,kk,i,j,k
      real *8 z1,z2,z3,jfun,hfun,xtemp1,eps
      real *8 rr,dx,dy,dz
c
      ier = 0
c
      z1 = 1.5d0
      z2 = dsqrt(3d0)/2.d0
c
c     corners included
      if( itype .eq. 1 ) z2 = dsqrt(3d0)/2.d0
c     edges included, no corners
      if( itype .eq. 2 ) z2 = dsqrt(2d0)/2.d0
c     center only
      if( itype .eq. 3 ) z2 = 1.0d0/2.d0
c     center only, small interior sphere
      if( itype .eq. 4 ) z2 = 0.8d0/2.d0
c
      jfun = z2
      hfun = 1.0d0/(z1**2)
      nterms = 1
      do j = 2, 1000
        hfun = hfun/z1
        jfun = jfun*z2
        xtemp1 = jfun*hfun
        if(xtemp1 .lt. eps)then
          nterms = j
          return
        endif
      enddo
      ier = 1
      return
      end