! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module libsisso
!***********************************************************************
! Subroutines/Functions:
! ----------
! det: calculates the determinant of a given matrix
! inverse: calculates the inverse of a given matrix
! orth_de: linear least square fitting by orthogonal decomposition
! worth_de: observation weighted orth_de
! lls: linear least fitting by conventional method (not robust)
! coord_descent: coordinate descent
! crosspro: crossproduct between two vectors
! LASSO: least absolute shrinkage and selection operator
! mtlasso_mpi Multi-task LASSO
! corr:  pearson's correlation
! string_split: break a string into sub-strings.
! kfoldCV: k-fold CV for linear model
! convex2d_xxx: construction of 2D convex hull
! intriangle: check if a 3D point is inside a triangle
! convex3d_xxx: construction of 3D convex hull
! interlp: intersection of a line and a plane
! dispp: distance from a point to a plane
!************************************************************************

use var_global

contains

function dispp(p,a,b,c)
! Distance of a point from a plane
! input: a,b,c are the three points determing the plane, p is the point outside of the plane.
! output: the distance

real*8 dispp,a(3),b(3),c(3),p(3),normal(3)
normal=crosspro((a-b),(c-b))
dispp=abs(sum(normal*(p-a)))/sqrt(sum(normal**2))

end function

function interlp(p1,p2,p3,p4,p5)
! intersection between a line and a plane
! input: p1,p2,p3 for determing the plane, p4 and p5 determing the line
! output: the interception point

real*8 interlp(3),p1(3),p2(3),p3(3),p4(3),p5(3),normal(3),a,b,c,d,&
       m,n,p,t
! for plane
normal=crosspro((p1-p2),(p3-p2))
a=normal(1)
b=normal(2)
c=normal(3)
d=-(a*p1(1)+b*p1(2)+c*p1(3))  ! aX+bY+cZ+d=0 (X,Y,Z) is the normal
! for line
m=p5(1)-p4(1)
n=p5(2)-p4(2)
p=p5(3)-p4(3)  !line equation: (x-x0)/m=(y-y0)/n=(z-z0)/p=t
! intersection
t=-(a*p4(1)+b*p4(2)+c*p4(3)+d)/(m*a+n*b+p*c) ! X=mt+x0; Y=nt+y0; Z=pt+z0
interlp(1)=m*t+p4(1)
interlp(2)=n*t+p4(2)
interlp(3)=p*t+p4(3)
end function

function intriangle(p,a,b,c)
! p,a,b,c are in the same plane
! check if point p is inside the triangle formed by points a,b,c
real*8 a(3),b(3),c(3),p(3),v1(3),v2(3),normal_0(3),normal_1(3),normal_2(3),normal_3(3)
logical intriangle
intriangle=.false.
v1=a-b
v2=c-b
normal_0=crosspro_abnormalized(v1,v2) ! triangle normal
v1=p-b
v2=c-b
normal_1=crosspro_abnormalized(v1,v2)
v1=p-c
v2=a-c
normal_2=crosspro_abnormalized(v1,v2)
v1=p-a
v2=b-a
normal_3=crosspro_abnormalized(v1,v2)
if(sum(normal_0*normal_1)>=0.d0 .and. sum(normal_0*normal_2)>=0.d0 .and. sum(normal_0*normal_3)>=0.d0) intriangle=.true.
end function

subroutine string_split(instr,outstr,sp)
! break a string into sub-strings
! input: instr, input string; sp, separator
! output: outstr, output sub-strings
character(len=*) instr,outstr(:),sp
integer n
logical isend

isend=.false.
n=0
outstr=''

i=index(instr,sp)
if(i/=0) then
  if(i/=1) then
    n=n+1
    outstr(n)=instr(1:i-1)
  end if
  do while ((.not. isend) .and. n<ubound(outstr,1))
    if ((i+len(sp))<len(instr)) then
        j=index(instr(i+len(sp):),sp)
        if(j==0) then
          isend=.true.
          n=n+1
          outstr(n)=instr(i+len(sp):)
        else if(j>1) then
          n=n+1
          outstr(n)=instr(i+len(sp):i+len(sp)-1+j-1)
        end if
        i=i+len(sp)+j-1
     else
       isend=.true.
     end if
  end do
end if

end subroutine

function corr(x,y)
! pearson's correlation
! input: vector x and y
! output: the correlation coefficient
real*8 x(:),y(:),meanx,meany,sigmax,sigmay,m,corr
m=size(x)

meanx=sum(x)/m
meany=sum(y)/m
sigmax=sqrt(sum((x-meanx)**2)/m)
sigmay=sqrt(sum((y-meany)**2)/m)

corr=sum((x-meanx)*(y-meany))/(m*sigmax*sigmay)
end function

function det(mat)
! LU docomposition for sovling determinant of a matrix
! input: matrix mat
! output: the determinant.

integer i,j,k,n
real*8 mat(:,:),um(ubound(mat,1),ubound(mat,1)),s,det,temp(ubound(mat,1))
s=0
um=mat
n=ubound(mat,1)

do i=1,n
do j=i+1,n

if (um(i,i)==0.d0) then
  do k=i+1,n
    if(um(k,i) /=0.d0) then
      temp=um(i,:)
      um(i,:)=um(k,:)
      um(k,:)=-1*temp
      exit
    end if
  end do
end if
if (um(i,i)==0.d0) then
det=0;return
end if

um(j,:)=um(j,:)-um(j,i)/um(i,i)*um(i,:)
end do
end do

do i=1,n
if(i==1) then
s=um(i,i)
else
s=s*um(i,i)
endif
end do

det=s
end function

function inverse(mat)
! calculate the inverse of a given matrix
! input: the matrix
! output: the inversed matrix

real*8  mat(:,:),um(ubound(mat,1),ubound(mat,1)),lm(ubound(mat,1),ubound(mat,1))
real*8  x(ubound(mat,1),ubound(mat,1)),y(ubound(mat,1),ubound(mat,1)),inverse(ubound(mat,1),ubound(mat,1))
integer i,j,k,n
um=mat
n=ubound(mat,1)
lm=0;x=0;y=0
if (abs(det(mat))==0) stop 'Error: value of the determinant is 0, the matrix is singular'
if (abs(det(mat))<1d-30) write(*,'(a,E15.6E3,a)') 'Warning: value of the determinant is:',&
det(mat),' matrix might be singular'

!!!!!! construct up triangle matrix
do i=1,n
do j=i+1,n
um(j,:)=um(j,:)-um(j,i)/um(i,i)*um(i,:)
end do
end do

! construct low triangle matrix
lm(1,1)=mat(1,1)/um(1,1)
do i=2,n
do j=1,i
s=sum(lm(i,1:(i-1))*um(1:(i-1),j))
lm(i,j)=(mat(i,j)-s)/um(j,j)
end do
end do

! construct y matrix
y(1,1)=1/lm(1,1)
do i=2,n
do j=1,i
s=sum(lm(i,1:(i-1))*y(1:(i-1),j))
if(j/=i) y(i,j)=-s/lm(i,i)
if(j==i) y(i,j)=(1-s)/lm(i,i)
end do
end do

! construct x matrix, which is also the inverse matrix
do i=1,n
x(n,i)=y(n,i)/um(n,n)
end do
do i=n-1,1,-1
do j=1,n,1
s=sum(um(i,i+1:n)*x(i+1:n,j))
x(i,j)=(y(i,j)-s)/um(i,i)
end do
end do

inverse=x

end function

subroutine qr_de(a,q,r)
! QR decomposition of input matrix a
! https://en.wikipedia.org/wiki/QR_decomposition
integer i,j,k,m,n
real*8 a(:,:),q(ubound(a,1),ubound(a,2)),r(ubound(a,2),ubound(a,2))
real*8 u(ubound(a,1),ubound(a,2)),e(ubound(a,1),ubound(a,2))
m=ubound(a,1)
n=ubound(a,2)
u=0
e=0

do i=1,n
if(i==1) then
u(:,1)=a(:,1)
else
u(:,i)=a(:,i)
do j=1,i-1
u(:,i)=u(:,i)-dot_product(u(:,j),a(:,i))/dot_product(u(:,j),u(:,j))*u(:,j)
end do
end if
e(:,i)=u(:,i)/sqrt(dot_product(u(:,i),u(:,i)))
end do
q=e

do j=1,n
do i=1,j
r(i,j)=sum(e(:,i)*a(:,j))
end do

do k=j+1,n
r(k,j)=0.0
end do
end do
end subroutine

subroutine orth_de(x,y,intercept,beta,rmse)
! linear least square fit to y=a+x*b by orthogonal decomposition
! input: matrix x,vector y;
! output intercept,beta,rmse
! https://en.wikipedia.org/wiki/Linear_least_squares_(mathematics)

real*8  x(:,:),y(:),beta(ubound(x,2)),xprime(ubound(x,1),ubound(x,2)),yprime(ubound(y,1)),intercept,rmse
real*8  q(ubound(x,1),ubound(x,2)),r(ubound(x,2),ubound(x,2)),qty(ubound(x,2)),xmean(ubound(x,2)),ymean
integer i,j,k,m,n

m=ubound(x,1)
n=ubound(x,2)
do i=1,n
xmean(i)=sum(x(:,i))/m
xprime(:,i)=x(:,i)-xmean(i)
end do
ymean=sum(y)/m
yprime=y-ymean

call qr_de(xprime,q,r) ! results stored in q and r
qty=matmul(transpose(q),yprime)
beta(n)=qty(n)/r(n,n)

do i=n,1,-1
beta(i)=qty(i)
do j=i+1,n
beta(i)=beta(i)-r(i,j)*beta(j)
end do
beta(i)=beta(i)/r(i,i)
end do

rmse=sqrt(sum((yprime-matmul(xprime,beta))**2)/m)
intercept=ymean-sum(xmean*beta)

end subroutine

subroutine orth_de_nointercept(x,y,beta,rmse)
! linear least square fit to y=x*b by orthogonal decomposition
! input: matrix x,vector y;
! output beta,rmse

real*8 x(:,:),y(:),beta(ubound(x,2)),rmse
real*8 q(ubound(x,1),ubound(x,2)),r(ubound(x,2),ubound(x,2)),qty(ubound(x,2))
integer i,j,k,m,n

m=ubound(x,1)
n=ubound(x,2)

call qr_de(x,q,r) ! results stored in q and r
qty=matmul(transpose(q),y)
beta(n)=qty(n)/r(n,n)

do i=n,1,-1
beta(i)=qty(i)
do j=i+1,n
beta(i)=beta(i)-r(i,j)*beta(j)
end do
beta(i)=beta(i)/r(i,i)
end do

rmse=sqrt(sum((y-matmul(x,beta))**2)/m)

end subroutine

subroutine worth_de(x,y,weight,intercept,beta,rmse,wrmse)
! weighted linear least sqaure
implicit none
real*8  x(:,:),y(:),beta(ubound(x,2)),xprime(ubound(x,1),ubound(x,2)),yprime(ubound(y,1)),intercept,wrmse,rmse,&
q(ubound(x,1),ubound(x,2)),r(ubound(x,2),ubound(x,2)),qty(ubound(x,2)),xmean(ubound(x,2)),ymean,weight(:),&
wx(ubound(x,1),ubound(x,2)),wy(ubound(y,1))
integer i,j,k,m,n

m=ubound(x,1)
n=ubound(x,2)

do i=1,n
xmean(i)=sum(x(:,i))/m
xprime(:,i)=x(:,i)-xmean(i)
wx(:,i)=xprime(:,i)*sqrt(weight)
end do
ymean=sum(y)/m
yprime=y-ymean
wy=yprime*sqrt(weight)

call qr_de(wx,q,r) ! results stored in q and r
qty=matmul(transpose(q),wy)
beta(n)=qty(n)/r(n,n)

do i=n,1,-1
beta(i)=qty(i)
do j=i+1,n
beta(i)=beta(i)-r(i,j)*beta(j)
end do
beta(i)=beta(i)/r(i,i)
end do

wrmse=sqrt(sum(weight*(yprime-matmul(xprime,beta))**2)/m)
rmse=sqrt(sum((yprime-matmul(xprime,beta))**2)/m)
intercept=ymean-sum(xmean*beta)

end subroutine

subroutine lls(x,y,intercept,beta,rmse)
! linear least square fit by the standard method
! input: matrix x, vector y
! output: beta,rmse, intercept
! https://en.wikipedia.org/wiki/Linear_least_squares_(mathematics)
implicit none
real*8  x(:,:),y(ubound(x,1)),beta0(ubound(x,2)+1),rmse,x0(ubound(x,1),ubound(x,2)+1),&
        beta(ubound(x,2)),intercept
integer m,n
m=ubound(x,1)
n=ubound(x,2)

x0(:,1)=1
x0(:,2:n+1)=x

beta0=matmul(inverse(matmul(transpose(x0),x0)),matmul(transpose(x0),y))
rmse=sqrt(sum((y-matmul(x0,beta0))**2)/m)
intercept=beta0(1)
beta=beta0(2:n)

end subroutine

function crosspro(a,b)
! calculate the cross product: a x b
! input: vector a and b
! output: a vector
real*8  a(3),b(3),crosspro(3)
crosspro(1)=a(2)*b(3)-a(3)*b(2);
crosspro(2)=a(3)*b(1)-a(1)*b(3);
crosspro(3)=a(1)*b(2)-a(2)*b(1);
end function

function crosspro_abnormalized(a,b)
! a and b are normalized before calculating their cross product
real*8  a(3),b(3),aa(3),bb(3),crosspro_abnormalized(3),norma,normb
aa=a
bb=b
norma=sqrt(sum(aa**2))
normb=sqrt(sum(bb**2))
if(norma/=0.d0 .and. normb/=0.d0) then
  aa=aa/norma
  bb=bb/normb
else
  crosspro_abnormalized=0.d0
end if

crosspro_abnormalized(1)=aa(2)*bb(3)-aa(3)*bb(2);
crosspro_abnormalized(2)=aa(3)*bb(1)-aa(1)*bb(3);
crosspro_abnormalized(3)=aa(1)*bb(2)-aa(2)*bb(1);

end function

subroutine lasso(prod_xty,prod_xtx,lambda,max_iter,tole,beta_init,run_iter,beta,nf)
! min: f(beta)=1/2*||y-x*beta||**2 + lambda*||beta||_l1
! prod_xty=XtY; prod_xtx=XtX; max_iter:allowed max cycle;
! tole: convergence criteria for cd to stop
! beta_init: initial coefficient
! run_iter, actual run cycles; nf: number of selected features;
! input prod_xty,prod_xtx,lambda,max_iter,tole,beta_init;
! output run_iter,beta, nf
! (LASSO) J. Friedman, T. Hastie, R. Tibshirani, J. Stat. Softw. 33, 1(2010).
! (LASSO) J. Friedman, T. Hastie, H. Hofling, R. Tibshirani, Ann. Appl. Stat. 1, 302 (2007).
implicit none
real*8 prod_xty(:),prod_xtx(:,:),lambda,beta(:),beta_init(:),&
beta_old(ubound(beta,1)),z,tole,rand(ubound(beta,1)),beta_tmp,dbeta,xxbeta(ubound(beta,1))
integer ntotf,i,i1,i2(1),j,k,max_iter,run_iter,nf,ac1(ubound(beta,1)),ac2(ubound(beta,1))
logical active_change

ntotf=ubound(prod_xtx,1)

beta_old=beta_init
beta=beta_init
xxbeta=matmul(prod_xtx,beta)

!-----------------------------------
! entering the main updation cycles
!-----------------------------------

do i=1,max_iter

   if(i==1) then
      active_change=.true.
      ac1=0; ac2=0
   end if

  do j=1,ntotf
   if((.not. active_change) .and. abs(beta(j))<1d-10) then
     cycle
   else
       beta_tmp=beta(j)
       z=prod_xty(j)-xxbeta(j)+beta(j)
      if(z>0 .and. lambda<abs(z)) then
       beta(j)=z-lambda
      else if(z<0 .and. lambda<abs(z)) then
       beta(j)=z+lambda
      else if(lambda>=abs(z)) then
       beta(j)=0
      end if
      xxbeta=xxbeta-prod_xtx(:,j)*beta_tmp
      xxbeta=xxbeta+prod_xtx(:,j)*beta(j)
   end if
  end do
  active_change=.false.

  if(i==max_iter) print*, 'Warning: lasso run hits the max_iter.'
  if(maxval(abs(beta-beta_old))<tole .or. i==max_iter) then
    ! check if the active set converge
     do k=1,ntotf
        if(abs(beta(k))>1d-10) then
          ac2(k)=1
        else
          ac2(k)=0
        end if
     end do

     do k=1,ntotf
       if(ac1(k)/=ac2(k)) then
         ac1=ac2
         active_change=.true.
         exit
       end if
     end do
     if((.not. active_change)) exit
  else
    beta_old=beta
  end if

end do

nf=sum(ac2)
run_iter=i

end subroutine

subroutine mtlasso_mpi(prod_xty,prod_xtx,lambda,max_iter,tole,beta_init,run_iter,beta,nf,ncol)
! prod_xty=XtY; prod_xtx=XtX; max_iter:allowed max cycle;
! tole: convergence criteria for cd to stop
! beta_init: initial coefficient
! run_iter, actual run cycles; nf: number of selected features;
! ncol: mpi jobs assignment
! output run_iter,beta, nf
! (LASSO) J. Friedman, T. Hastie, R. Tibshirani, J. Stat. Softw. 33, 1(2010).
! (LASSO) J. Friedman, T. Hastie, H. Hofling, R. Tibshirani, Ann. Appl. Stat. 1, 302 (2007).
! (MTLASSO) G. Obozinski, B. Taskar, M. Jordan, 2006 "Multi-task feature selection"
! multi-task lasso return back to lasso when the number of task is one
! algorithm for sovling multi-task lasso can be found from that of group lasso
! (GLASSO) M. Yuan and Y. Lin, J. R. Statist. Soc. B 68,49(2006)
! (GLASSO) J. Friedman, T. Hastie, and R. Tibshirani, 2010 "A note on the group lasso and a sparse group lasso"
! (Elastic net) H. Zou, and T. Hastie, J. R. Statist. Soc. B 67, 301 (2005).

real*8 prod_xty(:,:),prod_xtx(:,:,:),lambda,beta(:,:),beta_init(:,:),beta_old(ubound(beta,1),ubound(beta,2)),tole,&
beta_tmp(ubound(beta,2)),beta_tmp2(ubound(beta,2)),dbeta,xxbeta(ubound(beta,1),ubound(beta,2)),&
Sj(ubound(beta,2)),norm
integer ntotf,i,j,k,max_iter,run_iter,nf,ac1(ubound(beta,1)),ac2(ubound(beta,1)),ntask,mpii,mpij,mpik,mpin,ncol(:)
logical active_change
!----

ntask=ubound(prod_xty,2)
ntotf=ubound(prod_xty,1)
beta_old=beta_init
beta=beta_init

! calculate xtx*beta
do mpij=1,ncol(mpirank+1)
do mpik=1,ntask
  xxbeta(mpij,mpik)=sum(prod_xtx(:,mpij,mpik)*beta(:,mpik))
end do
end do

! rank0 collect data and broadcast
mpin=ncol(mpirank+1)
if (mpirank /=0) then
call mpi_send(xxbeta(1:mpin,:),mpin*ntask,mpi_double_precision,0,1,mpi_comm_world,mpierr)
else
do mpii=1,mpisize-1
mpij=sum(ncol(1:mpii))
mpik=ncol(mpii+1)
call mpi_recv(xxbeta(mpij+1:mpij+mpik,:),mpik*ntask,mpi_double_precision,mpii,1,mpi_comm_world,status,mpierr)
end do
end if

call mpi_barrier(mpi_comm_world,mpierr)
call mpi_bcast(xxbeta,ntotf*ntask,mpi_double_precision,0,mpi_comm_world,mpierr)

!-----------------------------------
! entering the main updation cycles
!-----------------------------------
do i=1,max_iter

   if(i==1) then
      active_change=.true.
      ac1=0; ac2=0
   end if

  if(mpirank/=0) then  ! do the job processor after processor,rank0 first
   call mpi_recv(xxbeta,ntotf*ntask,mpi_double_precision,mpirank-1,1,mpi_comm_world,status,mpierr)
  end if

  do j=1+sum(ncol(1:mpirank)),sum(ncol(1:mpirank+1))

    if((.not. active_change) .and. maxval(abs(beta(j,:)))<1d-10) then
     cycle
    else
       ! Multi-task lasso and group lasso share the similar solution
       ! see paper "A note on the group lasso and a sparse group lasso" by J. Friedman, et al., 2010
       ! and also note that features are the same for all responses
       ! if ntask==1, back to lasso automatically.
       Sj=prod_xty(j,:)-xxbeta(j,:)+prod_xtx(j,j-sum(ncol(1:mpirank)),:)*beta(j,:)
       norm=sqrt(sum(Sj**2))
       beta_tmp=beta(j,:)
       if(norm<=lambda) then
         beta(j,:)=0.0
       else
         ! only when features are orthogonal
         !beta(j,:)=Sj*(1-lambda/norm)

         ! do it iteratively when features are not orthogonal
           beta_tmp2=beta(j,:)+1
           norm=sqrt(sum((beta(j,:))**2))
           if(norm<1d-10) norm=1.0
           do while(maxval(abs(beta(j,:)-beta_tmp2))>1d-10)
             beta_tmp2=beta(j,:)
             beta(j,:)=Sj/(prod_xtx(j,j-sum(ncol(1:mpirank)),:)+lambda/norm)
             norm=sqrt(sum((beta(j,:))**2))
           end do
         !--
       end if
       do k=1,ntask
       xxbeta(:,k)=xxbeta(:,k)-prod_xtx(:,j-sum(ncol(1:mpirank)),k)*beta_tmp(k)
       xxbeta(:,k)=xxbeta(:,k)+prod_xtx(:,j-sum(ncol(1:mpirank)),k)*beta(j,k)
       end do
   end if

 end do

 if(mpirank/=mpisize-1) then
 call mpi_send(xxbeta,ntotf*ntask,mpi_double_precision,mpirank+1,1,mpi_comm_world,mpierr)
 end if
 call mpi_barrier(mpi_comm_world,mpierr)
 call mpi_bcast(xxbeta,ntotf*ntask,mpi_double_precision,mpisize-1,mpi_comm_world,mpierr)

  mpin=ncol(mpirank+1)
  if (mpirank /=0) then
  call mpi_send(beta(1+sum(ncol(1:mpirank)):sum(ncol(1:mpirank+1)),:),ncol(mpirank+1)*ntask,&
                     mpi_double_precision,0,1,mpi_comm_world,mpierr)
  else
  do mpii=1,mpisize-1
  mpij=sum(ncol(1:mpii))
  mpik=ncol(mpii+1)
  call mpi_recv(beta(mpij+1:mpij+mpik,:),mpik*ntask,mpi_double_precision,mpii,1,mpi_comm_world,status,mpierr)
  end do
  end if
  call mpi_bcast(beta,ntotf*ntask,mpi_double_precision,0,mpi_comm_world,mpierr)
  call mpi_barrier(mpi_comm_world,mpierr)

  active_change=.false.

  if(i==max_iter) print*, 'Warning: lasso run hits the max_iter.'
  if(maxval(abs(beta-beta_old))<tole .or. i==max_iter) then
    ! check if the active set converge
     do k=1,ntotf
        if(maxval(abs(beta(k,:)))>1d-10) then
          ac2(k)=1
        else
          ac2(k)=0
        end if
     end do

     do k=1,ntotf
       if(ac1(k)/=ac2(k)) then
         ac1=ac2
         active_change=.true.
         exit
       end if
     end do
     if((.not. active_change)) exit
  else
    beta_old=beta
  end if

end do

nf=sum(ac2)
run_iter=i

end subroutine

subroutine coord_descent(x,y,max_iter,tole,beta,rmse)
! using coordinate descent method to solve the linear equation y=xb
! input: x(m,n),y(m),max_iter,tole; output beta(n),rmse
! x and y are already standardized, and y=xb
! output: rmse,beta
implicit none
real*8 x(:,:),y(ubound(x,1)),beta(ubound(x,2)),beta_old(ubound(x,2)),&
prod_xty(ubound(x,2)),prod_xtx(ubound(x,2),ubound(x,2)),rmse,tole,norm_beta
integer m,n,i,j,k,max_iter

m=ubound(x,1)
n=ubound(x,2)

beta_old=0.0
beta=0.0

! definition to make fast
prod_xty=matmul(transpose(x),y)
prod_xtx=matmul(transpose(x),x)

! entering the main updation cycles
do i=1,max_iter
 do j=1,n
       beta(j)=prod_xty(j)-sum(prod_xtx(j,:)*beta)+beta(j)
 end do
   norm_beta=sqrt(sum(beta**2))
  if(norm_beta==0 .or. (sqrt(sum((beta-beta_old)**2))/norm_beta)<tole .or. i==max_iter) then
    exit
  else
    beta_old=beta
  end if
end do

rmse=sqrt(sum((y-matmul(x,beta))**2)/m)

end subroutine

subroutine kfoldCV(x,y,random,fold,noise,CVrmse,CVmax)
! k-fold cross validation
! input: x, y, random, fold, noise
! output: CVrmse, CVmax,

integer ns,fold,random(:),mm1,mm2,mm3,mm4,i,j,k,kk,l
real*8 x(:,:),y(:),beta(ubound(x,2)),intercept,rmse,CVse(fold),CVrmse,CVmax,pred(ubound(y,1)),noise(:)

if(fold<2) stop 'Error: the fold of CV must be >=2 !'
ns=ubound(y,1)

CVmax=0
CVrmse=0
k=int(ns/fold)
kk=mod(ns,fold)
do l=1,fold
   mm1=1  ! sample start
   mm2=ns      ! sample end
   mm3=(l-1)*k+min((l-1),kk)+1 ! test start
   mm4=mm3+k-1+int(min(l,kk)/l)  ! test end
   if(mm1==mm3) then
      call orth_de(x([random(mm4+1:mm2)],:),y([random(mm4+1:mm2)])+noise([random(mm4+1:mm2)]),intercept,beta(:),rmse)
   else if(mm4==mm2) then
      call orth_de(x([random(mm1:mm3-1)],:),y([random(mm1:mm3-1)])+noise([random(mm1:mm3-1)]),intercept,beta(:),rmse)
   else
      call orth_de(x([random(mm1:mm3-1),random(mm4+1:mm2)],:),&
                   y([random(mm1:mm3-1),random(mm4+1:mm2)])+noise([random(mm1:mm3-1),random(mm4+1:mm2)]),&
                   intercept,beta(:),rmse)
   end if
   pred(mm3:mm4)=(intercept+matmul(x([random(mm3:mm4)],:),beta(:)))
end do
CVmax=maxval(abs(y([random])-pred))
CVrmse=sqrt(sum((y([random])-pred)**2)/ns)  ! quadratic mean over samples
end subroutine

subroutine convex2d_hull(set,numb,hull)
! calculate the convex hull for a given data set
! input: set, a matrix N x 2
! output: numb (number of vertices); hull, the vertices stored in clockwise direction
real*8 set(:,:),hull(:,:),tmp,vjj(2),vij(2),vkj(2),normij,normkj
integer numb,i,j,k,ntot,loc(1),nrecord
logical used(ubound(set,1)),isvertex

ntot=ubound(set,1)
used=.false.
numb=0

! find the initial point with min(x) and min(y)
! j can't be set 'used' as it is waiting to be found to close the hull
loc=minloc(set(:,1))
j=loc(1)
do i=1,ntot
  if(i==j) cycle
  if(abs(set(loc(1),1)-set(i,1))<=1d-10 .and. set(loc(1),2)>set(i,2)) loc(1)=i
end do
j=loc(1)
numb=1
hull(1,:)=set(j,:)

! find points at the same position with j
do i=1,ntot
   if(i==j) cycle
   if(abs(set(j,1)-set(i,1))<=1d-10 .and. abs(set(j,2)-set(i,2))<=1d-10) then
   numb=numb+1
   hull(numb,:)=set(i,:)
   used(i)=.true.
  end if
end do
if(numb==ntot) return

! start searching vertices
! from known vector vjj, find the next vertex k by searching all i

vjj=(/0.d0,-1.d0/)  ! initial vector pointing downward
nrecord=0

do while(any(used .eqv. .false.) )
  nrecord=nrecord+1
  if(nrecord>ntot) exit ! in case of endless loop
  isvertex=.false.
  vkj=vjj
  normkj=-1.d0  ! normkj<0 if vkj==vjj; normkj>0 if vkj\=vjj

  ! find the next vertex k to update j, vjj, numb, hull, used
  do i=1,ntot

    if(used(i) .or. i==j) cycle   ! loc(1) will be the last point to find

    if(abs(set(j,1)-set(i,1))<=1d-10 .and. abs(set(j,2)-set(i,2))<=1d-10  ) then  ! all the points at the same position
       numb=numb+1
       hull(numb,:)=set(i,:)
       used(i)=.true.
       cycle
    end if

    vij=set(i,:)-set(j,:)
    normij=sqrt(sum(vij**2))
    vij=vij/normij
    if(i==loc(1)) normij=1d10  ! ensure loc(1) is the last vertex

    tmp=vkj(1)*vij(2)-vij(1)*vkj(2)  ! cross product between vector vij and vkj

    if (tmp>1d-10   .or. &  ! on the left side of vkj(vkj==vjj) or vij
       (normkj>0.d0 .and. tmp>0.d0 .and. tmp<=1d-10 .and. sum(vij*vkj)>0.d0 ) .or. &  ! vkj/=vjj
       (normkj<0.d0 .and. tmp>=0.d0 .and. tmp<=1d-10 .and. sum(vij*vjj)<0.d0 ) .or. &  ! vkj==vjj
       (normkj>0.d0 .and. tmp==0.d0  .and. sum(vij*vkj)>0.d0 .and. normij<normkj ) ) then
          k=i
          vkj=vij
          normkj=normij  ! positive
          isvertex=.true.
    end if
  end do

  if(isvertex) then  ! assign the new vertex k to j
    if(k==loc(1)) exit  ! loc(1) is already in the hull(1,:)
     numb=numb+1
     hull(numb,:)=set(k,:)
     used(k)=.true.
     vjj=-vkj   ! reverse the direction of vkj and assign to vjj
     j=k   ! new j
  end if

end do

end subroutine

subroutine convex3d_hull(set,ntri,triangles)
! find the convex hull by finding all the triangle facets
! input: set, a matrix N x 3
! output:  triangles, the ids of vertices forming traingles; ntri, number of triangles
! NOTE: triangles is an allocatable array
real*8  set(:,:),tmp,vij(2),vkj(2),normal_a(3),normal_b(3),vtmp(3,3),vedge(3),aa,bb,cc
integer ntri,i,j,k,l,m,ntot,loc(2),nedge,iedge,leftright,comp(3),size_tri,size_edge,ntri_coplane,ntri_saved,nvert
integer,allocatable:: triangles(:,:),edges(:,:),change(:,:),recorder(:),coplane(:,:),ver_index(:)
logical overlap(ubound(set,1)),used,planar,goodedge

ntot=ubound(set,1)
overlap=.false.  ! points at the same position
ntri=0
nedge=0

size_tri=10000
size_edge=10000
allocate(triangles(size_tri,3))  ! size to be adjusted
allocate(edges(size_edge,2))

! find the initial edge (the most left one projected on the x-y plane)

!-------------------------------------
! first point: min(x),min(y),min(z)
loc(1:1)=minloc(set(:,1))
k=loc(1)
do i=1,ntot
  if(i==k) cycle
  if(abs(set(loc(1),1)-set(i,1))<=1d-10 .and. set(loc(1),2)>set(i,2)) loc(1)=i
end do
k=loc(1)
do i=1,ntot
 if(i==k) cycle
 if(abs(set(loc(1),1)-set(i,1))<=1d-10 .and. abs(set(loc(1),2)-set(i,2))<=1d-10 .and. set(loc(1),3)>set(i,3)) loc(1)=i
end do

! second point for the initial edge
vkj=(/0.d0,-1.d0/)
vtmp(3,:)=(/0.d0,0.d0,-1.d0/)
loc(2)=0
do i=1,ntot   ! find a i so that vector i<-j is to the left side of k<-j
  if(i==loc(1)) cycle
  vij=set(i,:2)-set(loc(1),:2)
  tmp=vkj(1)*vij(2)-vij(1)*vkj(2)  ! cross product vkj x vij

  if (tmp>1d-10 ) then  ! on the left side of vkj or vij
     loc(2)=i
     vkj=vij
     vtmp(3,:)=set(i,:3)-set(loc(1),:3) ! 3D form of vkj
  else if(abs(tmp)<=1d-10) then  ! considering 3D
    vtmp(1,:)=(/0.d0,0.d0,1.d0/)
    vtmp(2,:)=set(i,:3)-set(loc(1),:3)
    aa=sum(crosspro_abnormalized(vtmp(2,:),vtmp(1,:))*crosspro_abnormalized(vtmp(2,:),vtmp(3,:)))
    bb=sum(crosspro_abnormalized(vtmp(2,:),vtmp(1,:))**2)  ! between vi and z
    cc=sum(crosspro_abnormalized(vtmp(2,:),vtmp(3,:))**2)  ! between vi and vk
    if(aa<0 .or. (bb==0.d0 .and. cc/=0.d0) .or. (cc==0.d0 .and. sum(vtmp(2,:)**2)>sum(vtmp(3,:)**2)) ) then
        loc(2)=i
        vkj=vij
        vtmp(3,:)=set(i,:3)-set(loc(1),:3) ! 3D form of vkj
    end if
  end if
end do
if(loc(2)==0) return  ! all points are at the same one point
!-------------------------------------------------------

nedge=1
ntri=0
if(loc(1)<loc(2)) then ! let edges(i,1) always < edges(i,2)
  edges(1,:)=(/loc(1),loc(2)/)
else
  edges(1,:)=(/loc(2),loc(1)/)
end if

! find all points at the same position with the initial edge points
do i=1,ntot
   if(i==edges(1,1) .or. i==edges(1,2)) cycle
   if( sqrt(sum((set(edges(1,1),:)-set(i,:))**2))<1d-10 .or. sqrt(sum((set(edges(1,2),:)-set(i,:))**2))<1d-10) &
      overlap(i)=.true.
end do

! With the initial edge and plane, find all the triangles
leftright=1
iedge=1
do while(iedge<=nedge)

  ! set a initial plane
   vedge=set(edges(iedge,2),:)-set(edges(iedge,1),:)
   goodedge=.true.

   do i=1,ntot
     if(i==edges(iedge,1) .or. i==edges(iedge,2) .or. overlap(i) ) cycle
     vtmp(1,:)=set(i,:)-set(edges(iedge,1),:)
     vtmp(2,:)=crosspro_abnormalized(vedge,vtmp(1,:)) ! normal
     if(sqrt(sum(vtmp(2,:)**2))>1d-10) then
       normal_a=vtmp(2,:)      ! the normal vector of the initial plane
       k=i
       exit
     end if
     if(i==ntot) return  ! all points are on a line
   end do

 ! check if all the points are in one plane
   if(iedge==1) then
     planar=.true.
     do i=1,ntot
         if( sum((set(i,:)-set(edges(iedge,1),:))*normal_a) /=0.d0) then
           planar=.false.
           exit
         end if
     end do
     if(planar) return
   end if

 !-------------------------------------
 ! For each edge, find the leftmost and rightmost facet!
  do i=1,ntot
    if(overlap(i) .or. k==i .or. edges(iedge,1)==i .or. edges(iedge,2)==i) cycle
    vtmp(1,:)=set(i,:)-set(edges(iedge,1),:)
    vtmp(2,:)=crosspro_abnormalized(vedge,vtmp(1,:)) ! normal of the considered plane
    normal_b=vtmp(2,:)
    if(sqrt(sum(normal_b**2))<1d-10) cycle  ! point i is on the edge-line
    vtmp(3,:)=crosspro_abnormalized(normal_a,normal_b) ! cross product between the normal of two plane
    tmp=sum(vtmp(3,:)*vedge) ! to the left or right

    if(abs(tmp)>1d-10) then  !/=0
       if((leftright>0 .and. tmp>0.d0) .or. (leftright<0 .and. tmp<0.d0)) then
          k=i
          normal_a=normal_b
       end if
    else if(.not. intriangle(set(i,:),set(edges(iedge,1),:),set(edges(iedge,2),:),set(k,:)) ) then
       if(leftright>0) then
         vtmp(1,:)=set(i,:)-set(edges(iedge,1),:)
         vtmp(2,:)=set(k,:)-set(edges(iedge,1),:)
         aa=sum(crosspro_abnormalized(vedge,vtmp(2,:))*crosspro_abnormalized(vtmp(2,:),vtmp(1,:))) !edge x vk,vk x vi
         bb=sum(crosspro_abnormalized(vedge,vtmp(2,:))*crosspro_abnormalized(vedge,vtmp(1,:)))
       else ! reverse the edge direction
         vtmp(1,:)=set(i,:)-set(edges(iedge,2),:)
         vtmp(2,:)=set(k,:)-set(edges(iedge,2),:)
         aa=sum(crosspro_abnormalized(-vedge,vtmp(2,:))*crosspro_abnormalized(vtmp(2,:),vtmp(1,:)))!edge x vk,vk x vi
         bb=sum(crosspro_abnormalized(-vedge,vtmp(2,:))*crosspro_abnormalized(-vedge,vtmp(1,:)))
       end if

       if( bb <-1d-10) then   ! the edge is not really edge
          goodedge=.false.
          exit
       end if

       if( aa >=0.d0) then ! the edge repel the 'i' to the other edge
          k=i
          normal_a=normal_b
       end if

    end if
  end do

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

  if(goodedge) then
      ! add new triangle
       comp(1)=min(edges(iedge,1),edges(iedge,2),k)
       comp(3)=max(edges(iedge,1),edges(iedge,2),k)
       if(k/=comp(1) .and. k/=(comp(3))) then
           comp(2)=k
       elseif(edges(iedge,1)/=comp(1) .and. edges(iedge,1)/=comp(3)) then
           comp(2)=edges(iedge,1)
       else
           comp(2)=edges(iedge,2)
       end if

       used=.false.
       do i=1,ntri
         if(all(triangles(i,:) == comp(:))) then
            used=.true.
            exit
         end if
       end do

       if(.not. used ) then
          ntri=ntri+1
          triangles(ntri,:3)=comp(:3)
       end if
       if(ntri==size_tri) then
         allocate(change(size_tri,3))
         change=triangles
         deallocate(triangles)
         size_tri=size_tri*2
         allocate(triangles(size_tri,3))
         triangles(:ntri,:)=change
         deallocate(change)
       end if

       ! find overlap points
       do i=1,ntot
          if(i==k .or. overlap(i) ) cycle
          if( (abs(set(k,1)-set(i,1))<=1d-10 .and. abs(set(k,2)-set(i,2))<=1d-10 .and. &
              abs(set(k,3)-set(i,3))<=1d-10 )) overlap(i)=.true.
       end do

       do j=1,2
           comp(1)=min(edges(iedge,j),k)
           comp(2)=max(edges(iedge,j),k)
           used=.false.
           do i=1,nedge
              if(all(edges(i,:)==comp(:2))) then
                  used=.true.
                  exit
              end if
           end do
           if(.not. used) then
              nedge=nedge+1
              edges(nedge,:)=comp(:2)
           end if

          if(nedge==size_edge) then
            allocate(change(size_edge,2))
            change=edges
            deallocate(edges)
            size_edge=size_edge*2
            allocate(edges(size_edge,2))
            edges(:nedge,:)=change
            deallocate(change)
          end if

       end do
   end if

   leftright=-leftright   ! each edge is to be used twice.
   if(leftright>0) iedge=iedge+1

end do

! rearrangement of the triangles in the same plane
allocate(change(5*ntri,3))
allocate(coplane(5*ntri,3))
allocate(recorder(ntri))
allocate(ver_index(ntri*3))
recorder=1  ! 1: unaccessed; 0: accessed
ntri_saved=0  ! number of rearranged triangles
ntri_coplane=0  ! number of triangles in one plane

do i=1,ntri
  if(recorder(i)==0) cycle
  recorder(i)=0
  ntri_coplane=1
  coplane(ntri_coplane,:)=triangles(i,:)
  vtmp(1,:)=set(triangles(i,2),:)-set(triangles(i,1),:)
  vtmp(2,:)=set(triangles(i,3),:)-set(triangles(i,1),:)
  normal_a=crosspro_abnormalized(vtmp(1,:),vtmp(2,:)) ! the reference normal
  do j=i+1,ntri  ! find the coplane triangles if there are
     if(recorder(j)==0) cycle
     vtmp(1,:)=set(triangles(j,2),:)-set(triangles(j,1),:)
     vtmp(2,:)=set(triangles(j,3),:)-set(triangles(j,1),:)
     normal_b=crosspro_abnormalized(vtmp(1,:),vtmp(2,:)) !the normal of candidate triangle
     if(sqrt(sum(crosspro_abnormalized(normal_a,normal_b)**2))<=1d-10 .and. &
        dispp(set(triangles(j,1),:),set(triangles(i,1),:),set(triangles(i,2),:),set(triangles(i,3),:))<1d-6) then
        ntri_coplane=ntri_coplane+1
        coplane(ntri_coplane,:)=triangles(j,:)
        recorder(j)=0
     end if
  end do

  ver_index=0
  ver_index(1:3)=coplane(1,:)
  nvert=3
  do j=2,ntri_coplane  ! find the vertice of all the coplane triangles
    if(all(coplane(j,1)/=ver_index(:nvert))) then
       nvert=nvert+1; ver_index(nvert)=coplane(j,1)
    end if
    if(all(coplane(j,2)/=ver_index(:nvert))) then
       nvert=nvert+1; ver_index(nvert)=coplane(j,2)
    end if
    if(all(coplane(j,3)/=ver_index(:nvert))) then
       nvert=nvert+1; ver_index(nvert)=coplane(j,3)
    end if
  end do

  if(nvert>3) then
  ! direction
    vtmp(1,:)=set(ver_index(2),:)-set(ver_index(1),:)
    vtmp(2,:)=set(ver_index(3),:)-set(ver_index(1),:)
    normal_a=crosspro_abnormalized(vtmp(1,:),vtmp(2,:))

  ! find the starting point
    k=1
    do j=3,nvert
       vtmp(1,:)=set(ver_index(2),:)-set(ver_index(k),:)
       vtmp(2,:)=set(ver_index(j),:)-set(ver_index(k),:)
       vtmp(3,:)=crosspro_abnormalized(vtmp(1,:),vtmp(2,:))
       if(sum(vtmp(3,:)**2)==0.d0 .and. sum(vtmp(1,:)*vtmp(2,:))<0.d0) k=j
    end do
    ! switch points 1 and k
    j=ver_index(1)
    ver_index(1)=k
    ver_index(k)=j

   ! find the second point
    k=2
    do j=3,nvert  !find the first most left edge: 1-k
       vtmp(1,:)=set(ver_index(k),:)-set(ver_index(1),:)
       vtmp(2,:)=set(ver_index(j),:)-set(ver_index(1),:)
       normal_b=crosspro_abnormalized(vtmp(1,:),vtmp(2,:))
       aa=sum(normal_b*normal_a)
       if( aa>0.d0 .or. (aa==0.d0 .and.  sum(vtmp(2,:)**2)>sum(vtmp(1,:)**2) ) ) k=j
    end do

    ! find all the triangles
    m=2  ! point 1 and k
    vtmp(1,:)=set(ver_index(1),:)-set(ver_index(k),:)
    do while(m<nvert)
       l=0
       do j=2,nvert  ! find triangle 1-l-k
         if(j==k .or. ver_index(j)==0) cycle ! skip the evaluated points
         vtmp(2,:)=set(ver_index(j),:)-set(ver_index(k),:)
         normal_b=crosspro_abnormalized(vtmp(1,:),vtmp(2,:))
         aa=sum(normal_b*normal_a)
         if( aa> 0.d0) then
           l=j
           vtmp(1,:)=set(ver_index(l),:)-set(ver_index(k),:)
         elseif(aa==0.d0) then   ! linear
           if(sum(vtmp(2,:)**2)>sum(vtmp(1,:)**2)) then
             l=j
             vtmp(1,:)=set(ver_index(l),:)-set(ver_index(k),:)
           else
             ver_index(j)=0    ! remove points inside a line segment
           end if
         end if
       end do

       if(l/=0) then
         vtmp(2,:)=crosspro_abnormalized(vtmp(1,:),set(ver_index(l),:)-set(ver_index(1),:))
         if(sqrt(sum(vtmp(2,:)**2))>1d-10) then  ! the three points are not on the same line
            ntri_saved=ntri_saved+1 ! every loop there must be a new point found
            change(ntri_saved,:)=(/ver_index(1),ver_index(k),ver_index(l)/)
         end if
          ver_index(k)=0
          vtmp(1,:)=-vtmp(1,:)  ! reverse the direction for the next loop
          k=l
       end if

       m=m+1  ! every loop find one vertex,totally nvert-2 points
    end do

  else
     ntri_saved=ntri_saved+1
     change(ntri_saved,:)=ver_index(1:3)
  end if

end do

ntri=ntri_saved
triangles(:ntri_saved,:)=change(:ntri_saved,:)

deallocate(change)
deallocate(recorder)
deallocate(coplane)
deallocate(ver_index)
deallocate(edges)

end subroutine

subroutine convex2d_overlap(set1,set2,width,numb,area)
! counting the number of data and area in the overlapped region between two convex hulls
! input: data set 1, data set 2,width(boundary tolerance)
! output: number of data in the overlapped region, area of the overlapped region
! segment intersection: (http://dec3.jlu.edu.cn/webcourse/t000096/graphics/chapter5/01_1.html)
! if two convex domain has more than two intersection points, the two domains are considered totally overlap !

integer i,j,i2,j2,k,numb,nh1,nh2,ns1,ns2,n_intersect
real*8 set1(:,:),set2(:,:),area,hull1(ubound(set1,1),2),hull2(ubound(set2,1),2),width,norm1,norm2,vunit1(2),vunit2(2),&
set3(10*(ubound(set1,1)+ubound(set2,1)),2),tmp,segp(4,2),delta,lambda,mu,xa,xb,ya,yb,xc,xd,yc,yd
logical inside,polygon1,polygon2

call convex2d_hull(set1,nh1,hull1)  ! convex hull of data set 1
call convex2d_hull(set2,nh2,hull2)  ! convex hull of data set 2
ns1=ubound(set1,1)
ns2=ubound(set2,1)
numb=0
area=0.d0
polygon1=.true.
polygon2=.true.

if(convex2d_area(hull1(:nh1,:))<1d-10) polygon1=.false.
if(convex2d_area(hull2(:nh2,:))<1d-10) polygon2=.false.

! both the sets are not polygons
if((ns1>2 .and. (.not. polygon1)) .or. (ns2>2 .and. (.not. polygon2)) ) then   ! two lines
  numb=ns1+ns2      ! set to max since this is not wanted.
  area=0.d0
else
  ! set1 is polygon, count the number of set2 data in hull1
  if(polygon1) then
  do i=1,ns2
    ! check if data from set2 is inside hull1
    inside=.true.
    do j=1,nh1
       k=j+1
       if(j==nh1) k=1

       norm1=sqrt(sum((hull1(k,:)-hull1(j,:))**2))
       if(norm1<1d-10) cycle
       vunit1=(hull1(k,:)-hull1(j,:))/norm1
       norm2=sqrt(sum((set2(i,:)-hull1(j,:))**2))
       if(norm2<1d-10) cycle
       vunit2=(set2(i,:)-hull1(j,:))/norm2
       tmp=vunit1(1)*vunit2(2)-vunit2(1)*vunit1(2)  ! cross product

       if(tmp>0.d0) then
          if(width>0.d0) then
            if(convex2d_dist(set2(i:i,:2),hull1(:nh1,:2))>width) then  ! boundary tolerance
             inside=.false.
             exit
            end if
          else
             inside=.false.
             exit
          end if
      end if
    end do
    if(inside) then
       numb=numb+1
       set3(numb,:)=set2(i,:)
    end if
  end do
  end if

  ! set1 data in hull2
  if(polygon2) then
  do i=1,ns1
    ! check if set1 data is inside hull2
    inside=.true.
    do j=1,nh2
       k=j+1
       if(j==nh2) k=1

       norm1=sqrt(sum((hull2(k,:)-hull2(j,:))**2))
       if(norm1<1d-10) cycle
       vunit1=(hull2(k,:)-hull2(j,:))/norm1
       norm2=sqrt(sum((set1(i,:)-hull2(j,:))**2))
       if(norm2<1d-10) cycle
       vunit2=(set1(i,:)-hull2(j,:))/norm2
       tmp=vunit1(1)*vunit2(2)-vunit2(1)*vunit1(2)  ! cross product

       if(tmp>0.d0) then  ! point on the left side of the edge
          if(width>0.d0) then
             if(convex2d_dist(set1(i:i,:2),hull2(:nh2,:2))>width) then  ! boundary tolerance
                inside=.false.
                exit
             end if
          else
                inside=.false.
                exit
          end if
       end if
    end do
    if(inside) then
       numb=numb+1
       set3(numb,:)=set1(i,:)
    end if
  end do
  end if

  ! if has common region, solve edge intersection
  k=numb
  n_intersect=0
   do i=1,nh1
        i2=i+1
        if(i==nh1) i2=1
        do j=1,nh2
          j2=j+1
          if(j==nh2) j2=1
          xa=hull1(i,1); xb=hull1(i2,1); ya=hull1(i,2); yb=hull1(i2,2)
          xc=hull2(j,1); xd=hull2(j2,1); yc=hull2(j,2); yd=hull2(j2,2)
          delta=-(xb-xa)*(yd-yc)+(yb-ya)*(xd-xc)
          if(delta/=0.d0) then   ! intersect
             lambda=(-(xc-xa)*(yd-yc)+(yc-ya)*(xd-xc))/delta
             mu=((xb-xa)*(yc-ya)-(yb-ya)*(xc-xa))/delta
             if(lambda>=0.d0 .and. lambda<=1.d0 .and. mu>=0.d0 .and. mu<=1.d0) then
                k=k+1
                set3(k,:)=(/xa+lambda*(xb-xa),ya+lambda*(yb-ya)/)
             end if
             if(lambda>0 .and. lambda<1.d0 .and. mu>0 .and. mu<1.d0) n_intersect=n_intersect+1
          end if
        end do
   end do
   if(k>=3) then
      area=convex2d_area(set3(:k,:))   ! there must be intersection if there is overlap
   else if (k==0) then
      area= -convex2d_dist(hull1(:nh1,:),hull2(:nh2,:)) ! set a negative value
   end if
   if(n_intersect>2) numb=ns1+ns2  ! presumed totally overlap if there are more than 2 intersect points

end if
end subroutine

function convex2d_area(set)
! calculate the area of a 2d convex hull
! input: set, a matrix
! output: area
real*8 va(2),vb(2),area,convex2d_area,set(:,:),hull(ubound(set,1),ubound(set,2))
integer i,j,k,nh

call convex2d_hull(set,nh,hull)

area=0.d0
do i=3,nh   ! number of vertices must be >=3
  j=i-1
  va=(/hull(j,1)-hull(1,1),hull(j,2)-hull(1,2)/)
  vb=(/hull(i,1)-hull(1,1),hull(i,2)-hull(1,2)/)
  area=area+0.5d0*abs(va(1)*vb(2)-va(2)*vb(1))
end do
convex2d_area=area
if(area<1d-10) area=0.d0

end function

function convex2d_in(set1,set2,width)
! check how many points of set2 are inside the hull of set1
! input: the data set forming the hull; the point; and boundary tolerence
! output: .false. or .true.

integer i,j,k,nh,np,convex2d_in
real*8 set1(:,:),set2(:,:),hull(ubound(set1,1),ubound(set1,2)),tmp,width,norm1,norm2,vunit1(2),vunit2(2)

call convex2d_hull(set1,nh,hull)
convex2d_in=0

if(nh==1) return
np=ubound(set2,1)

do i=1,np
    convex2d_in=convex2d_in+1
    do j=1,nh
       k=j+1
       if(j==nh) k=1

        norm1=sqrt(sum((hull(k,:)-hull(j,:))**2))
        if(norm1<1d-10) cycle
        vunit1=(hull(k,:)-hull(j,:))/norm1
        norm2=sqrt(sum((set2(i,:)-hull(j,:))**2))
        if(norm2<1d-10) cycle
        vunit2=(set2(i,:)-hull(j,:))/norm2
        tmp=vunit1(1)*vunit2(2)-vunit2(1)*vunit1(2)  ! cross product

       if(tmp>0.d0) then
            if(width>0.d0) then
               if(convex2d_dist(set2(i:i,:2),hull(:nh,:2))>width) then  ! boundary tolerance
                  convex2d_in=convex2d_in-1
                  exit
               end if
            else
                  convex2d_in=convex2d_in-1
                  exit
            end if
       end if
    end do
end do

end function

function convex2d_dist(set1,set2)
! calculate the distance between two data sets (convex hulls)

real*8 set1(:,:),set2(:,:),convex2d_dist,hull1(ubound(set1,1),2),hull2(ubound(set2,1),2),&
p1(2),p2(2),p3(2),va(2),vb(2),vv(2),dot,len_sq,param,dist
integer nh1,nh2,i,j,k

if(ubound(set1,1)==1) then
  nh1=1
  hull1=set1
else
  call convex2d_hull(set1,nh1,hull1)
end if

if(ubound(set2,1)==1) then
  nh2=1
  hull2=set2
else
  call convex2d_hull(set2,nh2,hull2)
end if

convex2d_dist=1d10

do i=1,nh1
   if(nh1==1) exit
   j=i+1
   if(i==nh1) j=1
   p1=hull1(i,:)
   p2=hull1(j,:)
   va=p2-p1
   len_sq=sum(va**2)
   do k=1,nh2     ! distance of data from set2 to hull1
      p3=hull2(k,:)
      vb=p3-p1
      dot=sum(va*vb)
      if(len_sq/=0.d0) then
         param=dot/len_sq
      else
         param=-1
      end if

      if(param<0.d0) then
         vv=p1
      else if (param>1.d0) then
         vv=p2
      else
        vv(1)=p1(1)+param*va(1)
        vv(2)=p1(2)+param*va(2)
      end if
      dist=sqrt(sum((p3-vv)**2))
      if(dist<convex2d_dist) convex2d_dist=dist
   end do
end do

do i=1,nh2
   if(nh2==1) exit
   j=i+1
   if(i==nh2) j=1
   p1=hull2(i,:)
   p2=hull2(j,:)
   va=p2-p1
   len_sq=sum(va**2)
   do k=1,nh1
      p3=hull1(k,:)
      vb=p3-p1
      dot=sum(va*vb)
      if(len_sq/=0.d0) then
         param=dot/len_sq
      else
         param=-1
      end if

      if(param<0.d0) then
         vv=p1
      else if (param>1.d0) then
         vv=p2
      else
        vv(1)=p1(1)+param*va(1)
        vv(2)=p1(2)+param*va(2)
      end if
      dist=sqrt(sum((p3-vv)**2))
      if(dist<convex2d_dist) convex2d_dist=dist
   end do
end do
end function

subroutine convex1d_overlap(set1,set2,width,numb,length)
! input: set1, set2, width
! output: number of data, and the length, in the overlapped region
real*8 set1(:),set2(:),length,mini,maxi,width
integer numb,i,ns1,ns2
ns1=ubound(set1,1)
ns2=ubound(set2,1)

numb=0
length=0.d0

mini=minval(set2)-width
maxi=maxval(set2)+width
do i=1,ns1
 if(set1(i)>=mini .and. set1(i)<=maxi) numb=numb+1
end do

mini=minval(set1)-width
maxi=maxval(set1)+width
do i=1,ns2
 if(set2(i)>=mini .and. set2(i)<=maxi) numb=numb+1
end do

length=(min(maxval(set1),maxval(set2))-max(minval(set1),minval(set2)))
! if overlapped when length>0, and separated distance when length<0.

end subroutine

function convex1d_in(set1,set2,width)
! check how many data points of set2 are inside the segment by set1
real*8 set1(:),set2(:),mini,maxi,width
integer i,convex1d_in
ns1=ubound(set1,1)
ns2=ubound(set2,1)

convex1d_in=0

mini=minval(set1)-width
maxi=maxval(set1)+width
do i=1,ubound(set2,1)
 if(set2(i)>=mini .and. set2(i)<=maxi) convex1d_in=convex1d_in+1
end do

end function

function convex3d_in(set1,set2,width,ntri,triangles)
! check how many points of set2 are inside a 3d convex hull of set1
! input: the full data set1,set2, the boundary tolerence, and the hull-triangles

integer iii,i,j,k,ntri,ninter,triangles(:,:),convex3d_in
real*8 pref(3),set1(:,:),set2(:,:),width,pproj(3),pinter(3),v1(3),v2(3),v3(3),&
       normal(3),ddd,ttt,area,dist(3),vtmp(3,3)
real*8,allocatable:: inter_all(:,:)
logical inside

convex3d_in=0
allocate(inter_all(ntri,3))

do iii=1,ubound(set2,1)
     ninter=0
     pref=(/set2(iii,1)+1.0,set2(iii,2)+1.0,set2(iii,3)+1.0/) ! point-pref(arbitrary) is the line
     inside=.false.
     do i=1,ntri
       v1=set1(triangles(i,2),:)-set1(triangles(i,1),:)
       v2=set1(triangles(i,3),:)-set1(triangles(i,1),:)
       v3=set1(triangles(i,3),:)-set1(triangles(i,2),:)
       normal=crosspro(v1,v2)  ! normal of the triangle plane
       ddd=-sum(normal*set1(triangles(i,1),:)) ! the d of plane: ax+by+cz+d=0
       ttt=-(sum(normal*set2(iii,:))+ddd)/sum(normal**2)  ! the t of line equation
       pproj=set2(iii,:)+normal*ttt  ! projection of the point on the triangle plane

       ! measure the distance of the point from the triangle
       if(sqrt(sum((set2(iii,:)-pproj)**2))<=width) then
          if(intriangle(pproj,set1(triangles(i,1),:),set1(triangles(i,2),:),set1(triangles(i,3),:))) then !projection inside
             convex3d_in=convex3d_in+1
             inside=.true.
          else
             vtmp(1,:)=set2(iii,:)-set1(triangles(i,1),:)
             vtmp(2,:)=set2(iii,:)-set1(triangles(i,2),:)
             vtmp(3,:)=set2(iii,:)-set1(triangles(i,3),:)
             if(sum(vtmp(1,:)*v1) <=0.d0 .or. &
                sum(vtmp(2,:)*(-v1)) <=0.d0 ) then
                 dist(1)=min(sqrt(sum((vtmp(1,:))**2)),sqrt(sum((vtmp(2,:))**2)))
             else ! only acute angles in the triangle
                 area=sqrt(sum((crosspro(vtmp(1,:),v1))**2))
                 dist(1)=area/sqrt(sum(v1**2))
             end if
             if(sum(vtmp(1,:)*v2) <=0.d0 .or. &
                sum(vtmp(3,:)*(-v2)) <=0.d0 ) then
                 dist(2)=min(sqrt(sum((vtmp(1,:))**2)),sqrt(sum((vtmp(3,:))**2)))
             else ! only acute angles in the triangle
                 area=sqrt(sum((crosspro(vtmp(1,:),v2))**2))
                 dist(2)=area/sqrt(sum(v2**2))
             end if
             if(sum(vtmp(3,:)*(-v3)) <=0.d0 .or. &
                sum(vtmp(2,:)*v3) <=0.d0 ) then
                 dist(3)=min(sqrt(sum((vtmp(3,:))**2)),sqrt(sum((vtmp(2,:))**2)))
             else ! only acute angles in the triangle
                 area=sqrt(sum((crosspro(vtmp(3,:),(-v3)))**2))
                 dist(3)=area/sqrt(sum(v3**2))
             end if
             if(min(dist(1),dist(2),dist(3))<=width) then
                 convex3d_in=convex3d_in+1
                 inside=.true.
              end if
          end if
       end if

       if(inside) exit

       ! if not in the triangle, check intersections
       if(sum((set2(iii,:)-pref)*normal)/=0.d0 ) then ! line-plane is not parallel
         pinter=interlp(set1(triangles(i,1),:),set1(triangles(i,2),:),set1(triangles(i,3),:),set2(iii,:),pref)
         if(intriangle(pinter,set1(triangles(i,1),:),set1(triangles(i,2),:),set1(triangles(i,3),:))) then
             ninter=ninter+1
             inter_all(ninter,:)=pinter
         end if
       end if
     end do

     if(inside) cycle

     do i=1,ninter-1
       do j=i+1,ninter
         if(sqrt(sum((inter_all(i,:)-inter_all(j,:))**2))<1d-10) cycle ! the two points are at the same position
         v1=inter_all(i,:)-set2(iii,:)
         v2=inter_all(j,:)-set2(iii,:)
         if(sum(v1*v2)<0.d0) then  ! if v1 and v2 point to different direction, the point is inside
            convex3d_in=convex3d_in+1     ! otherwise the point is outside
            inside=.true.
         end if
         if(inside) exit
       end do
       if(inside) exit
     end do

end do

deallocate(inter_all)

end function

subroutine convex3d_overlap(set1,set2,width,numb)
! counting the number of overlap data
! input: data set 1, data set 2,width(boundary tolerance)
! output: number of data in the overlapped region

integer no1,no2,i,j,k,nset1,nset2,ntri1,ntri2
integer,allocatable:: triangles(:,:)
real*8 set1(:,:),set2(:,:),width
logical inside

nset1=ubound(set1,1)
nset2=ubound(set2,1)

call convex3d_hull(set1,ntri1,triangles)
if(ntri1==0) then  ! <3D are not prefered
   numb=nset1+nset2
   return
end if

! counts data of set2 in set1
no1=0
no1=no1+convex3d_in(set1,set2,width,ntri1,triangles)
deallocate(triangles)  ! allocated in the convex3d_hull

call convex3d_hull(set2,ntri2,triangles)
if(ntri2==0) then  ! <3D are not prefered
   numb=nset1+nset2
   return
end if

! counts data of set1 in set2
no2=0
no2=no2+convex3d_in(set2,set1,width,ntri2,triangles)
deallocate(triangles)

numb=no1+no2

end subroutine

end module


module mod_fenwick_tree
  use, intrinsic :: iso_fortran_env
  implicit none
  integer, private, parameter :: intkind = int32
  type fenwick_tree
    private
    integer(int32) :: n, p
    integer(intkind), allocatable :: body(:)
  contains
    procedure :: init => init
    procedure :: add => add
    procedure :: sum0 => sum0
    procedure :: sum1 => sum1
    generic :: sum => sum0, sum1
    procedure :: get => get
    procedure :: lower_bound => lower_bound
    procedure :: update => update
    procedure :: max => max0
  end type
  interface fenwick_tree
    module procedure :: newft0
  end interface
contains
  type(fenwick_tree) function newft0(n) result(res)
    integer(int32), intent(in) :: n
    integer(int32) :: p
    p = 1
    do while (lshift(p, 1) <= n)
      p = lshift(p, 1)
    end do
    res%n = n
    res%p = p
    allocate(res%body(n))
    res%body = 0
  end
  subroutine init(this, n)
    class(fenwick_tree), intent(out) :: this
    integer(int32), intent(in) :: n
    integer(int32) :: p
    p = 1
    do while (lshift(p, 1) <= n)
      p = lshift(p, 1)
    end do
    this%n = n
    this%p = p
    allocate(this%body(n))
    this%body = 0
  end
  subroutine add(this, i, v)
    class(fenwick_tree), intent(inout) :: this
    integer(int32), intent(in) :: i
    integer(intkind), intent(in) :: v
    integer(int32) :: x
    x = i
    do while (x <= this%n)
      this%body(x) = this%body(x) + v
      x = x + and(x, -x)
    end do
  end
  integer(intkind) function sum0(this, i) result(res)
    class(fenwick_tree), intent(in) :: this
    integer(int32), intent(in) :: i
    integer(int32) :: x
    res = 0
    x = i
    do while (x > 0)
      res = res + this%body(x)
      x = x - and(x, -x)
    end do
  end
  integer(intkind) function sum1(this, l, r) result(res)
    class(fenwick_tree), intent(in) :: this
    integer(int32), intent(in) :: l, r
    integer(int32) :: i, j
    res = 0
    i = l - 1
    j = r
    do while (j > i)
      res = res + this%body(j)
      j = j - and(j, -j)
    end do
    do while (i > j)
      res = res - this%body(i)
      i = i - and(i, -i)
    end do
  end
  integer(intkind) function get(this, i) result(res)
    class(fenwick_tree), intent(in) :: this
    integer(int32), intent(in) :: i
    integer(int32) :: x
    res = sum1(this, i, i)
  end
  integer(int32) function lower_bound(this, v) result(res)
    class(fenwick_tree), intent(in) :: this
    integer(intkind), intent(in) :: v
    integer(int32) :: k
    integer(intkind) :: w
    res = 0
    if (v <= 0) return
    k = this%p
    w = v
    do while (k > 0)
      if (res + k <= this%n .and. this%body(res + k) < w) then
        w = w - this%body(res + k)
        res = res + k
      end if
      k = rshift(k, 1)
    end do
    res = res + 1
  end
  subroutine update(this, i, v)
    class(fenwick_tree), intent(inout) :: this
    integer(int32), intent(in) :: i
    integer(intkind), intent(in) :: v
    integer(int32) :: x
    x = i
    do while (x <= this%n)
      if (this%body(x) < v) this%body(x) = v
      x = x + and(x, -x)
    end do
  end
  integer(intkind) function max0(this, i) result(res)
    class(fenwick_tree), intent(in) :: this
    integer(int32), intent(in) :: i
    integer(int32) :: x
    x = i
    res = 0
    do while (x > 0)
      res = max(res, this%body(x))
      x = x - and(x, -x)
    end do
  end
  integer(intkind) function lis_length(a) result(res)
    integer, intent(in) :: a(:)
    type(fenwick_tree) :: bit
    integer(intkind) :: tmp
    integer(int32) :: n, i
    n = size(a)
    call init(bit, n)
    res = 0
    do i = 1, n
      tmp = max0(bit, a(i) - 1) + 1
      res = max(res, tmp)
      call update(bit, a(i), tmp)
    end do
  end
  integer(intkind) function inversion_num(a) result(res)
    integer(int32), intent(in) :: a(:)
    type(fenwick_tree) :: bit
    integer(int32) :: n, i
    n = size(a)
    call init(bit, n)
    res = 0
    do i = 1, n
      call add(bit, a(i), 1_intkind)
      res = res + i - sum0(bit, a(i))
    end do
  end
end module mod_fenwick_tree


c     comment section
c
c     fm038
c
c         this routine tests arithmetic assignment statements of the
c     form          integer variable = arithmetic expression
c     where the arithmetic expression is formed with the arithmetic
c     operator /, integer constants and an integer variable.  both
c     positive and negative values are used for the integer constants
c     and the integer variable.
c
c         there are tests which require no truncation of the result
c     and tests where the result must be truncated before being stored
c     in the resultant integer variable.  some of the tests use parens
c     to group elements in the arithmetic expression.
c
c         there are tests where the arithmetic expression contains
c             (1) (integer constant/integer constant)/integer constant
c             (2) integer constant/(integer constant/integer constant)
c             (3) integer variable/integer constant
c             (4) integer constant/integer variable
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 6.6, evaluation of expressions
c        section 10.1, arithmetic assignment statement
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c         arithmetic assignment statement
c
c     test 520 through test 525 contain arithmetic assignment statements
c     of the form       integer variable = (int.con./int.con.)/int.con.
c     no truncation of the result is required.  both positive and
c     negative constants are included.
c
 5201 continue
      ivtnum = 520
c
c      ****  test 520  ****
c
      if (iczero) 35200, 5200, 35200
 5200 continue
      ivcomp = (24/3)/4
      go to 45200
35200 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45200, 5211, 45200
45200 if (ivcomp - 2) 25200,15200,25200
15200 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5211
25200 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5211 continue
      ivtnum = 521
c
c      ****  test 521  ****
c
      if (iczero) 35210, 5210, 35210
 5210 continue
      ivcomp = (7150/2)/25
      go to 45210
35210 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45210, 5221, 45210
45210 if (ivcomp - 143) 25210,15210,25210
15210 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5221
25210 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5221 continue
      ivtnum = 522
c
c      ****  test 522  ****
c
      if (iczero) 35220, 5220, 35220

 5220 continue
      ivcomp = (-24/3)/4
      go to 45220
35220 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45220, 5231, 45220
45220 if (ivcomp + 2) 25220,15220,25220
15220 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5231
25220 ivfail = ivfail + 1
      ivcorr = -2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5231 continue
      ivtnum = 523
c
c      ****  test 523  ****
c
      if (iczero) 35230, 5230, 35230
 5230 continue
      ivcomp = (330/(-3))/2
      go to 45230
35230 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45230, 5241, 45230
45230 if (ivcomp + 55) 25230,15230,25230
15230 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5241
25230 ivfail = ivfail + 1
      ivcorr = -55
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5241 continue
      ivtnum = 524
c
c      ****  test 524  ****
c
      if (iczero) 35240, 5240, 35240
 5240 continue
      ivcomp = ((-7150)/(-2))/(-25)
      go to 45240
35240 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45240, 5251, 45240
45240 if (ivcomp + 143) 25240,15240,25240
15240 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5251
25240 ivfail = ivfail + 1
      ivcorr = -143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5251 continue
      ivtnum = 525
c
c      ****  test 525  ****
c
      if (iczero) 35250, 5250, 35250
 5250 continue
      ivcomp = (15249/(-13))/(-51)
      go to 45250
35250 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45250, 5261, 45250
45250 if (ivcomp - 23) 25250,15250,25250
15250 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5261
25250 ivfail = ivfail + 1
      ivcorr = 23
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 526 through test 531 contain arithmetic assignment statements
c     of the form   iv = (ic/ic)/ic.
c     truncation of the result is required.  both positive and
c     negative constants are included.
c
 5261 continue
      ivtnum = 526
c
c      ****  test 526  ****
c
      if (iczero) 35260, 5260, 35260
 5260 continue
      ivcomp = (24/3)/3
      go to 45260
35260 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45260, 5271, 45260
45260 if (ivcomp - 2) 25260,15260,25260
15260 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5271
25260 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5271 continue
      ivtnum = 527
c
c      ****  test 527  ****
c
      if (iczero) 35270, 5270, 35270
 5270 continue
      ivcomp = (7151/3)/10
      go to 45270
35270 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45270, 5281, 45270
45270 if (ivcomp - 238) 25270,15270,25270
15270 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5281
25270 ivfail = ivfail + 1
      ivcorr = 238
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5281 continue
      ivtnum = 528
c
c      ****  test 528  ****
c
      if (iczero) 35280, 5280, 35280
 5280 continue
      ivcomp = (-24/3)/3
      go to 45280
35280 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45280, 5291, 45280
45280 if (ivcomp + 2) 25280,15280,25280
15280 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5291
25280 ivfail = ivfail + 1
      ivcorr = -2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5291 continue
      ivtnum = 529
c
c      ****  test 529  ****
c
      if (iczero) 35290, 5290, 35290
 5290 continue
      ivcomp = (7151/(-3))/10
      go to 45290
35290 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45290, 5301, 45290
45290 if (ivcomp + 238) 25290,15290,25290
15290 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5301
25290 ivfail = ivfail + 1
      ivcorr = -238
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5301 continue
      ivtnum = 530
c
c      ****  test 530  ****
c
      if (iczero) 35300, 5300, 35300
 5300 continue
      ivcomp = (15248/(-51))/(-23)
      go to 45300
35300 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45300, 5311, 45300
45300 if (ivcomp - 12) 25300,15300,25300
15300 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5311
25300 ivfail = ivfail + 1
      ivcorr = 12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5311 continue
      ivtnum = 531
c
c      ****  test 531  ****
c
      if (iczero) 35310, 5310, 35310
 5310 continue
      ivcomp = ((-27342)/(-4))/(-3)
      go to 45310
35310 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45310, 5321, 45310
45310 if (ivcomp + 2278) 25310,15310,25310
15310 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5321
25310 ivfail = ivfail + 1
      ivcorr = -2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 532 through test 537 contain arithmetic assignment statements
c     of the form   iv = ic/(ic/ic).
c     no truncation of the result is required.  both positive and
c     negative constants are included.
c
 5321 continue
      ivtnum = 532
c
c      ****  test 532  ****
c
      if (iczero) 35320, 5320, 35320
 5320 continue
      ivcomp = 24/(8/4)
      go to 45320
35320 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45320, 5331, 45320
45320 if (ivcomp - 12) 25320,15320,25320
15320 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5331
25320 ivfail = ivfail + 1
      ivcorr = 12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5331 continue
      ivtnum = 533
c
c      ****  test 533  ****
c
      if (iczero) 35330, 5330, 35330
 5330 continue
      ivcomp = 7150/(25/5)
      go to 45330
35330 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45330, 5341, 45330
45330 if (ivcomp - 1430) 25330,15330,25330
15330 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5341
25330 ivfail = ivfail + 1
      ivcorr = 1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5341 continue
      ivtnum = 534
c
c      ****  test 534  ****
c
      if (iczero) 35340, 5340, 35340
 5340 continue
      ivcomp = -24/(8/4)
      go to 45340
35340 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45340, 5351, 45340
45340 if (ivcomp + 12) 25340,15340,25340
15340 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5351
25340 ivfail = ivfail + 1
      ivcorr = -12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5351 continue
      ivtnum = 535
c
c      ****  test 535  ****
c
      if (iczero) 35350, 5350, 35350
 5350 continue
      ivcomp = 24/((-8)/4)
      go to 45350
35350 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45350, 5361, 45350
45350 if (ivcomp + 12) 25350,15350,25350
15350 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5361
25350 ivfail = ivfail + 1
      ivcorr = -12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5361 continue
      ivtnum = 536
c
c      ****  test 536  ****
c
      if (iczero) 35360, 5360, 35360
 5360 continue
      ivcomp = (-7150)/((-25)/(-5))
      go to 45360
35360 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45360, 5371, 45360
45360 if (ivcomp + 1430) 25360,15360,25360
15360 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5371
25360 ivfail = ivfail + 1
      ivcorr = -1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5371 continue
      ivtnum = 537
c
c      ****  test 537  ****
c
      if (iczero) 35370, 5370, 35370
 5370 continue
      ivcomp = -7150/(25/(-5))
      go to 45370
35370 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45370, 5381, 45370
45370 if (ivcomp - 1430) 25370,15370,25370
15370 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5381
25370 ivfail = ivfail + 1
      ivcorr = 1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 538 through test 543 contain arithmetic assigmment statements
c     of the form   iv = ic/(ic/ic).
c     truncation of the result is required.  both positive and
c     negative constants are included.
c
 5381 continue
      ivtnum = 538
c
c      ****  test 538  ****
c
      if (iczero) 35380, 5380, 35380
 5380 continue
      ivcomp = 29/(5/2)
      go to 45380
35380 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45380, 5391, 45380
45380 if (ivcomp - 14) 25380,15380,25380
15380 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5391
25380 ivfail = ivfail + 1
      ivcorr = 14
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5391 continue
      ivtnum = 539
c
c      ****  test 539  ****
c
      if (iczero) 35390, 5390, 35390
 5390 continue
      ivcomp = 7154/(26/5)
      go to 45390
35390 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45390, 5401, 45390
45390 if (ivcomp - 1430) 25390,15390,25390
15390 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5401
25390 ivfail = ivfail + 1
      ivcorr = 1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5401 continue
      ivtnum = 540
c
c      ****  test 540  ****
c
      if (iczero) 35400, 5400, 35400
 5400 continue
      ivcomp = -7154/(26/5)
      go to 45400
35400 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45400, 5411, 45400
45400 if (ivcomp + 1430) 25400,15400,25400
15400 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5411
25400 ivfail = ivfail + 1
      ivcorr = -1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5411 continue
      ivtnum = 541
c
c      ****  test 541  ****
c
      if (iczero) 35410, 5410, 35410
 5410 continue
      ivcomp = (-7154)/((-26)/5)
      go to 45410
35410 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45410, 5421, 45410
45410 if (ivcomp - 1430) 25410,15410,25410
15410 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5421
25410 ivfail = ivfail + 1
      ivcorr = 1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5421 continue
      ivtnum = 542
c
c      ****  test 542  ****
c
      if (iczero) 35420, 5420, 35420
 5420 continue
      ivcomp = 7154/((-26)/(-5))
      go to 45420
35420 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45420, 5431, 45420
45420 if (ivcomp - 1430) 25420,15420,25420
15420 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5431
25420 ivfail = ivfail + 1
      ivcorr = 1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5431 continue
      ivtnum = 543
c
c      ****  test 543  ****
c
      if (iczero) 35430, 5430, 35430
 5430 continue
      ivcomp = (-7154)/((-26)/(-5))
      go to 45430
35430 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45430, 5441, 45430
45430 if (ivcomp + 1430) 25430,15430,25430
15430 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5441
25430 ivfail = ivfail + 1
      ivcorr = -1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 544 through test 547 contain arithmetic assignment statements
c     of the form   integer variable = integer variable/integer constant
c
 5441 continue
      ivtnum = 544
c
c      ****  test 544  ****
c
      if (iczero) 35440, 5440, 35440
 5440 continue
      ivon01 = 75
      ivcomp = ivon01/25
      go to 45440
35440 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45440, 5451, 45440
45440 if (ivcomp - 3) 25440,15440,25440
15440 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5451
25440 ivfail = ivfail + 1
      ivcorr = 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5451 continue
      ivtnum = 545
c
c      ****  test 545  ****
c
      if (iczero) 35450, 5450, 35450
 5450 continue
      ivon01 = -3575
      ivcomp = ivon01/25
      go to 45450
35450 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45450, 5461, 45450
45450 if (ivcomp + 143) 25450,15450,25450
15450 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5461
25450 ivfail = ivfail + 1
      ivcorr = -143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5461 continue
      ivtnum = 546
c
c      ****  test 546  ****
c
      if (iczero) 35460, 5460, 35460
 5460 continue
      ivon01 = 3575
      ivcomp = ivon01/(-143)
      go to 45460
35460 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45460, 5471, 45460
45460 if (ivcomp + 25) 25460,15460,25460
15460 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5471
25460 ivfail = ivfail + 1
      ivcorr = -25
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5471 continue
      ivtnum = 547
c
c      ****  test 547  ****
c
      if (iczero) 35470, 5470, 35470
 5470 continue
      ivon01 = 959
      ivcomp = ivon01/120
      go to 45470
35470 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45470, 5481, 45470
45470 if (ivcomp -7)  25470,15470,25470
15470 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5481
25470 ivfail = ivfail + 1
      ivcorr = 7
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 548 through test 551 contain arithmetic assignment statements
c     of the form   integer variable =integer constant/integer variable.
c
 5481 continue
      ivtnum = 548
c
c      ****  test 548  ****
c
      if (iczero) 35480, 5480, 35480
 5480 continue
      ivon02 = 25
      ivcomp = 75/ivon02
      go to 45480
35480 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45480, 5491, 45480
45480 if (ivcomp - 3) 25480,15480,25480
15480 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5491
25480 ivfail = ivfail + 1
      ivcorr = 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5491 continue
      ivtnum = 549
c
c      ****  test 549  ****
c
      if (iczero) 35490, 5490, 35490
 5490 continue
      ivon02 = -25
      ivcomp = 3579/ivon02
      go to 45490
35490 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45490, 5501, 45490
45490 if (ivcomp + 143) 25490,15490,25490
15490 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5501
25490 ivfail = ivfail + 1
      ivcorr = -143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5501 continue
      ivtnum = 550
c
c      ****  test 550  ****
c
      if (iczero) 35500, 5500, 35500
 5500 continue
      ivon02 = -143
      ivcomp = (-3575)/ivon02
      go to 45500
35500 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45500, 5511, 45500
45500 if (ivcomp - 25) 25500,15500,25500
15500 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5511
25500 ivfail = ivfail + 1
      ivcorr = 25
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5511 continue
      ivtnum = 551
c
c      ****  test 551  ****
c
      if (iczero) 35510, 5510, 35510
 5510 continue
      ivon02 = 120
      ivcomp = -959/ivon02
      go to 45510
35510 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45510, 5521, 45510
45510 if (ivcomp + 7) 25510,15510,25510
15510 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5521
25510 ivfail = ivfail + 1
      ivcorr = -7
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c      ****    end of tests    ****
 5521 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm038)
      end


! *****************************COPYRIGHT*******************************
! (C) Crown copyright Met Office. All rights reserved.
! For further details please refer to the file COPYRIGHT.txt
! which you should have received as part of this distribution.
! *****************************COPYRIGHT*******************************
!
! Set and calculate derived fields here
!
!

Module derived_fields

  Use column_variables
  Use interpolation, only: interpolate, make_wgrid, make_vgrid &
       ,interpolate_x
  Use physconst, only : r_on_cp, g, p0, pi
  Use switches, only : icase

  Implicit none

contains

  subroutine calc_derived_fields

    ! Fields derived from model values, but kept
    ! in column_variables for use in some
    ! microphysics schemes
    integer :: k,j

    TdegK(:,:)=exner(:,:)*theta(:,:)
    pmb(:,:)=.01*p0*exner(:,:)**(1./r_on_cp)

    ! If we need a staggered grid in vertical...

    if (icase /= 650) then
       call make_wgrid(z,z_half)
       if ( nx > 1 ) then
       ! If we need a staggered grid in horizontal
          call make_vgrid(x,x_half)
       else
          x_half = x
       endif
    else
       !print *, 'make_wgrid called in test_case_2d'
    endif

    ! density on half levels
    do k=1,nz-1
       rho_half(k)=sqrt(rho(k)*rho(k+1))
    end do
    rho_half(nz)=rho(nz)*rho(nz)/rho(nz-1)

    !dz
    do k=2, nz
       dz(k)=z(k)-z(k-1)
       dz_half(k)=z_half(k)-z_half(k-1)
    end do
    dz(1)=dz(2)
    dz_half(1)=dz_half(2)

    !dx
    if (nx > 1) then
       do j=1,nx
          dx(j)=x(j)-x(j-1)
          dx_half(j)=x_half(j)-x_half(j-1)
       end do
       dx(0)=dx(1)
       dx(nx+1)=dx(nx)
       dx_half(0)=dx_half(1)
       dx_half(nx+1)=dx_half(nx)
    else
       dx(:) = 1.
       dx_half(:) = 1.
    endif

  end subroutine calc_derived_fields

End Module derived_fields


      subroutine cualde(idim,t,n,c,nc,k1,u,d,nd,ier)
c  subroutine cualde evaluates at the point u all the derivatives
c                     (l)
c     d(idim*l+j) = sj   (u) ,l=0,1,...,k, j=1,2,...,idim
c  of a spline curve s(u) of order k1 (degree k=k1-1) and dimension idim
c  given in its b-spline representation.
c
c  calling sequence:
c     call cualde(idim,t,n,c,nc,k1,u,d,nd,ier)
c
c  input parameters:
c    idim : integer, giving the dimension of the spline curve.
c    t    : array,length n, which contains the position of the knots.
c    n    : integer, giving the total number of knots of s(u).
c    c    : array,length nc, which contains the b-spline coefficients.
c    nc   : integer, giving the total number of coefficients of s(u).
c    k1   : integer, giving the order of s(u) (order=degree+1).
c    u    : real, which contains the point where the derivatives must
c           be evaluated.
c    nd   : integer, giving the dimension of the array d. nd >= k1*idim
c
c  output parameters:
c    d    : array,length nd,giving the different curve derivatives.
c           d(idim*l+j) will contain the j-th coordinate of the l-th
c           derivative of the curve at the point u.
c    ier  : error flag
c      ier = 0 : normal return
c      ier =10 : invalid input data (see restrictions)
c
c  restrictions:
c    nd >= k1*idim
c    t(k1) <= u <= t(n-k1+1)
c
c  further comments:
c    if u coincides with a knot, right derivatives are computed
c    ( left derivatives if u = t(n-k1+1) ).
c
c  other subroutines required: fpader.
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer idim,n,nc,k1,nd,ier
      real u
c  ..array arguments..
      real t(n),c(nc),d(nd)
c  ..local scalars..
      integer i,j,kk,l,m,nk1
c  ..local array..
      real h(6)
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      if(nd.lt.(k1*idim)) go to 500
      nk1 = n-k1
      if(u.lt.t(k1) .or. u.gt.t(nk1+1)) go to 500
c  search for knot interval t(l) <= u < t(l+1)
      l = k1
 100  if(u.lt.t(l+1) .or. l.eq.nk1) go to 200
      l = l+1
      go to 100
 200  if(t(l).ge.t(l+1)) go to 500
      ier = 0
c  calculate the derivatives.
      j = 1
      do 400 i=1,idim
        call fpader(t,n,c(j),k1,u,l,h)
        m = i
        do 300 kk=1,k1
          d(m) = h(kk)
          m = m+idim
 300    continue
        j = j+n
 400  continue
 500  return
      end


MODULE GIBBS_EXTRA

	IMPLICIT NONE

	INTEGER,dimension(100):: CLIK_LMAX,CLIK_LMIN,clik_approx_chi2
	real(8),dimension(2:1000) :: cltt
	real(8),parameter:: PI    = 3.141592653589793238462643383279502884197

END MODULE GIBBS_EXTRA

SUBROUTINE GIBBS_EXTRA_FREE(handle)
	use comm_br_mod
	use GIBBS_EXTRA
	INTEGER,intent(in)::handle

	call comm_br_deallocate_object(handle)

	clik_lmin(handle) = -1
	clik_lmax(handle) = -1

END SUBROUTINE 	GIBBS_EXTRA_FREE

SUBROUTINE GIBBS_EXTRA_LKL(LKL,handle,CL)
	use comm_br_mod
	use GIBBS_EXTRA

	REAL(8),INTENT(OUT)::LKL
	INTEGER,intent(in)::handle
	REAL(8),INTENT(IN),DIMENSION(0:CLIK_LMAX(handle)-CLIK_LMIN(handle))::CL
	INTEGER::i,cur

	!TT
	cur = 0
	cltt = 0
	DO i = clik_lmin(handle),clik_lmax(handle)
		cltt(i)=CL(cur)*(i*(i+1.))/2./PI
		cur = cur + 1
	END DO

	LKL = comm_br_compute_lnL(cltt(2:clik_lmax(handle)),handle)

	if (clik_approx_chi2(handle)==1) then
		LKL = LKL - 0.5d0 * (clik_lmax(handle)-clik_lmin(handle)+1)
	endif

END SUBROUTINE 	GIBBS_EXTRA_LKL

SUBROUTINE GIBBS_EXTRA_PARAMETER_INIT(handle,datadir,l_datadir,lmin,lmax,firstchain,lastchain,firstsample,lastsample,step,approx_chi2)
	use comm_br_mod
	use GIBBS_EXTRA

	INTEGER,INTENT(IN)::l_datadir,lmin,lmax,firstchain,lastchain,firstsample,lastsample,step,approx_chi2
	character(len=l_datadir)::datadir
	INTEGER,INTENT(OUT)::handle
	character(len=1000)::sigma_file,cl_file,data_dir

	data_dir = TRIM(datadir)
	sigma_file = TRIM(data_dir)//"/sigma.fits"
	cl_file = TRIM(data_dir)//"/cl.dat"

	handle = 0

	call comm_br_initialize_object(sigma_file, cl_file, lmin, lmax, firstchain, lastchain, &
       & firstsample, lastsample, step, handle)

	clik_lmin(handle) = lmin
	clik_lmax(handle) = lmax
	clik_approx_chi2(handle) = approx_chi2

END SUBROUTINE 	GIBBS_EXTRA_PARAMETER_INIT

SUBROUTINE GIBBS_GAUSS_EXTRA_FREE(handle)
	use comm_gauss_br_mod
	use GIBBS_EXTRA
	INTEGER,intent(in)::handle

	call comm_gauss_br_deallocate_object(handle)

	clik_lmin(handle) = -1
	clik_lmax(handle) = -1

END SUBROUTINE 	GIBBS_GAUSS_EXTRA_FREE

SUBROUTINE GIBBS_GAUSS_EXTRA_LKL(LKL,handle,CL)
	use comm_gauss_br_mod
	use GIBBS_EXTRA

	REAL(8),INTENT(OUT)::LKL
	INTEGER,intent(in)::handle
	REAL(8),INTENT(IN),DIMENSION(0:CLIK_LMAX(handle)-CLIK_LMIN(handle))::CL
	INTEGER::i,cur

	!TT
	cur = 0
	cltt = 0
	DO i = clik_lmin(handle),clik_lmax(handle)
		cltt(i)=CL(cur)*(i*(i+1.))/2./PI
		cur = cur + 1
	END DO

	LKL = comm_gauss_br_compute_lnL(cltt(2:clik_lmax(handle)),handle)

END SUBROUTINE 	GIBBS_GAUSS_EXTRA_LKL

SUBROUTINE GIBBS_GAUSS_EXTRA_PARAMETER_INIT(handle,lmin,lmax,delta_l)
	use comm_gauss_br_mod
	use GIBBS_EXTRA

	INTEGER,INTENT(IN)::lmin,lmax,delta_l
	INTEGER,INTENT(OUT)::handle
	character(len=1000)::sigma_file

	sigma_file = "sigma.fits"

	handle = 0

	call comm_gauss_br_initialize_object(sigma_file, lmin, lmax, delta_l, handle)

	clik_lmin(handle) = lmin
	clik_lmax(handle) = lmax

END SUBROUTINE 	GIBBS_GAUSS_EXTRA_PARAMETER_INIT

SUBROUTINE GIBBS_GAUSS_EXTRA_V3_FREE(handle)
	use comm_gauss_br_mod_v3
	use GIBBS_EXTRA
	INTEGER,intent(in)::handle

	call comm_gauss_br_deallocate_object(handle)

	clik_lmin(handle) = -1
	clik_lmax(handle) = -1

END SUBROUTINE 	GIBBS_GAUSS_EXTRA_V3_FREE

SUBROUTINE GIBBS_GAUSS_EXTRA_V3_LKL(LKL,handle,CL)
	use comm_gauss_br_mod_v3
	use GIBBS_EXTRA

	REAL(8),INTENT(OUT)::LKL
	INTEGER,intent(in)::handle
	REAL(8),INTENT(IN),DIMENSION(0:CLIK_LMAX(handle)-CLIK_LMIN(handle))::CL
	INTEGER::i,cur

	!TT
	cur = 0
	cltt = 0
	DO i = clik_lmin(handle),clik_lmax(handle)
		cltt(i)=CL(cur)*(i*(i+1.))/2./PI
		cur = cur + 1
	END DO

	LKL = comm_gauss_br_compute_lnL(cltt(2:clik_lmax(handle)),handle)

END SUBROUTINE 	GIBBS_GAUSS_EXTRA_V3_LKL

SUBROUTINE GIBBS_GAUSS_EXTRA_PARAMETER_V3_INIT(handle,lmin,lmax,delta_l)
	use comm_gauss_br_mod_v3
	use GIBBS_EXTRA

	INTEGER,INTENT(IN)::lmin,lmax,delta_l
	INTEGER,INTENT(OUT)::handle
	character(len=1000)::sigma_file

	sigma_file = "sigma.fits"

	handle = 0

	call comm_gauss_br_initialize_object(sigma_file, lmin, lmax, delta_l, handle)

	clik_lmin(handle) = lmin
	clik_lmax(handle) = lmax

END SUBROUTINE 	GIBBS_GAUSS_EXTRA_PARAMETER_v3_INIT

MODULE COMM_LOWL_EXTRA

	IMPLICIT NONE

	INTEGER,dimension(100):: CLIK_LMAX, CLIK_LMIN
	real(8),dimension(0:100,1:6) :: cl_
	real(8),parameter:: PI    = 3.141592653589793238462643383279502884197

END MODULE COMM_LOWL_EXTRA

SUBROUTINE COMM_LOWL_EXTRA_PARAMETER_INIT(handle,parfile,l_parfile,lmin,lmax)
use comm_lowl_mod_dist
use COMM_LOWL_EXTRA
character(len=l_parfile)::parfile
integer,intent(OUT)::handle
integer,intent(IN)::l_parfile,lmax

call comm_lowl_initialize_object(parfile,handle)
clik_lmax(handle) = lmax
clik_lmin(handle) = lmin

END SUBROUTINE COMM_LOWL_EXTRA_PARAMETER_INIT

SUBROUTINE COMM_LOWL_EXTRA_LKL(LKL,handle,CL)
use comm_lowl_mod_dist
use COMM_LOWL_EXTRA
REAL(8),INTENT(OUT)::LKL
INTEGER,intent(in)::handle
REAL(8),INTENT(IN),DIMENSION(0:(CLIK_LMAX(handle)-clik_lmin(handle)+1)*6-1)::CL
integer::zero,i

cl_ = 0

!TT
zero = 0
DO i = clik_lmin(handle),clik_lmax(handle)
	cl_(i,1) = CL(zero+i-clik_lmin(handle)) *i*(i+1.)/2./PI
END DO

!EE
zero = zero + clik_lmax(handle)+1-clik_lmin(handle)
DO i = clik_lmin(handle),clik_lmax(handle)
	cl_(i,4) = CL(zero+i-clik_lmin(handle)) *i*(i+1.)/2./PI
END DO

!BB
zero = zero + clik_lmax(handle)+1-clik_lmin(handle)
DO i = clik_lmin(handle),clik_lmax(handle)
	cl_(i,6) = CL(zero+i-clik_lmin(handle)) *i*(i+1.)/2./PI
END DO

!TE
zero = zero + clik_lmax(handle)+1-clik_lmin(handle)
DO i = clik_lmin(handle),clik_lmax(handle)
	cl_(i,2) = CL(zero+i-clik_lmin(handle)) *i*(i+1.)/2./PI
END DO

!TB
zero = zero + clik_lmax(handle)+1-clik_lmin(handle)
DO i = clik_lmin(handle),clik_lmax(handle)
	cl_(i,3) = CL(zero+i-clik_lmin(handle)) *i*(i+1.)/2./PI
END DO

!EB
zero = zero + clik_lmax(handle)+1-clik_lmin(handle)
DO i = clik_lmin(handle),clik_lmax(handle)
	cl_(i,5) = CL(zero+i-clik_lmin(handle)) *i*(i+1.)/2./PI
END DO

LKL = comm_lowl_compute_lnL(cls=cl_, handle=handle)

END SUBROUTINE COMM_LOWL_EXTRA_LKL

SUBROUTINE COMM_LOWL_EXTRA_FREE(handle)
	use comm_lowl_mod_dist
	use COMM_LOWL_EXTRA
	INTEGER,intent(in)::handle

	call comm_lowl_deallocate_object(handle)

	clik_lmax(handle) = -1

END SUBROUTINE 	COMM_LOWL_EXTRA_FREE