! soft k-means clustering with k=2
! D.J.C. MacKay, Information Theory, Inference & Learning Algorithms, 2003, p.304
! Aug 2006

module kmeans_clstr
  use RandomNS
  use utils1
  implicit none

contains

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

  !soft k-means corresponding to the model of axis aligned Gaussians (see
  !MacKay, 2003)
  subroutine kmeans(k,pt,npt,numdim,cluster,min_pt)
    implicit none

    integer k,numdim,npt
    double precision pt(numdim,npt)
    double precision sigsq(k,numdim),means(k,numdim),wt(k),r(npt,k)
    integer cluster(npt)
    double precision sumr,totR(k),temp,covmat(numdim,numdim),mean(numdim)
    integer i,j,indx(1),x,nochg,count,min_pt
    logical clstrd
    double precision urv

    if(k>npt/min_pt+1) k=npt/min_pt+1

    clstrd=.false.
    nochg=0
    count=0

    do i=1,numdim
    	mean(i)=sum(pt(i,1:npt))/dble(npt)
    end do

    call calc_covmat(npt,numdim,pt,mean,covmat)

    do i=1,k
    	wt(i)=ranmarns(0)
      urv=ranmarns(0)
      x=int(dble(npt)*urv)+1
    	means(i,:)=pt(:,x)
    end do

!    means(1,1)=0
!    means(1,2)=0
!    means(2,1)=1.
!    means(2,2)=1.

    temp=huge(1.d0)
    do j=1,numdim
	       if(covmat(j,j)<temp) temp=covmat(j,j)
    end do
    sigsq=temp
    temp=sum(wt)
    wt=wt/temp

    do
    	count=count+1
      clstrd=.true.
    	do i=1,npt
		do j=1,k
			temp=1.
			do x=1,numdim
				temp=temp*2.506628275*sqrt(sigsq(j,x))
			end do
			r(i,j)=wt(j)*exp(-sum(((means(j,:)-pt(:,i))**2.)/(2.*sigsq(j,:))))/temp
		end do
		sumr=sum(r(i,:))
		r(i,:)=r(i,:)/sumr
		indx=maxloc(r(i,:))
            if(cluster(i)/=indx(1)) clstrd=.false.
		cluster(i)=indx(1)
	end do

	if(clstrd) then
		nochg=nochg+1
		if(nochg==2) exit
	else
		nochg=0
	end if

	do i=1,k
		totR(i)=sum(r(:,i))

		! update means & sigsq
		do j=1,numdim
			means(i,j)=sum(r(:,i)*pt(j,:))/totR(i)
			sigsq(i,j)=sum(r(:,i)*((pt(j,:)-means(i,j))**2.))/totR(i)
		end do
	end do

	!update weights
	temp=sum(totR(:))
	wt(:)=totR(:)/temp

    end do

  end subroutine kmeans

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

  !soft k-means corresponding to the model of spherical Gaussians (see MacKay 2003)
  subroutine kmeans2(k,pt,npt,numdim,cluster,min_pt)
    implicit none

    integer k,numdim,npt
    double precision pt(numdim,npt)
    double precision sigsq(k),means(k,numdim),wt(k),r(npt,k)
    integer cluster(npt),old_cluster(npt)
    double precision sumr,totR(k),temp,covmat(numdim,numdim),mean(numdim)
    integer i,j,indx(1),x,nochg,min_pt
    logical clstrd
    double precision urv

    if(k>npt/min_pt+1) k=npt/min_pt+1
    clstrd=.false.
    nochg=0

    do i=1,numdim
    	mean(i)=sum(pt(i,1:npt))/dble(npt)
    end do

    call calc_covmat(npt,numdim,pt,mean,covmat)

    do i=1,k
    	wt(i)=ranmarns(0)
      urv=ranmarns(0)
      x=int(dble(npt)*urv)+1
    	means(i,:)=pt(:,x)
    end do

    temp=huge(1.d0)
    do j=1,numdim
	       if(covmat(j,j)<temp) temp=covmat(j,j)
    end do
    sigsq=temp
    temp=sum(wt)
    wt=wt/temp

    old_cluster=0

    do
    	do i=1,npt
		do j=1,k
			temp=(2.506628275*sqrt(sigsq(j)))**dble(numdim)
			r(i,j)=wt(j)*exp(-sum((means(j,:)-pt(:,i))**2.)/(2.*sigsq(j)))/temp
		end do
		sumr=sum(r(i,:))
		r(i,:)=r(i,:)/sumr
		indx=maxloc(r(i,:))
		cluster(i)=indx(1)
	end do

	clstrd=.true.
	do i=1,npt
		if(old_cluster(i).ne.cluster(i)) then
			clstrd=.false.
			exit
		end if
	end do
	if(clstrd) then
		nochg=nochg+1
		if(nochg==2) exit
	else
		nochg=0
	end if
	old_cluster=cluster

	do i=1,k
		totR(i)=sum(r(:,i))
		sigsq(i)=0.

		! update means & sigsq
		do j=1,numdim
			means(i,j)=sum(r(:,i)*pt(j,:))/totR(i)
			sigsq(i)=sigsq(i)+sum(r(:,i)*((pt(j,:)-means(i,j))**2.))
		end do
		sigsq(i)=sigsq(i)/(numdim*totR(i))
	end do

	!update weights
	temp=sum(totR(:))
	wt(:)=totR(:)/temp

    end do

  end subroutine kmeans2

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

  !simple k-means
  subroutine kmeans3(k,pt,npt,numdim,means,cluster,min_pt)
	implicit none

    	integer k,numdim,npt,i1,i2,i3
    	double precision pt(numdim,npt)
    	double precision means(k,numdim),dis(min_pt,2)
    	integer cluster(npt),old_cluster(npt),r(npt,k),totR(k)
    	double precision temp,dist
    	integer i,j,x,nochg,scrap(k),min_pt
    	logical clstrd,flag
    	double precision urv,d1

    	if(k>npt/min_pt+1) k=npt/min_pt+1

	if(k==1) then
		do i=1,numdim
			means(1,i)=sum(pt(i,1:npt))/dble(npt)
		enddo
		cluster=1
		return
	endif

    	clstrd=.false.
    	nochg=0

!    call ranmarns(urv)
!    x=int(dble(npt)*urv)+1
!    means(1,:)=pt(:,x)
!    temp=-1.
!    do i=2,k
!    	lmean(:)=sum(means(1:i-1,:))/dble(i-1)
!    	do j=1,npt
!      	dist=sum((lmean(:)-pt(:,j))**2.)
!            if(dist>temp) then
!			temp=dist
!                  x=j
!            end if
!	end do
!	means(i,:)=pt(:,x)
!    end do

!    lmean(:)=means(1,:)
!    do i=1,k/2+1
!    	do
!      	flag=.false.
!    		call ranmarns(urv)
!    		x=int(dble(npt)*urv)+1
!      	do j=1,i-1
!      		if(x==scrap(j)) then
!            		flag=.true.
!                  	exit
!			end if
!		end do
!            if(.not.flag) exit
!	end do
!      scrap(i)=x
!    	means(i*2-1,1:numdim)=pt(1:numdim,x)
!      if(i*2>k) exit
!    	means(i*2,1:numdim)=2.*lmean(1:numdim)-pt(1:numdim,x)
!    end do

    	!choose random points as starting positions
    	do i=1,k
    		do
      			flag=.false.
            		urv=ranmarns(0)
    			x=int(dble(npt)*urv)+1
      			do j=1,i-1
      				if(x==scrap(j)) then
                  			flag=.true.
                        		exit
				endif
			enddo
            		if(flag) then
            			cycle
            		else
            			scrap(i)=x
                  		exit
			endif
		enddo
      		means(i,:)=pt(:,x)
    	enddo

    	old_cluster=0

    	do
    		do i=1,npt
    			temp=huge(1.d0)
			do j=1,k
				dist=sum((means(j,:)-pt(:,i))**2.)
                  		if(dist<temp) then
                  			temp=dist
                        		x=j
                  		endif
			enddo
            		r(i,:)=0
            		r(i,x)=1
			cluster(i)=x
		enddo

		clstrd=.true.
		do i=1,npt
			if(old_cluster(i)/=cluster(i)) then
				clstrd=.false.
				exit
			endif
		enddo

		if(clstrd) then
			!check if all the clusters have more than min_pt points
			do i=1,k
				if(totR(i)<min_pt) then
					dis=1.d99
					i1=min_pt-totR(i)
					do j=1,npt
						if(cluster(j)/=i .and. totR(cluster(j))>min_pt) then
							d1=sum((means(i,:)-pt(:,j))**2.)
							i3=0
							do i2=i1,1,-1
								if(d1<dis(i2,1)) then
									i3=i2
								else
									exit
								endif
							enddo
							if(i3/=0) then
								dis(i3+1:i1,:)=dis(i3:i1-1,:)
								dis(i3,1)=d1
								dis(i3,2)=dble(j)
							endif
						endif
					enddo
					do j=1,i1
						i3=int(dis(j,2))
						i2=cluster(i3)
						cluster(i3)=i
						totR(i)=totR(i)+1
						totR(i2)=totR(i2)-1
						r(i3,:)=0
            					r(i3,i)=1
					enddo
				endif
			enddo
			do i=1,k
				!update means
				do j=1,numdim
					means(i,j)=sum(r(:,i)*pt(j,:))/totR(i)
				enddo
			enddo
			exit
		endif

		old_cluster=cluster

		do i=1,k
			totR(i)=sum(r(:,i))
            		if(totR(i)==0) cycle

			!update means
			do j=1,numdim
				means(i,j)=sum(r(:,i)*pt(j,:))/totR(i)
			enddo
		enddo
    	enddo

  end subroutine kmeans3

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

  !Incremental K-means (Pham, Dimov, Nguyen, 2005)
  subroutine kmeans4(k,pt,npt,numdim,cluster,min_pt)
    implicit none

    integer k,numdim,npt
    double precision pt(:,:)
    double precision means(k,numdim)
    integer cluster(:)
    integer totR(k)
    integer i,j,x,m,min_pt
    logical clstrd
    double precision urv
    double precision distortion(k)!distortion of each cluster
    integer indx(1)

    if(k>npt/min_pt+1) k=npt/min_pt+1
    distortion=0.
    totR=0

    !choose a random point to be the cluster center
    cluster=1
    totR(1)=npt
    do j=1,numdim
    	means(1,j)=sum(pt(j,:))/dble(npt)
    end do

    if(k==1) return

    do m=2,k
    	clstrd=.false.

    	!pick the cluster with the max distortion
      indx=maxloc(distortion(1:m-1))

      !pick a random point from this cluster as new cluster center
      j=0
      urv=ranmarns(0)
    	x=int(dble(totR(indx(1)))*urv)+1
      do i=1,npt
      	if(cluster(i)==indx(1)) j=j+1
            if(j==x) exit
      end do
      means(cluster(i),:)=(means(cluster(i),:)*dble(totR(cluster(i)))-pt(:,i))/dble(totR(cluster(i))-1)
      means(m,:)=pt(:,i)
      totR(cluster(i))=totR(cluster(i))-1
      totR(m)=1
      cluster(i)=m

      do
      	clstrd=.true.

            !check whether each point is closest to its own cluster or to the newly formed
            !one & assign accordingly
            do i=1,npt
            	if(sum((pt(1:numdim,i)-means(cluster(i),1:numdim))**2.)> &
                  sum((pt(1:numdim,i)-means(m,1:numdim))**2.))then
                  	!point moved so not finished yet
                        clstrd=.false.

                        !update cluster data
                        totR(cluster(i))=totR(cluster(i))-1
                        cluster(i)=m
                        totR(m)=totR(m)+1
                  end if
            end do

		!update means & distortion of each cluster
            means=0.
            distortion=0.
            do i=1,npt
                  means(cluster(i),1:numdim)=means(cluster(i),1:numdim)+pt(1:numdim,i)
                  distortion(cluster(i))=distortion(cluster(i))+sum(pt(1:numdim,i)**2.)
            end do
            do j=1,numdim
                  means(1:m,j)=means(1:m,j)/dble(totR(1:m))
                  distortion(1:m)=distortion(1:m)-dble(totR(1:m))*(means(1:m,j)**2.)
            end do

            if(clstrd) exit
	end do
    end do

  end subroutine kmeans4

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

  !2-means with k=2 & clusters placed in their expected positions as the starting points
  subroutine kmeans6(pt,npt,numdim,cluster)
    implicit none

    integer numdim,npt
    double precision pt(numdim,npt)
    double precision means(2,numdim)
    integer cluster(npt)
    integer totR(2)
    integer i,j,x
    logical clstrd
    double precision covmat(numdim,numdim),evec(numdim,numdim),eval(numdim)

    !calculate the mean of the data
    do j=1,numdim
    	means(1,j)=sum(pt(j,1:npt))/dble(npt)
    end do

    !do principal component analysis
    call calc_covmat(npt,numdim,pt,means(1,:),covmat)
    evec=covmat
    call diagonalize(evec,eval,numdim,.false.)

    !place the cluster centers in their ex[ected locations
    means(2,:)=means(1,:)+evec(:,numdim)*sqrt(2.*eval(numdim)/3.1416)
    means(1,:)=means(1,:)-evec(:,numdim)*sqrt(2.*eval(numdim)/3.1416)

    cluster=1
    totR(1)=npt
    totR(2)=0

    do
      clstrd=.true.

	!check whether each point is closest to its own cluster or to the newly formed
	!one & assign accordingly
	do i=1,npt
      	if(cluster(i)==1) then
            	x=2
            else
            	x=1
            end if
            if(sum((pt(1:numdim,i)-means(cluster(i),1:numdim))**2.)> &
            sum((pt(1:numdim,i)-means(x,1:numdim))**2.))then
                  !point moved so not finished yet
                  clstrd=.false.

                  !update cluster data
                  totR(cluster(i))=totR(cluster(i))-1
                  cluster(i)=x
                  totR(x)=totR(x)+1
		end if
	end do

	!update means of each cluster
      means=0.
	do i=1,npt
		means(cluster(i),1:numdim)=means(cluster(i),1:numdim)+pt(1:numdim,i)
	end do
	do j=1,numdim
		means(1:2,j)=means(1:2,j)/dble(totR(1:2))
	end do

	if(clstrd) exit
    end do

  end subroutine kmeans6

!----------------------------------------------------------------------
  !Incremental K-means with Unknown K
  !(Pham, Dimov, Nguyen, 2005, "Incremental K-means Algorithm")
  !(Pham, Dimov, Nguyen, 2005, "Selection of K in K-means Clustering")
  subroutine kmeans5(k,pt,npt,numdim,cluster,min_pt)
    implicit none

    integer k,numdim,npt
    double precision pt(numdim,npt)
    double precision means(2,npt/(numdim+1),numdim),meanst(npt/(numdim+1),numdim)
    double precision mean(npt/(numdim+1),numdim)
    integer cls(2,npt),clst(npt),cluster(npt)
    integer totR(2,npt/(numdim+1)),totRt(npt/(numdim+1))!total points in each cluster
    integer i,j,x,m,min_pt
    logical clstrd
    !distortion of each cluster & total distortion of the recent two iterations
    double precision distortion(2,npt/(numdim+1)),totDistor(2),distor(npt/(numdim+1))
    integer indx(1)
    double precision f(npt/(numdim+1)),fmin,a(npt/(numdim+1))!evaluation function
    double precision S(npt/(numdim+1))!total distortion
    integer count!counter for evaluation function

    if(k>npt/min_pt+1) k=npt/min_pt+1
    distortion=0.
    totR=0
    f=0.
    a=0.
    S=0.
    count=0

    !choose a random point to be the cluster center
    cluster=1
    cls(2,:)=1
    totR(2,1)=npt
    do j=1,numdim
    	means(2,1,j)=sum(pt(j,:))/dble(npt)
      S(1)=S(1)+sum((pt(j,1:npt)-means(2,1,j))**2.)
    end do
    mean(:,:)=means(2,:,:)

    f(1)=1.
    fmin=1.
    k=1

    a(2)=1.-3./dble(4*numdim)
    m=1
    do
    	m=m+1
    	clstrd=.false.

    	!pick the cluster with the max distortion
      indx=maxloc(distortion(2,1:m-1))
      !break this cluster
      clst(:)=cls(2,:)
      totRt(:)=totR(2,:)
      meanst(:,:)=means(2,:,:)
      x=m-1
      j=indx(1)
      call kmeansDis(x,pt,npt,numdim,clst,j,totRt,distor,meanst)
      cls(1,:)=clst(:)
      totR(1,:)=totRt(:)
      means(1,:,:)=meanst(:,:)
      distortion(1,:)=distor(:)
      totDistor(1)=sum(distor(1:m))

      do i=1,m-1
      	if(i==indx(1)) cycle
            if(distortion(2,i)>1.5*(totDistor(2)-totDistor(1))) then
            	clst(:)=cls(2,:)
      		totRt(:)=totR(2,:)
     	 		meanst(:,:)=means(2,:,:)
                  x=m-1
                  call kmeansDis(x,pt,npt,numdim,clst,i,totRt,distor,meanst)
                  if(sum(distor(1:m))<totDistor(1)) then
                  	cls(1,:)=clst(:)
      			totR(1,:)=totRt(:)
      			means(1,:,:)=meanst(:,:)
      			distortion(1,:)=distor(:)
      			totDistor(1)=sum(distor(1:m))
                  end if
            end if
      end do

      !calculate the total distortion
      S(m)=0.
      do i=1,npt
            S(m)=S(m)+sum((pt(1:numdim,i)-means(1,cls(1,i),1:numdim))**2.)
      end do

	!calculate the evaluation function
      f(m)=S(m)/(S(m-1)*a(m))
      a(m+1)=a(m)+(1.-a(m))/6.
      !write(*,*)m,fmin,f(m),f(m-1),a(m)

      if(f(m)<fmin.and.f(m)<0.85) then
      	fmin=f(m)
            cluster(:)=cls(1,:)
            mean(:,:)=means(1,:,:)
            k=m
            count=0
      else
      	count=count+1
      end if

      !if 5 consecutive f values are greater than 0.85 then exit
      if(count==5) exit

      means(2,:,:)=means(1,:,:)
      cls(2,:)=cls(1,:)
      totR(2,:)=totR(1,:)
      distortion(2,:)=distortion(1,:)
      totDistor(2)=totDistor(1)
    end do

    !meanst=mean
    !do i=1,k
      !do j=1,numdim
    		!call Rescale_nest(meanst(i,j),j)
      !end do
    !end do
    !write(*,*)"means",meanst(1:k,:)
    !write(*,*)"fmin=",fmin

  end subroutine kmeans5

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

  !Incremental K-means (Pham, Dimov, Nguyen, 2005) with if npt in any cluster is
  !less than numdim+1 than (numdim+1-npt) closest points borrowed from its closest
  !neighbour cluster
  subroutine kmeans7(k,pt,npt,numdim,cluster,ad,cluster2,min_p)
    implicit none

    integer k,numdim,npt
    double precision pt(:,:)
    double precision means(npt/min_p+10,numdim)
    integer cluster(:)
    integer totR(npt/min_p+10),min_p
    integer i,j,x,m,q,r,k0
    logical clstrd
    double precision urv
    !double precision distortion(k)!distortion of each cluster
    integer indx(1),indx2(1)
    double precision adis(npt)!for keeping a record of the point's distances
    double precision dis1,dis2,dis(npt,2)
    integer ad,nc,cluster2(:,:),cc(npt),cpt(npt)

    !distortion=0.
    means=0.
    totR=0

    !choose a random point to be the cluster center
    cluster=1
    totR(1)=npt
    do j=1,numdim
    	means(1,j)=sum(pt(j,1:npt))/dble(npt)
    end do

    k=min(npt/min_p,k+10)
    if(k<=1) then
    	k=1
      ad=0
      return
    end if
    k0=k

    do m=2,k
    	clstrd=.false.

      !pick the cluster with most points
      indx=maxloc(totR(1:m-1))

      !if all the clusters have less than npt<2(numdim+1) points then exit
      if(totR(indx(1))<2*min_p) then
      	k=m-1
            exit
      end if

      !pick a random point from this cluster as new cluster center
      j=0
      urv=ranmarns(0)
    	x=int(dble(totR(indx(1)))*urv)+1
      do i=1,npt
      	if(cluster(i)==indx(1)) j=j+1
            if(j==x) exit
      end do
      means(cluster(i),:)=(means(cluster(i),:)*dble(totR(cluster(i)))-pt(:,i))/dble(totR(cluster(i))-1)
	means(m,:)=pt(:,i)
      totR(cluster(i))=totR(cluster(i))-1
      totR(m)=1
      cluster(i)=m

      do
      	clstrd=.true.

            !check whether each point is closest to its own cluster or to the newly formed
            !one & assign accordingly
            do i=1,npt
                  	dis1=sum((pt(1:numdim,i)-means(cluster(i),1:numdim))**2)
                        dis2=sum((pt(1:numdim,i)-means(m,1:numdim))**2)
                        adis(i)=dis1-dis2
            end do

            do i=1,numdim
            	means(1:m,i)=means(1:m,i)*dble(totR(1:m))
            end do
            do
            	indx2=maxloc(adis)
                  if(adis(indx2(1))<=0.) then
                  	exit
                  else if(totR(cluster(indx2(1)))<=min_p) then
                  	adis(indx2(1))=-1.
                  else
				!point moved so not finished yet
                        clstrd=.false.
                        !update cluster data
                        totR(cluster(indx2(1)))=totR(cluster(indx2(1)))-1
                       	means(cluster(indx2(1)),1:numdim)=means(cluster(indx2(1)),1:numdim)-pt(1:numdim,indx2(1))
                       	cluster(indx2(1))=m
                        totR(m)=totR(m)+1
                        means(m,1:numdim)=means(m,1:numdim)+pt(1:numdim,indx2(1))
                        adis(indx2(1))=-1.
                  end if
		end do

		!update means
            do j=1,numdim
                  means(1:m,j)=means(1:m,j)/dble(totR(1:m))
            end do

            !if num of points in the newly formed cluster are less than
            !(numdim+1) then borrow closest points from cluster from which the new cluster
            !was formed
            if(clstrd.and.(totR(m)<min_p.or.totR(indx(1))<min_p)) then
            	if(totR(m)<min_p) then
                  	x=m
                        q=indx(1)
                  else
                  	x=indx(1)
                        q=m
                  end if

            	adis=1.d99
            	do i=1,npt
                  	if(cluster(i)==q) then
                        	adis(i)=sum((pt(1:numdim,i)-means(x,1:numdim))**2)
                        end if
                  end do

                  means(q,1:numdim)=means(q,1:numdim)*dble(totR(q))
                  means(x,1:numdim)=means(x,1:numdim)*dble(totR(x))

                  do i=1,min_p-totR(x)
                  	indx2=minloc(adis)
                        adis(indx2(1))=1.d99
                        cluster(indx2(1))=x
                        means(q,1:numdim)=means(q,1:numdim)-pt(1:numdim,indx2(1))
                        means(x,1:numdim)=means(x,1:numdim)+pt(1:numdim,indx2(1))
                  end do

                  totR(q)=totR(q)-min_p+totR(x)
                  totR(x)=min_p
                  means(q,1:numdim)=means(q,1:numdim)/dble(totR(q))
                  means(x,1:numdim)=means(x,1:numdim)/dble(totR(x))
            end if

            if(clstrd) exit
	end do
    end do

    !find shared points
    ad=min(ad,npt-1)
    nc=min(k-1,ad)
    cluster2=0
    if(ad==0) return
    do i=1,k
      dis(1:nc,1)=1.d99
    	do j=1,k
      	if(i==j) cycle
         	dis1=sum((means(i,1:numdim)-means(j,1:numdim))**2)
            do r=1,nc
            	if(dis1<dis(r,1)) then
                  	dis(r+1:nc,1)=dis(r:nc-1,1)
                  	dis(r+1:nc,2)=dis(r:nc-1,2)
                        dis(r,1)=dis1
                        dis(r,2)=dble(j)
                        exit
                  end if
		end do
	end do

      cc(1:nc)=int(dis(1:nc,2))

      !make a list of point indices in cluster i
      q=0
      do j=1,npt
      	if(cluster(j)==i) then
                  q=q+1
            	cpt(q)=j
		end if
            if(q==totR(i)) exit
	end do

      !adis=1.d99
      dis(1:ad,1)=1.d99
      do j=1,npt
		do r=1,nc
                  if(cluster(j)==cc(r)) then
                  	do q=1,totR(i)
                        	dis1=sum((pt(1:numdim,cpt(q))-pt(1:numdim,j))**2)
                        	do k0=1,ad
                              	if(dis(k0,1)>dis1) then
            					dis(k0+1:ad,1)=dis(k0:ad-1,1)
                  				dis(k0+1:ad,2)=dis(k0:ad-1,2)
                        			dis(k0,1)=dis1
                        			dis(k0,2)=dble(j)
                                          exit
            				end if
					end do
                        end do
                        exit
                  end if
            end do
	end do

      cluster2(i,1:ad)=int(dis(1:ad,2))
    end do

  end subroutine kmeans7

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

  !Incremental K-means (Pham, Dimov, Nguyen, 2005) with if npt in any cluster is
  !less than numdim+1 than (numdim+1-npt) closest points borrowed from its closest
  !neighbour cluster
  subroutine sKmeans(k,pt,npt,numdim,cluster,min_p)
	implicit none

    	integer k,numdim,npt
    	double precision pt(:,:)
    	double precision means(npt/min_p+10,numdim)
    	integer cluster(npt)
    	integer totR(npt/min_p+10),min_p
    	integer i,j,x,m,q,k0
    	logical clstrd
    	double precision urv
    	integer indx(1),indx2(1)
    	double precision adis(npt)!for keeping a record of the point's distances
    	double precision dis1,dis2

	means=0.
    	totR=0

    	!choose a random point to be the cluster center
    	cluster=1
    	totR(1)=npt
    	do j=1,numdim
    		means(1,j)=sum(pt(j,1:npt))/dble(npt)
    	end do

    	k=min(npt/min_p,k+10)
    	if(k<=1) then
    		k=1
      	return
    	end if
    	k0=k

    	do m=2,k
    		clstrd=.false.

      		!pick the cluster with most points
      		indx=maxloc(totR(1:m-1))

      		!if all the clusters have less than npt<2(numdim+1) points then exit
      		if(totR(indx(1))<2*min_p) then
      			k=m-1
            		exit
      		endif

      		!pick a random point from this cluster as new cluster center
      		j=0
      		urv=ranmarns(0)
    		x=int(dble(totR(indx(1)))*urv)+1
      		do i=1,npt
      			if(cluster(i)==indx(1)) j=j+1
            		if(j==x) exit
      		enddo
      		means(cluster(i),:)=(means(cluster(i),:)*dble(totR(cluster(i)))-pt(:,i))/dble(totR(cluster(i))-1)
		means(m,:)=pt(:,i)
      		totR(cluster(i))=totR(cluster(i))-1
      		totR(m)=1
      		cluster(i)=m

      		do
      			clstrd=.true.

            		!check whether each point is closest to its own cluster or to the newly formed
            		!one & assign accordingly
            		do i=1,npt
                  		dis1=sum((pt(1:numdim,i)-means(cluster(i),1:numdim))**2)
                        	dis2=sum((pt(1:numdim,i)-means(m,1:numdim))**2)
                        	adis(i)=dis1-dis2
            		enddo

			do i=1,numdim
            			means(1:m,i)=means(1:m,i)*dble(totR(1:m))
            		enddo
            		do
            			indx2=maxloc(adis)
                  		if(adis(indx2(1))<=0.) then
                  			exit
                  		elseif(totR(cluster(indx2(1)))<=min_p) then
                  			adis(indx2(1))=-1.
                  		else
					!point moved so not finished yet
                        		clstrd=.false.
                        		!update cluster data
                        		totR(cluster(indx2(1)))=totR(cluster(indx2(1)))-1
                       			means(cluster(indx2(1)),1:numdim)=means(cluster(indx2(1)),1:numdim)-pt(1:numdim,indx2(1))
                       			cluster(indx2(1))=m
                        		totR(m)=totR(m)+1
                        		means(m,1:numdim)=means(m,1:numdim)+pt(1:numdim,indx2(1))
                        		adis(indx2(1))=-1.
                  		endif
			enddo

			!update means
            		do j=1,numdim
                  		means(1:m,j)=means(1:m,j)/dble(totR(1:m))
            		enddo

            		!if num of points in the newly formed cluster are less than
            		!(numdim+1) then borrow closest points from cluster from which the new cluster
            		!was formed
            		if(clstrd.and.(totR(m)<min_p.or.totR(indx(1))<min_p)) then
            			if(totR(m)<min_p) then
                  			x=m
                        		q=indx(1)
                  		else
                  			x=indx(1)
                        		q=m
                  		endif

            			adis=1.d99
            			do i=1,npt
                  			if(cluster(i)==q) then
                        			adis(i)=sum((pt(1:numdim,i)-means(x,1:numdim))**2)
                        		endif
                  		enddo

                  		means(q,1:numdim)=means(q,1:numdim)*dble(totR(q))
                  		means(x,1:numdim)=means(x,1:numdim)*dble(totR(x))

                  		do i=1,min_p-totR(x)
                  			indx2=minloc(adis)
                        		adis(indx2(1))=1.d99
                        		cluster(indx2(1))=x
                        		means(q,1:numdim)=means(q,1:numdim)-pt(1:numdim,indx2(1))
                        		means(x,1:numdim)=means(x,1:numdim)+pt(1:numdim,indx2(1))
                  		enddo

                  		totR(q)=totR(q)-min_p+totR(x)
                  		totR(x)=min_p
                  		means(q,1:numdim)=means(q,1:numdim)/dble(totR(q))
                  		means(x,1:numdim)=means(x,1:numdim)/dble(totR(x))
            		endif

            		if(clstrd) exit
		enddo
    	enddo

  end subroutine sKmeans

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

  !soft k-means corresponding to the model of arbitrary Gaussians
  subroutine kmeans8(k,pt,npt,numdim,means,Covmat,cluster,min_pt)
    implicit none

    integer k,numdim,npt
    double precision pt(numdim,npt)
    double precision means(k,numdim),wt(k),r(npt,k)
    integer cluster(npt),min_pt
    double precision sumr,totR(k),temp,covmat(k,numdim,numdim),mean(numdim)
    integer i,j,indx(1),x,nochg,count,q
    logical clstrd
    double precision urv

    if(k>npt/min_pt+1) k=npt/min_pt+1
    clstrd=.false.
    nochg=0
    count=0

    do i=1,numdim
    	mean(i)=sum(pt(i,1:npt))/dble(npt)
    end do

    call calc_covmat(npt,numdim,pt,mean,covmat(1,1:numdim,1:numdim))
    do i=2,k
    	covmat(i,:,:)=covmat(1,:,:)
    end do

    do i=1,k
      wt(i)=ranmarns(0)
      urv=ranmarns(0)
      x=int(dble(npt)*urv)+1
    	means(i,:)=pt(:,x)
    end do
    temp=sum(wt)
    wt=wt/temp

    do
    	count=count+1
      clstrd=.true.
    	do i=1,npt
		do j=1,k
			r(i,j)=wt(j)*mNormalF(numdim,pt(:,i),means(j,:),Covmat(j,:,:))
		end do
		sumr=sum(r(i,:))
		r(i,:)=r(i,:)/sumr
		indx=maxloc(r(i,:))
            if(cluster(i)/=indx(1)) clstrd=.false.
		cluster(i)=indx(1)
	end do

	if(clstrd) then
		nochg=nochg+1
		if(nochg==2) exit
	else
		nochg=0
	end if

	do i=1,k
		totR(i)=sum(r(:,i))

		!update means
		do j=1,numdim
			means(i,j)=sum(r(:,i)*pt(j,:))/totR(i)
		end do
            !update the covariance matrix
            do q=1,numdim
            	do j=q,numdim
            		Covmat(i,q,j)=sum(r(:,i)*pt(q,:)*pt(j,:))/totR(i)-means(i,q)*means(i,j)
			end do
                  if(q/=j) Covmat(i,j,q)=Covmat(i,q,j)
		end do
	end do

	!update weights
	temp=sum(totR(:))
	wt(:)=totR(:)/temp
    end do

  end subroutine kmeans8

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

  !Dinosaur clustering
  function Dmeans(k,pt,npt,like,ndim,cluster,min_pt,nptk,meank,covmatk,invcovk,tmatk,evalk,eveck,kfack,effk, &
  detcovk,volk,pVol,fVol,cSwitch,nCdim)
    implicit none

    !input variables
    integer k !no. of clusters required
    integer npt !no. of points
    double precision like(npt) !scaled log-like
    integer ndim !dimensionality
    double precision pt(ndim,npt) !points
    integer min_pt !min no. of points allowed in a cluster
    double precision pVol !prior volume
    logical cSwitch
    integer nCdim

    !input/output variables
    integer nptk(k) !input: no. of points in each of k-1 clusters, output: no. of points in each of k clusters
    integer cluster(npt) !input: cluster membership of each point for k-1 clusters,
    		    !output: cluster membership of each point for k clusters
    double precision meank(k,ndim) !input: means of k-1 clusters, output: means of k clusters
    double precision covmatk(k,ndim,ndim) !input: covmat of k-1 clusters, output: covmat of k clusters
    double precision invcovk(k,ndim,ndim) !input: invcov of k-1 clusters, output: invcov of k clusters
    double precision tmatk(k,ndim,ndim) !input: tmat of k-1 clusters, output: tmat of k clusters
    double precision evalk(k,ndim) !input: eval of k-1 clusters, output: eval of k clusters
    double precision eveck(k,ndim,ndim) !input: evec of k-1 clusters, output: evec of k clusters
    double precision kfack(k) !input: kfac of k-1 clusters, output: kfac of k clusters
    double precision effk(k) !input: eff of k-1 clusters, output: eff of k clusters
    double precision detcovk(k) !input: detcov of k-1 clusters, output: detcov of k clusters
    double precision volk(k) !input: vol of k-1 clusters, output: vol of k clusters
    double precision fVol !volume of the father ellipsoid

    !output variables
    integer Dmeans !0 if found a better partition, 1 if found a partition but not better, 2 if couldn't partition

    !work variables
    integer i,j,x,i1,i2,indx(1),count,gcount,cls(2)
    double precision, allocatable :: h(:,:),mdis(:,:),ptk(:,:),mu_tmp(:,:)
    double precision d1,d2
    logical flag
    logical, allocatable :: doCal(:), broken(:)
    !ellipsoid properties
    integer, allocatable :: nptx(:), clusterx(:),cluster2(:)
    double precision, allocatable :: meanx(:,:),covmatx(:,:,:),invcovx(:,:,:),tmatx(:,:,:),evalx(:,:)
    double precision, allocatable :: evecx(:,:,:),kfacx(:),effx(:),detcovx(:),volx(:)

    !sanity check
    if(npt<min_pt*k) then
    	Dmeans=2
	return
    endif

    allocate( h(k,npt), mdis(k,npt), ptk(ndim+1,npt), mu_tmp(2,ndim+1), meanx(k,ndim), covmatx(k,ndim,ndim), &
    invcovx(k,ndim,ndim), tmatx(k,ndim,ndim), evalx(k,ndim), evecx(k,ndim,ndim), kfacx(k),effx(k), detcovx(k), volx(k) )
    allocate( doCal(k), broken(k) )
    allocate( nptx(k), clusterx(npt), cluster2(npt) )

    !initialization
    nptx=nptk
    clusterx=cluster
    meanx=meank
    covmatx=covmatk
    invcovx=invcovk
    tmatx=tmatk
    evalx=evalk
    evecx=eveck
    kfacx=kfack
    effx=effk
    detcovx=detcovk
    volx=volk
    gcount=1
    broken=.false.

    do
    	flag=.false.
    	!first find the ellipsoid with most fractional wastage
    	d2=-1.d99
    	do i=1,k-1
    		if(broken(i)) cycle
    		d1=(volx(i)-pVol*nptx(i)/npt)/(pVol*nptx(i)/npt)
		if(d1>d2) then
			flag=.true.
			d2=d1
			j=i
		endif
    	enddo

    	!if none of the ellipsoids can be split then return
    	if(.not.flag) exit

    	broken(j)=.true.

	!split ellipsoid j
	i1=0
	do i=1,npt
		if(clusterx(i)==j) then
			i1=i1+1
			if(cSwitch) then
				ptk(1:nCdim,i1)=pt(1:nCdim,i)
				ptk(nCdim+1,i1)=like(i)
			else
				ptk(1:ndim,i1)=pt(1:ndim,i)
				ptk(ndim+1,i1)=like(i)
			endif
		endif
	enddo

	i2=2
!	if(cSwitch) then
!		call Kmeans3(i2,ptk(1:nCdim+1,1:i1),i1,nCdim+1,mu_tmp(:,1:nCdim+1),cluster2(1:i1),min_pt)
!	else
!		call Kmeans3(i2,ptk(1:ndim+1,1:i1),i1,ndim+1,mu_tmp(:,1:ndim+1),cluster2(1:i1),min_pt)
!	endif
	if(cSwitch) then
		call Kmeans3(i2,ptk(1:nCdim,1:i1),i1,nCdim,mu_tmp(:,1:nCdim),cluster2(1:i1),min_pt)
	else
		call Kmeans3(i2,ptk(1:ndim,1:i1),i1,ndim,mu_tmp(:,1:ndim),cluster2(1:i1),min_pt)
	endif

	!separate out the points
	nptx(j)=0
	nptx(k)=0
	i2=1
	do i=1,i1
		do x=i2,npt
			if(clusterx(x)==j) then
				if(cluster2(i)==1) then
					clusterx(x)=j
					nptx(j)=nptx(j)+1
				else
					clusterx(x)=k
					nptx(k)=nptx(k)+1
				endif
				i2=x+1
				exit
			endif
		enddo
	enddo

	cls(1)=j
	cls(2)=k
	do i2=1,2
		x=0
		!separate out the points
		do i=1,npt
			if(clusterx(i)==cls(i2)) then
				x=x+1
				ptk(1:ndim,x)=pt(1:ndim,i)
			endif
		enddo
		!min volume this ellipsoid should occupy
		d1=pVol*x/npt
		!calculate the ellipsoid properties
		call CalcEllProp(x,ndim,ptk(1:ndim,1:x),meanx(cls(i2),:),covmatx(cls(i2),:,:), &
		invcovx(cls(i2),:,:),tmatx(cls(i2),:,:),evecx(cls(i2),:,:),evalx(cls(i2),:),detcovx(cls(i2)),kfacx(cls(i2)), &
		effx(cls(i2)),volx(cls(i2)),d1,.false.)
	enddo

	!find if it's a better partition
!	if(nptx(j)<min_pt .or. nptx(k)<min_pt) then
!		count=0
!		Dmeans=2
!	else
		count=1
		if(gcount==1) then
			!save the best partition
			nptk=nptx
    			cluster=clusterx
    			meank=meanx
    			covmatk=covmatx
   			invcovk=invcovx
   			tmatk=tmatx
    			evalk=evalx
    			eveck=evecx
    			kfack=kfacx
   			effk=effx
    			detcovk=detcovx
    			volk=volx
		endif
		if(sum(volx(1:k))<fVol) then
			Dmeans=0
		else
			Dmeans=1
		endif
!	endif

    	doCal=.true.

	!calculate the distance measure
!    	do i=1,k
!		do j=1,npt
!			mdis(i,j)=MahaDis(ndim,pt(:,j),meanx(i,:),invcovx(i,:,:),kfacx(i)*effx(i))
!		enddo
!    	enddo

    	do
    		gcount=gcount+1
		!calculate the distance measure
    		do i=1,k
    			if(.not.doCal(i)) cycle
			do j=1,npt
				mdis(i,j)=MahaDis(ndim,pt(:,j),meanx(i,:),invcovx(i,:,:),kfacx(i)*effx(i))
				h(i,j)=volx(i)*mdis(i,j)/nptx(i)
			enddo
    		enddo

!		do x=1,npt
!			i=clusterx(x) !cluster in which point x lies
!
!			if(doCal(i)) mdis(x,i)=MahaDis(ndim,pt(:,x),meanx(i,:),invcovx(i,:,:),kfacx(i)*effx(i))
!			d2=kfacx(i)*effx(i)
!			d1=(((nptx(i)/(nptx(i)-1.d0))**3)*(1.d0-mdis(x,i)/(nptx(i)-1.d0))-1.d0)*sqrt(detcovx(i)*(d2**(ndim)))/ &
!    				(((nptx(i)/(nptx(i)-1.d0))**1.5d0)*sqrt(1.d0-mdis(x,i)/(nptx(i)-1.d0))+1.d0)
!
!			do j=1,k
!				if(j==i) then
!					h(j,x)=0.d0
!				else
!					if(doCal(j)) mdis(x,j)=MahaDis(ndim,pt(:,x),meanx(j,:),invcovx(j,:,:),kfacx(j)*effx(j))
!					d2=kfacx(j)*effx(j)
!					h(j,x)=(((nptx(j)/(nptx(j)+1.d0))**3)*(1.d0+mdis(x,j)/(nptx(j)+1.d0))-1.d0)*sqrt(detcovx(j)*(d2**(ndim)))/ &
!    						(((nptx(j)/(nptx(j)+1.d0))**1.5d0)*(sqrt(1.d0+mdis(x,j)/(nptx(j)+1.d0)))+1.d0)
!					h(j,x)=(h(j,x)+d1)!/dble(nptx(i)+nptx(j))
!				endif
!			enddo
!    		enddo

    		!now assign point j to the ellipsoid i such that h(i,j) is min
    		flag=.false.
    		do j=1,npt
    			indx=minloc(h(1:k,j))
			if(clusterx(j)/=indx(1)) then
				doCal(clusterx(j))=.true.
				doCal(indx(1))=.true.
				flag=.true.
				nptx(clusterx(j))=nptx(clusterx(j))-1
				nptx(indx(1))=nptx(indx(1))+1
				clusterx(j)=indx(1)
			endif
    		enddo

		!if a cluster has less than min_pt points then kill it
		if(flag) then
			do j=1,k
				if(nptx(j)<min_pt) then
					do i1=1,npt
						if(clusterx(i1)==j) then
							h(j,i1)=1.d99
							indx=minloc(h(1:k,i1))
							doCal(indx(1))=.true.
							nptx(j)=nptx(j)-1
							nptx(indx(1))=nptx(indx(1))+1
							clusterx(i1)=indx(1)
						endif
					enddo
					doCal(j)=.false.
					mdis(j,1:npt)=1.d99
					volx(j)=0.d0
					kfacx(j)=0.d0
					evalx(j,:)=0.d0
				endif
			enddo
			exit
		endif

		if(.not.flag) then
			!no point reassigned
			!check if clustering resulted in the new cluster having more than min_pt points
			if(nptx(k)>0 .and. nptx(k)<npt) then
				!check the boundary point of each ellipsoid
				do i=1,k
					if(nptx(i)==min_pt) cycle

					!find the boundary point
					d1=0.d0
					do j=1,npt
						if(clusterx(j)==i) then
							if(mdis(i,j)>d1) then
								d1=mdis(i,j)
								i1=j
							endif
						endif
					enddo

					!now calculate delF for all the other ellipsoids
					do j=1,k
						if(i==j .or. nptx(j)==0) cycle
						d1=kfacx(i)*effx(i)
						d2=kfacx(j)*effx(j)
						if(delF(ndim,nptx(i),nptx(j),mdis(i,i1),mdis(j,i1),detcovx(i), &
						detcovx(j),d1,d2)<0.) then
							doCal(i)=.true.
							doCal(j)=.true.
							flag=.true.
							nptx(i)=nptx(i)-1
							nptx(j)=nptx(j)+1
							clusterx(i1)=j
							exit
						endif
					enddo
					if(flag) exit
				enddo
			endif
		endif

		if(flag) then
			!point reassigned, recalculate the ellipsoid properties
			count=count+1
			!if no better partition found in the past 5 iterations then return
			if(count==20) exit
			if(nptx(k)>0 .and. nptx(k)<npt) then
				do i=1,k
					if(.not.doCal(i)) cycle
					i1=0
					do j=1,npt
						if(clusterx(j)==i) then
							i1=i1+1
							ptk(1:ndim,i1)=pt(1:ndim,j)
						endif
					enddo
					d1=pVol*dble(i1)/dble(npt)
					call CalcEllProp(i1,ndim,ptk(1:ndim,1:i1),meanx(i,:),covmatx(i,:,:), &
						invcovx(i,:,:),tmatx(i,:,:),evecx(i,:,:),evalx(i,:),detcovx(i),kfacx(i), &
						effx(i),volx(i),d1,.false.)
				enddo
				!check if this resulted in a better partition
				if(sum(volx(1:k))<sum(volk(1:k))) then
					!reset the counter
					count=0
					!save the best partition
					nptk=nptx
    					cluster=clusterx
    					meank=meanx
    					covmatk=covmatx
	    				invcovk=invcovx
    					tmatk=tmatx
    					evalk=evalx
    					eveck=evecx
    					kfack=kfacx
	    				effk=effx
    					detcovk=detcovx
    					volk=volx

					if(sum(volx(1:k))<fVol) then
						Dmeans=0
						if(abs(sum(volx(1:k))-pVol)/pVol<0.01) return
					else
						Dmeans=1
					endif
				endif
			endif
		else
			exit
		endif
	enddo
	if(Dmeans==0) exit
    enddo

    deallocate( h, mdis, ptk, mu_tmp, meanx, covmatx, invcovx, tmatx, evalx, evecx, kfacx, effx, detcovx, volx )
    deallocate( doCal, broken )
    deallocate( nptx, clusterx, cluster2 )

  end function Dmeans

!----------------------------------------------------------------------
  !calculate the variation in weighted average of e-tightness functions of 2
  !components for re-assigning a point from component 1 to 2
  !Choi, Wang & Kim, Eurographics 2007, vol. 26, No. 3
  function delF(ndim,n1,n2,mdis1,mdis2,detcov1,detcov2,kfac1,kfac2)
    implicit none

    !input variables
    integer ndim !dinemsionality
    integer n1,n2 !no. of points in each ellipsoid
    double precision mdis1,mdis2 !Mahalanobis distance of the point from both ellipsoids
    double precision detcov1,detcov2 !determinant of the covariance matrices of the ellipsoids
    double precision kfac1,kfac2 !overall enlargement factors of the ellipsoids

    !output variables
    double precision delF

    delF=(((n1/(n1-1.))**3)*(1.-mdis1/(n1-1.))-1.)*sqrt(detcov1*(kfac1**(ndim)))/ &
    	(((n1/(n1-1.))**1.5)*sqrt(1.-mdis1/(n1-1.))+1.)
    delF=delF+(((n2/(n2+1.))**3)*(1.+mdis2/(n2+1.))-1.)*sqrt(detcov2*(kfac2**(ndim)))/ &
    	(((n2/(n2+1.))**1.5)*(sqrt(1.+mdis2/(n2+1.)))+1.)

    delF=delF/(dble(n1+n2))

  end function delF

!----------------------------------------------------------------------
  !Incremental K-means with a given cluster 'm' to be split, returns means & distortions
  !(Pham, Dimov, Nguyen, 2005, "Incremental K-means Algorithm")
  !(Pham, Dimov, Nguyen, 2005, "Selection of K in K-means Clustering")
  subroutine kmeansDis(k,pt,npt,numdim,cluster,m,totR,distortion,means)
    implicit none

    integer k,numdim,npt
    double precision pt(numdim,npt)
    double precision means(:,:)
    integer cluster(npt)
    integer totR(:)!total points in each cluster
    integer m!cluster to be split
    integer i,j,x
    logical clstrd
    double precision urv
    double precision distortion(:)!distortion of each cluster

    if(k==0) then
    	cluster=1
    	do j=1,numdim
    		means(1,j)=sum(pt(j,:))/dble(npt)
    	end do
     	return
    end if

    clstrd=.false.

    !pick a random point from the cluster to be split as new cluster center
    j=0
    urv=ranmarns(0)
    x=int(dble(totR(m))*urv)+1
    do i=1,npt
      if(cluster(i)==m) j=j+1
	if(j==x) exit
    end do
    means(k+1,1:numdim)=pt(1:numdim,i)

    do
      clstrd=.true.

      !check whether each point is closest to its own cluster or to the newly formed
      !one & assign accordingly
      do i=1,npt
		if(sum((pt(1:numdim,i)-means(cluster(i),1:numdim))**2)> &
            sum((pt(1:numdim,i)-means(k+1,1:numdim))**2))then
			!point moved so not finished yet
			clstrd=.false.

			!update cluster data
                  totR(cluster(i))=totR(cluster(i))-1
			cluster(i)=k+1
			totR(k+1)=totR(k+1)+1
		end if
	end do

	!update means & distortion of each cluster
	means=0.
	distortion=0.
	do i=1,npt
		means(cluster(i),1:numdim)=means(cluster(i),1:numdim)+pt(1:numdim,i)
		distortion(cluster(i))=distortion(cluster(i))+sum(pt(1:numdim,i)**2)
	end do
	do j=1,numdim
		means(1:k+1,j)=means(1:k+1,j)/dble(totR(1:k+1))
		distortion(1:k+1)=distortion(1:k+1)-dble(totR(1:k+1))*(means(1:k+1,j)**2)
	end do

	if(clstrd) exit
    end do

  end subroutine kmeansDis

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

  subroutine cal_means(numdim,npt,p,mean)
    implicit none
    integer numdim,npt
    double precision p(numdim,npt)
    double precision mean(numdim)
    integer i,j

    mean=0.
    do i=1,numdim
       do j=1,npt
          mean(i)=mean(i)+p(i,j)
       end do
       mean(i)=mean(i)/dble(npt)
    end do

    return

  end subroutine cal_means

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

end module kmeans_clstr


PROGRAM example

use LDC3

 implicit none

 REAL(8), DIMENSION(3) :: alphas, c, alphas_inv
 LOGICAL :: passed

 ! Generate random alpha values
 call random_flat(3,alphas)
 write(*,*) ' '
 write(*,*) 'Generating random alpha vector:'
 write(*,*) 'alpha_h = ',alphas(1)
 write(*,*) 'alpha_r = ',alphas(2)
 write(*,*) 'alpha_t = ',alphas(3)
 write(*,*) ' '

 ! Calculate the corresponding LDCs
 write(*,*) 'Converting alpha vector -> LDCs vector:'
 call forward(alphas(1),alphas(2),alphas(3),c(1),c(2),c(3))
 write(*,*) 'c_2 = ',c(1)
 write(*,*) 'c_3 = ',c(2)
 write(*,*) 'c_4 = ',c(3)

 ! Test if the LDCs satisfy the seven analytic criteria
 call criteriatest(.TRUE.,c(1),c(2),c(3),passed)
 IF ( passed ) THEN
   write(*,*) 'LDCs satisfy the 7 analytic criteria => physically valid'
   write(*,*) ' '
 ELSE
   write(*,*) 'LDCs violate one or more of the 7 analytic criteria'
   write(*,*) ' '
 END IF

 ! Invert LDCs back to alphas
 write(*,*) 'Converting LDCs vector -> alpha vector:'
 call inverse(c(1),c(2),c(3),alphas_inv(1),alphas_inv(2),alphas_inv(3))
 write(*,*) 'alpha_h_inv = ',alphas_inv(1)
 write(*,*) 'alpha_r_inv = ',alphas_inv(2)
 write(*,*) 'alpha_t_inv = ',alphas_inv(3)
 write(*,*) ' '

CONTAINS

! ==============================================================================
SUBROUTINE random_flat(n,r)

 INTEGER i, n
 DOUBLE PRECISION seeda, r(n)

 call random_seed()
 DO i=1,n
   call random_number(seeda)
   r(i)=seeda
 END DO

END SUBROUTINE random_flat
! ==============================================================================

END PROGRAM example


      SUBROUTINE MNBRAK(AX,BX,CX,FA,FB,FC,FUNC)
      PARAMETER (GOLD=1.618034, GLIMIT=100., TINY=1.E-20)
      FA=FUNC(AX)
      FB=FUNC(BX)
      IF(FB.GT.FA)THEN
        DUM=AX
        AX=BX
        BX=DUM
        DUM=FB
        FB=FA
        FA=DUM
      ENDIF
      CX=BX+GOLD*(BX-AX)
      FC=FUNC(CX)
1     IF(FB.GE.FC)THEN
        R=(BX-AX)*(FB-FC)
        Q=(BX-CX)*(FB-FA)
        U=BX-((BX-CX)*Q-(BX-AX)*R)/(2.*SIGN(MAX(ABS(Q-R),TINY),Q-R))
        ULIM=BX+GLIMIT*(CX-BX)
        IF((BX-U)*(U-CX).GT.0.)THEN
          FU=FUNC(U)
          IF(FU.LT.FC)THEN
            AX=BX
            FA=FB
            BX=U
            FB=FU
            GO TO 1
          ELSE IF(FU.GT.FB)THEN
            CX=U
            FC=FU
            GO TO 1
          ENDIF
          U=CX+GOLD*(CX-BX)
          FU=FUNC(U)
        ELSE IF((CX-U)*(U-ULIM).GT.0.)THEN
          FU=FUNC(U)
          IF(FU.LT.FC)THEN
            BX=CX
            CX=U
            U=CX+GOLD*(CX-BX)
            FB=FC
            FC=FU
            FU=FUNC(U)
          ENDIF
        ELSE IF((U-ULIM)*(ULIM-CX).GE.0.)THEN
          U=ULIM
          FU=FUNC(U)
        ELSE
          U=CX+GOLD*(CX-BX)
          FU=FUNC(U)
        ENDIF
        AX=BX
        BX=CX
        CX=U
        FA=FB
        FB=FC
        FC=FU
        GO TO 1
      ENDIF
      RETURN
      END


!***************************************************************************************************
!>Subroutine initialMeshUniform():
!The subroutine creates meshes and sectors, and establishes the mapping relationship among meshes, sectors and processes.
!Each process is divided into eight sectors.
!NOTE: Each sector should have at least two meshes per dimension (x, y, z dimension).
!***************************************************************************************************
subroutine initialMesh()
	use mod_constants
	use mod_globalVariables
	use mod_structures

	implicit none
	include 'mpif.h'

	integer :: status(MPI_STATUS_SIZE), i, j, k, dir, localElem
	double precision :: length
	integer :: x, y, z, numXmin,numXmax,numYmin,numYmax,numZmin,numZmax	!used to determine numxLocal, numyLocal, numzLocal
	double precision :: tempCenter(6)

	length=meshLength
	numTotal=numx*numy*numz	!total cell in the system
	systemVol = dble(numTotal)*length**3d0

	!The  boundary coordinates of the system (xmin,xmax,ymin,ymax,zmin,zmax)
	do i=1,5,2
		myProc%globalCoord(i)=0d0
	end do
	myProc%globalCoord(2)=length*dble(numx)
	myProc%globalCoord(4)=length*dble(numy)
	myProc%globalCoord(6)=length*dble(numz)

	!The  boundary coordinates of the processor (xmin,xmax,ymin,ymax,zmin,zmax)
	myProc%localCoord(1)=dble(myProc%coords(1))*myProc%globalCoord(2)/dble(dims(1))    !<xmin
	myProc%localCoord(2)=myProc%localCoord(1)+myProc%globalCoord(2)/dble(dims(1))
	myProc%localCoord(3)=dble(myProc%coords(2))*myProc%globalCoord(4)/dble(dims(2))
	myProc%localCoord(4)=myProc%localCoord(3)+myProc%globalCoord(4)/dble(dims(2))
	myProc%localCoord(5)=dble(myProc%coords(3))*myProc%globalCoord(6)/dble(dims(3))
	myProc%localCoord(6)=myProc%localCoord(5)+myProc%globalCoord(6)/dble(dims(3))

	totalVolume=(myProc%localCoord(2)-myProc%localCoord(1))*(myProc%localCoord(4)-myProc%localCoord(3))*&
			(myProc%localCoord(6)-myProc%localCoord(5))

	!numxLocal, numyLocal, numzLocal are used to determine the size of the mesh inside the local processor.
	numxLocal=0
	numyLocal=0
	numzLocal=0

	!get numxLocal
	if(myProc%localCoord(1)==myProc%globalCoord(1) .AND. myProc%localCoord(2)==myProc%globalCoord(2)) then
		numXmin=0
		numXmax=numx
		numxLocal=numx
		tempCenter(1)=length/2d0
		tempCenter(2)=myProc%globalCoord(2)-length/2d0

	else if(myProc%localCoord(1)==myProc%globalCoord(1)) then	!at xmin

		numXmin=0
		numXmax = myProc%localCoord(2)/(length/2d0)
		if((dble(numXmax)*(length/2d0)) <=  myProc%localCoord(2) .AND. myProc%localCoord(2)< (dble(numXmax+1)*(length/2d0))) then
			if(mod(numXmax,2)==0) then
				numXmax = numXmax/2
			else
				numXmax = (numXmax+1)/2
			end if
		end if

		numxLocal=numXmax
		tempCenter(1)=length/2d0
		tempCenter(2)=dble(numXmax)*length-length/2d0

	else if(myProc%localCoord(2)==myProc%globalCoord(2)) then	!at xmax
		numXmin = myProc%localCoord(1)/(length/2d0)
		numXmax=numx
		if((dble(numXmin)*(length/2d0)) <=  myProc%localCoord(1) .AND. myProc%localCoord(1) < (dble(numXmin+1)*(length/2d0))) then
			if(mod(numXmin,2)==0) then
				numXmin = numXmin/2
			else
				numXmin = (numXmin+1)/2
			end if
		end if

		numxLocal=numx-numXmin
		tempCenter(1)=dble(numXmin)*length+length/2d0
		tempCenter(2)=myProc%globalCoord(2)-length/2d0

	else	!in the middle
		numXmin = myProc%localCoord(1)/(length/2d0)
		numXmax = myProc%localCoord(2)/(length/2d0)
		if((dble(numXmin)*(length/2d0)) <=  myProc%localCoord(1) .AND. myProc%localCoord(1) < &
				(dble(numXmin+1)*(length/2d0))) then
			if(mod(numXmin,2)==0) then
				numXmin = numXmin/2
			else
				numXmin = (numXmin+1)/2
			end if
		end if
		if((dble(numXmax)*(length/2d0)) <=  myProc%localCoord(2) .AND. myProc%localCoord(2) < &
				(dble(numXmax+1)*(length/2d0))) then
			if(mod(numXmax,2)==0) then
				numXmax = numXmax/2
			else
				numXmax = (numXmax+1)/2
			end if
		end if

		numxLocal = numXmax-numXmin
		tempCenter(1)=dble(numXmin)*length+length/2d0
		tempCenter(2)=dble(numXmax)*length-length/2d0

	end if

	!get numyLocal
	if(myProc%localCoord(3)==myProc%globalCoord(3) .AND. myProc%localCoord(4)==myProc%globalCoord(4)) then
		numYmin=0
		numYmax=numy
		numyLocal=numy
		tempCenter(3)=length/2d0
		tempCenter(4)=myProc%globalCoord(4)-length/2d0

	else if(myProc%localCoord(3)==myProc%globalCoord(3)) then	!at ymin
		numYmin=0
		numYmax = myProc%localCoord(4)/(length/2d0)
		if((dble(numYmax)*(length/2d0)) <=  myProc%localCoord(4) .AND. myProc%localCoord(4) < (dble(numYmax+1)*(length/2d0))) then
			if(mod(numYmax,2)==0) then
				numYmax = numYmax/2
			else
				numYmax = (numYmax+1)/2
			end if
		end if
		numyLocal=numYmax
		tempCenter(3)=length/2d0
		tempCenter(4)=dble(numYmax)*length-length/2d0

	else if(myProc%localCoord(4)==myProc%globalCoord(4)) then	!at ymax
		numYmin = myProc%localCoord(3)/(length/2d0)
		numYmax=numy
		if((dble(numYmin)*(length/2d0)) <=  myProc%localCoord(3) .AND. myProc%localCoord(3) < (dble(numYmin+1)*(length/2d0))) then
			if(mod(numYmin,2)==0) then
				numYmin = numYmin/2
			else
				numYmin = (numYmin+1)/2
			end if
		end if
		numyLocal=numy-numYmin
		tempCenter(3)=dble(numYmin)*length+length/2d0
		tempCenter(4)=myProc%globalCoord(4)-length/2d0

	else	!in the middle
		numYmin = myProc%localCoord(3)/(length/2d0)
		numYmax = myProc%localCoord(4)/(length/2d0)
		if((dble(numYmin)*(length/2d0)) <=  myProc%localCoord(3) .AND. myProc%localCoord(3) < &
				(dble(numYmin+1)*(length/2d0))) then
			if(mod(numYmin,2)==0) then
				numYmin = numYmin/2
			else
				numYmin = (numYmin+1)/2
			end if
		end if
		if((dble(numYmax)*(length/2d0)) <=  myProc%localCoord(4) .AND. myProc%localCoord(4) < &
				(dble(numYmax+1)*(length/2d0))) then
			if(mod(numYmax,2)==0) then
				numYmax = numYmax/2
			else
				numYmax = (numYmax+1)/2
			end if
		end if
		numyLocal = numYmax-numYmin
		tempCenter(3)=dble(numYmin)*length+length/2d0
		tempCenter(4)=dble(numYmax)*length-length/2d0
	end if

	!get numzLocal
	if(myProc%localCoord(5)==myProc%globalCoord(5) .AND. myProc%localCoord(6)==myProc%globalCoord(6)) then
		numZmin=0
		numZmax=numz
		numzLocal=numz
		tempCenter(5)=length/2d0
		tempCenter(6)=myProc%globalCoord(6)-length/2d0

	else if(myProc%localCoord(5)==myProc%globalCoord(5)) then	!at zmin
		numZmin=0
		numZmax = myProc%localCoord(6)/(length/2d0)
		if((dble(numZmax)*(length/2d0)) <=  myProc%localCoord(6) .AND. myProc%localCoord(6) < (dble(numZmax+1)*(length/2d0))) then
			if(mod(numZmax,2)==0) then
				numZmax = numZmax/2
			else
				numZmax = (numZmax+1)/2
			end if
		end if
		numzLocal=numZmax
		tempCenter(5)=length/2d0
		tempCenter(6)=dble(numZmax)*length-length/2d0

	else if(myProc%localCoord(6)==myProc%globalCoord(6)) then	!at zmax
		numZmin = myProc%localCoord(5)/(length/2d0)
		numZmax=numz
		if((dble(numZmin)*(length/2d0)) <=  myProc%localCoord(5) .AND. myProc%localCoord(5)< (dble(numZmin+1)*(length/2d0))) then
			if(mod(numZmin,2)==0) then
				numZmin = numZmin/2
			else
				numZmin = (numZmin+1)/2
			end if
		end if
		numzLocal=numz-numZmin
		tempCenter(5)=dble(numZmin)*length+length/2d0
		tempCenter(6)=myProc%globalCoord(6)-length/2d0

	else	!in the middle
		numZmin = myProc%localCoord(5)/(length/2d0)
		numZmax = myProc%localCoord(6)/(length/2d0)
		if((dble(numZmin)*(length/2d0)) <=  myProc%localCoord(5) .AND. myProc%localCoord(5) < &
				(dble(numZmin+1)*(length/2d0))) then
			if(mod(numZmin,2)==0) then
				numZmin = numZmin/2
			else
				numZmin = (numZmin+1)/2
			end if
		end if
		if((dble(numZmax)*(length/2d0)) <=  myProc%localCoord(6) .AND. myProc%localCoord(6) < &
				(dble(numZmax+1)*(length/2d0))) then
			if(mod(numZmax,2)==0) then
				numZmax = numZmax/2
			else
				numZmax = (numZmax+1)/2
			end if
		end if
		numzLocal = numZmax-numZmin
		tempCenter(5)=dble(numZmin)*length+length/2d0
		tempCenter(6)=dble(numZmax)*length-length/2d0
	end if

	!this variable is used at various points in SRSCD; lets us know the length fo myMesh(:)
	numCells=numxLocal*numyLocal*numzLocal	!total cells of this processor
	if(myProc%taskid==MASTER) then
		write(*,*) 'numx numy numz', numx, numy, numz
	end if
	!write(*,*) 'proc', myProc%taskid, 'numxLocal numyLocal numzLocal', numxLocal, numyLocal, numzLocal

	!If any processors don't have volume elements in them (too many procs), we create an error message
	if(numCells==0) then
		write(*,*) 'error processors with no volume elements'
		call MPI_ABORT(comm,ierr)
	end if

	!Step 5: Create meshes. And for each volume element in myMesh, assign coordinates and material number (and proc number)
	allocate(myMesh(numCells))
	localElem=0

	do k=1,numzLocal
		do j=1,numyLocal
			do i=1,numxLocal

				localElem=localElem+1

				x = numXmin+i
				y = numYmin+j
				z = numZmin+k

				myMesh(localElem)%coordinates(1)=tempCenter(1)+(i-1)*length
				myMesh(localElem)%coordinates(2)=tempCenter(3)+(j-1)*length
				myMesh(localElem)%coordinates(3)=tempCenter(5)+(k-1)*length
				myMesh(localElem)%material=1
				myMesh(localElem)%proc=myProc%taskid
				myMesh(localElem)%globalCell=(z-1)*numx*numy+(y-1)*numx+x

				myMesh(localElem)%length=length
				myMesh(localElem)%volume=length**3d0

				myMesh(localElem)%numNeighbors=1
				myMesh(localElem)%neighbors=0
				myMesh(localElem)%neighborProcs=-1
				!allocate(myMesh(localElem)%neighbors(6))
				!allocate(myMesh(localElem)%neighborProcs(6))
				!do dir=1,6
				!	myMesh(localElem)%numNeighbors(dir)=1
				!end do
			end do
		end do
	end do

	!Step 3d: assign neighbors and processor numbers for neighbors (connectivity in myMesh) - periodic or free surfaces
	call createMeshConnect(length)

end subroutine

!**************************************************************************************************
!>Subroutine createMeshConnect(length) (periodic boundary conditions or free surface)
!It identifies the mesh and processor of neighboring meshes for each mesh.
!The connectivity scheme is the same as in the global case, but neighboring processor numbers are used here.
!**************************************************************************************************
subroutine createMeshConnect(length)
	use mod_structures
	use mod_globalVariables
	implicit none
	include 'mpif.h'

	double precision, intent(in) :: length
	integer :: cell, localCell, maxElement, maxBndryCells
	integer :: i, dir, tag
	integer, allocatable :: send(:,:,:), recv(:,:)
	integer :: materialBuff(numCells,6)
	integer :: numSend(6)=0, numRecv(6)=0
	integer :: status(MPI_STATUS_SIZE)
	integer :: tempRecv
	double precision :: commTime1, commTime2

	maxBndryCells = numxLocal*numyLocal
	if((numyLocal*numzLocal) > maxBndryCells) then
		maxBndryCells = numyLocal*numzLocal
	end if
	if((numxLocal*numzLocal) > maxBndryCells) then
		maxBndryCells = numxLocal*numzLocal
	end if

	!allocate(send(2, numxLocal*numyLocal*numzLocal,6))
	allocate(send(2, maxBndryCells,6))

	do cell=1,numCells
		!Right (+x)
		if(mod(cell,numxLocal)==0) then !identify cell to the right
			myMesh(cell)%neighborProcs(1)=myProc%procNeighbor(1)
			if(myProc%procNeighbor(1)==-1) then	!+x free surface
				myMesh(cell)%neighbors(1)=0
			else if(myMesh(cell)%neighborProcs(1)==myProc%taskid) then	!+x periodic
				myMesh(cell)%neighbors(1)=cell-numxLocal+1
			else
				numSend(1)=numSend(1)+1			!count the number of items in buffer
				send(1,numSend(1),1)=cell		!localCellID in this processor
				send(2,numSend(1),1)=myMesh(cell)%material	!Material ID number that this element is composed of
			end if
		else
			myMesh(cell)%neighbors(1)=cell+1
			myMesh(cell)%neighborProcs(1)=myProc%taskid
		end if

		!Left (-x)
		if(mod(cell+numxLocal-1,numxLocal)==0) then !identify cell to the left
			myMesh(cell)%neighborProcs(2)=myProc%procNeighbor(2)
			if(myProc%procNeighbor(2)==-1) then	!-x free surface
				myMesh(cell)%neighbors(2)=0
			else if(myMesh(cell)%neighborProcs(2)==myProc%taskid) then
				myMesh(cell)%neighbors(2)=cell+numxLocal-1
			else
				numSend(2)=numSend(2)+1
				send(1,numSend(2),2)=cell
				send(2,numSend(2),2)=myMesh(cell)%material
			end if
		else
			myMesh(cell)%neighbors(2)=cell-1
			myMesh(cell)%neighborProcs(2)=myProc%taskid
		end if

		!Front (+y)
		if(mod(cell,numxLocal*numyLocal) > numxLocal*(numyLocal-1) .OR. mod(cell,numxLocal*numyLocal)==0) then
			myMesh(cell)%neighborProcs(3)=myProc%procNeighbor(3)
			if(myProc%procNeighbor(3)==-1) then
				myMesh(cell)%neighbors(3)=0
			else if(myMesh(cell)%neighborProcs(3)==myProc%taskid) then
				myMesh(cell)%neighbors(3)=cell-(numxLocal*(numyLocal-1))
			else
				numSend(3)=numSend(3)+1
				send(1,numSend(3),3)=cell
				send(2,numSend(3),3)=myMesh(cell)%material
			end if
		else
			myMesh(cell)%neighbors(3)=cell+numxLocal
			myMesh(cell)%neighborProcs(3)=myProc%taskid
		end if

		!Back (-y)
		if(mod(cell,numxLocal*numyLocal) <= numxLocal .AND. (mod(cell, numxLocal*numyLocal) /= 0 &
				.OR. numyLocal==1)) then
			myMesh(cell)%neighborProcs(4)=myProc%procNeighbor(4)
			if(myProc%procNeighbor(4)==-1) then
				myMesh(cell)%neighbors(4)=0
			else if(myMesh(cell)%neighborProcs(4)==myProc%taskid) then
				myMesh(cell)%neighbors(4)=cell+(numxLocal*(numyLocal-1))
			else
				numSend(4)=numSend(4)+1
				send(1,numSend(4),4)=cell
				send(2,numSend(4),4)=myMesh(cell)%material
			end if

		else
			myMesh(cell)%neighbors(4)=cell-numxLocal
			myMesh(cell)%neighborProcs(4)=myProc%taskid
		end if

		!Up (+z)
		if(mod(cell,numxLocal*numyLocal*numzLocal) > numxLocal*numyLocal*(numzLocal-1) &
				.OR. mod(cell, numxLocal*numyLocal*numzLocal)==0) then
			myMesh(cell)%neighborProcs(5)=myProc%procNeighbor(5)
			if(myProc%procNeighbor(5)==-1) then
				myMesh(cell)%neighbors(5)=0
			else if(myMesh(cell)%neighborProcs(5)==myProc%taskid) then
				myMesh(cell)%neighbors(5)=cell-(numxLocal*numyLocal*(numzLocal-1))
			else
				numSend(5)=numSend(5)+1
				send(1,numSend(5),5)=cell
				send(2,numSend(5),5)=myMesh(cell)%material
			end if

		else
			myMesh(cell)%neighbors(5)=cell+numxLocal*numyLocal
			myMesh(cell)%neighborProcs(5)=myProc%taskid
		end if

		!Down (-z)
		if(mod(cell,numxLocal*numyLocal*numzLocal) <= numxLocal*numyLocal &
				.AND. (mod(cell,numxLocal*numyLocal*numzLocal) /= 0 .OR. numzLocal==1)) then
			myMesh(cell)%neighborProcs(6)=myProc%procNeighbor(6)
			if(myProc%procNeighbor(6)==-1) then
				myMesh(cell)%neighbors(6)=0
			else if(myMesh(cell)%neighborProcs(6)==myProc%taskid) then
				myMesh(cell)%neighbors(6)=cell+(numxLocal*numyLocal*(numzLocal-1))
			else
				numSend(6)=numSend(6)+1
				send(1,numSend(6),6)=cell
				send(2,numSend(6),6)=myMesh(cell)%material
			end if

		else
			myMesh(cell)%neighbors(6)=cell-numxLocal*numyLocal
			myMesh(cell)%neighborProcs(6)=myProc%taskid
		end if
	end do

	maxElement=0
	!*******************************************************
	do dir = 1,6
		if(dir == 1 .OR. dir == 2) then			!<x
			numRecv(dir) = numyLocal*numzLocal
		else if(dir == 3 .OR. dir == 4) then	!<y
			numRecv(dir) = numxLocal*numzLocal
		else if(dir == 5 .OR. dir == 6) then	!<z
			numRecv(dir) = numxLocal*numyLocal
		end if
	end do

	do dir = 1,6

		if(mod(dir,2)==0) then
			tag = dir-1
		else
			tag = dir+1
		end if

		if(myProc%procNeighbor(dir) /= myProc%taskid .AND. myProc%procNeighbor(dir) /= -1) then
			commTime1=MPI_WTIME()
			call MPI_SEND(send(1,1,dir),numSend(dir)*2,MPI_INTEGER,myProc%procNeighbor(dir),dir,comm,ierr)
			commTime2=MPI_WTIME()
			commTimeSum=commTime2-commTime1
		end if

		if(myProc%procNeighbor(tag)/=myProc%taskid .AND. myProc%procNeighbor(tag) /= -1) then
			allocate(recv(2,numRecv(tag)))
			commTime1=MPI_WTIME()
			call MPI_RECV(recv,numRecv(tag)*2,MPI_INTEGER,myProc%procNeighbor(tag),dir,comm,status,ierr)
			commTime2=MPI_WTIME()
			commTimeSum=commTime2-commTime1

			do i=1, numRecv(tag)
				localCell=send(1,i,tag)
				myMesh(localCell)%neighbors(tag)=recv(1,i)
				materialBuff(localCell,tag)=recv(2,i)
			end do

			!if(myProc%taskid == 0) then
			!	do i = 1,numRecv(tag)
			!		write(*,*) 'recvDir', tag, 'numRecv', numRecv(tag), 'recvCell', recv(1,i)
			!	end do
			!end if

			deallocate(recv)
		end if
	end do
	deallocate(send)

	!***************************************************************************************************
	!Initializing myGhost with elements that are in neighboring processors that bound this one
	!***************************************************************************************************
	maxElement=0
	do i=1, numCells
		do dir=1, 6
			if(myMesh(i)%neighborProcs(dir) /= myProc%taskid) then	!we are pointing to a different proc
				if(myMesh(i)%neighbors(dir) > maxElement) then		!searching for the max element number in a neighbor
					maxElement=myMesh(i)%neighbors(dir)
				end if
			end if
		end do
	end do

	allocate(myGhost(maxElement,6))	!6 directions, maxElement elements in each direction (more than needed)
	!initialize myGhost with 0 in localNeighbor - signal that myGhost is not attached to anything
	do dir=1,6
		do i=1,maxElement
			myGhost(i,dir)%localNeighbor=0	!default, says that this is not a real element of myGhost.
			myGhost(i,dir)%proc=-10			!default, says that this is not a real element of myGhost.
			myGhost(i,dir)%material=0
			myGhost(i,dir)%length=0d0
			myGhost(i,dir)%volume=0d0
		end do
	end do

	do i=1,numCells
		do dir=1,6
			if(myMesh(i)%neighborProcs(dir) == -1) then										!this is a free surface
				!do nothing
			else if(myMesh(i)%neighborProcs(dir) /= myProc%taskid) then
				myGhost(myMesh(i)%neighbors(dir),dir)%proc=myMesh(i)%neighborProcs(dir)	!set proc # of elements in myGhost
				myGhost(myMesh(i)%neighbors(dir),dir)%length=length						!set length of elements in myGhost
				myGhost(myMesh(i)%neighbors(dir),dir)%volume=length**3d0					!set volume of elements in myGhost (changes with cascade addition)
				myGhost(myMesh(i)%neighbors(dir),dir)%material=materialBuff(i,dir)
				myGhost(myMesh(i)%neighbors(dir),dir)%localNeighbor=i
			end if
		end do
	end do

end subroutine

!***************************************************************************************
!>Function findgNeighborGID(globalID, dir)
!Inputs: globalID, direction
!Output: globalNeighborID of the globalID in the direaction
!***************************************************************************************
integer function findgNeighborGID(globalID, dir)
	use mod_structures
	use mod_globalVariables
	implicit none

	integer, intent(in) :: globalID, dir
	integer :: neighborID

	if(dir==1) then	!+x
		if(mod(globalID,numx)==0) then !identify cell to the right
			if(periods(1) .eqv. .true.) then	!periodic
				neighborID=globalID-numx+1
			else	!free surface
				neighborID=0
			end if
		else
			neighborID=globalID+1
		end if
	else if(dir==2) then
		if(mod(globalID+numx-1,numx)==0) then !identify cell to the left
			if(periods(1) .eqv. .true.) then
				neighborID=globalID+numx-1
			else
				neighborID=0
			end if
		else
			neighborID=globalID-1
		end if
	else if(dir==3) then
		if(mod(globalID,numx*numy) > numx*(numy-1) .OR. mod(globalID,numx*numy)==0) then	!identify cell to the front
			if(periods(2) .eqv. .true.) then
				neighborID=globalID-(numx*(numy-1))
			else
				neighborID=0
			end if
		else
			neighborID=globalID+numx
		end if
	else if(dir==4) then
		if(mod(globalID,numx*numy) <= numx .AND. (mod(globalID, numx*numy) /= 0 .OR. numy==1)) then	!identify cell to the back
			if(periods(2) .eqv. .true.) then
				neighborID=globalID+(numx*(numy-1))
			else
				neighborID=0
			end if
		else
			neighborID=globalID-numx
		end if
	else if(dir==5) then
		if(mod(globalID,numx*numy*numz) > numx*numy*(numz-1) .OR. mod(globalID, numx*numy*numz)==0) then	!identify cell to up
			if(periods(3) .eqv. .true.) then
				neighborID=globalID-(numx*numy*(numz-1))
			else
				neighborID=0
			end if
		else
			neighborID=globalID+numx*numy
		end if
	else if(dir==6) then
		if(mod(globalID,numx*numy*numz) <= numx*numy .AND. (mod(globalID,numx*numy*numz) /= 0 .OR. numz==1)) then	!identify cell to down
			if(periods(3) .eqv. .true.) then
				neighborID=globalID+(numx*numy*(numz-1))
			else
				neighborID=0
			end if
		else
			neighborID=globalID-numx*numy
		end if
	end if

	findgNeighborGID=neighborID

end function


#include "fintrf.h"
C
#if 0
C
C
#endif
	SUBROUTINE MEXFUNCTION(NLHS, PLHS, NRHS, PRHS)
	IMPLICIT NONE
	MWPOINTER PLHS(*), PRHS(*)
	INTEGER MXGETM, MXGETN
	INTEGER NLHS, NRHS
	MWPOINTER ROWS, COLS
	MWSIZE SIZE

C       Check for proper number of arguments.
	IF (NRHS .NE. 1) THEN
	   CALL MEXERRMSGTXT('One input required in wofz.')
	ENDIF
	ROWS = MXGETM(PRHS(1))
	COLS = MXGETN(PRHS(1))
	SIZE = ROWS*COLS
!	CALL INTERMEDIATE GATEWAY:
	CALL GATEWAY(PLHS,PRHS,SIZE)

	END
!	==============================================================

	SUBROUTINE GATEWAY(PLHS, PRHS, SIZE)
	IMPLICIT NONE
	MWPOINTER PLHS, PRHS
	MWSIZE SIZE
	MWPOINTER MXCREATEDOUBLEMATRIX, MXGETPR, MXGETPI
	MWPOINTER MXGETM, MXGETN, MXISCOMPLEX
	MWPOINTER ROWS, COLS
	INTEGER I, ISCOMPLEX
	DOUBLE PRECISION A(SIZE), B(SIZE), C(SIZE), D(SIZE)
	LOGICAL FLAG

	CALL MXCOPYPTRTOREAL8(MXGETPR(PRHS),A,SIZE)
!       Checks if there are imaginary numbers in data
	ISCOMPLEX = MXISCOMPLEX(PRHS)
	IF (ISCOMPLEX.EQ.1) THEN
	   CALL MXCOPYPTRTOREAL8(MXGETPI(PRHS),B,SIZE)
	END IF
	ROWS = MXGETM(PRHS)
	COLS = MXGETN(PRHS)
	PLHS = MXCREATEDOUBLEMATRIX(ROWS, COLS, 1)

!       CALL COMPUTATIONAL ROUTINE:
	DO 20, I=1,SIZE
	   IF (ISCOMPLEX.EQ.0) THEN
	      B(I) = 0
	   END IF
	   CALL WOFZ(A(I),B(I),C(I),D(I),FLAG)
 20	CONTINUE
	CALL MXCOPYREAL8TOPTR(C,MXGETPR(PLHS),SIZE)
	CALL MXCOPYREAL8TOPTR(D,MXGETPI(PLHS),SIZE)
	END
!	===============================================================
	SUBROUTINE WOFZ (X, Y, U, V)
	IMPLICIT DOUBLE PRECISION (A-H, O-Z)
	DOUBLE PRECISION A0, A1, A2, A3, A4, A5, A6
	DOUBLE PRECISION B0, B1, B2, B3, B4, B5, B6
	COMPLEX *16  T, W
	A0 = 122.607931777104326
	A1 = 214.382388694706425
	A2 = 181.928533092181549
	A3 = 93.155580458138441
	A4 = 30.180142196210589
	A5 = 5.912626209773153
	A6 = 0.564189583562615
	B0 = 122.607931773875350
	B1 = 352.730625110963558
	B2 = 457.334478783897737
	B3 = 348.703917719495792
	B4 = 170.354001821091472
	B5 = 53.992906912940207
	B6 = 10.479857114260399
	T  = DCMPLX(Y,-X)
	W  = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T + A1)*T+A0)
	1      /(((((((T + B6)*T + B5)*T + B4)*T + B3)*T + B2)*T + B1)*T+B0)
	U = DREAL(W)
	V = DIMAG(W)
	RETURN
	END


*     MC01WD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 10 )
*     .. Local Scalars ..
      DOUBLE PRECISION U1, U2
      INTEGER          DP, I, INFO
*     .. Local Arrays ..
      DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01WD
*     .. Executable Statements ..
*
      WRITE ( NOUT,FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
         READ ( NIN, FMT = * ) U1, U2
*        Compute Q(x) and R(x) from P(x) = (x**2+U2*x+U1) * Q(x) + R(x).
         CALL MC01WD( DP, P, U1, U2, Q, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 0, DP - 2
               WRITE ( NOUT, FMT = 99996 ) I, Q(I+3)
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) Q(1) + Q(2)*U2, Q(2)
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01WD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01WD = ',I2)
99997 FORMAT (' The coefficients of the quotient polynomial Q(x) are ',
     $       //' power of x     coefficient ')
99996 FORMAT (2X,I5,9X,F9.4)
99995 FORMAT (/' The coefficients of the remainder polynomial R(x) are '
     $       ,//' power of x     coefficient ',/'      0         ',F9.4,
     $       /'      1         ',F9.4)
99994 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END


module convolution

! Sample module to show how to calculate image convolution

implicit none
private
public apply

contains

subroutine apply(C)
integer, intent(inout) :: C(:, :, :)
integer :: C2(3, size(C, 2), size(C, 3))
integer :: k(3, 3)
integer :: i, j, o, w, h
! Filter:
!k = reshape([1, 1, 1, 1, 2, 1, 1, 1, 1], [3, 3])
k = reshape([-4, -2, 0, -2, 1, 2, 0, 2, 4], [3, 3])

w = size(C, 2)
h = size(C, 3)
C2 = C
do j = 2, h-1
    do i = 2, w-1
        do o = 1, 3
            C2(o, i, j) = sum(C(o, i-1:i+1, j-1:j+1)*k) / sum(k)
        end do
    end do
end do
C = C2
where (C < 0) C = 0
where (C > 255) C = 255
end subroutine

end module


c=======================================================================
c
c     SDLS Utility Functions
c
c-----------------------------------------------------------------------
c
c        ADJOINT : computing the symmetric matrix sum of Ai*y(i)
c
c        ADJOINTG: computing the symmetric matrix
c                  sum(Ai*lambda(i)) + sum(Bj*mu(j)) - sum(Bj*gamma(j))
c
c        OPERATA : computing the operator_A : vector(m) result of
c                  scalar product of m Ai constraints matrices with
c                  matrix X
c
c        CSDLSCE : computing the equal constraints matrices for SDLSCE
c
c        CSDLSCI : computing the constraints matrices for SDLSCI
c
c=======================================================================
c
c     subroutine ADJOINT
c
c     Computes symmetric matrix sum of Ai*y(i)
c
c-----------------------------------------------------------------------
      SUBROUTINE adjoint ( mct, nmat, vecty, matai, matadj )
c-----------------------------------------------------------------------
c
c     INPUT
c            mct    : number of constraints                      integer
c            nmat   : dimension of the matrices X and Ai         integer
c            vecty  : y vector(mct)                               double
c            matai  : mct vectorized symmetric matrices Ai
c                     vector( mct * (nmat*(nmat+1)/2) )           double
c
c     OUTPUT
c            matadj : sum(Ai.y(i)) vectorized symmetric matrix
c                     vector(nmat*(nmat+1)/2)                     double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER mct, nmat
      DOUBLE PRECISION vecty(*), matai(*), matadj(*)
c
c     local variables
      INTEGER im, in, pai, ssm
      DOUBLE PRECISION sum
c
c     initialization
      pai  = 0
      ssm  = (nmat*(nmat+1)/2)
c
      DO in=1,ssm
         pai = 0
         sum = 0.
         DO im=1,mct
            sum = sum + matai(pai+in)*vecty(im)
            pai = pai + ssm
         ENDDO
         matadj(in) = sum
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine ADJOINTG
c
c     Computing symmetric matrix
c     sum(Ai*lambda(i)) + sum(Bj*mu(j)) - sum(Bj*gamma(j))
c
c-----------------------------------------------------------------------
      SUBROUTINE adjointg ( mcte, mcti, nmat, ydual, acte, acti,
     &                      matadj )
c-----------------------------------------------------------------------
c
c     INPUT
c            mcte   : number of constraints                      integer
c            mcti   : number of inequal constraints              integer
c            nmat   : dimension of the matrices X and Ai         integer
c            ydual  : dual solution        vector(mcte + 2*mcti)  double
c            acte   : mcte Ai symmetric matrices(nmat*nmat)
c                     of constraints
c                     vectorized  vector( mct*(nmat*(nmat+1)/2) ) double
c            acti   : mcti Bj symmetric matrices(nmat*nmat) of
c                     inequal constraints  vector(mcti*nmat*nmat)
c                     vector( mcti*(nmat*(nmat+1)/2) )            double
c
c     OUTPUT
c            matadj : sum(Ai.y(i)) vectorized symmetric matrix
c                     vector(nmat*(nmat+1)/2)                     double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER mcte, mcti, nmat
      DOUBLE PRECISION ydual(*), acte(*), acti(*), matadj(*)
c
c     local variables
      INTEGER im, in, pact, ssm, plam, pgam, pmu
      DOUBLE PRECISION sum
c
c-----------------------------------------------------------------------
c
c     pointers for dual vector ydual
      plam = 1
c     plam   : pointer for lambda Lagrange coefficients, so mcte more
      pmu = plam + mcte
c     pmu    : pointer for mu Lagrange coefficients, so mcti more
      pgam = pmu + mcti
c     pgam   : pointer for gam Lagrange coefficients, so mcti more
c
      pact = 0
      ssm  = (nmat*(nmat+1)/2)
c
      DO in = 1,ssm
         sum  = 0.
         pact = 0
         DO im = 1,mcte
            sum = sum + acte(pact+in)*ydual(plam+im-1)
            pact = pact + ssm
         ENDDO
         pact = 0
         DO im = 1,mcti
            sum = sum + acti(pact+in)*(ydual(pmu+im-1)-ydual(pgam+im-1))
            pact = pact + ssm
         ENDDO
         matadj(in) = sum
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine OPERATA
c
c     Computes operator_A : vector(m) result of scalar product of
c     m Ai constraints matrices with matrix X
c
c-----------------------------------------------------------------------
      SUBROUTINE operata ( mct, nmat, matx, matai, vect )
c-----------------------------------------------------------------------
c
c     INPUT
c            mct    : number of constraints                      integer
c            nmat   : dimension of the matrices X and Ai         integer
c            matx   : vectorized symmetric matrix X
c                     vector(nmat*(nmat+1)/2)                     double
c            matai  : mct vectorized symmetric matrices Ai
c                     vector( mct * (nmat*(nmat+1)/2) )           double
c
c     OUTPUT
c            vect   : Ai.X vector(mct)                            double
c
c     CALL
c            XMS    : computing scalar product of two vectorized
c                     symmetric matrices M1.M2
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER mct, nmat
      DOUBLE PRECISION matx(*), matai(*), vect(*)
c
c     local variables
      INTEGER im, pai, ssm
c
c     initialization
      pai = 1
      ssm = (nmat*(nmat+1)/2)
      DO im = 1,mct
c
c        computing scalar product between matrix Ai and matrix X
         CALL XMS ( nmat, matx, matai(pai), vect(im) )
         pai = pai + ssm
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine  CSDLSCE
c
c     Equal constraints matrices for SDLSCE
c
c-----------------------------------------------------------------------
      SUBROUTINE csdlsce ( nmat, cmat, imatce, matce, mcte, acte, bcte )
c-----------------------------------------------------------------------
c
c     INPUT
c            nmat   : dimension of the matrix                    integer
c            cmat   : symmetric matrix(nmat*nmat) to optimize     double
c            imatce : symmetric matrix(nmat*nmat)                integer
c                     equal constraints indicators
c                     if imatce(i,j) = 1 : xmat(i,j) = cmat(i,j)
c                     if imatce(i,j) = 2 : xmat(i,j) = matce(i,j)
c                     only the lower part is used
c            matce  : symmetric matrix(nmat*nmat)                 double
c                     equal constraint value if imatce(i,j) = 2
c                     only the lower part is used
c     OUTPUT
c            mcte   : number of equal constraints                integer
c            acte   : mcte Ai symmetric matrices(nmat*nmat) of
c                     equal constraints, vector(mcte*nmat*nmat)   double
c            bcte   : value of equal constraints, vector(mcte)    double
c
c     CALL
c        IMX     : initialization at a scalar of a matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER nmat, mcte
      INTEGER imatce(nmat,*)
      DOUBLE PRECISION cmat(nmat,*), matce(nmat,*), acte(*), bcte(*)
c
c     local variables
      INTEGER i, j, ksa, sm, kb, ice
      DOUBLE PRECISION dzero
      PARAMETER ( dzero=0.E0 )
c
c-----------------------------------------------------------------------
c
      sm  = nmat*nmat
      ksa = 1
      kb  = 0
      DO i = 1,nmat
         DO j = 1,i
            ice = imatce(i,j)
            IF ( ice .NE. 0 ) THEN
               kb = kb + 1
               IF (ice .EQ. 1) bcte(kb) = cmat(i,j)
               IF (ice .EQ. 2) bcte(kb) = matce(i,j)
               CALL IMX ( nmat, nmat, acte(ksa), dzero )
               acte(ksa+i+(j-1)*nmat-1) = 1
               ksa = ksa + sm
            ENDIF
         ENDDO
      ENDDO
c
      mcte = kb
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine  CSDLSCI
c
c     Computing the constraints matrices for SDLSCI
c
c-----------------------------------------------------------------------
      SUBROUTINE csdlsci ( nmat, cmat, imatc, matc, matlci,
     &                     mcte, acte, bcte, mcti, acti, lcti, ucti )
c-----------------------------------------------------------------------
c
c     INPUT
c            nmat   : dimension of the matrix                    integer
c            cmat   : symmetric matrix(nmat*nmat) to optimize     double
c            imatc  : symmetric matrix(nmat*nmat)                integer
c                     constraints indicators (see method)
c                     only the lower part is used
c            matc   : symmetric matrix(nmat*nmat)                 double
c                     equal constraint value if imatc(i,j) = 2
c                     inequal constraint tolerance if imatc(i,j) = 3
c                     inequal constraint up value if imatc(i,j) = 4
c                     only the lower part is used
c            matlci : symmetric matrix(nmat*nmat)                 double
c                     inequal constraint low value if imatc(i,j) = 4
c                     only the lower part is used
c                     only the lower part is used
c     OUTPUT
c            mcte   : number of equal constraints                integer
c            acte   : mcte Ai symmetric matrices(nmat*nmat) of
c                     equal constraints, vector(mcte*nmat*nmat)   double
c            bcte   : value of equal constraints, vector(mcte)    double
c            mcti   : number of inequal constraints              integer
c            acti   : mcti Bi symmetric matrices(nmat*nmat) of
c                     inequal constraints  vector(mcti*nmat*nmat) double
c            lcti   : lower bounds of inequal constraints
c                     vector(mcti)                                double
c            ucti   : upper bounds of inequal constraints
c                     vector(mcti)                                double
c
c     CALL
c        IMX     : initialization at a scalar of a matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER nmat, mcte, mcti
      INTEGER imatc(nmat,*)
      DOUBLE PRECISION cmat(nmat,*), matc(nmat,*), matlci(nmat,*),
     &                 acte(*), bcte(*), acti(*), lcti(*), ucti(*)
c
c     local variables
      INTEGER i, j, sm, ik, icte, icti, ksae, ksai, icc
      DOUBLE PRECISION dzero
      PARAMETER ( dzero = 0.E0 )
c
c-----------------------------------------------------------------------
c
      sm = nmat*nmat
      icte = 0
      icti = 0
c
      ksae = 1
      ksai = 1
      DO i = 1,nmat
         DO j = 1,i
            ik  = i+(j-1)*nmat
            icc = imatc(i,j)
c
            IF ( icc .EQ. 1 ) THEN
               icte = icte + 1
               bcte(icte) = cmat(i,j)
               CALL IMX ( nmat, nmat, acte(ksae), dzero )
               acte(ksae+ik-1) = 1
               ksae = ksae + sm
            ENDIF
c
            IF ( icc .EQ. 2 ) THEN
               icte = icte + 1
               bcte(icte) = matc(i,j)
               CALL IMX ( nmat, nmat, acte(ksae), dzero )
               acte(ksae+ik-1) = 1
               ksae = ksae + sm
            ENDIF
c
            IF ( icc .EQ. 3 ) THEN
               icti = icti + 1
               ucti(icti) = cmat(i,j) + matc(i,j)
               lcti(icti) = cmat(i,j) - matc(i,j)
               CALL IMX ( nmat, nmat, acti(ksai), dzero )
               acti(ksai+ik-1) = 1
               ksai = ksai + sm
            ENDIF
c
            IF ( icc .EQ. 4 ) THEN
               icti = icti + 1
               ucti(icti) = matc(i,j)
               lcti(icti) = matlci(i,j)
               CALL IMX ( nmat, nmat, acti(ksai), dzero )
               acti(ksai+ik-1) = 1
               ksai = ksai + sm
            ENDIF
c
         ENDDO
      ENDDO
c
      mcte = icte
      mcti = icti
c
      RETURN
      END


      SUBROUTINE COST (N,X,WSAVE)
      IMPLICIT NONE
      INTEGER :: N, I, K, KC, MODN, NM1, NP1, NS2
      REAL :: X(*), WSAVE(*), C1, T1, T2, TX2, X1H, X1P3, XI, XIM2
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N.lt.2) GO TO 106
      IF (N.eq.2) GO TO 101
      GO TO 102
  101 X1H = X(1)+X(2)
      X(2) = X(1)-X(2)
      X(1) = X1H
      RETURN
  102 IF (N .GT. 3) GO TO 103
      X1P3 = X(1)+X(3)
      TX2 = X(2)+X(2)
      X(2) = X(1)-X(3)
      X(1) = X1P3+TX2
      X(3) = X1P3-TX2
      RETURN
  103 C1 = X(1)-X(N)
      X(1) = X(1)+X(N)
      DO 104 K=2,NS2
         KC = NP1-K
         T1 = X(K)+X(KC)
         T2 = X(K)-X(KC)
         C1 = C1+WSAVE(KC)*T2
         T2 = WSAVE(K)*T2
         X(K) = T1-T2
         X(KC) = T1+T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)
      CALL RFFTF (NM1,X,WSAVE(N+1))
      XIM2 = X(2)
      X(2) = C1
      DO 105 I=4,N,2
         XI = X(I)
         X(I) = X(I-2)-X(I-1)
         X(I-1) = XIM2
         XIM2 = XI
  105 CONTINUE
      IF (MODN .NE. 0) X(N) = XIM2
  106 RETURN
      END


!> \file rhoinsitu.f90
!! \BRIEF
!> Module with rhoinsitu subroutine - compute in situ density from S, Tis, P
MODULE mrhoinsitu
CONTAINS
!>     Compute in situ density from salinity (psu), in situ temperature (C), & pressure (db).
!!     This subroutine is needed because rho is a function (using scalars not arrays)
SUBROUTINE rhoinsitu(salt, tempis, pdbar, N, rhois)

  !     Purpose:
  !     Compute in situ density from salinity (psu), in situ temperature (C), & pressure (db)
  !     Needed because rho is a function

  USE msingledouble
  USE mrho
  IMPLICIT NONE

  INTEGER :: N

! INPUT variables
  ! salt   = salinity [psu]
  ! tempis = in situ temperature [C]
  ! pdbar  = pressure [db]

  !> salinity [psu]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: salt
  !> in situ temperature [C]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: tempis
  !> pressure [db]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: pdbar
!!!f2py optional , depend(salt) :: n=len(salt)
!f2py depend(salt) :: n=len(salt)

! OUTPUT variables:
  ! rhois  = in situ density

  !> in situ density [kg/m3]
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: rhois

! Local variables
  INTEGER :: i

! REAL(kind=rx) ::  rho
! EXTERNAL rho

  DO i = 1,N
     rhois(i) = rho(salt(i), tempis(i), pdbar(i)/10.)
  END DO

  RETURN
END SUBROUTINE rhoinsitu
END MODULE mrhoinsitu


!-----------------------------------------------------------------------
!     Subroutine:    calc_metrics
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          12/15/2011
!     Description:   This subroutine calculates the metric elements from
!                    the values currently stored in the background
!                    and realspace grids.
!
!                    We define our fuctions to be of the form
!                    f(rho,theta,phi) = sum{n=-ntor,ntor} sum{m=0,mpol) fmn(s) * cos(m*theta+n*N*phi)
!                    So we must chain rule to u and v where
!                    u = theta/2*pi  and  v = phi / 2*pi*N
!                    Thus
!                    df/du = df/dtheta * dtheta/du
!                    df/dv = df/dphi   * dphi/dv
!-----------------------------------------------------------------------
      SUBROUTINE calc_metrics
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY : rprec
      USE torlines_background, xm => xm_sav, xn => xn_sav
      USE torlines_realspace
      USE torlines_runtime
      USE EZspline_obj
      USE EZspline
!-----------------------------------------------------------------------
!     Local Variables
!          ier         Error flag
!          u           Poloidal dummy index
!          v           Toroidal dummy index
!          mn          Fourier dummy index
!          factor      ratio dphi/dv
!          fmn_temp    Dummy array to hold derivative coefficients (ex. rmnc*m)
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER :: ier, u, v, mn, s, mnmax
      REAL(rprec) :: factor
      REAL(rprec), ALLOCATABLE :: fmn_temp(:,:)
      TYPE(EZspline3_r8) :: r1_spl, z1_spl
      INTEGER :: bcs1(2),bcs2(2)
      REAL(rprec) :: R_grad(3), Z_grad(3)
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      bcs1=(/0,0/)
      bcs2=(/-1,-1/)
      mnmax = SIZE(rmnc_sav,1)
      ! Calculate deriviatives
      ! Note harmonics are in (mu+nv) form
      !ALLOCATE(fmn_temp(1:mnmax,1:nrho),STAT=ier)
      !IF (ier /= 0) CALL handle_err(ALLOC_ERR,'FMN_TEMP (calc_metrics)',ier)
      rs = 0; zs = 0; ru=0; zu=0; rv=0; zv=0;
      !FORALL(mn = 1:mnmax) fmn_temp(mn,:) = -rmnc_sav(mn,:)*xm(mn)
      !CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,ru,1,1)
      !FORALL(mn = 1:mnmax) fmn_temp(mn,:) = -rmnc_sav(mn,:)*xn(mn)*nfp
      !CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,rv,1,0)
      !FORALL(mn = 1:mnmax) fmn_temp(mn,:) = zmns_sav(mn,:)*xm(mn)
      !CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zu,0,0)
      !FORALL(mn = 1:mnmax) fmn_temp(mn,:) = zmns_sav(mn,:)*xn(mn)*nfp
      !CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zv,0,0)
      !IF (lasym) THEN
      !   FORALL(mn = 1:mnmax) fmn_temp(mn,:) = rmns_sav(mn,:)*xm(mn)
      !   CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,ru,0,0)
      !   FORALL(mn = 1:mnmax) fmn_temp(mn,:) = rmns_sav(mn,:)*xn(mn)*nfp
      !   CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,rv,0,0)
      !   FORALL(mn = 1:mnmax) fmn_temp(mn,:) = -zmnc_sav(mn,:)*xm(mn)
      !   CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zu,1,0)
      !   FORALL(mn = 1:mnmax) fmn_temp(mn,:) = -zmnc_sav(mn,:)*xn(mn)*nfp
      !   CALL mntouv(1,nrho,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zv,1,0)
      !END IF
      !DEALLOCATE(fmn_temp)

      ! Spline formulation
      ! xv*2*pi*nfp (didn't work)
      ! xv*2*pi     (worse than before)
      ! removing 2*pi dependancy is horrible
      ! full grid (nu-1 -> nu and nv-1 -> nv, better)
      ! Do full grid (no filling)
      CALL EZspline_init(r1_spl,nrho,nu,nv,bcs1,bcs2,bcs2,ier)
      CALL EZspline_init(z1_spl,nrho,nu,nv,bcs1,bcs2,bcs2,ier)
      r1_spl%x1 = rho
      z1_spl%x1 = rho
      r1_spl%x2(1:nu) = xu(1:nu)*pi2
      z1_spl%x2(1:nu) = xu(1:nu)*pi2
      r1_spl%x3(1:nv) = xv(1:nv)*pi2
      z1_spl%x3(1:nv) = xv(1:nv)*pi2
      r1_spl%isHermite    = 1
      z1_spl%isHermite    = 1
      CALL EZspline_setup(r1_spl,rreal,ier,exact_dim=.true.)
      CALL EZspline_setup(z1_spl,zreal,ier,exact_dim=.true.)

      DO v = 1, nv
         DO u = 1, nu
            DO s = 1, nrho
               !PRINT *,rho(s)
               CALL EZspline_gradient(r1_spl,rho(s),xu(u)*pi2,xv(v)*pi2,R_grad,ier)
               CALL EZspline_gradient(z1_spl,rho(s),xu(u)*pi2,xv(v)*pi2,Z_grad,ier)
               !IF (lverb) WRITE(327,'(3I5,6ES20.10)') s,u,v,rs(s,u,v),ru(s,u,v),rv(s,u,v),R_grad
               rs(s,u,v) = R_grad(1)
               ru(s,u,v) = R_grad(2)
               rv(s,u,v) = R_grad(3)*nfp
               zs(s,u,v) = Z_grad(1)
               zu(s,u,v) = Z_grad(2)
               zv(s,u,v) = Z_grad(3)*nfp
            END DO
         END DO
      END DO

      CALL EZspline_free(r1_spl,ier)
      CALL EZspline_free(z1_spl,ier)

      ! Calculate metric elements
      g11 = rs*rs+zs*zs
      g12 = rs*ru+zs*zu
      g13 = rs*rv+zs*zv
      g22 = ru*ru+zu*zu
      g23 = ru*rv+zu*zv
      g33 = rv*rv+zv*zv
      detg= g11*(g22*g33-g23*g23) + g12*(g23*g13-g12*g33) + g13*(g12*g23-g22*g13)
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE calc_metrics


      subroutine InitSectionsN
      implicit none
      include 'applu.incl'
      include 'indexbounds.h'

        xsize = isiz1
        ysize = isiz2
        zsize = isiz3

        section1 = xsize + 2
        section2 = xsize + ysize - 1
        section3 = xsize + ysize + zsize - 3

      return
      end

      subroutine InitLoopBoundsLocalN( k, LC)
      implicit none
      include 'indexbounds.h'
      include 'loopcontrol.h'
      integer, intent(in) :: k
      type(LoopControlStruct), intent(inout) :: LC

        LC%section1 = section1
        LC%section2 = section2
        LC%section3 = section3

        LC%xsize = xsize
        LC%ysize = ysize
        LC%zsize = zsize

        LC%updown = 0
        LC%updowne = 0
        LC%topseg = 0
        LC%botseg = 0

            if ( k .le. section1 ) then
              jfirst = 2
              jlast = k-4
            else if ( k .le. section2 ) then
              jfirst = 2
              jlast = ysize-1
            else
              jfirst = k-section2+1
              jlast = xsize-1
            endif

      return
      end

         pure extrinsic (hpf_local)
     >      subroutine GetIBoundsLocalN( j, k, LC)

      implicit none
      include 'indexbounds.h'
      include 'loopcontrol.h'

      integer, intent(in) :: j,k
      type(LoopControlStruct), intent(inout) :: LC

             if ( k .le. LC%section1) then
               LC%first = 2
               LC%last = jlast + 2 - j
             else if ( k .le. LC%section2) then
               if ( j .lt. k - LC%xsize ) then
                 LC%first = k - j - LC%xsize + 1
                 LC%last = LC%zsize - 1
               else
                 LC%first = 2
                 LC%last =  k - j - 2
               endif
             else
               LC%first = k - j - LC%xsize + 1
               LC%last = LC%xsize - 1
             endif

      return
      end

      extrinsic (hpf) subroutine SetLoopBounds
      implicit none
      include 'applu.incl'
      include 'indexbounds.h'
      include 'loopcontrol.h'
      integer sumdim, k, j
      type(LoopControlStruct) :: loopControl

      sumdim = isiz1+isiz2+isiz3-3
      do k = 6, sumdim
      call InitLoopBoundsLocalN( k, loopControl)
         jlow(k) = jfirst
         jhigh(k) = jlast
         do j= jfirst, jlast
           call GetIBoundsLocalN(j,k,loopControl)
           ilow(k,j) = loopControl%first
           ihigh(k,j) = loopControl%last
         end do
      end do

      return
      end


!! Pros:
!!
!!- A user only needs to use the extends(abstract_operator) and define
!!  the apply subroutine to use any Krylov solver.
!!
!!- Defining block matrices, combination of matrices and product
!!  matrices is trivial
!!
!!- Preconditoners are just some particular abstract operators.
!!
!! Cons.
!! - In same cases, we could save memory and computational power
!! defing other application like y=Ax+y instead of y=Ax. But these
!! savings are small and compromise readibility and flexibility of the
!! approach.

module AbstractOperators
  !! Module containg the abstract class parent of
  !! all operator classes defined on standard Fortran Vector
  use SimpleVectors
  implicit none
  public :: abstract_operator, application
  public :: eye
  type, abstract :: abstract_operator
     !! Abstract type defining base general operator

     !! Members:
     !! Number of columns (the domain of the application)
     integer :: ncol=0

     !! Number of rows (the co-domain of the application)
     integer :: nrow=0

     !! Logical flag for symmetry
     logical :: is_symmetric=.false.

     !! Real estimating the non linearity of the application, defined
     !! as: nonlinearity = |OP(x)+OP(y)-OP(x+y)|/(max(|x|,|y|,|x+y|)
     !! It is zero (the defualt value) for linear operators (up to
     !! machine precision). It may be greater that zero for quasi
     !! linear operator like inverse operator.
     real(kind=double) :: nonlinearity = 0.0d0
   contains
     !! Procedure for the application of the operator on a vector.
     procedure(application), deferred :: apply
  end type abstract_operator

  abstract interface
     !! Abstract procedure defining the interface for a general
     !! application actions
     !!
     !! y = M(x) = ( M*x if M is linear)
     recursive subroutine application(this,vec_in,vec_out,ierr)
       import abstract_operator
       import double
       implicit none
       !! The class with all quantities describing the operator
       class(abstract_operator), intent(inout) :: this
       !! The input" vector
       real(kind=double),        intent(in   ) :: vec_in(this%ncol)
       !! The output vector y= "operator apllied on" x
       real(kind=double),        intent(inout) :: vec_out(this%nrow)
       !! An integer flag to inform about error
       !! It is zero if no error occured
       integer,                          intent(inout) :: ierr
     end subroutine application
  end interface

  !! identity operator
  type, public, extends(abstract_operator) :: eye
   contains
     !! constructor
     procedure, public, pass :: init => init_eye
     !! procedure to be overrided
     procedure, public, pass :: apply =>  apply_eye
  end type eye
contains

    !! set identity dimensions
  subroutine init_eye(this,size)
    implicit none
    class(eye),     intent(inout) :: this
    integer,        intent(in   ) :: size

    !! the set domain/codomain operator dimension
    this%nrow = size
    this%ncol = size
    this%is_symmetric=.False.
    this%nonlinearity=zero

  end subroutine init_eye

  !! simply copy x into y
  subroutine apply_eye(this,vec_in,vec_out,ierr)
    implicit none
    class(eye),        intent(inout) :: this
    real(kind=double), intent(in   ) :: vec_in(this%ncol)
    real(kind=double), intent(inout) :: vec_out(this%nrow)
    integer,           intent(inout) :: ierr

    ! using basic linear algebra operation defined in SimpleVector module
    call d_axpby(this%nrow,one,vec_in,zero,vec_out)

    ! or we can simply use a procedure assocaite with standard Fortran vector
    vec_out=vec_in

    ierr=0
  end subroutine apply_eye

end module AbstractOperators


!##############################################################################
! PROGRAM planner
!
! ## The social planner solution to the static general equilibrium model
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog03_01m.f90"

program planner

    use globals
    use toolbox

    implicit none
    real*8 :: x(2), L(2), K(2), Y(2), fret

    ! initial guess
    x(:) = 5d0

    ! minimization routine
    call fminsearch(x, fret, (/0d0, 0d0/), (/10d0, 20d0/), utility)

    ! solution
    K(1) = x(1)
    L(1) = x(2)
    K(2) = Kbar - K(1)
    L(2) = Lbar - L(1)
    Y    = L**beta*K**(1d0-beta)

    ! output
    write(*,'(/a)')'GOODS MARKET 1 :'
    write(*,'(4(a,f6.2,2x))')' X1 =',Y(1),' Y1 =',Y(1)

    write(*,'(/a)')'GOODS MARKET 2 :'
    write(*,'(4(a,f6.2,2x))')' X2 =',Y(2),' Y2 =',Y(2)

    write(*,'(/a)')'LABOR MARKET :'
    write(*,'(4(a,f6.2,2x))')' L1 =',L(1),' L2 =',L(2),' L  =',Lbar

    write(*,'(/a)')'CAPITAL MARKET :'
    write(*,'(4(a,f6.2,2x))')' K1 =',K(1),' K2 =',K(2),' K  =',Kbar

end program


program fizzbuzz_select
    integer :: i

    do i = 1, 100
       select case (mod(i,15))
          case 0;        print *, 'FizzBuzz'
          case 3,6,9,12; print *, 'Fizz'
          case 5,10;     print *, 'Buzz'
          case default;  print *, i
       end select
    end do
 end program fizzbuzz_select


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE MINMAX (NPTS, PTS, VMIN, VMAX)
C=======================================================================

C   --*** MINMAX *** (ETCLIB) Calculate min/max value
C   --   Written by Amy Gilkey - revised 11/10/87
C   --
C   --MINMAX calculates the minimum and maximum of the data.
C   --
C   --Parameters:
C   --   NPTS - IN - the number of points
C   --   PTS - IN - the points
C   --   VMIN, VMAX - OUT - the maximum and maximum value of the points

      INTEGER NPTS
      REAL PTS(*)
      REAL VMIN, VMAX

      VMIN =  1.0E+30
      VMAX = -1.0E+30
      DO 10 I = 1, NPTS
         VMIN = MIN (VMIN, PTS(I))
         VMAX = MAX (VMAX, PTS(I))
   10 CONTINUE

C ... Check for NaN (Not a Number).
C     NaN is defined to be not equal to any other number including itself
      IF (VMIN .NE. VMIN .OR. VMAX .NE. VMAX) THEN
        CALL PRTERR('WARNING',
     *    'Data in subroutine MINMAX contains "NaN" values. Check Data')
        if (vmin .ne. vmin) vmin = -1.0e30
        if (vmax .ne. vmax) vmax =  1.0e30
      END IF

      RETURN
      END