module sdfs
!   Module provides signed distance functions (SDFs) for various shapes
!   and some operations to adjust, move, rotate etc them
!   All SDF functions are adapted from Inigo Quilex exhaustive list at:
!   https://www.iquilezles.org/www/articles/distfunctions/distfunctions.htm
!
    use vector_class
    use constants, only : wp

    implicit none

    type, abstract :: sdf
    ! base class.
    ! provides deferred evaluation func to get distance to shape
    ! and gives the transform and optical prperties.
    ! Layer is an important bookeeping integer.
        real(kind=wp) :: mus, mua, kappa, albedo, hgg, g2, n
        real(kind=wp) :: transform(4, 4)
        integer :: layer
        contains
        procedure(evalInterface), deferred :: evaluate
    end type sdf

    abstract interface
        function evalInterface(this, pos) result(res)
            use vector_class
            use constants, only : wp
            import sdf
            implicit none
            class(sdf) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res
        end function evalInterface
    end interface

    type, extends(sdf) :: sphere
        real(kind=wp) :: radius
        contains
        procedure :: evaluate => eval_sphere
    end type sphere

    interface sphere
        module procedure sphere_init
    end interface sphere

    type, extends(sdf) :: cylinder
        real(kind=wp) :: radius
        type(vector)  :: a, b
        contains
        procedure :: evaluate => eval_cylinder
    end type cylinder

    interface cylinder
        module procedure cylinder_init
    end interface cylinder

    type, extends(sdf) :: box
        type(vector) :: lengths
        contains
        procedure :: evaluate => eval_box
    end type box

    interface box
        module procedure box_init_vec
        module procedure box_init_scal
    end interface box

    type, extends(sdf) :: torus
        real(kind=wp) :: oradius, iradius
        contains
        procedure :: evaluate => eval_torus
    end type torus

    interface torus
        module procedure torus_init
    end interface torus

    type, extends(sdf) :: triprisim
        real(kind=wp) :: h1, h2
        contains
        procedure :: evaluate => eval_triprisim
    end type triprisim

    interface triprisim
        module procedure triprisim_init
    end interface triprisim

    type, extends(sdf) :: cone
        type(vector)  :: a, b
        real(kind=wp) :: ra, rb
        contains
        procedure :: evaluate => eval_cone
    end type cone

    interface cone
        module procedure cone_init
    end interface cone

    type, extends(sdf) :: capsule
        type(vector)  :: a, b
        real(kind=wp) :: r
        contains
        procedure :: evaluate => eval_capsule
    end type capsule

    interface capsule
        module procedure capsule_init
    end interface capsule

    type, extends(sdf) :: plane
        type(vector) :: a
        contains
        procedure :: evaluate => eval_plane
    end type plane

    interface plane
        module procedure plane_init
    end interface plane

    type, extends(sdf) :: segment
        type(vector) :: a, b
        contains
        procedure :: evaluate => eval_segment
    end type segment

    interface segment
        module procedure segment_init
    end interface segment

    type, extends(sdf) :: moon
        real(kind=wp) :: d, ra, rb
        contains
        procedure :: evaluate => eval_moon
    end type moon

    interface moon
        module procedure moon_init
    end interface moon

    type, extends(sdf) :: neural
        contains
        procedure :: evaluate => eval_neural
    end type neural

    interface neural
        module procedure neural_init
    end interface neural

    type, extends(sdf) :: model
        type(container), allocatable   :: array(:)
        procedure(op), nopass, pointer :: func
        real(kind=wp) :: k
        contains
        procedure :: evaluate => eval_model
    end type model

    interface model
        module procedure model_init
    end interface model

    type :: container
        class(sdf), pointer :: p => null()
    end type container

    type, extends(sdf) :: twist
        real(kind=wp) :: k
        class(sdf), pointer :: prim
        contains
        procedure :: evaluate => eval_twist
    end type twist

    interface twist
        module procedure twist_init
    end interface twist

    type, extends(sdf) :: displacement
        procedure(primitive), nopass, pointer :: func
        class(sdf), pointer :: prim
        contains
        procedure :: evaluate => eval_disp
    end type displacement

    interface displacement
        module procedure displacement_init
    end interface displacement

    type, extends(sdf) :: bend
        real(kind=wp) :: k
        class(sdf), pointer :: prim
        contains
        procedure :: evaluate => eval_bend
    end type bend

    interface bend
        module procedure bend_init
    end interface bend

    type, extends(sdf) :: elongate
        type(vector) :: size
        class(sdf), pointer :: prim
        contains
        procedure :: evaluate => eval_elongate
    end type elongate

    interface elongate
        module procedure elongate_init
    end interface elongate

    type, extends(sdf) :: repeat
        real(kind=wp) :: c
        type(vector) :: la, lb
        class(sdf), pointer :: prim
        contains
        procedure :: evaluate => eval_repeat
    end type repeat

    interface repeat
        module procedure repeat_init
    end interface repeat

    type, extends(sdf) :: extrude
        real(kind=wp) :: h
        class(sdf), pointer :: prim
        contains
        procedure :: evaluate => eval_extrude
    end type extrude

    interface extrude
        module procedure extrude_init
    end interface extrude

    abstract interface
        function op(d1, d2, k) result(res)
            use constants, only : wp
            implicit none
            real(kind=wp), intent(IN) :: d1, d2, k
            real(kind=wp) :: res
        end function op
    end interface

    abstract interface
        function primitive(pos) result(res)
            use vector_class, only : vector
            use constants,    only : wp
            implicit none
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res
        end function primitive
    end interface

    private
    ! shapes
    public :: sdf, cylinder, sphere, box, torus, cone, triprisim
    public :: capsule, plane, moon, neural, segment
    ! meta
    public :: model, container
    ! boolean ops
    public :: union, intersection, subtraction, SmoothUnion, op
    ! move ops
    public :: rotate_x, rotate_y, rotate_z, identity, translate
    ! deform ops
    public :: displacement, bend, twist, elongate, repeat, extrude
    ! utility funcs
    public :: calcNormal, model_init, render

    contains

        function segment_init(a, b, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(segment) :: out

            type(vector),            intent(IN) :: a, b
            real(kind=wp),           intent(IN) :: mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%a = a
            out%b = b

            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1.
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function segment_init

        function eval_segment(this, pos) result(res)

            implicit none

            class(segment) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = segment_fn(p, this%a, this%b) - 0.1_wp

        end function eval_segment

        function segment_fn(p, a, b) result(res)
            !p = pos
            !a = pt1
            !b = pt2
            !draws segment along the axis between 2 points a and b

            use utils, only : clamp

            implicit none

            type(vector), intent(IN) :: p, a, b
            real(kind=wp) :: res

            type(vector)  :: pa, ba
            real(kind=wp) :: h

            pa = p - a
            ba = b - a
            h = clamp((pa .dot. ba) / (ba .dot. ba), 0.0_wp, 1.0_wp)

            res = length(pa - ba*h)

        end function segment_fn

        function neural_init(mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(neural) :: out

            real(kind=wp),           intent(IN) :: mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function neural_init

function eval_neural(this, pos) result(out)
! this function is generated using code. do not edit
    use vec4_class
    use mat_class

    implicit none

    class(neural) :: this
    type(vector), intent(IN) :: pos
    real(kind=wp) :: out

    type(vec4) :: f0_0, f0_1, f0_2, f0_3, f1_0, f1_1, f1_2, f1_3, f2_0, f2_1, f2_2, f2_3

f0_0=sin(pos%y*vec4(-2.845,2.169,-3.165,-3.379)+pos%z*vec4(-1.938,2.632,-1.872,3.019)+pos%x*vec4(1.042,4.283,-.778,-3.063)+vec4(8.246,7.046,6.947,4.930))
f0_1=sin(pos%y*vec4(-.870,-.224,-3.854,-2.134)+pos%z*vec4(-1.474,-2.259,4.302,2.238)+pos%x*vec4(1.576,-.826,1.014,2.511)+vec4(.639,-.425,6.931,7.475))
f0_2=sin(pos%y*vec4(-2.161,1.539,-3.024,1.739)+pos%z*vec4(-3.388,.743,-3.374,-.536)+pos%x*vec4(3.843,-3.060,3.127,1.533)+vec4(1.916,-2.519,-.403,-1.918))
f0_3=sin(pos%y*vec4(.076,1.427,-2.403,-.442)+pos%z*vec4(3.012,1.584,-3.421,1.513)+pos%x*vec4(.061,-3.592,-.935,.125)+vec4(7.654,-.949,-7.044,4.319))
f1_0=sin(mat([.230_wp,.244_wp,-.196_wp,-.230_wp,-.303_wp,.187_wp,.122_wp,-.410_wp,.388_wp,-.741_wp,.731_wp,.031_wp,-.999_wp,-.044_wp,.107_wp,.171_wp])*f0_0+&
   mat([.141_wp,-.542_wp,-.726_wp,-.280_wp,-.445_wp,-.038_wp,-.397_wp,.348_wp,-.086_wp,.413_wp,.544_wp,.298_wp,-.075_wp,.122_wp,-.315_wp,.293_wp])*f0_1+&
   mat([.329_wp,-.106_wp,-.690_wp,.012_wp,-.073_wp,-.862_wp,.381_wp,.628_wp,.378_wp,-.012_wp,-.137_wp,-.071_wp,.580_wp,.060_wp,-1.094_wp,.652_wp])*f0_2+&
   mat([.616_wp,.363_wp,.211_wp,-.366_wp,-.396_wp,.388_wp,-.090_wp,.217_wp,.479_wp,-.339_wp,-.039_wp,-.132_wp,.176_wp,.223_wp,.312_wp,.082_wp])*f0_3+&
   vec4(-2.491,3.220,2.193,2.989))/1.0_wp+f0_0
f1_1=sin(mat([.137_wp,.498_wp,.156_wp,.391_wp,-.059_wp,.084_wp,-.182_wp,-.027_wp,.650_wp,.302_wp,.676_wp,-.202_wp,-.488_wp,.297_wp,-.136_wp,-.366_wp])*f0_0+&
   mat([.211_wp,.210_wp,-.557_wp,.021_wp,.808_wp,-.041_wp,-.726_wp,.028_wp,.003_wp,-.012_wp,-.280_wp,-.539_wp,-.624_wp,.261_wp,.262_wp,-.123_wp])*f0_1+&
   mat([-.220_wp,-.208_wp,.211_wp,-.740_wp,-.009_wp,-.103_wp,.741_wp,-.820_wp,-.312_wp,.074_wp,.432_wp,-.258_wp,.390_wp,-.249_wp,.375_wp,.169_wp])*f0_2+&
   mat([-.085_wp,-.105_wp,.309_wp,.291_wp,-.476_wp,-.764_wp,.048_wp,-.148_wp,-.318_wp,.182_wp,-.170_wp,-.220_wp,-1.041_wp,-.116_wp,-1.077_wp,.565_wp])*f0_3+&
   vec4(1.529_wp,2.058_wp,-.449_wp,-1.700_wp))/1.0_wp+f0_1
f1_2=sin(mat([.385_wp,.698_wp,-.630_wp,-.482_wp,-.099_wp,-.552_wp,.173_wp,-.148_wp,-.711_wp,-.721_wp,.342_wp,.079_wp,-.470_wp,-.177_wp,.011_wp,-.117_wp])*f0_0+&
   mat([.834_wp,-.758_wp,.162_wp,.761_wp,-.348_wp,.367_wp,.375_wp,.721_wp,.731_wp,.078_wp,.024_wp,.329_wp,.340_wp,-.429_wp,-.006_wp,.084_wp])*f0_1+&
   mat([.277_wp,.015_wp,-.449_wp,-.100_wp,-.223_wp,-.897_wp,.623_wp,-.004_wp,.049_wp,-.371_wp,.040_wp,-.200_wp,.367_wp,.221_wp,-.063_wp,.665_wp])*f0_2+&
   mat([1.595_wp,.428_wp,.417_wp,.268_wp,-.241_wp,.145_wp,.141_wp,-.185_wp,.430_wp,-.096_wp,.521_wp,.109_wp,-.239_wp,.770_wp,-.100_wp,-.128_wp])*f0_3+&
   vec4(-1.674_wp,2.261_wp,-2.165_wp,-3.244_wp))/1.0_wp+f0_2
f1_3=sin(mat([.228_wp,-.315_wp,.459_wp,.085_wp,-.060_wp,-.070_wp,-.217_wp,-.605_wp,-.217_wp,-.237_wp,.400_wp,.358_wp,.198_wp,-.722_wp,-.062_wp,-.805_wp])*f0_0+&
   mat([.108_wp,.313_wp,.793_wp,-.378_wp,-.168_wp,-.350_wp,.504_wp,.664_wp,.251_wp,-.058_wp,.087_wp,-.405_wp,.068_wp,.077_wp,.148_wp,-.741_wp])*f0_1+&
   mat([.324_wp,-.130_wp,.018_wp,.100_wp,-.658_wp,.087_wp,-.077_wp,-.082_wp,.101_wp,-.103_wp,-.132_wp,.159_wp,-.117_wp,-.563_wp,-.606_wp,-.278_wp])*f0_2+&
   mat([.181_wp,.584_wp,.390_wp,-.498_wp,.096_wp,-.461_wp,-.324_wp,.573_wp,-.261_wp,.849_wp,-.012_wp,.017_wp,-.289_wp,.578_wp,.161_wp,-1.158_wp])*f0_3+&
   vec4(-.938_wp,-.744_wp,2.675_wp,1.662_wp))/1.0_wp+f0_3
f2_0=sin(mat([-.165_wp,-.648_wp,-.274_wp,-.443_wp,.307_wp,-.478_wp,-.204_wp,-.103_wp,-.017_wp,1.027_wp,.680_wp,.228_wp,-.121_wp,.419_wp,.137_wp,-.253_wp])*f1_0+&
   mat([-.252_wp,.249_wp,.450_wp,-.249_wp,-1.085_wp,-.292_wp,.609_wp,.047_wp,-.999_wp,-.082_wp,-.005_wp,-.836_wp,-.356_wp,.411_wp,-.402_wp,.699_wp])*f1_1+&
   mat([-.103_wp,-.218_wp,-.000_wp,-.639_wp,-.057_wp,.447_wp,-.502_wp,-.505_wp,-.298_wp,.029_wp,-.363_wp,-.607_wp,.116_wp,-.942_wp,2.064_wp,.363_wp])*f1_2+&
   mat([.394_wp,.030_wp,.070_wp,1.402_wp,-.552_wp,-.391_wp,.255_wp,-.733_wp,-.102_wp,.263_wp,-.291_wp,.190_wp,.489_wp,.614_wp,.683_wp,.061_wp])*f1_3+&
   vec4(-.896_wp,.069_wp,3.048_wp,2.889_wp))/1.4_wp+f1_0
f2_1=sin(mat([.553_wp,-.627_wp,-.284_wp,-1.032_wp,-.524_wp,.294_wp,-.078_wp,-.128_wp,.100_wp,.112_wp,.089_wp,.318_wp,.560_wp,.407_wp,-.317_wp,-1.634_wp])*f1_0+&
   mat([.024_wp,.420_wp,.599_wp,.063_wp,-.317_wp,.728_wp,.197_wp,-1.037_wp,.425_wp,-.035_wp,-.240_wp,-1.530_wp,-.246_wp,.333_wp,.209_wp,-1.455_wp])*f1_1+&
   mat([.514_wp,-.095_wp,.139_wp,-.551_wp,-.225_wp,-.067_wp,.568_wp,-.958_wp,.038_wp,.161_wp,-.057_wp,-.871_wp,.468_wp,-.633_wp,.440_wp,1.798_wp])*f1_2+&
   mat([.185_wp,-.798_wp,.206_wp,.941_wp,1.032_wp,-.016_wp,.629_wp,-.416_wp,.026_wp,-.777_wp,.206_wp,-.360_wp,-.456_wp,.463_wp,1.117_wp,.883_wp])*f1_3+&
   vec4(2.594_wp,2.602_wp,-4.067_wp,.754_wp))/1.4_wp+f1_1
f2_2=sin(mat([.601_wp,.096_wp,-.071_wp,.363_wp,-1.159_wp,-.053_wp,.049_wp,-.140_wp,.056_wp,.701_wp,-.047_wp,-.031_wp,1.257_wp,-.421_wp,-.360_wp,-1.596_wp])*f1_0+&
   mat([.357_wp,.525_wp,-.130_wp,-.001_wp,-.643_wp,-.206_wp,.237_wp,-.837_wp,.813_wp,-.308_wp,.407_wp,-.157_wp,1.845_wp,.737_wp,-.374_wp,.390_wp])*f1_1+&
   mat([-.569_wp,.109_wp,.476_wp,-.377_wp,.124_wp,.171_wp,-.100_wp,-.606_wp,-.560_wp,.414_wp,.176_wp,.483_wp,-2.082_wp,-.375_wp,.928_wp,.125_wp])*f1_2+&
   mat([-.599_wp,.549_wp,-.414_wp,.642_wp,-.525_wp,.025_wp,.385_wp,-.797_wp,1.270_wp,.342_wp,-.068_wp,.965_wp,-1.026_wp,-.177_wp,.890_wp,.156_wp])*f1_3+&
   vec4(-4.226_wp,1.935_wp,3.830_wp,-2.055_wp))/1.4_wp+f1_2
f2_3=sin(mat([.463_wp,1.053_wp,.008_wp,-.354_wp,-.124_wp,-.566_wp,-.734_wp,.673_wp,.970_wp,-.193_wp,.377_wp,.283_wp,-.481_wp,-1.345_wp,.024_wp,.687_wp])*f1_0+&
   mat([-.358_wp,-.069_wp,.358_wp,.373_wp,.745_wp,-.056_wp,.054_wp,1.070_wp,-.459_wp,-.404_wp,-.654_wp,.665_wp,-.400_wp,.127_wp,.422_wp,.202_wp])*f1_1+&
   mat([.255_wp,-.513_wp,-.741_wp,-.345_wp,-.404_wp,.188_wp,.118_wp,.486_wp,.783_wp,.610_wp,-.790_wp,-.099_wp,-.555_wp,-3.111_wp,-1.241_wp,-.215_wp])*f1_2+&
   mat([.776_wp,.131_wp,.035_wp,.434_wp,.355_wp,-2.543_wp,-.158_wp,-.140_wp,.454_wp,1.154_wp,.156_wp,.543_wp,.555_wp,-.726_wp,.369_wp,-1.032_wp])*f1_3+&
   vec4(1.108_wp,.703_wp,-.637_wp,.098_wp))/1.4_wp+f1_3
out= (f2_0.dot.vec4(-.041,-.048,-.054,.034))+&
    (f2_1.dot.vec4(.066,.103,.066,-.022))+&
    (f2_2.dot.vec4(.011,.059,-.092,.064))+&
    (f2_3.dot.vec4(-.059,-.031,.063,-.052))+&
    (0.079)
end function eval_neural

        type(vector) function calcNormal(p, obj)

            implicit none

            type(vector), intent(IN) :: p
            class(sdf) :: obj

            real(kind=wp) :: h
            type(vector) :: xyy, yyx, yxy, xxx

            h = 1e-5_wp
            xyy = vector(1._wp, -1._wp, -1._wp)
            yyx = vector(-1._wp, -1._wp, 1._wp)
            yxy = vector(-1._wp, 1._wp, -1._wp)
            xxx = vector(1._wp, 1._wp, 1._wp)

            calcNormal = xyy*obj%evaluate(p + xyy*h) +  &
                         yyx*obj%evaluate(p + yyx*h) +  &
                         yxy*obj%evaluate(p + yxy*h) +  &
                         xxx*obj%evaluate(p + xxx*h)

            calcNormal = calcNormal%magnitude()

        end function calcNormal

        function model_init(array, func, kopt) result(out)
        !TODO make sure optical properties are same in all inputs
            implicit none

            type(model) :: out

            procedure(op) :: func
            type(container),          intent(IN) :: array(:)
            real(kind=wp), optional,  intent(IN) :: kopt

            out%array = array
            out%func => func
            if(present(kopt))then
                out%k = kopt
            else
                out%k = 0._wp
            end if

            associate(member => array(1)%p)
                out%mus = member%mus
                out%mua = member%mua
                out%kappa = member%kappa
                out%albedo = member%albedo
                out%g2 = member%g2
                out%hgg = member%hgg
                out%n = member%n
                out%layer = member%layer
            end associate

        end function model_init

        function eval_model(this, pos) result(res)

            implicit none

            class(model) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            integer :: i

            res = this%array(1)%p%evaluate(pos)
            do i = 2, size(this%array)
                res = this%func(res, this%array(i)%p%evaluate(pos), this%k)
            end do

        end function eval_model

        function cylinder_init(a, b, radius, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(cylinder) :: out

            real(kind=wp),           intent(IN) :: radius, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            type(vector),            intent(IN) :: a, b
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%a = a
            out%b = b
            out%radius = radius
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function cylinder_init

        function eval_cylinder(this, pos) result(res)

            implicit none

            class(cylinder) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = cylinder_fn(p, this%a, this%b, this%radius)

        end function eval_cylinder

        function cylinder_fn(p, a, b, r) result(res)
            !p = pos
            !a = pt1
            !b = pt2
            !r = radius
            !draws cylinder along the axis between 2 points a and b
            implicit none

            type(vector),  intent(IN) :: p, a, b
            real(kind=wp), intent(IN) :: r
            real(kind=wp) :: res

            type(vector)  :: ba, pa
            real(kind=wp) :: x, y, x2, y2, d, baba, paba

            ba = b - a
            pa = p - a
            baba = ba .dot. ba
            paba = pa .dot. ba
            x = length(pa * baba - ba*paba) - r*baba
            y = abs(paba - baba*.5_wp) - baba*.5_wp
            x2 = x**2
            y2 = (y**2)*baba
            if(max(x, y) < 0._wp)then
                d = -min(x2, y2)
            else
                if(x > 0._wp .and. y > 0._wp)then
                    d = x2 + y2
                elseif(x > 0._wp)then
                    d = x2
                elseif(y > 0._wp)then
                    d = y2
                else
                    d = 0._wp
                end if
            end if

            res = sign(sqrt(abs(d))/baba, d)

        end function cylinder_fn

        function box_init(lengths, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(box) :: out

            type(vector),            intent(IN) :: lengths
            real(kind=wp),           intent(IN) :: mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(in) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%lengths = .5_wp*lengths! as only half lengths
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function box_init

        function box_init_vec(lengths, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(box) :: out

            type(vector),            intent(IN) :: lengths
            real(kind=wp),           intent(IN) :: mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(in) :: transform(4, 4)

            out = box_init(lengths, mus, mua, hgg, n, layer, transform)

        end function box_init_vec

        function box_init_scal(length, mus, mua, hgg, n, layer, transform) result(res)

            implicit none

            type(box) :: res

            real(kind=wp),           intent(IN) :: length, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(in) :: transform(4, 4)

            type(vector) :: lengths

            lengths = vector(length, length, length)

            res = box_init(lengths, mus, mua, hgg, n, layer, transform)

        end function box_init_scal

        function eval_box(this, pos) result(res)

            implicit none

            class(box) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = box_fn(p, this%lengths)

        end function eval_box

        function box_fn(p, b) result(res)

            implicit none

            type(vector), intent(IN) :: p, b
            real(kind=wp) :: res

            type(vector) :: q

            q = abs(p) - b
            res = length(max(q, 0._wp)) + min(max(q%x, max(q%y, q%z)), 0._wp)

        end function box_fn

        function sphere_init(radius, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(sphere) :: out

            real(kind=wp),           intent(IN) :: radius, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%radius = radius
            out%layer = layer

            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function sphere_init

        function eval_sphere(this, pos) result(res)

            implicit none

            class(sphere) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = sphere_fn(p, this%radius)

        end function eval_sphere

        function sphere_fn(p, c) result(res)

            implicit none

            type(vector),  intent(IN) :: p
            real(kind=wp), intent(IN) :: c
            real(kind=wp) :: res

            res = sqrt(p%x**2+p%y**2+p%z**2) - c

        end function sphere_fn

        function torus_init(oradius, iradius, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(torus) :: out

            real(kind=wp),           intent(IN) :: oradius, iradius, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%oradius = oradius
            out%iradius = iradius
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function torus_init

        function eval_torus(this, pos) result(res)

            implicit none

            class(torus) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = torus_fn(p, this%oradius, this%iradius)

        end function eval_torus

        function torus_fn(p, or, ir) result(res)

            implicit none

            type(vector),  intent(IN) :: p
            real(kind=wp), intent(IN) :: or, ir
            real(kind=wp) :: res

            type(vector) :: q

            q = vector(length(vector(p%x, 0._wp, p%z)) - or, p%y, 0._wp)
            res = length(q) - ir

        end function torus_fn

        function triprisim_init(h1, h2, mus, mua, hgg, n, layer, transform) result(out)
        !h1 is height
        !h2 is length
        !
            implicit none

            type(triprisim) :: out

            real(kind=wp),           intent(IN) :: h1, h2, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%h1 = h1
            out%h2 = h2
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function triprisim_init

        function eval_triprisim(this, pos) result(res)

            implicit none

            class(triprisim) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = triprisim_fn(p, this%h1, this%h2)

        end function eval_triprisim

        function triprisim_fn(p, h1, h2) result(res)

            implicit none

            type(vector),  intent(IN) :: p
            real(kind=wp), intent(IN) :: h1, h2
            real(kind=wp) :: res

            type(vector) :: q

            q = abs(p)
            res = max(q%z - h2, max(q%x*.866025_wp + p%y*.5_wp, -p%y) - h1*.5_wp)

        end function triprisim_fn

        function cone_init(a, b, ra, rb, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(cone) :: out

            type(vector),            intent(IN) :: a, b
            real(kind=wp),           intent(IN) :: ra, rb, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%a = a
            out%b = b
            out%ra = ra
            out%rb = rb
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function cone_init

        function eval_cone(this, pos) result(res)

            implicit none

            class(cone) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = cone_fn(p, this%a, this%b, this%ra, this%rb)

        end function eval_cone

        function cone_fn(p, a, b, ra, rb) result(res)

            use utils, only : clamp

            implicit none

            type(vector),  intent(IN) :: p, a, b
            real(kind=wp), intent(IN) :: ra, rb
            real(kind=wp) :: res

            real(kind=wp) :: rba, baba, papa, paba, x, cax, cay, k, f, cbx, cby, s

            rba = rb - ra
            baba = (b-a) .dot. (b-a)
            papa = (p-a) .dot. (p-a)
            paba =  ((p-a) .dot. (b-a))/ baba
            x = sqrt(papa - baba*paba**2)
            if(paba < 0.5_wp)then
                cax = max(0._wp, x - ra)
            else
                cax = max(0._wp, x - rb)
            end if
            cay = abs(paba - 0.5_wp) - .5_wp
            k = rba**2 + baba
            f = clamp((rba * (x - ra) + paba*baba) / k, 0._wp, 1._wp)
            cbx = x - ra - f*rba
            cby = paba - f
            if(cbx < 0._wp .and. cay < 0._wp)then
                s = -1._wp
            else
                s = 1._wp
            end if
            res = s * sqrt(min(cax**2 + baba*cay**2, cbx**2 + baba*cby**2))

        end function cone_fn

        function capsule_init(a, b, r, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(capsule) :: out

            type(vector),            intent(IN) :: a, b
            real(kind=wp),           intent(IN) :: r, mus, mua, hgg, n
            integer,                 intent(IN) :: layer
            real(kind=wp), optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%a = a
            out%b = b
            out%r = r
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function capsule_init

        function eval_capsule(this, pos) result(res)

            implicit none

            class(capsule) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = capsule_fn(p, this%a, this%b, this%r)

        end function eval_capsule

        function capsule_fn(p, a, b, r) result(res)

            use utils, only : clamp

            implicit none

            type(vector),  intent(IN) :: p, a, b
            real(kind=wp), intent(IN) :: r
            real(kind=wp) :: res

            type(vector) :: pa, ba
            real(kind=wp) :: h

            pa = p - a
            ba = b - a
            h = clamp((pa .dot. ba) / (ba .dot. ba), 0._wp, 1._wp)
            res = length(pa - ba*h) - r

        end function capsule_fn

        function plane_init(a, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(plane) :: out

            type(vector),             intent(IN) :: a
            real(kind=wp),            intent(IN) :: mus, mua, hgg, n
            integer,                  intent(IN) :: layer
            real(kind=wp),  optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%a = a
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function plane_init

        function eval_plane(this, pos) result(res)

            implicit none

            class(plane) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = plane_fn(p, this%a)

        end function eval_plane

        function plane_fn(p, n) result(res)

            use utils, only : clamp

            implicit none

            type(vector), intent(IN) :: p, n
            real(kind=wp) :: res

            !n must be normalised
            res = (p .dot. n)

        end function plane_fn

        function moon_init(d, ra, rb, mus, mua, hgg, n, layer, transform) result(out)

            implicit none

            type(moon) :: out

            real(kind=wp),            intent(IN) :: d, ra, rb, mus, mua, hgg, n
            integer,                  intent(IN) :: layer
            real(kind=wp),  optional, intent(IN) :: transform(4, 4)

            real(kind=wp) :: t(4, 4)

            if(present(transform))then
                t = transform
            else
                t = identity()
            end if

            out%d = d
            out%ra = ra
            out%rb = rb
            out%layer = layer
            out%transform = t

            out%mus = mus
            out%mua = mua
            out%kappa = mus + mua
            if(out%mua < 1e-9_wp)then
                out%albedo = 1._wp
            else
                out%albedo = mus / out%kappa
            end if
            out%hgg = hgg
            out%g2 = hgg**2
            out%n = n

        end function moon_init

        function eval_moon(this, pos) result(res)

            implicit none

            class(moon) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            type(vector) :: p

            p = pos .dot. this%transform
            res = moon_fn(p, this%d, this%ra, this%rb)

        end function eval_moon

        function moon_fn(p, d, ra, rb) result(res)

            use utils, only : clamp

            implicit none

            type(vector),  intent(IN) :: p
            real(kind=wp), intent(IN) :: d, ra, rb
            real(kind=wp) :: res

            type(vector)  :: pos
            real(kind=wp) :: a, b, ra2, rb2, d2

            pos = vector(p%x, abs(p%y), 0._wp)
            ra2 = ra*ra
            rb2 = rb*rb
            d2 = d*d
            a = (ra2 - rb2 + d2) / (2._wp*d)
            b = sqrt(max(ra2 - a**2, 0._wp))
            if(d*(pos%x*b - pos%y*a) > d2*max(b - pos%y, 0._wp))then
                res = length(pos - vector(a, b, 0._wp))
            else
                res = max(-length(pos) - ra, length(pos - vector(d, 0._wp, 0._wp)) - rb)
            end if

        end function moon_fn

        function translate(o) result(out)

            implicit none

            type(vector), intent(IN) :: o

            real(kind=wp) :: out(4, 4)

            out(:, 1) = [1._wp, 0._wp, 0._wp, o%x]
            out(:, 2) = [0._wp, 1._wp, 0._wp, o%y]
            out(:, 3) = [0._wp, 0._wp, 1._wp, o%z]
            out(:, 4) = [0._wp, 0._wp, 0._wp, 1._wp]

        end function translate

        function union(d1, d2, k) result(res)

            implicit none

            real(kind=wp), intent(IN) :: d1, d2, k
            real(kind=wp) :: res

            res = min(d1, d2)
        end function union

        function SmoothUnion(d1, d2, k) result(res)

            use utils, only : mix, clamp

            implicit none

            real(kind=wp), intent(IN) :: d1, d2, k
            real(kind=wp) :: res

            real(kind=wp) :: h

            h = max(k - abs(d1 - d2), 0._wp) / k
            res = min(d1, d2) - h*h*h*k*(1._wp/6._wp)
            ! h = clamp(0.5 +.5*(d2-d1)/k, 0., 1.)
            ! SmoothUnion = mix(d2, d1, h) - k*h*(1.-h)

        end function SmoothUnion

        function subtraction(d1, d2, k) result(res)

            implicit none

            real(kind=wp), intent(IN) :: d1, d2, k
            real(kind=wp) :: res

            res = max(-d1, d2)

        end function subtraction

        function intersection(d1, d2, k) result(res)

            implicit none

            real(kind=wp), intent(IN) :: d1, d2, k
            real(kind=wp) :: res

            res = max(d1, d2)

        end function intersection

        type(elongate) function elongate_init(prim, size) result(out)

            implicit none

            type(vector), intent(IN) :: size
            class(sdf), target :: prim

            out%size = size
            out%prim => prim

            out%mus = prim%mus
            out%mua = prim%mua
            out%hgg = prim%hgg
            out%g2 = prim%g2
            out%n = prim%n
            out%kappa = prim%kappa
            out%albedo = prim%kappa
            out%layer = prim%layer
            out%transform = identity()

            end function elongate_init

        function eval_elongate(this, pos) result(res)

            implicit none

            class(elongate) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            res = elongate_fn(pos, this%size, this%prim)

        end function eval_elongate

        function elongate_fn(p, size, prim) result(res)

            implicit none

            class(sdf) :: prim

            type(vector), intent(IN) :: size
            type(vector), intent(IN) :: p
            real(kind=wp) :: res

            real(kind=wp) :: w
            type(vector) :: q

            q = abs(p) - size
            w = min(max(q%x, max(q%y, q%z)), 0._wp)

            res = prim%evaluate(max(q, 0._wp)) + w

        end function elongate_fn

        type(bend) function bend_init(prim, k) result(out)

            implicit none

            real(kind=wp), intent(IN) :: k
            class(sdf), target :: prim

            out%k = k
            out%prim => prim

            out%mus = prim%mus
            out%mua = prim%mua
            out%hgg = prim%hgg
            out%g2 = prim%g2
            out%n = prim%n
            out%kappa = prim%kappa
            out%albedo = prim%kappa
            out%layer = prim%layer
            out%transform = identity()

            end function bend_init

        function eval_bend(this, pos) result(res)

            implicit none

            class(bend) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            res = bend_fn(pos, this%k, this%prim)

        end function eval_bend

        function bend_fn(p, k, prim) result(res)

            implicit none

            class(sdf) :: prim

            real(kind=wp), intent(IN) :: k
            type(vector),  intent(IN) :: p
            real(kind=wp) :: res

            real(kind=wp) :: c, s, x2, y2, z2

            c = cos(k * p%x)
            s = sin(k * p%x)
            x2 = c * p%x - s * p%y
            y2 = s * p%x + c * p%y
            z2 = p%z

            res = prim%evaluate(vector(x2, y2, z2))

        end function bend_fn

        type(displacement) function displacement_init(prim, func) result(out)

            implicit none

            class(sdf), target :: prim
            procedure(primitive) :: func

            out%func => func
            out%prim => prim

            out%mus = prim%mus
            out%mua = prim%mua
            out%hgg = prim%hgg
            out%g2 = prim%g2
            out%n = prim%n
            out%kappa = prim%kappa
            out%albedo = prim%kappa
            out%layer = prim%layer
            out%transform = identity()

            end function displacement_init

        function eval_disp(this, pos) result(res)

            implicit none

            class(displacement) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            res = displacement_fn(pos, this%prim, this%func)

        end function eval_disp

        function displacement_fn(p, prim, disp) result(res)

            implicit none

            class(sdf) :: prim
            procedure(primitive) :: disp
            type(vector), intent(IN) :: p
            real(kind=wp) :: res

            real(kind=wp) :: d1, d2

            d1 = prim%evaluate(p)
            d2 = disp(p)

            res = d1 + d2

        end function displacement_fn

        type(twist) function twist_init(prim, k) result(out)

            implicit none

            class(sdf), target :: prim
            real :: k

            out%k = k
            out%prim => prim
            out%mus = prim%mus
            out%mua = prim%mua
            out%hgg = prim%hgg
            out%g2 = prim%g2
            out%n = prim%n
            out%kappa = prim%kappa
            out%albedo = prim%kappa
            out%layer = prim%layer
            out%transform = identity()

            end function twist_init

        function eval_twist(this, pos) result(res)

            implicit none

            class(twist) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            res = twist_fn(pos, this%k, this%prim)

        end function eval_twist

        function twist_fn(p, k, prim) result(res)

            implicit none

            class(sdf) :: prim
            type(vector),  intent(IN) :: p
            real(kind=wp), intent(IN) :: k
            real(kind=wp) :: res

            real(kind=wp) :: c, s, x2, y2, z2

            c = cos(k * p%z)
            s = sin(k * p%z)
            x2 = c*p%x - s*p%y
            y2 = s*p%x + c*p%y
            z2 = p%z

            res = prim%evaluate(vector(x2, y2, z2))

        end function twist_fn

        type(repeat) function repeat_init(prim, c, la, lb) result(out)

            implicit none

            class(sdf), target :: prim
            type(vector),  intent(IN) :: la, lb
            real(kind=wp), intent(IN) :: c

            out%c = c
            out%la = la
            out%lb = lb
            out%prim => prim

            out%mus = prim%mus
            out%mua = prim%mua
            out%hgg = prim%hgg
            out%g2 = prim%g2
            out%n = prim%n
            out%kappa = prim%kappa
            out%albedo = prim%kappa
            out%layer = prim%layer
            out%transform = identity()

            end function repeat_init

        function eval_repeat(this, pos) result(res)

            implicit none

            class(repeat) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            res = repeat_fn(pos, this%c, this%la, this%lb, this%prim)

        end function eval_repeat

        function repeat_fn(p, c, la, lb, prim) result(res)

            use vector_class

            implicit none

            class(sdf) :: prim
            type(vector),  intent(IN) :: p, la, lb
            real(kind=wp), intent(IN) :: c
            real(kind=wp) :: res

            type(vector) :: q

            q = p - c*clamp_vec(nint(p/c), la, lb)
            res = prim%evaluate(q)

        end function repeat_fn

        type(extrude) function extrude_init(prim, h) result(out)

            implicit none

            class(sdf), target :: prim
            real(kind=wp), intent(IN)   :: h

            out%h = h
            out%prim => prim

            out%mus = prim%mus
            out%mua = prim%mua
            out%hgg = prim%hgg
            out%g2 = prim%g2
            out%n = prim%n
            out%kappa = prim%kappa
            out%albedo = prim%kappa
            out%layer = prim%layer
            out%transform = identity()

        end function extrude_init

        function eval_extrude(this, pos) result(res)

            implicit none

            class(extrude) :: this
            type(vector), intent(IN) :: pos
            real(kind=wp) :: res

            res = extrude_fn(pos, this%h, this%prim)

        end function eval_extrude

        function extrude_fn(p, h, prim) result(res)

            implicit none

            class(sdf) :: prim
            type(vector),  intent(IN) :: p
            real(kind=wp), intent(IN) :: h
            real(kind=wp) :: res

            type(vector)  :: w
            real(kind=wp) :: d

            d = prim%evaluate(p)
            w = vector(d, abs(p%z) - h, 0._wp)
            res = min(max(w%x, w%y), 0._wp) + length(max(w, 0._wp))

        end function extrude_fn

        function rotate_x(angle) result(r)
        ! rotation funcs from https://inspirnathan.com/posts/54-shadertoy-tutorial-part-8/
            use utils, only : deg2rad

            implicit none

            real(kind=wp), intent(IN) :: angle

            real(kind=wp) :: r(4, 4), c, s, a

            a = deg2rad(angle)
            c = cos(a)
            s = sin(a)

            r(:, 1) = [1._wp, 0._wp, 0._wp, 0._wp]
            r(:, 2) = [0._wp, c,  s,  0._wp]
            r(:, 3) = [0._wp,-s,  c,  0._wp]
            r(:, 4) = [0._wp, 0._wp, 0._wp, 1._wp]

        end function rotate_x

        function rotate_y(angle) result(r)

            use utils, only : deg2rad

            implicit none

            real(kind=wp), intent(IN) :: angle

            real(kind=wp) :: r(4, 4), c, s, a

            a = deg2rad(angle)
            c = cos(a)
            s = sin(a)

            r(:, 1) = [c,  0._wp, -s,  0._wp]
            r(:, 2) = [0._wp, 1._wp,  0._wp, 0._wp]
            r(:, 3) = [s,  0._wp,  c,  0._wp]
            r(:, 4) = [0._wp, 0._wp,  0._wp, 1._wp]

        end function rotate_y

        function rotate_z(angle) result(r)

            use utils, only : deg2rad

            implicit none

            real(kind=wp), intent(IN) :: angle

            real(kind=wp) :: r(4, 4), c, s, a

            a = deg2rad(angle)
            c = cos(a)
            s = sin(a)

            r(:, 1) = [c, -s,  0._wp, 0._wp]
            r(:, 2) = [s,  c,  0._wp, 0._wp]
            r(:, 3) = [0._wp, 0._wp, 1._wp, 0._wp]
            r(:, 4) = [0._wp, 0._wp, 0._wp, 1._wp]

        end function rotate_z

        function identity() result(r)

            implicit none

            real(kind=wp) :: r(4, 4)

            r(:, 1) = [1._wp, 0._wp, 0._wp, 0._wp]
            r(:, 2) = [0._wp, 1._wp, 0._wp, 0._wp]
            r(:, 3) = [0._wp, 0._wp, 1._wp, 0._wp]
            r(:, 4) = [0._wp, 0._wp, 0._wp, 1._wp]

        end function identity

        subroutine render(cnt, extent, samples, fname)

            use utils,     only : pbar
            use constants, only : fileplace
            use writer_mod

            implicit none

            type(container),        intent(IN) :: cnt(:)
            integer,                intent(IN) :: samples
            type(vector),           intent(IN) :: extent
            character(*), optional, intent(IN) :: fname

            type(vector)               :: pos, wid
            integer                    :: i, j, k, u, ns, id
            real(kind=wp)              :: x, y, z, ds(size(cnt)-1)
            real(kind=wp), allocatable :: image(:, :, :)
            type(pbar)                 :: bar

            character(len=:), allocatable  :: filename

            if(present(fname))then
                filename = fname
            else
                filename = "model.dat"
            end if
            ns = int(samples / 2)
            allocate(image(samples, samples, samples))
            wid = extent/real(ns, kind=wp)
            bar = pbar(samples)
!$omp parallel default(none) shared(cnt, ns, wid, image, samples, bar)&
!$omp private(i, x, y, z, pos, j, k, u, ds, id)
!$omp do
            do i = 1, samples
                call bar%progress()
                x = (i-ns) *wid%x
                do j = 1, samples
                    y = (j-ns) *wid%y
                    do k = 1, samples
                        z = (k-ns) * wid%z
                        pos = vector(x, y, z)
                        ds = 0._wp
                        do u = 1, size(ds)
                            ds(u) = cnt(u)%p%evaluate(pos)
                        end do

                        if(all(ds > 0._wp))then
                            id=0.
                        else
                            if(maxval(ds) < 0._wp)then
                                id = cnt(maxloc(ds,dim=1))%p%layer
                            else
                                id = cnt(minloc(ds,dim=1))%p%layer
                            end if
                        end if
                        if(minval(ds) > 0)then
                            id = 0
                        else
                            id = minloc(ds, dim=1)
                        end if
                        image(i, j, k) = minval(ds)!id
                    end do
                end do
            end do
!$OMP end  do
!$OMP end parallel
            call write(image, trim(fileplace)//filename)
        end subroutine render
end module sdfs


subroutine make_PDS_ref()
  use dyn_lc
  use rebin
  implicit none

  integer              :: i, j, reb_dim
  double precision, allocatable :: pw_ref_int(:,:), pw2_ref(:)
  ! real   , allocatable :: reb_freq(:), reb_pds_ref(:), reb_err_pds_ref(:)
  character (len = 200):: name_base_2
  logical              :: yes_no

  if (.not. allocated(pw_ref_int)) allocate(pw_ref_int(int_number, int_len_dim / 2))
  do i = 1, int_number
     call periodogram_frac_rms(lc_ref(i,:), pw_ref_int(i, :), dt, int_len_dim)
  enddo

!Declared in the modulae file
  if(.not. allocated(pw_ref)    ) allocate(pw_ref    (int_len_dim/2))
  if(.not. allocated(err_pw_ref)) allocate(err_pw_ref(int_len_dim/2))

  if(.not. allocated(pw2_ref)   ) allocate(pw2_ref   (int_len_dim/2))
  pw_ref  = 0.0
  pw2_ref = 0.0
  do j = 1, int_len_dim / 2
     do i = 1, int_number
        pw_ref  (j) = pw_ref  (j) + pw_ref_int(i, j)
        pw2_ref (j) = pw2_ref (j) + pw_ref_int(i, j)**2
     enddo
  enddo
  pw_ref  = pw_ref  / real(int_number)
  pw2_ref = pw2_ref / real(int_number)

  do j = 1, int_len_dim / 2 - 1
     err_pw_ref(j) = sqrt((pw2_ref(j)-pw_ref(j)**2)/real(int_number))
  enddo

  if (.not. allocated(freq)) then
     call make_freq_array()
  endif

!------------------- PRINT and REBIN ---------------------

  if (yes_no('   Do you want to save the PDS of the reference band light curve?')) then

      name_base_2 = 'ener_PDS_ref_band.dat'
      write(*,*) '   The name the reference band PDS is ', trim(name_base_2)
      open(71, file = trim(name_base_2))
      write(71, *) 'skip on'
      write(71, *) 'read serr 1 2'
      do j = 1, int_len_dim / 2 - 1
         write(71, *) (freq(j + 1) + freq(j)) * 0.5 , df, pw_ref(j), err_pw_ref(j)
      enddo
      write(71, *) 'no no'
      write(71, *) 'log x y on'
      close(71)

! -------------- REBIN --------------
      if (yes_no('   Do you want to rebin the PDS?')) then
         ! If(.not. allocated(Reb_Freq) ) allocate(Reb_freq (int_len_dim /2))
         call rebin_PDS(freq, pw_ref_int, int_number, int_len_dim, reb_dim)
         name_base_2 = 'ener_PDS_ref_band_reb.dat'
         write(*,*) '   The name the rebinned PDS is ', trim(name_base_2)
         open(71, file = trim(name_base_2))
         write(71, *) 'skip on'
         write(71, *) 'read serr 1 2'
         do j = 1, reb_dim - 1

            write(71, *) (reb_freq(j + 1) + reb_freq(j)) * 0.5 ,(reb_freq(j + 1) - reb_freq(j)) * 0.5, reb_pds(j), reb_err_pds(j)
         enddo
         write(71, *) 'no no'
         write(71, *) 'log x y on'
         close(71)

      endif

!--------------- Print final statements ---------------
      write(*,*)
      write(*,*) '   The normalisation of the PDS is rms-squared (see Uttley et al 2014 Eq.3)'
      write(*,*)
      write(*,*) '   Press Enter to continue'
      read(*,*)
      write(*,*)

   endif  ! end of the print and rebin stuff

   if (allocated(pw2_ref        )) deallocate(pw2_ref        )

 end subroutine make_PDS_ref


!     Manning drag formulation
!     Input: hgrid.gr3
!     Output: drag.gr3.0
!     Formulation: Cd=(fmc**2.0*9.810)/depth**(1.0/3.0) where depth>=h_min, and fmc is Manning coefficient.
!
!     ifort -Bstatic -O3 -o manning manning.f90
!     pgf90 -O2 -mcmodel=medium -Mbounds  -Bstatic -o manning manning.f90
      program friction

      implicit real*8(a-h,o-z)
      character*14 title
      integer :: i34(4)

      write(*,*)'enter manning coefficient'
      read(*,*)fmc
!      fmc=0.025 default
      write(*,*)'enter min depth (m):'
      read(*,*)h_min
      if(h_min<=0) stop 'min  depth should be >0'

      open(11,file='hgrid.gr3',status='old')
      open(12,file='drag.gr3.0')

      read(11,'(a14)') title
      write(12,*)fmc,h_min
      read(11,*) ne,np
      write(12,*) ne,np

      tmax=0.0
      do i=1,np
        read(11,*) node,x,y,depth
        !if (depth.lt.1.0) depth=1.0
        depth=max(depth,h_min)
        ffactor=(fmc**2.0*9.810)/depth**(1.0/3.0)
        if (ffactor.gt.tmax) tmax=ffactor
        write(12,21) node,x,y,ffactor
      enddo
      write(*,*) 'Maximum friction coefficient is ', tmax

      do i=1,ne
        read(11,*)j,k,i34(1:k)
        write(12,*)i,k,i34(1:k)
      enddo !i

   20 format(i9,1x,f11.9,1x,f4.1)
   21 format(i9,1x,3(1x,e14.7))

      stop
      end


C igual que automatico pero lleva el factor multiplicatico cte
c de la presion en el ultimo nodo (como nodosp que cuelga de blends2)

	subroutine automaticop(mi,mp,ntotal4,difer,npos,rt,t)

	implicit real*4 (a-h,o-z)
	include 'PARAMETER' !por kt,kn,kl y kld
	parameter (kld4=4*kld)

        integer npos(*),ntotal4,nodosposibles(kt),icalerr
        real*4 difer(*),rt(*),derivada(kt),t(*)
        real*4 x(kt),z(kt),f(kt,kt),tau(kt)

        common/nodosposibles/nummax,nodosposibles
        common/ndata/ndata !para fperfil2 y automatico
        common/tau/tau
        common/calerr/icalerr !si calculo errores=1 else =0

	data iprimeraveza/0/

c calculamos los posibles nodos
       ntau=mi
        if(iprimeraveza.eq.0)then
           iprimeraveza=1
           k=2
           nodosposibles(1)=1
           nodosposibles(2)=2
           do j=3,ntau
              resto=(ntau-1)-(j-1)*((ntau-1)/(j-1))
              if(resto.eq.0)then
                 k=k+1
                 nodosposibles(k)=j
              end if
           end do
           nummax=k
        end if

c calculamos la derivada de la chi^2
c        print*,'automatico nmax ',mi
        do i=1,mi
           s=0.
           do j=1,ndata
              k=(i-1)*ntotal4+npos(j)
              s=s+difer(j)*rt(k)
           end do
           derivada(i)=s
c           print*,i,derivada(i)
        end do

c buscamos el numero de nodos optimo
        if(icalerr.eq.0)then
           if(mp.gt.1)then
             call criterio(ntau,derivada,mi,mp)
           else
             mi=1
           end if
        else
           print*,'nodos (aut) para errores',mi
        end if

c        print*,'cuantos pongo'
c        read*,mi

        if(mi.gt.1)then
	    m=(ntau-1)/(mi-1)   !n es el numero de taus
                            !m es el numero de pasos en cada subintervalo
	    do i=1,mi        !mi es el numero de nodos total i el indice del nodo
	       j=(i-1)*m+1   !j el indice en tau
	       x(i)=tau(j)   !x(i) es el valor de tau en el nodo
            end do

	    call splines22(x,x,mi-2,ntau,tau,z,f)
        end if

        call nodos_subp(rt,ntau,mi,f,ntotal4,t)

	return
        end
c _____________________________________________________
	subroutine nodos_subp(rt,n,no,f,ntotal4,t)

	implicit real*4 (a-h,o-z)
	include 'PARAMETER' !por kt,kn,kl y kld

        integer no
        real*4 rt(*),f(kt,kt),gr(kt),t(*),y(kt)

	if(no.le.0)return

	if(no.eq.1)then   !si perturbacion constante
           ymedio=0
           do i=1,n
              ymedio=ymedio+t(i)
           end do
           ymedio=ymedio/float(n)

           do ilam=1,ntotal4
	      sumart=0.
              do i=1,n
                 kk=(i-1)*ntotal4+ilam
                 sumart=sumart+rt(kk)
              end do
              rt(ilam)=sumart*ymedio
           end do
	else
c          do j=1,n
c            print*,'automatico ',j,t(j)
c          end do

	   m=(n-1)/(no-1)   !n es el numero de taus
                            !m es el numero de pasos en cada subintervalo
	   do i=1,no        !no es el numero de nodos total i el indice del nodo
	      j=(i-1)*m+1   !j el indice en tau
	      y(i)=t(j)    !y(i) es el valor del parametro en el nodo
c              print*,'automatico n no i j y',n,no,i,j,y(i)
           end do

           do ilam=1,ntotal4
	      do i=1,no
	         ggg=0.
	         do j=1,n
                    kk=(j-1)*ntotal4+ilam
	            ggg=ggg+rt(kk)*f(j,i)
                 end do
	         gr(i)=ggg
	      end do
	      do i=1,no
                 kk=(i-1)*ntotal4+ilam
 	         rt(kk)=gr(i)*y(no)
	      end do
           end do
c           print*,'automatico rt(',kk,')=',rt(kk)
	end if
	return
	end

c _________________________________________________________________


!*==claic1.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLAIC1 applies one step of incremental condition estimation.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLAIC1 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
!
!       .. Scalar Arguments ..
!       INTEGER            J, JOB
!       REAL               SEST, SESTPR
!       COMPLEX            C, GAMMA, S
!       ..
!       .. Array Arguments ..
!       COMPLEX            W( J ), X( J )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLAIC1 applies one step of incremental condition estimation in
!> its simplest version:
!>
!> Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
!> lower triangular matrix L, such that
!>          twonorm(L*x) = sest
!> Then CLAIC1 computes sestpr, s, c such that
!> the vector
!>                 [ s*x ]
!>          xhat = [  c  ]
!> is an approximate singular vector of
!>                 [ L      0  ]
!>          Lhat = [ w**H gamma ]
!> in the sense that
!>          twonorm(Lhat*xhat) = sestpr.
!>
!> Depending on JOB, an estimate for the largest or smallest singular
!> value is computed.
!>
!> Note that [s c]**H and sestpr**2 is an eigenpair of the system
!>
!>     diag(sest*sest, 0) + [alpha  gamma] * [ conjg(alpha) ]
!>                                           [ conjg(gamma) ]
!>
!> where  alpha =  x**H*w.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOB
!> \verbatim
!>          JOB is INTEGER
!>          = 1: an estimate for the largest singular value is computed.
!>          = 2: an estimate for the smallest singular value is computed.
!> \endverbatim
!>
!> \param[in] J
!> \verbatim
!>          J is INTEGER
!>          Length of X and W
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is COMPLEX array, dimension (J)
!>          The j-vector x.
!> \endverbatim
!>
!> \param[in] SEST
!> \verbatim
!>          SEST is REAL
!>          Estimated singular value of j by j matrix L
!> \endverbatim
!>
!> \param[in] W
!> \verbatim
!>          W is COMPLEX array, dimension (J)
!>          The j-vector w.
!> \endverbatim
!>
!> \param[in] GAMMA
!> \verbatim
!>          GAMMA is COMPLEX
!>          The diagonal element gamma.
!> \endverbatim
!>
!> \param[out] SESTPR
!> \verbatim
!>          SESTPR is REAL
!>          Estimated singular value of (j+1) by (j+1) matrix Lhat.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is COMPLEX
!>          Sine needed in forming xhat.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is COMPLEX
!>          Cosine needed in forming xhat.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE CLAIC1(Job,J,X,Sest,W,Gamma,Sestpr,S,C)
      IMPLICIT NONE
!*--CLAIC1139
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER J , Job
      REAL Sest , Sestpr
      COMPLEX C , Gamma , S
!     ..
!     .. Array Arguments ..
      COMPLEX W(J) , X(J)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE , TWO
      PARAMETER (ZERO=0.0E0,ONE=1.0E0,TWO=2.0E0)
      REAL HALF , FOUR
      PARAMETER (HALF=0.5E0,FOUR=4.0E0)
!     ..
!     .. Local Scalars ..
      REAL absalp , absest , absgam , b , eps , norma , s1 , s2 , scl , &
     &     t , test , tmp , zeta1 , zeta2
      COMPLEX alpha , cosine , sine
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , CONJG , MAX , SQRT
!     ..
!     .. External Functions ..
      REAL SLAMCH
      COMPLEX CDOTC
      EXTERNAL SLAMCH , CDOTC
!     ..
!     .. Executable Statements ..
!
      eps = SLAMCH('Epsilon')
      alpha = CDOTC(J,X,1,W,1)
!
      absalp = ABS(alpha)
      absgam = ABS(Gamma)
      absest = ABS(Sest)
!
      IF ( Job==1 ) THEN
!
!        Estimating largest singular value
!
!        special cases
!
         IF ( Sest==ZERO ) THEN
            s1 = MAX(absgam,absalp)
            IF ( s1==ZERO ) THEN
               S = ZERO
               C = ONE
               Sestpr = ZERO
            ELSE
               S = alpha/s1
               C = Gamma/s1
               tmp = SQRT(S*CONJG(S)+C*CONJG(C))
               S = S/tmp
               C = C/tmp
               Sestpr = s1*tmp
            ENDIF
            RETURN
         ELSEIF ( absgam<=eps*absest ) THEN
            S = ONE
            C = ZERO
            tmp = MAX(absest,absalp)
            s1 = absest/tmp
            s2 = absalp/tmp
            Sestpr = tmp*SQRT(s1*s1+s2*s2)
            RETURN
         ELSEIF ( absalp<=eps*absest ) THEN
            s1 = absgam
            s2 = absest
            IF ( s1<=s2 ) THEN
               S = ONE
               C = ZERO
               Sestpr = s2
            ELSE
               S = ZERO
               C = ONE
               Sestpr = s1
            ENDIF
            RETURN
         ELSEIF ( absest<=eps*absalp .OR. absest<=eps*absgam ) THEN
            s1 = absgam
            s2 = absalp
            IF ( s1<=s2 ) THEN
               tmp = s1/s2
               scl = SQRT(ONE+tmp*tmp)
               Sestpr = s2*scl
               S = (alpha/s2)/scl
               C = (Gamma/s2)/scl
            ELSE
               tmp = s2/s1
               scl = SQRT(ONE+tmp*tmp)
               Sestpr = s1*scl
               S = (alpha/s1)/scl
               C = (Gamma/s1)/scl
            ENDIF
            RETURN
         ELSE
!
!           normal case
!
            zeta1 = absalp/absest
            zeta2 = absgam/absest
!
            b = (ONE-zeta1*zeta1-zeta2*zeta2)*HALF
            C = zeta1*zeta1
            IF ( b>ZERO ) THEN
               t = C/(b+SQRT(b*b+C))
            ELSE
               t = SQRT(b*b+C) - b
            ENDIF
!
            sine = -(alpha/absest)/t
            cosine = -(Gamma/absest)/(ONE+t)
            tmp = SQRT(sine*CONJG(sine)+cosine*CONJG(cosine))
            S = sine/tmp
            C = cosine/tmp
            Sestpr = SQRT(t+ONE)*absest
            RETURN
         ENDIF
!
      ELSEIF ( Job==2 ) THEN
!
!        Estimating smallest singular value
!
!        special cases
!
         IF ( Sest==ZERO ) THEN
            Sestpr = ZERO
            IF ( MAX(absgam,absalp)==ZERO ) THEN
               sine = ONE
               cosine = ZERO
            ELSE
               sine = -CONJG(Gamma)
               cosine = CONJG(alpha)
            ENDIF
            s1 = MAX(ABS(sine),ABS(cosine))
            S = sine/s1
            C = cosine/s1
            tmp = SQRT(S*CONJG(S)+C*CONJG(C))
            S = S/tmp
            C = C/tmp
            RETURN
         ELSEIF ( absgam<=eps*absest ) THEN
            S = ZERO
            C = ONE
            Sestpr = absgam
            RETURN
         ELSEIF ( absalp<=eps*absest ) THEN
            s1 = absgam
            s2 = absest
            IF ( s1<=s2 ) THEN
               S = ZERO
               C = ONE
               Sestpr = s1
            ELSE
               S = ONE
               C = ZERO
               Sestpr = s2
            ENDIF
            RETURN
         ELSEIF ( absest<=eps*absalp .OR. absest<=eps*absgam ) THEN
            s1 = absgam
            s2 = absalp
            IF ( s1<=s2 ) THEN
               tmp = s1/s2
               scl = SQRT(ONE+tmp*tmp)
               Sestpr = absest*(tmp/scl)
               S = -(CONJG(Gamma)/s2)/scl
               C = (CONJG(alpha)/s2)/scl
            ELSE
               tmp = s2/s1
               scl = SQRT(ONE+tmp*tmp)
               Sestpr = absest/scl
               S = -(CONJG(Gamma)/s1)/scl
               C = (CONJG(alpha)/s1)/scl
            ENDIF
            RETURN
         ELSE
!
!           normal case
!
            zeta1 = absalp/absest
            zeta2 = absgam/absest
!
            norma = MAX(ONE+zeta1*zeta1+zeta1*zeta2,                    &
     &              zeta1*zeta2+zeta2*zeta2)
!
!           See if root is closer to zero or to ONE
!
            test = ONE + TWO*(zeta1-zeta2)*(zeta1+zeta2)
            IF ( test>=ZERO ) THEN
!
!              root is close to zero, compute directly
!
               b = (zeta1*zeta1+zeta2*zeta2+ONE)*HALF
               C = zeta2*zeta2
               t = C/(b+SQRT(ABS(b*b-C)))
               sine = (alpha/absest)/(ONE-t)
               cosine = -(Gamma/absest)/t
               Sestpr = SQRT(t+FOUR*eps*eps*norma)*absest
            ELSE
!
!              root is closer to ONE, shift by that amount
!
               b = (zeta2*zeta2+zeta1*zeta1-ONE)*HALF
               C = zeta1*zeta1
               IF ( b>=ZERO ) THEN
                  t = -C/(b+SQRT(b*b+C))
               ELSE
                  t = b - SQRT(b*b+C)
               ENDIF
               sine = -(alpha/absest)/t
               cosine = -(Gamma/absest)/(ONE+t)
               Sestpr = SQRT(ONE+t+FOUR*eps*eps*norma)*absest
            ENDIF
            tmp = SQRT(sine*CONJG(sine)+cosine*CONJG(cosine))
            S = sine/tmp
            C = cosine/tmp
            RETURN
!
         ENDIF
      ENDIF
!
!     End of CLAIC1
!
      END SUBROUTINE CLAIC1


      FUNCTION amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,fac)
      INTEGER ihi,mp,ndim,np,NMAX
      REAL amotsa,fac,yb,yhi,p(mp,np),pb(np),psum(np),y(mp),funk
      PARAMETER (NMAX=200)
      EXTERNAL funk
CU    USES funk,ran1
      INTEGER idum,j
      REAL fac1,fac2,tt,yflu,ytry,ptry(NMAX),ran1
      COMMON /ambsa/ tt,idum
      fac1=(1.-fac)/ndim
      fac2=fac1-fac
      do 11 j=1,ndim
        ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11    continue
      ytry=funk(ptry)
      if (ytry.le.yb) then
        do 12 j=1,ndim
          pb(j)=ptry(j)
12      continue
        yb=ytry
      endif
      yflu=ytry-tt*log(ran1(idum))
      if (yflu.lt.yhi) then
        y(ihi)=ytry
        yhi=yflu
        do 13 j=1,ndim
          psum(j)=psum(j)-p(ihi,j)+ptry(j)
          p(ihi,j)=ptry(j)
13      continue
      endif
      amotsa=yflu
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/amotsa.for


	FUNCTION PS_LFCV ( datain, nparm, thepar, tvflag )
C************************************************************************
C* PS_LFCV								*
C*									*
C* This function returns the level of free convection for a parcel	*
C* with THTE of THEPAR.  TVFLAG determines if temperature or virtual	*
C* temperature is used in the calculation.  If there are multiple	*
C* LFC's, the one closest to the ground is returned.			*
C*									*
C* REAL PS_LFCV ( DATAIN, NPARM, THEPAR, TVFLAG )			*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of dat set parameters	*
C*	THEPAR		REAL		Parcel THTE in Kelvin		*
C*	TVFLAG		LOGICAL		Temperature flag		*
C*									*
C* Output parameters:							*
C*	PS_LFCV		REAL		Level of free convection in mb	*
C**									*
C* Log:									*
C* G. Huffman/USRA	 9/89	Adapted from PS_EQLV			*
C* M. desJardins/GSFC	 7/90	Reorganized for GEMPAK 5		*
C* K. Brill/NMC		01/92	Avoid undergrd man lvls			*
C* K. Brill/EMC		 1/96	Set limit on passes in final loop	*
C* T. Lee/GSC		 8/97	Cleaned up; Added a temperature flag	*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( EPSI = .6077 )
	REAL		datain ( nparm, * )
C*
	REAL		datlev ( MMPARM ),  outdat ( MMPARM ),
     +			spt (10), spb (10), stt (10), stb (10)
	LOGICAL		tvflag, indx
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	PS_LFCV = RMISSD
C
	IF  ( ERMISS ( thepar ) )  RETURN
C
C*	Get the surface pressure value.
C
	CALL PC_GLEV ( 1, datain, nparm, datlev, ier )
	psfc = datlev (1)
C
C*	Find the highest level which reports pressure and temperature
C*	data.
C
	CALL PC_FTOP  ( datain, nparm, numlev, outdat, ier )
	IF  ( numlev .le. 1 )  RETURN
C
C*	Get top level pressure and temperature; initialize the
C*	number of crossings.
C
	pbot    = outdat (1)
	tbpark  = PR_TMST ( thepar, pbot , 0. )
	tbpar   = PR_TMKC ( tbpark )
	IF  ( tvflag )  THEN
	    tebot  = outdat (7)
	    tbpark = PR_TVRK ( tbpar, tbpar, pbot )
	    tbpar  = PR_TMKC ( tbpark )
	  ELSE
	    tebot = outdat (2)
	END IF
	ncross = 0
C
C*	Get LCL pressure and temperature.
C
	CALL PS_PRCL  ( datain, nparm, 500., 3, 1, depth,
     +			idcord, pavg, tavg, tdavg, uavg, vavg,
     +			zavg, thavg, rmxavg, ier )
	IF  ( ERMISS ( pavg  ) .or. ERMISS ( tavg ) .or.
     +	      ERMISS ( tdavg ) .or. ( ier .ne. 0 ) )  THEN
	    RETURN
	  ELSE
	    tlcl  = PR_TLCL ( tavg, tdavg )
	    plcl  = PR_PLCL ( tavg, pavg, tlcl )
	    CALL PC_CMDT ( 5, 6, 7, plcl, 1, datain, outdat, ier )
	    IF  ( ier .ne. 0 )  RETURN
	END IF
C
C*	Loop down through the sounding finding plus-to-minus crossings.
C*	Missing PRES or TMPC is an error.
C
	indx = .false.
	DO  WHILE ( (numlev .gt. 1) .and. (pbot .le. plcl) )
	  ptop  = pbot
	  tetop = tebot
	  tupar = tbpar
	  numlev = numlev - 1
	  CALL PC_GLEV  ( numlev, datain, nparm, datlev, ier )
	  CALL PC_COMP  ( 5,    datlev, outdat, ier )
	  IF ( datlev (1) .le. psfc ) THEN
	    IF  ( ERMISS (outdat(1)) .or. ERMISS (outdat(2)) )  RETURN
	    pbot   = outdat (1)
	    tbpark = PR_TMST ( thepar, pbot, 0. )
	    tbpar  = PR_TMKC ( tbpark )
	    IF  ( tvflag )  THEN
		tebot  = outdat (7)
		tbpark = PR_TVRK ( tbpar, tbpar, pbot )
		tbpar  = PR_TMKC ( tbpark )
	      ELSE
		tebot  = outdat (2)
	    END IF
	    IF  ( tupar .gt. tetop )  indx = .true.
C
C*	    If we've hit a crossing and still have room in the storage
C*	    arrays, save useful parameters.
C
	    IF  ( ( tetop .lt. tupar ) .and.
     +		  ( tebot .ge. tbpar ) .and. ( ncross .lt. 10 ) )  THEN
		ncross       = ncross + 1
		spt (ncross) = ptop
		spb (ncross) = pbot
		stt (ncross) = tetop
		stb (ncross) = tebot
	    END IF
	  END IF
	END DO
C
C*      If no plus-to-minus crossings occurred, return PLCL when
C*	the parcel's temperature is warmer than the environment's.
C
        IF  ( ncross .eq. 0 )  THEN
	    IF  ( indx )  PS_LFCV = plcl
	    RETURN
	  ELSE
C
C*	  More than 1 crossing; pick the lowest one.
C
	    ic = ncross
	END IF
C
C*	Interpolation for virtual temperature case:
C*
C*	Assume linear LN(P) variation for the temperature and mixing
C*	ratio (q).  Find the linear equations for T and q, and equate
C*	the virtual temperatures at the intersecting point for the
C*	parcel and the environment. Solve for P.
C
	IF  ( tvflag )  THEN
C
C*	    Get enviromental data at the pressure levels.
C
	    CALL PC_CMDT ( 5, 6, 7, spt (ic), 1, datain, outdat, ier )
	    ptt  =  PR_TMCK ( outdat (2) )
	    IF  ( ERMISS ( outdat (3) ) ) outdat (3) = outdat (2)
	    pmx  =  PR_MIXR ( outdat (3), spt (ic) )
	    CALL PC_CMDT ( 5, 6, 7, spb (ic), 1, datain, outdat, ier )
	    qtt  =  PR_TMCK ( outdat (2) )
	    IF  ( ERMISS ( outdat (3) ) ) outdat (3) = outdat (2)
	    qmx  =  PR_MIXR ( outdat (3), spb (ic) )
C
C*	    Compute linear coefficients for T and q on the
C*	    environmental temperature profile.
C
	    rpb  = ALOG ( spb (ic) )
	    rpt  = ALOG ( spt (ic) )
	    pdf  = ( rpb - rpt )
	    ae   = ( qmx - pmx ) * .001 / pdf
	    be   = ( pmx * rpb - qmx * rpt ) *.001 / pdf
	    ce   = ( qtt - ptt ) / pdf
	    de   = ( ptt * rpb - qtt * rpt ) / pdf
C
C*	    Get parcel data at the pressure levels.
C
	    xtt  =  PR_TMST ( thepar, spt (ic), 0. )
	    xttc =  PR_TMKC ( xtt )
	    xmx  =  PR_MIXR ( xttc, spt (ic) )
	    ytt  =  PR_TMST ( thepar, spb (ic), 0. )
	    yttc =  PR_TMKC ( ytt )
	    ymx  =  PR_MIXR ( yttc, spb (ic) )
C
C*	    Compute linear coefficients for T and q on the parcel
C*	    temperature profile.
C
	    ap   = ( ymx - xmx ) * .001 / pdf
	    bp   = ( xmx * rpb - ymx * rpt ) * .001 / pdf
	    cp   = ( ytt - xtt ) / pdf
	    dp   = ( xtt * rpb - ytt * rpt ) / pdf
C
C*	    Solve for P.
C
	    a    = ae * ce - ap * cp
	    b    = ( be * ce - bp * cp ) + ( ae * de - ap * dp )
     +		   + ( ce - cp ) / EPSI
	    c    = be * de - bp * dp + ( de - dp ) / EPSI
	    pest = ( - b + ( b ** 2 - 4. * a * c ) ** .5 ) / ( 2. * a )
	    pest = EXP ( pest )
	  ELSE
C
C*	    Interpolation for temperature case:
C*
C*	    Do a linear interpolation in LN(P) to get PEST, an estimate
C*	    of the pressure that corresponds to THEPAR.  Iterately get
C*	    the interpolated data at PEST, compute the saturated THTE
C*	    at that level, and do a linear interpolation in LN(P)
C*	    for the new PEST.
C
	    oldest = RMISSD
	    stt (ic ) = PR_THTE ( spt (ic), stt (ic), stt (ic) )
	    stb (ic ) = PR_THTE ( spb (ic), stb (ic), stb (ic) )
	    pest   = spb (ic) *
     +		   ( spt (ic) / spb (ic) ) ** ( (thepar   - stb (ic)) /
     +					      (stt (ic) - stb (ic)) )
C
	    kcnt = 200
	    DO  WHILE ( ABS ( pest - oldest ) .gt. 0.01 .and.
     +			kcnt .gt. 0 )
		oldest = pest
		IF  ( pest .le. spt (ic) .or. pest .ge. spb (ic) )  THEN
		    PS_LFCV = pest
		    RETURN
		END IF
		CALL PC_CMDT ( 5, 6, 7, oldest, 1, datain, outdat, ier )
C
		teest = PR_THTE ( outdat (1), outdat (2), outdat (2) )
		IF  ( teest .gt. thepar )  THEN
		    rtt = stt (ic)
		    rpt = spt (ic)
		  ELSE
		    rtt = stb (ic)
		    rpt = spb (ic)
		END IF
		pest  = oldest * ( rpt / oldest ) **
     +			( ( thepar - teest ) / ( rtt - teest ) )
		kcnt = kcnt - 1
	    END DO
	    IF ( kcnt .eq. 0 ) pest = RMISSD
	END IF
C*
	IF ( pest .gt. plcl ) pest = plcl
	PS_LFCV = pest
	RETURN
	END


! Module contains routines involved in initialising, allocating, deallocating
! all the various matrices and arrays that are needed for simulation
!
module initialise
        use globals
        use display
        implicit none
contains
        ! allocate the memory
        subroutine alloc_matrices()
                allocate(kx(N,N),ky(N,N),kz(N,N),k_sq(N,N),kinv_sq(N,N),cut(N,N))
                !underlying mesh
                allocate(X(N,N),Y(N,N))
                ! initial omega and velocity values
                allocate(om_i(N,N),u_0(N,N),v_0(N,N))
                allocate(uu_hat_temp(N,N),vv_hat_temp(N,N),ww_hat_temp(N,N))
                !projection tensors
                allocate(p11(N,N),p12(N,N),p13(N,N),p21(N,N),p22(N,N),p23(N,N),p31(N,N),p32(N,N),p33(N,N))
                ! integrating factor
                allocate(iuu_hat(N,N),ivv_hat(N,N),iww_hat(N,N),irho_hat(N,N))
                ! time step variables
                allocate(iuu_hat_new(N,N),ivv_hat_new(N,N),iww_hat_new(N,N),irho_hat_new(N,N))
                allocate(ifactor(N,N),t_ifactor(N,N),exp_ifactor_1(N,N),exp_ifactor_2(N,N))

                ! right side variables
                allocate(rr(N,N),ur(N,N),vr(N,N),wr(N,N))
                allocate(rr_old(N,N),ur_old(N,N),vr_old(N,N),wr_old(N,N))
                allocate(growth_rate(num_steps))
                allocate(tote(num_steps))
        end subroutine alloc_matrices

        ! iniitialise wavenumber matrices
        subroutine init_wn()
                integer :: i,j
                kz=ukz
                forall(i=1:N,j=1:N/2+1) kx(i,j)=cmplx(tpiL,0,8)*cmplx(j-1,0,8)
                forall(i=1:N,j=N/2+2:N) kx(i,j)=cmplx(tpiL,0,8)*cmplx(j-N-1,0,8)
                ky=transpose(kx)
                k_sq=kx*kx+ky*ky+kz*kz
                kinv_sq=1.0_8/k_sq
                if (hypervis==1) then
                        k_sq=k_sq*k_sq
                end if
                !dealiasing information using 2/3s rule
                print *, 'Using dealiasing rule of: ', dealias_coeff
                n_k=ceiling(dealias_coeff*N)
                if(mod(n_k,2)==1) then
                        n_k=n_k-1
                end if
                n_k=(N-n_k)/2
                cut=cmplx(1.0,0,8)
                forall(i=1:N,j=(N/2-n_k+1):(N/2+n_k+1)) cut(i,j)=0
                cut=cut*transpose(cut)
        end subroutine init_wn

        !initialise the grid
        subroutine init_grid()
                real(kind=8), dimension(N) :: xx
                integer ::  i,j
                do i=1,N
                        xx(i)=-L/2.0_8+dx*real(i,8)
                end do
                forall(i=1:N,j=1:N) X(i,j)=xx(j)
                Y=transpose(X)
        end subroutine init_grid

        !initialise the projection tensor
        subroutine init_projection()
                p11=1-kx*kx*kinv_sq
                p22=1-ky*ky*kinv_sq
                p33=1-kz*kz*kinv_sq
                p12=-kx*ky*kinv_sq
                p13=-kx*kz*kinv_sq
                p23=-ky*kz*kinv_sq
                p32=p23
                p21=p12
                p31=p13
        end subroutine init_projection

        subroutine init_conditions(cont,kzs)
                integer, intent(in) :: cont
                real(kind=8), dimension(:,:), allocatable  ::uur,vvr,wwr
                character(len=30) :: fname
                character(len=30), intent(in) :: kzs
                !if new run generate new initial conditions
                if(cont==0) then
                        allocate(uur(N,N),vvr(N,N),wwr(N,N))
                        call random_number(uur)
                        call random_number(vvr)
                        call random_number(wwr)
                        uu=cmplx(uur,0,8)
                        vv=cmplx(vvr,0,8)
                        ww=cmplx(wwr,0,8)
                        rho=cmplx(0,0,8)
                else
                        fname='k_z.'//trim(kzs)//'.u.dat'
                        call mat_r2f_c(uu,fname,N)
                        fname='k_z.'//trim(kzs)//'.v.dat'
                        call mat_r2f_c(vv,fname,N)
                        fname='k_z.'//trim(kzs)//'.w.dat'
                        call mat_r2f_c(ww,fname,N)
                        fname='k_z.'//trim(kzs)//'.rho.dat'
                        call mat_r2f_c(rho,fname,N)
                end if
        end subroutine init_conditions

        !deallocate memory
        subroutine dealloc_matrices()
        end subroutine dealloc_matrices

end module initialise