!>------------------------------------------------------------
!!  date / time module
!!
!!  Defines a Time_type object
!!
!!  Contains various utilities for working with dates and times.
!!  Utilities are capable of handling multiple model calendars.
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!------------------------------------------------------------
submodule(time_object) time_implementation
    use co_util,           only : broadcast

    implicit none

    ! integer, parameter :: MAXSTRINGLENGTH = 1024
    ! integer, parameter, public :: GREGORIAN=0, NOLEAP=1, THREESIXTY=2, NOCALENDAR=-1
    ! integer, parameter, public :: NON_VALID_YEAR = -9999

contains

    !>------------------------------------------------------------
    !!  Initialize the time object
    !!
    !!  Set the object calendar and base year
    !!
    !!------------------------------------------------------------
    module subroutine time_init_c(this, calendar_name, year_zero, month_zero, day_zero, hour_zero)
        implicit none
        class(Time_type) :: this
        character(len=*), intent(in) :: calendar_name
        integer, intent(in), optional :: year_zero, month_zero, day_zero, hour_zero

        integer :: i

        ! zero based month_starts (will have 1 added below)
        this%month_start = [0,31,59,90,120,151,181,212,243,273,304,334,365]

        call this%set_calendar(calendar_name)

        if (this%calendar == THREESIXTY) then
            do i=0,12
                this%month_start(i+1) = i*30
            end do
        endif

        this%month_start = this%month_start + 1

        if ( present(year_zero) ) then
            this%year_zero = year_zero
        endif
        if ( present(month_zero) ) then
            this%month_zero = month_zero
        endif
        if ( present(day_zero) ) then
            this%day_zero = day_zero
        endif
        if ( present(hour_zero) ) then
            this%hour_zero = hour_zero
        endif

    end subroutine time_init_c

    !>------------------------------------------------------------
    !!  Initialize the time object
    !!
    !!  Set the object calendar and base year
    !!
    !!------------------------------------------------------------
    module subroutine time_init_i(this, calendar, year_zero, month_zero, day_zero, hour_zero)
        implicit none
        class(Time_type) :: this
        integer, intent(in) :: calendar
        integer, intent(in), optional :: year_zero, month_zero, day_zero, hour_zero

        integer :: i

        ! zero based month_starts (will have 1 added below)
        this%month_start = [0,31,59,90,120,151,181,212,243,273,304,334,365]

        this%calendar = calendar

        if (this%calendar == THREESIXTY) then
            do i=0,12
                this%month_start(i+1) = i*30
            end do
        endif

        this%month_start = this%month_start + 1

        if ( present(year_zero) ) then
            this%year_zero = year_zero
        endif
        if ( present(month_zero) ) then
            this%month_zero = month_zero
        endif
        if ( present(day_zero) ) then
            this%day_zero = day_zero
        endif
        if ( present(hour_zero) ) then
            this%hour_zero = hour_zero
        endif

    end subroutine time_init_i

    !>------------------------------------------------------------
    !!  Set the calendar from a given name
    !!
    !!  Looks at a calendar_name string to identify matches to known calendars
    !!  Known calendars are : 'gregorian', 'standard', '365-day', 'noleap', '360-day'
    !!  But only the first 5 characters are required.
    !!
    !!  Sets the object calendar attribute.
    !!
    !!------------------------------------------------------------
    module subroutine set_calendar(this, calendar_name)
        implicit none
        class(Time_type) :: this
        character(len=*), intent(in) :: calendar_name

        this%calendar = NOCALENDAR

        select case (trim(calendar_name))
            case("proleptic_gregorian")
                this%calendar = GREGORIAN
            case("gregorian")
                this%calendar = GREGORIAN
            case("standard")
                this%calendar = GREGORIAN
            case("365-day")
                this%calendar = NOLEAP
            case("365_day")
                this%calendar = NOLEAP
            case("noleap")
                this%calendar = NOLEAP
            case("360-day")
                this%calendar = THREESIXTY
            case("360_day")
                this%calendar = THREESIXTY
            case default
                this%calendar = NOCALENDAR
        end select

        if (this%calendar==NOCALENDAR) then
            ! in case there are odd characters tacked on the end (as seems to happen with some netcdf files?)
            select case (trim(calendar_name(1:5)))
                case("prole")
                    this%calendar = GREGORIAN
                case("grego")
                    this%calendar = GREGORIAN
                case("stand")
                    this%calendar = GREGORIAN
                case("365-d")
                    this%calendar = NOLEAP
                case("365_d")
                    this%calendar = NOLEAP
                case("nolea")
                    this%calendar = NOLEAP
                case("360-d")
                    this%calendar = THREESIXTY
                case("360_d")
                    this%calendar = THREESIXTY
                case default
                    write(*,*) "Unknown Calendar: '", trim(calendar_name),"'"
                    write(*,*) "Acceptable names = "
                    write(*,*) "  'gregorian', 'standard', '365-day', '365_day', 'noleap', '360-day', '360_day'"
                    write(*,*) " "
                    stop
            end select
        endif

    end subroutine set_calendar

    !>------------------------------------------------------------
    !!  Return the current date number (seconds since reference time)
    !!
    !!  For a gregorian calendar, if no year is specified, this will be
    !!  a modified Julian day (*86400).  For all other calendars it will be
    !!  seconds since startyear/startmonth/startday
    !!
    !!------------------------------------------------------------
    module function get_seconds(this) result(seconds)
        implicit none
        class(Time_type) :: this
        double precision :: seconds

        seconds = this%current_date_time * 86400.0D0
    end function get_seconds

    !>------------------------------------------------------------
    !!  Return the current date number (days since initial year)
    !!
    !!  For a gregorian calendar, if no year is specified, this will be
    !!  a modified Julian day.  For all other calendars it will be days since 0-1-1
    !!
    !!------------------------------------------------------------
    module function get_mjd(this) result(mjd)
        implicit none
        class(Time_type) :: this
        double precision :: mjd

        mjd = this%current_date_time
    end function get_mjd

    !>------------------------------------------------------------
    !!  Calcualte the julian day number corresponding to a given year, month and day
    !!  in a gregorian calendar
    !!
    !!   Algorithm from Wikipedia: http://en.wikipedia.org/wiki/Julian_day
    !!   originally from Richards, E. G. (2013). Calendars. In S. E. Urban & P. K. Seidelmann, eds.
    !!                   Explanatory Supplement to the Astronomical Almanac, 3rd ed. (pp. 585–624).
    !!                   Mill Valley, Calif.: University Science Books. ISBN 978-1-89138-985-6
    !!                   p617-9
    !!
    !!------------------------------------------------------------
    function gregorian_julian_day(year, month, day, hour, minute, second) result(julian_day)
        implicit none
        integer, intent(in) :: year, month, day, hour, minute, second
        double precision :: julian_day
        double precision :: d,m,y
        integer :: a,b

        a = (14-month)/12
        y = year+4800-a
        m = month+12*a-3

        ! Gregorian calendar
        b = day + floor((153*m+2)/5) + 365*y + floor(y/4) - floor(y/100) + floor(y/400) - 32045

        ! Julian calendar
        ! b = day + floor(153*m+2/5) + 365*y + floor(y/4) - 32083

        julian_day = b + (((second/60d+0)+minute)/60d+0 + hour-12)/24.0

    end function

    !>------------------------------------------------------------
    !!  Convert a Year, Month, Day, hour, minute, second into a single number
    !!
    !!  This number will be a Modified Julian Day for the default gregorian calendar
    !!  or it will be a number of days since whatever the initial year was
    !!
    !!------------------------------------------------------------
    module function date_to_mjd(this, year, month, day, hour, minute, second)
        implicit none
        class(Time_type), intent(in) :: this
        integer, intent(in) :: year, month, day, hour, minute, second
        double precision :: date_to_mjd

        if (this%calendar==GREGORIAN) then
            date_to_mjd = gregorian_julian_day(year, month, day, hour, minute, second)

            date_to_mjd = date_to_mjd - gregorian_julian_day(this%year_zero, this%month_zero, this%day_zero, this%hour_zero, 0, 0)

        else if (this%calendar==NOLEAP) then
            date_to_mjd = (year*365 + this%month_start(month)-1 + day-1 + (hour + (minute+second/60d+0)/60d+0)/24d+0) &
                         - (this%year_zero*365 + this%month_start(this%month_zero)-1 + this%day_zero-1 + (this%hour_zero)/24d+0)
        else if (this%calendar==THREESIXTY) then
            date_to_mjd = (year*360 + this%month_start(month)-1 + day-1 + (hour + (minute+second/60d+0)/60d+0)/24d+0) &
                         - (this%year_zero*360 + this%month_start(this%month_zero)-1 + this%day_zero-1 + (this%hour_zero)/24d+0)
        end if

    end function date_to_mjd

    !>------------------------------------------------------------
    !!  Calculate the year, month, day, hour, minute second for the current date_time object
    !!
    !!  Y, M, D, h, m, s are modified on return
    !!  arguably, seconds should be a real number, not an integer...
    !!
    !!------------------------------------------------------------
    module subroutine calendar_date(this, year, month, day, hour, minute, second)
        implicit none
        class(Time_type), intent(in) :: this
        integer, intent(out) :: year, month, day, hour, minute, second

        integer :: y=4716,j=1401,m=2,n=12,r=4,p=1461
        integer :: v=3,u=5,s=153,w=2,B=274277,C=-38
        integer ::f,e,g,h, jday
        double precision :: day_fraction, mjd

        mjd = this%current_date_time+1d-5 ! add less than one second

        !------------------------------------------------------------
        !
        ! Calculate the dates for a Gregorian Calendar
        !
        !------------------------------------------------------------
        if (this%calendar==GREGORIAN) then
            mjd = mjd + gregorian_julian_day(this%year_zero, this%month_zero, this%day_zero, this%hour_zero, 0, 0)
            jday=nint(mjd)

            f = jday+j+(((4*jday+B)/146097)*3)/4+C
            e = r*f+v
            g = mod(e,p)/r
            h = u*g+w
            day   = mod(h,s)/u+1
            month = mod(h/s+m,n)+1
            year  = e/p-y+(n+m-month)/n
            mjd = mjd + 0.5
        !------------------------------------------------------------
        !
        ! Calculate the dates for a No leap Calendar
        !
        !------------------------------------------------------------
        else if (this%calendar==NOLEAP) then

            year = floor((mjd + (this%month_start(this%month_zero)-1) + (this%day_zero-1) + this%hour_zero/24.0) / 365)
            day_fraction = mjd - year*365+1 + (this%month_start(this%month_zero)-1) + (this%day_zero-1) + this%hour_zero/24.0
            month = 1
            do f=1,12
                if (day_fraction >this%month_start(f)) then
                    month = f
                endif
            end do
            day = floor(day_fraction - this%month_start(month))+1
            year = year + this%year_zero
            mjd = mjd + this%hour_zero/24.0
        !------------------------------------------------------------
        !
        ! Calculate the dates for a 360-day Calendar
        !
        !------------------------------------------------------------
        else if (this%calendar==THREESIXTY) then
            year = floor((mjd + (this%month_zero-1) * 30 + (this%day_zero-1) + this%hour_zero/24.0) / 360)
            day_fraction = mjd - year*360+1 + (this%month_zero-1) * 30 + (this%day_zero-1) + this%hour_zero/24.0
            month = 1
            do f=1,12
                if (day_fraction > this%month_start(f)) then
                    month = f
                endif
            end do

            day = floor(day_fraction - this%month_start(month)) + 1
            year = year + this%year_zero
            mjd = mjd + this%hour_zero/24.0
        end if

        !------------------------------------------------------------
        !
        ! Calculate the hour/minute/second for any calendar
        !
        !------------------------------------------------------------
        day_fraction = mod(mjd, 1.0)
        hour = floor(day_fraction * 24)

        day_fraction = day_fraction * 24 - hour
        minute = floor(day_fraction * 60)

        day_fraction = day_fraction * 60 - minute
        second = nint((day_fraction - (24d0*60*1d-5)) * 60)

    end subroutine calendar_date

    !>------------------------------------------------------------
    !!  Return the day of the year corresponding to the current date_time
    !!
    !!  Calculate the day of the year from a "modified julian day" or other days since date
    !!
    !!------------------------------------------------------------
    module function calc_day_of_year(this, lon)
        implicit none
        real                        :: calc_day_of_year
        class(Time_type), intent(in):: this
        real,             intent(in), optional :: lon

        real :: offset
        integer :: year, month, day, hour, minute, second

        offset = 0
        if (present(lon)) then
            if (lon>180) then
                offset = (lon-360) / 360.0
            else
                offset = lon / 360.0
            endif
        endif

        call this%date(year, month, day, hour, minute, second)

        calc_day_of_year = this%current_date_time - this%date_to_mjd(year, 1,1,0,0,0) + offset

    end function calc_day_of_year

    !>------------------------------------------------------------
    !!  Return the fractional way through the year corresponding to the current date_time
    !!
    !!  "Jan  1, 00:00" is 0
    !!  "Dec 31, 24:00" is 1.0
    !!
    !!------------------------------------------------------------
    module function calc_year_fraction(this, lon)
        implicit none
        real                        :: calc_year_fraction
        class(Time_type)            :: this
        real, intent(in), optional  :: lon

        real :: offset
        double precision :: year_start

        integer :: year, month, day, hour, minute, second

        offset = 0

        if (this%calendar==GREGORIAN) then
            call this%date(year, month, day, hour, minute, second)
            year_start = this%date_to_mjd(year, 1,1,0,0,0)

            if (present(lon)) then
                if (lon>180) then
                    offset = (lon-360) / 360.0
                else
                    offset = lon / 360.0
                endif
            endif

            calc_year_fraction = (this%mjd() + offset - year_start) / (this%date_to_mjd(year+1, 1,1,0,0,0) - year_start)

        else if (this%calendar==NOLEAP) then
            if (present(lon)) then
                calc_year_fraction = this%day_of_year(lon) / 365.0
            else
                calc_year_fraction = this%day_of_year() / 365.0
            endif
        else if (this%calendar==THREESIXTY) then
            if (present(lon)) then
                calc_year_fraction = this%day_of_year(lon) / 360.0
            else
                calc_year_fraction = this%day_of_year() / 360.0
            endif
        endif

        ! necessary in case lon is between 0 and 180
        calc_year_fraction = mod(calc_year_fraction, 1.0)

    end function calc_year_fraction

    !>------------------------------------------------------------
    !!  Set the current date based on an input string
    !!
    !!  Convert an input date string in the form YYYY/MM/DD or YYYY/MM/DD hh:mm:ss
    !!
    !!------------------------------------------------------------
    module subroutine set_from_string(this, date)
        implicit none
        class(Time_type), intent(inout) :: this
        character (len=*), intent(in) :: date

        read(date(1:4), *) this%year
        read(date(6:7), *) this%month
        read(date(9:10),*) this%day

        if(len_trim(date) <= 18) then
            this%second  = 0
            this%minute  = 0
            this%hour    = 0
        else
            read(date(12:13), *) this%hour
            read(date(15:16), *) this%minute
            read(date(18:19), *) this%second
        endif

        this%current_date_time = this%date_to_mjd(this%year, this%month, this%day, this%hour, this%minute, this%second)
    end subroutine set_from_string

    !>------------------------------------------------------------
    !!  Set the current date based on an input set of integer date components
    !!
    !!  Set the datetime object to a given input date (Year, Month, Day, Hour, Minute, second)
    !!
    !!------------------------------------------------------------
    module subroutine set_from_date(this, year, month, day, hour, minute, second)
        implicit none
        class(Time_type), intent(inout) :: this
        integer, intent(in) :: year, month, day
        integer, intent(in), optional :: hour, minute, second
        integer :: set_hour, set_minute, set_second

        set_hour=0; set_minute=0; set_second=0
        if (present(hour))   set_hour = hour
        if (present(minute)) set_minute = minute
        if (present(second)) set_second = second

        this%current_date_time = this%date_to_mjd(year, month, day, set_hour, set_minute, set_second)
        this%year   = year
        this%month  = month
        this%day    = day
        this%hour   = set_hour
        this%minute = set_minute
        this%second = set_second

    end subroutine set_from_date

    !>------------------------------------------------------------
    !!  Set the current date based on an input day number (e.g. Modified Julian day)
    !!
    !!  Set the datetime object to a given input datetime number
    !!
    !!------------------------------------------------------------
    module subroutine set_from_mjd(this, days)
        implicit none
        class(Time_type), intent(inout) :: this
        double precision, intent(in) :: days
        integer :: year, month, day, hour, minute, second

        this%current_date_time = days

        call this%date(year, month, day, hour, minute, second)
        this%year   = year
        this%month  = month
        this%day    = day
        this%hour   = hour
        this%minute = minute
        this%second = second

    end subroutine set_from_mjd

    !>------------------------------------------------------------
    !!  Create a formated "units" string for this object
    !!
    !!  For example "days since 1858-11-17 00:00:00"
    !!
    !!------------------------------------------------------------
    module function units(this)
        implicit none
        class(Time_type), intent(in)   :: this
        character(len=MAXSTRINGLENGTH) :: units

        write(units, '("days since ",i4,"-",i2.2,"-",i2.2," ",i2.2,":00:00")') &
                this%year_zero,this%month_zero,this%day_zero,this%hour_zero

    end function units

    module subroutine bcast(this, source, first_image, last_image)
        implicit none
        class(Time_type), intent(inout) :: this
        integer,          intent(in)    :: source
        integer,          intent(in)    :: first_image
        integer,          intent(in)    :: last_image

        integer, allocatable :: as_array(:)[:]
        allocate(as_array(10)[*])

        as_array(1) = this%year_zero
        as_array(2) = this%month_zero
        as_array(3) = this%day_zero
        as_array(4) = this%calendar
        as_array(5) = this%year
        as_array(6) = this%month
        as_array(7) = this%day
        as_array(8) = this%hour
        as_array(9) = this%minute
        as_array(10)= this%second

        call broadcast(as_array, source, first_image, last_image)

        if (this_image() /= source) then
            call this%init(as_array(4), as_array(1), as_array(2), as_array(3))

            call this%set_from_date(as_array(5), as_array(6), as_array(7), as_array(8), as_array(9), as_array(10))
        endif

    end subroutine

    !>------------------------------------------------------------
    !!  Convert the date object into a string in the 0-filled format : "YYYY/MM/DD hh:mm:ss"
    !!
    !!------------------------------------------------------------
    module function as_string(this, input_format) result(pretty_string)
        implicit none
        class(Time_type), intent(in) :: this
        character(len=*), intent(in), optional :: input_format
        character(len=MAXSTRINGLENGTH) :: pretty_string
        character(len=MAXSTRINGLENGTH) :: format
        integer :: i

        associate(year  => this%year,   &
                  month => this%month,  &
                  day   => this%day,    &
                  hour  => this%hour,   &
                  minute=> this%minute, &
                  second=> this%second  &
                  )

        if (present(input_format)) then
            format = input_format
        else
            ! this is the default format string to generate "YYYY/MM/DD hh:mm:ss"
            format = '(I4,"/",I0.2,"/",I0.2," ",I0.2,":",I0.2,":",I0.2)'
        endif

        ! this and the format statement above are the important bits
        write(pretty_string, format) year, month, day, hour, minute, second

        end associate

    end function as_string

    !>------------------------------------------------------------
    !!  Test that time 1 is greater than time 2
    !!
    !!  Used to implement the [>] operator
    !!  If the two input times have the same refernce calender, it just returns
    !!  > on the internal time representation between the two
    !!  Otherwise it retrieves the year, month, day, ... from both and checks for
    !!  > on all elements sequentially (year, then month, then day...)
    !!
    !!------------------------------------------------------------
    module function greater_than(t1, t2)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        logical :: greater_than

        greater_than = .False.

        ! note if calendars are the same, can just return mjd delta...
        if ((t1%calendar == t2%calendar).and.(t1%year_zero == t2%year_zero)) then
            if ((t1%month_zero == t2%month_zero).and.(t1%day_zero == t2%day_zero).and.(t1%hour_zero == t2%hour_zero))  then
                greater_than = (t1%current_date_time > t2%current_date_time)
                return
            endif
        endif

        if (t1%year > t2%year) then
            greater_than = .True.
        else if (t1%year == t2%year) then
            if (t1%month > t2%month) then
                greater_than = .True.
            else if (t1%month == t2%month) then
                if (t1%day > t2%day) then
                    greater_than = .True.
                else if (t1%day == t2%day) then
                    if (t1%hour > t2%hour) then
                        greater_than = .True.
                    else if (t1%hour == t2%hour) then
                        if (t1%minute > t2%minute) then
                            greater_than = .True.
                        else if (t1%minute == t2%minute) then
                            if (t1%second > t2%second) then
                                greater_than = .True.
                            else if (t1%second == t2%second) then
                                greater_than = .False.
                            endif
                        endif
                    endif
                endif
            endif
        endif

    end function greater_than

    !>------------------------------------------------------------
    !!  Test that time 1 is greater than or equal to time 2
    !!
    !!  Used to implement the [>=] operator
    !!  If the two input times have the same refernce calender, it just returns
    !!  >= on the internal time representation between the two
    !!  Otherwise it retrieves the year, month, day, ... from both and checks for
    !!  >= on all elements sequentially (year, then month, then day...)
    !!
    !!------------------------------------------------------------
    module function greater_or_eq(t1, t2)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        logical :: greater_or_eq

        greater_or_eq = .False.

        ! note if calendars are the same, can just return mjd delta...
        if ((t1%calendar == t2%calendar).and.(t1%year_zero == t2%year_zero)) then
            if ((t1%month_zero == t2%month_zero).and.(t1%day_zero == t2%day_zero).and.(t1%hour_zero == t2%hour_zero))  then
                greater_or_eq = (t1%current_date_time >= t2%current_date_time)
                return
            endif
        endif

        if (t1%year > t2%year) then
            greater_or_eq = .True.
        else if (t1%year == t2%year) then
            if (t1%month > t2%month) then
                greater_or_eq = .True.
            else if (t1%month == t2%month) then
                if (t1%day > t2%day) then
                    greater_or_eq = .True.
                else if (t1%day == t2%day) then
                    if (t1%hour > t2%hour) then
                        greater_or_eq = .True.
                    else if (t1%hour == t2%hour) then
                        if (t1%minute > t2%minute) then
                            greater_or_eq = .True.
                        else if (t1%minute == t2%minute) then
                            if (t1%second >= t2%second) then
                                greater_or_eq = .True.
                            endif
                        endif
                    endif
                endif
            endif
        endif

    end function greater_or_eq

    !>------------------------------------------------------------
    !!  Test that time 1 is equal to time 2
    !!
    !!  Used to implement the [==] operator
    !!  If the two input times have the same refernce calender, it just returns
    !!  == on the internal time representation between the two
    !!  Otherwise it retrieves the year, month, day, ... from both and checks for
    !!  equality on all elements
    !!
    !!------------------------------------------------------------
    module function equal(t1, t2)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        logical :: equal

        equal = .False.
        ! note if calendars are the same, can just return mjd delta...
        if ((t1%calendar == t2%calendar).and.(t1%year_zero == t2%year_zero)) then
            if ((t1%month_zero == t2%month_zero).and.(t1%day_zero == t2%day_zero).and.(t1%hour_zero == t2%hour_zero))  then
                equal = (abs(t1%current_date_time - t2%current_date_time) < 1.1575e-05)
                return
            endif
        endif

        if ((t1%year == t2%year).and.(t1%month == t2%month).and.(t1%day == t2%day)      &
            .and.(t1%hour == t2%hour).and.(t1%minute == t2%minute).and.(t1%second == t2%second)) then
            equal = .True.
        endif

    end function equal

    !>------------------------------------------------------------
    !!  Test that time 1 is not equal to time 2
    !!
    !!  Used to implement the [/=] operator
    !!  Simply returns not ==
    !!
    !!------------------------------------------------------------
    module function not_equal(t1, t2)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        logical :: not_equal

        not_equal = .not.equal(t1,t2)

    end function not_equal

    !>------------------------------------------------------------
    !!  Test that time 1 is less than or equal to time 2
    !!
    !!  Used to implement the [<=] operator
    !!  Simply returns not >
    !!
    !!------------------------------------------------------------
    module function less_or_eq(t1, t2)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        logical :: less_or_eq

        less_or_eq = .not.greater_than(t1,t2)

    end function less_or_eq

    !>------------------------------------------------------------
    !!  Test that time 1 is less than time 2
    !!
    !!  Used to implement the [<] operator
    !!  Simply returns not >=
    !!
    !!------------------------------------------------------------
    module function less_than(t1, t2)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        logical :: less_than

        less_than = .not.greater_or_eq(t1,t2)

    end function less_than

    !>------------------------------------------------------------
    !!  Compare that two time objects are equal to within a specified precision
    !!
    !!  If precision is not specified, just returns the == operator result
    !!  If precision is specified, returns true if abs(t1-t2) <= precision
    !!
    !!------------------------------------------------------------
    module function equals_with_precision(t1,t2, precision) result(equals)
        implicit none
        class(Time_type),    intent(in) :: t1, t2
        type(time_delta_t),  intent(in), optional :: precision
        logical :: equals
        type(time_delta_t) :: dt

        if (.not.present(precision)) then
            equals = (t1%equal(t2))
        else
            dt = t1 - t2
            equals = abs(dt%seconds()) <= precision%seconds()
        endif

    end function equals_with_precision

    !>------------------------------------------------------------
    !!  Subtract two times and return a time_delta object
    !!
    !!------------------------------------------------------------
    module function difference(t1, t2) result(dt)
        implicit none
        class(Time_type), intent(in) :: t1, t2
        type(time_delta_t) :: dt

        type(Time_type) :: temp_time
        integer :: year, month, day, hour, minute, second

        if (((t1%calendar == t2%calendar).and.(t1%year_zero == t2%year_zero)) &
            .and.((t1%month_zero == t2%month_zero).and.(t1%day_zero == t2%day_zero).and.(t1%hour_zero == t2%hour_zero))) then

            call dt%set(seconds=(t1%mjd() - t2%mjd()) * 86400.0D0)
        else
            ! if the two time object reference calendars don't match
            ! create a new time object with the same referecnce as t1
            ! then copy the date/time data into it from t2 before computing the time delta
            call temp_time%init(t1%calendar,t1%year_zero,t1%month_zero,t1%day_zero, t1%hour_zero)
            call t2%date(year, month, day, hour, minute, second)
            call temp_time%set(year, month, day, hour, minute, second)

            call dt%set(seconds=((t1%mjd() - temp_time%mjd()) * 86400.0D0))
        endif

    end function difference

    !>------------------------------------------------------------
    !!  Add a given time delta to a time object
    !!
    !!  returns a new time object
    !!
    !!------------------------------------------------------------
    module function addition(t1, dt) result(t2)
        implicit none
        class(Time_type),   intent(in) :: t1
        type(time_delta_t), intent(in) :: dt
        type(Time_type) :: t2

        t2 = t1 ! set calendar startyear, etc.

        call t2%set(t1%mjd() + dt%days())

    end function addition

end submodule time_implementation


*dk,find3to2
      subroutine find3to2(it1,ipos,it2,it3,id,jd,flag,
     *                    npoints,ntets)
C
C ######################################################################
C
C      PURPOSE -
C
C         This routine finds the tet pair corresponding to the
C         tet triplet with a common edge:
C            (i1,i2,i3,i4)
C            -------------
C            (i3,i4,i1,nodd)
C            (i4,i3,i2,nodd)   where i1-i2 denotes the common edge.
C
C      INPUT ARGUMENTS -
C
C         it1   - the first tet
C         ipos  - the position fo the common edge (1 - 6)
C
C      OUTPUT ARGUMENTS -
C
C         it2   - the tet number of the second member of the triplet
C         it3   - the tet number of the third member of the triplet
C         id    - the "itet" coordinates of the two new tets
C         jd    - the "jtet" coordinates of the two new tets
C         flag  - +1 ==>  flip is possible
C                  0 ==>  flip is not-possible
C
C     CHANGE HISTORY -
C
C        $Log: find3to2.f,v $
C        Revision 2.00  2007/11/05 19:45:55  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.8   05 Jan 2001 12:56:04   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.7   Tue Aug 18 16:26:04 1998   kuprat
CPVCS     Reduced diagnostic output if idebug<2.
CPVCS
CPVCS       Rev 1.6   Wed Jul 09 09:12:08 1997   dcg
CPVCS    make error checking more rigorous
CPVCS    add better diagnostics if idebug set
CPVCS
CPVCS       Rev 1.5   Mon Apr 14 16:48:02 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.4   08/30/95 21:09:18   het
CPVCS    Put cmo table data into the cmoatt storage block
CPVCS
CPVCS       Rev 1.3   12/02/94 15:05:00   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:46:40   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:50:50   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:12:08   pvcs
CPVCS    Original version.
C
C ######################################################################
C
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
C
C ######################################################################
C
C arguments it1,ipos,it2,it3,id,jd,flag,npoints,ntets
      integer it1,ipos,it2,it3,flag,npoints,ntets
      integer id(12),jd(12)

C variables

      integer i1,i2,i3,i4,i5
      integer ierror,ierrwrt,lenitet,icmotype,lenjtet,i,it,
     *        isum1,isum2,isum3,isum4,isum5,ict12,
     *        j,k,length,lenxic, lenyic,lenzic,ipos1,ipos2,ipos3,
     *        ipos4,ict345

      real*8 xst,xn,yn,zn,xa,ya,za,x3,y3,z3,x7,y7,z7,sn,s3,s7,
     *       dot1,dot2

C statement functions

      real*8 crosx1,crosy1,crosz1
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
C
C ######################################################################
C BEGIN begin
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
      call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C
C

      ipos1=ielist(4*ipos-3)
      ipos2=ielist(4*ipos-2)
      ipos3=ielist(4*ipos-1)
      ipos4=ielist(4*ipos  )
      it2=0.25*dble(jtet(ipos3,it1))+0.9
      it3=0.25*dble(jtet(ipos4,it1))+0.9
C
      i1=itet(ipos1,it1)
      i2=itet(ipos2,it1)
      i3=itet(ipos3,it1)
      i4=itet(ipos4,it1)
      i5=itet1(jtet(ipos4,it1))
C
      id(1)=i3
      id(2)=i4
      id(3)=i1
      id(4)=i5
      id(5)=i4
      id(6)=i3
      id(7)=i2
      id(8)=i5
C
      jd(3)=4*(it2-1)+3
      jd(4)=jtet(ipos2,it1)
      jd(7)=4*(it1-1)+3
      jd(8)=jtet(ipos1,it1)
C        "id(3)" and "id(7)" denote the previously common edge
      do 10 i=1,4
         if(itet(i,it2).eq.id(3)) jd(6)=jtet(i,it2)
         if(itet(i,it2).eq.id(7)) jd(1)=jtet(i,it2)
         if(itet(i,it3).eq.id(3)) jd(5)=jtet(i,it3)
         if(itet(i,it3).eq.id(7)) jd(2)=jtet(i,it3)
 10   continue
C
C     ******************************************************************
C
C     DETERMINE IF A 3-TO-2 FLIP IS POSSIBLE BY TESTING WHETHER THE
C     POINTS ON THE PREVIOUS COMMON EDGE (id(3)-id(7)) ARE ON OPPOSITE
C     SIDES OF THE POTENTIAL NEW FACE (id(1)-id(2)-id(4))
C
      xst=1.0e-9
      xn=crosx1(id(1),id(2),id(4))
      yn=crosy1(id(1),id(2),id(4))
      zn=crosz1(id(1),id(2),id(4))
      xa=xic(id(1))
      ya=yic(id(1))
      za=zic(id(1))
      x3=xic(id(3))-xa
      y3=yic(id(3))-ya
      z3=zic(id(3))-za
      x7=xic(id(7))-xa
      y7=yic(id(7))-ya
      z7=zic(id(7))-za
      sn=sqrt(xn*xn+yn*yn+zn*zn)
      s3=sqrt(x3*x3+y3*y3+z3*z3)
      s7=sqrt(x7*x7+y7*y7+z7*z7)
      dot1=xn*x3+yn*y3+zn*z3
      dot2=xn*x7+yn*y7+zn*z7
      flag=0.0
      if(dot1*dot2.lt.0.0.and.abs(dot1).ge.xst*sn*s3.and.
     *                        abs(dot2).ge.xst*sn*s7) flag=1.0
C
      if(idebug.ge.2) then
         ict12=0
         ict345=0
         do  it=1,ntets
            isum1=(itet(1,it)-i1)*(itet(2,it)-i1)*
     *            (itet(3,it)-i1)*(itet(4,it)-i1)
            isum2=(itet(1,it)-i2)*(itet(2,it)-i2)*
     *            (itet(3,it)-i2)*(itet(4,it)-i2)
            if(isum1.eq.0.and.isum2.eq.0.and.itet(1,it).gt.0)
     *               ict12=ict12+1
C
            isum3=(itet(1,it)-i3)*(itet(2,it)-i3)*
     *            (itet(3,it)-i3)*(itet(4,it)-i3)
            isum4=(itet(1,it)-i4)*(itet(2,it)-i4)*
     *            (itet(3,it)-i4)*(itet(4,it)-i4)
            isum5=(itet(1,it)-i5)*(itet(2,it)-i5)*
     *            (itet(3,it)-i5)*(itet(4,it)-i5)
            if(isum3.eq.0.and.isum4.eq.0.and.isum5.eq.0.and.
     *           itet(1,it).gt.0) ict345=ict345+1
         enddo
         if(ict12.ne.3) then
            write(logdan,9020) it1,it2,it3
            call writloga("default",0,logdan,0,ierrwrt)
            write(logdan,9030) i1,i2
            call writloga("default",0,logdan,0,ierrwrt)
 9020       format("find3to2 - LINE EXISTS MORE THAN THREE TIMES:"
     *             " it1=",i10," it2=",i10," it3=",i10)
 9030       format("          connection:     ",i10,"     ",i10)
 9001       format(' in tet ',i10)
            do  it=1,ntets
               isum1=(itet(1,it)-i1)*(itet(2,it)-i1)*
     *            (itet(3,it)-i1)*(itet(4,it)-i1)
               isum2=(itet(1,it)-i2)*(itet(2,it)-i2)*
     *            (itet(3,it)-i2)*(itet(4,it)-i2)
               if(isum1.eq.0.and.isum2.eq.0) then
                  write(logdan,9001) it
                  call writloga('default',0,logdan,0,ierrwrt)
               endif
            enddo
            flag=0.0
C*****      if(flag.ne.0) call rwdmpw
         endif
         if(ict345.ne.0) then
            write(logdan,9000) it1,it2,it3
            call writloga("default",0,logdan,0,ierrwrt)
            write(logdan,9010) i3,i4,i5
            call writloga("default",0,logdan,0,ierrwrt)
 9000       format("find3to2 - FACE EXISTS: it1=",i10," it2=",i10,
     *             " it3=",i10)
 9010       format("                face:     ",i10,"     ",i10,
     *             "     ",i10)
            do  it=1,ntets
               isum3=(itet(1,it)-i3)*(itet(2,it)-i3)*
     *            (itet(3,it)-i3)*(itet(4,it)-i3)
               isum4=(itet(1,it)-i4)*(itet(2,it)-i4)*
     *            (itet(3,it)-i4)*(itet(4,it)-i4)
               isum5=(itet(1,it)-i5)*(itet(2,it)-i5)*
     *            (itet(3,it)-i5)*(itet(4,it)-i5)
               if(isum3.eq.0.and.isum4.eq.0.and.isum5.eq.0) then
                  write(logdan,9001) it
                  call writloga('default',0,logdan,0,ierrwrt)
               endif
            enddo
            flag=0.0
C*****      if(flag.ne.0) call rwdmpw
         endif
      endif
      goto 9999
 9999 continue
      return
      end


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

!X
!X IPModel_CH4
!X
!% CH4 module for use when implementing a new Interatomic Potential
!%
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
#include "error.inc"

module IPModel_CH4_module

use error_module
use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//)
use dictionary_module
use paramreader_module
use linearalgebra_module
use atoms_types_module
use units_module
use atoms_module
use topology_module

use mpi_context_module
use QUIP_Common_module

implicit none
private

include 'IPModel_interface.h'

public :: IPModel_CH4
type IPModel_CH4
  real(dp) :: cutoff = 0.0_dp

  character(len=STRING_LENGTH) :: label

end type IPModel_CH4

logical, private :: parse_in_ip, parse_matched_label
type(IPModel_CH4), private, pointer :: parse_ip

interface Initialise
  module procedure IPModel_CH4_Initialise_str
end interface Initialise

interface Finalise
  module procedure IPModel_CH4_Finalise
end interface Finalise

interface Print
  module procedure IPModel_CH4_Print
end interface Print

interface Calc
  module procedure IPModel_CH4_Calc
end interface Calc

interface
      function ch4pot_func_10(r)
      real(8), intent(in) :: r(10)
      real(8) :: ch4pot_func_10
      endfunction ch4pot_func_10
endinterface

contains

subroutine IPModel_CH4_Initialise_str(this, args_str, param_str)
  type(IPModel_CH4), intent(inout) :: this
  character(len=*), intent(in) :: args_str, param_str

  type(Dictionary) :: params

  call Finalise(this)

  call initialise(params)
  this%label=''
  call param_register(params, 'label', '', this%label, help_string="No help yet.  This source file was $LastChangedBy$")
  if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_CH4_Initialise_str args_str')) then
    call system_abort("IPModel_CH4_Initialise_str failed to parse label from args_str="//trim(args_str))
  endif
  call finalise(params)

  this%cutoff = 2.0

end subroutine IPModel_CH4_Initialise_str

subroutine IPModel_CH4_Finalise(this)
  type(IPModel_CH4), intent(inout) :: this

  ! Add finalisation code here

  this%label = ''
  this%cutoff = 0.0_dp
end subroutine IPModel_CH4_Finalise

subroutine IPModel_CH4_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error)
   type(IPModel_CH4), intent(inout):: this
   type(Atoms), intent(inout)      :: at
   real(dp), intent(out), optional :: e, local_e(:)
   real(dp), intent(out), optional :: f(:,:), local_virial(:,:)   !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)}
   real(dp), intent(out), optional :: virial(3,3)
   character(len=*), optional      :: args_str
   type(MPI_Context), intent(in), optional :: mpi
   integer, intent(out), optional :: error

   integer, dimension(5) :: signature
   integer, dimension(:,:), allocatable :: monomer_index
   logical, dimension(:), allocatable :: is_associated
   real(dp), dimension(3,4) :: pos
   real(dp), dimension(4,4) :: bmat, bmati
   real(dp), dimension(10) :: rten
   integer :: i, j, iC, iH, n_monomers

   INIT_ERROR(error)

   if (present(e)) e = 0.0_dp
   if (present(local_e)) then
      call check_size('Local_E',local_e,(/at%N/),'IPModel_CH4_Calc', error)
      local_e = 0.0_dp
   endif
   if (present(f)) then
      call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_CH4_Calc', error)
      f = 0.0_dp
   end if
   if (present(virial)) virial = 0.0_dp
   if (present(local_virial)) then
      call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_CH4_Calc', error)
      local_virial = 0.0_dp
   endif

   signature = (/6,1,1,1,1/)
   allocate(is_associated(at%N))

   is_associated = .false.
   call find_general_monomer(at,monomer_index,signature,is_associated,this%cutoff,error=error)

   n_monomers = size(monomer_index,2)

#ifdef HAVE_CH4
   call ch4_initialise(bmat,bmati)
#endif

   do i = 1, n_monomers
      iC = monomer_index(1,i)
      do j = 1, 4
         iH = monomer_index(j+1,i)
         pos(:,j) = diff_min_image(at,iC,iH) / BOHR
      enddo
#ifdef HAVE_CH4
      call bond_cart2radau_int10(pos,bmati,rten)
      if(present(e)) e = e + ch4pot_func_10(rten) * INVERSE_CM
#endif
   enddo

   if(allocated(monomer_index)) deallocate(monomer_index)
   if(allocated(is_associated)) deallocate(is_associated)

end subroutine IPModel_CH4_Calc

subroutine IPModel_CH4_Print(this, file)
  type(IPModel_CH4), intent(in) :: this
  type(Inoutput), intent(inout),optional :: file

  integer :: ti

  call Print("IPModel_CH4 : CH4 Potential", file=file)
  call Print("IPModel_CH4 : cutoff = " // this%cutoff, file=file)

end subroutine IPModel_CH4_Print

end module IPModel_CH4_module


module advec_mpi

use phys_consts, only: lsp,ms, wp
use grid, only : gridflag
use meshobj, only: curvmesh
  !! do not import grid sizes in case we want do subgrid advection...
use mpimod, only: mpi_cfg, halo, tag=>gemini_mpi

implicit none (type, external)
private
public :: halo_interface_vels_allspec,set_global_boundaries_allspec
contains
  !> Perform haloing needed to ghost-fill so cell interface vels (single species) can be computed across the grid
  subroutine halo_interface_vels(isp,isperiodic,vs2,vs3)
    integer, intent(in) :: isp
    logical, intent(in) :: isperiodic
    real(wp), dimension(-1:,-1:,-1:,:), intent(inout) :: vs2,vs3
    real(wp), dimension(-1:size(vs3,1)-2,-1:size(vs3,2)-2,-1:size(vs3,3)-2) :: param

    !> NEED TO ALSO PASS THE X2 VELOCITIES SO WE CAN COMPUTE INTERFACE VALUES
    param=vs2(:,:,:,isp)
    call halo(param,1,tag%vs2BC,isperiodic)
    !! we only need one ghost cell to compute interface velocities
    vs2(:,:,:,isp)=param

    !> PASS X3 VELOCITY BOUNDARY CONDITIONS WITH GENERIC HALOING ROUTINES
    param=vs3(:,:,:,isp)
    call halo(param,1,tag%vs3BC,isperiodic)
    !! we only need one ghost cell to compute interface velocities
    vs3(:,:,:,isp)=param
  end subroutine halo_interface_vels

  !> Repeat haloing operations for all species.
  subroutine halo_interface_vels_allspec(isperiodic,vs2,vs3,lsp)
    logical, intent(in) :: isperiodic
    real(wp), dimension(-1:,-1:,-1:,:), intent(inout) :: vs2,vs3
    integer, intent(in) :: lsp
    integer :: isp

    if (lsp>size(vs2,4)) error stop 'number of haloed species must be less than or equal to total species number'
    do isp=1,lsp
      call halo_interface_vels(isp,isperiodic,vs2,vs3)
    end do
  end subroutine halo_interface_vels_allspec

  !> set values in global boundary ghost cells based on extrapolation, can be done by each worker
  !    without input from the root process; does not require mpi.  This does require the inteferface
  !    velocities from the x1 direction so in sense it must be preceded by an mpi call of some sort.
  !    This function works for a single species "isp".  It does need information about the mpi image
  !    organization and as such is considered part of the advec_mpi module.
  subroutine set_global_boundaries(isp,isperiodic,ns,rhovs1,vs1,vs2,vs3,rhoes,v1i)
    integer, intent(in) :: isp
    logical, intent(in) :: isperiodic
    real(wp), dimension(-1:,-1:,-1:,:), intent(inout) :: ns,rhovs1,vs1,vs2,vs3,rhoes
    real(wp), dimension(1:size(vs1,1)-3,1:size(vs1,2)-4,1:size(vs1,3)-4), intent(in) :: v1i
    !    real(wp), parameter :: vellim=2000.0
    !    real(wp), parameter :: vellim=0.0
    real(wp) :: coeff
    integer :: ix2,ix3,lx1,lx2,lx3
    integer :: idleft,idright,idup,iddown
    real(wp), dimension(-1:size(vs3,1)-2,-1:size(vs3,2)-2,-1:size(vs3,3)-2) :: param,param2,param3,param4
    real(wp) :: tstart,tfini

    lx1=size(vs1,1)-4
    lx2=size(vs1,2)-4
    lx3=size(vs1,3)-4

    !> GHOST CELL VALUES FOR DENSITY (these need to be done last to avoid being overwritten by send/recv's!!!)
    do ix3=1,lx3
      do ix2=1,lx2
        !> logical bottom
        coeff=ns(2,ix2,ix3,isp)/ns(3,ix2,ix3,isp)
        ns(0,ix2,ix3,isp)=min(coeff*ns(1,ix2,ix3,isp),ns(1,ix2,ix3,isp))
        ns(-1,ix2,ix3,isp)=min(coeff*ns(0,ix2,ix3,isp),ns(0,ix2,ix3,isp))

        !> logical top
        coeff=ns(lx1-1,ix2,ix3,isp)/ns(lx1-2,ix2,ix3,isp)
        ns(lx1+1,ix2,ix3,isp)=min(coeff*ns(lx1,ix2,ix3,isp),ns(lx1,ix2,ix3,isp))
        ns(lx1+2,ix2,ix3,isp)=min(coeff*ns(lx1+1,ix2,ix3,isp),ns(lx1+1,ix2,ix3,isp))
      end do
    end do

    !FOR X1 MOMENTUM DENSITY
    rhovs1(0,1:lx2,1:lx3,isp)=2*v1i(1,:,:)-vs1(1,1:lx2,1:lx3,isp)
    !! initially these are velocities.  Also loose definition of 'conformable'.  Also corners never get set, but I suppose they aren't really used anyway.
    rhovs1(-1,:,:,isp)=rhovs1(0,:,:,isp)+rhovs1(0,:,:,isp)-vs1(1,:,:,isp)
    rhovs1(lx1+1,1:lx2,1:lx3,isp)=2*v1i(lx1+1,:,:)-vs1(lx1,1:lx2,1:lx3,isp)
    rhovs1(lx1+2,:,:,isp)=rhovs1(lx1+1,:,:,isp)+rhovs1(lx1+1,:,:,isp)-vs1(lx1,:,:,isp)

    rhovs1(-1:0,:,:,isp)=rhovs1(-1:0,:,:,isp)*ns(-1:0,:,:,isp)*ms(isp)
    !! now convert to momentum density
    rhovs1(lx1+1:lx1+2,:,:,isp)=rhovs1(lx1+1:lx1+2,:,:,isp)*ns(lx1+1:lx1+2,:,:,isp)*ms(isp)

    !> FOR INTERNAL ENERGY
    rhoes(0,:,:,isp)=rhoes(1,:,:,isp)
    rhoes(-1,:,:,isp)=rhoes(1,:,:,isp)
    rhoes(lx1+1,:,:,isp)=rhoes(lx1,:,:,isp)
    rhoes(lx1+2,:,:,isp)=rhoes(lx1,:,:,isp)

    !MZ - collect the x2 boundary conditions here - these are no longer global
    iddown=mpi_cfg%myid2-1
    idup=mpi_cfg%myid2+1

    !> SET THE GLOBAL X2 BOUNDARY CELLS AND ASSUME HALOING WON'T OVERWRITE.
    !> THIS DIMENSION IS ASSUMED TO NEVER BE PEREIODIC
    if (iddown==-1) then
      vs2(:,0,:,isp)=vs2(:,1,:,isp)

      ns(:,0,:,isp)=ns(:,1,:,isp)
      ns(:,-1,:,isp)=ns(:,1,:,isp)
      rhovs1(:,0,:,isp)=rhovs1(:,1,:,isp)
      rhovs1(:,-1,:,isp)=rhovs1(:,1,:,isp)
      rhoes(:,0,:,isp)=rhoes(:,1,:,isp)
      rhoes(:,-1,:,isp)=rhoes(:,1,:,isp)
    end if
    if (idup==mpi_cfg%lid2) then
      vs2(:,lx2+1,:,isp)=vs2(:,lx2,:,isp)

      ns(:,lx2+1,:,isp)=ns(:,lx2,:,isp)
      ns(:,lx2+2,:,isp)=ns(:,lx2,:,isp)
      rhovs1(:,lx2+1,:,isp)=rhovs1(:,lx2,:,isp)
      rhovs1(:,lx2+2,:,isp)=rhovs1(:,lx2,:,isp)
      rhoes(:,lx2+1,:,isp)=rhoes(:,lx2,:,isp)
      rhoes(:,lx2+2,:,isp)=rhoes(:,lx2,:,isp)
    end if

    !> NOW DEAL WITH ADVECTION ALONG X3; FIRST IDENTIFY MY NEIGHBORS
    idleft=mpi_cfg%myid3-1; idright=mpi_cfg%myid3+1

    !> SET THE GLOBAL x3 BOUNDARY CELLS AND ASSUME THAT HALOING WON'T OVERWRITE...
    if (.not. isperiodic) then
      if (idleft==-1) then
        !! left side is at global boundary, assume haloing won't overwrite
        vs3(:,:,0,isp)=vs3(:,:,1,isp)
        !! copy first cell to first ghost (vs3 not advected so only need only ghost)

        ns(:,:,0,isp)=ns(:,:,1,isp)
        ns(:,:,-1,isp)=ns(:,:,1,isp)
        rhovs1(:,:,0,isp)=rhovs1(:,:,1,isp)
        rhovs1(:,:,-1,isp)=rhovs1(:,:,1,isp)
        rhoes(:,:,0,isp)=rhoes(:,:,1,isp)
        rhoes(:,:,-1,isp)=rhoes(:,:,1,isp)
      end if
      if (idright==mpi_cfg%lid3) then    !my right boundary is the global boundary, assume haloing won't overwrite
        vs3(:,:,lx3+1,isp)=vs3(:,:,lx3,isp)    !copy last cell to first ghost (all that's needed since vs3 not advected)

        ns(:,:,lx3+1,isp)=ns(:,:,lx3,isp)
        ns(:,:,lx3+2,isp)=ns(:,:,lx3,isp)
        rhovs1(:,:,lx3+1,isp)=rhovs1(:,:,lx3,isp)
        rhovs1(:,:,lx3+2,isp)=rhovs1(:,:,lx3,isp)
        rhoes(:,:,lx3+1,isp)=rhoes(:,:,lx3,isp)
        rhoes(:,:,lx3+2,isp)=rhoes(:,:,lx3,isp)
      end if
    end if
  end subroutine set_global_boundaries

  !> set global boundaries for all species
  subroutine set_global_boundaries_allspec(isperiodic,ns,rhovs1,vs1,vs2,vs3,rhoes,vs1i,lsp)
    logical, intent(in) :: isperiodic
    real(wp), dimension(-1:,-1:,-1:,:), intent(inout) :: ns,rhovs1,vs1,vs2,vs3,rhoes
    real(wp), dimension(1:size(vs1,1)-3,1:size(vs1,2)-4,1:size(vs1,3)-4,1:size(vs1,4)), intent(in) :: vs1i
    integer, intent(in) :: lsp
    integer :: isp

    if (lsp>size(vs1,4)) error stop 'number of global boundaries must be less than or equal to total species number'
    do isp=1,lsp
      call set_global_boundaries(isp,isperiodic,ns,rhovs1,vs1,vs2,vs3,rhoes,vs1i(:,:,:,isp))
    end do
  end subroutine set_global_boundaries_allspec
end module advec_mpi