module growthmod
	implicit none
	contains
 !===================================
 subroutine initialize_gw3(d_connect,d_node,peti_coord,leaf_coord,max_leaf_angle,&
	max_leaf_length,max_leaf_width,leaf_shape_rate,peti_length,max_length)
	integer,allocatable,intent(out)::d_connect(:,:)
	real(8),allocatable,intent(out)::d_node(:,:),peti_coord(:,:,:),leaf_coord(:,:,:,:)
	real(8),intent(in)::max_leaf_angle,&
	max_leaf_length,max_leaf_width,leaf_shape_rate,peti_length,max_length
	real(8) r1,r2,x_coord,&
	y_coord,z_coord,direction,pi,angle,x_coord_1,y_coord_1,z_coord_1,&
	peti_RUE,mid_length,width,length
	real(8),allocatable::a(:),b(:),z(:),nvec(:),a_unit(:),b_unit(:)

	integer int_num,real_value

	integer i,j,n,m,o,parent,itr
	integer :: seedsize
	integer,allocatable :: seed(:)
	real :: rnd
	integer :: c !時間を入れる
	pi=3.14159265350d0

	int_num=3
	real_value=5
	allocate(d_connect(2,int_num),d_node(2,real_value))
	allocate(peti_coord(2,4,3),leaf_coord(2,3,4,3)   )
	allocate(a(3),b(3),z(3),nvec(3),a_unit(3),b_unit(3) )
	leaf_coord(:,:,:,:)=0.0d0
	peti_coord(:,:,:)=0.0d0
	!initisalize d_connect
	d_connect(1,1)=1
	d_connect(1,2)=-1 !Apical No.
	d_connect(1,3)=0

	d_connect(2,1)=1
	d_connect(2,2)=0 !Apical No.
	d_connect(2,3)=0

	!initialize d_node
	d_node(1,1)=0.0d0
	d_node(1,2)=0.0d0
	d_node(1,3)=0.0d0
	d_node(1,4)=1.0d0
	d_node(1,5)=0.0d0

	d_node(2,1)=0.0d0
	d_node(2,2)=0.0d0
	d_node(2,3)=max_length
	d_node(2,4)=1.0d0
	d_node(2,5)=0.0d0

	!initialize peti_coord(:,:,:)============

	!random number generation
	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	angle=((rnd-0.50d0)+1.0d0)*max_leaf_angle

	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	length=((rnd-0.50d0)+1.0d0)*peti_length

	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	direction=rnd*360.0d0

	r1=cos(pi*(angle/180.0d0))*length
	r2=sin(pi*(angle/180.0d0))*length

	x_coord=d_node(2,1)
	y_coord=d_node(2,2)
	z_coord=d_node(2,3)

	x_coord=x_coord+r2*cos( pi*(direction/180.0d0) )
	y_coord=y_coord+r2*sin( pi*(direction/180.0d0) )
	z_coord=z_coord+r1

	peti_coord(1,:,:)=0.0d0

	peti_coord(2,1,1)=x_coord
	peti_coord(2,1,2)=y_coord
	peti_coord(2,1,3)=z_coord

	!second-fourth
	do i=2,4
		!random number generation
		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		angle=((rnd-0.50d0)+1.0d0)*max_leaf_angle

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		if(i==2)then
			peti_RUE=0.1
		else
			peti_RUE=0.05
		endif

		length=((rnd-0.50d0)+1.0d0)*max_leaf_length*peti_RUE

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		if(i==2)then
			direction=rnd*360.0d0
		elseif(i==3)then
			direction=direction+120
		elseif(i==4)then
			direction=direction-240
		endif
		r1=cos(pi*(angle/180.0d0))*length
		r2=sin(pi*(angle/180.0d0)  )*length

		x_coord_1=x_coord
		y_coord_1=y_coord
		z_coord_1=z_coord

		x_coord_1=x_coord_1+r2*cos( pi*(direction/180.0d0) )
		y_coord_1=y_coord_1+r2*sin( pi*(direction/180.0d0) )
		z_coord_1=z_coord_1+r1

		peti_coord(2,i,1)=x_coord_1
		peti_coord(2,i,2)=y_coord_1
		peti_coord(2,i,3)=z_coord_1
	enddo

	!leaf generate
	do i=1,3
		!random number generation
		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		angle=((rnd-0.50d0)+1.0d0)*max_leaf_angle

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		length=((rnd-0.50d0)+1.0d0)*max_leaf_length
		width=((rnd-0.50d0)+1.0d0)*max_leaf_width

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		if(i==1)then
			direction=rnd*360.0d0
		elseif(i==2)then
			direction=direction+120
		elseif(i==3)then
			direction=direction-240
		endif

		r1=cos(pi*(angle/180.0d0))*length
		r2=sin(pi*(angle/180.0d0)  )*length

		x_coord_1=peti_coord(2,i,1)
		y_coord_1=peti_coord(2,i,2)
		z_coord_1=peti_coord(2,i,3)

		x_coord_1=x_coord_1+r2*cos( pi*(direction/180.0d0) )
		y_coord_1=y_coord_1+r2*sin( pi*(direction/180.0d0) )
		z_coord_1=z_coord_1+r1

		leaf_coord(2,i,3,1)=x_coord_1
		leaf_coord(2,i,3,2)=y_coord_1
		leaf_coord(2,i,3,3)=z_coord_1

		leaf_coord(2,i,1,1)=peti_coord(2,i,1)
		leaf_coord(2,i,1,2)=peti_coord(2,i,2)
		leaf_coord(2,i,1,3)=peti_coord(2,i,3)
		!
		a(1)=leaf_coord(2,i,3,1)-peti_coord(2,i,1)
		a(2)=leaf_coord(2,i,3,2)-peti_coord(2,i,2)
		a(3)=leaf_coord(2,i,3,3)-peti_coord(2,i,3)

		z(1)=0.0d0
		z(2)=0.0d0
		z(3)=1.0d0

		a_unit(:)=a(:)/dsqrt(dot_product(a,a))

		b(:)=z(:)-dot_product(a,z)*a_unit(:)

		b_unit(:)=b(:)/dsqrt(dot_product(b,b))

		nvec(1)=a_unit(2)*b_unit(3)-a_unit(3)*b_unit(2)
		nvec(2)=a_unit(3)*b_unit(1)-a_unit(1)*b_unit(3)
		nvec(3)=a_unit(1)*b_unit(2)-a_unit(2)*b_unit(1)

		nvec(:)=nvec(:)/dsqrt(dot_product(nvec,nvec))

		mid_length=1.0d0/(1.0d0+leaf_shape_rate)*length

		j=2

			x_coord_1=peti_coord(2,i,1)
			y_coord_1=peti_coord(2,i,2)
			z_coord_1=peti_coord(2,i,3)

			x_coord_1=x_coord_1+mid_length*a_unit(1)
			y_coord_1=y_coord_1+mid_length*a_unit(2)
			z_coord_1=z_coord_1+mid_length*a_unit(3)

			leaf_coord(2,i,j,1)=x_coord_1-0.50d0*width*nvec(1)
			leaf_coord(2,i,j,2)=y_coord_1-0.50d0*width*nvec(2)
			leaf_coord(2,i,j,3)=z_coord_1-0.50d0*width*nvec(3)

		j=4
			x_coord_1=peti_coord(2,i,1)
			y_coord_1=peti_coord(2,i,2)
			z_coord_1=peti_coord(2,i,3)

			x_coord_1=x_coord_1+mid_length*a_unit(1)
			y_coord_1=y_coord_1+mid_length*a_unit(2)
			z_coord_1=z_coord_1+mid_length*a_unit(3)

			leaf_coord(2,i,j,1)=x_coord_1+0.50d0*width*nvec(1)
			leaf_coord(2,i,j,2)=y_coord_1+0.50d0*width*nvec(2)
			leaf_coord(2,i,j,3)=z_coord_1+0.50d0*width*nvec(3)

	enddo

 end subroutine initialize_gw3
 !===================================
 subroutine growth_gw3(node,d_connect,d_node,max_angle,max_length,&
	Apical_dominance_p,max_leaf_angle,&
	max_leaf_length,max_leaf_width,leaf_shape_rate,&
	peti_coord,leaf_coord,peti_length)

	integer,allocatable::d_connect_es(:,:)
	integer,allocatable,intent(inout)::d_connect(:,:)

	real(8),allocatable::d_node_es(:,:),peti_coord_es(:,:,:),&
		leaf_coord_es(:,:,:,:)
	real(8),allocatable,intent(inout)::d_node(:,:),peti_coord(:,:,:),&
		leaf_coord(:,:,:,:)

	real(8),intent(in)::max_angle,max_length,peti_length
	real(8),intent(in)::max_leaf_angle,&
	max_leaf_length,max_leaf_width,leaf_shape_rate
	real(8) angle,length,direction,r1,r2,pi,x_coord,y_coord,z_coord
	integer,intent(in)::node,Apical_dominance_p

	real(8) x_coord_1,y_coord_1,z_coord_1,peti_RUE,mid_length,width
	real(8),allocatable::a(:),b(:),z(:),nvec(:),a_unit(:),b_unit(:)

	integer i,j,n,m,o,parent,itr
	integer :: seedsize
	integer,allocatable :: seed(:)
	real :: rnd
	integer :: c !時間を入れる

	pi=3.14159265350d0

	allocate(a(3),b(3),z(3),nvec(3),a_unit(3),b_unit(3) )

	n=size(d_connect,1)
	m=size(d_connect,2)
	o=size(d_node,2)
	allocate(d_connect_es(n+1,m),d_node_es(n+1,o))
	d_connect_es(:,:)=0
	allocate(peti_coord_es(n,4,3),leaf_coord_es(n,3,4,3)   )
	!copy
	do i=1,n
		d_connect_es(i,:)=d_connect(i,:)
		d_node_es(i,:)=d_node(i,:)
	enddo

	!generate new node
	d_connect_es(n+1,1)=node
	if(d_connect_es(node,2)==-1  )then
		!basis
		return
	elseif(d_connect_es(node,2)==0  )then
		!aptical node => Get aptical dominance
		d_connect_es(n+1,2)=0

		d_connect_es(node,2)=1
		parent=d_connect_es(node,1)
		itr=1
		do
			itr=itr+1
			if( d_connect_es(parent,2)==-1 )then
				!base
				exit
			else
				if(  d_connect_es(parent,2)+1>=itr)then
					d_connect_es(parent,2)=d_connect_es(parent,2)+1
					parent = d_connect_es(parent,1)
				else
					cycle
				endif
			endif
		enddo

	elseif(d_connect_es(node,2)>=Apical_dominance_p  )then
		!generate new aptical
		d_connect_es(n+1,2)=0
		parent=d_connect_es(node,1)
		itr=1
		do
			itr=itr+1
			if( d_connect_es(parent,2)==-1 )then
				!base
				exit
			else
				if(  d_connect_es(parent,2)+1==itr)then
					d_connect_es(parent,2)=d_connect_es(parent,2)+1
					parent = d_connect_es(parent,1)
				else
					exit
				endif
			endif
		enddo
	else
		!not generate
		return
	endif

	d_connect_es(n+1,3)=0

	!random number generation
	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	angle=((rnd-0.50d0)+1.0d0)*max_angle

	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	length=((rnd-0.50d0)+1.0d0)*max_length

	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	direction=rnd*360.0d0

	r1=abs(cos(pi*(angle/180.0d0)))*length
	r2=abs( sin(pi*(angle/180.0d0)  ))*length

	x_coord=d_node(node,1)
	y_coord=d_node(node,2)
	z_coord=d_node(node,3)

	x_coord=x_coord+r2*cos( pi*(direction/180.0d0) )
	y_coord=y_coord+r2*sin( pi*(direction/180.0d0) )
	z_coord=z_coord+r1

	d_node_es(n+1,1)=x_coord
	d_node_es(n+1,2)=y_coord
	d_node_es(n+1,3)=z_coord
	d_node_es(n+1,4)=1.0d0
	d_node_es(n+1,5)=0.0d0

	deallocate(d_connect,d_node)
	n=size(d_connect_es,1)
	m=size(d_connect_es,2)
	o=size(d_node_es,2)
	allocate(d_connect(n,m),d_node(n,o))
	d_connect(:,:)=d_connect_es(:,:)
	d_node(:,:)=d_node_es(:,:)
	deallocate(d_connect_es,d_node_es)

	!====================================
	!generate peti and leaf
	!========================

	!expand peti_coord,leaf_coord
	!copy
	n=size(d_connect,1)
	leaf_coord_es(:,:,:,:)=leaf_coord(:,:,:,:)
	peti_coord_es(:,:,:)=peti_coord(:,:,:)
	deallocate(peti_coord,leaf_coord)
	allocate(peti_coord(n,4,3),leaf_coord(n,3,4,3)   )

	do i=1,size(peti_coord,1)
		peti_coord(i,:,:)=peti_coord_es(i,:,:)
		leaf_coord(i,:,:,:)=leaf_coord_es(i,:,:,:)
	enddo
	deallocate(peti_coord_es,leaf_coord_es)

	n=size(d_connect,1)
	!random number generation
	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	angle=((rnd-0.50d0)+1.0d0)*max_leaf_angle

	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	length=((rnd-0.50d0)+1.0d0)*peti_length

	call system_clock(count=c) !時間を取得
	call random_seed(size=seedsize)
	allocate(seed(seedsize))
	call random_seed(get=seed)
	seed = c !時間を全部に代入
	call random_number(rnd) !rndに乱数をセット
	deallocate(seed)

	direction=rnd*360.0d0

	r1=cos(pi*(angle/180.0d0))*length
	r2=sin(pi*(angle/180.0d0)  )*length

	x_coord=d_node(n,1)
	y_coord=d_node(n,2)
	z_coord=d_node(n,3)

	x_coord=x_coord+r2*cos( pi*(direction/180.0d0) )
	y_coord=y_coord+r2*sin( pi*(direction/180.0d0) )
	z_coord=z_coord+r1

	peti_coord(1,:,:)=0.0d0

	peti_coord(n,1,1)=x_coord
	peti_coord(n,1,2)=y_coord
	peti_coord(n,1,3)=z_coord

	!second-fourth
	do i=2,4
		!random number generation
		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		angle=((rnd-0.50d0)+1.0d0)*max_leaf_angle

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		if(i==2)then
			peti_RUE=0.10d0
		else
			peti_RUE=0.050d0
		endif

		length=((rnd-0.50d0)+1.0d0)*max_leaf_length*peti_RUE

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		if(i==2)then
			direction=rnd*360.0d0
		elseif(i==3)then
			direction=direction+120
		elseif(i==4)then
			direction=direction-240
		endif

		r1=abs(cos(pi*(angle/180.0d0)))*length
		r2=abs( sin(pi*(angle/180.0d0)  ))*length

		x_coord_1=x_coord
		y_coord_1=y_coord
		z_coord_1=z_coord

		x_coord_1=x_coord_1+r2*cos( pi*(direction/180.0d0) )
		y_coord_1=y_coord_1+r2*sin( pi*(direction/180.0d0) )
		z_coord_1=z_coord_1+r1

		peti_coord(n,i,1)=x_coord_1
		peti_coord(n,i,2)=y_coord_1
		peti_coord(n,i,3)=z_coord_1
	enddo

	!leaf generate
	do i=1,3
		!random number generation
		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		angle=((rnd-0.50d0)+1.0d0)*max_leaf_angle

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		length=((rnd-0.50d0)+1.0d0)*max_leaf_length
		width=((rnd-0.50d0)+1.0d0)*max_leaf_width

		call system_clock(count=c) !時間を取得
		call random_seed(size=seedsize)
		allocate(seed(seedsize))
		call random_seed(get=seed)
		seed = c !時間を全部に代入
		call random_number(rnd) !rndに乱数をセット
		deallocate(seed)

		if(i==1)then
			direction=rnd*360.0d0
		elseif(i==2)then
			direction=direction+120
		elseif(i==3)then
			direction=direction-240
		endif

		r1=abs(cos(pi*(angle/180.0d0)))*length
		r2=abs( sin(pi*(angle/180.0d0)  ))*length

		x_coord_1=peti_coord(n,i,1)
		y_coord_1=peti_coord(n,i,2)
		z_coord_1=peti_coord(n,i,3)

		x_coord_1=x_coord_1+r2*cos( pi*(direction/180.0d0) )
		y_coord_1=y_coord_1+r2*sin( pi*(direction/180.0d0) )
		z_coord_1=z_coord_1+r1

		leaf_coord(n,i,3,1)=x_coord_1
		leaf_coord(n,i,3,2)=y_coord_1
		leaf_coord(n,i,3,3)=z_coord_1

		leaf_coord(n,i,1,1)=peti_coord(n,i,1)
		leaf_coord(n,i,1,2)=peti_coord(n,i,2)
		leaf_coord(n,i,1,3)=peti_coord(n,i,3)
		!
		a(1)=leaf_coord(n,i,3,1)-peti_coord(n,i,1)
		a(2)=leaf_coord(n,i,3,2)-peti_coord(n,i,2)
		a(3)=leaf_coord(n,i,3,3)-peti_coord(n,i,3)

		z(1)=0.0d0
		z(2)=0.0d0
		z(3)=1.0d0

		a_unit(:)=a(:)/dsqrt(dot_product(a,a))

		b(:)=z(:)-dot_product(a,z)*a_unit(:)

		b_unit(:)=b(:)/dsqrt(dot_product(b,b))

		nvec(1)=a_unit(2)*b_unit(3)-a_unit(3)*b_unit(2)
		nvec(2)=a_unit(3)*b_unit(1)-a_unit(1)*b_unit(3)
		nvec(3)=a_unit(1)*b_unit(2)-a_unit(2)*b_unit(1)
		nvec(:)=nvec(:)/dsqrt(dot_product(nvec,nvec))
		mid_length=1.0d0/(1.0d0+leaf_shape_rate)*length

		j=2

			x_coord_1=peti_coord(n,i,1)
			y_coord_1=peti_coord(n,i,2)
			z_coord_1=peti_coord(n,i,3)

			x_coord_1=x_coord_1+mid_length*a_unit(1)
			y_coord_1=y_coord_1+mid_length*a_unit(2)
			z_coord_1=z_coord_1+mid_length*a_unit(3)

			leaf_coord(n,i,j,1)=x_coord_1-0.50d0*width*nvec(1)
			leaf_coord(n,i,j,2)=y_coord_1-0.50d0*width*nvec(2)
			leaf_coord(n,i,j,3)=z_coord_1-0.50d0*width*nvec(3)

		j=4
			x_coord_1=peti_coord(n,i,1)
			y_coord_1=peti_coord(n,i,2)
			z_coord_1=peti_coord(n,i,3)

			x_coord_1=x_coord_1+mid_length*a_unit(1)
			y_coord_1=y_coord_1+mid_length*a_unit(2)
			z_coord_1=z_coord_1+mid_length*a_unit(3)

			leaf_coord(n,i,j,1)=x_coord_1+0.50d0*width*nvec(1)
			leaf_coord(n,i,j,2)=y_coord_1+0.50d0*width*nvec(2)
			leaf_coord(n,i,j,3)=z_coord_1+0.50d0*width*nvec(3)

	enddo

 end subroutine growth_gw3
 !===================================
 subroutine update_factor_gw3(d_connect,d_node,RUE,num_node,leaf_coord&
	,day,daylength,limit_leaf_day,day_ID)
	real(8),intent(inout)::d_node(:,:)
	real(8),intent(in)::RUE,leaf_coord(:,:,:,:),daylength(:)
	real(8),allocatable::photosynthesis(:,:),radiation(:,:)
	real(8) factor,light_area,total_area,old_RUEmeter
	integer,intent(in)::d_connect(:,:),num_node,day_ID,day(:,:),limit_leaf_day
	integer i,j,month,node_ID,leaf_ID

	allocate(photosynthesis(num_node,3),radiation(12,2) )
	photosynthesis(:,:)=0.0d0
	open(60,file="radiation.txt")
	do i=1,12
		read(60,*)radiation(i,1:2)
	enddo
	close(60)

	!生成してから1日経ってから光合成開始
	!日照面積判定
	do i=1,num_node
		do j=1,size(leaf_coord,2)
			!compute light area
			node_ID=i
			leaf_ID=j
			call detect_light_area(leaf_coord,light_area,total_area,node_ID,leaf_ID)

			photosynthesis(i,1)=light_area
			photosynthesis(i,2)=total_area
			!光合成量＝日射時間(hr)×面積当たり時間当たり日射量(MJ/m^2/hr)×日照面積(m^2)×日射量あたり光合成(g/MJ)
			month=day(day_ID,2)
			if( radiation(month,1)==0.0d0 )then
				photosynthesis(i,3)=0.0d0
			endif

			if(d_connect(i,3)==-1 )then
				old_RUEmeter=0.0d0
			else
				old_RUEmeter=dble(d_connect(i,3))/dble(limit_leaf_day)
				if(old_RUEmeter<0)stop"debugb"
			endif

			photosynthesis(i,3)=daylength(day_ID)*radiation(month,2)/radiation(month,1)&
				*light_area*RUE*old_RUEmeter
		enddo
	enddo

	do i=1,num_node
		!compute factor
		factor=d_node(i,5)

		factor=factor+photosynthesis(i,3)

		d_node(i,5)=factor
	enddo

 end subroutine update_factor_gw3
 !===================================
 subroutine detect_start(start,finish,seedling_day,harvesting_day,day)
	integer,intent(out)::start,finish
	integer,intent(in)::seedling_day(:),harvesting_day(:),day(:,:)
	integer i,j,n,yy,mm,dd,diff

	do i=1,size(day,1)
		yy=day(i,1)
		mm=day(i,2)
		dd=day(i,3)

		diff=abs( seedling_day(1)-yy )&
			+abs( seedling_day(2)-mm )&
			+abs( seedling_day(3)-dd )

		if(diff==0 )then
			start=i
			exit
		endif

	enddo

	do i=1,size(day,1)
		yy=day(i,1)
		mm=day(i,2)
		dd=day(i,3)

		diff=abs( harvesting_day(1)-yy )&
			+abs( harvesting_day(2)-mm )&
			+abs( harvesting_day(3)-dd )

		if(diff==0 )then
			finish=i
			exit
		endif

	enddo

 end subroutine detect_start
 !===================================
  subroutine count_br_per_node(node_number,br_per_node,d_connect)
	integer,intent(in)::node_number,d_connect(:,:)
	integer,intent(out)::br_per_node
	integer i

	br_per_node=0
	do i=1,size(d_connect,1)
		if(node_number==d_connect(i,1) )then
			br_per_node=br_per_node+1
		else
			cycle
		endif
	enddo
	if(br_per_node>=3)stop"debug"

 end subroutine count_br_per_node
 !===================================
 subroutine detect_light_area(leaf_coord,light_area,total_area,node_ID,leaf_ID)
	real(8),intent(in)::leaf_coord(:,:,:,:)
	real(8),intent(out)::light_area,total_area
	real(8),allocatable::mid_x(:),shape_function(:),evaluate_point(:,:),eva_x(:),rvec(:)&
		,x1(:),x2(:),y1(:),y2(:)
	real(8) gzi_1,gzi_2,eva_r,mid_r,both_r,l1,l2,l3
	integer,intent(in)::node_ID,leaf_ID
	integer i,j,k,l,m,shade_or_not,count_shade

	allocate(mid_x(3),shape_function(4),evaluate_point(4,2),eva_x(3),rvec(2),x1(2),x2(2))
	allocate(y1(3),y2(3))

	!2D linear interpolation,4 points
	evaluate_point(1,1)=-0.50d0
	evaluate_point(1,2)=-0.50d0
	evaluate_point(2,1)=-0.50d0
	evaluate_point(2,2)=0.50d0
	evaluate_point(3,1)=0.50d0
	evaluate_point(3,2)=0.50d0
	evaluate_point(4,1)=0.50d0
	evaluate_point(4,2)=-0.50d0

	y1(1:3)=leaf_coord(node_ID,leaf_ID,1,1:3)-leaf_coord(node_ID,leaf_ID,3,1:3)
	y2(1:3)=leaf_coord(node_ID,leaf_ID,2,1:3)-leaf_coord(node_ID,leaf_ID,4,1:3)
	l1=dsqrt( dot_product(y1,y1) )
	l2=dsqrt( dot_product(y2,y2) )
	total_area=0.50d0*l1*l2/100.0d0/100.0d0

	count_shade=0
	do k=1,4 !evaluate points
		gzi_1=evaluate_point(k,1)
		gzi_2=evaluate_point(k,2)
		shape_function(1)=0.250d0*(1.0d0-gzi_1)*(1.0d0-gzi_1)
		shape_function(2)=0.250d0*(1.0d0-gzi_1)*(1.0d0+gzi_1)
		shape_function(3)=0.250d0*(1.0d0+gzi_1)*(1.0d0+gzi_1)
		shape_function(4)=0.250d0*(1.0d0+gzi_1)*(1.0d0-gzi_1)

		eva_x(:)=0.0d0
		do l=1,4
			eva_x(:)=eva_x(:)+leaf_coord(node_ID,leaf_ID,l,:)&
				*shape_function(l)
		enddo
		rvec(:)=leaf_coord(node_ID,leaf_ID,k,1:2)
		eva_r=dsqrt( dot_product(rvec-eva_x(1:2) ,rvec-eva_x(1:2)  ) )

		shade_or_not=0

		do i=1,size(leaf_coord,1)
			do j=1,size(leaf_coord,2)
				mid_x(:)=0.0d0
				do l=1,4
					mid_x(:)=mid_x(:)+0.250d0*leaf_coord(i,j,l,:)
				enddo

				!if z coordinate of the midpoint of the leaf > evaluate point
				! => possible node
				if(mid_x(3) < eva_x(3) )then
					cycle
				endif

				x1(1:2)=leaf_coord(i,j,1,1:2)-leaf_coord(i,j,3,1:2)
				x2(1:2)=leaf_coord(i,j,2,1:2)-leaf_coord(i,j,4,1:2)

				mid_r=dsqrt( dot_product(x1,x1) )+dsqrt( dot_product(x2,x2) )
				mid_r=0.50d0*mid_r

				both_r=dsqrt( dot_product(mid_x(1:2)-eva_x(1:2),mid_x(1:2)-eva_x(1:2)))

				if(both_r > eva_r+mid_r)then
					cycle
				else
					shade_or_not=1
					exit
				endif
			enddo

			if(shade_or_not==1)then
				exit
			endif
		enddo

		if(shade_or_not==1)then
			cycle
		else
			count_shade=count_shade+1
		endif
	enddo

	light_area=total_area/4.0d0*dble(count_shade)

 end subroutine detect_light_area
 !===================================
 subroutine get_old(d_connect,limit_leaf_day)
	integer,intent(inout)::d_connect(:,:)
	integer,intent(in)::limit_leaf_day
	integer i

	do i=1,size(d_connect,1)
		if(d_connect(i,3)==0 )then
			!first day
			d_connect(i,3)=limit_leaf_day
		elseif(d_connect(i,3)==1 )then
			d_connect(i,3)=-1
		elseif(d_connect(i,3)==-1 )then
			d_connect(i,3)=-1
		elseif(limit_leaf_day>=d_connect(i,3) .and. d_connect(i,3)>=2)then
			d_connect(i,3)=d_connect(i,3)-1
		else
			stop"invalid d_connect,3"
		endif
	enddo

 end subroutine get_old
 !===================================
 subroutine generate_pod(d_node,d_pod,source_convection_rate,source_limitation)
	real(8),intent(inout)::d_node(:,:),d_pod(:,:)
	real(8),intent(in)::source_convection_rate,source_limitation
	real(8) total_source,extra_source
	integer i,j,pn

	do i=1,size(d_node,1)
		total_source=d_node(i,5)
		pn=0
		do j=1,size(d_pod,2)
			if(d_pod(i,j)==source_limitation)then
				cycle
			elseif(d_pod(i,j)<source_limitation )then
				pn=j
				exit
			else
				stop"invalid source/pod"
			endif
		enddo

		if(pn==0)then
			!sink was occupied
			cycle
		endif

		if(total_source>=source_convection_rate)then
			d_node(i,5)=total_source-source_convection_rate
			d_pod(i,pn)=d_pod(i,pn)+source_convection_rate

		elseif(source_convection_rate>total_source .and. &
			total_source>0.0d0)then
			d_pod(i,pn)=d_pod(i,pn)+total_source
			d_node(i,5)=0.0d0
		elseif(total_source==0.0d0)then
			cycle
		else
			stop"invalid source < 0"
		endif

		extra_source=0.0d0
		do j=1,size(d_pod,2)
			if(extra_source/=0.0d0)then
				d_pod(i,j)=d_pod(i,j)+extra_source
			endif

			if(d_pod(i,j)>source_limitation)then
				extra_source=d_pod(i,j)-source_limitation
				d_pod(i,j)=source_limitation
			endif
		enddo

		if(extra_source/=0.0d0)then
			d_node(i,5)=d_node(i,5)+extra_source
			extra_source=0.0d0
		endif

	enddo

 end subroutine generate_pod
 !===================================
end module growthmod


module cbmix
  implicit none
  save

  public :: cbCalcMixtureParams
  public :: cbCalcM, setCubicm1m2, getCubicm1m2
  public :: calcBmixCubic

contains

  !---------------------------------------------------------------------------------------
  !> Calculation of parameter m1 and m2 for the selected EOS
  ! \param acf -  Ascentric factor (used for Schmidth/Wenzel
  !
  !
  ! Not really necessay to use input parameters, but done to emphasize that
  ! for some EOS's the m's are dependent of b and/or c
  !
  subroutine cbCalcM (cbeos, cpar, bpar)
    use eosdata
    use cubic_eos, only: cb_eos
    implicit none
    class(cb_eos), intent(inout) :: cbeos
    real, optional, intent (in)  :: cpar,bpar
    real ::  sqterm,sw,acf,b,c
    real ::  sqterm2, t1,t2,t3,t4

    real :: m1,m2,bdiff,cdiff,bplus,cplus,bminus,cminus
    real :: sqterm2_bplus, sqterm2_cplus, sqterm2_bminus, sqterm2_cminus
    real :: sqterm_bminus, sqterm_cminus, sqterm_bplus, sqterm_cplus
    real :: dm1db_num, dm1dc_num, dm2db_num,dm2dc_num
    real :: m1_bplus, m1_bminus, m1_cplus, m1_cminus
    real :: m2_bplus, m2_bminus, m2_cplus, m2_cminus

    cbeos%dm1dB = 0.0D0
    cbeos%dm1dC = 0.0D0
    cbeos%dm2dB = 0.0D0
    cbeos%dm2dC = 0.0D0

    cbeos%d2m1dB2 = 0.0D0
    cbeos%d2m2dB2 = 0.0D0

    cbeos%d2m1dC2 = 0.0D0
    cbeos%d2m2dC2 = 0.0D0

    cbeos%d2m1dBdC = 0.0D0
    cbeos%d2m2dBdC = 0.0D0

    select case (cbeos%subeosidx)
    case (cbVdW)
      cbeos%m1 = 0.0D0
      cbeos%m2 = 0.0D0
    case (cbSRK, cbPR, cspSRK, cpaSRK, cspPR, cpaPR, eosLK)
      cbeos%m1 = (-(cbeos%delta + 1)+ sqrt(cbeos%delta**2 + 6.0*cbeos%delta + 1.0))/2.0
      cbeos%m2 = (-(cbeos%delta + 1)- sqrt(cbeos%delta**2 + 6.0*cbeos%delta + 1.0))/2.0
    case (cbSW) !< For this EOS, the m1 and m2 are re-calculated after the mixing paramteres are calculated
      acf = cpar
      sw = 1.0+18.0*acf+9.0*acf*acf
      sqterm = sqrt(sw)
      cbeos%m1 = (-1.0 - 3.0*acf + sqterm)/2.0
      cbeos%m2 = (-1.0 - 3.0*acf - sqterm)/2.0

      cbeos%dm1dc = -1.5 + 4.5*(1.0+acf)/sqterm
      cbeos%dm2dc = -1.5 - 4.5*(1.0+acf)/sqterm

      cbeos%d2m1dc2 = 4.5*(sw-9.0*(1.0+acf)**2)/(sw*sqterm)
      cbeos%d2m2dc2 = -cbeos%d2m1dc2

    case (cbPT) !< The Patel-Teja 3 parameter cubic EOS
      ! Need to calculated after mixing of b and c
      c = cpar
      b = bpar
      sqterm2 = b*b+6*b*c+c*c
      sqterm = sqrt(sqterm2)

      cbeos%m1 = (-b-c + sqterm)/(2*b)
      cbeos%m2 = (-b-c - sqterm)/(2*b)

      cbeos%dm1dB = -(c*(3*b-sqterm+c))/(2*sqterm*b*b)
      cbeos%dm2dB =  (c*(3*b+sqterm+c))/(2*sqterm*b*b)

      cbeos%dm1dC =  (3*b-sqterm+c)/(2*sqterm*b)
      cbeos%dm2dC = -(3*b+sqterm+c)/(2*sqterm*b)

      t2 = b*b + 5*b*c + 3*c*c
      t3 = b*b*b*sqterm*sqterm2
      t4 = c*c*c
      cbeos%d2m1dB2 =   c*(3*b*t2 - sqterm*sqterm2 + t4) /t3
      cbeos%d2m2dB2 = -(c*(3*b*t2 + sqterm*sqterm2 + t4))/t3

      t1 = 3*b+c
      cbeos%d2m1dC2 = -(t1*t1 - sqterm2)/(2*sqterm2*sqterm*b)
      cbeos%d2m2dC2 = -cbeos%d2m1dC2

      cbeos%d2m1dBdC = -((t1-sqterm)* (b*(b+3*c)-c*sqterm))/(2*sqterm*sqterm2*b*b)
      cbeos%d2m2dBdC =  ((t1+sqterm)* (b*(b+3*c)+c*sqterm))/(2*sqterm*sqterm2*b*b)

      ! Test numerical:
      if (cbeos%cubic_verbose) then
        m1 = cbeos%m1
        m2 = cbeos%m2

        bdiff = 1.0E-5
        cdiff = 1.0E-5

        bplus = b+bdiff
        cplus = c+cdiff

        bminus = b-bdiff
        cminus = c-cdiff

        sqterm2_bplus = bplus*bplus+6*bplus*c+c*c
        sqterm2_cplus = b*b+6*b*cplus+cplus*cplus

        sqterm_bplus = sqrt(sqterm2_bplus)
        sqterm_cplus = sqrt(sqterm2_cplus)

        sqterm2_bminus = bminus*bminus+6*bminus*c+c*c
        sqterm2_cminus = b*b+6*b*cminus+cminus*cminus

        sqterm_bminus = sqrt(sqterm2_bminus)
        sqterm_cminus = sqrt(sqterm2_cminus)

        m1_bplus = (-bplus-c + sqterm_bplus)/(2*bplus)
        m1_bminus = (-bminus-c + sqterm_bminus)/(2*bminus)

        m1_cplus = (-b-cplus + sqterm_cplus)/(2*b)
        m1_cminus = (-b-cminus + sqterm_cminus)/(2*b)

        m2_bplus = (-bplus-c - sqterm_bplus)/(2*bplus)
        m2_bminus = (-bminus-c - sqterm_bminus)/(2*bminus)

        m2_cplus = (-b-cplus - sqterm_cplus)/(2*b)
        m2_cminus = (-b-cminus - sqterm_cminus)/(2*b)

        dm1db_num  = (m1_bplus - m1_bminus)/(2*bdiff)
        dm1dc_num  = (m1_cplus - m1_cminus)/(2*cdiff)

        dm2db_num  = (m2_bplus - m2_bminus)/(2*bdiff)
        dm2dc_num  = (m2_cplus - m2_cminus)/(2*cdiff)

        write (*,*) 'PT derivtest, analytical, numerical'
        write (*,*) 'PT derivtest, dm1/db: ', cbeos%dm1db, dm1db_num, cbeos%dm1db - dm1db_num
        write (*,*) 'PT derivtest, dm1/dc: ', cbeos%dm1dc, dm1dc_num, cbeos%dm1dc- dm1dc_num
        write (*,*) 'PT derivtest, dm2/db: ', cbeos%dm2db, dm2db_num, cbeos%dm2db- dm2db_num
        write (*,*) 'PT derivtest, dm2/dc: ', cbeos%dm2dc, dm2dc_num, cbeos%dm2dc- dm2dc_num
      endif
    end select
  end subroutine cbCalcM

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

  !> Calculation of critical compressibility and the Ohmega-term in the cubic EOS.
  !! The parameters m1 and m2 should already be calculated
  !!
  !! The terms OhmegaA, OhmegaB and Zcrit are composition dependendent and are
  !! stored as an array of length nc in the cbeos type
  !!
  !! For the VdW, RK, SRK, SKRGB, PR and later EOS that does not have
  !! composition dependent m1 and m2, these terms have the same value for all
  !! elementes in the array.
  !!
  !! The OhmegaA, OhmegaB and Zcrit are solved using a second order
  !! Newton-Raphson method and converges normally after 3-4 iterations.
  !!

  subroutine cbCalcOmegaZc(nc,cbeos)
    use eosdata
    use cubic_eos, only: cb_eos
    implicit none
    integer, intent(in) :: nc
    class(cb_eos), intent(inout) :: cbeos
    real, parameter  :: eps = 1.0E-10
    integer, parameter  :: maxiter = 10
    real :: n,n1,n2,zcomb,dzcomb,f,fd,fdd,argum
    integer :: iter
    integer :: ic,i
    real :: bc,dbc,kc
    real :: acfi
    if (cbeos%subeosidx == cbSW) then !> For the Schmidt and Wenzel EOS
       do ic = 1,nc
          acfi = cbeos%single(ic)%acf
          bc = 0.25989 - 0.0217*acfi + 0.00375*acfi*acfi !< initial value critical compressibility
          dbc = 1.0E10
          iter = 1
          do while (iter < maxiter .and. abs (dbc) > eps)
             f = (6.0*acfi+1)*bc*bc*bc + 3*bc*bc + 3*bc -1.0
             fd = 3.0*(6.0*acfi+1)*bc*bc+ 6.0*bc + 3.0
             fdd = 6.0*(6.0*acfi+1)*bc + 6.0
             argum = 1.0 - 2.0*f*fdd/fd**2
             if (argum.gt.0.0) then
                argum = sqrt(argum)
             else
                argum = 1.0
             end if
             dbc = (-2.0)*f/(fd*(1.0+argum))
             bc= bc + dbc
             iter = iter + 1
          enddo

          if (iter == maxiter) call StopError ("Third order method failed to calculate zcrit")
          if (cbeos%cubic_verbose) then
             write (*,*) 'Calculation of ohmega/zcrit converged after ',iter-1,' iterations for SW EOS'
          endif
          kc = 1.0/(3.0*(1 + bc*acfi))
          cbeos%single(ic)%omegaB = bc * kc

          argum = 1.0 - kc*(1.0-bc)
          cbeos%single(ic)%omegaA = argum**3
          cbeos%single(ic)%zcrit = kc
          cbeos%single(ic)%omegaC = 0.0D0
       enddo
    else if (cbeos%subeosidx == cbPT) then
       ! General term for zcrit
       do ic = 1,nc
          acfi = cbeos%single(ic)%acf
          ! From Patel-Teja general correlation (eq 21)
          cbeos%single(ic)%zcrit = 0.329032-0.076799*acfi + 0.0211947*acfi*acfi
          cbeos%single(ic)%omegaC = 1.0-3.0*cbeos%single(ic)%zcrit
          dbc = 1.0E10
          iter = 1
          bc = cbeos%single(ic)%zcrit
          do while (iter < maxiter .and. abs (dbc) > eps)
             f = bc*bc*bc+(2-3*cbeos%single(ic)%zcrit)*bc*bc &
                  + 3*cbeos%single(ic)%zcrit*cbeos%single(ic)%zcrit*bc &
                  - cbeos%single(ic)%zcrit**3
             fd = 3*bc*bc + 2*(2-3*cbeos%single(ic)%zcrit)*bc &
                  + 3*cbeos%single(ic)%zcrit*cbeos%single(ic)%zcrit
             fdd = 6*bc + 2*(2-3*cbeos%single(ic)%zcrit)

             argum = 1.0 - 2.0*f*fdd/fd**2
             if (argum.gt.0.0) then
                argum = sqrt(argum)
             else
                argum = 1.0
             end if
             dbc = (-2.0)*f/(fd*(1.0+argum))
             bc= bc + dbc
             iter = iter + 1
          enddo

          cbeos%single(ic)%omegaB = bc
          cbeos%single(ic)%omegaC = 1.0-3.0*cbeos%single(ic)%zcrit

          cbeos%single(ic)%omegaA = 3*cbeos%single(ic)%zcrit*cbeos%single(ic)%zcrit &
               + 3*(1-2*cbeos%single(ic)%zcrit)*cbeos%single(ic)%omegaB &
               + cbeos%single(ic)%omegaB*cbeos%single(ic)%omegaB &
               + cbeos%single(ic)%omegaC
       enddo
    else ! other 2 param eos's
       !! Solve Zc/OhmegaB with a 3rd order method for two-param eques
       zcomb = 5.0
       dzcomb = 1.0E10
       iter = 1
       do while (iter < maxiter .and. abs(dzcomb) > eps)
          n  = zcomb - 1.0
          n1 = zcomb - cbeos%m1
          n2 = zcomb - cbeos%m2
          f = n*n1**2+n*n1*n2+n*n2**2-n1**2*n2-n1*n2**2
          fd = 3.0*(n*n1+n*n2-n1*n2)
          fdd = 6.0*n
          argum = 1.0-2.0*f*fdd/fd**2
          if (argum.gt.0.0) then
             argum = sqrt(argum)
          else
             argum = 1.0
          end if
          dzcomb = (-2.0)*f/(fd*(1.0+argum))
          zcomb = zcomb+dzcomb
          iter = iter + 1
       enddo

       if (iter == maxiter) call StopError ("Third order method failed to calculate zcrit")
       if (cbeos%cubic_verbose) then
          write (*,*) 'Calculation of ohmega/zcrit converged after ',iter-1,' iterations for CB  EOS'
       endif
       argum = n1*n2/(n*n1+n*n2)
       do ic=1,nc
          cbeos%single(ic)%omegaB = (1.0-argum)/(zcomb-1.0)
          cbeos%single(ic)%zcrit = cbeos%single(ic)%omegaB*zcomb
          cbeos%single(ic)%omegaA = cbeos%single(ic)%omegaB*(1.0/n-cbeos%single(ic)%omegaB)*n1*n2
          cbeos%single(ic)%omegaC = 0.0D0
       enddo
    endif

    do i=1,nc
      call cbSingleCalcABC(nc,cbeos,i)
    enddo

  end subroutine cbCalcOmegaZc

  subroutine cbSingleCalcABC(nc,cbeos,i)
    use cubic_eos, only: cb_eos
    use thermopack_constants, only: kRgas
    implicit none
    integer, intent(in) :: nc, i
    class(cb_eos), intent(inout) :: cbeos
    ! Locals
    real :: tci,pci

    tci = cbeos%single(i)%tc !< Critical temperature component, i
    pci = cbeos%single(i)%pc !< Critical pressure component, i
    cbeos%single(i)%a = cbeos%single(i)%omegaA*(kRgas*tci)**2/pci
    cbeos%single(i)%b = cbeos%single(i)%omegaB*kRgas*tci/pci
    cbeos%single(i)%c = cbeos%single(i)%omegaC*kRgas*tci/pci

  end subroutine cbSingleCalcABC

  !----------------------------------------------------------------------
  !> Calculate bij to be used in the mixing rules of the covolume parameter
  !!
  !! \param s Exponent
  !!
  !! \author Morten Hammer
  !! \todo Add lij mixing parameter
  subroutine cbCalcLowcasebij(nc,cbeos,s)
    use cubic_eos, only: cb_eos
    use numconstants, only: small
    implicit none
    integer, intent(in) :: nc
    class(cb_eos), intent(inout) :: cbeos
    real, intent(in) :: s
    ! Locals
    integer :: i,j !< Counters
    real :: inv_s

    if (abs(s-1.0) >= small) then
      cbeos%simple_covolmixing = .false.

      if (allocated (cbeos%lowcase_bij) .eqv. .false. ) call StopError('CalcLowcasebij: Equation of state are not selected')

      do i=1,nc
        cbeos%lowcase_bij(i,i) = cbeos%single(i)%b
      enddo
      inv_s = 1.0/s
      do i=1,nc
        do j=i,nc
          cbeos%lowcase_bij(i,j) = (0.5*(cbeos%single(i)%b**inv_s + cbeos%single(j)%b**inv_s))**s
          cbeos%lowcase_bij(j,i) = cbeos%lowcase_bij(i,j) ! *(1.0-lij(i,j)) ! Todo
        enddo
      enddo
    endif
  end subroutine cbCalcLowcasebij

  !< Calculate the mixing parameters according to the selected mixing rule.
  !! \param t - Temperature [K]
  !! \param p - Pressure [Pa]
  !! \param zComp - mole numbers [mole]
  !!
  !! For the Schmidt and Wenzel EOS, the constants m1 and m2 in the
  !! EOS-formulations needs to be updated based on the calculated b_i's for
  !! the components in the mixture and the mixture ascentric factor. This
  !! call to calcM after the temperature-dependent alpha-term has been calculated.
  !!
  !! First part could be written as a separate subroutine
  !! calculating the derivatives of the alpha-function
  !!

  !< The m_srk and m_pr by Michelsen
  ! For Patel-Teja the "s" is a fitted paramtere called "F" and are available
  ! In their article if component specific "s" are to be used

  !! xx = s**2 ! This is the original SOAVE(1972) formulation. Correct in form, also supercritical
  !! yy = -2.0*s*(s+1.0)

  subroutine cbCalcBmix (nc, cbeos, T, zcomp)
    !> Calculate covolume parameter, which can depend on both composition and
    !> temperature.
    !> \author Ailo, Jan 2020
    use cubic_eos, only: cb_eos
    use cbBeta, only: cbCalcBetaTerm
    integer, intent (in) :: nc
    class(cb_eos), intent(inout) :: cbeos
    real, intent(in) :: T
    real, intent (in) :: zcomp(nc)
    ! Locals
    integer :: i, j
    real :: bii, biiT, biiTT
    real :: bjj, bjjT, bjjTT
    real :: bij, bijT, bijTT, lijfac, biTT(nc)
    real :: sumn

    call cbCalcBetaTerm(nc, cbeos, T)
    cbeos%b = 0.0
    cbeos%bT = 0.0
    cbeos%bTT = 0.0
    if (cbeos%simple_covolmixing) then
       do i=1,nc
          cbeos%bi(i) = cbeos%single(i)%b * cbeos%single(i)%beta
          cbeos%biT(i) = cbeos%single(i)%b * cbeos%single(i)%dbetadT
          cbeos%bij(i,1:nc) = 0.0 ! d^2b/(dni*dnj) = 0

          cbeos%b = cbeos%b + zcomp(i)*cbeos%bi(i)
          cbeos%bT = cbeos%bT + zcomp(i)*cbeos%biT(i)
          cbeos%bTT = cbeos%bTT + zcomp(i)*cbeos%single(i)%b*cbeos%single(i)%d2betadT2
       end do
       cbeos%sumb = cbeos%b
    else
       ! Michelsen approach for general mixing of covolume
       sumn = sum(zcomp)
       do i=1,nc
          cbeos%bi(i) = 0.0
          cbeos%biT(i) = 0.0
          biTT(i) = 0.0
          bii = cbeos%single(i)%b * cbeos%single(i)%beta
          biiT = cbeos%single(i)%b * cbeos%single(i)%dbetadT
          biiTT = cbeos%single(i)%b * cbeos%single(i)%d2betadT2
          do j=1,nc
             bjj = cbeos%single(j)%b * cbeos%single(j)%beta
             bjjT = cbeos%single(j)%b * cbeos%single(j)%dbetadT
             bjjTT = cbeos%single(j)%b * cbeos%single(j)%d2betadT2

             lijfac = 1-cbeos%lij(i,j)
             bij = lijfac*(bii+bjj)/2.0
             bijT = lijfac*(biiT+bjjT)/2.0
             bijTT = lijfac*(biiTT+bjjTT)/2.0
             cbeos%bi(i)  = cbeos%bi(i)  + zcomp(j)*bij
             cbeos%biT(i) = cbeos%biT(i) + zcomp(j)*bijT
             biTT(i) = biTT(i) + zcomp(j)*bijTT
          enddo
          cbeos%b  = cbeos%b  + zcomp(i)*cbeos%bi(i)/sumn
          cbeos%bT = cbeos%bT + zcomp(i)*cbeos%biT(i)/sumn
          cbeos%bTT = cbeos%bTT + zcomp(i)*biTT(i)/sumn
       enddo

       cbeos%bi  = (2.0*cbeos%bi  - cbeos%b)/sumn
       cbeos%biT = (2.0*cbeos%biT - cbeos%bT)/sumn

       do i=1,nc
          bii = cbeos%single(i)%b * cbeos%single(i)%beta
          do j=1,nc
             bjj = cbeos%single(j)%b * cbeos%single(j)%beta
             lijfac = 1-cbeos%lij(i,j)
             bij = lijfac*(bii+bjj)/2.0
             cbeos%bij(i,j) = (2*bij - cbeos%bi(i) - cbeos%bi(j))/sumn
          enddo
       enddo
       cbeos%sumb = cbeos%b
    end if

  end subroutine cbCalcBmix

  ! As cbCalcBmix, but not filling cbeos type
  function calcBmixCubic(nc, cbeos, z) result(Bmix)
    use cubic_eos, only: cb_eos
    implicit none
    integer, intent (in) :: nc
    class(cb_eos), intent(in) :: cbeos
    real, intent (in) :: z(nc)
    real :: Bmix
    ! Locals
    integer :: i,j
    real :: sumn, bi

    sumn = sum(z)
    if (cbeos%simple_covolmixing) then
      Bmix = 0
      do i=1,nc
        Bmix = Bmix + z(i)*cbeos%single(i)%b
      enddo
      Bmix = Bmix/sumn
    else
      ! Michelsen approach for general mixing of covolume
      Bmix = 0.0
      do i=1,nc
        bi = 0.0
        do j=1,nc
          bi = bi + z(j)*cbeos%lowcase_bij(i,j)
        enddo
        Bmix = Bmix + z(i)*bi
      enddo
      Bmix = Bmix/sumn**2
    endif
  end function calcBmixCubic

  subroutine cbCalcCmix (nc, cbeos, zcomp)
    use eosdata, only: cbSW
    use cubic_eos, only: cb_eos
    implicit none
    integer, intent (in) :: nc
    class(cb_eos), intent(inout) :: cbeos
    real, intent(in) :: zcomp(nc)
    ! Locals
    integer :: low,high,i,j
    real :: acfi
    real :: sum1, sum2, bi07, bj07

    sum1 = 0.0
    sum2 = 0.0
    cbeos%sumc = 0.0
    low = 1
    high = nc
    do i=low,high
       acfi = cbeos%single(i)%acf !< Acentric factor component, i

       if (cbeos%subeosidx == cbSW) then !< Need intermediate sums
          bi07 =  cbeos%bi(i)**0.7 !< Assume the cbCalcBmix has been called
          sum1 = sum1 + zcomp(i)*acfi*bi07
          sum2 = sum2 + zcomp(i)*bi07
       else
          cbeos%ci(i) = cbeos%single(i)%c
          cbeos%sumc = cbeos%sumc + zcomp(i)*cbeos%ci(i)
          cbeos%cij(i,1:nc) = 0.0D00
       endif
    end do

    if (cbeos%subeosidx == cbSW) then
       cbeos%sumc = sum1 / sum2
       do i=1,nc
          bi07 = cbeos%bi(i)**0.7
          cbeos%ci(i) = (bi07/sum2) * (cbeos%single(i)%acf - (sum1/sum2))
          do j=1,nc
             bj07 = cbeos%bi(j)**0.7
             cbeos%cij(i,j) = -(bi07*bj07/(sum2*sum2)) &
                  * (cbeos%single(i)%acf + cbeos%single(j)%acf - 2*sum1/sum2)
          end do
       end do
    endif
    cbeos%c = cbeos%sumc
  end subroutine cbCalcCmix

  !-------------------------------------------
  subroutine cbCalcAmix(nc, cbeos, t, zcomp)
    use cubic_eos, only: cb_eos, cbMixVdW, cbMixVdWCPA, &
         cbMixHuronVidal, cbMixHuronVidal2, cbMixNRTL, cbMixUNIFAC, &
         cbMixHVCPA, cbMixHVCPA2, cbMixWongSandler, cbMixReid
    use wong_sandler, only : WongSandlerMix
    use excess_gibbs, only : ExcessGibbsMix
    use cbAlpha, only: cbCalcAlphaTerm
    implicit none
    integer, intent (in) :: nc
    class(cb_eos), intent(inout) :: cbeos
    real, intent(in) :: t, zcomp(nc)

    ! Common part for all mixing rules - actually the temperature dependent
    ! alpha(T) term in the EOS. ap = alpha(T)*ai

    ! Assign  alpha-terms including temperature derivatives
    call cbCalcAlphaTerm(nc, cbeos, T)

    select case (cbeos%mruleidx)

    case (cbMixVdW, cbMixVdWCPA)
      call vanderWaalsMix(nc,cbeos,t,zcomp)

    case (cbMixHuronVidal, cbMixHuronVidal2, cbMixNRTL, cbMixUNIFAC, &
         cbMixHVCPA, cbMixHVCPA2)
      call ExcessGibbsMix(cbeos,T,zcomp)

    case (cbMixWongSandler)
      call WongSandlerMix(cbeos, T, zcomp)

    case (cbMixReid) !< Un-symmetric - need to be developed
      call stoperror ("Reid mixing rule not yet implemented")
    case default
      call stoperror ("Unknown mixing rules")
    end select

    cbeos%a = cbeos%suma
  end subroutine cbCalcAmix

  subroutine vanderWaalsMix(nc,cbeos,t,zcomp)
    use stringmod, only: str_eq
    use cubic_eos, only: cb_eos
    implicit none
    integer, intent(in) :: nc
    class(cb_eos), intent(inout) :: cbeos
    real, intent(in) :: t, zcomp(nc)
    !
    ! Local variables
    real :: sum1,sum2,sum3
    integer :: i, j,  low, high
    real :: pij,dpijdt, d2pijdt2
    real :: afac(nc)
    real :: dafacdt(nc),d2afacdt2(nc)

    low = 1
    high = nc

    !> Ideal contributions
    sum1 = 0.0D0
    sum2 = 0.0D0
    sum3 = 0.0D0
    do i=low,high
      afac(i) = sqrt(cbeos%single(i)%a*cbeos%single(i)%alpha)
      sum1 = sum1 + afac(i)*zcomp(i)
      if (cbeos%cubic_verbose) then
        write(*,*) 'afac(,',i,') = ',afac(i)
        write(*,*) 'sum1 = ',sum1
      endif
    end do
    cbeos%suma = sum1*sum1

    do i=low,high
      if (afac(i) > 0.0) then
        dafacdt(i) = (0.5*cbeos%single(i)%a/afac(i)) * cbeos%single(i)%dalphadt
        d2afacdt2(i) = -0.25*cbeos%single(i)%a/afac(i) &
            * ((cbeos%single(i)%dalphadt*cbeos%single(i)%dalphadt) &
            - (2.0*cbeos%single(i)%alpha*cbeos%single(i)%d2alphadt2))/cbeos%single(i)%alpha
       sum2 = sum2 + dafacdt(i)*zcomp(i)
       sum3 = sum3 + d2afacdt2(i)*zcomp(i)
       cbeos%ait(i) = 2.0*dafacdt(i)*sum1
       cbeos%ai(i) = 2.0*afac(i)*sum1
     else
       dafacdt(i) = 0.0
       d2afacdt2(i) = 0.0
       cbeos%ait(i) = 0.0
       cbeos%ai(i) = 0.0
     endif
    end do

    do i=low,high
       cbeos%ait(i) = cbeos%ait(i) + 2.0*sum2*afac(i)
    end do

    do i=low,high
       do j=low,high
          cbeos%aij(i,j) = 2.0*afac(i)*afac(j)
       end do
    end do

    cbeos%at = 2.0*sum1*sum2
    cbeos%att = 2.0*(sum2*sum2+sum1*sum3)

    !> Nonideal contributions (the kij terms)
    do i=low,high
      do j=i+1,high
        pij = afac(i)*afac(j)*cbeos%kij(i,j)
        dpijdt = cbeos%kij(i,j)*(afac(j)*dafacdt(i) + &
             afac(i)*dafacdt(j))
        d2pijdt2 = cbeos%kij(i,j)*(afac(j)*d2afacdt2(i)+ &
             2.0*dafacdt(i)*dafacdt(j)+ &
             afac(i)*d2afacdt2(j))

        cbeos%suma   = cbeos%suma - 2.0*zcomp(i)*zcomp(j)*pij
        cbeos%ai(i)  = cbeos%ai(i) - 2.0*pij*zcomp(j)
        cbeos%ai(j)  = cbeos%ai(j) - 2.0*pij*zcomp(i)
        cbeos%ait(i) = cbeos%ait(i) - 2.0*dpijdt*zcomp(j)
        cbeos%ait(j) = cbeos%ait(j) - 2.0*dpijdt*zcomp(i)
        cbeos%at     = cbeos%at - 2.0*zcomp(i)*zcomp(j)*dpijdt
        cbeos%aij(i,j) = cbeos%aij(i,j) - 2.0*pij
        cbeos%aij(j,i) = cbeos%aij(j,i) - 2.0*pij
        cbeos%att   = cbeos%att - 2.0*zcomp(i)*zcomp(j)*d2pijdt2

       enddo
    enddo
  end subroutine vanderWaalsMix

  subroutine cbCalcMixtureParams(nc,cbeos,t,zcomp)
    !> Update the parameters of the cubic EoS, such as a and b, given the state (t, zcomp).
    use eosdata, only: cbSW, cbPT
    use cubic_eos, only: cb_eos
    implicit none
    integer, intent(in) :: nc                         !< number of components
    class(cb_eos), intent(inout) :: cbeos            !< cubic eos instance
    real, intent(in) :: t                             !< temperature (K)
    real, intent(in) :: zcomp(nc)                     !< mole numbers (mole)

    cbeos%sumn = sum(zcomp)
    cbeos%suma = 0.0D+00
    cbeos%sumb = 0.0D+00
    cbeos%sumc = 0.0D+00
    cbeos%At   = 0.0D+00
    cbeos%Att  = 0.0D+00
    cbeos%Bt   = 0.0D+00
    cbeos%Bit  = 0.0D+00
    cbeos%Btt   = 0.0D+00
    cbeos%Bi = 0.0D+00

    ! Mixing rule for the B-parameter
    call cbCalcBmix(nc,cbeos,t,zcomp)

    if (cbeos%subeosidx == cbSW .or. cbeos%subeosidx == cbPT) then
       ! Mixing rule for the C-parameter - need B-paramteter
       call cbCalcCmix(nc, cbeos, zcomp)
       call cbCalcM(cbeos, cbeos%sumc, cbeos%sumb)
    endif

    ! Mixing rule for the A-parameter - need B-paramters
    call cbCalcAmix(nc,cbeos,t,zcomp)
  end subroutine cbCalcMixtureParams

  !> For tuning of the parameters m1 and m2 in the cubic eos
  subroutine setCubicm1m2(cbeos, m1, m2)
    use thermopack_var, only: nce
    use cubic_eos, only: cb_eos
    implicit none
    class(cb_eos), intent(inout) :: cbeos            !< cubic eos instance
    real, intent(in) :: m1, m2
    !
    cbeos%m1 = m1
    cbeos%m2 = m2
    call cbCalcOmegaZc(nce,cbeos) !Uses the m1 and m2 for two-param eos
    cbeos%delta = -1.0D20
  end subroutine setCubicm1m2

  !> For retrieval of the parameters m1 and m2 in the cubic eos
  subroutine getCubicm1m2(cbeos, m1,m2)
    use cubic_eos, only: cb_eos
    implicit none
    class(cb_eos), intent(inout) :: cbeos            !< cubic eos instance
    real, intent(out) :: m1, m2
    !
    m1 = cbeos%m1
    m2 = cbeos%m2
  end subroutine getCubicm1m2

end module cbmix


!-------------------------------------------------------------------------------
!  The @header, @table_section, @table_subsection, @item and @end_table commands
!  are custom defined commands in Doxygen.in. They are defined under ALIASES.
!  For the page created here, the 80 column limit is exceeded. Arguments of
!  aliases are separated by ','. If you intended ',' to be a string you must use
!  an escaped comma '\,'.
!
!>  @page profile_sec Profiles types.
!>
!>  @tableofcontents
!>  @section profile_namelist_intro_sec Introduction
!>  This page contains discriptions of the types of profiles that can be used
!>  for parameterized profiles. Profiles are tagged in the
!>  @ref model_profile_sec, as @fixed_width{pp_*_} where @fixed_width{*} refers
!>  to the specific profile.
!>
!>  @section profile_types_sec Profile types
!>  Profiles can be defined as any of the following types.
!>
!>  @subsection profile_none none
!>  @fixed_width{none} No profile is used in this instance.
!>
!>  @subsection profile_two_power two_power
!>  @fixed_width{'two_power'} Profile is defined as a two power poly nomical
!>  with 4 coeffiecents. Coefficients are defined as in the first 4 indicies of
!>  the @fixed_width{'_b'} array. The profile is defined as follows.
!>
!>     a(x) = b[0] + b[1]*(1 - x^b[2])^b[3]
!>
!>  where x is valid from zero to one.
!>
!>  @subsection profile_two_power_gs two_power_gs
!>  @fixed_width{'two_power_gs'} Profile is defined as a two power poly nomical
!>  with 4 coefficients plus and an arbitrary number of additional guassian
!>  functions. The number of giassian functions if limited to the size of the
!>  @fixed_width{'_b'} array. The two power part is defined the same as
!>  @ref profile_two_power. The remaining guassian bits are defined as
!>
!>     a(x) = b[i]*Exp(-(x - b[i + 1])^2/b[i + 2]^2)
!>
!>  @subsection profile_two_power_r two_power_r
!>  @fixed_width{'two_power_r'} Reversed Two power profile defined the same as
!>  @ref profile_two_power except the argument is reversed. The function is
!>  maximum at x = 1 and minimum at x = 0.
!>
!>  @subsection profile_power_series_gs power_series
!>  @fixed_width{'power_series'} Profile is defined as a power series with
!>  @fixed_width{'_b'} array coefficients.
!>
!>     a(x) = b[0] + b[1]*x + b[2]*x^2 + b[3]*x^3 + etc...
!>
!>  @subsection profile_cubic_spline cubic_spline
!>  @fixed_width{'cubic_spline'} Profile defined as cubic spline segments.
!>  Splines knots are defined by the position, @fixed_width{'_as'} array, and
!>  amplitude, @fixed_width{'_af'} array.
!>
!>  @subsection profile_akima_spline akima_spline
!>  @fixed_width{'akima_spline'} Profile defined as akima spline segments.
!>  Splines knots are defined by the position, @fixed_width{'_as'} array, and
!>  amplitude, @fixed_width{'_af'} array.
!>
!>  @subsection profile_line_segment line_segment
!>  @fixed_width{'line_segment'} Profile defined as line segments. Segment knots
!>  are defined by the position, @fixed_width{'_as'} array, and amplitude,
!>  @fixed_width{'_af'} array.
!>
!>  @subsection profile_sq_ecp sq_exp_1d
!>  @fixed_width{'sq_exp_1d'} Guassian process profile are defined by hyper
!>  parameters in the first two elements of the @fixed_width{'_b'} array. The
!>  points the profile is computed to is defined by positions on the
!>  @fixed_width{'_as'} array.
!>
!>  @subsection profile_sq_ecp sq_exp_1d_ln
!>  @fixed_width{'sq_exp_1d_ln'} Guassian process profile are defined by hyper
!>  parameters in the first two elements of the @fixed_width{'_b'} array. The
!>  points the profile is computed to is defined by positions on the
!>  @fixed_width{'_as'} array.
!*******************************************************************************
!>  @file pprofile_T.f
!>  @brief Contains module @ref pprofile_T.
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Defines the base class of the type @ref pprofile_class. This module contains
!>  all the code necessary to define parameterized profiles.
!*******************************************************************************
      MODULE pprofile_T
      USE stel_kinds
      USE stel_constants
      USE v3_utilities
      USE mpi_inc
      USE profiler

      IMPLICIT NONE

!*******************************************************************************
!  model module parameters
!*******************************************************************************
!>  Maximum size for parameter profile name lengths.
      INTEGER, PARAMETER, PUBLIC :: p_type_len=20

!>  Lower array bound for function profiles.
      INTEGER, PARAMETER, PUBLIC :: ilb_b   = 0
!>  Upper array bound for function profiles.
      INTEGER, PARAMETER, PUBLIC :: iub_b   = 21
!>  Array size for spline profiles.
      INTEGER, PARAMETER, PUBLIC :: iub_asf = 101

!>  No profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_none_type           = -1
!>  Two Power profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_two_power_type      = 0
!>  Two Power with guassian profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_two_power_gs_type   = 1
!>  Power Series profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_power_series_type   = 2
!>  Cubic Spline profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_cubic_spline_type   = 3
!>  Akima Spline profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_akima_spline_type   = 4
!>  Line Segment profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_line_segment_type   = 5
!>  Reverse Two Power profile type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_two_power_r_type    = 6
!>  Guassian process profile 1D square exponetal type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_gp_1d_sexp_type     = 7
!>  Guassian process profile 1D square exponetal with the ln of sigma x type.
      INTEGER, PARAMETER, PRIVATE :: pprofile_gp_1d_ln_sexp_type  = 8

!*******************************************************************************
!  DERIVED-TYPE DECLARATIONS
!  1) model class
!
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  Base class representing a parameterized profile.
!-------------------------------------------------------------------------------
      TYPE :: pprofile_class
!>  Parameterized profile type
         INTEGER :: p_type = pprofile_none_type
!>  Array of coefficients for the functional profiles.
         REAL (rprec), DIMENSION(ilb_b:iub_b) :: b = 0.0
!>  Array of radial position values for the segmented profiles.
         REAL (rprec), DIMENSION(:), POINTER  :: as => null()
!>  Array of profile values for the segmented profiles.
         REAL (rprec), DIMENSION(:), POINTER  :: af => null()
!>  Index of the last segemented value.
         INTEGER                              :: maxSplineIndex = 1

!>  Cached value of the af array.
         REAL (rprec), DIMENSION(:), POINTER  :: cache => null()
!>  Cached value of the af array.
         REAL (rprec), DIMENSION(:), POINTER  :: cache_hyper => null()
      CONTAINS
         PROCEDURE :: get_value => pprofile_get_value
         PROCEDURE :: get_p_type_name => pprofile_get_p_type_name
         PROCEDURE :: get_gp_ij => pprofile_get_gp_ij
         PROCEDURE :: get_gp_pi => pprofile_get_gp_pi
         PROCEDURE :: get_gp_pp => pprofile_get_gp_pp
         GENERIC   :: get_gp => get_gp_ij, get_gp_pi, get_gp_pp
         PROCEDURE :: get_gp_num_hyper_param =>                                &
     &                   pprofile_get_gp_num_hyper_param
         PROCEDURE :: write => pprofile_write                                  &
         PROCEDURE :: save_state => pprofile_save_state
         PROCEDURE :: reset_state => pprofile_reset_state
         FINAL     :: pprofile_destruct
      END TYPE

!-------------------------------------------------------------------------------
!>  Pointer to a pprofile object. Used for creating arrays of pprofile pointers.
!>  This is needed because fortran does not allow arrays of pointers directly.
!-------------------------------------------------------------------------------
      TYPE pprofile_pointer
         TYPE (pprofile_class), POINTER :: p => null()
      END TYPE

!*******************************************************************************
! SECTION III. INTERFACE BLOCKS
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  Interface for sxrem ti constructor.
!-------------------------------------------------------------------------------
      INTERFACE pprofile_class
         MODULE PROCEDURE pprofile_construct
      END INTERFACE

      PRIVATE findMaxIndex

      CONTAINS
!*******************************************************************************
!  CONSTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Construct a @ref pprofile_class.
!>
!>  Allocates memory and initializes a @ref pprofile_class.
!>
!>  @param[in] p_type Profile type discription.
!>  @param[in] b      Array of functional profile coefficients
!>  @param[in] as     Array of segmented radial positions.
!>  @param[in] af     Array of segmented profile values.
!>  @returns A pointer to a constructed @ref pprofile_class object.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_construct(p_type, b, as, af)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (pprofile_class), POINTER :: pprofile_construct
      CHARACTER (len=*), INTENT(in)         :: p_type
      REAL(rprec), DIMENSION(:), INTENT(in) :: b
      REAL(rprec), DIMENSION(:), INTENT(in) :: as
      REAL(rprec), DIMENSION(:), INTENT(in) :: af

!  local variables
      CHARACTER (len=p_type_len)            :: p_type_lc
      REAL (rprec)                          :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      ALLOCATE(pprofile_construct)

! Store profile coeffients.
      pprofile_construct%b = b

! Find and store the maximum s index if specifying splines.
      pprofile_construct%maxSplineIndex = findMaxIndex(as)
      ALLOCATE(pprofile_construct%as(pprofile_construct%maxSplineIndex))
      pprofile_construct%as = as(1:pprofile_construct%maxSplineIndex)

      ALLOCATE(pprofile_construct%af(pprofile_construct%maxSplineIndex))
      pprofile_construct%af = af(1:pprofile_construct%maxSplineIndex)

!  Convert the type to lower case, and truncate
      p_type_lc = p_type
      CALL tolower(p_type_lc)
      SELECT CASE(TRIM(p_type_lc))

         CASE ('two_power')
            pprofile_construct%p_type = pprofile_two_power_type

         CASE ('two_power_gs')
            pprofile_construct%p_type = pprofile_two_power_gs_type

         CASE ('two_power_r')
            pprofile_construct%p_type = pprofile_two_power_r_type

         CASE ('power_series')
            pprofile_construct%p_type = pprofile_power_series_type

         CASE ('cubic_spline')
            IF (pprofile_construct%maxSplineIndex .lt. 4) THEN
               WRITE(*,*) 'pprofile:cubic spline: too few as values'
               WRITE(*,*) 'maxSplineIndex, as = ',                             &
     &                    pprofile_construct%maxSplineIndex
               WRITE(*,*) pprofile_construct%as
               CALL EXIT(1)
            END IF
            pprofile_construct%p_type = pprofile_cubic_spline_type

         CASE ('akima_spline')
            IF (pprofile_construct%maxSplineIndex .lt. 4) THEN
               WRITE(*,*) 'pprofile:akima spline: too few as values'
               WRITE(*,*) 'maxSplineIndex, as = ',                             &
     &                    pprofile_construct%maxSplineIndex
               WRITE(*,*) pprofile_construct%as
               CALL EXIT(1)
            END IF
            pprofile_construct%p_type = pprofile_akima_spline_type

         CASE ('line_segment')
            pprofile_construct%p_type = pprofile_line_segment_type

         CASE ('sq_exp_1d')
            pprofile_construct%p_type = pprofile_gp_1d_sexp_type
            ALLOCATE(pprofile_construct%cache(                                 &
     &                  SIZE(pprofile_construct%af)))
            ALLOCATE(pprofile_construct%cache_hyper(2))

         CASE ('sq_exp_1d_ln')
            pprofile_construct%p_type = pprofile_gp_1d_ln_sexp_type
            ALLOCATE(pprofile_construct%cache(                                 &
     &                  SIZE(pprofile_construct%af)))
            ALLOCATE(pprofile_construct%cache_hyper(2))

         CASE ('none')
            pprofile_construct%p_type = pprofile_none_type

         CASE DEFAULT
            pprofile_construct%p_type = pprofile_none_type
            WRITE(*,*) 'Unrecognized p_type:', p_type_lc
            WRITE(*,*) ' *** CHECK YOUR INPUT ***'

      END SELECT

      CALL profiler_set_stop_time('pprofile_construct', start_time)

      END FUNCTION

!*******************************************************************************
!  DESTRUCTION SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Deconstruct a @ref pprofile_class object.
!>
!>  Deallocates memory and uninitializes a @ref pprofile_class object.
!>
!>  @param[inout] this A @ref pprofile_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE pprofile_destruct(this)

      IMPLICIT NONE

!  Declare Arguments
      TYPE (pprofile_class), INTENT(inout) :: this

!  Start of executable code
      IF (ASSOCIATED(this%as)) THEN
         DEALLOCATE(this%as)
         this%as => null()
      END IF

      IF (ASSOCIATED(this%af)) THEN
         DEALLOCATE(this%af)
         this%af => null()
      END IF

      IF (ASSOCIATED(this%cache)) THEN
         DEALLOCATE(this%cache)
         this%cache => null()
      END IF

      IF (ASSOCIATED(this%cache_hyper)) THEN
         DEALLOCATE(this%cache_hyper)
         this%cache_hyper => null()
      END IF

      END SUBROUTINE

!*******************************************************************************
!  GETTER SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Gets the value of a profile at a radial position.
!>
!>  Evaluates the profile at the specifed radial position. If the radial
!>  position is out side the plasma, it returns the baseline value. If there is
!>  no profile type specified return the default value.
!>
!>  @param[in] this  A @ref pprofile_class instance.
!>  @param[in] s_arg Radial position to evaluate the profile at.
!>  @returns The value of the profile.
!>  @todo This function makes vmec specific assumptions of 1 being the maximum
!>  radial value.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_get_value(this, s_arg)
      USE line_segment
      USE functions

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec)                        :: pprofile_get_value
      CLASS (pprofile_class), INTENT (in) :: this
      REAL (rprec), INTENT(in)            :: s_arg

!  local variables
      REAL (rprec)                        :: s_use
      REAL (rprec)                        :: s_01
      LOGICAL                             :: l_01
      INTEGER                             :: i
      INTEGER                             :: iflag
      REAL (rprec)                        :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

!  Define argument and logical variable for s between zero and one
      s_01 = MAX(zero, MIN(one,s_arg))
      l_01 = (s_arg .ge. zero) .and. (s_arg .le. one)

      SELECT CASE(this%p_type)

         CASE (pprofile_none_type)
            pprofile_get_value = -1.E49_rprec

! v3fit uses an extra varible as an offset than vmec as a result the b array is
! one index shorter than what two_power takes.
         CASE (pprofile_two_power_type)
            pprofile_get_value = this%b(0)
            IF (l_01) THEN
               pprofile_get_value = pprofile_get_value                         &
     &                            + two_power(s_arg, this%b(1:iub_b))
            END IF

! v3fit uses an extra varible as an offset than vmec as a result the b array is
! one index shorter than what two_power takes. This profile reverses the s
! argument so that the maximum amplitude is at s=1 and the minimum is at s = 0.
         CASE (pprofile_two_power_r_type)
            pprofile_get_value = this%b(0)
            IF (l_01) THEN
               s_use = 1.0 - s_arg
               pprofile_get_value = pprofile_get_value                         &
     &                            + two_power(s_use, this%b(1:iub_b))
            END IF

! v3fit uses an extra varible as an offset than vmec as a result the b array is
! one index shorter than what two_power_gs takes. As a result only 5 guassian
! peaks maybe specified instead of the 6 vmec can use.
         CASE (pprofile_two_power_gs_type)
            pprofile_get_value = this%b(0)
            IF (l_01) THEN
               pprofile_get_value = pprofile_get_value                         &
     &                            + two_power_gs(s_arg,                        &
     &                                           this%b(1:iub_b))
            END IF

         CASE (pprofile_power_series_type)
            pprofile_get_value = zero
            DO i = iub_b, ilb_b, -1      ! all of b array, backwards
               pprofile_get_value = pprofile_get_value*s_01                    &
     &                            + this%b(i)
            END DO

         CASE (pprofile_cubic_spline_type)
            s_use = MIN(this%as(this%maxSplineIndex),                          &
     &                  MAX(s_arg, this%as(1)))
            CALL spline_cubic(s_use, pprofile_get_value,                       &
     &                        this%as, this%af,                                &
     &                        this%maxSplineIndex, iflag)
            IF (iflag .ge. 0) THEN

               CALL profiler_set_stop_time('pprofile_get_value',               &
     &                                     start_time)

               RETURN
            ELSE IF (iflag .eq. -1) THEN
               WRITE (*,*) 'ERROR: pprofile: outside value from ' //           &
     &                     'spline_cubic'
            ELSE IF(iflag .eq. -2) THEN
               WRITE (*,*) 'ERROR: pprofile:  decreasing s values ' //         &
     &                     'in spline_cubic'
            ELSE
               WRITE (*,*) 'ERROR: pprofile: unknown error from ' //           &
     &                     'spline_cubic'
            END IF
!  Splines shuld not reach this point without triggering an error.
            CALL EXIT(1)

         CASE (pprofile_akima_spline_type)
            s_use = MIN(this%as(this%maxSplineIndex),                          &
     &                  MAX(s_arg,this%as(1)))
            CALL spline_akima(s_use, pprofile_get_value,                       &
     &                        this%as, this%af,                                &
     &                        this%maxSplineIndex, iflag)
            IF (iflag < 0) THEN
               WRITE (*,*) 'ERROR: pprofile: bad value from ' //               &
     &                     'spline_akima requested'
               CALL EXIT(1)
            END IF

         CASE (pprofile_line_segment_type,                                     &
     &         pprofile_gp_1d_sexp_type,                                       &
     &         pprofile_gp_1d_ln_sexp_type)
            CALL line_seg(s_arg, pprofile_get_value, this%as, this%af,         &
     &                    this%maxSplineIndex)

      END SELECT

      CALL profiler_set_stop_time('pprofile_get_value', start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Gets the name of the profile type.
!>
!>  Convertes a profile type to a string discription.
!>
!>  @param[in] this  A @ref pprofile_class instance.
!>  @returns The name of the profile type.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_get_p_type_name(this)

!  Declare Arguments
      CHARACTER (len=p_type_len)         :: pprofile_get_p_type_name
      CLASS (pprofile_class), INTENT(in) :: this

!  local variables
      REAL (rprec)                       :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE (this%p_type)

         CASE (pprofile_two_power_type)
            pprofile_get_p_type_name = 'two_power'

         CASE (pprofile_two_power_gs_type)
            pprofile_get_p_type_name = 'two_power_gs'

         CASE (pprofile_two_power_r_type)
            pprofile_get_p_type_name = 'two_power_r'

         CASE (pprofile_power_series_type)
            pprofile_get_p_type_name = 'power_series'

         CASE (pprofile_cubic_spline_type)
            pprofile_get_p_type_name = 'cubic_spline'

         CASE (pprofile_akima_spline_type)
            pprofile_get_p_type_name = 'akima_spline'

         CASE (pprofile_line_segment_type)
            pprofile_get_p_type_name = 'line_segment'

         CASE (pprofile_gp_1d_sexp_type)
            pprofile_get_p_type_name = 'sq_exp_1d'

         CASE (pprofile_gp_1d_ln_sexp_type)
            pprofile_get_p_type_name = 'sq_exp_1d_ln'

         CASE DEFAULT
            pprofile_get_p_type_name = 'none'

      END SELECT

      CALL profiler_set_stop_time('pprofile_get_p_type_name',                  &
     &                            start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Get the guassian process kernel value for the two as indicies.
!>
!>  Indicies are the index of the as array. Only valid for guassian process
!>  profiles.
!>
!>  @param[in] this A @ref pprofile_class instance.
!>  @param[in] i    ith profile position.
!>  @param[in] j    jth profile position.
!>  @returns The name of the profile type.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_get_gp_ij(this, i, j)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec)                        :: pprofile_get_gp_ij
      CLASS (pprofile_class), INTENT (in) :: this
      INTEGER, INTENT(in)                 :: i
      INTEGER, INTENT(in)                 :: j

!  local variables
      REAL (rprec)                       :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE(this%p_type)

         CASE (pprofile_gp_1d_sexp_type)
            pprofile_get_gp_ij = pprofile_gp_1d_sqexp_k(this,                  &
     &                                                  this%as(i),            &
     &                                                  this%as(j))

         CASE (pprofile_gp_1d_ln_sexp_type)
            pprofile_get_gp_ij = pprofile_gp_1d_sqexp_ln_k(this,               &
     &                                                     this%as(i),         &
     &                                                     this%as(j))

         CASE DEFAULT
            pprofile_get_gp_ij = 0.0

      END SELECT

      CALL profiler_set_stop_time('pprofile_get_gp_ij', start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Get the guassian process kernel value for the point and index.
!>
!>  Index are the index of the as array. Point is a measurement point on the
!>  profile. Only valid for guassian process profiles.
!>
!>  @param[in] this  A @ref pprofile_class instance.
!>  @param[in] p     Point to evaluate the kernel at.
!>  @param[in] i     Profile position index.
!>  @returns The value of the gp kernel function for p and i.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_get_gp_pi(this, p, i)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec)                        :: pprofile_get_gp_pi
      CLASS (pprofile_class), INTENT (in) :: this
      REAL (rprec), INTENT(in)            :: p
      INTEGER, INTENT(in)                 :: i

!  local variables
      REAL (rprec)                        :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE(this%p_type)

         CASE (pprofile_gp_1d_sexp_type)
            pprofile_get_gp_pi = pprofile_gp_1d_sqexp_k(this, p,               &
     &                                                  this%as(i))

         CASE (pprofile_gp_1d_ln_sexp_type)
            pprofile_get_gp_pi = pprofile_gp_1d_sqexp_ln_k(this, p,            &
     &                                                     this%as(i))

         CASE DEFAULT
            pprofile_get_gp_pi = 0.0

      END SELECT

      CALL profiler_set_stop_time('pprofile_get_gp_pi', start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Get the guassian process kernel value for two points.
!>
!>  Points are a measurement point on the profile. Only valid for guassian
!>  process profiles.
!>
!>  @param[in] this A @ref pprofile_class instance.
!>  @param[in] p1   First point to evaluate the kernel at.
!>  @param[in] p2   SEOND point to evaluate the kernel at.
!>  @returns The value of the gp kernel function for p and i.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_get_gp_pp(this, p1, p2)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec)                        :: pprofile_get_gp_pp
      CLASS (pprofile_class), INTENT (in) :: this
      REAL (rprec), INTENT(in)            :: p1
      REAL (rprec), INTENT(in)            :: p2

!  local variables
      REAL (rprec)                        :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE(this%p_type)

         CASE (pprofile_gp_1d_sexp_type)
            pprofile_get_gp_pp = pprofile_gp_1d_sqexp_k(this, p1, p2)

         CASE (pprofile_gp_1d_ln_sexp_type)
            pprofile_get_gp_pp = pprofile_gp_1d_sqexp_ln_k(this, p1, p2)

         CASE DEFAULT
            pprofile_get_gp_pp = 0.0

      END SELECT

      CALL profiler_set_stop_time('pprofile_get_gp_pp', start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Get the number of hyper parameters for guassian process kernel.
!>
!>  Hyper parameters must be set to maximise the log of the evidence. If this
!>  profile is not a guassian process return zero.
!>
!>  @param[in] this A @ref pprofile_class instance.
!>  @returns Number of hyper parameters.
!-------------------------------------------------------------------------------
      FUNCTION pprofile_get_gp_num_hyper_param(this)

      IMPLICIT NONE

!  Declare Arguments
      INTEGER :: pprofile_get_gp_num_hyper_param
      CLASS (pprofile_class), INTENT (in) :: this

!  local variables
      REAL (rprec)                        :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE(this%p_type)

         CASE (pprofile_gp_1d_sexp_type, pprofile_gp_1d_ln_sexp_type)
            pprofile_get_gp_num_hyper_param = 2

         CASE DEFAULT
            pprofile_get_gp_num_hyper_param = 0

      END SELECT

      CALL profiler_set_stop_time('pprofile_get_gp_num_hyper_param',           &
     &                            start_time)

      END FUNCTION

!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Write out the profile to an output file.
!>
!>  This formats and writes out information about a parameterized profile.
!>
!>  @param[in] this A @ref pprofile_class instance.
!>  @param[in] id   Identification of the profle.
!>  @param[in] iou  Input/output unit of the output file.
!-------------------------------------------------------------------------------
      SUBROUTINE pprofile_write(this, id, iou)
      IMPLICIT NONE

!  Declare Arguments
      CLASS (pprofile_class), INTENT(in) :: this
      CHARACTER (len=*), INTENT(in)      :: id
      INTEGER, INTENT(in)                :: iou

!  local variables
      INTEGER                           :: i
      REAL (rprec)                      :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

!  Actual write. Could do a select-case on p_type.
      WRITE(iou,1100) id
      WRITE(iou,1200) TRIM(this%get_p_type_name())

      SELECT CASE(this%p_type)

         CASE (pprofile_two_power_type,                                        &
     &         pprofile_two_power_r_type)
            WRITE(iou,1210)
            WRITE(iou,1300) this%b(0:3)

         CASE (pprofile_power_series_type,                                     &
     &         pprofile_two_power_gs_type)
            WRITE(iou,1220)
            WRITE(iou,1300) this%b(ilb_b:iub_b)

         CASE (pprofile_cubic_spline_type,                                     &
     &         pprofile_akima_spline_type,                                     &
     &         pprofile_line_segment_type)
            WRITE(iou,1230)
            WRITE(iou,1231) (i, this%as(i), this%af(i),                        &
     &                       i = 1, this%maxSplineIndex)

         CASE (pprofile_gp_1d_sexp_type,                                       &
     &         pprofile_gp_1d_ln_sexp_type)
            WRITE(iou,1300) this%b(0:1)
            WRITE(iou,1231) (i, this%as(i), this%af(i),                        &
     &                       i = 1, this%maxSplineIndex)

      END SELECT

      CALL profiler_set_stop_time('pprofile_write', start_time)

1100  FORMAT(/' Parameterized Profile Write: id = ',a)
1200  FORMAT('   pp_type = ',a)
1210  FORMAT(' b_0 + Th(s)Th(1-s)(b_1 (1 - s ** b_2) ** b_3).',                &
     &       '   b(0:3) = ')
1220  FORMAT(' Th(s)Th(1-s)[Sum_0_n b_i s** i].   b(0:n) = ')
1230  FORMAT(' i       as(i)           af(i)')
1231  FORMAT(1x,i3,2x,es15.8,2x,es15.8)
1300  FORMAT(4(2x,es15.8))

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Save the internal state of the profile.
!>
!>  Saves the profile af array if using the guassian process.
!>
!>  @param[inout] this A @ref pprofile_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE pprofile_save_state(this)

      IMPLICIT NONE

!  Declare Arguments
      CLASS (pprofile_class), INTENT(inout) :: this

!  local variables
      REAL (rprec)                          :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE (this%p_type)

         CASE (pprofile_gp_1d_sexp_type,                                       &
     &         pprofile_gp_1d_ln_sexp_type)
            this%cache = this%af
            this%cache_hyper = this%b(0:1)

      END SELECT

      CALL profiler_set_stop_time('pprofile_save_state', start_time)

      END SUBROUTINE

!-------------------------------------------------------------------------------
!>  @brief Reset the internal state of the profile.
!>
!>  Resets the profile af array if using the guassian process.
!>
!>  @param[inout] this A @ref pprofile_class instance.
!-------------------------------------------------------------------------------
      SUBROUTINE pprofile_reset_state(this)

      IMPLICIT NONE

!  Declare Arguments
      CLASS (pprofile_class), INTENT(inout) :: this

!  local variables
      REAL (rprec)                          :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      SELECT CASE (this%p_type)

         CASE (pprofile_gp_1d_sexp_type,                                       &
     &         pprofile_gp_1d_ln_sexp_type)
            this%af = this%cache
            this%b(0:1) = this%cache_hyper

      END SELECT

      CALL profiler_set_stop_time('pprofile_reset_state', start_time)

      END SUBROUTINE

!*******************************************************************************
!  PRIVATE
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Finds the index of the maximum radial position.
!>
!>  This assumes that the radials positions are specifed in increasing order.
!>
!>  @param[in] s_array Array of radial positions
!>  @returns Index of the last position.
!-------------------------------------------------------------------------------
      FUNCTION findMaxIndex(s_array)

      IMPLICIT NONE

!  Declare Arguments
      INTEGER                               :: findMaxIndex
      REAL(rprec), DIMENSION(:), INTENT(in) :: s_array

!  local variables
      REAL (rprec)                          :: start_time

!  Start of executable code
      start_time = profiler_get_start_time()

      findMaxIndex = MAXLOC(s_array, dim=1)

      CALL profiler_set_stop_time('findMaxIndex', start_time)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Evaluate the one dimensional squared exponential kernel.
!>
!>  The squared exponential kernel is defined as
!>
!>    b(0)^2*exp(-(x1 - x2)^2/2*b(1)^2)                                      (1)
!>
!>  where b(0) and b(1) are the hyper parameters.
!>
!>  @param[in] this A @ref pprofile_class instance.
!>  @param[in] p1   First position.
!>  @param[in] p2   Second position.
!>  @returns Value of the kernel.
!-------------------------------------------------------------------------------
      PURE FUNCTION pprofile_gp_1d_sqexp_k(this, p1, p2)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec) :: pprofile_gp_1d_sqexp_k
      TYPE (pprofile_class), INTENT(in) :: this
      REAL (rprec), INTENT(in)          :: p1
      REAL (rprec), INTENT(in)          :: p2

!  Start of executable code
      pprofile_gp_1d_sqexp_k =                                                 &
     &   this%b(0)**2*EXP(-(p1 - p2)**2/(2.0*this%b(1)**2))

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Evaluate the one dimensional squared exponential kernel
!>
!>  This kernel is mathmatically the same as the squared exp kernel, but here
!>  we treat the amplitude [ b(0) ] differently. The value of b(0) used here is
!>  equal to the log of value of b(0) used in the 1d_sqexp. I'm testing this
!>  formulation to see if it helps convergence.
!>
!>    exp(2*b(0) - (x1- x2)**2)/2*b(1)**2)                                   (1)
!>
!>  @param[in] this A @ref pprofile_class instance.
!>  @param[in] p1 first position
!>  @param[in] p2 second position
!>  @param[in] b  Array of coefficients
!>  @returns Value of the kernel
!-------------------------------------------------------------------------------
      PURE FUNCTION pprofile_gp_1d_sqexp_ln_k(this, p1, p2)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec) :: pprofile_gp_1d_sqexp_ln_k
      TYPE (pprofile_class), INTENT(in) :: this
      REAL (rprec), INTENT(in)          :: p1
      REAL (rprec), INTENT(in)          :: p2

!  Start of executable code
      pprofile_gp_1d_sqexp_ln_k =                                              &
     &   EXP(2.0*this%b(0) - (p1 - p2)**2/(2.0*this%b(1)**2))

      END FUNCTION

      END MODULE


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! PROGRAM TO COMPUTE FLOW PARAMETERS FOR COUETTE-POISEUILLE FLOW !!
!! Written by: Aakash PATIL, IMP Turbulence                       !!
!! Mentor:  Dr. Jean-Philip LAVAL                                 !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program cpflow1D

use module_parameters
use module_grid
use module_solver
use module_triSolve

implicit none

        INTEGER		    ::I,K
	REAL(8)	            ::UMAX,UAVG,UTAU1,UTAU2
	REAL(8),ALLOCATABLE ::YHAD(:),YPAD(:),A(:),B(:)
	REAL(8),ALLOCATABLE ::U(:),U1(:),MIX_LEN(:),LEN_ZERO(:),TKIN_VIS(:),TKIN_VISN(:),TKIN_VISS(:),LD(:),MD(:),UD(:),D(:)
	REAL(8)	::A1,A2,ERROR
        CHARACTER(len=100)::excommand
        CHARACTER(len=15):: OUTPUTFILE
        REAL(8)          ::VW, H, DPDX
        INTEGER:: NUM_CASE

        print*, "########################################"
        print*, "###### Couette_Poiseuille-FlowCode #####"
        print*, "########################################"

        !CASE SELECTION
        print*,"Please Enter a Case Number(from 1 to 18):"
        read*, NUM_CASE
        !DO NUM_CASE=1,19 !start of allCaseLoop
        !NUM_CASE=15     !hard assign

        !Checking Case Number and Managing Filenames
        if (NUM_CASE < 10) then
                  write (OUTPUTFILE, "(A6,I1,A8)") "Case_0",NUM_CASE,"_sim.dat"
        elseif (NUM_CASE<19) then
                  write (OUTPUTFILE, "(A5,I2,A8)") "Case_",NUM_CASE,"_sim.dat"
        else
                  print *, "Invalid Case Number. Exiting"
                  STOP
        endif

        !Read the Parameters
        print *, "### Fetching Values from the Parameters File ###"
        CALL case_select(NUM_CASE,VW, H, DPDX)
        print *, "The selected CASE NUMBER is ",NUM_CASE
        print *, "Here, the values of VW, H, DPDX are ",VW, H, DPDX, "respectively."
        print *, "The data generated will be saved to file ", OUTPUTFILE

	ALLOCATE(YPAD(N),YHAD(N),U(N),U1(N),MIX_LEN(N),LEN_ZERO(N),A(N),B(N))
	ALLOCATE(TKIN_VIS(N),TKIN_VISN(N),TKIN_VISS(N),LD(N),MD(N),UD(N),D(N))
	U=0.0d0

	!Call Main Functions
	print *, "### Generating Grid ###"
	CALL sGrid_Generator(H,N,ALPHA,YPAD,YHAD)
	print *, "### Solving for Flow Parameters ###"
        CALL SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,KIN_VIS,CONV_CRIT,MAX_ITER,OUTPUTFILE,NUM_CASE)

        !Data Management
        print *, "### Organizing Data Files ###"
        !print *, "Copying Generated GRID.dat to the directory '../Simulated_Data'"
        !call system('cp GRID.dat ../Simulated_Data/GRID.dat')
        print *, "Copied Successfully "
        print *, "Copying Generated simulation data to the directory '../Simulated_Data'"
        excommand="cp "//OUTPUTFILE//" ../Simulated_Data/"//OUTPUTFILE
        print *, trim(excommand)
        call system(trim(excommand))
        print *, "Copied Successfully "

        !Automatic Plotting
        print *, "### Plotting ###"
        excommand="python autoplotting.py --file "//OUTPUTFILE
        if (PLOT=='Y') then
                print *, "Creating Plots"
                print *, trim(excommand)
                call system(trim(excommand))
        else
                print *, "Auto Plotting Disabled"
        end if

        DEALLOCATE(YPAD,YHAD,U,U1,MIX_LEN,LEN_ZERO,A,B)
	DEALLOCATE(TKIN_VIS,TKIN_VISN,TKIN_VISS,LD,MD,UD,D)

        print*, "Cleaning Execution Directory"
        call system("rm *.dat")

        !END DO
end program


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C Program   USMTUNED1
C Convolves an image with a  2-D  function  which  may  be
C constant (a top hat) or a Gaussian, and of variable size.
C JLP
C Version 20-04-90
C--*******************************************************************
C         USER PARAMETERS:-
C
C         INPUT                               This   is   the   input
C                                             Starlink image.
C
C         OUTPUT                              This  is   the   output   2-D
C                                             Starlink image.
C
C         BOXSIZ          5                   The size  of  the  convolving
C                                             box - between 3 and 33
C                                             and odd.
C
C         TYPE            GAUSS               This  may   be   Tophat   (or
C                                             anything starting with T) for
C                                             convolution with  a  top  hat
C                                             (constant);     any     other
C                                             response    gives    Gaussian
C                                             smoothing.
C
C         SIGMA           1                   If the TYPE  is  Gauss,  then
C                                             this  is  the  sigma  of  the
C                                             convolving Gaussian
C
C         FRACTION        1                   The fraction of the smoothed
C                                             image which is subtracted
C
C         RMS             0                   The minimum dispersion in the
C                                             image (i.e. dispersion of sky)
C
C         IX0,IY0                               Position of the nucleus
C
C
C         M.J.Currie               RAL                            27-Apr-84
C         W.B.Sparks               RGO                            14-Jul-86
C
C Example: RUNS USMTUNED /INPUT=  /OUTPUT=  /BOXSIZE=5 /TYPE=TOPHAT /X0=
C                        /Y0=  /RMS=  /SIGMA=
C--------------------------------------------------------------------------
	PROGRAM USMTUNED1
	PARAMETER (MAXSIZ=33)

	INTEGER*4 AXIS(2),KIND,SIZE,PIN,POUT,ISTAT
	INTEGER*4 MADRID(1)
	REAL*4 SIGMA
	CHARACTER*6 TYPE,BUFFER*32,COMMENTS*80,NAME*40
	COMMON /VMR/MADRID
C
	CALL JLP_BEGIN
        CALL JLP_INQUIFMT

C Set up input and output images
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
10      FORMAT(A)
	CALL JLP_VM_READIMAG(PIN,AXIS(1),AXIS(2),NAME,COMMENTS)
	ISIZE=AXIS(1)*AXIS(2)*4
	CALL JLP_GETVM(POUT,ISIZE)
C
C Now pick up the boxsize
C
	SIZE=5
  100 CALL RDKEYI('BOXSIZ',.TRUE.,1,SIZE,I,ISTAT)
27	WRITE(6,28)
28	FORMAT(' Size of the box (odd number between 3 and 33)')
	READ(5,*,ERR=27) SIZE
	IF (SIZE.LT.3.OR.SIZE.GT.MAXSIZ.OR. MOD(SIZE,2) .EQ. 0 ) THEN
	  WRITE(6,*) ' Error: try again'
	  GOTO 27
	ENDIF
C
C And the type of profile
C
	TYPE='GAUSS '
	WRITE(6,*)' Option (GAUSS or TOPHAT)?'
	READ(5,10)TYPE
10	FORMAT(A)
	IF((TYPE(1:1).EQ.'T').OR.(TYPE(1:1).EQ.'t')) THEN
	  KIND=1
	ELSE
	  KIND=2
C Pick up sigma if a gaussian profile is to be used
	  SIGMA=1
	  WRITE(6,*)' Sigma (pixels) :'
	  READ(5,*) SIGMA
	END IF
C
	fraction=1.0
	WRITE(6,*)' Fraction to be removed (between 0. and 1.)'
	READ(5,*) FRACTION
	rms=0.0
	WRITE(6,*) 'Input intensity dispersion of sky'
	READ(5,*) RMS
	WRITE(6,*) 'Position of nucleus of galaxy: IX0,IY0'
	READ(5,*) IX0,IY0
C
C Now call the working subroutine
C
	CALL USMTUNED_SUB(MADRID(PIN),MADRID(POUT),AXIS(1),AXIS(2),
     1            KIND,SIZE,SIGMA,FRACTION,RMS,IX0,IY0)

	WRITE(COMMENTS,11) NAME(1:20)
11	FORMAT(' USMTUNED of ',A20)
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	CALL JLP_WRITEIMAG(MADRID(POUT),AXIS(1),AXIS(2),AXIS(1),
     1	NAME,COMMENTS)

	CALL JLP_END
	STOP
	END
C************************************************************************
      SUBROUTINE USMTUNED_SUB(IN,OUT,NX,NY,KIND,NB,SIGMA,FRACTION,
     1 rms,ix0,iy0)
C+************************************************************************
C
C
C      CONVOLVES A 2-D ARRAY WITH A BOX WITH GAUSSIAN OR TOP-HAT SHAPE
C
C      IN IS THE INPUT ARRAY , AND OUT THE OUTPUT ARRAY BOTH OF SIZE
C      NX BY NY
C      KIND = 1 GIVES TOP-HAT KIND = 2 (OR ANYTHING EXCEPT 1) GIVES GAUSSIAN
C      THE CONVOLVING BOX IS OF SIZE NB BY NB
C      IF KIND=2 , SIGMA IS THE STANDARD DEVIATION OF THE GAUSSIAN
C
C-************************************************************************
      REAL WT(33,33)
      REAL IN(NX,NY),OUT(NX,NY)
      INTEGER*4 KIND,NB
      REAL*4 SIGMA
      CHARACTER*72 LIST
      CHARACTER*13 MESS
      external delta
C
C      FIRST GENERATE THE CONVOLVING FUNCTION
C
C      THE SUM OF THE ELEMENTS SHOULD BE 1 , SO FIND TOTAL
C
      TOT=0
      IF (KIND.EQ.1) THEN
         DO 20 J=1,NB
            DO 10 I=1,NB
               WT(I,J)=1.0
               TOT=TOT+WT(I,J)
   10       CONTINUE
   20    CONTINUE
      ELSE
         ALPHA=1.0/(1.4142*SIGMA)
         A2=ALPHA*ALPHA
         C=REAL(NB+1)/2.0
         DO 40 J=1,NB
            Y=REAL(J)
            DO 30 I=1,NB
               X=REAL(I)
               R2=(X-C)*(X-C)+(Y-C)*(Y-C)
               WT(I,J)=EXP(-A2*R2)
               TOT=TOT+WT(I,J)
   30       CONTINUE
   40    CONTINUE
      END IF
      write(6,98)tot
   98 format(1h ,'Sum of weights before normalization',2x,e13.6)
c
c Renormalize to sum=1 so that delta-function is properly scaled
c
      do j=1,nb
        do i=1,nb
          wt(i,j)=wt(i,j)/tot
        enddo
      enddo

      IEDGE=(NB-1)/2
c      if(iedge.gt.2)then
c        write(6,*) ' Will estimate intensity dispersions in 5x5 box'
c        iside=2
c      else
        iside=iedge
c      endif
      nb2=iside+1
c
c Find max intensity dispersion corresponding to a delta-function filter
c
      s=0.0
      sx=0.0
      sxx=0.0
      jjm=max(1,iy0-iside)
      jjp=min(ny,iy0+iside)
      iim=max(1,ix0-iside)
      iip=min(nx,ix0+iside)
      do kj=jjm,jjp
        do ki=iim,iip
          s=s+1.0
          sx=sx+in(ki,kj)
          sxx=sxx+in(ki,kj)*in(ki,kj)
        enddo
      enddo
      sigmax=sqrt((sxx-(sx*sx/s))/(s-1.0))
      write(6,99)rms,sigmax,sigma
   99 format(1h ,'Sky rms, galaxy rms, length scale (sigma):',
     1 3(2x,e13.6))
      if(sigmax.le.rms)then
        write(6,*) 'Sigmax<=rms'
        go to 80
      endif
      delsig=sigmax-rms

      DO J=1,NY
C
C   JM,JP ARE THE MINIMUM AND MAXIMUM ROWS USED IN THE SMOOTH
C   IM,IP ARE THE MINIMUM AND MAXIMUM COLUMNS USED IN THE SMOOTH
C
         JM=MAX(1,J-IEDGE)
         JP=MIN(NY,J+IEDGE)
         jjm=max(1,j-iside)
         jjp=min(ny,j+iside)
         DO I=1,NX
            IM=MAX(1,I-IEDGE)
            IP=MIN(NX,I+IEDGE)
            iim=max(1,i-iside)
            iip=min(nx,i+iside)
c
c Find mean and sd in box
c
            s=0.0
            sx=0.0
            sxx=0.0
            do kj=jjm,jjp
              do ki=iim,iip
                s=s+1.0
                sx=sx+in(ki,kj)
                sxx=sxx+in(ki,kj)*in(ki,kj)
              enddo
            enddo
            if(s.gt.1.0)then
             term=(sxx-(sx*sx/s))/(s-1.0)
             if(term.gt.0.0)then
               sigm=sqrt(term)
             else
               write(6,88)term,i,j
   88 format(1h ,'Term,i,j=',e13.6,2i4)
               sigm=0.0
             endif
            else
             sigm=0.0
            endif
            dfrac=(min(sigmax,max(rms,sigm))-rms)/delsig
            eps=1.0-dfrac

            S=0.
C
C   JJ IS THE NUMBER OF ROWS OF THE BOX CLIPPED BY THE IMAGE'S EDGE
C   II IS THE NUMBER OF COLUMNS OF THE BOX CLIPPED BY THE IMAGE'S EDGE
C
            JJ=MIN(JM-J+IEDGE,IEDGE)
            WTS=0.
            DO KJ=JM,JP
               JJ=JJ+1
               II=MIN(IM-I+IEDGE,IEDGE)
               DO KI=IM,IP
                  II=II+1
                  weight=eps*WT(ii,jj)+dfrac*delta(ii,jj,nb2)
                  S=S+IN(KI,KJ)*weight
C
C   WTS SUMS THE WEIGHTS FOR NORMALISATION
C
                  WTS=WTS+weight
               END DO
            END DO
            if(wts.gt.0.0)then
               OUT(I,J)=IN(I,J)-FRACTION*S/WTS
            else
               out(i,j)=0.0
            endif
         END DO
C
C   OUTPUT TO ENCOURAGE THE USER
C
         IF (MOD(J,30) .EQ. 0) THEN
            MESS='FINISHED LINE'
            WRITE (6,'(A,2X,I4)') MESS,J
         END IF
      END DO
C
   80 return
      END
      function delta(i,j,nb2)
      if(i.eq.j.and.i.eq.nb2)then
        delta=1.0
      else
        delta=0.0
      endif
      return
      end


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_SBLS_EXAMPLE
   USE GALAHAD_SBLS_double                    ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   TYPE ( SMT_type ) :: H, A, C
   REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: SOL
   TYPE ( SBLS_data_type ) :: data
   TYPE ( SBLS_control_type ) :: control
   TYPE ( SBLS_inform_type ) :: inform
   INTEGER :: s
   INTEGER :: n = 3, m = 2, h_ne = 4, a_ne = 4, c_ne = 1
   INTEGER :: data_storage_type = 0
! start problem data
   ALLOCATE( SOL( n + m ) )
   SOL( 1 : n ) = (/ 7.0_wp, 4.0_wp, 8.0_wp /)  ! RHS a
   SOL( n + 1 : n + m ) = (/ 2.0_wp, 1.0_wp /)  ! RHS b
! sparse co-ordinate storage format
   IF ( data_storage_type == 0 ) THEN
   CALL SMT_put( H%type, 'COORDINATE', s )  ! Specify co-ordinate
   CALL SMT_put( A%type, 'COORDINATE', s )  ! storage for H, A and C
   CALL SMT_put( C%type, 'COORDINATE', s )
   ALLOCATE( H%val( h_ne ), H%row( h_ne ), H%col( h_ne ) )
   ALLOCATE( A%val( a_ne ), A%row( a_ne ), A%col( a_ne ) )
   ALLOCATE( C%val( c_ne ), C%row( c_ne ), C%col( c_ne ) )
   H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! matrix H
   H%row = (/ 1, 2, 3, 3 /)                     ! NB lower triangle
   H%col = (/ 1, 2, 3, 1 /) ; H%ne = h_ne
   A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! matrix A
   A%row = (/ 1, 1, 2, 2 /)
   A%col = (/ 1, 2, 2, 3 /) ; A%ne = a_ne
   C%val = (/ 1.0_wp /) ! matrix C
   C%row = (/ 2 /) ! NB lower triangle
   C%col = (/ 1 /) ; C%ne = c_ne
! sparse row-wise storage format
   ELSE IF ( data_storage_type == - 1 ) THEN
   CALL SMT_put( H%type, 'SPARSE_BY_ROWS', s )  ! Specify sparse-by-rows
   CALL SMT_put( A%type, 'SPARSE_BY_ROWS', s )  ! storage for H, A and C
   CALL SMT_put( C%type, 'SPARSE_BY_ROWS', s )
   ALLOCATE( H%val( h_ne ), H%col( h_ne ), H%ptr( n + 1 ) )
   ALLOCATE( A%val( a_ne ), A%col( a_ne ), A%ptr( m + 1 ) )
   ALLOCATE( C%val( c_ne ), C%col( c_ne ), C%ptr( m + 1 ) )
   H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! matrix H
   H%col = (/ 1, 2, 3, 1 /)                     ! NB lower triangular
   H%ptr = (/ 1, 2, 3, 5 /)                     ! Set row pointers
   A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! matrix A
   A%col = (/ 1, 2, 2, 3 /)
   A%ptr = (/ 1, 3, 5 /)                        ! Set row pointers
   C%val = (/ 1.0_wp /)                         ! matrix C
   C%col = (/ 1 /)                              ! NB lower triangular
   C%ptr = (/ 1, 1, 2 /)                        ! Set row pointers
! dense storage format
   ELSE
   CALL SMT_put( H%type, 'DENSE', s )  ! Specify dense
   CALL SMT_put( A%type, 'DENSE', s )  ! storage for H, A and C
   CALL SMT_put( C%type, 'DENSE', s )
   ALLOCATE( H%val( n * ( n + 1 ) / 2 ) )
   ALLOCATE( A%val( n * m ) )
   ALLOCATE( C%val( m * ( m + 1 ) / 2 ) )
   H%val = (/ 1.0_wp, 0.0_wp, 2.0_wp, 4.0_wp, 0.0_wp, 3.0_wp /) ! H
   A%val = (/ 2.0_wp, 1.0_wp, 0.0_wp, 0.0_wp, 1.0_wp, 1.0_wp /) ! A
   C%val = (/ 0.0_wp, 1.0_wp, 0.0_wp /)                         ! C
! problem data complete
   END IF
   CALL SBLS_initialize( data, control )        ! Initialize control parameters
!  control%print_level = 1
   control%preconditioner = 2
! factorize matrix
   CALL SBLS_form_and_factorize( n, m, H, A, C, data, control, inform )
   IF ( inform%status < 0 ) THEN                !  Unsuccessful call
     WRITE( 6, "( ' SBLS_form_and_factorize exit status = ', I6 ) " )          &
       inform%status
     STOP
   END IF
! solve system
   CALL SBLS_solve( n, m, A, C, data, control, inform, SOL )
   IF ( inform%status == 0 ) THEN                !  Successful return
     WRITE( 6, "( ' SBLS: Solution = ', /, ( 5ES12.4 ) )" ) SOL
   ELSE                                          !  Error returns
     WRITE( 6, "( ' SBLS_solve exit status = ', I6 ) " ) inform%status
   END IF
   CALL SBLS_terminate( data, control, inform )  !  delete internal workspace
   END PROGRAM GALAHAD_SBLS_EXAMPLE