module mod_entropy
    use mod_kinds,          only: rk,ik
    use mod_constants,      only: ZERO, HALF, ONE, TWO, THREE, CYLINDRICAL
    use mod_interpolate,    only: interpolate_element_standard
    use mod_chidg_mpi,      only: ChiDG_COMM
    use mpi_f08,            only: MPI_AllReduce, MPI_REAL8, MPI_SUM
    use DNAD_D

    use type_chidg_data,    only: chidg_data_t
    implicit none

contains

    !> Function to compute the entropy error in a domain. Assuming the Euler equations
    !! and isentropic flow.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   1/28/2016
    !!
    !!
    !------------------------------------------------------------------------------------
    function compute_entropy_error(data) result(entropy_error)
        type(chidg_data_t), intent(inout)   :: data

        real(rk), allocatable, dimension(:) :: &
            rho, rhou, rhov, rhow, rhoE, p, entropy

        !real(rk), dimension(data%mesh%domain(1)%elems(1)%gq%vol%nnodes)    :: entropy_rise
        real(rk), allocatable :: entropy_rise(:)

        integer(ik) :: irho, irhou, irhov, irhow, irhoE
        integer(ik) :: ielem, iface, nelem, iseed, idom, ierr
        real(rk)    :: pinf, tinf, rhoinf, gam, entropy_ref, error_sum, error_sum_reduced, vol, error, entropy_error, vol_sum, vol_sum_reduced

        pinf   = 110000._rk
        tinf   = 300._rk
        rhoinf = pinf/(tinf*287.15_rk)

        !& DEBUG - HARDCODED GAMMA
        gam    = 1.4_rk

        entropy_ref = pinf/(rhoinf**gam)

        !& DEBUG - HARDCODED EQUATION SET
        associate (mesh => data%mesh, sdata => data%sdata, eqnset => data%eqnset, prop => data%eqnset(1)%prop)

            ! Get equation indices
            irho  = prop%get_primary_field_index("Density"   )
            irhou = prop%get_primary_field_index("Momentum-1")
            irhov = prop%get_primary_field_index("Momentum-2")
            irhow = prop%get_primary_field_index("Momentum-3")
            irhoE = prop%get_primary_field_index("Energy"    )

            !
            ! No need to seed element derivatives
            !
            iseed = 0

            !
            ! Zero entropy error
            !
            error_sum     = ZERO
            vol           = ZERO
            vol_sum       = ZERO

            !
            ! Loop over elements and accumulate entropy error
            !
            do idom = 1,data%mesh%ndomains()

                nelem = data%mesh%domain(idom)%nelem
                do ielem = 1,nelem

                    !
                    ! Interpolate variables to GQ nodes
                    !
                    rho  = interpolate_element_standard(mesh,sdata%q,idom,ielem,irho, 1, 'value')
                    rhou = interpolate_element_standard(mesh,sdata%q,idom,ielem,irhou,1, 'value')
                    rhov = interpolate_element_standard(mesh,sdata%q,idom,ielem,irhov,1, 'value')
                    rhow = interpolate_element_standard(mesh,sdata%q,idom,ielem,irhow,1, 'value')
                    rhoE = interpolate_element_standard(mesh,sdata%q,idom,ielem,irhoE,1, 'value')

                    if (mesh%domain(idom)%elems(ielem)%coordinate_system == CYLINDRICAL) then
                        rhov = rhov / mesh%domain(idom)%elems(ielem)%interp_coords_def(:,1)
                    end if

                    !
                    ! Compute pressure
                    !
                    !p = prop%fluid%compute_pressure(rho,rhou,rhov,rhow,rhoE)
                    p = (1.4_rk-ONE)*(rhoE - HALF*( (rhou*rhou) + (rhov*rhov) + (rhow*rhow) )/rho )

                    !
                    ! Compute entropy and entropy rise.
                    !
                    entropy = p/(rho**gam)
                    entropy_rise = ((entropy - entropy_ref)/entropy_ref)**TWO

                    !
                    ! Integrate entropy error
                    !
                    error = sum(entropy_rise * mesh%domain(idom)%elems(ielem)%jinv_def * mesh%domain(idom)%elems(ielem)%basis_s%weights())

                    !
                    ! Compute element volume
                    !
                    vol = abs(sum(mesh%domain(idom)%elems(ielem)%jinv_def * mesh%domain(idom)%elems(ielem)%basis_s%weights()))

                    error_sum = error_sum + error
                    vol_sum   = vol_sum + vol

                end do ! ielem

            end do ! idom

        end associate

        ! Reduce the total error across processors
        call MPI_AllReduce(error_sum,error_sum_reduced,1,MPI_REAL8,MPI_SUM,ChiDG_COMM,ierr)

        ! Reduce the total volume across processors
        call MPI_AllReduce(vol_sum,vol_sum_reduced,1,MPI_REAL8,MPI_SUM,ChiDG_COMM,ierr)

        ! Compute the global volume-weighted entropy error
        entropy_error = sqrt(error_sum_reduced/vol_sum_reduced)

    end function compute_entropy_error
    !**********************************************************************************************

end module mod_entropy


C
C $Id: tsfnsp.f,v 1.5 2008-07-27 00:17:12 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION TSFNSP (ECCENT,PHI,SINPHI)
C
C FUNCTION TO COMPUTE CONSTANT (SMALL T).
C
      IMPLICIT REAL (A-Z)
      DATA HALF,ONE /0.5E0,1.0E0/
      DATA HALFPI /1.5707963267948966E0/
C
      CON = ECCENT * SINPHI
      COM = HALF * ECCENT
      CON = ((ONE - CON) / (ONE + CON)) ** COM
      TSFNSP = TAN (HALF * (HALFPI - PHI)) / CON
C
      RETURN
      END


c
c-----------------------------------------------------------------------
c
c
c
      double precision function p18fxw(xw)
      implicit double precision (a-h,o-z)
      common/p18xwc/ x,y
c
c     # The slope of the characteristic between (x,y) and (xw,yw) is
c     # tan(theta + mu)
c
      theta = p18th(xw)
      p18fxw = p18yw(xw)-y + dtan(theta+p18mu(theta)) *(x-xw)
      return
      end


!  SFM  04/06/2013  Code changes from M.Grecu
!  SFM  05/06/2013  Code changes from M.Grecu, via L.Woltz
!
subroutine covYYp(covyy,yy,ny,nm)
integer ny, nm
real ::   yy(ny,nm), covyy(ny,ny)
real ::   my(ny)

do i=1, ny
   my(i)=sum(yy(i,1:nm))/nm
enddo

do i=1, ny
   do j=1, ny
      covyy(i,j)=sum((yy(i,1:nm)-my(i))*(yy(j,1:nm)-my(j)))/nm
   enddo
enddo

end subroutine covYYp

subroutine covXYp(covxy,yy,xx,ny,nx,nm)
integer ny, nm, nx
real ::   yy(ny,nm), xx(nx,nm), covxy(nx,ny)
real ::   mx(nx), my(ny)

do i=1, nx
   mx(i)=sum(xx(i,1:nm))/nm
enddo
do i=1, ny
   my(i)=sum(yy(i,1:nm))/nm
enddo

do i=1, nx
   do j=1, ny
      covxy(i,j)=sum((xx(i,1:nm)-mx(i))*(yy(j,1:nm)-my(j)))/nm
   enddo
enddo

end subroutine covXYp
!enkF1d(Xens(:,1:nmemb1-1),Yens(:,1:nmemb1-1),Yobs,nx,ny,nMemb-1,xup)
subroutine enkF1d(xens,yens,yobs,nx,ny,nm,xup, ipias,s0KuVar,s0KaVar,S0Cov,&
  piaKuVar,piaKaVar)
  use ran_mod
  implicit none
  integer :: ny,nx,nm, ipias(2)
  real :: xens(nx,nm), yens(ny,nm), yobs(ny), ym(ny), ydiff(ny,nm+1)
  real :: covyy(ny,ny), covxy(nx,ny)
  character :: uplo
  integer   :: info, lda, ldb, n, nrhs, i, j, irec, ii
  integer   :: nmemb1, nmemb2,  k
  real      :: xm(nx), xup(nx), maxx, minx, stdx, s1, s0KuVar,S0KaVar,s0Cov,&
       piaKuVar,piaKaVar

! WSO  begin 08/20/2015 increased array dimension to 800 to avoid overflow for
! "deep"
! profiles
  real      :: dxup(800)
! WSO  end 08/20/2015

  !print*, nx, ny, nm
  !print*, Yobs

  nmemb1=nm
!   print '(11F10.4)', yens(1:ny,1:nm)
  call covYYp(covyy(1:ny,1:ny),yens(1:ny,1:nm),ny,nmemb1)
!   print '(11F10.4)', covyy(1:ny,1:ny)
!   print*, ny
!   stop

  do i=1,ipias(1)-1 !Ka dBZ obs
     if(i.ne.ipias(1)) then
        covyy(i,i)=covyy(i,i)+4.
     else
        covyy(i,i)=covyy(i,i)+4.
     endif
  enddo

  !   print '(11F10.4)', covyy(1:ny,1:ny)
!   stop
  call covXYp(covxy(1:nx,1:ny),yens(1:ny,1:nm),xens(1:nx,1:nm),ny,nx,nm)

  uplo='U'

  do i=1,ny
     ym(i)=sum(yens(i,1:nm))/nm
     ydiff(i,1)=yobs(i)-ym(i)
     do j=1,nm
        ydiff(i,1+j)=yobs(i)-yens(i,j)
     enddo
  enddo

  covyy(ipias(1),ipias(1))=covyy(ipias(1),ipias(1))+s0KuVar
  covyy(ipias(2),ipias(2))=covyy(ipias(2),ipias(2))+s0KaVar
  covyy(ipias(1)+2,ipias(1)+2)=covyy(ipias(1)+2,ipias(1)+2)+piaKuVar
  covyy(ipias(1)+3,ipias(1)+3)=covyy(ipias(1)+3,ipias(1)+3)+piaKaVar

  do i=ipias(2)+3,ny
     covyy(i,i)=covyy(i,i)+100/2./2.
  enddo
  do i=ipias(2)+10,ny
     covyy(i,i)=covyy(i,i)+150/2./2.
  enddo

  call sposv(uplo, ny, 1+nm, covyy(1:ny,1:ny), ny, ydiff(1:ny,1:1+nm), ny, info)

  s1=stdx(xens(1,1:nm),nm)
  !print*, info
  if(info .ne. 0) then
     !print*, 'info1',info
     do i=1,-ny
        write(*,10) covyy(i,1:ny)
     enddo
     !stop
     10 format(70(F8.2,1x))
     !print*, s0kuVar,s0KaVar
     !print*, yens(1,1:nm)
     !print*, yens(2,1:nm)
  else
!     print*, 'info0',info
  endif
  do j=1,nx
     xm(j)=sum(xens(j,1:nm))/nm
     maxx=maxval(xens(j,1:nm))
     minx=minval(xens(j,1:nm))
     xup(j)=xm(j)
  enddo
  if (maxval(yobs(1:ny)).gt.1e3) then
     return
  endif
  if (minval(yobs(1:ny)).lt.-1e3) then
     return
  endif

  if(info==0) then
!! begin MG 09132013  ! GPM instruments left for Japan
     do j=1,nx
        dxup(j)=0
        do i=1,ny
           dxup(j)=dxup(j)+covxy(j,i)*ydiff(i,1)
        enddo
        xm(j)=sum(xens(j,1:nm))/nm

     enddo
!! end MG 09182013
     !print*,  xm(1), dxup
     !print*, nx
!! begin MG 09182013
     !print*, xm(1)+dxup(1)
     !print*, isnan(dxup(1))
     if(xm(1)+dxup(1) .lt. 300 .and. (isnan(dxup(1)) .eqv. .false.)) then
 !       print*, 'update'
        do j=1,nx
           xm(j)=sum(xens(j,1:nm))/nm
           maxx=maxval(xens(j,1:nm))
           minx=minval(xens(j,1:nm))
           xup(j)=xm(j)

           do i=1,ny
              xup(j)=xup(j)+covxy(j,i)*ydiff(i,1)
              !print*, j, i, covxy(j,i), ydiff(i,1), xup(j)
              !        if(xup(j)>maxx) xup(j)=maxx
              do k=1,nm
                 xens(j,k)=xens(j,k)+covxy(j,i)*ydiff(i,1+k)
              enddo
           enddo
           if(xup(j)<0.5*minx) xup(j)=0.5*minx
           do k=1,nm
              if(minx>0) then
                 if(xens(j,k)<0.2*minx) xens(j,k)=0.2*minx
              endif
              if(maxx>0) then
                 if(xens(j,k)>1.2*maxx) xens(j,k)=1.2*maxx
              endif
           enddo
        enddo
     endif

!     xup(1:nx)=xm(1:nx)+dxup(1:nx)
!! end MG 09182013
     if(xup(1) .gt. 1110 .or. isnan(xup(1))) then
        print*, xens(1,1:nm)
        print*, yens(1:ny,1)
        print*, yobs(1:ny)
        print*, nm,ny,nx
        print*, 'Unc=',s1,stdx(xens(1,1:nm),nm)
	print *, 'COVXY',(covxy(1,ii),ii=1,ny),'   ',xup(1),isnan(xup(1))
        print*, ydiff(1:ny,1)
        !print*, dxup(1), xm(1)
        !print*, dxup
        print*, 'kgain'
        stop
     end if
  endif
end subroutine enkF1d

function  stdx(xn,n)
integer :: n
real :: stdx
real :: xn(n)

xm=sum(xn)/n
stdx=sqrt(sum((xn-xm)**2/(n-1)))
end function stdx


!******************************************
!************ CFD Course Project **********
!************** A. F. Forughi *************
!**************** (6/2011) ****************
!***** Sharif University of Technology ****
!***     FVM Method: Staggered Grid     ***
!***          SIMPLE algorithm          ***
!***     Solver: BiCGSTAB (Sparse)      ***
!******************************************

implicit none
allocatable ps(:,:),pp(:,:),us(:,:),vs(:,:),apu(:,:),apv(:,:)
allocatable umatv(:),umati(:),umatj(:),umrhs(:),x(:),vmatv(:),vmati(:),vmatj(:),vmrhs(:)
allocatable pmatv(:),pmati(:),pmatj(:),pmrhs(:),pxx(:),pyy(:)
allocatable uwn(:),uws(:),uww(:),uwe(:),pbcn(:),pbcs(:),pbcw(:),pbce(:)
real(8) lx,ly,dx,dy,ps,pp,us,vs,rho,mu,alphau,alphav,alphap,umatv,umrhs,x,bires,vmatv,vmrhs,pmatv,pmrhs,b
real(8) fe,fw,fn,fs,de,dw,ds,dn,ae,aw,an,as,ap,bound,apu,apv
real(8) uwn,uws,uww,uwe,spw
real(8) idx,jdy,val,mi,ma,contres,creslimit
integer i,j,ti,ni,nj,umati,umatj,unnzero,vmati,vmatj,vnnzero,pmati,pmatj,pnnzero,un,vn,pn,k,bimaxit,pxx,pyy,simpit
integer pbcn,pbcs,pbcw,pbce
character side

open(1,file="result.plt")
open(2,file="residual.plt")
open(3,file="profiles.plt")

print*," CFD Project, A. F. Forughi (6/2011)"
print*," "
print*,"Please enter the dimensions:"
print*,"Lx:"
read*,lx
print*,"Ly:"
read*,ly
print*,"dx=dy:"
read*,dx
!lx=1.0d0
!ly=1.0d0
!dx=0.025d0

dy=dx
rho=1.0d0
mu=1.00d0
print*,"-----------------------------------------------------------"

ni=int(lx/dx) !no. of nodes on x
nj=int(ly/dy) !no. of nodes on y

allocate (ps(1:ni+2,1:nj+2),pp(1:ni+2,1:nj+2),us(1:ni+3,1:nj+3),vs(1:ni+3,1:nj+3))

ps=0.0d0;pp=0.0d0;us=0.0d0;vs=0.0d0
alphau=0.7d0 ; alphav=0.7d0 ; alphap=0.3d0

unnzero=5*(ni-3)*(nj-2)+4*(ni-3)*2+4*(nj-2)*2+3*4!none zero
vnnzero=5*(ni-2)*(nj-3)+4*(ni-2)*2+4*(nj-3)*2+3*4
pnnzero=5*(ni-2)*(nj-2)+4*(ni-2)*2+4*(nj-2)*2+3*4
un=(ni-1)*(nj) ; vn=(ni)*(nj-1) ;pn=ni*nj !n*n
allocate (umatv(1:unnzero),umati(1:unnzero),umatj(1:unnzero),umrhs(1:un),x(1:pn))
allocate (vmatv(1:vnnzero),vmati(1:vnnzero),vmatj(1:vnnzero),vmrhs(1:vn),apu(3:ni+1,2:nj+1),apv(2:ni+1,3:nj+1))
allocate (pmatv(1:pnnzero),pmati(1:pnnzero),pmatj(1:pnnzero),pmrhs(1:pn),pxx(1:pn),pyy(1:pn))
allocate (uwn(1:ni+3),uws(1:ni+3),uww(1:nj+3),uwe(1:nj+3),pbcn(2:ni+1),pbcs(2:ni+1),pbcw(2:nj+1),pbce(2:nj+1))
apu=0.0d0 ; apv=0.0d0 ; pmrhs=0.0d0
uwn=0.0d0 ;uws=0.0d0 ;uww=0.0d0 ;uwe=0.0d0
pbcn=0 ;pbcs=0 ;pbcw=0 ;pbce=0

!Set ICs:
!P IC:
ps=0.0d0
!U IC:
us(3:ni+1,2:nj+1)=-1.0e-20
!V IC:
vs(2:ni+1,3:nj+1)=-1.0e-20

!Set BCs:
!Moved wall:
print*,"                          Default BC is static Wall"
print*," "
print*,"Moving Wall Boundary Condition(s):"
do
    print*,"Enter Side letter: n:North, s:South, w:West, e:East or another to skip this BC"
	read*,side
	if ((side=="n").or.(side=="s").or.(side=="e").or.(side=="w")) then
		print*,"Enter Velocity:"
		read*,val
		if     (side=="n") then
			print*,"Enter X min:"
			read*,mi
			print*,"Enter X max:"
			read*,ma
			uwn(int(mi/dx)+3:int(ma/dx)+1)=val
		elseif (side=="s") then
			print*,"Enter X min:"
			read*,mi
			print*,"Enter X max:"
			read*,ma
			uws(int(mi/dx)+3:int(ma/dx)+1)=val
		elseif (side=="e") then
			print*,"Enter Y min:"
			read*,mi
			print*,"Enter Y max:"
			read*,ma
			uwe(int(mi/dy)+3:int(ma/dy)+1)=val
		elseif (side=="w") then
			print*,"Enter Y min:"
			read*,mi
			print*,"Enter Y max:"
			read*,ma
			uww(int(mi/dy)+3:int(ma/dy)+1)=val
		else
			exit
		endif
	else
		exit
	endif
enddo
print*,"-----------------------------------------------------------"

!uwn(:)=0.0d0 ;uws(:)=0.0d0 ;uww(:)=0.0d0 ;uwe(:)=0.0d0 !Wall velocity on some where

uwn(1)=uwn(3);uwn(2)=uwn(3);uwn(ni+3)=uwn(ni+1);uwn(ni+2)=uwn(ni+1) !for writing data on wall
uws(1)=uws(3);uws(2)=uws(3);uws(ni+3)=uws(ni+1);uws(ni+2)=uws(ni+1)
uww(1)=uww(3);uww(2)=uww(3);uww(nj+3)=uww(nj+1);uww(nj+2)=uww(nj+1)
uwe(1)=uwe(3);uwe(2)=uwe(3);uwe(nj+3)=uwe(nj+1);uwe(nj+2)=uwe(nj+1)

!Velocity Inlet:
print*,"Velocity Inlet Boundary Condition(s):"
do
	print*,"Enter Side letter: n:North, s:South, w:West, e:East or another to skip this BC"
	read*,side
	if ((side=="n").or.(side=="s").or.(side=="e").or.(side=="w")) then
		print*,"Enter Velocity:"
		read*,val
		if     (side=="n") then
			print*,"Enter X min:"
			read*,mi
			print*,"Enter X max:"
			read*,ma
			vs(int(mi/dx)+2:int(ma/dx)+1,nj+2)=-val
		elseif (side=="s") then
			print*,"Enter X min:"
			read*,mi
			print*,"Enter X max:"
			read*,ma
			vs(int(mi/dx)+2:int(ma/dx)+1,2)=val
		elseif (side=="e") then
			print*,"Enter Y min:"
			read*,mi
			print*,"Enter Y max:"
			read*,ma
			us(ni+2,int(mi/dy)+2:int(ma/dy)+1)=-val
		elseif (side=="w") then
			print*,"Enter Y min:"
			read*,mi
			print*,"Enter Y max:"
			read*,ma
			us(2,int(mi/dy)+2:int(ma/dy)+1)=val
		else
			exit
		endif
	else
		exit
	endif
enddo
print*,"-----------------------------------------------------------"

!us(2,:)=+0.0d0    !W
!us(ni+2,:)=-0.0d0 !E
!vs(:,2)=+0.0d0    !S
!vs(:,nj+2)=-0.0d0 !N

!Pressure:
print*,"Constant Peressure Condition(s):"
do
	print*,"Enter Side letter: n:North, s:South, w:West, e:East or another to skip this BC"
	read*,side
	if ((side=="n").or.(side=="s").or.(side=="e").or.(side=="w")) then
		print*,"Enter Pressure:"
		read*,val
		if     (side=="n") then
			print*,"Enter X min:"
			read*,mi
			print*,"Enter X max:"
			read*,ma
			pbcn(int(mi/dx)+1:int(ma/dx)+1)=1
			ps(int(mi/dx)+1:int(ma/dx)+1,nj+1)=val
		elseif (side=="s") then
			print*,"Enter X min:"
			read*,mi
			print*,"Enter X max:"
			read*,ma
			pbcs(int(mi/dx)+1:int(ma/dx)+1)=1
			ps(int(mi/dx)+1:int(ma/dx)+1,2)=val
		elseif (side=="e") then
			print*,"Enter Y min:"
			read*,mi
			print*,"Enter Y max:"
			read*,ma
			pbce(int(mi/dy)+1:int(ma/dy)+1)=1
			ps(ni+1,int(mi/dy)+1:int(ma/dy)+1)=val
		elseif (side=="w") then
			print*,"Enter Y min:"
			read*,mi
			print*,"Enter Y max:"
			read*,ma
			pbcw(int(mi/dy)+1:int(ma/dy)+1)=1
			ps(2,int(mi/dy)+1:int(ma/dy)+1)=val
		else
			exit
		endif
	else
		exit
	endif
enddo
print*,"-----------------------------------------------------------"

!Active Peressure BC:
!pbcn(:)=0 ;pbcs(:)=0 ;pbce(:)=0 ;pbcw(:)=0 ! 1=Active  , 0=Deactive
!Set Value of Pressure BC
!ps(2,:)=+0.0d0    !W
!ps(ni+1,:)=+0.0d0 !E
!ps(:,2)=+0.0d0    !S
!ps(:,nj+1)=+0.0d0 !N

print*," "
print*,"Enter Convergance Conditions:"
print*,"Enter No. of Maximum iteration="
read*,simpit
print*,"Enter minimum Continuity Residual threshold="
read*,creslimit

bires=1.0e-20     !BiCGSTAB Minimum Residual
bimaxit=300       !BiCGSTAB Maximum Iterations
!creslimit=1.0e-10 !Continuity Minimum Residual
!simpit=300        !Continuity Maximum Iterations

do ti=1,simpit !SIMPLE Algorithm Loop

	!U momentum:
	k=0 !counter
	do j=2,nj+1
		do i=3,ni+1
			fe=rho*dy*(us(i,j)+us(i+1,j))/2
			fw=rho*dy*(us(i,j)+us(i-1,j))/2
			fs=rho*dx*(vs(i,j)+vs(i-1,j))/2
			fn=rho*dx*(vs(i,j+1)+vs(i-1,j+1))/2
			de=mu*dy/dx ; dw=mu*dy/dx ; ds=mu*dx/dy ; dn=mu*dx/dy
			!Hybrid:
			ae=max(-fe,(de-fe/2.0),0.0d0)!
			as=max(+fs,(ds+fs/2.0),0.0d0)!
			aw=max(+fw,(dw+fw/2.0),0.0d0)!
			an=max(-fn,(dn-fn/2.0),0.0d0)!
			ap=ae+as+aw+an+(fe-fw+fn-fs)

			!U Matrixer:
			bound=0.0

			if (i/=3) then !W
				k=k+1
				umatv(k)=-aw
				umati(k)=(j-2)*(ni-1)+(i-2-1)
				umatj(k)=(j-2)*(ni-1)+(i-2)
			else
				bound=bound+aw*us(i-1,j) !for the velocity inlet
			endif

			if (i/=ni+1) then !E
				k=k+1
				umatv(k)=-ae
				umati(k)=(j-2)*(ni-1)+(i-2+1)
				umatj(k)=(j-2)*(ni-1)+(i-2)
			else
				bound=bound+ae*us(i+1,j) !for the velocity inlet
			endif

			if (j/=nj+1) then !N
				k=k+1
				umatv(k)=-an
				umati(k)=(j-2+1)*(ni-1)+(i-2)
				umatj(k)=(j-2)*(ni-1)+(i-2)
			else
				ap=ap+mu*dx/(0.5*dy) !moving wall !*((us(i,j)-uw)/us(i,j))
				bound=mu*(uwn(i))*dx/(0.5*dy)
			endif

			if (j/=2) then !S
				k=k+1
				umatv(k)=-as
				umati(k)=(j-2-1)*(ni-1)+(i-2)
				umatj(k)=(j-2)*(ni-1)+(i-2)
			else
				ap=ap+mu*dx/(0.5*dy) !static wall
				bound=mu*(uws(i))*dx/(0.5*dy)
			endif

			k=k+1
			umatv(k)=ap/alphau!-sp
			umati(k)=(j-2)*(ni-1)+(i-2)
			umatj(k)=(j-2)*(ni-1)+(i-2)
			apu(i,j)=ap !for the pressure correction

			umrhs((j-2)*(ni-1)+(i-2))=(ps(i-1,j)-ps(i,j))*dy+((1-alphau)*ap/alphau)*us(i,j)+bound!+sc

		enddo
	enddo ! The End of U momentum

	!V momentum:

	k=0 !counter
	do j=3,nj+1
		do i=2,ni+1
			fe=rho*dy*(us(i+1,j)+us(i+1,j-1))/2
			fw=rho*dy*(us(i,j)+us(i,j-1))/2
			fs=rho*dx*(vs(i,j)+vs(i,j-1))/2
			fn=rho*dx*(vs(i,j)+vs(i,j+1))/2
			de=mu*dy/dx ; dw=mu*dy/dx ; ds=mu*dx/dy ; dn=mu*dx/dy
			!Hybrid:
			ae=max(-fe,(de-fe/2.0),0.0d0)!
			as=max(+fs,(ds+fs/2.0),0.0d0)!
			aw=max(+fw,(dw+fw/2.0),0.0d0)!
			an=max(-fn,(dn-fn/2.0),0.0d0)!
			ap=ae+as+aw+an+(fe-fw+fn-fs)

			!Matrixer:
			bound=0.0
			if (i/=2) then !W
				k=k+1
				vmatv(k)=-aw
				vmati(k)=(j-3)*(ni)+(i-1-1)
				vmatj(k)=(j-3)*(ni)+(i-1)
			else
				ap=ap+mu*dy/(0.5*dx) !stat wall
				bound=mu*(uww(j))*dy/(0.5*dx)
			endif

			if (i/=ni+1) then !E
				k=k+1
				vmatv(k)=-ae
				vmati(k)=(j-3)*(ni)+(i-1+1)
				vmatj(k)=(j-3)*(ni)+(i-1)
			else
				ap=ap+mu*dy/(0.5*dx) !stat wall
				bound=mu*(uwe(j))*dy/(0.5*dx)
				endif

			if (j/=nj+1) then !N
				k=k+1
				vmatv(k)=-an
				vmati(k)=(j-3+1)*(ni)+(i-1)
				vmatj(k)=(j-3)*(ni)+(i-1)
			else
				bound=bound+an*vs(i,j+1)
			endif

			if (j/=3) then !S
				k=k+1
				vmatv(k)=-as
				vmati(k)=(j-3-1)*(ni)+(i-1)
				vmatj(k)=(j-3)*(ni)+(i-1)
			else
				bound=bound+as*vs(i,j-1)
			endif

			k=k+1
			vmatv(k)=ap/alphav!-sp
			vmati(k)=(j-3)*(ni)+(i-1)
			vmatj(k)=(j-3)*(ni)+(i-1)

			apv(i,j)=ap

			vmrhs((j-3)*(ni)+(i-1))=(ps(i,j-1)-ps(i,j))*dx+((1-alphav)*ap/alphav)*vs(i,j)+bound!+sc

		enddo
	enddo ! End of V momentum

	!Solve U & V, then set results in U* & V*:
2	format(a3,$)
	write(*,2) "U "
	call bicgstab(umatv,umati,umatj,unnzero,umrhs,un,x,bires,bimaxit)
	do k=1,un
		us(mod(k-1,ni-1)+1+2,int((k-1)/(ni-1))+2)=x(k)
	enddo

	write(*,2) "V "
	call bicgstab(vmatv,vmati,vmatj,vnnzero,vmrhs,vn,x,bires,bimaxit)
	do k=1,vn
		vs(mod(k-1,ni)+1+1,int((k-1)/(ni))+3)=x(k)
	enddo

	!Boundary Velocity Correction for Peressure BCs:
	do j=2,nj+1
		if (pbcw(j)==1) then !W
			us(2,j)=us(3,j)+vs(2,j+1)-vs(2,j)
		endif
		if (pbce(j)==1) then !E
			us(ni+2,j)=us(ni+1,j)+vs(ni+1,j)-vs(ni+1,j+1)
		endif
	enddo
	do i=2,ni+1
		if (pbcn(i)==1) then !N
			vs(i,nj+2)=vs(i,nj+1)+us(i,nj+1)-us(i+1,nj+1)
		endif
		if (pbcs(i)==1) then !S
			vs(i,2)=vs(i,3)+us(i,3)-us(i+1,3)
		endif
	enddo

	!Peressure Correction Equations (pp):
	k=0 !counter
	do j=2,nj+1
		do i=2,ni+1
			aw=0.0d0;ae=0.0d0;as=0.0d0;an=0.0d0;ap=0.0d0
			if (i/=2)    aw=rho*dy*dy*alphau/apu(i,j)
			if (i/=ni+1) ae=rho*dy*dy*alphau/apu(i+1,j)
			if (j/=2)    as=rho*dx*dx*alphav/apv(i,j)
			if (j/=nj+1) an=rho*dx*dx*alphav/apv(i,j+1)

			if ((i==2).and.(pbcw(j)==1)) then !P BC on W
				k=k+1
				ap=0.01d0
				pmatv(k)=ap
				pmati(k)=(j-2)*ni+(i-1)
				pmatj(k)=(j-2)*ni+(i-1)
				pmrhs((j-2)*ni+(i-1))=0.0d0
				cycle
			endif

			if ((i==ni+1).and.(pbce(j)==1)) then !P BC on E
				k=k+1
				ap=0.01d0
				pmatv(k)=ap
				pmati(k)=(j-2)*ni+(i-1)
				pmatj(k)=(j-2)*ni+(i-1)
				pmrhs((j-2)*ni+(i-1))=0.0d0
				cycle
			endif

			if ((j==2).and.(pbcs(j)==1)) then !P BC on S
				k=k+1
				ap=0.01d0
				pmatv(k)=ap
				pmati(k)=(j-2)*ni+(i-1)
				pmatj(k)=(j-2)*ni+(i-1)
				pmrhs((j-2)*ni+(i-1))=0.0d0
				cycle
			endif

			if ((j==nj+1).and.(pbcn(j)==1)) then !P BC on N
				k=k+1
				ap=0.01d0
				pmatv(k)=ap
				pmati(k)=(j-2)*ni+(i-1)
				pmatj(k)=(j-2)*ni+(i-1)
				pmrhs((j-2)*ni+(i-1))=0.0d0
				cycle
			endif

			if (i/=2) then
				k=k+1
				pmatv(k)=-aw
				pmati(k)=(j-2)*ni+(i-1-1)
				pmatj(k)=(j-2)*ni+(i-1)
			endif

			if (i/=ni+1) then
				k=k+1
				pmatv(k)=-ae
				pmati(k)=(j-2)*ni+(i-1+1)
				pmatj(k)=(j-2)*ni+(i-1)
			endif

			if (j/=2) then
				k=k+1
				pmatv(k)=-as
				pmati(k)=(j-2-1)*ni+(i-1)
				pmatj(k)=(j-2)*ni+(i-1)
			endif

			if (j/=nj+1) then
				k=k+1
				pmatv(k)=-an
				pmati(k)=(j-2+1)*ni+(i-1)
				pmatj(k)=(j-2)*ni+(i-1)
			endif

			ap=ap+ae+aw+an+as
			k=k+1
			pmatv(k)=ap
			pmati(k)=(j-2)*ni+(i-1)
			pmatj(k)=(j-2)*ni+(i-1)

			pmrhs((j-2)*ni+(i-1))=rho*dy*(us(i,j)-us(i+1,j))+rho*dx*(vs(i,j)-vs(i,j+1))

		enddo
	enddo!The end of pressure Eqns.

	!Solve Pressure Eqns.:
	write(*,2) "P "
	call bicgstab(pmatv,pmati,pmatj,k,pmrhs,pn,x,bires,bimaxit) !pnnzero->k (for press BCs) !! DON'T change k
	do k=1,pn
		pp(mod(k-1,ni)+1+1,int((k-1)/(ni))+1+1)=x(k)
	enddo

	!Continuity Residual Calculation:
	contres=sqrt(dot_product(pmrhs,pmrhs))/pn
	print*,"SIMPLE Iter=",ti,"Continuity Res.=",contres
	write(2,*),ti,contres

	!New Pressure with Corrections (PP):
	do j=2,nj+1
		do i=2,ni+1
			ps(i,j)=ps(i,j)+pp(i,j)*alphap
		enddo
	enddo

	!New U from pressure field:
	do j=2,nj+1
		do i=3,ni+1
			us(i,j)=us(i,j)+(dy*alphau/apu(i,j))*(pp(i-1,j)-pp(i,j))
		enddo
	enddo

	!New V from pressure field:
	do j=3,nj+1
		do i=2,ni+1
			vs(i,j)=vs(i,j)+(dx*alphav/apv(i,j))*(pp(i,j-1)-pp(i,j))
		enddo
	enddo

	if (contres<creslimit) exit !Convergance Checker (by the Continuity Residual)
enddo !!SIMPLE Loop

!Writing Results:
!Extrapolate the P, U & V For Walls:
ps(1,:)=1.5*ps(2,:)-0.5*ps(3,:)
ps(ni+2,:)=1.5*ps(ni+1,:)-0.5*ps(ni,:)
ps(:,1)=1.5*ps(:,2)-0.5*ps(:,3)
ps(:,nj+2)=1.5*ps(:,nj+1)-0.5*ps(:,nj)
us(1,:)=us(2,:);us(ni+3,:)=us(ni+2,:)
vs(:,1)=vs(:,2);vs(:,nj+3)=vs(:,nj+2)
us(:,1)=uws(:);us(:,nj+2)=uwn(:)
do j=1,nj+2
	vs(1,j)=uww(j)
	vs(ni+2,j)=uwe(j)
enddo

!Writing to File:
write(1,*) "VARIABLES= X,Y,U,V,P" !Tecplot header
write(1,*) "ZONE I=",ni+2,",J=",nj+2,",F=POINT"
do j=1,nj+2
	do i=1,ni+2
		idx=0.0d0;jdy=0.0d0!first mesh & last mesh correction
		if (i>1) idx=-dx/2.0d0
		if (i==ni+2) idx=-dx
		if (j>1) jdy=-dy/2.0d0
		if (j==nj+2) jdy=-dy
		write(1,*) (i-1)*dx+idx,(j-1)*dy+jdy,(us(i,j)+us(i+1,j))/2.0,(vs(i,j)+vs(i,j+1))/2.0,ps(i,j)
	enddo
	write(3,*) (j-1)*dy+jdy,"	",(us(ni/2,j)+us(ni/2+1,j))/2.0
enddo
close(1) !"Result.plt"

close(2) !"Residual.plt"

pause "Press any key to exit"
stop
end

![A].b calculater with sparse efficient algorithm (used in BiCGSTAB subroutine):
subroutine matvec(a,ai,aj,nnzero,b,n,c)
	implicit none
	INTEGER, INTENT(inout) :: n !n*n
	INTEGER, INTENT(inout) :: nnzero !none zero
	REAL*8,  INTENT(inout), DIMENSION(1:nnzero) :: a  !A matrix
	INTEGER, INTENT(inout), DIMENSION(1:nnzero) :: ai  !A matrix i
	INTEGER, INTENT(inout), DIMENSION(1:nnzero) :: aj  !A matrix j
	REAL*8,  INTENT(inout), DIMENSION(1:n) :: b !b vector (right hand side)
	REAL*8,  INTENT(inout), DIMENSION(1:n) :: c !Answer vector
	integer i
	c=0.0d0
	do i=1,nnzero
		c(aj(i))=c(aj(i))+a(i)*b(ai(i))
	enddo
endsubroutine

!To solve [A].[x]=[b] system of equations by BiCGSTAB method:
subroutine bicgstab(a,ai,aj,nnzero,b,n,x,bires,bimaxit)
	implicit none
	INTEGER, INTENT(inout) :: n  !Matrix size (n*n)
	INTEGER, INTENT(inout) :: nnzero !No. of none zero elements in [A]
	real*8,  INTENT(inout) :: bires !Max. Residual to converge
	INTEGER, INTENT(inout) :: bimaxit !Max. iterations
	REAL*8,  INTENT(inout), DIMENSION(1:nnzero) :: a  !A matrix
	INTEGER, INTENT(inout), DIMENSION(1:nnzero) :: ai  !A matrix i
	INTEGER, INTENT(inout), DIMENSION(1:nnzero) :: aj  !A matrix j
	REAL*8,  INTENT(inout), DIMENSION(1:n) :: b !Right hand side
	REAL*8,  INTENT(inout), DIMENSION(1:n) :: x !Answer

	allocatable temp(:),r0(:),r(:),p(:),s(:),rr(:)
	integer i
	real(8) temp,r0,r,p,alpha,s,w,rr,beta,res
	allocate (temp(1:n),r0(1:n),r(1:n),p(1:n),s(1:n),rr(1:n))
	i=0

	!BiCGSTAB Algorithm:
	!1:
	x=0.0 !First Guess

	call matvec(a,ai,aj,nnzero,x,n,temp)
	r0=b-temp

	!2:
	p=r0
	r=r0

	!3:
	do
		i=i+1

		!4:
		call matvec(a,ai,aj,nnzero,p,n,temp)
		alpha=(dot_product(r,r0))/(dot_product(temp,r0))

		!5:
		s=r-alpha*temp

		!6:
		call matvec(a,ai,aj,nnzero,s,n,temp)
		w=(dot_product(temp,s))/(dot_product(temp,temp))

		!7:
		x=x+alpha*p+w*s

		!8:
		rr=s-w*temp

		!9:
		beta=((dot_product(rr,r0))/(dot_product(r,r0)))*(alpha/w)

		!10:
		call matvec(a,ai,aj,nnzero,p,n,temp)
		p=rr+beta*(p-w*temp)

		!11:
		r=rr

		!12:
		res=dsqrt(dot_product(r,r))/n

		if ((res<bires).or.(i>bimaxit)) then !Convergance or Max iterations Checking
			print*,"BiCGSTAB Res.=",res ,"by",i,"iters"
			exit
		endif
	enddo

endsubroutine


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0
real(dp), parameter :: stop_time = 5.0
!real(dp), parameter :: stop_time = 0.0

real(dp), parameter :: CFL = 0.8_dp

real(dp), parameter :: beta = 0.5

real(dp), parameter :: dt_checkpoint = 5e-1_dp

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

real(dp), parameter :: dt_analyze = dt_checkpoint

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 1.5

real(dp), parameter :: xlim(2) = diameter * ((/0.0,1.0/) - 0.0)
real(dp), parameter :: ylim(2) = diameter * ((/0.0,1.0/) - 0.0)

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

real(dp), parameter :: bell_mass  = 0.5_dp
!real(dp), parameter :: bell_sigma = 2 * 7.5e-3_dp
real(dp), parameter :: bell_sigma = 2.0e-2_dp

real(dp), parameter :: blast_energy = 1.0_dp
!real(dp), parameter :: blast_sigma = 2 * 5.0e-3_dp
!real(dp), parameter :: blast_sigma = 2 * 5.0e-3_dp
real(dp), parameter :: blast_sigma = 3.0e-2_dp

real(dp), parameter :: bell_mass_normalized = bell_mass/SQRT((2*pi)**N_DIMS)/bell_sigma**N_DIMS
real(dp), parameter :: blast_ener_normalized = blast_energy/SQRT((2*pi)**N_DIMS)/blast_sigma**N_DIMS

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

real(dp), parameter :: dens0 = 1e-0_dp
!real(dp), parameter :: pres0 = 1e-5_dp
real(dp), parameter :: pres0 = 1e-5_dp

real(dp), parameter :: velx0 = 0.0
real(dp), parameter :: vely0 = 0.0

!real(dp), parameter :: kappa = 7.0_dp/5.0_dp
real(dp), parameter :: kappa = 1.4_dp

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

integer, parameter :: mesh_minlevel = 6
integer, parameter :: mesh_maxlevel = 6

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.3*dens0
real(dp), parameter :: dens_coarse_threshold = 1.2*dens0

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


PROGRAM LA_DSPGVD_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_SPGVD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, INFO, N, NS
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:), BB(:), W(:)
   REAL(WP), ALLOCATABLE :: A(:), B(:), Z(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'DSPGVD ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N
   PRINT *, 'N = ', N
   NS = N*(N+1)/2
   ALLOCATE ( A(NS), AA(NS), B(NS), BB(NS), W(N), Z(N,N) )
!
      READ (NIN, *) AA, BB
   A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE (NOUT,*) 'J = ', I; WRITE (NOUT,FMT) (A(J+(I-1)*I/2),J=1,I)
      ENDDO
      WRITE(NOUT,*) 'The matrix B:'
      DO I = 1, N
        WRITE (NOUT,*) 'J = ', I; WRITE (NOUT,FMT) (B(J+(I-1)*I/2),J=1,I)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_DSPGVD LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, 1, ''U'', Z, INFO )'
   A=AA; B=BB
   CALL LA_SPGVD( A, B, W, 1, 'U', Z, INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, 2, ''U'', Z )'
   A=AA; B=BB
   CALL LA_SPGVD( A, B, W, 2, 'U', Z )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, 3, Z=Z )'
   A=AA; B=BB
   CALL LA_SPGVD( A, B, W, 3, Z=Z )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, UPLO=''L'', Z=Z, INFO=INFO )'
   A=AA; B=BB; W = HUGE(1.0_WP); Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B, W, UPLO='L', Z=Z, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A(1:5), B, W, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A(1:5), B, W, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B(1:5), W, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B(1:5), W, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W(1:N-1), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B, W(1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, 5, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B, W, 5, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, UPLO=''9'', INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B, W, UPLO='9', INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, Z=Z(1:N-1,:), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B, W, Z=Z(1:N-1,:), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVD( A, B, W, Z=Z(:,1:N-1), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVD( A, B, W, Z=Z(:,1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!
END PROGRAM LA_DSPGVD_ET_EXAMPLE


!----------------------------------------
subroutine norm(x, res, k0, k1, j0, j1, i0, i1, l, m, n)
  !
  ! compute the sum of x**2 in the interior domain
  ! (excluding the halo)
  !
  implicit none

  integer, intent(in):: l, m, n
  integer, intent(in):: k0, k1, j0, j1, i0, i1
  real*8, dimension(l, m, n), intent(in) :: x
  real*8, intent(out) :: res

  !!!!f2py intent(inplace):: x

  integer:: i, j, k

  res = 0.
  do k = k0+1, k1
     do j = j0+1, j1
        do i = i0+1, i1
           res = res+ x(k,j,i)*x(k,j,i)
        enddo
     enddo
  enddo

end subroutine norm


program generate_list_neighbours
! given a point find all neighbouring points

! use the sphere_tesselate module
! (this is what we want to test after all)
use sphere_tesselate

! implicit none as always
implicit none

! declare a tesselation which defines our icosahedron
! (kind of like a mesh)
type(tesselation) :: tess
type(point) :: pt
type(triangle) :: tr
type(list_neighbours) :: lnbrs
integer :: pt_id

! build the icosadron with the following arguments:
! -- level = 0
! -- shape = icosahedron
! -- point at poles = true
tess = st_new(2,'ico',.true.)

write (*,*) 'Calling st_generate_list_neighbours'
call st_generate_list_neighbours(tess,lnbrs)

! show some elements in the list
pt_id = 98
write(*,*) 'pt_id:',pt_id
write(*,*) 'neighbours:',lnbrs%list(pt_id)%idxs

! show whole list
! do pt_id = 1,13
! write(*,*) 'whole list:',lnbrs%list(pt_id)%idxs
! end do

end program


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! This test case is test for power operator (int precision).
! The result of power using base -1 depends on the parity of the exponent.

program test
  integer :: i1, i2, res(6)
  integer(kind = 8) :: i2_8
  integer :: eres(6) = [1, 1, -1, -1, 0, 0]

  i2 = -8
  i1 = -1
  res(1) = i1 ** i2
  res(2) = i1 ** (-8)

  i2 = -7
  i1 = -1
  res(3) = i1 ** i2
  res(4) = i1 ** -7

  i2 = -7
  i1 = -2
  res(5) = i1 ** i2
  res(6) = i1 ** -7

  call check(res, eres, 6)
end


program diffusion
use, intrinsic :: iso_fortran_env, only : dp => REAL64, error_unit
use :: mpi
implicit none
integer, parameter :: MEM_ALLOC_ERR = 1
integer, parameter :: default_n = 5, nr_dims = 2, nr_iters = 500
real(kind=dp), parameter :: tol = 1.0e-4_dp
integer :: ierr, iter_nr, n, comm_rank, comm_size
real(Kind=dp), dimension(:, :), allocatable :: new_temp, temp
character(len=1024) :: buffer
integer, dimension(nr_dims) :: dims
logical, dimension(nr_dims) :: periodic
logical :: reorder
integer :: cart_comm, row_type, col_type
real(kind=dp) :: delta, avg_temp

! setup MPI and get size and initial rank
call MPI_Init(ierr)
call MPI_Comm_size(MPI_COMM_WORLD, comm_size, ierr)
call MPI_Comm_rank(MPI_COMM_WORLD, comm_rank, ierr)

! setup Carthesian communicator
dims = 0
periodic = .true.
reorder = .true.
call MPI_Dims_create(comm_size, nr_dims, dims, ierr)
call MPI_Cart_create(MPI_COMM_WORLD, nr_dims, dims, periodic, reorder, &
                     cart_comm, ierr)
call MPI_Comm_rank(cart_comm, comm_rank, ierr)

! rank 0 handles command line arguments, and broadcasts them to other
! ranks
if (comm_rank == 0) then
    if (command_argument_count() == 1) then
        call get_command_argument(1, buffer)
        read (buffer, '(I5)') n
    else
        n = default_n
    end if
end if
call MPI_Bcast(n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

! create and register types
call create_types(row_type, col_type, n)

! create and initialize local arrays for temperature and old temperature
call allocate_matrix(temp, n)
call init_matrix(temp)
call allocate_matrix(new_temp, n)

! allow diffusion until changes are smaller than tolerance, or the maximum
! number of iterations is exceeded
delta = 0.0_dp
do iter_nr = 1, nr_iters
    if (mod(iter_nr, 2) == 0) then
        call halo_exchange(new_temp, cart_comm, row_type, col_type)
        call update_matrix(new_temp, temp, delta)
    else
        call halo_exchange(temp, cart_comm, row_type, col_type)
        call update_matrix(temp, new_temp, delta)
    end if
    if (delta < tol) exit
end do

! compute average temperature
call compute_avg(temp, avg_temp, cart_comm)

! process 0 will report
if (comm_rank == 0) then
    print '(I0, A, A, E15.5, A, E15.5)', iter_nr - 1, ' iterations ', &
        ' with delta = ', delta, ', average temp. = ', avg_temp
end if

deallocate(temp)
deallocate(new_temp)

! take down MPI
call MPI_Comm_free(cart_comm, ierr)
call MPI_Type_free(row_type, ierr)
call MPI_Type_free(col_type, ierr)
call MPI_Finalize(ierr)

contains

! routine to allocate an nxn matrix
    subroutine allocate_matrix(matrix, n)
        implicit none
        real(kind=dp), dimension(:, :), allocatable, intent(inout) :: matrix
        integer, intent(in) :: n
        allocate(matrix(n, n), stat=ierr)
        if (ierr /= 0) then
            write (error_unit, '(A, I0)') &
                'can not allocate temp in ', comm_rank
            call MPI_Abort(MPI_COMM_WORLD, MEM_ALLOC_ERR, ierr)
        end if
    end subroutine allocate_matrix

! create MPI types for halo exchange
    subroutine create_types(row_type, col_type, n)
        implicit none
        integer, intent(inout) :: row_type, col_type
        integer, intent(in) :: n
        integer :: ierr
        call MPI_Type_vector(n, 1, n, MPI_DOUBLE_PRECISION, row_type, ierr)
        call MPI_Type_commit(row_type, ierr)
        call MPI_type_contiguous(n, MPI_DOUBLE_PRECISION, col_type, ierr)
        call MPI_Type_commit(col_type, ierr)
     end subroutine create_types

! initialize a matrix, mostly to zero, some elements randomly to a
! non-zero value
    subroutine init_matrix(matrix)
        implicit none
        real(kind=dp), dimension(:, :), intent(inout) :: matrix
        real(kind=dp), parameter :: min_val = 0.0_dp, max_val = 1.0_dp, &
                                    prob = 0.1_dp
        integer :: i, j
        real(kind=dp) :: r
        do j = 1, size(matrix, 2)
            do i = 1, size(matrix, 1)
                call random_number(r)
                if (r < prob) then
                    matrix(i, j) = max_val
                else
                    matrix(i, j) = min_val
                end if
            end do
        end do
    end subroutine init_matrix

! perform a single update step for the diffusion
    subroutine update_matrix(matrix, new_matrix, delta)
        implicit none
        real(kind=dp), dimension(:, :), intent(in) :: matrix
        real(kind=dp), dimension(:, :), intent(inout) :: new_matrix
        real(kind=dp), intent(out) :: delta
        real(kind=dp), parameter :: delta_t = 0.01_dp
        integer :: i, j
        delta = 0.0_dp
        do j = 2, size(matrix, 2) - 1
            do i = 2, size(matrix, 1) - 1
                new_matrix(i, j) = 0.25_dp*(matrix(i - 1, j) + &
                                            matrix(i + 1, j) + &
                                            matrix(i, j - 1) + &
                                            matrix(i, j + 1))
                delta = max(delta, abs(new_matrix(i, j) - matrix(i, j)))
            end do
        end do
    end subroutine update_matrix

    subroutine halo_exchange(matrix, comm, row_type, col_type)
        implicit none
        real(kind=dp), dimension(:, :), intent(inout) :: matrix
        integer, intent(in) :: comm, row_type, col_type
        integer, parameter :: tag = 17
        integer :: up, right, down, left, comm_rank, ierr, nr_rows, nr_cols
        nr_rows = size(matrix, 1)
        nr_cols = size(matrix, 2)
        call MPI_Comm_rank(comm, comm_rank, ierr)
        call MPI_Cart_shift(comm, 0, 1, left, right, ierr)
        call MPI_Cart_shift(comm, 1, 1, up, down, ierr)
        call MPI_Sendrecv(matrix(2, 1), 1, row_type, up, tag, &
                          matrix(1, 1), 1, row_type, down, tag, &
                          comm, MPI_STATUS_IGNORE, ierr)
        call MPI_Sendrecv(matrix(nr_rows - 1, 1), 1, row_type, down, tag, &
                          matrix(nr_rows, 1), 1, row_type, up, tag, &
                          comm, MPI_STATUS_IGNORE, ierr)
        call MPI_Sendrecv(matrix(1, 2), 1, col_type, left, tag, &
                          matrix(1, 1), 1, col_type, right, tag, &
                          comm, MPI_STATUS_IGNORE, ierr)
        call MPI_Sendrecv(matrix(1, nr_cols - 1), 1, col_type, right, tag, &
                          matrix(1, nr_cols), 1, col_type, left, tag, &
                          comm, MPI_STATUS_IGNORE, ierr)
    end subroutine halo_exchange

! compute the local average, and compute global average in rank 0
    subroutine compute_avg(matrix, avg, comm)
        implicit none
        real(kind=dp), dimension(:, :), intent(in) :: matrix
        real(kind=dp), intent(out) :: avg
        integer, intent(in) :: comm
        real(kind=dp) :: local_avg
        integer :: comm_size, ierr
        call MPI_Comm_size(comm, comm_size, ierr)
        local_avg = sum(matrix)/size(matrix)
        call MPI_Reduce(local_avg, avg, 1, MPI_DOUBLE_PRECISION, MPI_SUM, &
                        0, comm, ierr)
        avg = avg/comm_size
    end subroutine compute_avg

end program diffusion


PROGRAM add_arrays

IMPLICIT NONE

INTEGER :: i
REAL, DIMENSION(4) :: a = (/ 1., 2., 3., 4./)
REAL, DIMENSION(4) :: b = (/ 5., 6., 7., 8./)
REAL, DIMENSION(4) :: c, d

! Element by element addition
DO i = 1, 4
   c(i) = a(i) + b(i)
END DO

! Whole array addition
d = a + b

! Write out results
WRITE (*,100) 'c', c
WRITE (*,100) 'd', d
100 FORMAT (' ',A,' = ',5(F6.1,1X))

END PROGRAM


! This subroutine is used to caculate Hamiltonian for
! bulk system .

  subroutine hamk_bulk_nsoc(k,Hamk_bulk)

     use para
     implicit none

     ! loop index
     integer :: i1,i2,ia,ib,ic,iR

     real(dp) :: kdotr

     ! wave vector in 2d
     real(Dp) :: k(3)

     ! coordinates of R vector
     real(Dp) :: R(3)

     ! Hamiltonian of bulk system
     complex(Dp),intent(out) ::Hamk_bulk(num_wann_soc, num_wann_soc)

     Hamk_bulk=0d0
     do iR=1, Nrpts_nsoc
        ia=irvec_nsoc(1,iR)
        ib=irvec_nsoc(2,iR)
        ic=irvec_nsoc(3,iR)

        R(1)=dble(ia)
        R(2)=dble(ib)
        R(3)=dble(ic)

        kdotr=k(1)*R(1) + k(2)*R(2) + k(3)*R(3)

        Hamk_bulk(:,:)=Hamk_bulk(:,:)&
        +HmnR_nsoc(:,:,iR)*Exp(2d0*pi*zi*kdotr)/ndegen_nsoc(iR)
     enddo

     !> check hermitcity
     do i1=1, Num_wann_soc
     do i2=1, Num_wann_soc
        if(abs(Hamk_bulk(i1,i2)-conjg(Hamk_bulk(i2,i1))).ge.1e-6)then
          write(*,*)'there are something wrong with Hamk_bulk'
          stop
        endif
     enddo
     enddo

     return
  end subroutine Hamk_bulk_nsoc

  subroutine hamk_bulk_soc(k,Hamk_bulk)

     use para
     implicit none

     ! loop index
     integer :: i1,i2,ia,ib,ic,iR

     real(dp) :: kdotr

     ! wave vector in 2d
     real(Dp) :: k(3)

     ! coordinates of R vector
     real(Dp) :: R(3)

     ! Hamiltonian of bulk system
     complex(Dp),intent(out) ::Hamk_bulk(num_wann_soc, num_wann_soc)

     Hamk_bulk=0d0
     do iR=1, Nrpts_soc
        ia=irvec_soc(1,iR)
        ib=irvec_soc(2,iR)
        ic=irvec_soc(3,iR)

        R(1)=dble(ia)
        R(2)=dble(ib)
        R(3)=dble(ic)

        kdotr=k(1)*R(1) + k(2)*R(2) + k(3)*R(3)

        Hamk_bulk(:,:)=Hamk_bulk(:,:)&
        +HmnR_soc(:,:,iR)*Exp(2d0*pi*zi*kdotr)/ndegen_soc(iR)
     enddo

     !> check hermitcity
     do i1=1, Num_wann_soc
     do i2=1, Num_wann_soc
        if(abs(Hamk_bulk(i1,i2)-conjg(Hamk_bulk(i2,i1))).ge.1e-6)then
          write(*,*)'there are something wrong with Hamk_bulk'
          stop
        endif
     enddo
     enddo

     return
  end subroutine Hamk_bulk_soc


      subroutine gridset(xface,yface,zface,rhokap,xmax,ymax,zmax,kappa)

      implicit none

      include 'grid.txt'

      real*8 xmax,ymax,zmax,kappa

      integer i,j,k
      real*8 x,y,z,rho,taueq,taupole

      print *, 'Setting up density grid....'

c**********  Linear Cartesian grid. Set up grid faces ****************
      do i=1,nxg+1
         xface(i)=(i-1)*2.*xmax/nxg
      end do
      do i=1,nyg+1
         yface(i)=(i-1)*2.*ymax/nyg
      end do
      do i=1,nzg+1
         zface(i)=(i-1)*2.*zmax/nzg
      end do

c**************  Loop through x, y, and z to set up grid density.  ****
      do i=1,nxg
       do j=1,nyg
        do k=1,nzg
           x=xface(i)-xmax+xmax/nxg
           y=yface(j)-ymax+ymax/nyg
           z=zface(k)-zmax+zmax/nzg

c**********************Call density setup subroutine
           call density(x,y,z,rho)
           rhokap(i,j,k)=rho*kappa

        end do
       end do
      end do

c****************** Calculate equatorial and polar optical depths ****
      taueq=0.
      taupole=0.
      do i=1,nxg
         taueq=taueq+rhokap(i,nyg/2,nzg/2)
      enddo
      do i=1,nzg
         taupole=taupole+rhokap(nxg/2,nyg/2,i)
      enddo
      taueq=taueq*2.*xmax/nxg
      taupole=taupole*2.*zmax/nzg
      print *,'taueq = ',taueq,'  taupole = ',taupole

c************** Write out density grid as unformatted array
      open(10,file='density.dat',status='unknown',
     +        form='unformatted')
           write(10) rhokap
      close(10)

      open(10,file='slice.dat',status='unknown')

      do i=1,nxg
        write(10,*) (rhokap(i,j,10), j=1,nyg)
      end do

c      do i=1,nxg
c       do j=1,nyg
c           x=xface(i)-xmax+xmax/nxg
c           y=yface(j)-ymax+ymax/nyg
c         write(10,*) x,y,rhokap(i,j,101)
c
c       end do
c      end do

      return
      end


      SUBROUTINE caldat(julian,mm,id,iyyy)
      INTEGER id,iyyy,julian,mm,IGREG
      PARAMETER (IGREG=2299161)
      INTEGER ja,jalpha,jb,jc,jd,je
      if(julian.ge.IGREG)then
        jalpha=int(((julian-1867216)-0.25)/36524.25)
        ja=julian+1+jalpha-int(0.25*jalpha)
      else
        ja=julian
      endif
      jb=ja+1524
      jc=int(6680.+((jb-2439870)-122.1)/365.25)
      jd=365*jc+int(0.25*jc)
      je=int((jb-jd)/30.6001)
      id=jb-jd-int(30.6001*je)
      mm=je-1
      if(mm.gt.12)mm=mm-12
      iyyy=jc-4715
      if(mm.gt.2)iyyy=iyyy-1
      if(iyyy.le.0)iyyy=iyyy-1
      return
      END

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


subroutine SHExpandGLQ(cilm, lmax, gridglq, w, plx, zero, norm, csphase, lmax_calc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will expand a grid of data (regulary spaced in longitude,
!	and irregurarly in latitude according to the Guass-Legendre quadrature points)
!	into spherical harmonics by utilizing an FFT of each latitudinal band, and a
!	Guass-Legendre Quadrature in latitute. Note that the array PLX is
!	optional, and should not be precomputed when memory is an issue (i.e., LMAX>360).
!	It is implicitly assumed that the gridded data are bandlimited to degree LMAX.
!	If the optional parameter LMAX_CALC is specified, the spherical harmonic coefficients
!	will be calculated only up to and including this degree.
!
!	If PLX is not present, the Legendre functions are computed on the fly
!	using the scaling methodolgy presented in Holmes and Featherston (2002).
!	When NORM is 1,2 or 4, these are accurate to degree 2800. When NORM is 3, the
!	routine is only stable to about degree 15.
!
!	Calling Parameters:
!		IN
!			gridglq		Gridded data used in the expansion generated
!					from a call to MakeGridGLQ, with dimensions
!					(LMAX+1, 2*LMAX+1).
!			lmax		Spherical harmonic bandwidth of the input grid.
!					If LMAX_CALC is not specified, this corresponds
!					to the maximum spherical harmonic degree of the expansion.
!			w		Gauss-Legendre points used in the integrations
!					(determined from a call to PreCompute).
!		OUT
!			cilm 		Spherical harmonic coefficients of expansion with
!					dimensions (2, LMAX+1, LMAX+1), or if LMAX_CAL is
!					present (2, LMAX_CALC+1, LMAX_CALC+1).
!		OPTIONAL (IN)
!			plx		Input array of Associated Legendre Polnomials computed
!					at the Gauss-Legendre points (determined from a call to
!					PreCompute). If this is not included, then the optional
!					array ZERO MUST be inlcuded.
!			zero		Array of dimension LMAX+1 that contains the latitudinal
!					gridpoints used in the Gauss-Legendre quadrature integration
!					scheme, calculated from a call to PreCompute. This is only
!					needed if PLX is not given.
!			norm		Normalization to be used when calculating the Legendre functions
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!			csphase		1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!			lmax_calc	The maximum spherical harmonic degree calculated in the
!					spherical harmonic expansion.
!
!	Dependencies:	FFTW3, NGLQSH, CSPHASE_DEFAULT
!
!	Written by Mark Wieczorek (October 2003)
!
!	September 3, 2005. 	Modifed so that the array plx is now optional.
!	September 26, 2005. 	Added optional argument NORM.
!	October 16, 2006. 	The Legendre functions are now computed within this program
!				during the summations over l and m. This leads to an increase in speed
!				of about a factor of 2.
!	July 23, 2007.		Added optional argument LMAX_CALC.
!	August 18, 2009.	Fixed bug that could have given incorrect results when LMAX_CAlC = 0
!	November 21, 2011	Fixed problem where saved variables used in Plm recursion were not recalculated
!				if NORM changed from one call to the next (with the same value of N).
!
!	Copyright (c) 2005-2011, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use FFTW3
	use SHTOOLS, only: NGLQSH, CSPHASE_DEFAULT

	implicit none
	real*8, intent(in) ::	w(:), gridglq(:,:)
	real*8, intent(in), optional ::	plx(:,:), zero(:)
	real*8, intent(out) ::	cilm(:,:,:)
	integer, intent(in) ::	lmax
	integer, intent(in), optional :: norm, csphase, lmax_calc
	integer :: 		nlong, nlat, i, l, m, k, kstart, l1, m1, phase, i_s, astat(4), &
				lnorm, lmax_comp
	real*8 :: 		pi, gridl(2*lmax+1), prod, scalef, rescalem, u, p, pmm, &
				pm1, pm2, z, fcoef1(2, lmax+1), fcoef2(2, lmax+1)
	complex*16 ::		cc(lmax+1)
	integer*8 :: 		plan
	real*8, save, allocatable ::	f1(:), f2(:), sqr(:), symsign(:)
	integer, save ::	lmax_old=0, norm_old = 0

	if (present(lmax_calc)) then
		lmax_comp = min(lmax, lmax_calc)
	else
		lmax_comp = lmax
	endif

	if (present(lmax_calc)) then
		if (lmax_calc > lmax) then
			print*, "Error --- SHExpandGLQ"
			print*, "LMAX_CALC must be less than or equal to the effective bandwidth of GRID."
			print*, "Effective bandwidth of GRID = N/2 - 1 = ", lmax
			print*, "LMAX_CALC = ", lmax_calc
			stop
		endif
	endif

	if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax_comp+1 .or. size(cilm(1,1,:)) < lmax_comp+1) then
		print*, "Error --- SHExpandGLQ"
		print*, "CILM must be dimensioned as (2, LMAX_COMP+1, LMAX_COMP+1) where"
		print*, "LMAX_COMP = MIN(LMAX+1, LMAX_CALC+1)"
		print*, "LMAX = ", lmax
		if (present(lmax_calc)) print*, "LMAX_CALC = ", lmax_calc
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	elseif (size(gridglq(1,:)) < 2*lmax+1 .or. size(gridglq(:,1)) < lmax+1 ) then
		print*, "Error --- SHExpandGLQ"
		print*, "GRIDGLQ must be dimensioned as (LMAX+1, 2*LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(gridglq(:,1)), size(gridglq(1,:))
		stop
	elseif (size(w) < lmax+1) then
		print*, "Error --- SHExpandGLQ"
		print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(w)
		stop
	endif

	if (present(plx)) then
		if (size(plx(:,1)) < lmax+1 .or. size(plx(1,:)) < (lmax+1)*(lmax+2)/2) then
			print*, "Error --- SHExpandGLQ"
			print*, "PLX must be dimensioned as (LMAX+1, (LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
			print*, "Input array is dimensioned as ", size(plx(:,1)), size(plx(1,:))
			stop
		endif
	elseif (present(zero)) then
		if (size(zero) < lmax+1) then
			print*, "Error --- SHExpandGLQ"
			print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
			print*, "Input array is dimensioned ", size(zero)
			stop
		endif
	else
		print*, "Error --- SHExpandGLQ"
		print*, "Either PLX or ZERO must be specified."
		stop
	endif

	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error - SHExpandGLQ"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif

		lnorm = norm

	else
		lnorm = 1
	endif

	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "Error --- SHExpandGLQ"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

	nlong = 2*(lmax+1) -1	! This is the number of points (and period) used
				! in the FFT in order that m=0 to lmax.

	nlat = NGLQSH(lmax)	! nlat = lmax+1

	pi = acos(-1.0d0)

	cilm = 0.0d0

	scalef = 1.0d-280

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate recursion constants used in computing the Legendre polynomials
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if ( (lmax_comp /= lmax_old .or. lnorm /= norm_old) .and. .not. present(plx) ) then

		if (allocated(sqr)) deallocate(sqr)
		if (allocated(f1)) deallocate(f1)
		if (allocated(f2)) deallocate(f2)
		if (allocated(symsign)) deallocate(symsign)

		allocate(sqr(2*lmax_comp+1), stat=astat(1))
		allocate(f1((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(2))
		allocate(f2((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(3))
		allocate(symsign((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(4))

		if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /= 0) then
			print*, "Error --- SHExpandGLQ"
			print*, "Problem allocating arrays SQR, F1, F2, or SYMSIGN", astat(1), astat(2), astat(3), astat(4)
			stop
		endif

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Calculate signs used for symmetry of Legendre functions about equator
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 0
		do l = 0, lmax_comp, 1
			do m = 0, l, 1
				k = k + 1
				if (mod(l-m,2) == 0) then
					symsign(k) = 1.0d0
				else
					symsign(k) = -1.0d0
				endif
			enddo
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	Precompute square roots of integers that are used several times.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l=1, 2*lmax_comp+1
			sqr(l) = sqrt(dble(l))
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Precompute multiplicative factors used in recursion relationships
		! 		P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
		!		k = l*(l+1)/2 + m + 1
		!	Note that prefactors are not used for the case when m=l as a different
		!	recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m) is assumed to be zero.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 1

		select case(lnorm)

			case(1,4)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = sqr(3)
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
					f2(k) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                				f2(k) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                  				 	/ sqr(2*l-3) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(2)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = 1.0d0
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  				f2(k) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(3)

				do l=1, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-1, 1
						k = k+1
						f1(k) = dble(2*l-1) / dble(l-m)
                  				f2(k) = dble(l+m-1) / dble(l-m)
					enddo
					k = k + 1
				enddo

		end select

		lmax_old = lmax_comp
		norm_old = lnorm

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Create generic plan for gridl
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dfftw_plan_dft_r2c_1d_(plan, nlong, gridl(1:nlong), cc, FFTW_MEASURE)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Determine Cilms, one l at a time I by integrating over all
	!	latitudes using Gauss-Legendre Quadrature. When PLX is not
	!	present, the Legendre functions are computed on the fly
	!	during the summations over l and m. These are scaled using
	!	the methodology of Holmesand Featherstone (2002), with the
	!	exception of the m=0 terms that do not need to be scaled
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(plx)) then

		do i=1, nlat

			gridl(1:nlong) = gridglq(i,1:nlong)
			call dfftw_execute_(plan)				! take fourier transform
			fcoef1(1,1:lmax+1) = 2.0d0 * w(i) * pi * dble(cc(1:lmax+1)) / dble(nlong)
			fcoef1(2,1:lmax+1) = -2.0d0 * w(i) * pi * dimag(cc(1:lmax+1)) / dble(nlong)

			k = 0
			do l = 0, lmax_comp, 1
				l1 = l + 1
				do m = 0, l, 1
					m1 = m+1
					k = k + 1
					cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + plx(i,k) * fcoef1(1:2,m1)
				enddo
			enddo
		enddo

	else

		do i=1, (nlat+1)/2

			if (i == (nlat+1)/2 .and. mod(nlat,2) /= 0) then		! This latitude is the equator; z=0, u=1

				gridl(1:nlong) = gridglq(i,1:nlong)
				call dfftw_execute_(plan)				! take fourier transform
				fcoef1(1,1:lmax+1) = 2.0d0 * w(i) * pi * dble(cc(1:lmax+1)) / dble(nlong)
				fcoef1(2,1:lmax+1) = -2.0d0 * w(i) * pi * dimag(cc(1:lmax+1)) / dble(nlong)

				u = 1.0d0

				select case(lnorm)
					case(1,2,3);	pm2 = 1.0d0
					case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
				end select

				cilm(1,1,1) = cilm(1,1,1) + pm2 * fcoef1(1,1)

				if (lmax_comp == 0) cycle

				k = 2

				do l=2, lmax_comp, 2
					l1 = l+1
					k = k+l
					p = - f2(k) * pm2
					pm2 = p
					cilm(1,l1,1) = cilm(1,l1,1) + p * fcoef1(1,1)
					k = k + l + 1
				enddo

				select case(lnorm)
					case(1,2);	pmm = sqr(2) * scalef
					case(3);	pmm = scalef
					case(4);	pmm = sqr(2) * scalef / sqrt(4.0d0*pi)
				end select

				rescalem = 1.0d0/scalef
				kstart = 1

				do m = 1, lmax_comp-1, 1

					m1 = m + 1
					kstart = kstart+m+1

					select case(lnorm)
						case(1,4)
							pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
							pm2 = pmm
						case(2)
							pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
							pm2 = pmm / sqr(2*m+1)
						case(3)
							pmm = phase * pmm * dble(2*m-1)
							pm2 = pmm
					end select

					fcoef1(1:2,m1) = fcoef1(1:2,m1) * rescalem

					cilm(1:2,m1,m1) = cilm(1:2,m1,m1) + pm2 * fcoef1(1:2,m1)

					k = kstart+m+1

					do l = m+2, lmax_comp, 2
						l1 = l+1
						k = k+l
                  				p = - f2(k) * pm2
                  				pm2 = p
						cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + p * fcoef1(1:2,m1)
						k = k + l + 1
					enddo

				enddo

            			select case(lnorm)
            				case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            				case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            				case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        			end select

        			cilm(1:2,lmax_comp+1,lmax_comp+1) = cilm(1:2,lmax_comp+1,lmax_comp+1) &
        					+ pmm * fcoef1(1:2,lmax_comp+1)

			else

				z = zero(i)
				u = sqrt( (1.0d0-z) * (1.0d0+z) )

				gridl(1:nlong) = gridglq(i,1:nlong)
				call dfftw_execute_(plan)
				fcoef1(1,1:lmax+1) = 2.0d0 * w(i) * pi * dble(cc(1:lmax+1)) / dble(nlong)
				fcoef1(2,1:lmax+1) = -2.0d0 * w(i) * pi * dimag(cc(1:lmax+1)) / dble(nlong)

				i_s = nlat + 1 - i	! point symmetric about the equator

				gridl(1:nlong) = gridglq(i_s,1:nlong)
				call dfftw_execute_(plan)
				fcoef2(1,1:lmax+1) = 2.0d0 * w(i_s) * pi * dble(cc(1:lmax+1)) / dble(nlong)
				fcoef2(2,1:lmax+1) = -2.0d0 * w(i_s) * pi * dimag(cc(1:lmax+1)) / dble(nlong)

				select case(lnorm)
					case(1,2,3);	pm2 = 1.0d0
					case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
				end select

				cilm(1,1,1) = cilm(1,1,1) + pm2 * (fcoef1(1,1) + fcoef2(1,1) )
				! symsign(1) = 1

				if (lmax_comp == 0) cycle

				k = 2
				pm1 =  f1(k) * z * pm2
				cilm(1,2,1) = cilm(1,2,1) + pm1 * ( fcoef1(1,1) - fcoef2(1,1) )
				! symsign(2) = -1

				do l=2, lmax_comp, 1
					l1 = l+1
					k = k+l
					p = f1(k) * z * pm1 - f2(k) * pm2
					pm2 = pm1
					pm1 = p
					cilm(1,l1,1) = cilm(1,l1,1) + p * ( fcoef1(1,1) + fcoef2(1,1) * symsign(k) )
				enddo

				select case(lnorm)
					case(1,2);	pmm = sqr(2) * scalef
					case(3);	pmm = scalef
					case(4);	pmm = sqr(2) * scalef / sqrt(4.0d0*pi)
				end select

				rescalem = 1.0d0/scalef
				kstart = 1

				do m = 1, lmax_comp-1, 1

					m1 = m+1
					rescalem = rescalem * u
					kstart = kstart+m+1

					select case(lnorm)
						case(1,4)
							pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
							pm2 = pmm
						case(2)
							pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
							pm2 = pmm / sqr(2*m+1)
						case(3)
							pmm = phase * pmm * dble(2*m-1)
							pm2 = pmm
					end select

					fcoef1(1:2,m1) = fcoef1(1:2,m1) * rescalem
					fcoef2(1:2,m1) = fcoef2(1:2,m1) * rescalem

					cilm(1:2,m1,m1) = cilm(1:2,m1,m1) + pm2 * &
							( fcoef1(1:2,m1) + fcoef2(1:2,m1) )
					! symsign(kstart) = 1

					k = kstart+m+1
	   				pm1 = z * f1(k) * pm2

	   				cilm(1:2,m1+1,m1) = cilm(1:2,m1+1,m1) + pm1 * &
               						( fcoef1(1:2,m1) - fcoef2(1:2,m1) )
               				! symsign(k) = -1

					do l = m+2, lmax_comp, 1
						l1 = l+1
						k = k+l
                  				p = z * f1(k) * pm1-f2(k) * pm2
                  				pm2 = pm1
                  				pm1 = p
						cilm(1:2,l1,m1) = cilm(1:2,l1,m1) + p * &
								( fcoef1(1:2,m1) + fcoef2(1:2,m1) * symsign(k) )
					enddo

				enddo

				rescalem = rescalem * u

            			select case(lnorm)
            				case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            				case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            				case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        			end select

        			cilm(1:2,lmax_comp+1,lmax_comp+1) = cilm(1:2,lmax_comp+1,lmax_comp+1) + pmm * &
        						( fcoef1(1:2,lmax_comp+1) + fcoef2(1:2,lmax_comp+1) )
        						! symsign = 1

			endif
		enddo

	endif

	call dfftw_destroy_plan_(plan)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Divide by integral of Ylm*Ylm
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	select case(lnorm)

		case(1)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) / (4.0d0*pi)
			enddo

		case(2)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = dble(2*l+1) * cilm(1:2,l+1, 1:l+1) / (4.0d0*pi)
			enddo

		case(3)

			do l=0, lmax_comp, 1
				prod = 4.0d0*pi/dble(2*l+1)
				cilm(1,l+1,1) = cilm(1,l+1,1) / prod
				prod = prod / 2.0d0
				do m=1, l-1, 1
					prod = prod * dble(l+m) * dble(l-m+1)
					cilm(1:2,l+1,m+1) = cilm(1:2,l+1,m+1) / prod
				enddo
				!do m=l case
				if (l /= 0) cilm(1:2,l+1,l+1) = cilm(1:2,l+1, l+1)/(prod*dble(2*l))
			enddo

	end select

end subroutine SHExpandGLQ


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

program sensitivity

  use forlab, only: IPRE, RPRE, CLEN, progress_perc, split_argument, &
    num2str, rng, linspace, mean, savebin, tic, toc
  use benchmark_functions, only: BenchmarkFunction
  use stochoptim, only: Evolutionary
#ifdef do_mpi
  use mpi
#endif

  implicit none

  ! Inputs
  integer(kind = IPRE) :: n_dim, popfactor, max_iter, max_run, seed, verbose, nx, ny
  real(kind = RPRE) :: w, c, gamma, F, CR, sigma, mu_perc, xmin, xmax, ymin, ymax
  character(len = :), allocatable :: solver, func, xaxis_name, yaxis_name

  ! Local variables
  integer(kind = IPRE) :: popsize, n_run, i, j, counter
  real(kind = RPRE), dimension(:), allocatable :: xaxis, yaxis
  real(kind = RPRE), dimension(:,:,:), allocatable :: Z
  character(len = 18) :: attributes
  type(Evolutionary) :: ea
  type(BenchmarkFunction) :: bf

  ! MPI variables
  integer(kind = IPRE) :: master = 0, rank, ierr, iprv

  ! Initialize MPI
#ifdef do_mpi
  call mpi_init_thread(mpi_thread_funneled, iprv, ierr)
  call mpi_comm_rank(mpi_comm_world, rank, ierr)
#else
  rank = 0
#endif

  ! Read command line arguments
  call command_arguments()

  ! Initialize random number generator
  if ( seed .ge. 0 ) then
    call rng(seed)
  else
    call rng()
  end if

  ! Analyze sensitivity to parameters
  allocate(Z(nx,ny,max_run))
  xaxis = linspace(xmin, xmax, nx)
  yaxis = linspace(ymin, ymax, ny)
  counter = 0

  if ( rank .eq. master ) then
    print *
    call tic()
    call progress_perc(0, nx*ny, " Processing: ")
  end if
  select case(solver)
  case("pso", "cpso")
    do i = 1, nx
      do j = 1, ny
        counter = counter + 1
        !$omp parallel default(shared) private(popsize, bf, ea)
        !$omp do schedule(runtime)
        do n_run = 1, max_run
          if ( xaxis_name .eq. "c" .and. yaxis_name .eq. "w" ) then
            popsize = n_dim * popfactor
            bf = BenchmarkFunction(func, n_dim)
            ea = Evolutionary(bf % func, bf % lower, bf % upper, &
                              popsize = popsize, max_iter = max_iter, &
                              constrain = .false., snap = .false., verbose = verbose)
            call ea % optimize(solver = solver, w = yaxis(j), c1 = xaxis(i), &
                               c2 = xaxis(i), gamma = gamma)
          else if ( xaxis_name .eq. "c" .and. yaxis_name .eq. "n_dim" ) then
            popsize = yaxis(j) * popfactor
            bf = BenchmarkFunction(func, int(yaxis(j)))
            ea = Evolutionary(bf % func, bf % lower, bf % upper, &
                              popsize = popsize, max_iter = max_iter, &
                              constrain = .false., snap = .false., verbose = verbose)
            call ea % optimize(solver = solver, w = w, c1 = xaxis(i), &
                               c2 = xaxis(i), gamma = gamma)
          else if ( xaxis_name .eq. "w" .and. yaxis_name .eq. "n_dim" ) then
            popsize = yaxis(j) * popfactor
            bf = BenchmarkFunction(func, int(yaxis(j)))
            ea = Evolutionary(bf % func, bf % lower, bf % upper, &
                              popsize = popsize, max_iter = max_iter, &
                              constrain = .false., snap = .false., verbose = verbose)
            call ea % optimize(solver = solver, w = xaxis(i), c1 = c, &
                               c2 = c, gamma = gamma)
          end if
          Z(i,j,n_run) = ea % gfit
        end do
        !$omp end parallel
        if ( rank .eq. master ) call progress_perc(counter, nx*ny, " Processing: ")
      end do
    end do
  end select

  ! Save results
  if ( rank .eq. master ) then
    call system("mkdir -p output")
    call system("rm -f output/" // solver // "_" // func // "_" // num2str(n_dim) // "_Z.bin")
    call system("rm -f output/" // solver // "_" // func // "_" // num2str(n_dim) // "_xaxis.bin")
    call system("rm -f output/" // solver // "_" // func // "_" // num2str(n_dim) // "_yaxis.bin")
    call savebin("output/" // solver // "_" // func // "_" // num2str(n_dim) // "_Z.bin", Z)
    call savebin("output/" // solver // "_" // func // "_" // num2str(n_dim) // "_xaxis.bin", xaxis)
    call savebin("output/" // solver // "_" // func // "_" // num2str(n_dim) // "_yaxis.bin", yaxis)
  end if

  ! Display results
  if ( rank .eq. master ) then
    print *
    print *
    attributes = "function:"
    print *, adjustr(attributes) // " '" // trim(func) // "'"
    call ea % print()

    print *
    call toc()
    print *
  end if

#ifdef do_mpi
  call mpi_finalize(ierr)
#endif

contains

  subroutine command_arguments()
    integer(kind = IPRE) :: i, n_argin
    character(len = CLEN) :: argin
    character(len = :), allocatable :: argname, argval

    solver = "cpso"
    func = "sphere"
    n_dim = 2
    popfactor = 5
    w = 0.7298
    c = 1.49618
    gamma = 1.
    F = 0.5
    CR = 0.1
    sigma = 0.5
    mu_perc = 0.5
    max_iter = 200
    seed = -1
    xaxis_name = "c"
    xmin = 0.
    xmax = 3.
    nx = 10
    yaxis_name = "w"
    ymin = 0.
    ymax = 1.
    ny = 10
    max_run = 100
    verbose = 0

    n_argin = command_argument_count()
    do i = 1, n_argin
      call get_command_argument(i, argin)
      call split_argument(argin, argname, argval)

      select case(argname)
      ! Number of dimensions
      case("n_dim")
        read(argval, *) n_dim

      ! Solver
      case("solver")
        solver = argval

      ! Function
      case("func")
        func = argval

      ! Population size factor (popsize = popfactor * n_dim)
      case("popfactor")
        read(argval, *) popfactor

      ! Inertia weight
      case("w")
        read(argval, *) w

      ! Acceleration parameters
      case("c")
        read(argval, *) c

      ! Competitivity parameter
      case("gamma")
        read(argval, *) gamma

      ! Differential weight
      case("F")
        read(argval, *) F

      ! Crossover probability
      case("CR")
        read(argval, *) CR

      ! Step size
      case("sigma")
        read(argval, *) sigma

      ! Percentage of offsprings
      case("mu_perc")
        read(argval, *) mu_perc

      ! Maximum number of iterations
      case("max_iter")
        read(argval, *) max_iter

      ! Random number seed
      case("seed")
        read(argval, *) seed

      ! X axis
      case("xaxis")
        xaxis_name = argval

      ! X min
      case("xmin")
        read(argval, *) xmin

      ! X max
      case("xmax")
        read(argval, *) xmax

      ! NX
      case("nx")
        read(argval, *) nx

      ! Y axis
      case("yaxis")
        yaxis_name = argval

      ! Y min
      case("ymin")
        read(argval, *) ymin

      ! Y max
      case("ymax")
        read(argval, *) ymax

      ! NY
      case("ny")
        read(argval, *) ny

      ! Maximum number of iterations
      case("max_run")
        read(argval, *) max_run

      ! Verbosity
      case("verbose")
        read(argval, *) verbose

      case default
        print *, "Error: unknown argument '" // trim(argname) // "'"
        stop
      end select
    end do
    return
  end subroutine command_arguments

  subroutine select_axis(axis, axis_name)
    real(kind = RPRE), dimension(:), intent(inout) :: axis
    character(len = *), intent(in) :: axis_name

    return
  end subroutine select_axis

end program sensitivity


C
C $Id: wmgtso.f,v 1.8 2008-07-27 00:17:36 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE WMGTSO(X1,Y1,X2,Y2,NOUT,XIN,YIN,IFLG)
C
C  Returns the symbol outlines:
C
C  Returns points along the Bezier curve for a warm front symbol.
C  This is an arch beginning at (X2,Y2) and traversing to (X1,Y1).
C  NOUT must be greater than 2.
C
C  Returns points of a triangle for cold front symbols.
C
C  If IFLG has absolute value "1", then warm front symbols are
C  returned; if IFLG has absolute value "2", then cold front symbols
C  are returned.  The algebraic sign of IFLG determines which side
C  the symbol points to (the two possibilities are mirror-imaged
C  about the line connecting the points (X1,Y1) and (X2,Y2).
C
      PARAMETER (NDIM=7)
C
      include 'wmcomn.h'
C
      DIMENSION XIN(NOUT),YIN(NOUT)
      DIMENSION WSBZCX(NDIM),WSBZCY(NDIM)
      DIMENSION WSXTMP(NDIM),WSYTMP(NDIM),WXTRAN(NDIM),WYTRAN(NDIM)
C
C  X and Y Bezier control points for the warm front symbol.
C
      DATA WSBZCX/ 1.00000,  0.94737,  0.36842,  0.00000,
     +            -0.36842, -0.94737, -1.00000           /
      DATA WSBZCY/ 0.00000, -1.05263, -1.42100, -1.42100,
     +            -1.42100, -1.05263,  0.00000           /
C
C  Scale the control points, and flip depending of the direction
C  the symbols are to be drawn in.
C
      D  = SQRT((Y2-Y1)**2+(X2-X1)**2)
      SS = 0.5*D
      DO 10 I=1,NDIM
        WXTRAN(I) = SS*WSBZCX(I)
        WYTRAN(I) = SS*SIGN(1,IFLG)*WSBZCY(I)
   10 CONTINUE
C
C  Make the cold front symbols a little larger.
C
      IF (ABS(IFLG) .EQ. 1) THEN
        WYTRAN(4) = 1.1*WYTRAN(4)
      ENDIF
C
C  Rotate the control points.
C
      COSANG = (X2-X1)/D
      SINANG = (Y2-Y1)/D
      DO 20 I=1,NDIM
        WSXTMP(I) = WXTRAN(I)*COSANG-WYTRAN(I)*SINANG
        WSYTMP(I) = WXTRAN(I)*SINANG+WYTRAN(I)*COSANG
   20 CONTINUE
      DO 30 I=1,NDIM
        WXTRAN(I) = WSXTMP(I)
        WYTRAN(I) = WSYTMP(I)
   30 CONTINUE
C
C  Translate the control points.
C
      XM = 0.5*(X1+X2)
      YM = 0.5*(Y1+Y2)
      DO 40 I=1,NDIM
        WXTRAN(I) = XM+WXTRAN(I)
        WYTRAN(I) = YM+WYTRAN(I)
   40 CONTINUE
C
      IF (ABS(IFLG).EQ.1 .OR. ABS(IFLG).EQ.3) THEN
C
C  Return cold front symbol.
C
        XIN(1) =  WXTRAN(1)
        YIN(1) =  WYTRAN(1)
        XIN(2) =  WXTRAN(4)
        YIN(2) =  WYTRAN(4)
        XIN(3) =  WXTRAN(7)
        YIN(3) =  WYTRAN(7)
      ELSE
C
C  Calculate the points along the Bezier curve for a warm front symbol.
C
        NHALF = NOUT/2
        CALL BCFCRV(WXTRAN(1),WYTRAN(1),NHALF+1,XIN(1),YIN(1))
        IF (MOD(NOUT,2) .EQ. 0) THEN
          CALL BCFCRV(WXTRAN(4),WYTRAN(4),NHALF,
     +                XIN(NHALF+1),YIN(NHALF+1))
        ELSE
          CALL BCFCRV(WXTRAN(4),WYTRAN(4),NHALF+1,
     +                XIN(NHALF+1),YIN(NHALF+1))
        ENDIF
      ENDIF
C
      RETURN
      END


!     Generate nudging factors on a rotated elliptical-zone
!     Works for mixed tri/quad
!     Input: hgrid.gr3;  center @ the mouth; rx,ry,rat,rmax; rotating angle (angle made from
!            x-axis of hgrid.gr3 to the x-axis in which the elliptical-zone is defined)
!     Output: nudge.gr3 ([s,t,uv,elev]_nudge.gr3)
!     Don't forget to zero out estuary and river values.
!     ifort -Bstatic -O3 -o gen_nudge gen_nudge.f90
!     pgf90 -O2 -mcmodel=medium -o gen_nudge gen_nudge.f90

      implicit real*8(a-h,o-z)
      parameter(pi=3.1415926d0)
      dimension nm(4)

!     Center
      x0=198450.16
      y0=2766178.50

!     Minor and major axes
      rx=663e3 !584e3
      ry=400e3
      rat=1.2 !(outer rx)/(inner rx); same for ry; must be >1
      !max. relax. const. (T90=0.5 days); dimension is sec^-1. Final relax. is this times dt
      rmax=-log(0.1)/(86400*0.5)
      !angle made from x-axis of hgrid.gr3 to the x-axis in which the elliptical-zone is defined
      angle=-45./180*pi

      print*, 'max relax=',rmax
      open(14,file='hgrid.gr3',status='old')
      open(13,file='nudge.gr3')
      read(14,*)
      read(14,*)ne,np
      write(13,*)
      write(13,*)ne,np
      do i=1,np
        read(14,*)j,x,y,h
        !Compute new coordinates in rotated frame
        x0_new=x0*cos(angle)+y0*sin(angle)
        y0_new=y0*cos(angle)-x0*sin(angle)
        xnew=x*cos(angle)+y*sin(angle)
        ynew=y*cos(angle)-x*sin(angle)
        rr=(xnew-x0_new)**2/rx/rx+(ynew-y0_new)**2/ry/ry
        tnu=rmax*(rr-1)/(rat*rat-1)
        tnu=dmax1(0.d0,dmin1(rmax,tnu))
        write(13,'(i10,2(1x,e24.10),1x,e14.6)')i,x,y,tnu
      enddo !i

      do i=1,ne
        read(14,*)j,k,(nm(l),l=1,k)
        write(13,*)j,k,(nm(l),l=1,k)
      enddo !i

      stop
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      double precision function transitdur(nfit,sol,np)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none
      integer nfit,col,np
      double precision sol(nfit),Pi,Msun,Rsun,G,aConst,b,Psec,adrs,
     .  cincl,temp(4),tpi,rdr,bb

      Pi=acos(-1.d0)   !Pi
      tpi=2.0d0*pi
      Msun=1.9891d30 !kg  mass of Sun
      Rsun=696265.0d0*1000.0d0 !m  radius of Sun
      G=6.674d-11 !N m^2 kg^-2  Gravitation constant
      aConst=(G/(4.0*Pi*Pi))**(1.0d0/3.0d0)

      col=8+(np-1)*10
      bb=sol(col+3)
      b=sqrt(bb)
      Psec=sol(col+2)*8.64d4 !sec ; period of planet
      adrs=1000.0*sol(1)*G*(Psec)**2/(3.0d0*Pi)
      adrs=adrs**(1.0d0/3.0d0) !a/R*
      cincl=b/adrs !cos(i)
      rdr=sol(col+4)

      temp(1)=Psec/Pi
      temp(2)=1.0d0/adrs
      temp(3)=(1+rdr)**2.0-bb
      temp(4)=1-cincl*cincl
C     Transit duration in sec
      transitdur=temp(1)*asin(temp(2)*sqrt(temp(3)/temp(4)))!/3600.0

      return
      end


module TestModule

    type :: dot
        integer :: x, y, z
    end type dot

    type :: cut
        type(dot) :: a, b
    end type cut

    real(8) :: PI = 3.1415926

contains

    function length(a)
        real(8) :: length
        type(cut) :: a
        length = sqrt((a%a%x-a%b%x)**2 + (a%a%y-a%A%Y)**2 + (a%A%z-A%b%z)**2)
    end function length

end module


      SUBROUTINE qrsolv(n, r, ldr, ipvt, diag, qtb, x, sdiag, wa)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: n, ldr
      INTEGER, DIMENSION(n), INTENT(in) :: ipvt
      REAL(rprec), DIMENSION(ldr,n), INTENT(inout) :: r
      REAL(rprec), DIMENSION(n) :: diag, qtb, x, sdiag, wa
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, zero = 0
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: j, jp1, k, kp1, l, nsing, l1
      REAL(rprec) :: COS, cotan, qtbpj, SIN, SUM0, TAN, temp
      REAL(rprec) , ALLOCATABLE :: temp1u(:)
C-----------------------------------------------
c
c     SUBROUTINE qrsolv
c
c     given an m by n matrix a, an n by n diagonal matrix d,
c     and an m-vector b, the problem is to determine an x which
c     solves the system
c
c           a*x = b ,     d*x = 0 ,
c
c     in the least squares sense.
c
c     this SUBROUTINE completes the solution of the problem
c     IF it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, IF
c     a*p = q*r, WHERE p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, THEN qrsolv EXPects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q TRANSPOSE)*b. the system
c     a*x = b, d*x = 0, is THEN equivalent to
c
c                  t       t
c           r*z = q *b ,  p *d*p*z = 0 ,
c
c     where x = p*z. If this system does not have full rank,
c     then a least squares solution is obtained. on output qrsolv
c     also provides an upper triangular matrix s such that
c
c            t   t               t
c           p *(a *a + d*d)*p = s *s .
c
c     s is computed within qrsolv and may be of separate interest.
c
c     the SUBROUTINE statement is
c
c       SUBROUTINE qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
c
c     WHERE
c
c       n is a positive INTEGER input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle CONTAINS the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive INTEGER input variable not less than n
c         which specifies the leading DIMENSION of the array r.
c
c       ipvt is an INTEGER input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q TRANSPOSE)*b.
c
c       x is an output array of length n which CONTAINS the least
c         squares solution of the system a*x = b, d*x = 0.
c
c       sdiag is an output array of length n which CONTAINS the
c         diagonal elements of the upper triangular matrix s.
c
c       wa is a work array of length n.
c
c     subprograms called
c
c       fortran-supplied ... ABS,sqrt
c
c     argonne national laboratory. MINpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
c
c     copy r and (q TRANSPOSE)*b to preserve input and initialize s.
c     in particular, SAVE the diagonal elements of r in x.
c
      DO j = 1, n
         r(j:n,j) = r(j,j:n)
         x(j) = r(j,j)
      END DO
      wa(1:n) = qtb(1:n)
c
c     eliminate the diagonal matrix d using a givens rotation.
c
      DO j = 1, n
c
c        prepare the row of d to be eliminated, locating the
c        diagonal element using p from the qr factorization.
c
         l = ipvt(j)
         IF (diag(l) .ne. zero) THEN
            sdiag(j+1:n) = zero
            sdiag(j) = diag(l)
c
c        the transformations to eliminate the row of d
c        modify ONLY a single element of (q TRANSPOSE)*b
c        beyond the first n, which is initially zero.
c
            qtbpj = zero
            DO k = j, n
c
c           determine a givens rotation which eliminates the
c           appropriate element in the current row of d.
c
               IF (sdiag(k) .ne. zero) THEN
                  IF (ABS(r(k,k)) .lt. ABS(sdiag(k))) THEN
                     coTAN = r(k,k)/sdiag(k)
                     SIN = one/SQRT(one + cotan*cotan)
                     COS = SIN*cotan
                  ELSE
                     TAN = sdiag(k)/r(k,k)
                     COS = one/SQRT(one + TAN*tan)
                     SIN = COS*tan
                  END IF
c
c           compute the modified diagonal element of r and
c           the modified element of ((q TRANSPOSE)*b,0).
c
                  r(k,k) = COS*r(k,k) + SIN*sdiag(k)
                  temp = COS*wa(k) + SIN*qtbpj
                  qtbpj = (-sin*wa(k)) + COS*qtbpj
                  wa(k) = temp
c
c           accumulate the tranformation in the row of s.
c
                  kp1 = k + 1
                  IF (n .ge. kp1) THEN
                     l1 = n-kp1+1
                     ALLOCATE (temp1u(l1))
                     temp1u(:l1) = COS*r(kp1:n,k) + SIN*sdiag(kp1:n)
                     sdiag(kp1:n) = (-sin*r(kp1:n,k)) + COS*sdiag(kp1:n)
                     r(kp1:n,k) = temp1u(:l1)
                     DEALLOCATE (temp1u)
                  END IF
               END IF
            END DO
         END IF
c
c        store the diagonal element of s and restore
c        the corresponding diagonal element of r.
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
      END DO
c
c     solve the triangular system for z. IF the system is
c     singular, then obtain a least squares solution.
c
      nsing = n
      DO j = 1, n
         IF (sdiag(j).eq.zero .and. nsing.eq.n) nsing = j - 1
         IF (nsing .lt. n) wa(j) = zero
      END DO
      IF (nsing .ge. 1) THEN
         DO k = 1, nsing
            j = nsing - k + 1
            jp1 = j + 1
            IF (nsing .lt. jp1) THEN
               SUM0 = zero
            ELSE
               SUM0 = SUM(r(jp1:nsing,j)*wa(jp1:nsing))
            END IF
            wa(j) = (wa(j)-sum0)/sdiag(j)
         END DO
      END IF
c
c     permute the components of z back to components of x.
c
      DO j = 1, n
         l = ipvt(j)
         x(l) = wa(j)
      END DO

      END SUBROUTINE qrsolv