module horiz_interp_spherical_mod

  ! <CONTACT EMAIL="Matthew.Harrison@noaa.gov"> Matthew Harrison </CONTACT>
  ! <CONTACT EMAIL="Zhi.Liang@noaa.gov"> Zhi Liang </CONTACT>

  ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

  ! <OVERVIEW>
  !   Performs spatial interpolation between grids using inverse-distance-weighted scheme.
  ! </OVERVIEW>

  ! <DESCRIPTION>
  !     This module can interpolate data from rectangular/tripolar grid
  !     to rectangular/tripolar grid. The interpolation scheme is inverse-distance-weighted
  !     scheme.    There is an optional mask field for missing input data.
  !     An optional output mask field may be used in conjunction with
  !     the input mask to show where output data exists.
  ! </DESCRIPTION>

  use mpp_mod,               only : mpp_error, FATAL, WARNING, stdout
  use mpp_mod,               only : mpp_root_pe, mpp_pe
  use fms_mod,               only : write_version_number, file_exist, close_file
  use fms_mod,               only : check_nml_error, open_namelist_file
  use constants_mod,         only : pi
  use horiz_interp_type_mod, only : horiz_interp_type, stats

  implicit none
  private

  public :: horiz_interp_spherical_init, horiz_interp_spherical, horiz_interp_spherical_end

  integer, parameter :: max_neighbors = 400
  real,    parameter :: max_dist_default = 0.1  ! radians
  integer, parameter :: num_nbrs_default = 4
  real,    parameter :: large=1.e20
  real,    parameter :: epsln=1.e-10

  integer            :: pe, root_pe

  !--- namelist interface
  !<NAMELIST NAME="horiz_interp_spherical_nml">
  ! <DATA NAME="search_method" TYPE="character(len=32)">
  !  indicate the searching method to find the nearest neighbor points. Its value
  !  can be "radial_search" and "full_search", with default value "radial_search".
  !  when search_method is "radial_search", the search may be not quite accurate for some cases.
  !  Normally the search will be ok if you chose suitable max_dist.
  !  When search_method is "full_search", it will be always accurate, but will be slower
  !  comparing to "radial_search". Normally these two search algorithm will produce same
  !  results other than order of operation. "radial_search" are recommended to use.
  !  The purpose to add "full_search" is in case you think you interpolation results is
  !  not right, you have other option to verify.
  ! </DATA>
  !</NAMELIST>

  character(len=32) :: search_method = "radial_search" ! or "full_search"
  namelist /horiz_interp_spherical_nml/ search_method

  !-----------------------------------------------------------------------
  character(len=128) :: version = '$Id: horiz_interp_spherical.f90,v 13.0 2006/03/28 21:39:46 fms Exp $'
  character(len=128) :: tagname = '$Name: latest $'
  logical            :: do_vers = .true.
  logical            :: module_is_initialized = .FALSE.

contains

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_spherical_init">

  !   <OVERVIEW>
  !      Initialization routine.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !      Allocates space and initializes a derived-type variable
  !      that contains pre-computed interpolation indices and weights.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_spherical_init(Interp, lon_in,lat_in,lon_out,lat_out, num_nbrs, max_dist, src_modulo)
  !   </TEMPLATE>
  !
  !   <IN NAME="lon_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Longitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lat_in" TYPE="real, dimension(:,:)" UNITS="radians">
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lon_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Longitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="lat_out" TYPE="real, dimension(:,:)" UNITS="radians" >
  !      Latitude (in radians) for source data grid.
  !   </IN>

  !   <IN NAME="num_nbrs" TYPE="integer, optional">
  !     Number of nearest neighbors for regridding. When number of neighbors within
  !     the radius max_dist ( namelist variable) is less than num_nbrs, All the neighbors
  !     will be used to interpolate onto destination grid. when number of neighbors within
  !     the radius max_dist ( namelist variable) is greater than num_nbrs, at least "num_nbrs"
  !     neighbors will be used to remap onto destination grid.
  !   </IN>

  !   <IN NAME="max_dist" TYPE="real, optional" UNITS="radians">
  !      Maximum region of influence around destination grid points.
  !   </IN>

  !   <IN NAME="src_modulo" TYPE="logical, optional">
  !      logical variable to indicate if the boundary condition along zonal boundary
  !      is cyclic or not. When true, the zonal boundary condition is cyclic.
  !   </IN>

  !   <INOUT NAME="Interp" TYPE="type(horiz_interp_type)">
  !      A derived-type variable containing indices and weights used for subsequent
  !      interpolations. To reinitialize this variable for a different grid-to-grid
  !      interpolation you must first use the "horiz_interp_end" interface.
  !   </INOUT>

  subroutine horiz_interp_spherical_init(Interp, lon_in,lat_in,lon_out,lat_out, &
       num_nbrs, max_dist, src_modulo)
    type(horiz_interp_type), intent(inout) :: Interp
    real, intent(in),       dimension(:,:) :: lon_in, lat_in, lon_out, lat_out
    integer, intent(in),        optional   :: num_nbrs
    real, optional,             intent(in) :: max_dist
    logical,          intent(in), optional :: src_modulo

    !------local variables ---------------------------------------
    integer :: i, j, n, unit, ierr, io
    integer :: map_dst_xsize, map_dst_ysize, map_src_xsize, map_src_ysize
    integer :: map_src_size, num_neighbors
    real    :: max_src_dist, tpi, hpi
    logical :: src_is_modulo
    real    :: min_theta_dst, max_theta_dst, min_phi_dst, max_phi_dst
    real    :: min_theta_src, max_theta_src, min_phi_src, max_phi_src
    integer, dimension(:),        allocatable        :: ilon, jlat
    integer, dimension(:,:,:),    allocatable        :: map_src_add
    integer, dimension(:,:),      allocatable        :: num_found
    real, dimension(:,:,:),       allocatable        :: map_src_dist
    real, dimension(size(lon_out,1),size(lon_out,2)) :: theta_dst, phi_dst
    real, dimension(size(lon_in,1)*size(lon_in,2))   :: theta_src, phi_src

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

    pe      = mpp_pe()
    root_pe = mpp_root_pe()

    if (do_vers) then
       call write_version_number (version, tagname)
       do_vers = .false.
    endif

    if (file_exist('input.nml')) then
       unit = open_namelist_file ( )
       ierr=1; do while (ierr /= 0)
          read  (unit, nml=horiz_interp_spherical_nml, iostat=io, end=10)
          ierr = check_nml_error(io,'horiz_interp_spherical_nml')  ! also initializes nml error codes
       enddo
 10    call close_file (unit)
    endif

    tpi = 2.0*PI; hpi = 0.5*PI

    num_neighbors = num_nbrs_default
    if(present(num_nbrs)) num_neighbors = num_nbrs
    if (num_neighbors <= 0) call mpp_error(FATAL,'horiz_interp_spherical_mod: num_neighbors must be > 0')

    max_src_dist = max_dist_default
    if (PRESENT(max_dist)) max_src_dist = max_dist
    Interp%max_src_dist = max_src_dist

    src_is_modulo = .true.
    if (PRESENT(src_modulo)) src_is_modulo = src_modulo

    !--- check the grid size comformable
    map_dst_xsize=size(lon_out,1);map_dst_ysize=size(lon_out,2)
    map_src_xsize=size(lon_in,1); map_src_ysize=size(lon_in,2)
    map_src_size = map_src_xsize*map_src_ysize

    if (map_dst_xsize /= size(lat_out,1) .or. map_dst_ysize /= size(lat_out,2)) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: destination grids not conformable')
    if (map_src_xsize /= size(lat_in,1) .or. map_src_ysize /= size(lat_in,2)) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: source grids not conformable')

    theta_src      = reshape(lon_in,(/map_src_size/))
    phi_src        = reshape(lat_in,(/map_src_size/))
    theta_dst(:,:) = lon_out(:,:)
    phi_dst(:,:)   = lat_out(:,:)

    min_theta_dst=tpi;max_theta_dst=0.0;min_phi_dst=pi;max_phi_dst=-pi
    min_theta_src=tpi;max_theta_src=0.0;min_phi_src=pi;max_phi_src=-pi

    where(theta_dst<0.0)  theta_dst = theta_dst+tpi
    where(theta_dst>tpi)  theta_dst = theta_dst-tpi
    where(theta_src<0.0)  theta_src = theta_src+tpi
    where(theta_src>tpi)  theta_src = theta_src-tpi

    where(phi_dst < -hpi) phi_dst = -hpi
    where(phi_dst > hpi)  phi_dst =  hpi
    where(phi_src < -hpi) phi_src = -hpi
    where(phi_src > hpi)  phi_src =  hpi

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          min_theta_dst = min(min_theta_dst,theta_dst(i,j))
          max_theta_dst = max(max_theta_dst,theta_dst(i,j))
          min_phi_dst = min(min_phi_dst,phi_dst(i,j))
          max_phi_dst = max(max_phi_dst,phi_dst(i,j))
       enddo
    enddo

    do i=1,map_src_size
       min_theta_src = min(min_theta_src,theta_src(i))
       max_theta_src = max(max_theta_src,theta_src(i))
       min_phi_src = min(min_phi_src,phi_src(i))
       max_phi_src = max(max_phi_src,phi_src(i))
    enddo

    if (min_phi_dst < min_phi_src) print *, '=> WARNING:  latitute of dest grid exceeds src'
    if (max_phi_dst > max_phi_src) print *, '=> WARNING:  latitute of dest grid exceeds src'
    ! when src is cyclic, no need to print out the following warning.
    if(.not. src_is_modulo) then
       if (min_theta_dst < min_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src'
       if (max_theta_dst > max_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src'
    endif
    allocate(map_src_add(map_dst_xsize,map_dst_ysize,max_neighbors),    &
         map_src_dist(map_dst_xsize,map_dst_ysize,max_neighbors),   &
         num_found(map_dst_xsize,map_dst_ysize),                    &
         ilon(max_neighbors),jlat(max_neighbors)  )

    ! allocate memory to data type
    allocate(Interp%i_lon(map_dst_xsize,map_dst_ysize,max_neighbors), &
         Interp%j_lat(map_dst_xsize,map_dst_ysize,max_neighbors),     &
         Interp%src_dist(map_dst_xsize,map_dst_ysize,max_neighbors),  &
         Interp%num_found(map_dst_xsize,map_dst_ysize)       )

    map_src_add         = 0
    map_src_dist        = large
    num_found           = 0

    !using radial_search to find the nearest points and corresponding distance.

    select case(trim(search_method))
    case ("radial_search") ! will be efficient, but may be not so accurate for some cases
       call radial_search(theta_src, phi_src, theta_dst, phi_dst, map_src_xsize, map_src_ysize, &
            map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo)
    case ("full_search")   ! always accurate, but less efficient.
       call full_search(theta_src, phi_src, theta_dst, phi_dst, map_src_add, map_src_dist, &
            num_found, num_neighbors,max_src_dist )
    case default
       call mpp_error(FATAL,"horiz_interp_spherical_init: nml search_method = "// &
                  trim(search_method)//" is not a valid namelist option")
    end select

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          do n=1,num_found(i,j)
             if(map_src_add(i,j,n) == 0) then
                jlat(n) = 0; ilon(n) = 0
             else
                jlat(n) = map_src_add(i,j,n)/map_src_xsize + 1
                ilon(n) = map_src_add(i,j,n) - (jlat(n)-1)*map_src_xsize
                if(ilon(n) == 0) then
                   jlat(n) = jlat(n) - 1
                   ilon(n) = map_src_xsize
                endif
             endif
          enddo
          Interp%i_lon(i,j,:)         = ilon(:)
          Interp%j_lat(i,j,:)         = jlat(:)
          Interp%num_found(i,j)       = num_found(i,j)
          Interp%src_dist(i,j,:)      = map_src_dist(i,j,:)
       enddo
    enddo

    Interp%nlon_src = map_src_xsize; Interp%nlat_src = map_src_ysize
    Interp%nlon_dst = map_dst_xsize; Interp%nlat_dst = map_dst_ysize

    deallocate(map_src_add, map_src_dist, ilon, jlat)
    return

  end subroutine horiz_interp_spherical_init
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_spherical">

  !   <OVERVIEW>
  !      Subroutine for performing the horizontal interpolation between two grids.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Subroutine for performing the horizontal interpolation between two grids.
  !     horiz_interp_spherical_init must be called before calling this routine.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_spherical( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value)
  !   </TEMPLATE>
  !
  !   <IN NAME="Interp" TYPE="type(horiz_interp_type)">
  !     Derived-type variable containing interpolation indices and weights.
  !     Returned by a previous call to horiz_interp_init.
  !   </IN>
  !   <IN NAME="data_in" TYPE="real, dimension(:,:)">
  !      Input data on source grid.
  !   </IN>
  !   <IN NAME="verbose" TYPE="integer, optional">
  !      flag for the amount of print output.
  !               verbose = 0, no output; = 1, min,max,means; = 2, still more
  !   </IN>
  !   <IN NAME="mask_in" TYPE="real, dimension(:,:),optional">
  !      Input mask, must be the same size as the input data. The real value of
  !      mask_in must be in the range (0.,1.). Set mask_in=0.0 for data points
  !      that should not be used or have missing data.
  !   </IN>
  !   <IN NAME="missing_value" TYPE="real, optional">
  !      Use the missing_value to indicate missing data.
  !   </IN>
  !   <OUT NAME="data_out" TYPE="real, dimension(:,:)">
  !      Output data on destination grid.
  !   </OUT>
  !   <OUT NAME="mask_out" TYPE="real, dimension(:,:),optional">
  !      Output mask that specifies whether data was computed.
  !   </OUT>

  subroutine horiz_interp_spherical( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value)
    type (horiz_interp_type), intent(in)        :: Interp
    real, intent(in),  dimension(:,:)           :: data_in
    real, intent(out), dimension(:,:)           :: data_out
    integer, intent(in),               optional :: verbose
    real, intent(in), dimension(:,:),  optional :: mask_in
    real, intent(out), dimension(:,:), optional :: mask_out
    real, intent(in),                  optional :: missing_value

    !--- some local variables ----------------------------------------
    real, dimension(Interp%nlon_dst, Interp%nlat_dst,size(Interp%src_dist,3)) :: wt
    real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src
    real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst
    integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found
    integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose
    real    :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum
    !-----------------------------------------------------------------

    iverbose = 0;  if (present(verbose)) iverbose = verbose

    nlon_in  = Interp%nlon_src; nlat_in  = Interp%nlat_src
    nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst

    if(size(data_in,1) .ne. nlon_in .or. size(data_in,2) .ne. nlat_in ) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: size of input array incorrect')

    if(size(data_out,1) .ne. nlon_out .or. size(data_out,2) .ne. nlat_out ) &
         call mpp_error(FATAL,'horiz_interp_spherical_mod: size of output array incorrect')

    mask_src = 1.0; mask_dst = 1.0
    if(present(mask_in)) mask_src = mask_in

    do n=1,nlat_out
       do m=1,nlon_out
          ! neighbors are sorted nearest to farthest
          ! check nearest to see if it is a land point
          num_found = Interp%num_found(m,n)
          if(num_found == 0 ) then
             mask_dst(m,n) = 0.0
          else
             i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1)
             if (mask_src(i1,j1) .lt. 0.5) then
                mask_dst(m,n) = 0.0
             endif

             if(num_found .gt. 1 ) then
                i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2)
                ! compare first 2 nearest neighbors -- if they are nearly
                ! equidistant then use this mask for robustness
                if(abs(Interp%src_dist(m,n,2)-Interp%src_dist(m,n,1)) .lt. epsln) then
                   if((mask_src(i1,j1) .lt. 0.5))  mask_dst(m,n) = 0.0
                endif
             endif

             sum=0.0
             do k=1, num_found
                if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5 ) then
                   wt(m,n,k) = 0.0
                else
                   if (Interp%src_dist(m,n,k) <= epsln) then
                      wt(m,n,k) = large
                      sum = sum + large
                   else if(Interp%src_dist(m,n,k) <= Interp%max_src_dist ) then
                      wt(m,n,k) = 1.0/Interp%src_dist(m,n,k)
                      sum = sum+wt(m,n,k)
                   else
                      wt(m,n,k) = 0.0
                   endif
                endif
             enddo
             if (sum > epsln) then
                do k = 1, num_found
                   wt(m,n,k) = wt(m,n,k)/sum
                enddo
             else
                mask_dst(m,n) = 0.0
             endif
          endif
       enddo
    enddo

    data_out = 0.0
    do n=1,nlat_out
       do m=1,nlon_out
          if(mask_dst(m,n) .gt. 0.5) then
             do k=1, Interp%num_found(m,n)
                i = Interp%i_lon(m,n,k)
                j = Interp%j_lat(m,n,k)
                data_out(m,n) = data_out(m,n)+data_in(i,j)*wt(m,n,k)
             enddo
          else
             if(present(missing_value)) then
                data_out(m,n) = missing_value
             else
                data_out(m,n) = 0.0
             endif
          endif
       enddo
    enddo

    if(present(mask_out)) mask_out = mask_dst

    !***********************************************************************
    ! compute statistics: minimum, maximum, and mean
    !-----------------------------------------------------------------------

    if (iverbose > 0) then

       ! compute statistics of input data

       call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask=mask_src)

       ! compute statistics of output data
       call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask=mask_dst)

       !---- output statistics ----
       ! root_pe have the information of global mean, min and max
       if(pe == root_pe) then
          write (*,900)
          write (*,901)  min_in ,max_in, avg_in
          if (present(mask_in))  write (*,903)  miss_in
          write (*,902)  min_out,max_out,avg_out
          if (present(mask_out)) write (*,903)  miss_out
       endif
900    format (/,1x,10('-'),' output from horiz_interp ',10('-'))
901    format ('  input:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
902    format (' output:  min=',f16.9,'  max=',f16.9,'  avg=',f22.15)
903    format ('          number of missing points = ',i6)

    endif

    return
  end subroutine horiz_interp_spherical
  ! </SUBROUTINE>

  !#######################################################################
  ! <SUBROUTINE NAME="horiz_interp_spherical_end">

  !   <OVERVIEW>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_init.
  !   </OVERVIEW>
  !   <DESCRIPTION>
  !     Deallocates memory used by "horiz_interp_type" variables.
  !     Must be called before reinitializing with horiz_interp_init.
  !   </DESCRIPTION>
  !   <TEMPLATE>
  !     call horiz_interp_spherical_end ( Interp )
  !   </TEMPLATE>

  !   <INOUT NAME="Interp" TYPE="horiz_interp_type">
  !     A derived-type variable returned by previous call
  !     to horiz_interp_init. The input variable must have
  !     allocated arrays. The returned variable will contain
  !     deallocated arrays.
  !   </INOUT>

  subroutine horiz_interp_spherical_end( Interp )

    type (horiz_interp_type), intent(inout) :: Interp

    deallocate ( Interp%src_dist, Interp%num_found, Interp%i_lon, Interp%j_lat )

  end subroutine horiz_interp_spherical_end
  ! </SUBROUTINE>

  !#######################################################################

  subroutine radial_search(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map_src_ysize, &
       map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo)
    real,    intent(in),    dimension(:)   :: theta_src, phi_src
    real,    intent(in),    dimension(:,:) :: theta_dst, phi_dst
    integer, intent(in)                    :: map_src_xsize, map_src_ysize
    integer, intent(out), dimension(:,:,:) :: map_src_add
    real,    intent(out), dimension(:,:,:) :: map_src_dist
    integer, intent(inout), dimension(:,:) :: num_found
    integer, intent(in)                    :: num_neighbors
    real,    intent(in)                    :: max_src_dist
    logical, intent(in)                    :: src_is_modulo

    !---------- local variables ----------------------------------------
    integer, parameter :: max_nbrs = 50
    integer :: i, j, jj, i0, j0, n, l,i_left, i_right
    integer :: map_dst_xsize, map_dst_ysize
    integer :: i_left1, i_left2, i_right1, i_right2
    integer :: map_src_size, step, step_size, bound, bound_start, bound_end
    logical :: continue_search, result, continue_radial_search
    real    :: d, res
    !------------------------------------------------------------------
    map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2)
    map_src_size = map_src_xsize*map_src_ysize

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          continue_search=.true.
          step = 1
          step_size = sqrt(real(map_src_size) )
          do while (continue_search .and. step_size > 0)
             do while (step <= map_src_size .and. continue_search)
                ! count land points as nearest neighbors
                d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step))
                if (d <= max_src_dist) then
                   result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                        step,d, num_found(i,j), num_neighbors )
                   if (result) then
                      n = 0
                      i0 = mod(step,map_src_xsize)

                      if (i0 == 0) i0 = map_src_xsize
                      res = float(step)/float(map_src_xsize)
                      j0 = ceiling(res)
                      continue_radial_search = .true.
                      do while (continue_radial_search)
                         continue_radial_search = .false.
                         n = n+1 ! radial counter
                         if(n > max_nbrs) exit
                         ! ************** left boundary *******************************
                         i_left = i0-n
                         if (i_left <= 0) then
                            if (src_is_modulo) then
                               i_left = map_src_xsize + i_left
                            else
                               i_left = 1
                            endif
                         endif

                         do l = 0, 2*n
                            jj = j0 - n - 1 + l
                            if( jj < 0) then
                               bound = ( 1 - jj )*map_src_xsize - i_left
                            else if ( jj >= map_src_ysize ) then
                               bound = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left
                            else
                               bound = jj * map_src_xsize + i_left
                            endif

                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                         enddo

                         ! ***************************right boundary *******************************
                         i_right = i0+n
                         if (i_right > map_src_xsize) then
                            if (src_is_modulo) then
                               i_right = i_right - map_src_xsize
                            else
                               i_right = map_src_xsize
                            endif
                         endif

                         do l = 0, 2*n
                            jj = j0 - n - 1 + l
                            if( jj < 0) then
                               bound = ( 1 - jj )*map_src_xsize - i_right
                            else if ( jj >= map_src_ysize ) then
                               bound = ( 2*map_src_ysize - jj) * map_src_xsize - i_right

                            else
                               bound = jj * map_src_xsize + i_right
                            endif

                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                         enddo

                         ! ************************* bottom boundary **********************************
                         i_left2 = 0
                         if( i_left > i_right) then
                            i_left1 = 1
                            i_right1 = i_right
                            i_left2 = i_left
                            i_right2 = map_src_xsize
                         else
                            i_left1 = i_left
                            i_right1 = i_right
                         endif

                         jj = j0 - n - 1
                         if( jj < 0 ) then
                            bound_start = ( 1 - jj)*map_src_xsize - i_right1
                            bound_end   = ( 1 - jj)*map_src_xsize - i_left1
                         else
                            bound_start = jj * map_src_xsize + i_left1
                            bound_end = jj * map_src_xsize + i_right1
                         endif

                         bound = bound_start
                         do while (bound <= bound_end)
                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                            bound = bound + 1

                         enddo

                         if(i_left2 > 0 ) then
                            if( jj < 0 ) then
                               bound_start = ( 1 - jj)*map_src_xsize - i_right2
                               bound_end   = ( 1 - jj)*map_src_xsize - i_left2
                            else
                               bound_start = jj * map_src_xsize + i_left2
                               bound_end = jj * map_src_xsize + i_right2
                            endif

                            bound = bound_start
                            do while (bound <= bound_end)
                               d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                               if(d<=max_src_dist) then
                                  result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                       bound,d, num_found(i,j), num_neighbors)
                                  if (result) continue_radial_search = .true.
                               endif
                               bound = bound + 1
                            enddo
                         endif

                         ! ************************** top boundary ************************************
                         jj = j0 + n - 1
                         if( jj >= map_src_ysize) then
                            bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right1
                            bound_end   = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left1
                         else
                            bound_start = jj * map_src_xsize + i_left1
                            bound_end = jj * map_src_xsize + i_right1
                         endif

                         bound = bound_start
                         do while (bound <= bound_end)
                            d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                            if(d<=max_src_dist) then
                               result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                    bound,d, num_found(i,j), num_neighbors)
                               if (result) continue_radial_search = .true.
                            endif
                            bound = bound + 1
                         enddo

                         if(i_left2 > 0) then
                            if( jj >= map_src_ysize) then
                               bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right2
                               bound_end   = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left2
                            else
                               bound_start = jj * map_src_xsize + i_left2
                               bound_end = jj * map_src_xsize + i_right2
                            endif

                            bound = bound_start
                            do while (bound <= bound_end)
                               d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound))
                               if(d<=max_src_dist) then
                                  result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                                       bound,d, num_found(i,j), num_neighbors)
                                  if (result) continue_radial_search = .true.
                               endif
                               bound = bound + 1
                            enddo
                         endif

                      enddo
                      continue_search = .false. ! stop looking
                   endif
                endif
                step=step+step_size
             enddo ! search loop
             step = 1
             step_size = step_size/2
          enddo
       enddo
    enddo

    return

  end subroutine radial_search

  !#####################################################################

  function update_dest_neighbors(map_src_add, map_src_dist, src_add,d, num_found, min_nbrs)

    integer, intent(inout), dimension(:) :: map_src_add
    real, intent(inout),    dimension(:) :: map_src_dist
    integer, intent(in)                  :: src_add
    real, intent(in)                     :: d
    integer, intent(inout)               :: num_found
    integer, intent(in)                  :: min_nbrs

    logical :: update_dest_neighbors, already_exist = .false.

    integer :: n,m

    update_dest_neighbors = .false.

    n = 0
    NLOOP : do while ( n .le. num_found )
       n = n + 1
       DIST_CHK : if (d .le. map_src_dist(n)) then
          do m=n,num_found
             if (src_add == map_src_add(m)) then
                already_exist = .true.
                exit NLOOP
             endif
          enddo
          if(num_found < max_neighbors) then
             num_found = num_found + 1
          else
             call mpp_error(FATAL,'update_dest_neighbors: '// &
                  'number of neighbor points found is greated than maxium neighbor points' )
          endif
          do m=num_found,n+1,-1
             map_src_add(m) = map_src_add(m-1)
             map_src_dist(m) = map_src_dist(m-1)
          enddo
          map_src_add(n) = src_add
          map_src_dist(n) = d
          update_dest_neighbors = .true.
          if( num_found > min_nbrs ) then
             if( map_src_dist(num_found) > map_src_dist(num_found-1) ) then
                num_found = num_found - 1
             endif
             if( map_src_dist(min_nbrs+1) > map_src_dist(min_nbrs) ) then
                num_found = min_nbrs
             endif
          endif
          exit NLOOP ! n loop
       endif DIST_CHK
    end do NLOOP
    if(already_exist) return

    if( .not. update_dest_neighbors ) then
       if( num_found < min_nbrs ) then
          num_found               = num_found + 1
          update_dest_neighbors   = .true.
          map_src_add(num_found)  = src_add
          map_src_dist(num_found) = d
       endif
    endif

    return

  end function update_dest_neighbors

  !########################################################################
!  function spherical_distance(theta1,phi1,theta2,phi2)

!    real, intent(in) :: theta1, phi1, theta2, phi2
!    real :: spherical_distance

!    real :: r1(3), r2(3), cross(3), s, dot, ang

    ! this is a simple, enough way to calculate distance on the sphere
    ! first, construct cartesian vectors r1 and r2
    ! then calculate the cross-product which is proportional to the area
    ! between the 2 vectors.  The angular distance is arcsin of the
    ! distancealong the sphere
    !
    ! theta is longitude and phi is latitude
    !

!    r1(1) = cos(theta1)*cos(phi1);r1(2)=sin(theta1)*cos(phi1);r1(3)=sin(phi1)
!    r2(1) = cos(theta2)*cos(phi2);r2(2)=sin(theta2)*cos(phi2);r2(3)=sin(phi2)

!    cross(1) = r1(2)*r2(3)-r1(3)*r2(2)
!    cross(2) = r1(3)*r2(1)-r1(1)*r2(3)
!    cross(3) = r1(1)*r2(2)-r1(2)*r2(1)

!    s = sqrt(cross(1)**2.+cross(2)**2.+cross(3)**2.)

!    s = min(s,1.0-epsln)

!    dot = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3)

!    if (dot > 0) then
!       ang = asin(s)
!    else if (dot < 0) then
!       ang = pi + asin(s)  !?  original is pi - asin(s)
!    else
!       ang = pi/2.
!    endif

!    spherical_distance = abs(ang) ! in radians

!    return

!  end function spherical_distance
  ! The great cycle distance
  function spherical_distance(theta1,phi1,theta2,phi2)

    real, intent(in) :: theta1, phi1, theta2, phi2
    real :: spherical_distance, dot

    if(theta1 == theta2 .and. phi1 == phi2) then
        spherical_distance = 0.0
        return
    endif

    dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2)
    if(dot > 1 ) dot = 1.
    if(dot < -1) dot = -1
    spherical_distance = acos(dot)

    return

  end function spherical_distance

  !#######################################################################

  subroutine full_search(theta_src,phi_src,theta_dst,phi_dst,map_src_add, map_src_dist,num_found, &
                         num_neighbors,max_src_dist)
    real,    intent(in),    dimension(:)   :: theta_src, phi_src
    real,    intent(in),    dimension(:,:) :: theta_dst, phi_dst
    integer, intent(out), dimension(:,:,:) :: map_src_add
    real,    intent(out), dimension(:,:,:) :: map_src_dist
    integer, intent(out), dimension(:,:)   :: num_found
    integer, intent(in)                    :: num_neighbors
    real, intent(in)                       :: max_src_dist

    integer :: i,j,map_src_size, step
    integer :: map_dst_xsize,map_dst_ysize
    real    :: d
    logical :: found

    map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2)
    map_src_size =size(theta_src(:))

    do j=1,map_dst_ysize
       do i=1,map_dst_xsize
          do step = 1, map_src_size
             d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step))
             if( d <= max_src_dist) then
                found = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), &
                     step,d,num_found(i,j), num_neighbors )
             endif
          enddo
       enddo
    enddo

  end subroutine full_search

  !#######################################################################

end module horiz_interp_spherical_mod


c=======================================================================
c
c     subroutine CSTSEC
c
c     Sector constraints used by asset allocation methods
c
c-----------------------------------------------------------------------
      SUBROUTINE cstsec ( nasset, nsect, nsubs, asect,
     &                    minsec, equsec, maxsec,
     &                    neq, nin, ccst, bcst )
c-----------------------------------------------------------------------
c
c     INPUT :
c            nasset : size of portfolio                          integer
c            nsect  : number of sectors                          integer
c            nsubs  : number of sub-sectors/sector vector(nsect) integer
c            asect  : assets dispatching by sector
c                     matrix (nasset*nsect)                      integer
c            minsec : sectors min weight matrix (nsect,nssmax)    double
c            equsec : sectors equ weight matrix (nsect,nssmax)    double
c            maxsec : sectors max weight matrix (nsect,nssmax)    double
c                     nssmax : max of nsubs
c
c     OUTPUT :
c            neq    : number of equality constraints             integer
c            nin    : number of inequality constraints           integer
c            ccst   : matrix of constraints (nasset*(nin+neq))    double
c            bcst   : vector of constraints (nin+neq)             double
c                     neq = ( number of equsec(i,j)>=0 )
c                     nin = 2*(somme(nsubs(i)),i=1,nsect)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER nasset, nsect, neq, nin
      INTEGER nsubs(*), asect(nasset,*)
      DOUBLE PRECISION minsec(nsect,*), equsec(nsect,*),
     &                 maxsec(nsect,*), bcst(*), ccst(nasset,*)
c
c     local variables
      INTEGER ic, is, jss, ka, nsstot
c
c-----------------------------------------------------------------------
c
c     nb of subsectors
      nsstot = 0
      DO is = 1,nsect
         nsstot = nsstot + nsubs(is)
      ENDDO
c
c     nb of inequality constrainsts
      nin = 2*nsstot
c
c     equality constraints matrix and vector
      neq = 0
      ic = 0
      DO is=1,nsect
         DO jss=1,nsubs(is)
            IF (equsec(is,jss).ge.0.0) THEN
               neq = neq + 1
               ic = ic + 1
               bcst(ic) = equsec(is,jss)
               DO ka=1,nasset
                  IF (asect(ka,is).eq.jss) THEN
                     ccst(ka,ic) = 1.0
                  ELSE
                     ccst(ka,ic) = 0.0
                  ENDIF
               ENDDO
            ENDIF
         ENDDO
      ENDDO
c
c     inequality constraints matrix and vector
      DO is=1,nsect
         DO jss=1,nsubs(is)
            ic = ic + 1
            bcst(ic) = maxsec(is,jss)
            bcst(ic+nsstot) = -minsec(is,jss)
            DO ka=1,nasset
               IF (asect(ka,is).eq.jss) THEN
                  ccst(ka,ic) = 1.
                  ccst(ka,ic+nsstot) = -1.0
               ELSE
                  ccst(ka,ic) = 0.0
                  ccst(ka,ic+nsstot) = 0.
               ENDIF
            ENDDO
         ENDDO
      ENDDO
c
      RETURN
      END


! ::
! :: ----------------------------------------------------------
! ::
        subroutine volweight_sum_angularmomentum(lo,hi,problo,dx,fab, &
                                              fab_l1,fab_l2,fab_l3, &
                                              fab_h1,fab_h2,fab_h3, &
                                              dir,amom)
        use amrex_fort_module, only : rt => amrex_real
        use probdata_module, only: center
        implicit none
        integer, intent(in) :: lo(3),hi(3),fab_l1,fab_h1,fab_l2, &
                               fab_h2,fab_l3,fab_h3,dir
        real(rt), intent(in) :: problo(3),dx(3)
        real(rt), intent(in) :: fab(fab_l1:fab_h1, &
                                            fab_l2:fab_h2, &
                                            fab_l3:fab_h3)
        integer :: i,j,k
        real(rt) :: pos(3)
        real(rt), intent(out) :: amom(3)
        do i= 1,3
          amom(i) = 0.0d0
        enddo
        if(dir.eq.1) then
          do k=lo(3),hi(3)
            pos(3) = problo(3) + (DBLE(k)+0.5d0)*dx(3) - center(3)
            do j=lo(2),hi(2)
              pos(2) = problo(2) + (DBLE(j)+0.5d0)*dx(2) - center(2)
              do i=lo(1),hi(1)
                amom(2) = amom(2) - fab(i,j,k)*pos(3)
                amom(3) = amom(3) + fab(i,j,k)*pos(2)
              enddo
            enddo
          enddo
        elseif(dir.eq.2) then
          do k=lo(3),hi(3)
            pos(3) = problo(3) + (DBLE(k)+0.5d0)*dx(3) - center(3)
            do j=lo(2),hi(2)
              do i=lo(1),hi(1)
                pos(1) = problo(1) + (DBLE(i)+0.5d0)*dx(1) - center(1)
                amom(1) = amom(1) + fab(i,j,k)*pos(3)
                amom(3) = amom(3) - fab(i,j,k)*pos(1)
              enddo
            enddo
          enddo
        elseif(dir.eq.3) then
          do k=lo(3),hi(3)
            do j=lo(2),hi(2)
              pos(2) = problo(2) + (DBLE(j)+0.5d0)*dx(2) - center(2)
              do i=lo(1),hi(1)
                pos(1) = problo(1) + (DBLE(i)+0.5d0)*dx(1) - center(1)
                amom(2) = amom(2) + fab(i,j,k)*pos(1)
                amom(1) = amom(1) - fab(i,j,k)*pos(2)
              enddo
            enddo
          enddo
        endif
        do i=1,3
          amom(i) = amom(i)*(dx(1)*dx(2)*dx(3))
        enddo
!        write(*,*) '### amom ',amom
        return
        end subroutine volweight_sum_angularmomentum


c
c-----------------------------------------------------------------------
c subroutine:  fft842
c fast fourier transform for n=2**m
c complex input
c-----------------------------------------------------------------------
c
      subroutine fft842 (in, n, x, y, ier)
c
c this program replaces the vector z=x+iy by its  finite
c discrete, complex fourier transform if in=0.  the inverse transform
c is calculated for in=1.  it performs as many base
c 8 iterations as possible and then finishes with a base 4 iteration
c or a base 2 iteration if needed.
c
c the subroutine is called as subroutine fft842 (in,n,x,y).
c the integer n (a power of 2), the n real location array x, and
c the n real location array y must be supplied to the subroutine.
c
      dimension x(*), y(*), l(15)
      common /con2/ pi2, p7
      equivalence (l15,l(1)), (l14,l(2)), (l13,l(3)), (l12,l(4)),
     *    (l11,l(5)), (l10,l(6)), (l9,l(7)), (l8,l(8)), (l7,l(9)),
     *    (l6,l(10)), (l5,l(11)), (l4,l(12)), (l3,l(13)), (l2,l(14)),
     *    (l1,l(15))
c
c
c iw is a machine dependent write device number
c
c+noao
c      iw = i1mach(2)
      ier = 0
c-noao
c
      pi2 = 8.*atan(1.)
      p7 = 1./sqrt(2.)
      do 10 i=1,31
        m = i
        nt = 2**i
        if (n.eq.nt) go to 20
  10  continue
c+noao
c      write (iw,9999)
c9999  format (35h n is not a power of two for fft842)
c      stop
      ier = 1
      return
c-noao
  20  n2pow = m
      nthpo = n
      fn = nthpo
      if (in.eq.1) go to 40
      do 30 i=1,nthpo
        y(i) = -y(i)
  30  continue
  40  n8pow = n2pow/3
      if (n8pow.eq.0) go to 60
c
c radix 8 passes,if any.
c
      do 50 ipass=1,n8pow
        nxtlt = 2**(n2pow-3*ipass)
        lengt = 8*nxtlt
        call r8tx(nxtlt, nthpo, lengt, x(1), x(nxtlt+1), x(2*nxtlt+1),
     *      x(3*nxtlt+1), x(4*nxtlt+1), x(5*nxtlt+1), x(6*nxtlt+1),
     *      x(7*nxtlt+1), y(1), y(nxtlt+1), y(2*nxtlt+1), y(3*nxtlt+1),
     *      y(4*nxtlt+1), y(5*nxtlt+1), y(6*nxtlt+1), y(7*nxtlt+1))
  50  continue
c
c is there a four factor left
c
  60  if (n2pow-3*n8pow-1) 90, 70, 80
c
c go through the base 2 iteration
c
c
  70  call r2tx(nthpo, x(1), x(2), y(1), y(2))
      go to 90
c
c go through the base 4 iteration
c
  80  call r4tx(nthpo, x(1), x(2), x(3), x(4), y(1), y(2), y(3), y(4))
c
  90  do 110 j=1,31
        l(j) = 1
        if (j-n2pow) 100, 100, 110
 100    l(j) = 2**(n2pow+1-j)
 110  continue
      ij = 1
      do 130 j1=1,l1
      do 130 j2=j1,l2,l1
      do 130 j3=j2,l3,l2
      do 130 j4=j3,l4,l3
      do 130 j5=j4,l5,l4
      do 130 j6=j5,l6,l5
      do 130 j7=j6,l7,l6
      do 130 j8=j7,l8,l7
      do 130 j9=j8,l9,l8
      do 130 j10=j9,l10,l9
      do 130 j11=j10,l11,l10
      do 130 j12=j11,l12,l11
      do 130 j13=j12,l13,l12
      do 130 j14=j13,l14,l13
      do 130 ji=j14,l15,l14
        if (ij-ji) 120, 130, 130
 120    r = x(ij)
        x(ij) = x(ji)
        x(ji) = r
        fi = y(ij)
        y(ij) = y(ji)
        y(ji) = fi
 130    ij = ij + 1
      if (in.eq.1) go to 150
      do 140 i=1,nthpo
        y(i) = -y(i)
 140  continue
      go to 170
 150  do 160 i=1,nthpo
        x(i) = x(i)/fn
        y(i) = y(i)/fn
 160  continue
 170  return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r2tx
c radix 2 iteration subroutine
c-----------------------------------------------------------------------
c
      subroutine r2tx(nthpo, cr0, cr1, ci0, ci1)
      dimension cr0(2), cr1(2), ci0(2), ci1(2)
      do 10 k=1,nthpo,2
        r1 = cr0(k) + cr1(k)
        cr1(k) = cr0(k) - cr1(k)
        cr0(k) = r1
        fi1 = ci0(k) + ci1(k)
        ci1(k) = ci0(k) - ci1(k)
        ci0(k) = fi1
  10  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r4tx
c radix 4 iteration subroutine
c-----------------------------------------------------------------------
c
      subroutine r4tx(nthpo, cr0, cr1, cr2, cr3, ci0, ci1, ci2, ci3)
      dimension cr0(2), cr1(2), cr2(2), cr3(2), ci0(2), ci1(2), ci2(2),
     *    ci3(2)
      do 10 k=1,nthpo,4
        r1 = cr0(k) + cr2(k)
        r2 = cr0(k) - cr2(k)
        r3 = cr1(k) + cr3(k)
        r4 = cr1(k) - cr3(k)
        fi1 = ci0(k) + ci2(k)
        fi2 = ci0(k) - ci2(k)
        fi3 = ci1(k) + ci3(k)
        fi4 = ci1(k) - ci3(k)
        cr0(k) = r1 + r3
        ci0(k) = fi1 + fi3
        cr1(k) = r1 - r3
        ci1(k) = fi1 - fi3
        cr2(k) = r2 - fi4
        ci2(k) = fi2 + r4
        cr3(k) = r2 + fi4
        ci3(k) = fi2 - r4
  10  continue
      return
      end
c
c-----------------------------------------------------------------------
c subroutine:  r8tx
c radix 8 iteration subroutine
c-----------------------------------------------------------------------
c
      subroutine r8tx(nxtlt, nthpo, lengt, cr0, cr1, cr2, cr3, cr4,
     *    cr5, cr6, cr7, ci0, ci1, ci2, ci3, ci4, ci5, ci6, ci7)
      dimension cr0(2), cr1(2), cr2(2), cr3(2), cr4(2), cr5(2), cr6(2),
     *    cr7(2), ci1(2), ci2(2), ci3(2), ci4(2), ci5(2), ci6(2),
     *    ci7(2), ci0(2)
      common /con2/ pi2, p7
c
      scale = pi2/float(lengt)
      do 30 j=1,nxtlt
        arg = float(j-1)*scale
        c1 = cos(arg)
        s1 = sin(arg)
        c2 = c1**2 - s1**2
        s2 = c1*s1 + c1*s1
        c3 = c1*c2 - s1*s2
        s3 = c2*s1 + s2*c1
        c4 = c2**2 - s2**2
        s4 = c2*s2 + c2*s2
        c5 = c2*c3 - s2*s3
        s5 = c3*s2 + s3*c2
        c6 = c3**2 - s3**2
        s6 = c3*s3 + c3*s3
        c7 = c3*c4 - s3*s4
        s7 = c4*s3 + s4*c3
        do 20 k=j,nthpo,lengt
          ar0 = cr0(k) + cr4(k)
          ar1 = cr1(k) + cr5(k)
          ar2 = cr2(k) + cr6(k)
          ar3 = cr3(k) + cr7(k)
          ar4 = cr0(k) - cr4(k)
          ar5 = cr1(k) - cr5(k)
          ar6 = cr2(k) - cr6(k)
          ar7 = cr3(k) - cr7(k)
          ai0 = ci0(k) + ci4(k)
          ai1 = ci1(k) + ci5(k)
          ai2 = ci2(k) + ci6(k)
          ai3 = ci3(k) + ci7(k)
          ai4 = ci0(k) - ci4(k)
          ai5 = ci1(k) - ci5(k)
          ai6 = ci2(k) - ci6(k)
          ai7 = ci3(k) - ci7(k)
          br0 = ar0 + ar2
          br1 = ar1 + ar3
          br2 = ar0 - ar2
          br3 = ar1 - ar3
          br4 = ar4 - ai6
          br5 = ar5 - ai7
          br6 = ar4 + ai6
          br7 = ar5 + ai7
          bi0 = ai0 + ai2
          bi1 = ai1 + ai3
          bi2 = ai0 - ai2
          bi3 = ai1 - ai3
          bi4 = ai4 + ar6
          bi5 = ai5 + ar7
          bi6 = ai4 - ar6
          bi7 = ai5 - ar7
          cr0(k) = br0 + br1
          ci0(k) = bi0 + bi1
          if (j.le.1) go to 10
          cr1(k) = c4*(br0-br1) - s4*(bi0-bi1)
          ci1(k) = c4*(bi0-bi1) + s4*(br0-br1)
          cr2(k) = c2*(br2-bi3) - s2*(bi2+br3)
          ci2(k) = c2*(bi2+br3) + s2*(br2-bi3)
          cr3(k) = c6*(br2+bi3) - s6*(bi2-br3)
          ci3(k) = c6*(bi2-br3) + s6*(br2+bi3)
          tr = p7*(br5-bi5)
          ti = p7*(br5+bi5)
          cr4(k) = c1*(br4+tr) - s1*(bi4+ti)
          ci4(k) = c1*(bi4+ti) + s1*(br4+tr)
          cr5(k) = c5*(br4-tr) - s5*(bi4-ti)
          ci5(k) = c5*(bi4-ti) + s5*(br4-tr)
          tr = -p7*(br7+bi7)
          ti = p7*(br7-bi7)
          cr6(k) = c3*(br6+tr) - s3*(bi6+ti)
          ci6(k) = c3*(bi6+ti) + s3*(br6+tr)
          cr7(k) = c7*(br6-tr) - s7*(bi6-ti)
          ci7(k) = c7*(bi6-ti) + s7*(br6-tr)
          go to 20
  10      cr1(k) = br0 - br1
          ci1(k) = bi0 - bi1
          cr2(k) = br2 - bi3
          ci2(k) = bi2 + br3
          cr3(k) = br2 + bi3
          ci3(k) = bi2 - br3
          tr = p7*(br5-bi5)
          ti = p7*(br5+bi5)
          cr4(k) = br4 + tr
          ci4(k) = bi4 + ti
          cr5(k) = br4 - tr
          ci5(k) = bi4 - ti
          tr = -p7*(br7+bi7)
          ti = p7*(br7-bi7)
          cr6(k) = br6 + tr
          ci6(k) = bi6 + ti
          cr7(k) = br6 - tr
          ci7(k) = bi6 - ti
  20    continue
  30  continue
      return
      end


PROGRAM TEST3
 USE PE2D_TYPE
 USE PE2D_AUX
 USE PE2D_GROUND
 USE PE2D_ATMOS
 USE PE2D_NUM
 IMPLICIT NONE
 !--------
 INTEGER(I4B) :: I, J, N
 REAL(DP), DIMENSION(:,:,:), ALLOCATABLE :: C
 REAL(DP), DIMENSION(:,:), ALLOCATABLE :: YA, YVAL1, YVAL2, YCOMP
 REAL(DP), DIMENSION(:), ALLOCATABLE :: XVAL, XA, A
 REAL(DP) :: L, DR, X0, H0, S, THETA, ANGLE, X(3,3), Y(3,3)
 INTEGER(I4B) :: M, NDER
 COMPLEX(DPC) :: Z(3,3), IM
 !--------
 WRITE(*,*) "Enter number of data points N and number of interpolation points M"
 READ(*,*) N, M
 !--------
 OPEN(UNIT=10,FILE='test/test_f_analytic.dat')
 OPEN(UNIT=20,FILE='test/test_f_numeric.dat')
 OPEN(UNIT=30,FILE='test/test_f_numeric2.dat')
 OPEN(UNIT=40,FILE='test/test_f_comp.dat')
 !--------
 NDER = 2
 L = 5000.0_DP
 ANGLE = 40.0_DP
 THETA = ANGLE*PI/180.0_DP
 X0 = L/2.0_DP
 S = L/5.0_DP
 H0 = SQRT(EXP(1.0_DP)/2.0_DP)*S*ATAN(THETA)
 DR = L/N
 ALLOCATE(XA(N+1), YA(N+1,0:NDER))
 XA = (/ (I*DR, I=0,N) /)
 DO I=1,N+1
  YA(I,:) = GHILL(H0,X0,S,XA(I))
  WRITE(10,100) XA(I), YA(I,:)
 END DO
 !--------
 DR = L/M
 ALLOCATE(XVAL(M+1),YVAL1(M+1,0:NDER),YVAL2(M+1,0:NDER),YCOMP(M+1,1:NDER))
 XVAL = (/ (I*DR, I=0,M) /)
 YVAL1 = POLINT1(XVAL,NDER,XA,YA)
 YVAL2(:,0) = INTERP1(XA,YA,XVAL,.TRUE.,0.0_DP)
 YVAL2(:,1) = DIFF1(XA,YA(:,0))
 YVAL2(:,2) = DIFF2(XA,YA(:,0))
 DO I=3,N-1
  DO J=1,NDER
   YCOMP(I,J) = YVAL2(I,J)/YA(I,J)
  END DO
  WRITE(20,100) XVAL(I), YVAL1(I,:)
  WRITE(30,100) XVAL(I), YVAL2(I,:)
  WRITE(40,100) XVAL(I), YCOMP(I,:)
 END DO
 !--------
 100 FORMAT(4(F16.5,X))
 !--------
 ALLOCATE(C(0:4,0:8,0:8),A(0:8))
 A = (/0,1,-1,2,-2,3,-3,4,-4/)
 !A = (/-4,-3,-2,-1,0,1,2,3,4/)
 C = FDW(4,8,0.0_DP,A)
 DO J = 0,4
  WRITE(*,*) "DERIVATIVE ORDER = ", J
  WRITE(*,*) "-----------------------"
  DO I = 1,4
   WRITE(*,101) 2*I, C(J,2*I,:)
  END DO
  WRITE(*,*) "-----------------------"
  WRITE(*,*)
 END DO
 !--------
 101 FORMAT(I1,X,9(F10.3,X))
 !--------
 IM = CMPLX(0.0_DP,1.0_DP,KIND=DP)
 DO I = 1,3
  DO J = 1,3
   Z(I,J) = I+J*IM
  END DO
 END DO
 X = REAL(Z)
 Y = AIMAG(Z)
 WRITE(*,*) "Z = ", Z
 WRITE(*,*) "RE(Z) = ", X
 WRITE(*,*) "IM(Z) = ", Y
 !--------
END PROGRAM


!----------------------------------------------------------------------------
! This file is part of UCLALES.
!
! UCLALES is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! UCLALES is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 1999-2007, Bjorn B. Stevens, Dep't Atmos and Ocean Sci, UCLA
!----------------------------------------------------------------------------
!
!
MODULE defs

  INTEGER :: nv = 1, nv1 = 2, mb = 1
  REAL    :: totalpower
  REAL, PARAMETER :: R      = 287.04
  REAL, PARAMETER :: Rm     = 461.5
  REAL, PARAMETER :: ep     = R/Rm
  REAL, PARAMETER :: ep2    = Rm/R - 1.
  REAL, PARAMETER :: cp     = 1005.
  REAL, PARAMETER :: cv     = cp-R
  REAL, PARAMETER :: rcp    = R/cp
  REAL, PARAMETER :: cpr    = cp/R
  REAL, PARAMETER :: g      = 9.81
  REAL, PARAMETER :: p00    = 1.e+05
  REAL, PARAMETER :: p00i   = 1./p00
  REAL, PARAMETER :: omega  = 7.292e-05
  REAL, PARAMETER :: alvl   = 2.5e+06  ! latent heat of vaporization
  REAL, PARAMETER :: alvi   = 2.834e+06 ! latent heat of sublimation
  REAL, PARAMETER :: rowt   = 1.e+3
  REAL, PARAMETER :: roice  = 0.9e+3
  REAL, PARAMETER :: vonk   = 0.40
  REAL, PARAMETER :: stefan = 5.6696e-8
  REAL, PARAMETER :: SolarConstant  = 1.365d+3
  REAL, PARAMETER :: mair   = 28.967 ! molar mass of air
  REAL, PARAMETER :: pi     = 3.14159265358979323846264338327
  REAL, PARAMETER :: kb     = 1.3807e-23 !Boltzman constant

END MODULE defs


module initdata_module

  use amrex_paralleldescriptor_module, only: parallel_IOProcessor => amrex_pd_ioprocessor
  use network, only: nspec
  use amrex_fort_module, only : amrex_spacedim
  use base_state_geometry_module, only: nr_fine, max_radial_level
  use meth_params_module, only: nscal, rho_comp, rhoh_comp, temp_comp, spec_comp, pi_comp, &
                                prob_lo, prob_hi, grav_const
  use eos_module
  use eos_type_module
  use amrex_constants_module
  use probin_module, only : pert_amp, scale_height, pres_base, k_hoz, k_vert

  implicit none

  private

contains

  subroutine initdata(lev, time, lo, hi, &
       scal, scal_lo, scal_hi, nc_s, &
       vel, vel_lo, vel_hi, nc_v, &
       s0_init, p0_init, dx) bind(C, name="initdata")

    integer         , intent(in   ) :: lev, lo(3), hi(3)
    integer         , intent(in   ) :: scal_lo(3), scal_hi(3), nc_s
    integer         , intent(in   ) :: vel_lo(3), vel_hi(3), nc_v
    double precision, intent(in   ) :: time
    double precision, intent(inout) :: scal(scal_lo(1):scal_hi(1), &
         scal_lo(2):scal_hi(2), &
         scal_lo(3):scal_hi(3), 1:nc_s)
    double precision, intent(inout) :: vel(vel_lo(1):vel_hi(1), &
         vel_lo(2):vel_hi(2), &
         vel_lo(3):vel_hi(3), 1:nc_v)
    double precision, intent(in   ) :: s0_init(0:max_radial_level,0:nr_fine-1,1:nscal)
    double precision, intent(in   ) :: p0_init(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: dx(3)

    ! local variables

    integer          :: i,j,k,r
    type (eos_t) :: eos_state
    double precision :: x, y, rho0, rho_local, rho_base

!    ! abort program
!    call amrex_error()

    ! set velocity to zero
    vel(vel_lo(1):vel_hi(1),vel_lo(2):vel_hi(2),vel_lo(3):vel_hi(3),1:nc_v) = 0.d0

    do k=lo(3),hi(3)
       do j=lo(2),hi(2)
          do i=lo(1),hi(1)

             if (amrex_spacedim .eq. 1) then
                r = i
             else if (amrex_spacedim .eq. 2) then
                r = j
             else if (amrex_spacedim .eq. 3) then
                r = k
             end if

             ! set scalars using s0
             scal(i,j,k,rho_comp)  = s0_init(lev,r,rho_comp)
             scal(i,j,k,rhoh_comp) = s0_init(lev,r,rhoh_comp)
             scal(i,j,k,temp_comp) = s0_init(lev,r,temp_comp)
             scal(i,j,k,spec_comp:spec_comp+nspec-1) = &
                  s0_init(lev,r,spec_comp:spec_comp+nspec-1)

             ! initialize pi to zero for now
             scal(i,j,k,pi_comp) = 0.d0

          end do
       end do
    end do

    ! introduce density fluctuations - only implemented for 2D

    if ((amrex_spacedim == 1) .or. amrex_spacedim == 3) then
      call amrex_error("density perturbation only implemented for 2d")
    endif

    do k=lo(3),hi(3)
    do j=lo(2),hi(2)
    do i=lo(1),hi(1)

      r = j ! this loop is currently 2d only
      x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)
      y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)

      ! This seems to work ok with sealed box?

!      rho0 = s0_init(lev,r,rho_comp)
!      rho_local = rho0 * (1.0 + &
!        pert_amp * exp(-y/(2.0_num * scale_height)) * &
!        cos(x * k_hoz * M_PI / (prob_hi(1) - prob_lo(1)) ) * &
!        sin(y * k_vert * M_PI / (prob_hi(2) - prob_lo(2)) )  &
!      )

      ! What about this ?

      rho_base = pres_base / scale_height / abs(grav_const)
      rho0 = s0_init(lev,r,rho_comp)
      rho_local = rho0 &
        + rho_base * pert_amp * exp(-y/(2d0 * scale_height)) * &
        cos(x * k_hoz * m_pi / (prob_hi(1) - prob_lo(1)) ) * &
        sin(y * k_vert * m_pi / (prob_hi(2) - prob_lo(2)) )

      ! if k_vert is 0, dont multiply by sin(0) = 0
      ! (make this all more elegant later)

      if (k_vert == 0d0) then
        rho_local = rho0 &
          + rho_base * pert_amp * exp(-y/(2d0 * scale_height)) * &
          cos(x * k_hoz * m_pi / (prob_hi(1) - prob_lo(1)) )
      endif

      !
      eos_state%rho   = rho_local
      eos_state%p     = p0_init(lev,r)
      eos_state%T     = s0_init(lev,r,temp_comp)
      eos_state%xn(:) = 1.0d0 ! single fluid

      ! (rho,p) --> T, h
      call eos(eos_input_rp, eos_state)

      scal(i,j,k,rho_comp)  = eos_state%rho
      scal(i,j,k,rhoh_comp) = eos_state%rho * eos_state%h
      scal(i,j,k,temp_comp) = eos_state%T
      scal(i,j,k,spec_comp:spec_comp+nspec-1) = eos_state%rho * eos_state%xn ! single fluid

    end do
    end do
    end do

  end subroutine initdata

  subroutine initdata_sphr(time, lo, hi, &
       scal, scal_lo, scal_hi, nc_s, &
       vel, vel_lo, vel_hi, nc_v, &
       s0_init, p0_init, &
       dx, r_cc_loc, r_edge_loc, &
       cc_to_r, ccr_lo, ccr_hi) bind(C, name="initdata_sphr")

    integer         , intent(in   ) :: lo(3), hi(3)
    integer         , intent(in   ) :: scal_lo(3), scal_hi(3), nc_s
    integer         , intent(in   ) :: vel_lo(3), vel_hi(3), nc_v
    integer         , intent(in   ) :: ccr_lo(3), ccr_hi(3)
    double precision, intent(in   ) :: time
    double precision, intent(inout) :: scal(scal_lo(1):scal_hi(1), &
         scal_lo(2):scal_hi(2), &
         scal_lo(3):scal_hi(3), nc_s)
    double precision, intent(inout) :: vel(vel_lo(1):vel_hi(1), &
         vel_lo(2):vel_hi(2), &
         vel_lo(3):vel_hi(3), nc_v)
    double precision, intent(in   ) :: s0_init(0:max_radial_level,0:nr_fine-1,1:nscal)
    double precision, intent(in   ) :: p0_init(0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: dx(3)
    double precision, intent(in   ) :: r_cc_loc  (0:max_radial_level,0:nr_fine-1)
    double precision, intent(in   ) :: r_edge_loc(0:max_radial_level,0:nr_fine)
    double precision, intent(in   ) :: cc_to_r   (ccr_lo(1):ccr_hi(1), &
         ccr_lo(2):ccr_hi(2),ccr_lo(3):ccr_hi(3))

    call amrex_error("error: called initdata_sphr, but is a stub")

  end subroutine initdata_sphr

end module initdata_module


SUBROUTINE legpoly(l,sgm,mu,plm1,pl)

! ---------------------------------------------
!
! Uses a recursive relationship to compute the
!  next Legendre polynomial
!
! ---------------------------------------------

IMPLICIT NONE

INTEGER, INTENT(IN) :: l, sgm
REAL*8, INTENT(IN) :: mu
REAL*8, INTENT(INOUT) :: plm1, pl
REAL*8 :: plp1

plp1 = (1.0/(l+1.0))*((2.0*l+1.0)*sgm*mu*pl-l*plm1)
plm1 = pl
pl   = plp1

END SUBROUTINE legpoly


!
! ej1a.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program ej1a

use precision, pr => dp
use mtmod

implicit none
integer                             :: i, j, k
integer, parameter                  :: u_max=1500
integer, dimension(:), allocatable  :: s
integer                             :: tmc, n_down, n_up, n_left, n_right
integer                             :: spinadd, loc, L
real(pr),dimension(0:u_max)         :: corr_e, corr_m, e_c, m_c
real(pr)                            :: e, m, d_e, r, T, Rp, e_w
real(pr)                            :: prob(-4:4, -1:1)
character (30)                      :: Lchar, Tchar, L1, T1
character (30)                      :: outfile, corr_file
character (30)                      :: outf, corr_f

print *, "getting variables"
call get_command_argument(1, Tchar)
call get_command_argument(2, Lchar)
call get_command_argument(3, outf)
call get_command_argument(4, corr_f)

read(Tchar, *) T1
read(Lchar, *) L1
read(T1, *) T
read(L1, *) L
read(outf, *) outfile
read(corr_f, *) corr_file

print*,'T=',T
print*,'L=',L
print*,'out=', outfile
print*,'corr_out=', corr_file

allocate(s(0:(L*L)-1))

36 format(F8.4, 4X, F8.4, 4X, F8.4, 4X, F8.4, 4X)
38 format(F6.4, 4X, F6.4, 4X, I8)

open(unit=10, file=outfile, status='unknown')
write(10, *) "#m    e    m2    e2    "

! Inicializo la red de spines.
!  1 = up
! -1 = down
s = (/ (1, i=0, (L*L) - 1) /)

! energia del estado fundamental, en unidades de J
e = -2._pr * real(L*L, pr)

! correlaciones
corr_e = (/ (0, i=0, u_max) /)
corr_m = (/ (0, i=0, u_max) /)
loc = 0

m = sum(s)
!write(10, 36) m/real(L*L,pr), e/real(L*L, pr), (m/real(L*L, pr))**2, (e/real(L*L, pr))**2

! posibles deltas de energia
do k = -4, 4, 2
    prob(k, +1) = exp( (-2._pr * real(k, pr)) / (2.2692_pr * T) )
    prob(k, -1) = exp( ( 2._pr * real(k, pr)) / (2.2692_pr * T) )
end do

! dar vuelta la red por completo una vez
! de forma ordenada
do tmc =1, 100000
    do k = 0, (L * L) -1
        i = mod(k, L)
        j = int(k/L)
        n_up    = mod(j-1+L, L) * L  +  i
        n_down  = mod(j+1  , L) * L  +  i
        n_left  = mod(i-1+L, L)  +  L * j
        n_right = mod(i+1  , L)  +  L * j
        ! calculo el delta de energia
        spinadd = s(n_up) + s(n_down) + s(n_left) + s(n_right)
        d_e = 2_pr * s(k) * spinadd
        if (d_e < 0) then
            s(k) = -1 * s(k)
            e = e + d_e
        else
            ! sorteo un numero random
            r = grnd()
            Rp = prob(spinadd, s(k))
            if ( Rp > r) then
                s(k) = -1 * s(k)
                e = e + d_e
            end if
        end if
    end do

    if (tmc > 10000) then  ! descarto transitorio
        m = sum(s)/real(L*L, pr)
        e_w = e/real(L*L, pr)

        if (mod(tmc, 100)==0) then  !!!!!!!!!!!!!! BUG
            write(10, 36) m, e_w, m*m, e_w*e_w
        end if
        ! actualizo e_c, m_c y calculo correlaciones corr_m,e
        e_c(mod(loc, u_max+1)) = e_w
        m_c(mod(loc, u_max+1)) = m

        if (loc>u_max) then
            do i = 0, u_max
                corr_e(i) = corr_e(i) + e_w*e_c(mod(loc-i, u_max+1))
                corr_m(i) = corr_m(i) + m * m_c(mod(loc-i, u_max+1))
            end do
        else
            do i = 0, loc
                corr_e(i) = corr_e(i) + e_w*e_c(loc-i)
                corr_m(i) = corr_m(i) + m * m_c(loc-i)
            end do
        end if
        loc = loc + 1

    end if
end do
close(10)

open(unit=11, file=corr_file, status='unknown')
write(11, *) "#   corr_m    corr_e   u_corr"
do i = 0, u_max
    write(11, 38) corr_m(i)/real(loc-i, pr), corr_e(i)/real(loc-i, pr), i
end do
close(11)

open(unit=17, file='spins_transaction.dat', status='unknown')
do j = 0, (L*L)-1
    write(17, *) s(j)
end do
close(17)

end program


!*==srot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b SROT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
!
!       .. Scalar Arguments ..
!       REAL C,S
!       INTEGER INCX,INCY,N
!       ..
!       .. Array Arguments ..
!       REAL SX(*),SY(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    applies a plane rotation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in,out] SX
!> \verbatim
!>          SX is REAL array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of SX
!> \endverbatim
!>
!> \param[in,out] SY
!> \verbatim
!>          SY is REAL array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>         storage spacing between elements of SY
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is REAL
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is REAL
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup single_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SROT(N,Sx,Incx,Sy,Incy,C,S)
      IMPLICIT NONE
!*--SROT96
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      REAL C , S
      INTEGER Incx , Incy , N
!     ..
!     .. Array Arguments ..
      REAL Sx(*) , Sy(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      REAL stemp
      INTEGER i , ix , iy
!     ..
      IF ( N<=0 ) RETURN
      IF ( Incx==1 .AND. Incy==1 ) THEN
!
!       code for both increments equal to 1
!
         DO i = 1 , N
            stemp = C*Sx(i) + S*Sy(i)
            Sy(i) = C*Sy(i) - S*Sx(i)
            Sx(i) = stemp
         ENDDO
      ELSE
!
!       code for unequal increments or equal increments not equal
!         to 1
!
         ix = 1
         iy = 1
         IF ( Incx<0 ) ix = (-N+1)*Incx + 1
         IF ( Incy<0 ) iy = (-N+1)*Incy + 1
         DO i = 1 , N
            stemp = C*Sx(ix) + S*Sy(iy)
            Sy(iy) = C*Sy(iy) - S*Sx(ix)
            Sx(ix) = stemp
            ix = ix + Incx
            iy = iy + Incy
         ENDDO
      ENDIF
      END SUBROUTINE SROT


      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1 RPL,DDSDDT,DRPLDE,DRPLDT,
     2 STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3 NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4 CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)

      INCLUDE 'ABA_PARAM.INC'
C LOCAL ARRAYS
C ----------------------------------------------------------------
C EELAS - LOGARITHMIC ELASTIC STRAINS
C EELASP - PRINCIPAL ELASTIC STRAINS
C BBAR - DEVIATORIC RIGHT CAUCHY-GREEN TENSOR
C BBARP - PRINCIPAL VALUES OF BBAR
C BBARN - PRINCIPAL DIRECTION OF BBAR (AND EELAS)
C DISTGR - DEVIATORIC DEFORMATION GRADIENT (DISTORTION TENSOR)
C ----------------------------------------------------------------
C
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1 DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     2 STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     3 PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3),
     4 JSTEP(4)

      DIMENSION EELAS(6), EELASP(3), BBAR(6), BBARP(3), BBARN(3, 3),
     1 DISTGR(3,3)
      PARAMETER(ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0, FOUR=4.D0,
     1 SIX=6.D0)

      C10=PROPS(1)
      D1=PROPS(2)
C
C JACOBIAN AND DISTORTION TENSOR
C
      DET=DFGRD1(1, 1)*DFGRD1(2, 2)*DFGRD1(3, 3)
     1 -DFGRD1(1, 2)*DFGRD1(2, 1)*DFGRD1(3, 3)
      IF(NSHR.EQ.3) THEN
      DET=DET+DFGRD1(1, 2)*DFGRD1(2, 3)*DFGRD1(3, 1)
     1 +DFGRD1(1, 3)*DFGRD1(3, 2)*DFGRD1(2, 1)
     2 -DFGRD1(1, 3)*DFGRD1(3,1)*DFGRD1(2, 2)
     3 -DFGRD1(2, 3)*DFGRD1(3, 2)*DFGRD1(1, 1)
      END IF
      SCALE=DET**(-ONE/THREE)
      DO K1=1, 3
          DO K2=1, 3
              DISTGR(K2, K1)=SCALE*DFGRD1(K2, K1)
          END DO
      END DO
C CALCULATE DEVIATORIC LEFT CAUCHY-GREEN DEFORMATION TENSOR
C
      BBAR(1)=DISTGR(1, 1)**2+DISTGR(1, 2)**2+DISTGR(1, 3)**2
      BBAR(2)=DISTGR(2, 1)**2+DISTGR(2, 2)**2+DISTGR(2, 3)**2
      BBAR(3)=DISTGR(3, 3)**2+DISTGR(3, 1)**2+DISTGR(3, 2)**2
      BBAR(4)=DISTGR(1, 1)*DISTGR(2, 1)+DISTGR(1, 2)*DISTGR(2, 2)
     1 +DISTGR(1, 3)*DISTGR(2, 3)
      IF(NSHR.EQ.3) THEN
          BBAR(5)=DISTGR(1, 1)*DISTGR(3, 1)+DISTGR(1, 2)*DISTGR(3, 2)
     1 +DISTGR(1, 3)*DISTGR(3, 3)
          BBAR(6)=DISTGR(2, 1)*DISTGR(3, 1)+DISTGR(2, 2)*DISTGR(3, 2)
     1 +DISTGR(2, 3)*DISTGR(3, 3)
      END IF
C
C CALCULATE THE STRESS
C
      TRBBAR=(BBAR(1)+BBAR(2)+BBAR(3))/THREE
      EG=TWO*C10/DET
      EK=TWO/D1*(TWO*DET-ONE)
      PR=TWO/D1*(DET-ONE)
      DO K1=1,NDI
          STRESS(K1)=EG*(BBAR(K1)-TRBBAR)+PR
      END DO
      DO K1=NDI+1,NDI+NSHR
          STRESS(K1)=EG*BBAR(K1)
      END DO
C CALCULATE THE STIFFNESS
C
      EG23=EG*TWO/THREE
      DDSDDE(1, 1)= EG23*(BBAR(1)+TRBBAR)+EK
      DDSDDE(2, 2)= EG23*(BBAR(2)+TRBBAR)+EK
      DDSDDE(3, 3)= EG23*(BBAR(3)+TRBBAR)+EK
      DDSDDE(1, 2)=-EG23*(BBAR(1)+BBAR(2)-TRBBAR)+EK
      DDSDDE(1, 3)=-EG23*(BBAR(1)+BBAR(3)-TRBBAR)+EK
      DDSDDE(2, 3)=-EG23*(BBAR(2)+BBAR(3)-TRBBAR)+EK
      DDSDDE(1, 4)= EG23*BBAR(4)/TWO
      DDSDDE(2, 4)= EG23*BBAR(4)/TWO
      DDSDDE(3, 4)=-EG23*BBAR(4)
      DDSDDE(4, 4)= EG*(BBAR(1)+BBAR(2))/TWO
      IF(NSHR.EQ.3) THEN
          DDSDDE(1, 5)= EG23*BBAR(5)/TWO
          DDSDDE(2, 5)=-EG23*BBAR(5)
          DDSDDE(3, 5)= EG23*BBAR(5)/TWO
          DDSDDE(1, 6)=-EG23*BBAR(6)
          DDSDDE(2, 6)= EG23*BBAR(6)/TWO
          DDSDDE(3, 6)= EG23*BBAR(6)/TWO
          DDSDDE(5, 5)= EG*(BBAR(1)+BBAR(3))/TWO
          DDSDDE(6, 6)= EG*(BBAR(2)+BBAR(3))/TWO
          DDSDDE(4,5)= EG*BBAR(6)/TWO
          DDSDDE(4,6)= EG*BBAR(5)/TWO
          DDSDDE(5,6)= EG*BBAR(4)/TWO
      END IF
      DO K1=1, NTENS
          DO K2=1, K1-1
              DDSDDE(K1, K2)=DDSDDE(K2, K1)
          END DO
      END DO
C
C CALCULATE LOGARITHMIC ELASTIC STRAINS (OPTIONAL)
C
      CALL SPRIND(BBAR, BBARP, BBARN, 1, NDI, NSHR)
      EELASP(1)=LOG(SQRT(BBARP(1))/SCALE)
      EELASP(2)=LOG(SQRT(BBARP(2))/SCALE)
      EELASP(3)=LOG(SQRT(BBARP(3))/SCALE)
      EELAS(1)=EELASP(1)*BBARN(1,1)**2+EELASP(2)*BBARN(2, 1)**2
     1 +EELASP(3)*BBARN(3, 1)**2
      EELAS(2)=EELASP(1)*BBARN(1, 2)**2+EELASP(2)*BBARN(2, 2)**2
     1 +EELASP(3)*BBARN(3, 2)**2
      EELAS(3)=EELASP(1)*BBARN(1, 3)**2+EELASP(2)*BBARN(2, 3)**2
     1 +EELASP(3)*BBARN(3, 3)**2
      EELAS(4)=TWO*(EELASP(1)*BBARN(1, 1)*BBARN(1, 2)
     1 +EELASP(2)*BBARN(2, 1)*BBARN(2, 2)
     2 +EELASP(3)*BBARN(3, 1)*BBARN(3, 2))
      IF(NSHR.EQ.3) THEN
      EELAS(5)=TWO*(EELASP(1)*BBARN(1, 1)*BBARN(1, 3)
     1 +EELASP(2)*BBARN(2, 1)*BBARN(2, 3)
     2 +EELASP(3)*BBARN(3, 1)*BBARN(3, 3))
      EELAS(6)=TWO*(EELASP(1)*BBARN(1, 2)*BBARN(1, 3)
     1 +EELASP(2)*BBARN(2, 2)*BBARN(2, 3)
     2 +EELASP(3)*BBARN(3, 2)*BBARN(3, 3))
      END IF

      STATEV(1)=STATEV(1)+1

      RETURN
      END


c
c
c
c
      function fbody(x,y)
      implicit double precision (a-h,o-z)
      dimension xuc(10),yuc(10),xlc(10),ylc(10)
      dimension xupw(500),yupw(500)
      logical first
      common /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold
       common /skewll/ y0skew,dely
       common /exwavey/ np,ipad,R1,R2,rp,dtshift
       data first /.true./
       pi = 3.14159265358979d0
c
c  negative inside the body (exterior to the domain), positive otherwise.
c
c     fbody = 1.
c     return
c
      go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,
     .22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32)iprob
c
    1 continue
c     # quarter cylinder
      r = .5001d0
      fbody = (x-1.0d0)**2 + (y-0.d0)**2 - r**2
      if (fbody.eq.0.d0) fbody = 1d-5
      return
c
    2 continue
      fbody = 1.d0
!      if (y .lt. .00001) fbody = -1.   ! test horizontal wall

      return

!   22 continue
!      fbody = 1.d0
!      if (y .lt. (0.1d0-.0001) ) fbody = -1.   ! test horizontal wall
!      return

   22 continue
      fbody = 1.d0
      if (y .lt. .0001 ) fbody = -1.   ! test horizontal wall
      return

!   23 continue
!      fbody = 1.d0
!      dyi = 0.00999d0
!      if ( (y .lt. dyi .and. x > 0.5d0) .or.
!     .     (y .lt. -(x-0.5d0)/sqrt(3.d0) + dyi) .and. x <= 0.5d0) then
!       fbody = -1.   ! test horizontal wall
!      endif
!      return

   23 continue
      fbody = 1.d0
      if ( (y .lt. 0.00001d0 .and. x > 0.5d0) .or.
     .     (y .lt. -(x-0.5d0)/sqrt(3.d0)) .and. x <= 0.5d0) then
       fbody = -1.   ! test horizontal wall
      endif
      return

   24 continue
c     # channel
      if ((y .ge. .1d0*x+.11d0) .and. (y .le. .1d0*x+.81d0)) then
        fbody = 1.0d0
      else
        fbody = -1.d0
      endif

      return
   25 continue

      xint = 2.d0 - 0.00001d0
      yint = 0.d0

c      dangle = 0.321750554d0
      dangle = pi/5.d0
      f1 = (y-yint) - tan(dangle) * (x-xint)
      f2 = (y-xint) - tan(dangle) * (x-yint)

      if ( f1 > 0.d0 .and. f2 < 0.d0 ) then
          fbody = 1.d0
      else
          fbody = -1.d0
      endif

      return
   26 continue
c     # bunch of overlapping circles
      fbody = 1.d0

      xstart = 1.d0
      xend = 3.d0
      numcircles = 4
      dx = (xend-xstart)/(numcircles-1)
      xc = xstart
      yc = 2.d0
      r = 0.5d0

      do n=1,numcircles
        if( (x-xc)**2 /(r/1.25)**2+(y-yc)**2 / r**2- 1. <0) then
            fbody = -1.d0
        endif
        xc = xc+dx
      end do

      return

  27  continue
      fbody = 1.d0
      R1 = 0.751d0
      R2 = 1.251d0
      if(   (x-1.5d0)**2 +(y-1.5d0)**2  < R1**2
     . .or. (x-1.5d0)**2 +(y-1.5d0)**2  > R2**2 ) then
            fbody = -1.d0
      endif

      return

 28   continue
      fbody = 1.d0
      R1 = 1.00d0
      R2 = 1.384d0
      if(   (x**2 +y**2  < R1**2)
     . .or. (x**2 +y**2  > R2**2) ) then
            fbody = -1.d0
      endif
      return

 29   continue
      fbody = 1.d0
      ! best so far
      R1 = 0.759d0
      R2 = 1.251d0
      rp = 0.25d0
      np = 10
!      dtshift = .0d0

      ! np = 10 works for 25,50,100 and has a nice overlapping example
      ! when np = 100
!      R1 = 0.751d0
!      R2 = 1.251d0
!      rp = 0.25d0

!      np = 7
!      R1 = 0.751d0
!      R2 = 1.251d0
!      rp = 0.25d0

      theta = atan2(y-1.5d0, x-1.5d0)+dtshift
      R = dsqrt( (x-1.5d0)**2 + (y-1.5d0)**2 )
      if(  (x-1.5d0)**2 +(y-1.5d0)**2  < (R1+rp*sin(np*theta))**2
     ..or. (x-1.5d0)**2+(y-1.5d0)**2>(R2+rp*sin(np*theta))**2 ) then
            fbody = -1.d0
      endif

      return

 30   continue
c     #NACA 0012 airfoil
      fbody = 1.d0

      ddt = 1.d-1

      if( x < 0.25 .or. x > 0.75d0) then
      return
      endif

      xp = (x-0.25)/0.5d0
      yp = (y-0.25)/0.5d0

      daf = 5.d0 * ddt*(0.2969 * dsqrt(xp) -0.1260 * xp
     . - 0.3516 *xp**2
     .              +0.2843 * xp**3 -0.1036*xp**4)
      if( dabs(yp) < daf) then
        fbody = -1.d0
      endif

      return
c
c again to match rotbox on zero origin domain
c
    3 continue
c     # nozzle
      fbody = 1.d0
      pi2 = 2.d0*datan(1.d0)
c      fbody = (w1-w2)*(datan(alf*(x-.5d0))/pi2)**2 + w2 - abs(y-.5d0)
      return
c
    4 continue
      fbody = 1.d0
!c     # piecewise linear channel (e.g. ramp)
!c     # (xlc(1),ylc(1)), ..., (xlc(nlc),ylc(nlc)) defines lower wall
!c     # (xuc(1),yuc(1)), ..., (xuc(nuc),yuc(nuc)) defines upper wall
!c
!c     # 40 degree ramp:
!      xlc(1) = 0.d0
!      ylc(1) = .8142d0
!      xlc(2) = .85d0
!      ylc(2) = .101d0
!      xlc(3) = 1.d0
!      ylc(3) = .101d0
!      nlc = 3
!      nuc = 0
!c
!c     # 20 degree ramp aligned with grid:
!      xlc(1) = 0.d0
!      ylc(1) = .04649702d0
!      xlc(2) = .1d0
!      ylc(2) = .0101d0
!      xlc(3) = 1.d0
!      ylc(3) = .0101d0
!      nlc = 3
!      nuc = 0
!c
!c     # 20 degree ramp:
!      xlc(1) = 0.d0
!      ylc(1) = .0101d0
!      xlc(2) = .1d0
!      ylc(2) = .0101d0
!      xlc(3) = 1.d0
!      ylc(3) = .3376732d0
!      nlc = 3
!      nuc = 0
!c
!      fbody = 1.
!      if (nuc.eq.0) go to 43
!      do 41 i=1,nuc
!   41    if (x.lt.xuc(i)) go to 42
!   42 if (i.eq.1) i=2
!      if (i.gt.nuc) i = nuc
!      ybdry = yuc(i-1)+(x-xuc(i-1))*(yuc(i)-yuc(i-1))/(xuc(i)-xuc(i-1))
!      if (y.gt.ybdry) fbody = -1.
!   43 if (nlc.eq.0. .or. fbody.eq.-1.) go to 46
!      do 44 i=1,nlc
!   44    if (x.lt.xlc(i)) go to 45
!   45 if (i.eq.1) i = 2
!      if (i.gt.nlc) i = nlc
!      ybdry = ylc(i-1)+(x-xlc(i-1))*(ylc(i)-ylc(i-1))/(xlc(i)-xlc(i-1))
!      if (y.lt.ybdry) fbody = -1.
!   46 continue
!c      if (r.eq.0.) return
!c      fbody = fbody * ((x-cx1)**2 + (y-cy1)**2 - r**2)
      return
c
    5 continue
      fbody = 1.d0
c     # channel
c      f1 = (x-1.0d0)*beta - (y-cy2)*alf
c      f2 = -x*beta + (y - cy2 + (beta+w1)/alf)*alf
c      f3 = (x-cx1)*alf + (y-cy1)*beta
c      if (f1.gt.0d0 .and. f2.gt.0d0 .and. f3.gt.0d0) then
c          fbody = 1.d0
c        else
c          fbody = -1.d0
c        endif
c      if (r.eq.0.) return
c      fbody = fbody * ((x-.5d0)**2 + (y-.5d0)**2 - r**2)
      return
c
    6 continue
c     #NACA 0012 airfoil
c     theta = (8.d0 * datan(1.d0)*4.d0)/180.d0
      theta = 0.d0
      alf = dcos(theta)
      beta = dsin(theta)
c trailing edge location (cx1,cy1). w1 = length of chord.
c     cx1 = 03.050d0
c     cy1 = 03.0d0
      cx1 = 06.050d0
      cy1 = 06.0d0
      w1 = 0.1d0
      xi = 1.0089d0*(w1 + (x-cx1)*alf + (y-cy1)*beta)/w1
      eta = 1.0089d0*(-(x-cx1)*beta + (y-cy1)*alf)/w1
      fbody = dabs(eta) - .6d0*(0.2969d0*dsqrt(dabs(xi))
     &        + (((-0.1015d0*xi
     &        + .2843d0)*xi - .3516d0)*xi - .126d0)*xi)
     &        + 100.d0*(1.-dsign(1.d0,xi))
      return
c
    7 continue
c     # multiple cylinders
      fbody = 1.
c     if ((x-.4)**2+(y-.507)**2 - (.103)**2 .lt. 0.) fbody = -1.
c     if ((x-.5)**2+(y-.227)**2 - (.096)**2 .lt. 0.) fbody = -1.
c     if ((x-.5)**2+(y-.787)**2 - (.096)**2 .lt. 0.) fbody = -1.
      if ((x-.3)**2+(y-.30)**2 - (.12)**2 .lt. 0.) fbody = -1.
      if ((x-.4)**2+(y-.70)**2 - (.15)**2 .lt. 0.) fbody = -1.
c     if (y.lt. .03) fbody = -1.
      if (y.gt. .97) fbody = -1.
      return
c
    8 continue
c     # wall at 45 degrees
c     if (y.gt. 0.95d0-x) then
c       fbody = 1.0d0
c     else
c       fbody = -1.0d0
c     endif
c     # wall at small angle
      y0skew = 0.04999d0
c     dely = 0.2d0
      dely = 0.0d0
      if (y.gt. y0skew + dely*x) then
        fbody = 1.0d0
      else
        fbody = -1.0d0
      endif
      return
c
    9 continue
c     # kumar's nozzle
      fbody = 1.d0
c     if (y.gt. .29999d0) fbody = -1.d0
      if (y.gt. .39999d0) fbody = -1.d0
      if (x.lt. .1743d0 .or. x.gt. .68252d0) return
      if (y.gt. .10001d0) return
      if (x.lt. .35d0) then
          if (y.gt. .1d0-.1659d0*(x-.1743d0)) fbody = -1.d0
        else
          if (y.gt. .07085d0+.08766d0*(x-.35d0)) fbody = -1.d0
        endif
      return
c
   10 continue
c     # 2 cylinder run
      fbody1 = (x-.43)**2 + (y-.3)**2 - .0201
      fbody2 = (x-.5)**2 + (y-.75)**2 - .0201
      if ((fbody1 .gt. 0.d0) .and. (fbody2 .gt. 0.d0)) fbody = 1.d0
      if ((fbody1 .gt. 0.d0) .and. (fbody2 .lt. 0.d0)) fbody = fbody2
      if ((fbody1 .lt. 0.d0) .and. (fbody2 .gt. 0.d0)) fbody = fbody1
      return
c
   11 continue
      fbody = 1.d0
c     # single cylinder
      temp = (x-0.5d0)**2 + (y-0.5d0)**2 - .15d0**2
      if(temp < 0.d0) fbody = -1.d0
c     fbody = (x-.5)**2 + (y-.5)**2 - .037
c     fbody = (x-.5)**2 + (y-.5)**2 - .143**2
c     fbody = (x-.5)**2 + (y-.5)**2 - .235**2
      return
c
   12 continue
c     # 90 degree bend
      x0 = .1d0
      y0 = .9d0
      r1 = .59d0
      r2 = .89d0
      fbody = -1.
      if (x.le.x0 .and. y.le.y0-r1 .and. y.ge.y0-r2) fbody = 1.
      if (y.ge.y0 .and. x.ge.x0+r1 .and. x.le.x0+r2) fbody = 1.
      if (x.gt.x0 .and. y.lt.y0) then
         r = dsqrt((x-x0)**2 + (y-y0)**2)
         if (r.ge.r1 .and. r.le.r2) fbody = 1.
      endif
      return

   13 continue
c     # hemicircle
c     r = .25001d0
c     fbody = (x-.5d0)**2 + (y-0.d0)**2 - r**2
c     if (fbody.eq.0.d0) fbody = 1d-5
      r = .5001d0
      fbody = (x-0d0)**2 + (y-0.2d0)**2 - r**2
      if (fbody.eq.0.d0) fbody = 1d-5
      return
c
   14 continue
c    # no body
      fbody = 1.d0
      return
c
   15 continue
c     if (y .lt. .39d0 .and. y .gt. .00000000001d0) then
c     if (y .gt. .025001d0) then
      alpha = .11d0
      alpha = .333333333d0
      if (y .lt. .1749d0+alpha*x .and. y .gt. .025000d0+alpha*x) then
       fbody = 1.0d0
      else
       fbody = -1.d0
      endif
      return
c
   16 continue
      if ((y .ge. .1d0*x+.11d0) .and. (y .le. .1d0*x+.81d0)) then
c     if ((y .ge. -.13999999+x) .and. (y .le. x+.1399999999)) then
c     if ((y .ge. -.2+x) .and. (y .le. x+.2)) then
       fbody = 1.0d0
      else
       fbody = -1.d0
      endif
      return
c
   17 continue
c     # single cylinder for swirling flow
      fbody = (x-2.0d0)**2 + (y-2.0d0)**2 - 1.000567d0**2
c     fbody = (x-.5)**2 + (y-.5)**2 - .1923538406**2
      return
c
   18 continue
c     # simple wave around curved wall, from Whitham, p. 204
c
c     # lower wall:
c
      if ((x.le.0.1d0 .and. y.ge.0.302d0) .or. (x.gt.0.1d0 .and.
     &     x.le.0.7d0 .and. y.ge.0.302d0-0.3d0*(x-0.1d0)**2).or.(x.gt.0.7d0
     &     .and. y.ge..194d0-0.36d0*(x-0.7d0))) then
         fbody = 1.d0
        else
         fbody = -1.d0
        endif
c     return
c
c     # upper wall:
c
      if (first) then
c     #  generate upper boundary points:
         nupw = 300
         call p18(xupw,yupw,nupw)
         first = .false.
      endif
c
      if (fbody.gt. 0.) then
         do 1810 i=1,nupw
            if (x .lt. xupw(i)) go to 1820
 1810    continue
         write(6,*) 'error in fbody...  upper wall'
         write(6,*) '   xupw doesn"t go far enough.'
         write(6,*) '   try increasing h in p18'
 1820    continue
         if (i.eq.1) i = 2
c     # use linear interp between points i-1 and i to get y on wall:
         yw = yupw(i-1) + (x-xupw(i-1)) * (yupw(i)-yupw(i-1))/
     &        (xupw(i)-xupw(i-1))
         if (y.gt.yw) fbody = -1.d0
      endif
      return
c
 19   continue
c
c  supersonic vortex  in circular channel.  inner radius r1, outer r2.
c  center of circles at the origin
c
      r1 = 1.d0
c     r2 = 1.50
      r2 = 1.3820
      fbody = -1.d0
c     r = dsqrt(x**2 + y**2)
      rsq = (x**2 + y**2)
c     if (x .lt. 0.d0) then
c        if (y .gt. r1 .and. y .lt. r2) fbody = 1.0d0
c      else if (y .lt. 0.d0) then
c        if (x .gt. r1 .and. x .lt. r2) fbody = 1.0d0
c      else if (r.ge.r1 .and. r.le.r2) then
c        fbody = 1.d0
c      endif
c     if (r .ge. r1 .and. r .le. r2) fbody = 1.d0
      if (rsq .ge. r1*r1 .and. rsq .le. r2*r2) fbody = 1.d0

      return

 20   continue
c
c  annulus, as in 1d irregular grid paper. need to shift since
c  code assumes lower left corner of domain is origin
c  but paper has center of circle at the origin
c
      xshift = 1.50
      yshift = 1.50  ! in case want to break symmetry
      r1 = .75d0
      r2 = 1.25d0
      fbody = -1.d0
      xuse = x - xshift
      yuse = y - yshift
      rsq = (xuse**2 + yuse**2)
      if (rsq .ge. r1*r1 .and. rsq .le. r2*r2) fbody = 1.d0
c
c stick problem 16 into prob 20 but with fixed velocity and 1 variable
c      if ((y .ge. .1*x+.11) .and. (y .le. .1*x+.81)) then
c       fbody = 1.0d0
c      else
c       fbody = -1.d0
c      endif

      return

 21   continue
c     # 30 degree ramp: starts ta x=.5 has BAD CELL BLOWING UP
      xwall = 1.d0/6.d0
      ywall = (3.-xwall)*tan(30*pi/180)
      if (x .lt. xwall) then
         if (y .gt.0.d0) then
             fbody = 1.d0
         else
             fbody = -1.d0
         endif
      else
        slope = (ywall - 0.d0)/(3.00d0-xwall)
        ybndry = (x-xwall)*slope
        if (y .ge. ybndry) then
           fbody = 1.d0
        else
           fbody = -1.d0
        endif
      endif
      return

 31   continue
      fbody = 1.d0
!      R1 = 1.00d0
!      R2 = 1.384d0
!      if(   (x**2 +y**2  < R1**2)
!     . .or. (x**2 +y**2  > R2**2) ) then
!            fbody = -1.d0
!      endif
      return
 32   continue
      fbody = 1.d0
      ! best so far
      R1 = 0.759d0
      R2 = 1.251d0
      rp = 0.25d0
      np = 10

      theta = atan2(y,x)
      R = dsqrt( x**2 + y**2 )
      if(   x**2 + y**2  < (R1+rp*sin(np*theta))**2
     . .or. x**2 + y**2  > (R2+rp*sin(np*theta))**2
     . .or. x+y < 0.25d0) then
            fbody = -1.d0
      endif

      return

      return

      end


!trying out fortran
program bookanalysis
implicit none
character(1024) :: buffer
character(50), dimension(53, 9) :: data_array
character(10) :: date_added, date_read
integer, dimension(3) :: date1, date2
integer :: day1, day2, i, j, pos, pos2, pages_read
integer, dimension(12) :: days_in_month
real :: read_speed

days_in_month = (/31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/)

open(10, file="books2016.csv")
open(11, file="fictionbooksreadbyday.csv")
open(12, file="nonfictionbooksreadbyday.csv")
open(13, file="technicalbooksreadbyday.csv")

read(10, *) !header

do i = 1, 52

	read(10,"(A)") buffer
 	do j = 1,9
		pos = index(buffer, ',')
        if(pos == 0) then
	   		pos = LEN(buffer)
		end if
        data_array(i, j) =  buffer( : pos)
        buffer = buffer(pos + 1: )
	end do

	date_added = data_array(i, 8)
    date_read = data_array(i, 7)

	print *, date_added
    print *, date_read

	do j = 1,2
		pos = index(date_added, '/')
        read(date_added( : pos - 1),*)date1(j)
        date_added = date_added(pos + 1: )

        pos2 = index(date_read, '/')
        read(date_read( : pos2 - 1),*)date2(j)
        date_read = date_read(pos2 + 1: )
    end do

    ! calculate length in days
  	day1 = date1(1)
    day2 = date2(1)

    do j = 1, (date1(2) - 1)
		day1 = day1 + days_in_month(j)
    end do

    do j = 1, (date2(2) - 1)
		day2 = day2 + days_in_month(j)
    end do

	read(data_array(i, 4),*)pages_read

    print *, day1, ",", day2, ",", pages_read

    read_speed = pages_read / (1  + day2 - day1)

	if("Fiction" == trim(data_array(i,9))) then
		write(11,*) day2, ",", read_speed
    else if("Technical" == trim(data_array(i,9))) then
      	write(13,*) day2, ",", read_speed
	else
		write(12,*) day2, ",", read_speed
    end if
end do

close(10)
close(11)
close(12)
close(13)

end program bookanalysis

!http://www.moreisdifferent.com/2015/07/16/why-physicsts-still-use-fortran/
!http://www.fortrantutorial.com/


MODULE m_shadow

! ----------------------------------------------------------------------
! MODULE: m_shadow
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the m_shadow subroutine
! ----------------------------------------------------------------------
! Author :      Dr. Tzupang Tseng, Geosceince Australia, Australia
!
!
! Created:      16-04-2019
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE shadow ( r_sat, r_sun, r_moon, lambda, ECLTYP )

! ----------------------------------------------------------------------
! SUBROUTINE: shadow.f90
! ----------------------------------------------------------------------
! Purpose:
! This subrutine is used to compute the coefficient for scaling the solar radiation pressure
! from penumbra to umbra. The concept of this model is to use the ratio of the celestial radius
! over the distance (the celestial to the satellite) as a threshold for the eclipsing judgement.
! Such a ratio forms an apparent angle (in radian) viewed from the satellite.
! By comparing with different apparent angles as viewed from the satellite, the satellite can be
! judged in the sun light, penumbra or umbra.
!
! This concept can be easily understood through three illustrations: a sideview,
! a look-down view from the satellite and a sideview of the vector yy.
! ----------------------------------------------------------------------
! Input arguments:
! - r_sat        : satellite position vector (m)
! - r_sun        : Sun position vector wrt the earth
! - r_moon       : Moon position vector wrt the earth
!
! Output arguments:
! - lambda       : Coefficient for scaling the SRP-induced acceleration acting
!                  on the eclipsed GNSS satellites
!
!                  lambda = 1     : In SUN LIGHT AREA
!                         = 0     : In UMBRA AREA (full eclipse)
!                  0 < lambda < 1 : In PENUMBRA AREA
!- ECLTYP        : ECLIPSE TYPE = 'E' : eclipsed by the earth shadow
!                                 'M' : eclipsed by the moon  shadow
!                                 ' ' : no eclipse
!
! ----------------------------------------------------------------------
! Author :	Dr. Tzupang Tseng
!
! Created:	16-04-2019
!
! Changes:      Simon McClusky 19/06/2019 (Fixed bug in lunar eclipse logic)
!
! Copyright:  GEOSCIENCE AUSTRALIA
! ----------------------------------------------------------------------
      USE mdl_precision
      USE mdl_num
      USE mdl_param
      USE m_get_lambda
      IMPLICIT NONE

! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(3),INTENT(IN) :: r_sat,r_moon
      REAL (KIND = prec_q), DIMENSION(3),INTENT(IN) :: r_sun
      REAL (KIND = prec_q), INTENT(OUT) :: lambda

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      CHARACTER (KIND = 1) :: ECLTYP
      REAL (KIND = prec_q) :: sunrad, moonrad, ertrad
      REAL (KIND = prec_q) :: Dsun, Dmoonsun
      REAL (KIND = prec_q) :: Ds,sclfa
      REAL (KIND = prec_q) :: AB, CD
      REAL (KIND = prec_q) :: rp, rs, xx
      REAL (KIND = prec_q), DIMENSION(3) :: ud
      REAL (KIND = prec_q), DIMENSION(3) :: yy
      REAL (KIND = prec_q), DIMENSION(3) :: Rmoonsun, Rsatmoon
      INTEGER              :: i,j,k
      INTEGER (KIND = 4) :: idbprt,idebug

! ----------------------------------------------------------------------
! Numerical Constants
! ----------------------------------------------------------------------
sunrad = Sun_radius
moonrad = Moon_radius
ertrad = Earth_Radius
lambda = 1.0d0
ECLTYP = ' '

! ---------------------------------------------------------------------
! The distance between the Earth and Sun
Dsun = norm2(r_sun)

! The distance between the Satellite and the Sun
Ds = norm2(r_sun - r_sat)

! The unit vector of the satellite wrt the sun (SUN->SAT)
ud=(r_sat-r_sun)/Ds

! Check if an Earth  Eclipse is possible. Ie satellite is in the sunlit area?
IF (Ds .gt. Dsun) THEN

! Project the satellite position vector onto the unit vector SUN->SAT
   AB = dot_product(r_sat,ud)

! A vector resulted from the cross product of the position vector EARTH->SAT and the unit vector SUN->SAT

   CALL productcross(r_sat,ud,yy)

! rs  : apparent angle of sun as viewed from satellite (radians)
! rp  : apparent angle of eclipsing body as viewed from satellite (radians)
! xx  : apparent separation of the center of the Sun and eclipsing body (radians)
!     rs+rp <= xx : no eclipse
!
!     rp-rs >= xx : full eclipse

   xx = norm2(yy)/AB
   rs=sunrad/Ds
   rp=ertrad/AB

! Check the earth shadow

   CALL get_lambda(rs, rp, xx, lambda, idbprt, idebug)

   IF (lambda .lt. 1.0d0) THEN
      ECLTYP = 'E'
!     PRINT*,' ECLTYP =  ', ECLTYP
      RETURN
   ENDIF

ENDIF

! Now check if a lunar eclipse is possible? Ie is the moon closer to the Sun than the Satellite?
Rmoonsun = r_moon - r_sun
Rsatmoon = r_sat - r_moon

!Dmoonsun = dsqrt(Rmoonsun(1)**2+Rmoonsun(2)**2+Rmoonsun(3)**2)
Dmoonsun = norm2(Rmoonsun)

IF (Ds .gt. Dmoonsun) THEN

   CD = dot_product(Rsatmoon,ud)
   CALL productcross (Rsatmoon,ud,yy)
   xx=norm2(yy)/CD

   rs=sunrad/Ds
   rp=moonrad/CD

   CALL get_lambda(rs, rp, xx, lambda, idbprt, idebug)

   IF( lambda.lt.1.d0 ) THEN
      ECLTYP = 'M'
!     PRINT*,' ECLTYP =  ', ECLTYP
      RETURN
   ENDIF

END IF

END SUBROUTINE

END MODULE